ajhc 0.8.0.4 → 0.8.0.5
raw patch · 42 files changed
+2383/−1869 lines, 42 filesdep +HTTPdep +ajhcdep +networksetup-changednew-component:exe:jahm
Dependencies added: HTTP, ajhc, network
Files
- Makefile.cabalinst +2/−0
- README.md +10/−9
- Setup.hs +35/−4
- ajhc.cabal +124/−65
- drift_processed/C/FromGrin2.hs +11/−9
- drift_processed/DataConstructors.hs +8/−8
- drift_processed/E/SSimplify.hs +1/−1
- drift_processed/E/ToHs.hs +0/−493
- drift_processed/Ho/Type.hs +26/−27
- drift_processed/Options.hs +1/−1
- lib/jhc/Jhc/Type/Ptr.hs +1/−1
- library_deps.make +1/−1
- src/E/Arbitrary.hs +6/−5
- src/E/Main.hs +1/−1
- src/E/SStrictness.hs +0/−280
- src/E/TypeAnalysis.hs +1/−1
- src/FrontEnd/Tc/Unify.hs +1/−1
- src/GenUtil.hs +1/−5
- src/Grin/Arity.hs +0/−45
- src/Grin/Embed.hs +0/−130
- src/Grin/FromE.hs +1/−1
- src/Grin/Grin.hs +4/−2
- src/Grin/Interpret.hs +0/−187
- src/Grin/Unboxing.hs +0/−115
- src/Ho/ReadSource.hs +1/−2
- src/Main.hs +0/−116
- src/RawFiles.hs +436/−80
- src/Support/ShowTable.hs +0/−24
- src/Util/BooleanSolver.hs +0/−246
- src/Util/SHA1.hs +3/−3
- src/Version/Config.hs +1/−1
- src/data/targets.ini +1/−1
- src_jahm/Distribution/Client/HttpUtils.hs +114/−0
- src_jahm/Distribution/Compat/CopyFile.hs +83/−0
- src_jahm/Distribution/Compat/Exception.hs +26/−0
- src_jahm/Distribution/Compat/TempFile.hs +126/−0
- src_jahm/Distribution/Simple/Utils.hs +1055/−0
- src_jahm/Distribution/Text.hs +43/−0
- src_jahm/Distribution/Verbosity.hs +102/−0
- src_jahm/Main.hs +37/−0
- src_main/Main.hs +116/−0
- utils/build_extlibs.prl +4/−4
Makefile.cabalinst view
@@ -3,6 +3,8 @@ LIB_OPTIONS=$(RTSOPTS) $(JHC_TEST) -L- -L. include library_deps.make +build: $(JHC_LIBS) $(JHC_EXT_LIBS)+ ## Note: Should write like below style for Windows + msys env. ## install FILES "DESTDIR" install: $(JHC_LIBS) $(JHC_EXT_LIBS)
README.md view
@@ -1,9 +1,9 @@ # [Ajhc](http://ajhc.github.com/) - arafura-jhc [](https://travis-ci.org/ajhc/ajhc) A fork of [jhc](http://repetae.net/computer/jhc/).-And also Haskell compiler. +And also a Haskell compiler. -This project is founded by [Metasepi Project](http://metasepi.masterq.net/).+This project is founded by [Metasepi Project](http://metasepi.org/). ## How to install @@ -19,7 +19,8 @@ $ git checkout arafura $ autoreconf -i $ ./configure- $ make cabal-install+ $ make+ $ make install ## For developing @@ -39,7 +40,7 @@ The command [darcs send](http://darcs.net/Using/Send) sends email the patch to jhc author (= [John Meacham](http://repetae.net/)). -## Needing to install/build on Windows (currently in progress)+## Needing to install/build on Windows (experimental) ### Install msys @@ -77,22 +78,22 @@ * Try to rewrite a part of NetBSD bootloader. http://www.youtube.com/watch?v=JMyxy5Qo2m8 * Translate Jhc User’s Manual to Japanese.- http://metasepi.masterq.net/posts/2013-01-12-jhc_manual_ja.html+ http://metasepi.org/posts/2013-01-12-jhc_manual_ja.html * Fix bug that run stm32f3-discovery demo. It causes Ajhc RTS heep impl. https://github.com/ajhc/demo-cortex-m3/tree/master/stm32f3-discovery * Support to build on Windows. * Cabalize Ajhc. Ajhc's hl files will be not controled with cabal.+* Support LPCXpresso NXP LPX1769 with demo.+* Pass all regress test, and enable regress fail setting on travis-ci.+ https://travis-ci.org/ajhc/ajhc ### Yet * No more depend on DrIFT. Use http://hackage.haskell.org/package/derive. * No more depend on Perl (LWP and YAML).-* Support LPCXpresso NXP LPX1769 with demo. * Rewrite Cortex-M3 base library with Ajhc.-* Pass all regress test, and enable regress fail setting on travis-ci.- https://travis-ci.org/ajhc/ajhc * Analyze jhc internal (Japanese doc).- http://metasepi.masterq.net/posts/2013-01-31-jhc_internal_overview.html+ http://metasepi.org/posts/2013-01-31-jhc_internal_overview.html * Find critical region of Ajhc for reentrant and thread safe. * Port Haskell libraries on haskell-platform to Ajhc. * Understand jhc's region inference.
Setup.hs view
@@ -10,20 +10,47 @@ make verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "make" +pName :: String+pName = "ajhc"+ #ifdef mingw32_HOST_OS (<//>) = (Px.</>)-jhcCmd local = Px.joinPath $ splitDirectories $- buildDir local <//> pName <//> pName+jhcCmd local = Px.joinPath $ splitDirectories $+ buildDir local <//> pName <//> pName+jahmCmd local = Px.joinPath $ splitDirectories $+ buildDir local <//> "jahm" <//> "jahm" #else-jhcCmd local = buildDir local </> pName </> pName+jhcCmd local = buildDir local </> pName </> pName+jahmCmd local = buildDir local </> "jahm" </> "jahm" #endif- where pName = "ajhc" +buildStdLib pkg local verbosity copy+ = do let dirs = L.absoluteInstallDirs pkg local copy+ idir = datadir dirs+ bdir = bindir dirs+ icmd = jhcCmd local+ jcmd = jahmCmd local+#ifdef mingw32_HOST_OS+ exeExt = ".exe"+#else+ exeExt = ""+#endif+ putStrLn $ "Installing libraries in " ++ idir+ make verbosity+ [ "-f", "Makefile.cabalinst", "build"+ , "TARGET=" ++ idir+ , "JHCPROG=" ++ icmd+ , "JAHMPROG=" ++ jcmd+ , "BINDIR=" ++ bdir+ , "EXEEXT=" ++ exeExt+ ]+ installStdLib pkg local verbosity copy = do let dirs = L.absoluteInstallDirs pkg local copy idir = datadir dirs bdir = bindir dirs icmd = jhcCmd local+ jcmd = jahmCmd local #ifdef mingw32_HOST_OS exeExt = ".exe" #else@@ -34,12 +61,16 @@ [ "-f", "Makefile.cabalinst", "install" , "TARGET=" ++ idir , "JHCPROG=" ++ icmd+ , "JAHMPROG=" ++ jcmd , "BINDIR=" ++ bdir , "EXEEXT=" ++ exeExt ] main :: IO () main = defaultMainWithHooks $ simpleUserHooks {+ postBuild = \ _ flags pkg lbi -> do+ let verb = (S.fromFlag $ S.buildVerbosity flags)+ buildStdLib pkg lbi verb NoCopyDest , postInst = \ _ flags pkg lbi -> do let verb = (S.fromFlag $ S.installVerbosity flags) installStdLib pkg lbi verb NoCopyDest
ajhc.cabal view
@@ -1,7 +1,7 @@-cabal-version: >= 1.6+cabal-version: >= 1.10 name: ajhc build-type: Custom-version: 0.8.0.4+version: 0.8.0.5 license: GPL-2 license-file: COPYING category: Compiler@@ -16,7 +16,7 @@ system, but rather generates what is needed as part of the compilation process. However, back ends do have specific run-time representations of data, which can be affected by things like the choice of garbage collector.-homepage: http://ajhc.masterq.net/+homepage: http://ajhc.metasepi.org/ data-files: README.md @@ -30,9 +30,9 @@ type: git location: https://github.com/ajhc/ajhc.git -executable ajhc- main-is: Main.hs+library hs-source-dirs: drift_processed src+ default-language: Haskell98 c-sources: src/StringTable/StringTable_cbits.c@@ -69,24 +69,71 @@ else build-depends: unix - other-modules:+ exposed-modules: C.FFI C.FromGrin2- C.Generate C.Prims Cmm.Number+ DataConstructors+ Doc.DocLike+ Doc.Pretty+ E.Main+ E.Program+ E.Rules+ E.Type+ FlagDump+ FrontEnd.Class+ FrontEnd.Exports+ FrontEnd.HsSyn+ FrontEnd.Infix+ FrontEnd.KindInfer+ FrontEnd.Rename+ FrontEnd.Representation+ FrontEnd.SrcLoc+ FrontEnd.Tc.Kind+ FrontEnd.Tc.Module+ FrontEnd.Tc.Type+ FrontEnd.TypeSynonyms+ FrontEnd.Warning+ Grin.FromE+ Grin.Grin+ Grin.Main+ Grin.Show+ Ho.Build+ Ho.Collected+ Ho.Library+ Ho.Type+ Info.Info+ Info.Types+ Interactive+ Name.Id+ Name.Name+ Options+ PackedString+ Stats+ StringTable.Atom+ Support.CFF+ Support.TempDir+ Util.BitSet+ Util.GMap+ Util.Gen+ Util.HasSize+ Util.Perhaps+ Util.SHA1+ Util.SetLike+ Version.Version++ other-modules:+ C.Generate Cmm.Op Cmm.OpEval- DataConstructors DerivingDrift.DataP DerivingDrift.Drift DerivingDrift.RuleUtils DerivingDrift.StandardRules Doc.Attr Doc.Chars- Doc.DocLike Doc.PPrint- Doc.Pretty E.Annotate E.Arbitrary E.Binary@@ -102,18 +149,12 @@ E.LambdaLift E.LetFloat E.Lint- E.Main E.PrimDecode E.PrimOpt- E.Program- E.Rules E.SSimplify- E.SStrictness E.Show E.Subst- E.ToHs E.Traverse- E.Type E.TypeAnalysis E.TypeCheck E.Values@@ -122,88 +163,51 @@ Fixer.Fixer Fixer.Supply Fixer.VMap- FlagDump FlagOpts- FrontEnd.Class FrontEnd.DataConsAssump FrontEnd.DeclsDepends FrontEnd.DependAnalysis FrontEnd.Desugar FrontEnd.Diagnostic- FrontEnd.Exports FrontEnd.FrontEnd FrontEnd.HsErrors FrontEnd.HsParser FrontEnd.HsPretty- FrontEnd.HsSyn- FrontEnd.Infix- FrontEnd.KindInfer FrontEnd.Lexer FrontEnd.ParseMonad FrontEnd.ParseUtils- FrontEnd.Rename- FrontEnd.Representation- FrontEnd.SrcLoc FrontEnd.Syn.Options FrontEnd.Syn.Traverse FrontEnd.Tc.Class- FrontEnd.Tc.Kind FrontEnd.Tc.Main- FrontEnd.Tc.Module FrontEnd.Tc.Monad- FrontEnd.Tc.Type FrontEnd.Tc.Unify FrontEnd.TypeSigs- FrontEnd.TypeSynonyms FrontEnd.TypeSyns FrontEnd.Unlit FrontEnd.Utils- FrontEnd.Warning GenUtil- Grin.Arity Grin.DeadCode Grin.Devolve- Grin.Embed Grin.EvalInline- Grin.FromE- Grin.Grin Grin.HashConst- Grin.Interpret Grin.Lint- Grin.Main Grin.NodeAnalyze Grin.Noodle Grin.Optimize Grin.SSimplify- Grin.Show Grin.StorageAnalysis- Grin.Unboxing Grin.Val Grin.Whiz Ho.Binary- Ho.Build- Ho.Collected- Ho.Library Ho.ReadSource- Ho.Type Info.Binary- Info.Info Info.Properties- Info.Types- Interactive- Main Name.Binary- Name.Id- Name.Name Name.Names Name.Prim Name.VConsts- Options- PackedString RawFiles- Stats- StringTable.Atom- Support.CFF Support.Cabal Support.CanType Support.Compat@@ -212,37 +216,27 @@ Support.IniParse Support.MD5 Support.MapBinaryInstance- Support.ShowTable- Support.TempDir Support.Tickle Support.Transform Support.Tuple Support.Unparse- Util.BitSet- Util.BooleanSolver Util.ContextMonad Util.ExitCodes Util.FilterInput- Util.GMap- Util.Gen Util.Graph Util.Graphviz- Util.HasSize Util.Histogram Util.Inst Util.IntBag Util.Interact Util.NameMonad Util.Once- Util.Perhaps Util.Progress Util.RWS Util.ReaderWriter Util.Relation- Util.SHA1 Util.SameShape Util.Seq- Util.SetLike Util.TrueSet Util.UnionFind Util.UnionSolve@@ -251,10 +245,9 @@ Util.VarName Util.YAML Version.Config- Version.Version Paths_ajhc - extensions:+ default-extensions: BangPatterns, TypeFamilies, ViewPatterns, UndecidableInstances, OverlappingInstances, RecordWildCards, RecursiveDo, TupleSections, ParallelListComp, GeneralizedNewtypeDeriving, ScopedTypeVariables,@@ -267,6 +260,72 @@ PolymorphicComponents, ExistentialQuantification, UnicodeSyntax, PostfixOperators, PatternGuards, LiberalTypeSynonyms, RankNTypes, TypeOperators, EmptyDataDecls, KindSignatures+ ghc-options: -W -fno-warn-unused-matches -fwarn-type-defaults -i./drift_processed -i./src cc-options: -std=c99 cpp-options: -DUSE_HASKELINE -DWITH_CABAL++executable ajhc+ main-is: Main.hs+ hs-source-dirs: src_main+ default-language: Haskell98++ build-depends:+ base >= 4.0 && < 5,+ HsSyck,+ array,+ binary,+ bytestring,+ containers,+ directory,+ fgl,+ filepath,+ haskeline,+ mtl,+ old-time,+ pretty,+ process,+ random,+ regex-compat,+ syb,+ temporary,+ utf8-string,+ zlib,+ ajhc++ if os(windows)+ build-depends: Win32+ else+ build-depends: unix++ ghc-options: -W -fno-warn-unused-matches -fwarn-type-defaults+ cc-options: -std=c99+ cpp-options: -DUSE_HASKELINE -DWITH_CABAL++executable jahm+ main-is: Main.hs+ hs-source-dirs: src_jahm+ default-language: Haskell98++ build-depends:+ base >= 4.0 && < 5,+ HTTP,+ bytestring,+ filepath,+ network,+ pretty,+ process,+ directory++ if !os(windows)+ build-depends:+ unix++ other-modules:+ Distribution.Client.HttpUtils+ Distribution.Compat.CopyFile+ Distribution.Compat.Exception+ Distribution.Compat.TempFile+ Distribution.Simple.Utils+ Distribution.Text+ Distribution.Verbosity
drift_processed/C/FromGrin2.hs view
@@ -157,7 +157,7 @@ include fn = text "#include <" <> text fn <> text ">" (header,body) = generateC (function (name "jhc_hs_init") voidType [] [Public] icaches:Map.elems fm) (Map.elems sm) icaches :: Statement- icaches | fopts FO.Jgc = mconcat [ toStatement $ functionCall (name "find_cache") [reference (toExpression $ nodeCacheName t),toExpression $ name "arena", tbsize (sizeof (structType $ nodeStructName t)), toExpression nptrs] | (t,nptrs) <- Set.toList wAllocs ]+ icaches | fopts FO.Jgc = mconcat [ toStatement $ functionCall (name "find_cache") [reference (toExpression $ nodeCacheName t),toExpression $ name "saved_arena", tbsize (sizeof (structType $ nodeStructName t)), toExpression nptrs] | (t,nptrs) <- Set.toList wAllocs ] | otherwise = mempty cafnames = [ text "&_" <> tshow (varName v) | (v,_) <- grinCafs grin ] constnames = map (\n -> text "&_c" <> tshow n) [ 1 .. length $ Grin.HashConst.toList finalHcHash]@@ -213,7 +213,7 @@ fr2 = basicType' retTy return [function fnname2 fr2 as2 [Public]- (creturn $ cast fr2 $ functionCall fnname $ (if fopts FO.Jgc then (variable (name "saved_gc"):) else id) $+ (creturn $ cast fr2 $ functionCall fnname $ (if fopts FO.Jgc then ([variable (name "saved_gc"), variable (name "saved_arena")] ++) else id) $ zipWith cast (map snd as') (map variable newVars))] @@ -562,8 +562,8 @@ isCompound Prim {} = False isCompound _ = True -mgc = if fopts FO.Jgc then (v_gc:) else id-mgct = if fopts FO.Jgc then ((name "gc",gc_t):) else id+mgc = if fopts FO.Jgc then ([v_gc, v_arena] ++) else id+mgct = if fopts FO.Jgc then ([(name "gc",gc_t), (name "arena",arena_t)] ++) else id convertExp :: Exp -> C (Statement,Expression) convertExp (Prim Func { primArgTypes = as, primRetType = r, primRetArgs = rs@(_:_), ..} vs ty) = do@@ -814,7 +814,7 @@ Nothing -> do st <- nodeType t as' <- mapM convertVal as- let wmalloc | fopts FO.Jgc = \_ -> functionCall (name "s_alloc") [toExpression $ name "gc", (toExpression $ nodeCacheName t)]+ let wmalloc | fopts FO.Jgc = \_ -> functionCall (name "s_alloc") [toExpression $ name "gc", toExpression $ name "arena", (toExpression $ nodeCacheName t)] | otherwise = jhc_malloc (reference (toExpression $ nodeCacheName t)) nptrs' nptrs = length (filter (not . nonPtr . getType) as) + if sf then 1 else 0 nptrs' = if nptrs > 0 && not sf && t `Map.notMember` cpr then nptrs + 1 else nptrs@@ -931,15 +931,15 @@ --gc_end = functionCall (name "gc_end") [] tbsize sz = functionCall (name "TO_BLOCKS") [sz] -jhc_malloc_atomic sz | fopts FO.Jgc = functionCall (name "gc_array_alloc_atomic") [v_gc,nullPtr, sz, toExpression (0::Int)]+jhc_malloc_atomic sz | fopts FO.Jgc = functionCall (name "gc_array_alloc_atomic") [v_gc, v_arena, nullPtr, sz, toExpression (0::Int)] | otherwise = jhc_malloc nullPtr (0::Int) (sizeof sptr_t *# sz) -jhc_malloc ntn nptrs sz | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc,ntn, tbsize sz, toExpression nptrs]--- | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc,tbsize sz, toExpression nptrs]+jhc_malloc ntn nptrs sz | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc, v_arena, ntn, tbsize sz, toExpression nptrs]+-- | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc, v_arena, tbsize sz, toExpression nptrs] jhc_malloc _ 0 sz = functionCall (name "jhc_malloc_atomic") [sz] jhc_malloc _ _ sz = functionCall (name "jhc_malloc") [sz] -jhc_malloc_ptrs sz | fopts FO.Jgc = functionCall (name "gc_array_alloc") [v_gc, sz]+jhc_malloc_ptrs sz | fopts FO.Jgc = functionCall (name "gc_array_alloc") [v_gc, v_arena, sz] jhc_malloc_ptrs sz = functionCall (name "jhc_malloc") [sizeof sptr_t *# sz] f_assert e = functionCall (name "assert") [e]@@ -979,8 +979,10 @@ fptr_t = basicGCType "fptr_t" wptr_t = basicGCType "wptr_t" gc_t = basicGCType "gc_t"+arena_t = basicGCType "arena_t" v_gc = variable (name "gc") v_saved_gc = variable (name "saved_gc")+v_arena = variable (name "arena") a_STD = Attribute "A_STD" a_FALIGNED = Attribute "A_FALIGNED"
drift_processed/DataConstructors.hs view
@@ -289,13 +289,13 @@ sortName :: ESort -> Name sortName s = f s where- f EStar = s_Star -- ^ the sort of boxed lazy types- f EBang = s_Bang -- ^ the sort of boxed strict types- f EHash = s_Hash -- ^ the sort of unboxed types- f ETuple = s_Tuple -- ^ the sort of unboxed tuples- f EHashHash = s_HashHash -- ^ the supersort of unboxed types- f EStarStar = s_StarStar -- ^ the supersort of boxed types- f (ESortNamed n) = n -- ^ user defined sorts+ f EStar = s_Star -- the sort of boxed lazy types+ f EBang = s_Bang -- the sort of boxed strict types+ f EHash = s_Hash -- the sort of unboxed types+ f ETuple = s_Tuple -- the sort of unboxed tuples+ f EHashHash = s_HashHash -- the supersort of unboxed types+ f EStarStar = s_StarStar -- the supersort of boxed types+ f (ESortNamed n) = n -- user defined sorts sortConstructor name ss = emptyConstructor { conName = name,@@ -781,7 +781,7 @@ sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ] slotTypes wdt n kind | sortKindLike kind, (e,ts) <- fromPi kind = take (length (conSlots mc) - length ts) (conSlots mc)- -- | sortKindLike kind, (e,ts) <- fromPi kind = (conSlots mc)+ ---- | sortKindLike kind, (e,ts) <- fromPi kind = (conSlots mc) where Identity mc = getConstructor n wdt slotTypes wdt n e | Just fa <- followAlias wdt e = slotTypes wdt n fa slotTypes _ n e = error $ "slotTypes: error in " ++ show n ++ ": " ++ show e
drift_processed/E/SSimplify.hs view
@@ -977,7 +977,7 @@ noSizeIncrease e xs = f e xs where currentSize = 1 + length xs f (ELam t e) (x:xs) = f e xs- f ELam {} [] = False -- ^ abort if we will create a lambda+ f ELam {} [] = False -- abort if we will create a lambda f e [] = isJust $ exprSize currentSize e 3 [] f e xs = isJust $ exprSize (currentSize - length xs) e 3 []
− drift_processed/E/ToHs.hs
@@ -1,493 +0,0 @@-{- Generated by DrIFT (Automatic class derivations for Haskell) -}-{-# LINE 1 "src/E/ToHs.hs" #-}-module E.ToHs(compileToHs) where--import Char-import Control.Monad-import Control.Monad.Identity-import Control.Monad.RWS-import Control.Monad.Trans-import Control.Monad.Writer-import Data.Monoid-import System.IO-import Text.PrettyPrint.HughesPJ(render,($$),nest,Doc())-import qualified Data.Set as Set-import qualified Data.Traversable as T-import qualified System--import C.Arch-import C.Prims-import DataConstructors-import Doc.DocLike-import Doc.PPrint-import E.E-import E.FreeVars-import E.Program-import E.Subst-import E.Traverse-import E.Values-import Name.Id-import Name.Name-import Name.Names-import Name.Prim-import Name.VConsts-import Numeric-import Options-import PackedString-import RawFiles(viaghc_hs)-import Support.CanType-import Support.FreeVars-import Util.Gen-import Util.SetLike-import qualified FlagDump as FD--progress str = wdump FD.Progress $ (putErrLn str) >> hFlush stderr--{-# NOINLINE compileToHs #-}-compileToHs :: Program -> IO ()-compileToHs prog = do- (v,_,Coll { collNames = ns, collPrims = prims }) <- runRWST (fromTM $ transE (programE prog)) emptyEnvironment 1-- let rv = render (text "theRealMain = " <> v)- let data_decls = render (transDataTable (progDataTable prog) ns) ++ "\n"- let foreign_decls = render (transForeign $ Set.toList prims) ++ "\n"- let fn = optOutName options- let cf = (fn ++ "_code.hs")- progress ("Writing " ++ show cf)- name <- System.getProgName- args <- getArguments- let argstring = simpleQuote (name:args)- comm = shellQuote $ ["ghc", "-O", cf, "-o", fn ]- writeFile cf $ unlines ["-- " ++ argstring,"-- " ++ comm,"",viaghc_hs,render restate,data_decls,rv,"",foreign_decls]- progress ("Running: " ++ comm)- r <- System.system comm- when (r /= System.ExitSuccess) $ fail "Hs code did not compile."- return ()--cTypeInfoT (ELit LitCons { litAliasFor = Just af }) = cTypeInfoT af-cTypeInfoT (ELit LitCons { litName = n }) | (RawType,t) <- fromName n = cTypeInfo t--cTypeInfo "wchar_t" = ("Char#","C#","Char")-cTypeInfo "HsChar" = ("Char#","C#","Char")-cTypeInfo "HsPtr" = ("Addr#","Ptr","(Ptr ())")-cTypeInfo "HsFunPtr" = ("Addr#","Ptr","(Ptr ())")-cTypeInfo n = (if primTypeIsSigned pi then "Int#" else "Word#",v,i) where- (v,i) = if primTypeIsSigned pi then ('I':nn ++ "#","Int" ++ nn) else ('W':nn ++ "#","Word" ++ nn)- nn = show $ primTypeSizeOf pi * 8- Just pi = primitiveInfo n--showCType n = fst3 $ cTypeInfo n--restate = vcat $ map f restated where- f (n,nn,v) = g (nameType n) <> text v <+> text "=" <+> showTCName nn n- g DataConstructor = empty- g TypeConstructor = text "type "- restated = [- (dc_Cons,0,"jhc_Cons"),- (dc_EmptyList,0,"jhc_EmptyList"),- (tc_List,1,"ListTCon")- ]--transForeign ps = vcat (map f ps) where- f (AddrOf s) = text $ "foreign import ccall \"&" ++ unpackPS s ++ "\" addr_" ++ mangleIdent (unpackPS s) ++ " :: Ptr ()"- f furc@Func { funcName = fn, funcIOLike = True, primArgTypes = as, primRetType = "void" } = ans <$> ans' where- ans = text $ "foreign import ccall unsafe \"" ++ unpackPS fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ intercalate " -> " (map (snd . snd) vals ++ ["IO ()"])- ans' = text $ cfuncname furc <+> "w" <+> unwords (fsts vals) <+> " = case _" ++ cfuncname furc <+> intercalate " " [ parens (c <+> a) | (a,(c,_)) <- vals ] <+> "of IO f -> case f w of (# w, _ #) -> w"- vals = [ ('a':show n,ioInfo a) | a <- as | n <- naturals ]- f furc@Func { funcName = fn, funcIOLike = True, primArgTypes = as, primRetType = rt' } = ans <$> ans' where- ans = text $ "foreign import ccall unsafe \"" ++ unpackPS fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ intercalate " -> " (map (snd . snd) vals ++ ["IO " ++ rt])- ans' = text $ cfuncname furc <+> "w" <+> unwords (fsts vals) <+> " = case _" ++ cfuncname furc <+> intercalate " " [ parens (c <+> a) | (a,(c,_)) <- vals ] <+> "of IO f -> case f w of (# w, " ++ rc ++ " r #) -> (# w, r #)"- vals = [ ('a':show n,ioInfo a) | a <- as | n <- naturals ]- (rc,rt) = ioInfo rt'- f furc@Func { funcName = fn, funcIOLike = False, primArgTypes = as, primRetType = rt' } = ans <$> ans' where- ans = text $ "foreign import ccall unsafe \"" ++ unpackPS fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ intercalate " -> " (map (snd . snd) vals ++ [rt])- ans' = text $ cfuncname furc <+> unwords (fsts vals) <+> " = case _" ++ cfuncname furc <+> intercalate " " [ parens (c <+> a) | (a,(c,_)) <- vals ] <+> "of " ++ rc ++ " r -> r"- vals = [ ('a':show n,ioInfo a) | a <- as | n <- naturals ]- (rc,rt) = ioInfo rt'--- f furc@Func { funcName = fn, funcIOLike = False, primArgTypes = as, primRetType = rt } = ans where--- ans = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ cfuncname furc ++ " :: " ++ intercalate " -> " (map showCType (as ++ [rt]))--- f furc@Func { funcName = fn, funcIOLike = True, primArgTypes = as, primRetType = rt } = ans where--- ans = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ cfuncname furc ++ " :: " ++ intercalate " -> " ("World__":(map showCType as ++ ["(# World__, " ++ showCType rt ++ " #)"]))- f n = text "{- Foreign.Error " <+> tshow n <+> text "-}"- ioInfo n = (x,y) where- (_,x,y) = cTypeInfo n--transDataTable dataTable ns = vcat (theType:map g (lefts wtd)) where- wtd = Set.toList (mconcatMap f (Set.toList ns))- f (n,_,_) | n `elem` builtIns = Set.empty- f (n,_,_) | Just _ <- fromUnboxedNameTuple n = Set.empty- f (n,_,_) | Just _ <- fromTupname n = Set.empty- f w@(n,nn,tl) = case (nameType n,tl) of- (DataConstructor,False) -> Set.fromList $ do- c <- getConstructor n dataTable- return (Left $ conInhabits c)- (TypeConstructor,True) -> Set.singleton (Left n)- (TypeConstructor,False) -> Set.singleton (Right (n,nn))- (RawType,_) -> Set.empty- (nt,_) -> error (show (w,nt))- theType = text "data Type = Char | Int" <+> case rights wtd of- [] -> empty- as -> text "|" <+> hcat (punctuate (text " | ") (map tt as))- tt (n,nn) = hsep (showTCName nn n:replicate nn (text "Type"))-- g n = ans where- ans = text "data" <+> hsep (showTCName (length $ conSlots con) n:[ text ('x':show i) | _ <- conSlots con | i <- [2::Int,4 ..] ]) <+> dchildren- Just con = getConstructor n dataTable- childs = conChildren con- dchildren | DataNormal [] <- childs = empty- | DataNormal childs <- childs = text "=" <+> hcat (punctuate (text " | ") (map dc childs))- | otherwise = empty- dc cn = ans where- ans = hsep (showCName cn: map showSlot (conSlots con))- Just con = getConstructor cn dataTable- showSlot (EVar v) = pprint v- showSlot (ELit LitCons { litArgs = es, litAliasFor = Just af }) = showSlot (foldl eAp af es)- showSlot (EPi TVr { tvrType = a } b) = parens $ showSlot a <+> text "->" <+> showSlot b- showSlot (ELit (LitCons { litName = c, litArgs = as })) = showCon c (map showSlot as)- --builtIns = [tc_Int,tc_Char,dc_Int,dc_Char,rt_int,rt_HsChar,tc_World__,tc_Array__,tc_MutArray__,tc_Ref__,rt_HsPtr]- builtIns = [tc_Int,tc_Char,dc_Int,dc_Char,tc_World__,tc_Array__,tc_MutArray__,tc_Ref__]--data Environment = Env {- envParen :: Bool,- envType :: Bool,- envCoerce :: IdSet- }--emptyEnvironment = Env {- envParen = False,- envType = False,- envCoerce = mempty- }--data Collect = Coll { collNames :: Set.Set (Name,Int,Bool), collPrims :: Set.Set Prim }- {-! derive: Monoid !-}--newtype TM a = TM { fromTM :: RWST Environment Collect Int IO a }- deriving(MonadState Int,MonadReader Environment,MonadWriter Collect,Monad,Functor,MonadIO)--mparen xs = do- Env { envParen = p } <- ask- x <- local (\e -> e { envParen = True }) xs- if p then return $ parens x else return x--nparen xs = do local (\e -> e { envParen = True }) xs--noParens x = local (\e -> e { envParen = False }) x--showCon c ts | Just 0 <- fromUnboxedNameTuple c, nameType c == TypeConstructor = text "Nothing"-showCon c ts | Just 0 <- fromUnboxedNameTuple c, nameType c == DataConstructor = text "theNothing"-showCon c ts | Just _ <- fromUnboxedNameTuple c = text "(# " <> hsep (punctuate comma ts) <> text " #)"-showCon c ts | Just _ <- fromTupname c = text "(" <> hsep (punctuate comma ts) <> text ")"-showCon c [] | c == tc_World__ = text "World__"-showCon c [a] | c == tc_Array__ = parens $ text "Array__" <+> a-showCon c [a] | c == tc_MutArray__ = parens $ text "MutArray__" <+> a-showCon c [a] | c == tc_Ref__ = parens $ text "Ref__" <+> a-showCon c [] | (RawType,v) <- fromName c = text $ showCType v-showCon c [] | c == tc_Int = text "Int"-showCon c [] | c == tc_Char = text "Char"-showCon c [] = showTCName 0 c-showCon c ts = parens $ hsep (showTCName (length ts) c:ts)--showTCName n c | nameType c == TypeConstructor = showCName c <> text "_" <> tshow n-showTCName _ c = showCName c--showCName c | c == dc_Char = text "C#"-showCName c | c == dc_Int = text "I#"-showCName c = text $ case nameType c of- DataConstructor -> 'D':mangleIdent (show c)- TypeConstructor -> 'T':mangleIdent (show c)- n -> 'U':mangleIdent (show n ++ "_" ++ show c)--transType :: E -> TM Doc-transType e | typeLike e = return $ text "Type"-transType (EPi TVr {tvrType = a } b) = local (\e -> e { envType = True }) $ mparen $ do- a <- transType a- b <- transType b- return $ a <+> text "->" <+> b-transType (ELit LitCons { litArgs = es, litAliasFor = Just af }) = transType (foldl eAp af es)-transType (ELit LitCons { litName = c, litArgs = ts }) = nparen $ do- Env { envType = inType } <- ask- tell mempty { collNames = Set.singleton (c,length ts,inType) }- ts <- mapM transType ts- return $ showCon c ts-transType e = return $ text "{- ERROR " <> tshow e <> text " -} Type"--typeLike (ESort EStar) = True-typeLike (EPi TVr { tvrType = a } b) = typeLike a && typeLike b-typeLike _ = False--transE :: E -> TM Doc-transE (EError s _) = mparen $ return (text "error" <+> tshow s)-transE (EError s _) = mparen $ return (text "error__" <+> tshow s <> text "#" <+> text "`seq`" <+> text "undefined")-transE (ELit (LitInt num t)) = case cTypeInfoT t of- ("Char#",_,_) -> return $ text (show $ chr $ fromIntegral num) <> text "#"- ("Int#",_,_) | num < 0 -> mparen $ return $ text (show num) <> text "#"- | otherwise -> return $ text (show num) <> text "#"- ("Addr#",_,_) | num == 0 -> return $ text "nullAddr#"- | otherwise -> mparen $ return $ text "int2Addr#" <+> text (show num) <> text "#"- ("Word#",_,_) -> mparen $ text "int2Word# (" <> tshow num <> text "# )"-transE (ELit LitCons { litName = c, litArgs = ts }) = nparen $ do- Env { envType = inType } <- ask- tell mempty { collNames = Set.singleton (c,length ts,inType) }- ts <- mapM transE ts- return $ showCon c ts-transE ee | (e,ts@(_:_)) <- fromLam ee = mparen $ do- ts' <- mapM transTVr ts- e <- noParens $ transE e- return $ text "\\" <> hsep ts' <+> text "->" <+> e-transE (EVar tvr) = do- --env <- asks envCoerce- t <- transTVr tvr- --case tvrIdent tvr `member` env of- case hasBoxes (tvrType tvr) of- False -> return t- True -> mparen $ return $ text "unsafeCoerce#" <+> t-transE ee | (e,es@(_:_)) <- fromAp ee = mparen $ do- e <- transE e- es <- mapM transE es- return (hsep (e:es))-transE ELetRec { eDefs = ds, eBody = e } = mparen $ do- --local (\e -> e { envCoerce = envCoerce e `mappend` fromList [ tvrIdent t | (t,_) <- ds, hasBoxes (tvrType t)] }) $ do- ds' <- flip mapM ds $ \ (tvr,e) -> do- let (b,bs) = fromLam e- tt <- noParens $ transType (tvrType tvr)- t <- transTVr tvr- bs <- mapM transTVr bs- e <- case hasBoxes (tvrType tvr) of- False -> noParens $ transE b- True -> do- t <- transE b- return $ text "unsafeCoerce#" <+> t- return (t <+> text "::" <+> tt <> semi $$ hsep (t:bs) <+> text "=" <+> e)- e <- noParens $ transE e- return (text "let {" $$ nest 4 (vcat (punctuate (text ";") ds')) $$ text "} in" <+> e)-transE ECase { eCaseBind = TVr { tvrIdent = 0, tvrType = tt }, eCaseScrutinee = scrut, eCaseDefault = Just body, eCaseAlts = [] } | isLifted tt = mparen $ do- scrut <- transE scrut- body <- transE body- return (scrut <+> text "`seq`" <+> body)-transE ECase { eCaseBind = bind, eCaseScrutinee = scrut, eCaseDefault = md, eCaseAlts = as } = mparen $ do- scrut <- noParens $ transE scrut- let dobind = 0 /= tvrIdent bind- b <- transTVr bind- md <- T.mapM transE md- let md' = flip fmap md $ \e -> b <+> text "->" <+> if dobind && isLifted (getType bind) then text "seq" <+> b <+> e else e- as <- mapM (transAlt dobind b) as- let alts = as ++ maybeToMonad md'- return (text "case" <+> scrut <+> text "of {" $$ nest 4 (vcat (punctuate semi alts)) $$ text "}")-transE e | Just (e',_) <- from_unsafeCoerce e = mparen $ do- e' <- transE e'- return (text "unsafeCoerce#" <+> e')-transE e@(EPrim (APrim (PrimPrim prim) _) args _) = case (unpackPS prim,args) of- ("dependingOn",[x,_y]) -> transE x -- XXX- (fs,args) | Just ghcprim <- lookup fs ghcPrimTable -> mparen $ mapM transE args >>= \args' -> return $ hsep (text ghcprim:args')- _ -> mparen $ return $ text "error" <+> tshow ("ToHs.Error: " ++ show e)---transE (EPrim (APrim Operator { primOp = "-", primRetType = rt } _) [x] _) = mparen $ do--- x <- transE x--- return (hsep [text "negateInt#",x])---transE (EPrim (APrim Operator { primOp = op, primRetType = rt } _) [x,y] _) | Just z <- op2Table (op,rt) = mparen $ do--- x <- transE x--- y <- transE y--- return (hsep [text z,x,y])---transE (EPrim (APrim Operator { primOp = op, primArgTypes = [at,_] } _) [x,y] _) | Just z <- op2TableCmp (op,showCType at) = mparen $ do--- x <- transE x--- y <- transE y--- return $ text "fromBool" <+> (parens $ hsep [text z,x,y])-transE (EPrim (APrim CConst { primConst = ('"':rs) } _) [] _) = return (text ('"':rs) <> text "#")-transE (EPrim (APrim (PrimString ss) _) [] _) = return (tshow ss <> text "#")-transE (EPrim (APrim PrimTypeInfo { primArgType = at, primTypeInfo = c } _) [] _) = ans where- Just pi = primitiveInfo at- ans = case c of- PrimSizeOf -> return $ tshow (primTypeSizeOf pi) <> char '#'--transE (EPrim (APrim Peek { primArgType = at } _) [w,x] _) = mparen ans where- ans = do- w <- transE w- x <- transE x- return (text func <+> x <+> text "0#" <+> w)- (tt,_,_) = cTypeInfo at- Just pi = primitiveInfo at- size = primTypeSizeOf pi * 8- sign = primTypeIsSigned pi- func = case tt of- "Char#" -> "readWideCharOffAddr#"- "Addr#" -> "readAddrOffAddr#"- "Int#" -> "readInt" ++ show size ++ "OffAddr#"- "Word#" -> "readWord" ++ show size ++ "OffAddr#"-transE (EPrim (APrim Peek { primArgType = at } _) [x] (ELit LitCons { litName = n })) = mparen $ ans where- ans = do x <- ans'; castVal at (show n) x- ans' = mparen $ do- x <- transE x- return (text func <+> x <+> text "0#")- (tt,_,_) = cTypeInfo at- Just pi = primitiveInfo at- size = primTypeSizeOf pi * 8- sign = primTypeIsSigned pi- func = case tt of- "Char#" -> "indexWideCharOffAddr#"- "Addr#" -> "indexAddrOffAddr#"- "Int#" -> "indexInt" ++ show size ++ "OffAddr#"- "Word#" -> "indexWord" ++ show size ++ "OffAddr#"-transE (EPrim (APrim Poke { primArgType = at } _) [w,ptr,v] _) = mparen ans where- ans = do- w <- transE w- ptr <- transE ptr- v <- transE v- return (text func <+> ptr <+> text "0#" <+> v <+> w)- Just pi = primitiveInfo at- size = primTypeSizeOf pi * 8- sign = primTypeIsSigned pi- (tt,_,_) = cTypeInfo at- func = case tt of- "Char#" -> "writeWideCharOffAddr#"- "Addr#" -> "writeAddrOffAddr#"- "Int#" -> "writeInt" ++ show size ++ "OffAddr#"- "Word#" -> "writeWord" ++ show size ++ "OffAddr#"-transE (EPrim (APrim (AddrOf addr) _) [] _) = mparen $ do- tell mempty { collPrims = Set.singleton (AddrOf addr) }- return (text $ "unPtr addr_" ++ mangleIdent (unpackPS addr))--transE (EPrim (APrim func@Func {} _) xs _) = mparen $ do- tell mempty { collPrims = Set.singleton func }- xs <- mapM transE xs- return (hsep (text (cfuncname func):xs))---transE (EPrim (APrim cast@CCast { primArgType = at, primRetType = rt } _) [x] _) = mparen $ transE x >>= \x -> castVal at rt x--transE e = mparen $ return $ text "error" <+> tshow ("ToHs.Error: " ++ show e)--ghcPrimTable = [- ("newWorld__","newWorld__"),- ("catch__","catch#"),- ("raiseIO__","raiseIO#"),- ("newRef__","newMutVar#"),- ("readRef__","readMutVar#"),- ("writeRef__","writeMutVar#"),- ("newMutArray__","newArray#"),- ("readArray__","readArray#"),- ("writeArray__","writeArray#"),- ("indexArray__","indexArray#"),- ("unsafeFreezeArray__","unsafeFreezeArray#"),- ("alloca__","alloca__")- ]--castVal :: ExtType -> ExtType -> Doc -> TM Doc-castVal at rt x = case (showCType at,showCType rt) of- (a,b) | a == b -> return x- z | Just co <- lookup z coercions -> mparen $ return (text co <+> x)- xs -> fail $ "unknown coercion: " ++ show xs- where- coercions = [- (("Int#","Char#"),"chr#"),- (("Char#","Int#"),"ord#"),- (("Addr#","Int#"),"addr2Int#"),- (("Int#","Addr#"),"int2Addr#"),- (("Word#","Int#"),"word2Int#"),- (("Int#","Word#"),"int2Word#"),- (("Char#","Word#"),"char2Word__"),- (("Word#","Char#"),"word2Char__"),- (("Addr#","Word#"),"addr2Word__"),- (("Word#","Addr#"),"word2Addr__")- ]--cfuncname Func { funcName = fn, funcIOLike = iol, primArgTypes = as, primRetType = r } = text $ ("func_" ++ (if iol then "io" else "pure") ++ "_" ++ unpackPS fn ++ intercalate "_" (r:as))--hasBoxes e = or $ execWriter (f e) where- f e | e == tBox = tell [True] >> return e- f e = emapEGH f f f e--op2Table (op,rt) = lookup (showCType rt) table >>= lookup op where- table = [ ("Int#",intTable),("Word#",wordTable),("Addr#",addrTable)]- intTable = [- ("+","(+#)"),- ("-","(-#)"),- ("*","(*#)"),- ("%","remInt#"),- ("/","quotInt#")- ]- wordTable = [- ("+","plusWord#"),- ("-","minusWord#"),- ("*","timesWord#"),- ("%","remWord#"),- ("/","quotWord#")- ]- addrTable = [ ("+","plusAddr__") ]--op2TableCmp (op,rt) = lookup rt table >>= lookup op where- table = [ ("Int#",intTable), ("Char#",charTable), ("Addr#",addrTable),("Word#",wordTable)]- intTable = [- (">","(>#)"),- ("==","(==#)"),- ("<","(<#)"),- (">=","(>=#)"),- ("<=","(<=#)")- ]- charTable = [- (">","gtChar#"),- ("==","eqChar#"),- ("<","ltChar#"),- (">=","gteChar#"),- ("<=","lteChar#")- ]- addrTable = [- (">","gtAddr#"),- ("==","eqAddr#"),- ("<","ltAddr#"),- (">=","gteAddr#"),- ("<=","lteAddr#")- ]- wordTable = [- (">","gtWord#"),- ("==","eqWord#"),- ("<","ltWord#"),- (">=","gteWord#"),- ("<=","lteWord#")- ]--transAlt :: Bool -> Doc -> Alt E -> TM Doc-transAlt dobind b (Alt LitInt { litNumber = i, litType = tt } e) = do- let (t,_,_) = cTypeInfoT tt- e <- noParens $ transE e- case t of- "Int#" -> return $ (if dobind then b <> char '@' else empty) <> tshow i <> text "#" <+> text "->" <+> e- "Char#" -> return $ (if dobind then b <> char '@' else empty) <> text (show $ chr $ fromIntegral i) <> text "#" <+> text "->" <+> e- _ -> do- let bvar = if dobind then b else text "_bvar"- Just eq = op2TableCmp ("==",t)- v <- transE (ELit (LitInt i tt))- return (bvar <+> text "|" <+> text eq <+> bvar <+> v <+> text "->" <+> e)-transAlt dobind b (Alt LitCons { litName = c, litArgs = ts } e) = do- tell mempty { collNames = Set.singleton (c,length ts,False) } -- XXX this shouldn't be needed- ts <- mapM transTVr ts- e <- noParens $ transE e- return ( (if dobind then b <> char '@' else empty) <> showCon c ts <+> text "->" <+> e)--transTVr :: TVr -> TM Doc-transTVr TVr { tvrIdent = 0 } = return $ char '_'-transTVr tvr = return (text $ 'v':mangleIdent (pprint tvr))--mangleIdent xs = concatMap f xs where- f '.' = "__"- f '@' = "_a"- f ',' = "_c"- f '(' = "_L"- f ')' = "_R"- f '$' = "_d"- f '%' = "_P"- f '#' = "_h"- f '/' = "_s"- f '=' = "_e"- f '+' = "_p"- f '-' = "_m"- f '!' = "_b"- f '>' = "_r"- f '<' = "_l"- f '\'' = "_t"- f '_' = "_u"- f c | isAlphaNum c = [c]- f c = '_':'x':showHex (ord c) ""-{-* Generated by DrIFT : Look, but Don't Touch. *-}-instance Monoid Collect where- mempty = Coll mempty mempty- mappend (Coll aa ab) (Coll aa' ab') = Coll (mappend aa aa')(mappend ab ab')---- Imported from other files :-
drift_processed/Ho/Type.hs view
@@ -36,73 +36,72 @@ cff_idep = chunkType "IDEP" cff_file = chunkType "FILE" --- A SourceHash is the hash of a specific file, it is associated with a+-- | A SourceHash is the hash of a specific file, it is associated with a -- specific 'Module' that said file implements. type SourceHash = MD5.Hash--- HoHash is a unique identifier for a ho file or library.+-- | HoHash is a unique identifier for a ho file or library. type HoHash = MD5.Hash --- while a 'Module' is a single Module associated with a single haskell source+-- | while a 'Module' is a single Module associated with a single haskell source -- file, a 'ModuleGroup' identifies a group of mutually recursive modules. -- Generally it is chosen from among the Modules making up the group, but the -- specific choice has no other meaning. We could use the HoHash, but for readability -- reasons when debugging it makes more sense to choose an arbitrary Module. type ModuleGroup = Module --- the collected information that is passed around+-- | the collected information that is passed around -- this is not stored in any file, but is what is collected from the ho files. data CollectedHo = CollectedHo {- -- this is a list of external names that are valid but that we may not know+ -- | this is a list of external names that are valid but that we may not know -- anything else about it is used to recognize invalid ids. choExternalNames :: IdSet,- -- these are the functions in Comb form.+ -- | these are the functions in Comb form. choCombinators :: IdMap Comb,- -- these are rules that may need to be retroactively applied to other+ -- | these are rules that may need to be retroactively applied to other -- modules choOrphanRules :: Rules,- -- the hos+ -- | the hos choHoMap :: Map.Map ModuleGroup Ho,- -- libraries depended on+ -- | libraries depended on choLibDeps :: Map.Map PackedString HoHash,- -- these are caches of pre-computed values+ -- | these are caches of pre-computed values choHo :: Ho, -- ^ cache of combined and renamed ho choVarMap :: IdMap (Maybe E) -- ^ cache of variable substitution map } {-! derive: update !-} --- The header contains basic information about the file, it should be enough to determine whether+-- | The header contains basic information about the file, it should be enough to determine whether -- we can discard the file right away or consider it further.- data HoHeader = HoHeader {- -- * the version of the file format. it comes first so we don't try to read data that may be in a different format.+ -- | the version of the file format. it comes first so we don't try to read data that may be in a different format. hohVersion :: Int,- -- * my sha1 id+ -- | my sha1 id hohHash :: HoHash,- -- * the human readable name, either the ModuleGroup or the library name and version.+ -- | the human readable name, either the ModuleGroup or the library name and version. hohName :: Either ModuleGroup (PackedString,Version),- -- * library dependencies+ -- | library dependencies hohLibDeps :: [(PackedString,HoHash)],- -- * arch dependencies, these say whether the file is specialized for a+ -- | arch dependencies, these say whether the file is specialized for a -- given arch. hohArchDeps :: [(PackedString,PackedString)] } --- These are the dependencies needed to check if a ho file is up to date. it+-- | These are the dependencies needed to check if a ho file is up to date. it -- only appears in ho files as hl files do not have source code to check -- against or depend on anything but other libraries. data HoIDeps = HoIDeps {- -- * modules depended on indexed by a hash of the source.+ -- | modules depended on indexed by a hash of the source. hoIDeps :: Map.Map SourceHash (Module,[(Module,SrcLoc)]),- -- * Haskell Source files depended on+ -- | Haskell Source files depended on hoDepends :: [(Module,SourceHash)],- -- * Other objects depended on to be considered up to date.+ -- | Other objects depended on to be considered up to date. hoModDepends :: [HoHash],- -- * library module groups needed+ -- | library module groups needed hoModuleGroupNeeds :: [ModuleGroup] } data HoLib = HoLib {- -- * arbitrary metainformation such as library author, web site, etc.+ -- | arbitrary metainformation such as library author, web site, etc. hoModuleMap :: Map.Map Module ModuleGroup, hoReexports :: Map.Map Module Module, hoModuleDeps :: Map.Map ModuleGroup [ModuleGroup],@@ -121,13 +120,13 @@ instance Show Library where showsPrec n lib = showsPrec n (hohHash $ libHoHeader lib) --- data only needed for type checking.+-- | data only needed for type checking. data HoTcInfo = HoTcInfo { hoExports :: Map.Map Module [Name], hoDefs :: Map.Map Name (SrcLoc,[Name]),- hoAssumps :: Map.Map Name Type, -- used for typechecking+ hoAssumps :: Map.Map Name Type, -- ^ used for typechecking hoFixities :: FixityMap,- hoKinds :: KindEnv, -- used for typechecking+ hoKinds :: KindEnv, -- ^ used for typechecking hoTypeSynonyms :: TypeSynonyms, hoClassHierarchy :: ClassHierarchy, hoFieldMap :: FieldMap@@ -135,7 +134,7 @@ {-! derive: update, Monoid !-} data HoBuild = HoBuild {- -- Filled in by E generation+ -- | Filled in by E generation hoDataTable :: DataTable, hoEs :: [(TVr,E)], hoRules :: Rules
drift_processed/Options.hs view
@@ -39,7 +39,7 @@ import System.Console.GetOpt import System.Directory import System.IO.Unsafe-import System.Environment+import System.Environment (getArgs, getProgName, getEnv) import System.Exit import qualified Data.ByteString.UTF8 as BS import qualified Data.Map as M
lib/jhc/Jhc/Type/Ptr.hs view
@@ -3,4 +3,4 @@ import Jhc.Prim.Bits data {-# CTYPE "HsPtr" #-} Ptr a = Ptr Addr_-data {-# CTYPE "FunPtr" #-} FunPtr a = FunPtr FunAddr_+data {-# CTYPE "HsFunPtr" #-} FunPtr a = FunPtr FunAddr_
library_deps.make view
@@ -1,4 +1,4 @@-BUILD_EXTLIBS = perl utils/build_extlibs.prl -c $(JHCPROG)+BUILD_EXTLIBS = perl utils/build_extlibs.prl -c $(JHCPROG) -j $(JAHMPROG) jhc-prim-1.0.hl: lib/jhc-prim/jhc-prim.yaml lib/jhc-prim/Jhc/Prim/IO.hs lib/jhc-prim/Jhc/Prim/Prim.hs lib/jhc-prim/Jhc/Prim/Array.hs lib/jhc-prim/Jhc/Prim/Wrapper.hs \ lib/jhc-prim/Jhc/Prim/Rts.hs lib/jhc-prim/Jhc/Prim/Bits.hs
src/E/Arbitrary.hs view
@@ -2,19 +2,19 @@ --import Test.QuickCheck import Data.Monoid-import Doc.DocLike+import Doc.DocLike() import Doc.PPrint import Doc.Pretty (putDoc, Doc) import E.E import E.Show import E.TypeCheck()-import GenUtil+import GenUtil() import Name.Id import Name.VConsts-import Random+import System.Random import Support.CanType-import Support.FreeVars-import qualified Data.Map as Map+import Support.FreeVars()+-- import qualified Data.Map as Map import qualified Data.Set as Set data EP = EP {@@ -32,6 +32,7 @@ | t == tInteger = choose [return $ ELit $ LitInt 1 tInteger] | t == tChar = choose [return $ ELit $ LitInt (fromIntegral (fromEnum 'x')) tChar] | t == eStar = choose $ map return [tChar, tInteger]+ | otherwise = fail "not support value" var t = do x <- randomRIO (1,100)
src/E/Main.hs view
@@ -208,7 +208,7 @@ mprog <- simplifyProgram sopt "Init-One" coreMini mprog - -- | this catches more static arguments if we wait until after the initial normalizing simplification pass+ -- this catches more static arguments if we wait until after the initial normalizing simplification pass mprog <- transformProgram tparms { transformSkipNoStats = True, transformCategory = "SimpleRecursive" , transformOperation = return . staticArgumentTransform } mprog
− src/E/SStrictness.hs
@@ -1,280 +0,0 @@-module E.SStrictness(- analyzeProgram- ) where--import Control.Monad-import Control.Monad.RWS-import Data.FunctorM-import Data.List-import Data.Typeable-import qualified Data.Map as Map--import Doc.PPrint-import E.E-import E.Program-import GenUtil-import Info.Info as Info-import Name.Id-import Util.BooleanSolver-import Util.SetLike---- our 2 point lattice--- True == strict--- False == not strict--type SL = Bool--x `islte` y = x `implies` y-x `isgte` y = y `implies` x--data TAnot l = TAnot l (TTyp l)- deriving (Eq,Typeable)--data TTyp l = (TAnot l) `TFun` (TAnot l) | TAtomic | TCPR [TAnot l]- deriving (Eq,Typeable)--type Typ = TAnot (CV (CA Var))--instance Functor TAnot where- fmap f (TAnot l t) = TAnot (f l) (fmap f t)--instance Functor TTyp where- fmap _ TAtomic = TAtomic- fmap f (x `TFun` y) = fmap f x `TFun` fmap f y- fmap f (TCPR xs) = TCPR $ map (fmap f) xs--instance FunctorM TAnot where- fmapM f (TAnot l t) = do l <- f l; t <- fmapM f t; return $ TAnot l t--instance FunctorM TTyp where- fmapM _ TAtomic = return TAtomic- fmapM f (x `TFun` y) = do x <- fmapM f x; y <- fmapM f y; return $ x `TFun` y- fmapM f (TCPR xs) = do xs <- mapM (fmapM f) xs; return $ TCPR xs--instance Show l => Show (TAnot l) where- showsPrec d (TAnot l typ) = showParen (d > 10) $ showsPrec 11 typ . showString "^" . showsPrec 11 l--instance Show l => Show (TTyp l) where- showsPrec d (t1 `TFun` t2) = showParen (d > 9) $ showsPrec 10 t1 . showString " -> " . showsPrec 10 t2- showsPrec _ TAtomic = showString "@"- showsPrec d (TCPR ts) = showParen True $ foldr (.) id (intersperse (showString ",") (map shows ts))--newtype Var = V Int- deriving(Eq,Ord,Typeable)--instance Show Var where- showsPrec _ (V x) = ('v':) . shows x--type Constraints = C (CA Var)--type Environment = Map.Map Id Typ--newtype IM a = IM (RWST Environment Constraints Int IO a)- deriving(MonadState Int,MonadReader Environment,MonadWriter Constraints,Monad,Functor,MonadIO)--newVar :: IM Var-newVar = do- v <- get- put (v + 1)- return (V v)--newtype ShowString = ShowString String--instance Show ShowString where- showsPrec _ (ShowString s) = showString s--fn (CJust v) = ShowString (show v)-fn CTrue = ShowString "S"-fn CFalse = ShowString "L"--strict,lazy :: CV (CA Var)-strict = CTrue-lazy = CFalse--data Variance = Nowhere | Positive | Negative | Both- deriving(Eq,Ord,Show)--instance Monoid Variance where- mempty = Nowhere- mappend x y | x == y = x- mappend Positive Negative = Both- mappend Negative Positive = Both- mappend Nowhere x = x- mappend x Nowhere = x--flipVariance Positive = Negative-flipVariance Negative = Positive-flipVariance x = x--collect :: Typ -> [(Var,Variance)]-collect t = execWriter $ f Positive t where- f p (TAnot (CJust v) t) = tell [(fromCA v,p)] >> g p t- f p (TAnot _ t) = g p t- g p TAtomic = return ()- g p (x `TFun` y) = f (flipVariance p) x >> f p y--{-# NOINLINE analyzeProgram #-}-analyzeProgram prog = do- flip mapM_ (programDs prog) $ \ (t,e) -> case (runIM (infer e)) of- Left err -> putStrLn $ "strictness error :" ++ pprint t ++ "\n" ++ err- Right (c,(ty,_)) -> do- putStrLn $ "strictnes " ++ pprint t- print c- let cc (TAnot l TAtomic) = strict `islte` l- cc (TAnot _ (_ `TFun` b)) = cc b- print (fmap fn ty)- putStrLn "solving:"- --(cc,cvs) <- groundConstraints $ c -- `mappend` cc ty- processConstraints True c--- rs <- flip mapM cvs $ \cv -> do--- res <- readValue cv--- let rr = case res of--- ResultJust True -> CTrue--- ResultJust False -> CFalse--- ResultBounded a _ _ -> CJust (fromCA a)--- return (fromCA cv, rr )--- let mp :: Map.Map Var (CV Var)--- mp = Map.fromList rs--- zz (CJust x) | Just y <- Map.lookup x (Map.fromList rs) = y--- zz (CJust y) = CJust y--- zz CTrue = CTrue--- zz CFalse = CFalse--- ty' = fmap zz ty--- print (fmap fn ty)--- let varmap = (Map.fromListWith mappend $ collect ty')--- print varmap--- flip mapM_ cvs $ \cv -> do--- res <- readValue cv--- print (fromCA cv,fmap fromCA res)--- --print (fmap (zz . CJust . fromCA) cc)-- return ()--runIM :: MonadIO m => IM a -> m (Constraints,a)-runIM (IM s) = do- (a,_,c) <- liftIO $ runRWST s mempty 1- return (c,a)--atom = TAnot lazy TAtomic--mkVar :: IM (CV (CA Var))-mkVar = do- v <- newVar- ca <- mkCA v- return (CJust ca)--infer :: E -> IM (Typ,E)-infer e@(ELit l) = do- return (TAnot strict TAtomic,e)- --return (atom,e)-infer e@EPi {} = do- return (TAnot strict TAtomic,e)- --return (atom,e)-infer (EVar tvr) = do- env <- ask- case mlookup (tvrIdent tvr) env `mplus` Info.lookup (tvrInfo tvr) of- Nothing -> do- -- guess a pessimistic type if we know nothing about a variable- t <- guessType (tvrType tvr)- return (t,EVar tvr)- Just t -> return (t,EVar tvr)-infer (EPrim p xs t) = do- ts <- mapM infer xs- v <- mkVar- mapM_ (\ (TAnot t _) -> tell (v `islte` t)) (map fst ts)- return (TAnot v TAtomic,EPrim p (map snd ts) t)-infer (EError s t) = do- v <- mkVar- return (TAnot v TAtomic,EError s t)-infer (ELam x@TVr {tvrType = t1} m) = do- s1 <- freshAnot t1- (s2,e) <- local (minsert (tvrIdent x) s1) $- infer m- v <- mkVar- return (TAnot strict $ s1 `TFun` s2,ELam x e)-infer ec@ECase {} = do- nv <- mkVar- (TAnot t _,e') <- infer (eCaseScrutinee ec)- tell (nv `implies` t)- ((ty:tys) ,ec) <- caseBodiesMapM' infer ec- (TAnot res rt) <- foldM freshGLB ty tys- tell (nv `implies` res)- return (TAnot nv rt,ec { eCaseScrutinee = e' })-infer (EAp a b) = do- (TAnot k (s1 `TFun` (TAnot rst s2)),a) <- infer a- (s1'@(TAnot zz _),b) <- infer b- s1 `subsA` s1'- res <- mkVar- -- the function is strict if we are strict- tell (res `implies` k)- tell (res `implies` rst)- return (TAnot res s2,EAp a b)---infer (ELetRec ds e) = do--infer e = fail $ "infer: unsupported\n" ++ show e--caseBodiesMapM' :: Monad m => (E -> m (t,E)) -> E -> m ([t],E)-caseBodiesMapM' f ec@ECase { eCaseAlts = as, eCaseDefault = d } = do- let g (Alt l e) = do (t,e) <- f e ; return (t,Alt l e)- as' <- mapM g as- d' <- fmapM f d- let ts = fsts as' ++ maybe [] ((:[]) . fst) d'- return $ (ts,ec { eCaseAlts = snds as', eCaseDefault = fmap snd d' })-caseBodiesMapM' _ _ = error "caseBodiesMapM'"---- | pessimistic guess of type for variables we know nothing about.--- warning! newtypes of infinite functions are wonky. need to figure out solution.-guessType (EPi TVr {tvrType = t1 } t2) = do- TAnot _ t1 <- guessType t1- t2 <- guessType t2- v <- mkVar- return (TAnot v $ TAnot lazy t1 `TFun` t2)-guessType _ = do- v <- mkVar- return (TAnot v TAtomic)--freshAnot (EPi TVr {tvrType = t1 } t2) = do- t1 <- freshAnot t1- t2 <- freshAnot t2- v <- mkVar- return (TAnot v $ t1 `TFun` t2)-freshAnot _ = do- v <- mkVar- return (TAnot v TAtomic)--freshGLB (TAnot k1 TAtomic) (TAnot k2 TAtomic) = do- v <- mkVar- tell (v `islte` k1)- tell (v `islte` k2)- return (TAnot v TAtomic)--freshGLB (TAnot k1 (TFun a1 b1)) (TAnot k2 (TFun a2 b2)) = do- v <- mkVar- tell (v `islte` k1)- tell (v `islte` k2)- a <- freshLUB a1 a2- b <- freshGLB a2 b2- return (TAnot v (TFun a b))--freshLUB (TAnot k1 TAtomic) (TAnot k2 TAtomic) = do- v <- mkVar- tell (v `isgte` k1)- tell (v `isgte` k2)- return (TAnot v TAtomic)--freshLUB (TAnot k1 (TFun a1 b1)) (TAnot k2 (TFun a2 b2)) = do- v <- mkVar- tell (v `isgte` k1)- tell (v `isgte` k2)- a <- freshLUB a1 a2- b <- freshGLB a2 b2- return (TAnot v (TFun a b))--subs (x1 `TFun` y2) (x3 `TFun` y4) = do- x3 `subsA` x1- y2 `subsA` y4-subs TAtomic TAtomic = return ()--subsA (TAnot a t1) (TAnot b t2) = do- tell (a `islte` b)- t1 `subs` t2
src/E/TypeAnalysis.hs view
@@ -208,7 +208,7 @@ getValue (EVar v) | Just x <- Info.lookup (tvrInfo v) = return x | otherwise = return $ value (vmapPlaceholder ())- -- | otherwise = fail $ "getValue: no varinfo: " ++ show v+ ---- | otherwise = fail $ "getValue: no varinfo: " ++ show v getValue e | Just c <- typConstant e = return $ value c getValue e = return $ value $ fuzzyConstant e -- TODO - make more accurate
src/FrontEnd/Tc/Unify.hs view
@@ -301,7 +301,7 @@ mgu (TVar a) (TVar b) | a == b = return () mgu c1@(TCon tc1) c2@(TCon tc2) | tc1==tc2 = return ()- -- | otherwise = fail $ "mgu: Constructors don't match:" ++ show (c1,c2)+ ---- | otherwise = fail $ "mgu: Constructors don't match:" ++ show (c1,c2) | otherwise = unificationError c1 c2 mgu TForAll {} _ = error "attempt to unify TForall" mgu _ TForAll {} = error "attempt to unify TForall"
src/GenUtil.hs view
@@ -130,7 +130,7 @@ import System.Time import System.CPUTime import System.Exit-import System.Environment+import System.Environment (getArgs, getEnv) {-# SPECIALIZE snub :: [String] -> [String] #-} {-# SPECIALIZE snub :: [Int] -> [Int] #-}@@ -331,12 +331,10 @@ snds :: [(a,b)] -> [b] snds = map snd -{-# INLINE repeatM #-} {-# SPECIALIZE repeatM :: IO a -> IO [a] #-} repeatM :: Monad m => m a -> m [a] repeatM x = sequence $ repeat x -{-# INLINE repeatM_ #-} {-# SPECIALIZE repeatM_ :: IO a -> IO () #-} repeatM_ :: Monad m => m a -> m () repeatM_ x = sequence_ $ repeat x@@ -344,12 +342,10 @@ {-# RULES "replicateM/0" replicateM 0 = const (return []) #-} {-# RULES "replicateM_/0" replicateM_ 0 = const (return ()) #-} -{-# INLINE replicateM #-} {-# SPECIALIZE replicateM :: Int -> IO a -> IO [a] #-} replicateM :: Monad m => Int -> m a -> m [a] replicateM n x = sequence $ replicate n x -{-# INLINE replicateM_ #-} {-# SPECIALIZE replicateM_ :: Int -> IO a -> IO () #-} replicateM_ :: Monad m => Int -> m a -> m () replicateM_ n x = sequence_ $ replicate n x
− src/Grin/Arity.hs
@@ -1,45 +0,0 @@-module Grin.Arity(grinRaiseArity) where--import IO(stdout)-import qualified Data.Map as Map--import Fixer.Fixer-import Fixer.Supply-import GenUtil-import Grin.Grin-import Support.FreeVars-import Support.ShowTable--grinRaiseArity :: Grin -> IO Grin-grinRaiseArity grin = do- fixer <- newFixer- argSupply <- newSupply fixer-- mapM_ (go argSupply) (grinFunctions grin)-- findFixpoint (Just ("grin arity raising",stdout)) fixer-- rv <- supplyReadValues argSupply- printTable "Grin.Arity: arguments" rv-- return grin--go argSupply (fn,~(Tup as) :-> e) = do- vs <- mapM (\ (Var v _,i) -> supplyValue argSupply (fn,i)) (zip as naturals)- let env = Map.fromList (zip [ v | ~(Var v _) <- as ] vs)- f Fetch {} = return ()- f (App n as _) = mapM_ (g n) (zip as naturals)- f (Store (NodeC nn as)) | Just (_,n) <- tagUnfunction nn = mapM_ (g n) (zip as naturals)- f (e1 :>>= p :-> e2) = f e1 >> f e2- f (Case x as) = mapM_ bf (freeVars x) >> sequence_ [ f e | _ :-> e <- as]- f e = mapM_ bf (freeVars e)- g fn (Var v _,i) | Just value <- Map.lookup v env = do- vv <- supplyValue argSupply (fn,i)- addRule $ vv `implies` value- g _ _ = return ()- bf v | Just val <- Map.lookup v env = addRule $ value True `implies` val- bf _ = return ()- f e--implies :: Value Bool -> Value Bool -> Rule-implies x y = y `isSuperSetOf` x
− src/Grin/Embed.hs
@@ -1,130 +0,0 @@-module Grin.Embed((.>>=),(.>>),GG,VVar,TyNode,TyTag,TyPtr,TyRaw,embedTest) where--import Doc.Pretty-import GenUtil-import Grin.Grin-import Grin.Show-import StringTable.Atom-import Support.CanType-import Util.UniqueMonad--newtype GG = GG { unGG :: (Uniq Exp) }--data TyNode-data TyTag-data TyPtr a-data TyRaw a-data TyUnknown--runGG :: Int -> Uniq Exp -> Exp-runGG n x | n <= 0 = runGG 1 x-runGG s (GG x) = fst (runUniq s x)--unLam :: forall a . Valable a => ( a -> GG ) -> Uniq Lam-unLam f = do- (x,v) <- varUp (error "cannot unlamunknown")- gb <- unGG $ f x- return $ v :-> gb--dunLam :: forall a . Valable a => Ty -> ( a -> GG ) -> Uniq Lam-dunLam ty f = do- (x,v) <- varUp ty- gb <- unGG $ f x- return $ v :-> gb--{--data TyTup -- ???-data Val :: * where- Tag :: Tag -> Val TyTag- Const :: Val x -> Val (TyPtr x)- Lit :: Number -> Val (TyBasic)- Var :: Var -> Val a- NodeC :: Tag -> ???? -> Val TyNode- Tup :: ???? -> Val ???--}--infixr 1 .>>=, .>>--(.>>=) :: Valable a => GG -> (a -> GG) -> GG-(.>>=) (GG g1) f2 = GG $ do- ga <- g1- (x,v) <- varUp (getType ga)- gb <- unGG $ f2 x- return $ ga :>>= v :-> gb--(.>>) :: GG -> GG -> GG-(.>>) g1 g2 = g1 .>>= \ ( _ :: TyUnknown ) -> g2--newtype VVar a = VVar Val--class Valable a where- varUp :: Ty -> Uniq (a,Val)--vvarUp :: forall a . Ty -> Uniq (VVar a,Val)-vvarUp TyTup {} = error "vvarUp tuple"-vvarUp ty = do- vv <- newVal ty- return (VVar vv,vv)--newVal (TyTup tys) = do- vs <- mapM newVal tys- return (Tup vs)-newVal ty = do- i <- newUniq- return (Var (V i) ty)--{--instance Valable a where- varUp ty = do- vv <- newVal ty- return (undefined,vv)--}--instance Valable TyUnknown where- varUp ty = do- vv <- newVal ty- return (undefined,vv)--instance TyBasic a => Valable (VVar (TyRaw a)) where- varUp _ = vvarUp (Ty (rawType (undefined :: a)))--instance Valable (VVar TyNode) where- varUp _ = vvarUp TyNode-instance Valable (VVar TyTag) where- varUp _ = vvarUp TyTag-instance (Valable a, Valable b) => Valable (a,b) where- varUp (TyTup [x,y]) = do- (vva,va) <- varUp x- (vvb,vb) <- varUp y- return ((vva,vvb),Tup [va,vb])--class TyBasic a where- rawType :: a -> Atom--data RawInt-type Rint = TyRaw RawInt--instance TyBasic RawInt where- rawType _ = (toAtom "int")--gCase :: VVal a -> [Uniq Lam] -> GG-gCase (VVal v) ls = GG $ do- ls <- sequence ls- return $ Case v ls--gReturn :: VVal a -> GG-gReturn (VVal v) = GG $ return $ Return v--app2 :: Atom -> VVal a -> VVal b -> GG-app2 n (VVal a) (VVal b) = GG $ return (App n [a,b])--lLam :: Val -> Uniq Exp -> Uniq Lam-lLam v ue = do- e <- ue- return $ v :-> e--fact :: (Rint,Rint) -> GG-fact (n,r) = gCase n [unLam $ \ (x :: Rint) -> primMinus n 1 .>>= \ n' -> primTimes n r .>>= \r' -> app (toAtom "fact") [n',r'], lLam 1 (gReturn r) ]--embedTest = do- putDoc $ prettyFun (toAtom "fact",execUniq1 $ unLam fact)
src/Grin/FromE.hs view
@@ -576,7 +576,7 @@ -- | cc evaluates something in lazy context, returning a pointer to a node which when evaluated will produce the strict result. -- it is an invarient that evaling (cc e) produces the same value as (ce e) cc (EPrim don [e,_] _) | don == p_dependingOn = cc e- cc (EPrim (PrimPrim "fromBang_") (args -> [e]) _) = return $ if getType e == tyDNode then demote e else Return [e] -- $ demote e+ cc (EPrim (PrimPrim "fromBang_") (args -> [e]) _) = return $ if getType e == tyDNode then demote e else Return [e] ---- $ demote e -- e <- ce e -- return $ e :>>= [v] :-> demote v cc e | Just _ <- literal e = error "unboxed literal in lazy context"
src/Grin/Grin.hs view
@@ -235,8 +235,10 @@ gEval :: Val -> Exp gEval x = BaseOp Eval [x] -tyINode = TyINode -- ^ lazy node sptr_t-tyDNode = TyNode -- ^ strict node wptr_t+-- | lazy node sptr_t+tyINode = TyINode+-- | strict node wptr_t+tyDNode = TyNode createFuncDef local name body@(args :-> rest) = updateFuncDefProps FuncDef { funcDefName = name, funcDefBody = body, funcDefCall = call, funcDefProps = funcProps } where call = Item name (TyCall (if local then LocalFunction else Function) (map getType args) (getType rest))
− src/Grin/Interpret.hs
@@ -1,187 +0,0 @@-module Grin.Interpret(evaluate) where--import C.Prims-import Char-import CharIO-import Control.Monad.Identity-import Data.IORef-import Data.Map as Map hiding(map)-import Data.Monoid-import Doc.DocLike-import Doc.Pretty-import GenUtil hiding(putErrLn,putErr)-import Grin.Grin-import Grin.Show-import Name.VConsts-import Options-import StringTable.Atom-import Support.CanType-import qualified FlagDump as FD-import qualified Stats--type Builtin = [Val] -> IO Val--builtins = []-builtinMap = Map.fromList [ (x,y) | (x,y) <- builtins ]--createCafMap as = f vars [] >>= return . Map.fromList where- f [] xs = return xs- f ((x,y):xs) ys = newIORef y >>= \y -> f xs ((x,Addr y):ys)- vars = as--evaluate :: Grin -> IO (Val,Stats.Stats)-evaluate Grin { grinTypeEnv = tyEnv, grinFunctions = ts, grinCafs = cafs } = do- stats <- Stats.new- cafMap <- createCafMap cafs- let f x = interpret stats tyEnv cafMap builtinMap (fromList ts) x- g (App t [l@Lit {}] _) | t == funcEval = return l- g (App t [Const n] _) | t == funcEval = return n- g e = f e >>= \x -> case x of- NodeC t xs -> do- xs <- mapM (g . gEval) xs- return $ NodeC t xs- z -> return z- v <- g (App funcMain [] tyUnit)- return (v,stats)--funcCalls = toAtom "Function Calls"-primCalls = toAtom "Primitive Calls"--prettyEnv env = vcat [ text ('v':show x) <+> text "->" <+> prettyVal y | (V x,y) <- Map.toList env ]--interpret :: Stats.Stats -> TyEnv -> Map Var Val -> Map Atom Builtin -> Map Atom Lam -> Exp -> IO Val-interpret stats te cafMap primMap scMap e = f mempty e where- f :: Map Var Val -> Exp -> IO Val- f env (e1 :>>= (v :-> e2)) = do- r <- f env e1- be <- bind v r- f (be `mappend` env) e2- f env (App a xs ty) = do- wdump FD.Steps $ do- putErrLn $ render (prettyExp mempty $ App a xs' ty)- Stats.tick stats funcCalls- Stats.tick stats (toAtom $ "Function." ++ fromAtom a)- case Map.lookup a scMap of- Nothing -> error $ "Unknown App: " ++ show (App a xs' ty)- Just ((Tup as :-> e)) -> f (Map.fromList (zip [ v | Var v _ <- as] xs')) e- where xs' = map (le env) xs- f env (Prim Primitive { primAPrim = APrim CCast {} _, primType = (_,t)} [x]) = return $ (Lit n t)- where (Lit n _) = le env x- f env (Prim Primitive { primAPrim = APrim Func { funcName = "putwchar" } _} [x]) = putChar (chr $ fromIntegral n) >> return unit- where (Lit n _) = le env x- f env (Prim Primitive { primAPrim = APrim Operator { primOp = "<=" } _, primType = (_,t)} [x,y]) = if x' <= y' then return (Lit 1 t) else return (Lit 0 t)- where (Lit x' _) = le env x- (Lit y' _) = le env y- f env (Prim Primitive { primAPrim = APrim Operator { primOp = ">=" } _, primType = (_,t)} [x,y]) = if x' >= y' then return (Lit 1 t) else return (Lit 0 t)- where (Lit x' _) = le env x- (Lit y' _) = le env y- f env (Prim Primitive { primAPrim = APrim Operator { primOp = ">" } _, primType = (_,t)} [x,y]) = if x' > y' then return (Lit 1 t) else return (Lit 0 t)- where (Lit x' _) = le env x- (Lit y' _) = le env y- f env (Prim Primitive { primAPrim = APrim Operator { primOp = "<" } _, primType = (_,t)} [x,y]) = if x' < y' then return (Lit 1 t) else return (Lit 0 t)- where (Lit x' _) = le env x- (Lit y' _) = le env y- f env (Prim Primitive { primAPrim = APrim Operator { primOp = "==" } _, primType = (_,t)} [x,y]) = if x' == y' then return (Lit 1 t) else return (Lit 0 t)- where (Lit x' _) = le env x- (Lit y' _) = le env y- f env (Prim Primitive { primAPrim = APrim Operator { primOp = "+" } _, primType = (_,t)} [x,y]) = return (Lit (x' + y') t)- where (Lit x' _) = le env x- (Lit y' _) = le env y- f env (Prim Primitive { primAPrim = APrim Operator { primOp = "/" } _, primType = (_,t)} [x,y]) = return (Lit (x' `div` y') t)- where (Lit x' _) = le env x- (Lit y' _) = le env y- f env (Prim Primitive { primAPrim = APrim Operator { primOp = "%" } _, primType = (_,t)} [x,y]) = return (Lit (x' `mod` y') t)- where (Lit x' _) = le env x- (Lit y' _) = le env y- f env (Prim Primitive { primAPrim = APrim Operator { primOp = "-" } _, primType = (_,t)} [x,y]) = return (Lit (x' - y') t)- where (Lit x' _) = le env x- (Lit y' _) = le env y- f env (Prim Primitive { primAPrim = APrim Operator { primOp = "*" } _, primType = (_,t)} [x,y]) = return (Lit (x' * y') t)- where (Lit x' _) = le env x- (Lit y' _) = le env y- f env (Prim Primitive { primAPrim = APrim Operator { primOp = "-" } _, primType = (_,t)} [x]) = return (Lit (negate x') t)- where (Lit x' _) = le env x- f env (Prim p xs) = do- let a = primName p- xs' = map (le env) xs- wdump FD.Steps $ do- putErrLn $ render (prettyExp mempty $ Prim p xs')- Stats.tick stats primCalls- Stats.tick stats (toAtom $ "Primitive." ++ fromAtom a)- case Map.lookup a primMap of- Nothing -> error $ "Unknown Primitive: " ++ show (Prim p xs')- Just action -> do action xs'- f env (Return v) = return (le env v)- f env (Store v) = do- Stats.tick stats (toAtom "Allocations Performed")- fmap Addr $ newIORef (le env v)- f env (Fetch x)- | (Addr x) <- le env x = readIORef x- | (Const x) <- le env x = return x- f env (Update x v) | (Addr x) <- le env x = do- Stats.tick stats (toAtom "Updates Performed")- (writeIORef x $! (le env v)) >> return unit- f env (Update x v) | (Const x) <- le env x, x == le env v = return unit- f env (Update x v) = fail $ "Bad update: " ++ show (le env x,le env v)- f env (Error s t) = fail $ render $ tshow (s,t) <$> (prettyEnv env)--- f env (Eval x)--- | otherwise = f env $ App funcEval [x]--- | Const x <- lx = doEval x--- | (Addr ref) <- lx = do--- v <- readIORef ref--- nv <- doEval v--- writeIORef ref nv--- return nv--- where--- lx = le env x--- f env (Apply x y)--- | True = f env $ App funcApply [x,y]--- | False = doApply (le env x) (le env y)- f env (Case v ps) = match (le env v) ps where- match s ((p :-> e):ps) = case bind p s of- Nothing -> match s ps- Just env' -> f (env' `mappend` env) e- match e [] = fail $ "end of match: " ++ show e <+> show env- f env z = fail $ "cannot interpret: " ++ show (toList env,z)- le env (Tup vs) = Tup (map (le env) vs)- le env (NodeC t vs) = NodeC t (map (le env) vs)- le env z@(NodeV t vs) = NodeC (lt t) (map (le env) vs) where- lt x = case Map.lookup x env of- Just (Tag t) -> t- z' -> error $ "Invalid tag variable in NodeV: " ++ show (z,z')- le env z@(Var v _) = case Map.lookup v env `mplus` Map.lookup v cafMap of- Just x -> le env x- Nothing -> error $ "le" ++ show (z,env)- le _ x = x-- doApply (NodeC t xs) y- | n == (1::Int) = f mempty (App (toAtom $ 'f':rs) (xs ++ [y]) TyNode) -- TODO, right?- | n > 1 = return $ NodeC (toAtom $ 'P':show (n - 1) ++ "_" ++ rs) (xs ++ [y])- where- ('P':cs) = fromAtom t- (n','_':rs) = span isDigit cs- n = read n'- doApply x y = error $ "doApply " ++ show (x,y)- doEval x@(NodeC t xs)- | 'P':_ <- t' = return x- | 'T':_ <- t' = return x- | 'C':_ <- t' = return x- | 'F':rs <- t' = f mempty (App (toAtom $ 'f':rs) xs TyNode) -- TODO, right?- | 'B':rs <- t' = f mempty (App (toAtom $ 'b':rs) xs TyNode) -- TODO, right?- where- t' = fromAtom t- doEval x = error $ "doEval " ++ show x-- bind :: Monad m => Val -> Val -> m (Map Var Val)- bind (Var (V 0) _) _ = return mempty- bind (Var v _) r = return $ singleton v r- bind (Lit i _) (Lit i' _) | i == i' = return mempty- bind (Tup xs) (Tup ys) = liftM mconcat $ sequence $ zipWith bind xs ys- bind (Tag i) (Tag i') | i == i' = return mempty- bind (NodeV v vs) (NodeC t vs') = do- be <- liftM mconcat $ sequence $ zipWith bind vs vs'- return (be `mappend` singleton v (Tag t))- bind (NodeC t vs) (NodeC t' vs') | t == t' = do- liftM mconcat $ sequence $ zipWith bind vs vs'- bind v r | getType v == getType r = fail $ "unbindable: " ++ show (v,r,getType v,getType r) -- check type to be sure- bind x y = error $ "bad bind: " ++ show (x,y)
− src/Grin/Unboxing.hs
@@ -1,115 +0,0 @@-module Grin.Unboxing(unboxReturnValues) where--import Maybe-import Monad-import qualified Data.Map as Map-import qualified Data.Set as Set--import GenUtil-import Grin.Grin-import StringTable.Atom-import Support.CanType-import Support.Tuple-import Util.Graph--tailcalls :: Lam -> Set.Set Atom-tailcalls (_ :-> e) = f e where- f (_ :>>= l) = tailcalls l- f App { expFunction = fn } = Set.singleton fn- f Case { expAlts = as } = Set.unions (map tailcalls as)- f _ = Set.empty--unboxingCandidate :: Item -> Bool-unboxingCandidate item = isJust (unboxFunction undefined item)--isEnum (NV _ []) = True-isEnum _ = False--unboxFunction :: Monad m => Atom -> Item -> m (Exp -> Exp, Exp -> Exp, Ty, Item)-unboxFunction _ x | getType x == tyUnit = fail "unboxFunction: return type is already ()"--- get rid of any fully constant values in return-unboxFunction fn item | any isLeft rvs = return (unboxReturn, unboxCall, returnType, nvs) where- vs = fromTuple item- rvs = [ case constantItem v of Just x -> Left x ; _ -> Right v | v <- vs ]- nvs = tuple (rights rvs)- returnType = getType nvs- unboxReturn e = e :>>= tuple vars :-> Return (tuple vars')- unboxCall (App a as _) | a == fn = App a as returnType :>>= tuple vars' :-> Return (tuple [ case x of Left x -> x ; Right _ -> v | v <- vars | x <- rvs ])- vars = [Var v t | v <- [v1 ..] | t <- map getType vs ]- vars' = concat [ perhapsM (isRight r) (Var v t) | v <- [v1 ..] | t <- map getType vs | r <- rvs ]---- unbox enumerated types-unboxFunction fn (NodeValue vs) | all isEnum (Set.toList vs) = return (unboxReturn, unboxCall, TyTag, itemTag) where- unboxReturn (Return (NodeC t [])) = Return (Tag t)- unboxReturn e = e :>>= nodev :-> Return var- unboxCall (App a as ty) = App a as TyTag :>>= var :-> Return nodev- var = Var v1 TyTag- nodev = NodeV v1 []---- returning a known node type-unboxFunction fn (NodeValue vs) | [NV t args] <- Set.toList vs = let- returnType = tuple (map getType args)- unboxReturn (Return (NodeC t' xs))- | t == t' = Return (tuple xs)- | otherwise = error "returning wrong node"- unboxReturn e = e :>>= NodeC t vars :-> Return (tuple vars)- unboxCall (App a as _) | a == fn = App a as returnType :>>= tuple vars :-> Return (NodeC t vars)- vars = [Var v t | v <- [v1 ..] | t <- map getType args ]- in return (unboxReturn, unboxCall, returnType, tuple args)--unboxFunction _ item = fail "function not unboxable" -- (id,id,getType item)--constantItem (NodeValue vs) | [NV t xs] <- Set.toList vs = do- xs <- mapM constantItem xs- return (NodeC t xs)-constantItem (TupledValue xs) = do- xs <- mapM constantItem xs- return (Tup xs)-constantItem (HeapValue vs) | [HV _ (Right val)] <- Set.toList vs = do- return (Const val)-constantItem _ = fail "not constant item"--{-# NOINLINE unboxReturnValues #-}-unboxReturnValues :: Grin -> IO Grin-unboxReturnValues grin = do- let tcgraph = newGraph [ (n, Set.toList $ tailcalls body) | (n,body) <- grinFuncs grin] fst snd- ubc a | Just v <- Map.lookup a (grinReturnTags grin) = unboxingCandidate v- ubc _ = False- cfns = filter ubc (fsts $ grinFuncs grin)- pf fn | Just item <- Map.lookup fn (grinReturnTags grin) =- do x <- unboxFunction fn item ; return $ Map.singleton fn x- fns = Map.unions $ concatMap pf cfns- retTag fn _ | Just (_,_,_,ret) <- Map.lookup fn fns = ret- retTag _ x = x- retTe fn tyty | Just (_,_,ret,_) <- Map.lookup fn fns = tyty { tyReturn = ret }- retTe _ x = x- mtenv (TyEnv mp) = TyEnv $ Map.mapWithKey retTe mp- doFunc (fn,lam) | Just (unboxReturn,_,_,_) <- Map.lookup fn fns = doFunc' (fn,convertReturns unboxReturn lam)- doFunc (fn,lam) = doFunc' (fn,lam)- doFunc' (fn,lam) = (fn, convertApps doApp lam)- doApp ap@(App fn _ _) | Just (_,f,_,_) <- Map.lookup fn fns = f ap- doApp e = e- putStrLn "Unboxed return values"- mapM_ putStrLn [ " " ++ show fn ++ " - " ++ show nt | (fn,(_,_,nt,_)) <- Map.toList fns]-- let newgrin = setGrinFunctions (map doFunc (grinFuncs grin)) grin {- grinReturnTags = Map.mapWithKey retTag (grinReturnTags grin),- grinTypeEnv = mtenv (grinTypeEnv grin)- }- if Map.null fns then return newgrin else unboxReturnValues newgrin--convertReturns unboxReturn lam = g lam where- g (l :-> e) = l :-> f e- f (e :>>= l) = e :>>= g l- f e@Case { expAlts = as } = e { expAlts = map g as }- f e@Let { expBody = b } = e { expBody = f b }- f e@MkCont { expCont = c , expLam = b } = e { expCont = g c, expLam = g b }- f e = unboxReturn e--convertApps doApp lam = g lam where- g (l :-> e) = l :-> f e- f (e :>>= l) = f e :>>= g l- f e@Case { expAlts = as } = e { expAlts = map g as }- f e@Let { expDefs = defs, expBody = b } = e { expBody = f b, expDefs = [ createFuncDef True (funcDefName d) (g $ funcDefBody d) | d <- defs ] }- f e@MkCont { expCont = c , expLam = b } = e { expCont = g c, expLam = g b }- f e = doApp e
src/Ho/ReadSource.hs view
@@ -129,8 +129,7 @@ (ws,ParseOk e) -> processErrors ws >> return (e { hsModuleOpt = fileOpts' },LBSU.fromString s') (_,ParseFailed sl err) -> putErrDie $ show sl ++ ": " ++ err -fetchCompilerFlags :: IO (FilePath, -- ^ file path to compiler- [String]) -- ^ compiler arguments+fetchCompilerFlags :: IO (FilePath, [String]) -- ^ file path to compiler, compiler arguments fetchCompilerFlags = return (cc,args) where lup k = maybe "" id $ Map.lookup k (optInis options) boehmOpts | fopts FO.Boehm = ["-D_JHC_GC=_JHC_GC_BOEHM", "-lgc"]
− src/Main.hs
@@ -1,116 +0,0 @@-module Main(main) where--import Control.Exception-import Control.Monad.Identity-import Data.Char-import Prelude-import System.Directory-import System.FilePath as FP-import System.IO-import qualified Data.ByteString.Lazy as LBS--import DataConstructors-import E.Main-import E.Program-import E.Rules-import E.Type-import FrontEnd.Class-import Grin.Main(compileToGrin)-import Grin.Show(render)-import Ho.Build-import Ho.Collected-import Ho.Library-import Name.Name-import Options-import StringTable.Atom-import Support.TempDir-import Util.Gen-import Util.SetLike as S-import Version.Version(versionSimple)-import qualified FlagDump as FD-import qualified Interactive--main = wrapMain $ do- hSetEncoding stdout utf8- hSetEncoding stderr utf8- o <- processOptions- when (dump FD.Atom) $- addAtExit dumpStringTableStats- -- set temporary directory- maybeDo $ do x <- optWorkDir o; return $ setTempDir x- let darg = progressM $ do- (argstring,_) <- getArgString- return (argstring ++ "\n" ++ versionSimple)- case optMode o of- BuildHl hl -> darg >> buildLibrary processInitialHo processDecls hl- ListLibraries -> listLibraries- ShowHo ho -> dumpHoFile ho- PurgeCache -> purgeCache- Preprocess -> forM_ (optArgs o) $ \fn -> do- lbs <- LBS.readFile fn- res <- preprocessHs options fn lbs- LBS.putStr res- _ -> darg >> processFiles (optArgs o)---- we are very careful to only delete cache files.-purgeCache = do- Just hc <- findHoCache- ds <- getDirectoryContents hc- let cacheFile fn = case map toLower (reverse fn) of- 'o':'h':'.':fs -> length fs == 26 && all isAlphaNum fs- _ -> False- forM_ ds $ \fn -> when (cacheFile fn) (removeFile (hc </> fn))--processFiles :: [String] -> IO ()-processFiles cs = f cs (optMainFunc options) where- f [] Nothing = do- int <- Interactive.isInteractive- when (not int) $ putErrDie "ajhc: no input files"- g [Left preludeModule]- f [] (Just (b,m)) = do- m <- getModule (parseName Val m)- g [Left m]- f cs _ = g (map fileOrModule cs)- g fs = processCollectedHo . snd =<< parseFiles options [outputName] []- fs processInitialHo processDecls- fileOrModule f = case reverse f of- ('s':'h':'.':_) -> Right f- ('s':'h':'l':'.':_) -> Right f- ('c':'s':'h':'.':_) -> Right f- _ -> Left $ toModule f--processCollectedHo cho = do- if optStop options == CompileHo then return () else do- putProgressLn "Collected Compilation..."-- when (dump FD.ClassSummary) $ do- putStrLn " ---- class summary ---- "- printClassSummary (choClassHierarchy cho)- when (dump FD.Class) $ do- putStrLn " ---- class hierarchy ---- "- printClassHierarchy (choClassHierarchy cho)-- let dataTable = choDataTable cho- combinators = values $ choCombinators cho-- evaluate dataTable- evaluate combinators-- let prog = programUpdate program {- progCombinators = combinators,- progDataTable = dataTable- }- -- dump final version of various requested things- wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable)- wdump FD.DatatableBuiltin $- putErrLn (render $ showDataTable samplePrimitiveDataTable)- dumpRules (Rules $ fromList- [(combIdent x,combRules x) | x <- combinators, not $ null (combRules x)])-- -- enter interactive mode- int <- Interactive.isInteractive- if int then Interactive.interact cho else do- prog <- compileWholeProgram prog- compileToGrin prog--progressM c = wdump FD.Progress $ (c >>= putErrLn) >> hFlush stderr
src/RawFiles.hs view
@@ -152,7 +152,7 @@ \; cross compilation entries\n\ \\n\ \[win32]\n\- \cc=i386-mingw32-gcc\n\+ \cc=i686-w64-mingw32-gcc\n\ \executable_extension=.exe\n\ \merge=i686\n\ \\n\@@ -1059,6 +1059,354 @@ {-# NOINLINE changelog #-} changelog :: ByteString changelog = unsafePerformIO $ unsafePackAddress "\+ \commit 702d796aea22d1129491bb49b66a8a9a4b8ef901\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sat Jun 8 01:53:46 2013 +0900\n\+ \\n\+ \ Add Ajhc 0.8.0.5 Release Notes.\n\+ \\n\+ \commit 07c3dfbf0300b482393dae85a6a9c52599d303fa\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sat Jun 8 01:37:12 2013 +0900\n\+ \\n\+ \ Add public types to haddock.\n\+ \\n\+ \commit 216ce6a8fe17b0fa7c64b98db04ff9d07b2c5a39\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Fri Jun 7 22:48:11 2013 +0900\n\+ \\n\+ \ Avoid haddock parser error.\n\+ \\n\+ \commit b4b306d1472bba4ea7bfcf743eb7e770e2e2aa9f\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Fri Jun 7 22:10:04 2013 +0900\n\+ \\n\+ \ Need import Prelude hiding (catch) for GHC 7.4.\n\+ \\n\+ \commit 7ae0f0c227d2c49f41c80e6192dbd038c3ee0416\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Fri Jun 7 21:47:23 2013 +0900\n\+ \\n\+ \ Now run cabal haddock by hand.\n\+ \\n\+ \commit c6044d3b4c10aa3d5b0300684be07167f0a5e8e1\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Fri Jun 7 21:42:20 2013 +0900\n\+ \\n\+ \ Split library and program.\n\+ \\n\+ \commit f5fdf2ba0f79beab7d3cb1ef4cc3180c45d7def2\n\+ \Merge: b6d58e9 c019aa0\n\+ \Author: Kiwamu Okabe <kiwamu@gmail.com>\n\+ \Date: Wed Jun 5 08:55:48 2013 -0700\n\+ \\n\+ \ Merge pull request #19 from master-q/feature/reentrant1\n\+ \ \n\+ \ Feature/reentrant1: Add arity \"arena\" to all functions. (Sometime selftest has fail without problem.)\n\+ \\n\+ \commit c019aa02764309b0a3364a7f54d41e671ca2b99a\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Thu Jun 6 00:24:02 2013 +0900\n\+ \\n\+ \ Pass rtstest, again.\n\+ \\n\+ \commit f5aa9f87a0ad724830f3326123fabbf85995d5b5\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Thu Jun 6 00:19:33 2013 +0900\n\+ \\n\+ \ Pass rtstest.\n\+ \\n\+ \commit 4f8a185bace5562e16fb9fb803a8db9d43578d54\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Wed Jun 5 22:27:31 2013 +0900\n\+ \\n\+ \ Add arity \"arena\" to all functions.\n\+ \\n\+ \commit 73cedc4842866f48590ce191b3f79ea8392aba16\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Wed Jun 5 16:31:54 2013 +0900\n\+ \\n\+ \ Assign FunPtr as CTYPE \"HsFunPtr\".\n\+ \\n\+ \commit b6d58e95e63be9848f267e9242dedff5e5f7b25b\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Mon May 27 20:07:23 2013 +0900\n\+ \\n\+ \ Better NAIVEGC.\n\+ \\n\+ \commit 31c207fd41d9a9dc1209453606db37818045d29c\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Thu May 23 21:23:53 2013 +0900\n\+ \\n\+ \ Update Future plan.\n\+ \\n\+ \commit 2f6663bff4abee55619f2a79b46b3dbb1ae11721\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Thu May 23 18:30:52 2013 +0900\n\+ \\n\+ \ Run SelfTest with only 1 thread, and output plain text log.\n\+ \\n\+ \commit 8e48fc97986e7ad0c700fdaa032a4bffc4493ebb\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Wed May 22 20:36:05 2013 +0900\n\+ \\n\+ \ Run testInfo and testBinary using hunit.\n\+ \\n\+ \commit 078461ca2dac8b8334f568f7197afc42eab0cd41\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Wed May 22 20:23:24 2013 +0900\n\+ \\n\+ \ SelfTest uses test-framework-th library.\n\+ \\n\+ \commit 4158f4b51a5a3a7a3a6a20b5d394a8c44fb0c455\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Wed May 22 16:02:10 2013 +0900\n\+ \\n\+ \ Skip the regress tests fail now.\n\+ \\n\+ \commit 715083aaed642271fc286eca50c98bb74283bf1b\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Wed May 22 14:48:32 2013 +0900\n\+ \\n\+ \ regress.prl should return error when regress test error occured.\n\+ \\n\+ \commit 6759d23c08c84ae7bb0ead556049643c81cbf2d5\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Tue May 21 23:40:00 2013 +0900\n\+ \\n\+ \ Swap running install libs and testing on travis-ci.\n\+ \\n\+ \commit f5db932fbd357a8330bea4daa0a770c108816c4f\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Tue May 21 23:10:02 2013 +0900\n\+ \\n\+ \ Need valgrind to run rtstest.\n\+ \\n\+ \commit 667106896171c441024fcd0e13c3e9d95edc5e51\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Tue May 21 23:02:22 2013 +0900\n\+ \\n\+ \ jhc_test and stableptr_test return number of fail.\n\+ \\n\+ \commit ea8de920f1714b7183315fd0192cbdb6b79ab132\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Tue May 21 22:08:07 2013 +0900\n\+ \\n\+ \ Run rtstest on travis-ci.\n\+ \\n\+ \commit cfee75da539badf3b673614a902a22c4805539e8\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Wed May 15 09:23:08 2013 +0900\n\+ \\n\+ \ Run selftest on travis-ci.\n\+ \\n\+ \commit feb47bbaf5e110fdebfb544d505809622b254653\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Wed May 15 09:19:22 2013 +0900\n\+ \\n\+ \ Modify name.acc selftest code to pass it.\n\+ \\n\+ \commit b2c52edba05eb0ca88132a08ed4b78342c515747\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sun Apr 28 17:12:28 2013 +0900\n\+ \\n\+ \ No need sudo for cabal install.\n\+ \\n\+ \commit 6349fd5304cf68d541538a066af73e6c9165938e\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sun Apr 28 17:08:51 2013 +0900\n\+ \\n\+ \ GNU make same as Cabal.\n\+ \\n\+ \commit c2fcf3d4efa07925c0a92f0baf80bd5d998962eb\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sun Apr 28 04:17:11 2013 +0900\n\+ \\n\+ \ More gitignore entries.\n\+ \\n\+ \commit 534d3fff7f85e48a9bc2f0c80ea35f8f296d7452\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sun Apr 28 04:00:09 2013 +0900\n\+ \\n\+ \ Slim Makefile.\n\+ \\n\+ \commit 3968daca16d6e1524f899c07bbd81f931b7053cc\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sun Apr 28 01:47:09 2013 +0900\n\+ \\n\+ \ Run apt-get install libghc-temporary-dev libghc-haskeline-dev.\n\+ \\n\+ \commit be7b6dcb59df974f3b25e4b002fe1cc65565a459\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sun Apr 28 01:42:44 2013 +0900\n\+ \\n\+ \ Use cabal to compile me and run regress test.\n\+ \\n\+ \commit f1581ea0ac987b4d612160db1bc17d8159f55f29\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sat Apr 27 22:54:10 2013 +0900\n\+ \\n\+ \ Add jahm command to download file from Hackage DB.\n\+ \ \n\+ \ Usage: jahm downloadURI http://hackage.haskell.org/packages/archive/network/2.4.1.2/network-2.4.1.2.tar.gz network-2.4.1.2.tar.gz\n\+ \\n\+ \commit d945f1e72c54674abc1d4d04c066bdc637e34610\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sat Apr 27 22:24:07 2013 +0900\n\+ \\n\+ \ Jahm is cmpilable.\n\+ \\n\+ \commit 1de6d91b13a6b50f67a9aef9b7f91f21c278ee5c\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sat Apr 27 21:24:21 2013 +0900\n\+ \\n\+ \ Copy from cabal source code.\n\+ \\n\+ \commit d2cc0fde608a0c3362a35a59f8b7eed080707efb\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sat Apr 27 21:09:59 2013 +0900\n\+ \\n\+ \ Copy from cabal source code.\n\+ \\n\+ \commit 6d91389f1d7f95cb005d41382a8d6a15d0eccaf3\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Fri Apr 19 18:51:23 2013 +0900\n\+ \\n\+ \ Add dummy dir and symlink to avoid CI error on travis-ci.\n\+ \\n\+ \commit 40348972bb1c7e38effd8316bcd3135690b7f65b\n\+ \Author: Kiwamu Okabe <kiwamu@gmail.com>\n\+ \Date: Fri Apr 19 18:13:30 2013 +0900\n\+ \\n\+ \ Update README.md\n\+ \\n\+ \commit 2963a3de703474e85a033b80b6bdf14baa34a5af\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Mon Apr 15 10:56:52 2013 +0900\n\+ \\n\+ \ Use metasepi.org domain name.\n\+ \\n\+ \commit 1953685c18607d349485d6dc679838d9bb5e03b7\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Mon Apr 8 02:05:26 2013 +0900\n\+ \\n\+ \ Add script to dump debug infomation.\n\+ \\n\+ \commit a2d14fd969d51e6abdbc508e04ed97a029be5bb5\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sun Apr 7 22:14:18 2013 +0900\n\+ \\n\+ \ Too big stack for nofib.digits-of-e1 regress test.\n\+ \\n\+ \commit 71346a8fbb2bf9496ea03975a31aee5f80b7ea3d\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sun Apr 7 21:50:21 2013 +0900\n\+ \\n\+ \ Use ulimit command on bash.\n\+ \\n\+ \commit 6b7980c83a9ea17803876b5e80b166ef272fd19c\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sun Apr 7 21:42:48 2013 +0900\n\+ \\n\+ \ Run limit on travis-ci.\n\+ \\n\+ \commit ef68ae77fd85be4129974abe007ccac653aa0a35\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sun Apr 7 20:15:39 2013 +0900\n\+ \\n\+ \ Show meminfo on travis-ci.\n\+ \\n\+ \commit 4ff787bdaba39c411fb585ae4da5047c94a1d751\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sat Apr 6 17:16:12 2013 +0900\n\+ \\n\+ \ The selftest is runnable. But it catches error.\n\+ \\n\+ \commit 97c6427a1547b2c95f88788665f365c3a83e75b0\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sat Apr 6 16:50:52 2013 +0900\n\+ \\n\+ \ Umm.... I think we cann't use wine on travis-ci...\n\+ \\n\+ \commit 600ab13e6ae2817c6cc61a82cef95b5400fbd013\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sat Apr 6 16:43:41 2013 +0900\n\+ \\n\+ \ Run apt-get update before apt-get install.\n\+ \\n\+ \commit bf252a1283275600ed04e10120324bfb704170b9\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sat Apr 6 16:26:57 2013 +0900\n\+ \\n\+ \ Test for travis-ci.\n\+ \\n\+ \commit c10e974cb2a7e20de8893e70e7e30d7c32236748\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sat Apr 6 16:18:53 2013 +0900\n\+ \\n\+ \ Can I use wine on travis-ci? (test)\n\+ \\n\+ \commit 63e18e0c5009d624496af86ea8f0bb401d3a2a64\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sat Apr 6 16:06:43 2013 +0900\n\+ \\n\+ \ MinGW32 settings for passing rts/HelloWorld_win regress test.\n\+ \\n\+ \commit ea94b5db63d8ef2d3e90583ed27fc760d30243e9\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Sat Apr 6 02:20:33 2013 +0900\n\+ \\n\+ \ Find mingw-w64.\n\+ \\n\+ \commit 8003050e52ddf37c912158623114176769cce6a8\n\+ \Merge: 9aec7cb 2dc68c4\n\+ \Author: Kiwamu Okabe <kiwamu@gmail.com>\n\+ \Date: Fri Apr 5 07:53:54 2013 -0700\n\+ \\n\+ \ Merge pull request #11 from stepcut/arafura\n\+ \ \n\+ \ Thank's!\n\+ \\n\+ \commit 2dc68c441550d09ea573da7a8800455ca4ab898e\n\+ \Author: stepcut <jeremy@n-heptane.com>\n\+ \Date: Fri Apr 5 08:32:42 2013 -0500\n\+ \\n\+ \ The rest of the of lookupEnv patch\n\+ \\n\+ \commit 9aec7cb77a721ce09e59716ce0233daa23ee765c\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Fri Apr 5 19:19:31 2013 +0900\n\+ \\n\+ \ File src/Options.hs need getEnv function.\n\+ \\n\+ \commit 210da9343b6b7e38a89eb28f85602471a325647a\n\+ \Merge: ff0c404 7e958b3\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Fri Apr 5 19:10:39 2013 +0900\n\+ \\n\+ \ Merge branch 'arafura' of github.com:ajhc/ajhc into arafura\n\+ \\n\+ \commit 7e958b317eaa5473321b545f83ef06f440ac893b\n\+ \Merge: 474ebd5 aedd40c\n\+ \Author: Kiwamu Okabe <kiwamu@gmail.com>\n\+ \Date: Fri Apr 5 03:09:31 2013 -0700\n\+ \\n\+ \ Merge pull request #10 from stepcut/arafura\n\+ \ \n\+ \ use explicit import lists for System.Enviroment.\n\+ \\n\+ \commit aedd40cd8a6c55efcb485346598bcadcbc9d4b9e\n\+ \Author: stepcut <jeremy@n-heptane.com>\n\+ \Date: Fri Apr 5 00:26:03 2013 -0500\n\+ \\n\+ \ use explicit import lists for System.Enviroment to avoid conflicting definitions of lookupEnv.\n\+ \\n\+ \commit ff0c40426338e0ecb75cf6e4fb8c136da4bb103a\n\+ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\+ \Date: Thu Apr 4 02:21:18 2013 +0900\n\+ \\n\+ \ Bump up version 0.8.0.5.\n\+ \\n\ \commit 474ebd5aa9dc6497f078b8b1999f0cb8d1b2b85f\n\ \Author: Kiwamu Okabe <kiwamu@debian.or.jp>\n\ \Date: Thu Apr 4 02:17:45 2013 +0900\n\@@ -1825,7 +2173,7 @@ {-# NOINLINE shortchange_txt #-} shortchange_txt :: ByteString shortchange_txt = unsafePerformIO $ unsafePackAddress "\- \474ebd5aa9dc6497f078b8b1999f0cb8d1b2b85f\+ \702d796aea22d1129491bb49b66a8a9a4b8ef901\ \"# -- | Generated from rts\/rts\/slub.c@@ -2217,17 +2565,16 @@ \static char aligned_megablock_1[MEGABLOCK_SIZE] __attribute__ ((aligned(BLOCK_SIZE)));\n\ \static char gc_stack_base_area[(1UL << 8)*sizeof(gc_t)];\n\ \#endif\n\- \gc_t saved_gc;\n\- \struct s_arena *arena;\n\- \static gc_t gc_stack_base;\n\+ \gc_t saved_gc; /* xxx Remove me. */\n\+ \arena_t saved_arena; /* xxx Remove me. */\n\ \\n\ \#define TO_GCPTR(x) (entry_t *)(FROM_SPTR(x))\n\ \\n\- \void gc_perform_gc(gc_t gc) A_STD;\n\+ \void gc_perform_gc(gc_t gc, arena_t arena) A_STD;\n\ \static bool s_set_used_bit(void *val) A_UNUSED;\n\- \static void clear_used_bits(struct s_arena *arena) A_UNUSED;\n\- \static void s_cleanup_blocks(struct s_arena *arena);\n\- \static struct s_block *get_free_block(gc_t gc, struct s_arena *arena);\n\+ \static void clear_used_bits(arena_t arena) A_UNUSED;\n\+ \static void s_cleanup_blocks(arena_t arena);\n\+ \static struct s_block *get_free_block(gc_t gc, arena_t arena, bool retry);\n\ \static void *jhc_aligned_alloc(unsigned size);\n\ \\n\ \typedef struct {\n\@@ -2275,7 +2622,7 @@ \\n\ \static struct stack root_stack = EMPTY_STACK;\n\ \\n\- \void gc_add_root(gc_t gc, void *root)\n\+ \void gc_add_root(gc_t gc, arena_t arena, void *root)\n\ \{\n\ \ if(IS_PTR(root)) {\n\ \ entry_t *nroot = TO_GCPTR(root);\n\@@ -2295,17 +2642,17 @@ \}\n\ \\n\ \void A_STD\n\- \gc_perform_gc(gc_t gc)\n\+ \gc_perform_gc(gc_t gc, arena_t arena)\n\ \{\n\ \ profile_push(&gc_gc_time);\n\- \ arena->number_gcs++;\n\+ \ saved_arena->number_gcs++;\n\ \\n\ \ unsigned number_redirects = 0;\n\ \ unsigned number_stack = 0;\n\ \ unsigned number_ptr = 0;\n\ \ struct stack stack = EMPTY_STACK;\n\ \\n\- \ clear_used_bits(arena);\n\+ \ clear_used_bits(saved_arena);\n\ \\n\ \ debugf(\"Setting Roots:\");\n\ \ stack_check(&stack, root_stack.ptr);\n\@@ -2322,12 +2669,12 @@ \\n\ \ debugf(\"\\n\");\n\ \ debugf(\"Trace:\");\n\- \ stack_check(&stack, gc - gc_stack_base);\n\- \ number_stack = gc - gc_stack_base;\n\+ \ stack_check(&stack, gc - saved_arena->gc_stack_base);\n\+ \ number_stack = gc - saved_arena->gc_stack_base;\n\ \ for(unsigned i = 0; i < number_stack; i++) {\n\ \ debugf(\" |\");\n\ \ // TODO - short circuit redirects on stack\n\- \ sptr_t ptr = gc_stack_base[i];\n\+ \ sptr_t ptr = saved_arena->gc_stack_base[i];\n\ \ if(1 && (IS_LAZY(ptr))) {\n\ \ assert(GET_PTYPE(ptr) == P_LAZY);\n\ \ VALGRIND_MAKE_MEM_DEFINED(FROM_SPTR(ptr), sizeof(uintptr_t));\n\@@ -2376,19 +2723,19 @@ \ }\n\ \ }\n\ \ free(stack.stack);\n\- \ s_cleanup_blocks(arena);\n\+ \ s_cleanup_blocks(saved_arena);\n\ \ if (JHC_STATUS) {\n\ \ fprintf(stderr, \"%3u - %6u Used: %4u Thresh: %4u Ss: %5u Ps: %5u Rs: %5u Root: %3u\\n\",\n\- \ arena->number_gcs,\n\- \ arena->number_allocs,\n\- \ (unsigned)arena->block_used,\n\- \ (unsigned)arena->block_threshold,\n\+ \ saved_arena->number_gcs,\n\+ \ saved_arena->number_allocs,\n\+ \ (unsigned)saved_arena->block_used,\n\+ \ (unsigned)saved_arena->block_threshold,\n\ \ number_stack,\n\ \ number_ptr,\n\ \ number_redirects,\n\ \ (unsigned)root_stack.ptr\n\ \ );\n\- \ arena->number_allocs = 0;\n\+ \ saved_arena->number_allocs = 0;\n\ \ }\n\ \ profile_pop(&gc_gc_time);\n\ \}\n\@@ -2403,12 +2750,12 @@ \void\n\ \jhc_alloc_init(void) {\n\ \ VALGRIND_PRINTF(\"Jhc-Valgrind mode active.\\n\");\n\+ \ saved_arena = new_arena();\n\ \#ifdef _JHC_JGC_FIXED_MEGABLOCK\n\- \ saved_gc = gc_stack_base = (void *) gc_stack_base_area;\n\+ \ saved_gc = saved_arena->gc_stack_base = (void *) gc_stack_base_area;\n\ \#else\n\- \ saved_gc = gc_stack_base = malloc((1UL << 18)*sizeof(gc_stack_base[0]));\n\+ \ saved_gc = saved_arena->gc_stack_base = malloc((1UL << 18)*sizeof(saved_arena->gc_stack_base[0]));\n\ \#endif\n\- \ arena = new_arena();\n\ \ if(nh_stuff[0]) {\n\ \ nh_end = nh_start = nh_stuff[0];\n\ \ for(int i = 1; nh_stuff[i]; i++) {\n\@@ -2418,36 +2765,32 @@ \ nh_end = nh_stuff[i];\n\ \ }\n\ \ }\n\- \ for (int i = 0; i < GC_STATIC_ARRAY_NUM; i++) {\n\- \ find_cache(&array_caches[i], arena, i + 1, i + 1);\n\- \ find_cache(&array_caches_atomic[i], arena, i + 1, 0);\n\- \ }\n\ \}\n\ \\n\ \void\n\ \jhc_alloc_fini(void) {\n\ \ if(_JHC_PROFILE || JHC_STATUS) {\n\- \ fprintf(stderr, \"arena: %p\\n\", arena);\n\- \ fprintf(stderr, \" block_used: %i\\n\", arena->block_used);\n\- \ fprintf(stderr, \" block_threshold: %i\\n\", arena->block_threshold);\n\+ \ fprintf(stderr, \"arena: %p\\n\", saved_arena);\n\+ \ fprintf(stderr, \" block_used: %i\\n\", saved_arena->block_used);\n\+ \ fprintf(stderr, \" block_threshold: %i\\n\", saved_arena->block_threshold);\n\ \ struct s_cache *sc;\n\- \ SLIST_FOREACH(sc,&arena->caches,next)\n\+ \ SLIST_FOREACH(sc,&saved_arena->caches,next)\n\ \ print_cache(sc);\n\ \ }\n\ \}\n\ \\n\ \heap_t A_STD\n\- \(gc_alloc)(gc_t gc,struct s_cache **sc, unsigned count, unsigned nptrs)\n\+ \(gc_alloc)(gc_t gc, arena_t arena, struct s_cache **sc, unsigned count, unsigned nptrs)\n\ \{\n\ \ assert(nptrs <= count);\n\- \ entry_t *e = s_alloc(gc, find_cache(sc, arena, count, nptrs));\n\+ \ entry_t *e = s_alloc(gc, arena, find_cache(sc, saved_arena, count, nptrs));\n\ \ VALGRIND_MAKE_MEM_UNDEFINED(e,sizeof(uintptr_t)*count);\n\ \ debugf(\"gc_alloc: %p %i %i\\n\",(void *)e, count, nptrs);\n\ \ return (void *)e;\n\ \}\n\ \\n\ \static heap_t A_STD\n\- \s_monoblock(struct s_arena *arena, unsigned size, unsigned nptrs, unsigned flags) {\n\+ \s_monoblock(arena_t arena, unsigned size, unsigned nptrs, unsigned flags) {\n\ \ struct s_block *b = jhc_aligned_alloc(size * sizeof(uintptr_t));\n\ \ b->flags = flags | SLAB_MONOLITH;\n\ \ b->color = (sizeof(struct s_block) + BITARRAY_SIZE_IN_BYTES(1) +\n\@@ -2461,30 +2804,30 @@ \// Allocate an array of count garbage collectable locations in the garbage\n\ \// collected heap.\n\ \heap_t A_STD\n\- \gc_array_alloc(gc_t gc, unsigned count)\n\+ \gc_array_alloc(gc_t gc, arena_t arena, unsigned count)\n\ \{\n\ \ if (!count)\n\ \ return NULL;\n\ \ if (count <= GC_STATIC_ARRAY_NUM)\n\- \ return (wptr_t)s_alloc(gc,array_caches[count - 1]);\n\+ \ return (wptr_t)s_alloc(gc, arena,array_caches[count - 1]);\n\ \ if (count < GC_MAX_BLOCK_ENTRIES)\n\- \ return s_alloc(gc, find_cache(NULL, arena, count, count));\n\- \ return s_monoblock(arena, count, count, 0);\n\+ \ return s_alloc(gc, arena, find_cache(NULL, saved_arena, count, count));\n\+ \ return s_monoblock(saved_arena, count, count, 0);\n\ \ abort();\n\ \}\n\ \\n\ \// Allocate an array of count non-garbage collectable locations in the garbage\n\ \// collected heap.\n\ \heap_t A_STD\n\- \gc_array_alloc_atomic(gc_t gc, unsigned count, unsigned flags)\n\+ \gc_array_alloc_atomic(gc_t gc, arena_t arena, unsigned count, unsigned flags)\n\ \{\n\ \ if (!count)\n\ \ return NULL;\n\ \ if (count <= GC_STATIC_ARRAY_NUM && !flags)\n\- \ return (wptr_t)s_alloc(gc,array_caches_atomic[count - 1]);\n\+ \ return (wptr_t)s_alloc(gc, arena, array_caches_atomic[count - 1]);\n\ \ if (count < GC_MAX_BLOCK_ENTRIES && !flags)\n\- \ return s_alloc(gc, find_cache(NULL, arena, count, 0));\n\- \ return s_monoblock(arena, count, count, flags);\n\+ \ return s_alloc(gc, arena, find_cache(NULL, saved_arena, count, 0));\n\+ \ return s_monoblock(saved_arena, count, count, flags);\n\ \ abort();\n\ \}\n\ \\n\@@ -2532,7 +2875,7 @@ \}\n\ \\n\ \struct s_megablock *\n\- \s_new_megablock(struct s_arena *arena)\n\+ \s_new_megablock(arena_t arena)\n\ \{\n\ \ struct s_megablock *mb = malloc(sizeof(*mb));\n\ \#ifdef _JHC_JGC_FIXED_MEGABLOCK\n\@@ -2553,16 +2896,21 @@ \/* block allocator */\n\ \\n\ \static struct s_block *\n\- \get_free_block(gc_t gc, struct s_arena *arena) {\n\+ \get_free_block(gc_t gc, arena_t arena, bool retry) {\n\ \ arena->block_used++;\n\ \ if(__predict_true(SLIST_FIRST(&arena->free_blocks))) {\n\ \ struct s_block *pg = SLIST_FIRST(&arena->free_blocks);\n\ \ SLIST_REMOVE_HEAD(&arena->free_blocks,link);\n\ \ return pg;\n\ \ } else {\n\- \#ifndef _JHC_JGC_NAIVEGC\n\+ \#ifdef _JHC_JGC_NAIVEGC\n\+ \ if(retry == false) {\n\+ \ gc_perform_gc(gc, arena);\n\+ \ return NULL;\n\+ \ }\n\+ \#else\n\ \ if((arena->block_used >= arena->block_threshold)) {\n\- \ gc_perform_gc(gc);\n\+ \ gc_perform_gc(gc, arena);\n\ \ // if we are still using 80% of the heap after a gc, raise the threshold.\n\ \ if(__predict_false((unsigned)arena->block_used * 10 >= arena->block_threshold * 9)) {\n\ \ arena->block_threshold *= 2;\n\@@ -2592,7 +2940,7 @@ \}\n\ \\n\ \static void\n\- \s_cleanup_blocks(struct s_arena *arena) {\n\+ \s_cleanup_blocks(arena_t arena) {\n\ \ struct s_block *pg = SLIST_FIRST(&arena->monolithic_blocks);\n\ \ SLIST_INIT(&arena->monolithic_blocks);\n\ \ while (pg) {\n\@@ -2687,21 +3035,22 @@ \ */\n\ \\n\ \heap_t A_STD\n\- \s_alloc(gc_t gc, struct s_cache *sc)\n\+ \s_alloc(gc_t gc, arena_t arena, struct s_cache *sc)\n\ \{\n\ \#if _JHC_PROFILE\n\ \ sc->allocations++;\n\ \ sc->arena->number_allocs++;\n\ \#endif\n\- \ struct s_block *pg = SLIST_FIRST(&sc->blocks);\n\- \#ifdef _JHC_JGC_NAIVEGC\n\- \ if(__predict_false(!pg)) {\n\- \ gc_perform_gc(gc);\n\- \ pg = SLIST_FIRST(&sc->blocks);\n\- \ }\n\- \#endif\n\+ \ bool retry = false;\n\+ \ struct s_block *pg;\n\+ \retry_s_alloc:\n\+ \ pg = SLIST_FIRST(&sc->blocks);\n\ \ if(__predict_false(!pg)) {\n\- \ pg = get_free_block(gc, sc->arena);\n\+ \ pg = get_free_block(gc, sc->arena, retry);\n\+ \ if(__predict_false(!pg)) {\n\+ \ retry = true;\n\+ \ goto retry_s_alloc;\n\+ \ }\n\ \ VALGRIND_MAKE_MEM_NOACCESS(pg, BLOCK_SIZE);\n\ \ VALGRIND_MAKE_MEM_DEFINED(pg, sizeof(struct s_block));\n\ \ if(sc->num_entries != pg->u.pi.num_free)\n\@@ -2741,7 +3090,7 @@ \}\n\ \\n\ \struct s_cache *\n\- \new_cache(struct s_arena *arena, unsigned short size, unsigned short num_ptrs)\n\+ \new_cache(arena_t arena, unsigned short size, unsigned short num_ptrs)\n\ \{\n\ \ struct s_cache *sc = malloc(sizeof(*sc));\n\ \ memset(sc,0,sizeof(*sc));\n\@@ -2761,7 +3110,7 @@ \\n\ \// clear all used bits, must be followed by a marking phase.\n\ \static void\n\- \clear_used_bits(struct s_arena *arena)\n\+ \clear_used_bits(arena_t arena)\n\ \{\n\ \ struct s_block *pg;\n\ \ SLIST_FOREACH(pg, &arena->monolithic_blocks, link)\n\@@ -2800,7 +3149,7 @@ \}\n\ \\n\ \struct s_cache *\n\- \find_cache(struct s_cache **rsc, struct s_arena *arena,\n\+ \find_cache(struct s_cache **rsc, arena_t arena,\n\ \ unsigned short size, unsigned short num_ptrs)\n\ \{\n\ \ if(__predict_true(rsc && *rsc))\n\@@ -2817,9 +3166,9 @@ \ return sc;\n\ \}\n\ \\n\- \struct s_arena *\n\+ \arena_t\n\ \new_arena(void) {\n\- \ struct s_arena *arena = malloc(sizeof(struct s_arena));\n\+ \ arena_t arena = malloc(sizeof(struct s_arena));\n\ \ SLIST_INIT(&arena->caches);\n\ \ SLIST_INIT(&arena->free_blocks);\n\ \ SLIST_INIT(&arena->megablocks);\n\@@ -2827,6 +3176,11 @@ \ arena->block_used = 0;\n\ \ arena->block_threshold = 8;\n\ \ arena->current_megablock = NULL;\n\+ \\n\+ \ for (int i = 0; i < GC_STATIC_ARRAY_NUM; i++) {\n\+ \ find_cache(&array_caches[i], arena, i + 1, i + 1);\n\+ \ find_cache(&array_caches_atomic[i], arena, i + 1, 0);\n\+ \ }\n\ \ return arena;\n\ \}\n\ \\n\@@ -2855,7 +3209,7 @@ \ // no finalizers yet\n\ \ assert (!finalizer);\n\ \ unsigned spacing = 1 + finalizer;\n\- \ wptr_t *res = gc_array_alloc_atomic(saved_gc, spacing + TO_BLOCKS(size),\n\+ \ wptr_t *res = gc_array_alloc_atomic(saved_gc, saved_arena, spacing + TO_BLOCKS(size),\n\ \ finalizer ? SLAB_FLAG_FINALIZER : SLAB_FLAG_NONE);\n\ \ res[0] = (wptr_t)(res + spacing);\n\ \ if (finalizer)\n\@@ -2865,7 +3219,7 @@ \\n\ \heap_t A_STD\n\ \gc_new_foreignptr(HsPtr ptr) {\n\- \ HsPtr *res = gc_array_alloc_atomic(saved_gc, 2, SLAB_FLAG_FINALIZER);\n\+ \ HsPtr *res = gc_array_alloc_atomic(saved_gc, saved_arena, 2, SLAB_FLAG_FINALIZER);\n\ \ res[0] = ptr;\n\ \ res[1] = NULL;\n\ \ return TO_SPTR(P_WHNF, res);\n\@@ -2910,7 +3264,7 @@ \}\n\ \\n\ \void hs_perform_gc(void) {\n\- \ gc_perform_gc(saved_gc);\n\+ \ gc_perform_gc(saved_gc, saved_arena);\n\ \}\n\ \\n\ \#endif\n\@@ -2931,6 +3285,7 @@ \struct sptr;\n\ \struct s_arena;\n\ \struct s_cache;\n\+ \typedef struct s_arena *arena_t;\n\ \typedef void* *gc_t;\n\ \typedef void* heap_t; // a pointer into the GCed heap.\n\ \\n\@@ -2950,23 +3305,23 @@ \#define S_BLOCK(val) ((struct s_block *)((uintptr_t)(val) & ~(BLOCK_SIZE - 1)))\n\ \#define TO_BLOCKS(x) (((x) + sizeof(uintptr_t) - 1)/sizeof(uintptr_t))\n\ \\n\- \extern struct s_arena *arena;\n\+ \extern arena_t saved_arena;\n\ \extern gc_t saved_gc;\n\ \\n\ \void print_cache(struct s_cache *sc);\n\- \struct s_cache *new_cache(struct s_arena *arena, unsigned short size,\n\+ \struct s_cache *new_cache(arena_t arena, unsigned short size,\n\ \ unsigned short num_ptrs);\n\- \struct s_arena *new_arena(void);\n\- \struct s_cache *find_cache(struct s_cache **rsc, struct s_arena *arena,\n\+ \arena_t new_arena(void);\n\+ \struct s_cache *find_cache(struct s_cache **rsc, arena_t arena,\n\ \ unsigned short size, unsigned short num_ptrs);\n\- \void gc_add_root(gc_t gc, void * root);\n\- \void A_STD gc_perform_gc(gc_t gc);\n\+ \void gc_add_root(gc_t gc, arena_t arena, void * root);\n\+ \void A_STD gc_perform_gc(gc_t gc, arena_t arena);\n\ \uint32_t get_heap_flags(void* sp);\n\ \\n\- \heap_t s_alloc(gc_t gc, struct s_cache *sc) A_STD;\n\- \heap_t (gc_alloc)(gc_t gc,struct s_cache **sc, unsigned count, unsigned nptrs) A_STD;\n\- \heap_t gc_array_alloc(gc_t gc, unsigned count) A_STD;\n\- \heap_t gc_array_alloc_atomic(gc_t gc, unsigned count, unsigned slab_flags) A_STD;\n\+ \heap_t s_alloc(gc_t gc, arena_t arena, struct s_cache *sc) A_STD;\n\+ \heap_t (gc_alloc)(gc_t gc, arena_t arena,struct s_cache **sc, unsigned count, unsigned nptrs) A_STD;\n\+ \heap_t gc_array_alloc(gc_t gc, arena_t arena, unsigned count) A_STD;\n\+ \heap_t gc_array_alloc_atomic(gc_t gc, arena_t arena, unsigned count, unsigned slab_flags) A_STD;\n\ \/* foreignptr, saved_gc must be set properly. */\n\ \heap_t gc_malloc_foreignptr(unsigned alignment, unsigned size, bool finalizer) A_STD;\n\ \heap_t gc_new_foreignptr(HsPtr ptr) A_STD;\n\@@ -3716,7 +4071,7 @@ \#include \"jhc_rts_header.h\"\n\ \\n\ \#if _JHC_GC == _JHC_GC_JGC\n\- \typedef wptr_t (*eval_fn)(gc_t gc,node_t *node) A_STD;\n\+ \typedef wptr_t (*eval_fn)(gc_t gc,arena_t arena,node_t *node) A_STD;\n\ \#else\n\ \typedef wptr_t (*eval_fn)(node_t *node) A_STD;\n\ \#endif\n\@@ -3736,7 +4091,7 @@ \\n\ \wptr_t A_STD A_UNUSED A_HOT\n\ \#if _JHC_GC == _JHC_GC_JGC\n\- \eval(gc_t gc,sptr_t s)\n\+ \eval(gc_t gc,arena_t arena,sptr_t s)\n\ \#else\n\ \eval(sptr_t s)\n\ \#endif\n\@@ -3755,7 +4110,7 @@ \#endif\n\ \ fn = (eval_fn)SET_THUMB_BIT(fn);\n\ \#if _JHC_GC == _JHC_GC_JGC\n\- \ wptr_t r = (*fn)(gc,NODEP(ds));\n\+ \ wptr_t r = (*fn)(gc,arena,NODEP(ds));\n\ \#else\n\ \ wptr_t r = (*fn)(NODEP(ds));\n\ \#endif\n\@@ -3860,7 +4215,7 @@ \\n\ \wptr_t A_STD\n\ \#if _JHC_GC == _JHC_GC_JGC\n\- \eval(gc_t gc,sptr_t s);\n\+ \eval(gc_t gc,arena_t arena,sptr_t s);\n\ \#else\n\ \eval(sptr_t s);\n\ \#endif\n\@@ -4109,6 +4464,7 @@ \ SLIST_HEAD(,s_megablock) megablocks;\n\ \ unsigned number_gcs; // number of garbage collections\n\ \ unsigned number_allocs; // number of allocations since last garbage collection\n\+ \ gc_t gc_stack_base;\n\ \};\n\ \\n\ \struct s_megablock {\n\
− src/Support/ShowTable.hs
@@ -1,24 +0,0 @@-module Support.ShowTable where--import List-import Monad-import qualified Data.Map as Map-import qualified Data.Set as Set--class ShowTable a where- showTablePairs :: a -> [(String,String)]--instance (Show a,Show b) => ShowTable [(a,b)] where- showTablePairs xs = [ (show x,show y) | (x,y) <- xs ]--instance (Show a,Show b) => ShowTable (Map.Map a b) where- showTablePairs xs = [ (show x,show y) | (x,y) <- Map.toList xs ]--instance Show a => ShowTable (Set.Set a) where- showTablePairs xs = [ (show x,"") | x <- Set.toList xs ]---printTable :: ShowTable a => String -> a -> IO ()-printTable title x = do- unless (null title) $ putStrLn (title ++ ":")- mapM_ putStrLn $ sort [ " " ++ x ++ (if null y then "" else " - " ++ y) | (x,y) <- showTablePairs x]
− src/Util/BooleanSolver.hs
@@ -1,246 +0,0 @@--- straightforward linear time solver for boolean constraints.--module Util.BooleanSolver(- CA(),- CV(..),- fromCA,- readValue,- groundConstraints,- processConstraints,- C(),- Result(..),- mkCA,- equals,- implies-- )where--import Monad-import Data.IORef-import Control.Monad.Trans-import Util.UnionFind-import Data.List(intersperse)-import Data.Monoid-import Data.Typeable-import qualified Data.Set as Set-import qualified Data.Map as Map-import Util.UnionFind as UF-import Data.FunctorM----type Seq x = [x] -> [x]--newtype C v = C (Seq (CL v))- deriving(Monoid)---instance Functor C where- fmap f (C v) = C (map (fmap f) (v []) ++)--data CV v = CFalse | CTrue | CJust v- deriving(Eq,Ord,Typeable)----data CL v = CV v `Cimplies` CV v- deriving(Eq,Ord)--instance (Show l) => Show (C l) where- showsPrec _ (C xs) = showString "(" . foldr (.) id (intersperse (showString ",") (map shows (xs []))) . showString ")"--instance Functor CL where- fmap f (x `Cimplies` y) = fmap f x `Cimplies` fmap f y--instance FunctorM CL where- fmapM f (x `Cimplies` y) = return Cimplies `ap` (fmapM f x) `ap` (fmapM f y)---instance Functor CV where- fmap f (CJust x) = CJust (f x)- fmap _ CTrue = CTrue- fmap _ CFalse = CFalse--instance FunctorM CV where- fmapM f (CJust x) = liftM CJust (f x)- fmapM _ CTrue = return CTrue- fmapM _ CFalse = return CFalse----instance Show v => Show (CV v) where- showsPrec n (CJust v) = showsPrec n v- showsPrec _ CTrue = showString "T"- showsPrec _ CFalse = showString "F"------instance (Show e) => Show (CL e) where- showsPrec d (CJust x `Cimplies` CJust y) = showParen (d > 9) $ showsPrec 10 x . showString " -> " . showsPrec 10 y- showsPrec d (CTrue `Cimplies` CJust y) = showParen (d > 9) $ showsPrec 10 y . showString " := T"- showsPrec d (CJust x `Cimplies` CFalse) = showParen (d > 9) $ showsPrec 10 x . showString " := F"- showsPrec d (x `Cimplies` y) = showParen (d > 9) $ showsPrec 10 x . showString " -> " . showsPrec 10 y------ basic constraints--implies,equals :: CV v -> CV v -> C v-implies x y = C ((x `Cimplies` y):)-equals x y = (x `implies` y) `mappend` (y `implies` x)----- a variable is either set to a value or bounded by other values-data Ri a = Ri (Set.Set (RS a)) (Set.Set (RS a))--type R a = CV (Ri a)--type RS a = (Element (R a) a)--newtype CA v = CA (RS v)--fromCA :: CA v -> v-fromCA (CA e) = fromElement e--readValue :: MonadIO m => CA v -> m (Result (CA v))-readValue (CA v) = liftIO $ do- v <- find v- w <- getW v- case w of- CTrue -> return ResultJust { resultValue = True }- CFalse -> return ResultJust { resultValue = False }- (CJust (Ri x y)) -> do- x <- findSet x- y <- findSet y- return (ResultBounded (CA v) (map CA $ Set.toList x) (map CA $ Set.toList y))----findSet :: Set.Set (Element a b) -> IO (Set.Set (Element a b))-findSet xs = mapM find (Set.toList xs) >>= return . Set.fromList---mkCA :: MonadIO m => v -> m (CA v)-mkCA v = do liftM CA $ new (CJust (Ri mempty mempty)) v---groundConstraints :: (MonadIO m,Ord v) => C v -> m (C (CA v), Map.Map v (CA v))-groundConstraints (C cs) = liftIO $ do- ref <- newIORef mempty- let ccs = cs []- nv v = do- r <- readIORef ref- case Map.lookup v r of- Just v -> return v- Nothing -> do- e <- liftM CA $ new (CJust (Ri mempty mempty)) v- writeIORef ref (Map.insert v e r)- return e- v <- fmapM (fmapM nv) ccs- rr <- readIORef ref- return (C (v ++),rr)----processConstraints :: (Show v,MonadIO m)- => Bool -- ^ whether to propagate subset/superset info. if you only care about fixed results you don't need to do this. if you care about residual constraints and equivalance classes after solving then you should set this.- -> C (CA v) -- ^ the input- -> m ()-processConstraints propagateSets (C cs) = mapM_ prule (cs []) where- prule (CFalse `Cimplies` _) = return ()- prule (_ `Cimplies` CTrue) = return ()- prule (CTrue `Cimplies` CFalse) = fail "invalid constraint: T -> F"- prule (CTrue `Cimplies` CJust (CA y)) = find y >>= set Nothing True- prule (CJust (CA x) `Cimplies` CFalse) = find x >>= set Nothing False- prule (CJust (CA x) `Cimplies` CJust (CA y)) | x == y = return ()- prule (CJust (CA x) `Cimplies` CJust (CA y)) = do x <- find x; y <- find y; pimp x y- pimp' :: (MonadIO m,Show a) => RS a -> RS a -> m ()- pimp' x y = do x <- find x; y <- find y; pimp x y- pimp x y | x == y = return ()- pimp x y = do- xv <- getW x- yv <- getW y- case (xv,yv) of- (CJust ra,CJust rb) -> liftIO $ implies x y ra rb- (CFalse,_) -> return ()- (_,CTrue) -> return ()- (CTrue,CFalse) -> fail $ "invalid constraint T -> F: " ++ show x ++ " -> " ++ show y- (CTrue,CJust _) -> set (Just x) True y- (CJust _,CFalse) -> set (Just y) False x-- set mu b xe = do- w <- getW xe- case (w,b) of- (CTrue,True) -> return ()- (CFalse,False) -> return ()- (CJust (Ri _ sh),True) -> do putW xe CTrue; mapM_ (set mu True) (Set.toList sh)- (CJust (Ri sl _),False) -> do putW xe CFalse; mapM_ (set mu False) (Set.toList sl)- _ -> fail $ "invalid constrant: " ++ show xe ++ " := " ++ show b- fmapM_ (union const xe) mu-- implies :: (MonadIO m,Show a) => RS a -> RS a -> Ri a -> Ri a -> m ()- implies xe ye ra rb = do- ra@(Ri xl xh) <- findRi xe ra- rb@(Ri yl yh) <- findRi ye rb- if xe `Set.member` yh then liftIO $ equals xe ye ra rb else do- if xe `Set.member` yl then return () else do- if ye `Set.member` xl then liftIO $ equals xe ye ra rb else do- if ye `Set.member` xh then return () else do- putW xe (CJust $ Ri xl (Set.insert ye xh))- putW ye (CJust $ Ri (Set.insert xe yl) yh)- when propagateSets $ mapM_ (pimp' xe) (Set.toList yh)- when propagateSets $ mapM_ (flip pimp' ye) (Set.toList xl)- return ()- findRi x (Ri l h) = do- l <- liftM Set.fromList (mapM find (Set.toList l))- h <- liftM Set.fromList (mapM find (Set.toList h))- return (Ri l h)- equals xe ye (Ri xl xh) (Ri yl yh) = do- let nl = (xl `mappend` yl)- let nh = (xh `mappend` yh)- union (\ _ _ -> CJust (Ri nl nh)) xe ye- when propagateSets $ do- Ri nl nh <- findRi xe (Ri nl nh)- putW xe (CJust $ Ri nl nh)- let eq = Set.intersection nl nh- flip mapM_ (Set.toList eq) $ \ne -> do- ne <- find ne- CJust ri <- getW ne- ri <- findRi ne ri- equals xe ne (Ri nl nh) ri- return ()- return () :: IO ()-----data Result a =- ResultJust {- resultValue :: Bool- }- | ResultBounded {- resultRep :: a,- resultLB ::[a],- resultUB ::[a]- }---instance Functor Result where- fmap f (ResultBounded x ys zs) = ResultBounded (f x) (map f ys) (map f zs)- fmap f (ResultJust x) = ResultJust x--instance (Show a) => Show (Result a) where- showsPrec _ x = (showResult x ++)--showResult (ResultJust l) = show l-showResult rb@ResultBounded {} = sb (resultLB rb) ++ " <= " ++ show (resultRep rb) ++ " <= " ++ sb (resultUB rb) where- sb n | null n = "_"- sb n = show n----collectVars (Cimplies x y:xs) = x:y:collectVars xs-collectVars [] = []-
src/Util/SHA1.hs view
@@ -23,7 +23,7 @@ -} -{-# OPTIONS -funbox-strict-fields -fglasgow-exts -fno-warn-name-shadowing -O2 #-}+{-# OPTIONS -funbox-strict-fields -fno-warn-name-shadowing -O2 #-} module Util.SHA1 (sha1String,sha1file,sha1Bytes,hashToBytes,sha1Handle,ABCDE(..),Hash,emptyHash) where @@ -59,7 +59,7 @@ sha1Bytes :: [Word8] -> Hash-sha1Bytes ss = unsafePerformIO $ do+sha1Bytes ss = System.IO.Unsafe.unsafePerformIO $ do let len = length ss plen = sha1_step_1_2_plength len allocaBytes plen $ \ptr -> do@@ -100,7 +100,7 @@ hClose h return hash -big_endian = unsafePerformIO $ do+big_endian = System.IO.Unsafe.unsafePerformIO $ do let x :: Word32 x = 0x12345678 s <- with x $ \ptr -> peekCStringLen (castPtr ptr,4)
src/Version/Config.hs view
@@ -1,7 +1,7 @@ module Version.Config where shortVersion = "0.8"-version = "0.8.0.4"+version = "0.8.0.5" package = "ajhc" libdir = "/usr/local/lib" datadir = "/usr/local/share"
src/data/targets.ini view
@@ -26,7 +26,7 @@ ; cross compilation entries [win32]-cc=i386-mingw32-gcc+cc=i686-w64-mingw32-gcc executable_extension=.exe merge=i686
+ src_jahm/Distribution/Client/HttpUtils.hs view
@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------+-- | Separate module for HTTP actions, using a proxy server if one exists +-----------------------------------------------------------------------------+module Distribution.Client.HttpUtils (+ downloadURI,+ getHTTP,+ cabalBrowse,+ proxy,+ isOldHackageURI+ ) where++import Network.HTTP+ ( Request (..), Response (..), RequestMethod (..)+ , Header(..), HeaderName(..) )+import Network.HTTP.Proxy ( Proxy(..), fetchProxy)+import Network.URI+ ( URI (..), URIAuth (..) )+import Network.Browser+ ( BrowserAction, browse+ , setOutHandler, setErrHandler, setProxy, setAuthorityGen, request)+import Network.Stream+ ( Result, ConnError(..) )+import Control.Monad+ ( liftM )+import qualified Data.ByteString.Lazy.Char8 as ByteString+import Data.ByteString.Lazy (ByteString)++import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils+ ( die, info, warn, debug+ , copyFileVerbose, writeFileAtomic )+import Distribution.Text+ ( display )+import Data.Char ( isSpace )+import qualified System.FilePath as FilePath.Posix+ ( splitDirectories )++-- Trime+trim :: String -> String+trim = f . f+ where f = reverse . dropWhile isSpace++-- |Get the local proxy settings +--TODO: print info message when we're using a proxy based on verbosity+proxy :: Verbosity -> IO Proxy+proxy _verbosity = do+ p <- fetchProxy True+ -- Handle empty proxy strings+ return $ case p of+ Proxy uri auth ->+ let uri' = trim uri in+ if uri' == "" then NoProxy else Proxy uri' auth+ _ -> p++mkRequest :: URI -> Request ByteString+mkRequest uri = Request{ rqURI = uri+ , rqMethod = GET+ , rqHeaders = [Header HdrUserAgent userAgent]+ , rqBody = ByteString.empty }+ where userAgent = "cabal-install/0.1(jahm)"++-- |Carry out a GET request, using the local proxy settings+getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString))+getHTTP verbosity uri = liftM (\(_, resp) -> Right resp) $+ cabalBrowse verbosity (return ()) (request (mkRequest uri))++cabalBrowse :: Verbosity+ -> BrowserAction s ()+ -> BrowserAction s a+ -> IO a+cabalBrowse verbosity auth act = do+ p <- proxy verbosity+ browse $ do+ setProxy p+ setErrHandler (warn verbosity . ("http error: "++))+ setOutHandler (debug verbosity)+ auth+ setAuthorityGen (\_ _ -> return Nothing)+ act++downloadURI :: Verbosity+ -> URI -- ^ What to download+ -> FilePath -- ^ Where to put it+ -> IO ()+downloadURI verbosity uri path | uriScheme uri == "file:" =+ copyFileVerbose verbosity (uriPath uri) path+downloadURI verbosity uri path = do+ result <- getHTTP verbosity uri+ let result' = case result of+ Left err -> Left err+ Right rsp -> case rspCode rsp of+ (2,0,0) -> Right (rspBody rsp)+ (a,b,c) -> Left err+ where+ err = ErrorMisc $ "Unsucessful HTTP code: "+ ++ concatMap show [a,b,c]++ case result' of+ Left err -> die $ "Failed to download " ++ show uri ++ " : " ++ show err+ Right body -> do+ info verbosity ("Downloaded to " ++ path)+ writeFileAtomic path body+ --FIXME: check the content-length header matches the body length.+ --TODO: stream the download into the file rather than buffering the whole+ -- thing in memory.+ -- remember the ETag so we can not re-download if nothing changed.++-- Utility function for legacy support.+isOldHackageURI :: URI -> Bool+isOldHackageURI uri+ = case uriAuthority uri of+ Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->+ FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"]+ _ -> False
+ src_jahm/Distribution/Compat/CopyFile.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}+module Distribution.Compat.CopyFile (+ copyFile,+ copyOrdinaryFile,+ copyExecutableFile,+ setFileOrdinary,+ setFileExecutable,+ setDirOrdinary,+ ) where+++import Control.Monad+ ( when )+import Control.Exception+ ( bracket, bracketOnError )+import Distribution.Compat.Exception+ ( catchIO )+import Distribution.Compat.Exception+ ( throwIOIO )+import System.IO.Error+ ( ioeSetLocation )+import System.Directory+ ( renameFile, removeFile )+import Distribution.Compat.TempFile+ ( openBinaryTempFile )+import System.FilePath+ ( takeDirectory )+import System.IO+ ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf )+import Foreign+ ( allocaBytes )++#ifndef mingw32_HOST_OS+import System.Posix.Internals (withFilePath)+import System.Posix.Types+ ( FileMode )+import System.Posix.Internals+ ( c_chmod )+import Foreign.C+ ( throwErrnoPathIfMinus1_ )+#endif /* mingw32_HOST_OS */++copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()+copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest+copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest++setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO ()+#ifndef mingw32_HOST_OS+setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r--+setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x++setFileMode :: FilePath -> FileMode -> IO ()+setFileMode name m =+ withFilePath name $ \s -> do+ throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)+#else+setFileOrdinary _ = return ()+setFileExecutable _ = return ()+#endif+-- This happens to be true on Unix and currently on Windows too:+setDirOrdinary = setFileExecutable++copyFile :: FilePath -> FilePath -> IO ()+copyFile fromFPath toFPath =+ copy+ `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile"))+ where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->+ bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->+ do allocaBytes bufferSize $ copyContents hFrom hTmp+ hClose hTmp+ renameFile tmpFPath toFPath+ openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"+ cleanTmp (tmpFPath, hTmp) = do+ hClose hTmp `catchIO` \_ -> return ()+ removeFile tmpFPath `catchIO` \_ -> return ()+ bufferSize = 4096++ copyContents hFrom hTo buffer = do+ count <- hGetBuf hFrom buffer bufferSize+ when (count > 0) $ do+ hPutBuf hTo buffer count+ copyContents hFrom hTo buffer
+ src_jahm/Distribution/Compat/Exception.hs view
@@ -0,0 +1,26 @@+module Distribution.Compat.Exception (+ Exception.IOException,+ onException,+ catchIO,+ catchExit,+ throwIOIO,+ tryIO,+ ) where++import System.Exit+import qualified Control.Exception as Exception++onException :: IO a -> IO b -> IO a+onException = Exception.onException++throwIOIO :: Exception.IOException -> IO a+throwIOIO = Exception.throwIO++tryIO :: IO a -> IO (Either Exception.IOException a)+tryIO = Exception.try++catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+catchIO = Exception.catch++catchExit :: IO a -> (ExitCode -> IO a) -> IO a+catchExit = Exception.catch
+ src_jahm/Distribution/Compat/TempFile.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}+module Distribution.Compat.TempFile (+ openTempFile,+ openBinaryTempFile,+ openNewBinaryFile,+ createTempDirectory,+ ) where+++import System.FilePath ((</>))+import Foreign.C (eEXIST)++import System.IO (Handle, openTempFile, openBinaryTempFile)+import Data.Bits ((.|.))+import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,+ o_BINARY, o_NONBLOCK, o_NOCTTY)+import System.IO.Error (isAlreadyExistsError)+import System.Posix.Internals (withFilePath)+import Foreign.C (CInt)+import GHC.IO.Handle.FD (fdToHandle)+import Distribution.Compat.Exception (onException, tryIO)+import Foreign.C (getErrno, errnoToIOError)++import System.Posix.Internals (c_getpid)++#ifdef mingw32_HOST_OS+import System.Directory ( createDirectory )+#else+import qualified System.Posix+#endif++-- ------------------------------------------------------------+-- * temporary files+-- ------------------------------------------------------------++-- This is here for Haskell implementations that do not come with+-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.+-- TODO: Not sure about jhc++-- This is a copy/paste of the openBinaryTempFile definition, but+-- if uses 666 rather than 600 for the permissions. The base library+-- needs to be changed to make this better.+openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)+openNewBinaryFile dir template = do+ pid <- c_getpid+ findTempName pid+ where+ -- We split off the last extension, so we can use .foo.ext files+ -- for temporary files (hidden on Unix OSes). Unfortunately we're+ -- below filepath in the hierarchy here.+ (prefix,suffix) =+ case break (== '.') $ reverse template of+ -- First case: template contains no '.'s. Just re-reverse it.+ (rev_suffix, "") -> (reverse rev_suffix, "")+ -- Second case: template contains at least one '.'. Strip the+ -- dot from the prefix and prepend it to the suffix (if we don't+ -- do this, the unique number will get added after the '.' and+ -- thus be part of the extension, which is wrong.)+ (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)+ -- Otherwise, something is wrong, because (break (== '.')) should+ -- always return a pair with either the empty string or a string+ -- beginning with '.' as the second component.+ _ -> error "bug in System.IO.openTempFile"++ oflags = rw_flags .|. o_EXCL .|. o_BINARY++ findTempName x = do+ fd <- withFilePath filepath $ \ f ->+ c_open f oflags 0o666+ if fd < 0+ then do+ errno <- getErrno+ if errno == eEXIST+ then findTempName (x+1)+ else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))+ else do+ -- TODO: We want to tell fdToHandle what the filepath is,+ -- as any exceptions etc will only be able to report the+ -- fd currently+ h <- fdToHandle fd `onException` c_close fd+ return (filepath, h)+ where+ filename = prefix ++ show x ++ suffix+ filepath = dir `combine` filename++ -- FIXME: bits copied from System.FilePath+ combine a b+ | null b = a+ | null a = b+ | last a == pathSeparator = a ++ b+ | otherwise = a ++ [pathSeparator] ++ b++-- FIXME: Should use filepath library+pathSeparator :: Char+#ifdef mingw32_HOST_OS+pathSeparator = '\\'+#else+pathSeparator = '/'+#endif++-- FIXME: Copied from GHC.Handle+std_flags, output_flags, rw_flags :: CInt+std_flags = o_NONBLOCK .|. o_NOCTTY+output_flags = std_flags .|. o_CREAT+rw_flags = output_flags .|. o_RDWR++createTempDirectory :: FilePath -> String -> IO FilePath+createTempDirectory dir template = do+ pid <- c_getpid+ findTempName pid+ where+ findTempName x = do+ let dirpath = dir </> template ++ "-" ++ show x+ r <- tryIO $ mkPrivateDir dirpath+ case r of+ Right _ -> return dirpath+ Left e | isAlreadyExistsError e -> findTempName (x+1)+ | otherwise -> ioError e++mkPrivateDir :: String -> IO ()+#ifdef mingw32_HOST_OS+mkPrivateDir s = createDirectory s+#else+mkPrivateDir s = System.Posix.createDirectory s 0o700+#endif
+ src_jahm/Distribution/Simple/Utils.hs view
@@ -0,0 +1,1055 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Simple.Utils+-- Copyright : Isaac Jones, Simon Marlow 2003-2004+-- portions Copyright (c) 2007, Galois Inc.+--+-- Maintainer : cabal-devel@haskell.org+-- Portability : portable+--+-- A large and somewhat miscellaneous collection of utility functions used+-- throughout the rest of the Cabal lib and in other tools that use the Cabal+-- lib like @cabal-install@. It has a very simple set of logging actions. It+-- has low level functions for running programs, a bunch of wrappers for+-- various directory and file functions that do extra logging.++{- All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Jones nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++module Distribution.Simple.Utils (+ -- * logging and errors+ die,+ dieWithLocation,+ topHandler,+ warn, notice, info, debug,+ debugNoWrap, chattyTry,++ -- * running programs+ rawSystemExit,+ rawSystemExitCode,+ rawSystemExitWithEnv,+ rawSystemStdout,+ rawSystemStdInOut,+ rawSystemIOWithEnv,+ maybeExit,+ xargs,+ findProgramLocation,++ -- * copying files+ createDirectoryIfMissingVerbose,+ copyFileVerbose,+ copyDirectoryRecursiveVerbose,+ copyFiles,++ -- * installing files+ installOrdinaryFile,+ installExecutableFile,+ installOrdinaryFiles,+ installDirectoryContents,++ -- * File permissions+ setFileOrdinary,+ setFileExecutable,++ -- * file names+ currentDir,++ -- * finding files+ findFile,+ findFirstFile,+ findFileWithExtension,+ findFileWithExtension',++ -- * environment variables+ isInSearchPath,++ -- * simple file globbing+ matchFileGlob,+ matchDirFileGlob,+ parseFileGlob,+ FileGlob(..),++ -- * temp files and dirs+ withTempFile,+ withTempDirectory,++ -- * .cabal and .buildinfo files+ defaultPackageDesc,+ findPackageDesc,+ defaultHookedPackageDesc,+ findHookedPackageDesc,++ -- * reading and writing files safely+ withFileContents,+ writeFileAtomic,+ rewriteFile,++ -- * Unicode+ fromUTF8,+ toUTF8,+ readUTF8File,+ withUTF8FileContents,+ writeUTF8File,+ normaliseLineEndings,++ -- * generic utils+ equating,+ comparing,+ isInfixOf,+ intercalate,+ lowercase,+ wrapText,+ wrapLine,+ ) where++import Control.Monad+ ( when, unless, filterM )+import Control.Concurrent.MVar+ ( newEmptyMVar, putMVar, takeMVar )+import Data.List+ ( nub, unfoldr, isPrefixOf, tails, intercalate )+import Data.Char as Char+ ( toLower, chr, ord )+import Data.Bits+ ( Bits((.|.), (.&.), shiftL, shiftR) )+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8++import System.Directory+ ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile+ , findExecutable )+import System.Environment+ ( getProgName )+import System.Cmd+ ( rawSystem )+import System.Exit+ ( exitWith, ExitCode(..) )+import System.FilePath+ ( normalise, (</>), (<.>)+ , getSearchPath, takeDirectory, splitFileName+ , splitExtension, splitExtensions, splitDirectories )+import System.Directory+ ( createDirectory, renameFile, removeDirectoryRecursive )+import System.IO+ ( Handle, openFile, openBinaryFile, openBinaryTempFile+ , IOMode(ReadMode), hSetBinaryMode+ , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )+import System.IO.Error as IO.Error+ ( isDoesNotExistError, isAlreadyExistsError+ , ioeSetFileName, ioeGetFileName, ioeGetErrorString )+import System.IO.Error+ ( ioeSetLocation, ioeGetLocation )+import System.IO.Unsafe+ ( unsafeInterleaveIO )+import qualified Control.Exception as Exception++import Distribution.Text+ ( display )++import Control.Exception (evaluate)+import System.Process (runProcess)++import Control.Concurrent (forkIO)+import System.Process (runInteractiveProcess, waitForProcess)+#if __GLASGOW_HASKELL__ >= 702+import System.Process (showCommandForUser)+#endif++import Distribution.Compat.CopyFile+ ( copyFile, copyOrdinaryFile, copyExecutableFile+ , setFileOrdinary, setFileExecutable, setDirOrdinary )+import Distribution.Compat.TempFile+ ( openTempFile, createTempDirectory )+import Distribution.Compat.Exception+ ( IOException, throwIOIO, tryIO, catchIO, catchExit )+import Distribution.Verbosity++-- ----------------------------------------------------------------------------+-- Exception and logging utils++dieWithLocation :: FilePath -> Maybe Int -> String -> IO a+dieWithLocation filename lineno msg =+ ioError . setLocation lineno+ . flip ioeSetFileName (normalise filename)+ $ userError msg+ where+ setLocation Nothing err = err+ setLocation (Just n) err = ioeSetLocation err (show n)++die :: String -> IO a+die msg = ioError (userError msg)++topHandler :: IO a -> IO a+topHandler prog = catchIO prog handle+ where+ handle ioe = do+ hFlush stdout+ pname <- getProgName+ hPutStr stderr (mesage pname)+ exitWith (ExitFailure 1)+ where+ mesage pname = wrapText (pname ++ ": " ++ file ++ detail)+ file = case ioeGetFileName ioe of+ Nothing -> ""+ Just path -> path ++ location ++ ": "+ location = case ioeGetLocation ioe of+ l@(n:_) | n >= '0' && n <= '9' -> ':' : l+ _ -> ""+ detail = ioeGetErrorString ioe++-- | Non fatal conditions that may be indicative of an error or problem.+--+-- We display these at the 'normal' verbosity level.+--+warn :: Verbosity -> String -> IO ()+warn verbosity msg =+ when (verbosity >= normal) $ do+ hFlush stdout+ hPutStr stderr (wrapText ("Warning: " ++ msg))++-- | Useful status messages.+--+-- We display these at the 'normal' verbosity level.+--+-- This is for the ordinary helpful status messages that users see. Just+-- enough information to know that things are working but not floods of detail.+--+notice :: Verbosity -> String -> IO ()+notice verbosity msg =+ when (verbosity >= normal) $+ putStr (wrapText msg)++-- | More detail on the operation of some action.+--+-- We display these messages when the verbosity level is 'verbose'+--+info :: Verbosity -> String -> IO ()+info verbosity msg =+ when (verbosity >= verbose) $+ putStr (wrapText msg)++-- | Detailed internal debugging information+--+-- We display these messages when the verbosity level is 'deafening'+--+debug :: Verbosity -> String -> IO ()+debug verbosity msg =+ when (verbosity >= deafening) $ do+ putStr (wrapText msg)+ hFlush stdout++-- | A variant of 'debug' that doesn't perform the automatic line+-- wrapping. Produces better output in some cases.+debugNoWrap :: Verbosity -> String -> IO ()+debugNoWrap verbosity msg =+ when (verbosity >= deafening) $ do+ putStrLn msg+ hFlush stdout++-- | Perform an IO action, catching any IO exceptions and printing an error+-- if one occurs.+chattyTry :: String -- ^ a description of the action we were attempting+ -> IO () -- ^ the action itself+ -> IO ()+chattyTry desc action =+ catchIO action $ \exception ->+ putStrLn $ "Error while " ++ desc ++ ": " ++ show exception++-- -----------------------------------------------------------------------------+-- Helper functions++-- | Wraps text to the default line width. Existing newlines are preserved.+wrapText :: String -> String+wrapText = unlines+ . map (intercalate "\n"+ . map unwords+ . wrapLine 79+ . words)+ . lines++-- | Wraps a list of words to a list of lines of words of a particular width.+wrapLine :: Int -> [String] -> [[String]]+wrapLine width = wrap 0 []+ where wrap :: Int -> [String] -> [String] -> [[String]]+ wrap 0 [] (w:ws)+ | length w + 1 > width+ = wrap (length w) [w] ws+ wrap col line (w:ws)+ | col + length w + 1 > width+ = reverse line : wrap 0 [] (w:ws)+ wrap col line (w:ws)+ = let col' = col + length w + 1+ in wrap col' (w:line) ws+ wrap _ [] [] = []+ wrap _ line [] = [reverse line]++-- -----------------------------------------------------------------------------+-- rawSystem variants+maybeExit :: IO ExitCode -> IO ()+maybeExit cmd = do+ res <- cmd+ unless (res == ExitSuccess) $ exitWith res++printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()+printRawCommandAndArgs verbosity path args+ | verbosity >= deafening = print (path, args)+ | verbosity >= verbose =+#if __GLASGOW_HASKELL__ >= 702+ putStrLn $ showCommandForUser path args+#else+ putStrLn $ unwords (path : args)+#endif+ | otherwise = return ()++printRawCommandAndArgsAndEnv :: Verbosity+ -> FilePath+ -> [String]+ -> [(String, String)]+ -> IO ()+printRawCommandAndArgsAndEnv verbosity path args env+ | verbosity >= deafening = do putStrLn ("Environment: " ++ show env)+ print (path, args)+ | verbosity >= verbose = putStrLn $ unwords (path : args)+ | otherwise = return ()++-- Exit with the same exitcode if the subcommand fails+rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()+rawSystemExit verbosity path args = do+ printRawCommandAndArgs verbosity path args+ hFlush stdout+ exitcode <- rawSystem path args+ unless (exitcode == ExitSuccess) $ do+ debug verbosity $ path ++ " returned " ++ show exitcode+ exitWith exitcode++rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode+rawSystemExitCode verbosity path args = do+ printRawCommandAndArgs verbosity path args+ hFlush stdout+ exitcode <- rawSystem path args+ unless (exitcode == ExitSuccess) $ do+ debug verbosity $ path ++ " returned " ++ show exitcode+ return exitcode++rawSystemExitWithEnv :: Verbosity+ -> FilePath+ -> [String]+ -> [(String, String)]+ -> IO ()+rawSystemExitWithEnv verbosity path args env = do+ printRawCommandAndArgsAndEnv verbosity path args env+ hFlush stdout+ ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing+ exitcode <- waitForProcess ph+ unless (exitcode == ExitSuccess) $ do+ debug verbosity $ path ++ " returned " ++ show exitcode+ exitWith exitcode++-- Closes the passed in handles before returning.+rawSystemIOWithEnv :: Verbosity+ -> FilePath+ -> [String]+ -> [(String, String)]+ -> Maybe Handle -- ^ stdin+ -> Maybe Handle -- ^ stdout+ -> Maybe Handle -- ^ stderr+ -> IO ExitCode+rawSystemIOWithEnv verbosity path args env inp out err = do+ printRawCommandAndArgsAndEnv verbosity path args env+ hFlush stdout+ ph <- runProcess path args Nothing (Just env) inp out err+ exitcode <- waitForProcess ph+ unless (exitcode == ExitSuccess) $ do+ debug verbosity $ path ++ " returned " ++ show exitcode+ return exitcode++-- | Run a command and return its output.+--+-- The output is assumed to be text in the locale encoding.+--+rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String+rawSystemStdout verbosity path args = do+ (output, errors, exitCode) <- rawSystemStdInOut verbosity path args+ Nothing False+ when (exitCode /= ExitSuccess) $+ die errors+ return output++-- | Run a command and return its output, errors and exit status. Optionally+-- also supply some input. Also provides control over whether the binary/text+-- mode of the input and output.+--+rawSystemStdInOut :: Verbosity+ -> FilePath -> [String]+ -> Maybe (String, Bool) -- ^ input text and binary mode+ -> Bool -- ^ output in binary mode+ -> IO (String, String, ExitCode) -- ^ output, errors, exit+rawSystemStdInOut verbosity path args input outputBinary = do+ printRawCommandAndArgs verbosity path args++ Exception.bracket+ (runInteractiveProcess path args Nothing Nothing)+ (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)+ $ \(inh,outh,errh,pid) -> do++ -- output mode depends on what the caller wants+ hSetBinaryMode outh outputBinary+ -- but the errors are always assumed to be text (in the current locale)+ hSetBinaryMode errh False++ -- fork off a couple threads to pull on the stderr and stdout+ -- so if the process writes to stderr we do not block.++ err <- hGetContents errh+ out <- hGetContents outh++ mv <- newEmptyMVar+ let force str = (evaluate (length str) >> return ())+ `Exception.finally` putMVar mv ()+ --TODO: handle exceptions like text decoding.+ _ <- forkIO $ force out+ _ <- forkIO $ force err++ -- push all the input, if any+ case input of+ Nothing -> return ()+ Just (inputStr, inputBinary) -> do+ -- input mode depends on what the caller wants+ hSetBinaryMode inh inputBinary+ hPutStr inh inputStr+ hClose inh+ --TODO: this probably fails if the process refuses to consume+ -- or if it closes stdin (eg if it exits)++ -- wait for both to finish, in either order+ takeMVar mv+ takeMVar mv++ -- wait for the program to terminate+ exitcode <- waitForProcess pid+ unless (exitcode == ExitSuccess) $+ debug verbosity $ path ++ " returned " ++ show exitcode+ ++ if null err then "" else+ " with error message:\n" ++ err+ ++ case input of+ Nothing -> ""+ Just ("", _) -> ""+ Just (inp, _) -> "\nstdin input:\n" ++ inp++ return (out, err, exitcode)+++-- | Look for a program on the path.+findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath)+findProgramLocation verbosity prog = do+ debug verbosity $ "searching for " ++ prog ++ " in path."+ res <- findExecutable prog+ case res of+ Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path")+ Just path -> debug verbosity ("found " ++ prog ++ " at "++ path)+ return res+++-- | Like the unix xargs program. Useful for when we've got very long command+-- lines that might overflow an OS limit on command line length and so you+-- need to invoke a command multiple times to get all the args in.+--+-- Use it with either of the rawSystem variants above. For example:+--+-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs+--+xargs :: Int -> ([String] -> IO ())+ -> [String] -> [String] -> IO ()+xargs maxSize rawSystemFun fixedArgs bigArgs =+ let fixedArgSize = sum (map length fixedArgs) + length fixedArgs+ chunkSize = maxSize - fixedArgSize+ in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)++ where chunks len = unfoldr $ \s ->+ if null s then Nothing+ else Just (chunk [] len s)++ chunk acc _ [] = (reverse acc,[])+ chunk acc len (s:ss)+ | len' < len = chunk (s:acc) (len-len'-1) ss+ | otherwise = (reverse acc, s:ss)+ where len' = length s++-- ------------------------------------------------------------+-- * File Utilities+-- ------------------------------------------------------------++----------------+-- Finding files++-- | Find a file by looking in a search path. The file path must match exactly.+--+findFile :: [FilePath] -- ^search locations+ -> FilePath -- ^File Name+ -> IO FilePath+findFile searchPath fileName =+ findFirstFile id+ [ path </> fileName+ | path <- nub searchPath]+ >>= maybe (die $ fileName ++ " doesn't exist") return++-- | Find a file by looking in a search path with one of a list of possible+-- file extensions. The file base name should be given and it will be tried+-- with each of the extensions in each element of the search path.+--+findFileWithExtension :: [String]+ -> [FilePath]+ -> FilePath+ -> IO (Maybe FilePath)+findFileWithExtension extensions searchPath baseName =+ findFirstFile id+ [ path </> baseName <.> ext+ | path <- nub searchPath+ , ext <- nub extensions ]++-- | Like 'findFileWithExtension' but returns which element of the search path+-- the file was found in, and the file path relative to that base directory.+--+findFileWithExtension' :: [String]+ -> [FilePath]+ -> FilePath+ -> IO (Maybe (FilePath, FilePath))+findFileWithExtension' extensions searchPath baseName =+ findFirstFile (uncurry (</>))+ [ (path, baseName <.> ext)+ | path <- nub searchPath+ , ext <- nub extensions ]++findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a)+findFirstFile file = findFirst+ where findFirst [] = return Nothing+ findFirst (x:xs) = do exists <- doesFileExist (file x)+ if exists+ then return (Just x)+ else findFirst xs+++-- | List all the files in a directory and all subdirectories.+--+-- The order places files in sub-directories after all the files in their+-- parent directories. The list is generated lazily so is not well defined if+-- the source directory structure changes before the list is used.+--+getDirectoryContentsRecursive :: FilePath -> IO [FilePath]+getDirectoryContentsRecursive topdir = recurseDirectories [""]+ where+ recurseDirectories :: [FilePath] -> IO [FilePath]+ recurseDirectories [] = return []+ recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do+ (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)+ files' <- recurseDirectories (dirs' ++ dirs)+ return (files ++ files')++ where+ collect files dirs' [] = return (reverse files, reverse dirs')+ collect files dirs' (entry:entries) | ignore entry+ = collect files dirs' entries+ collect files dirs' (entry:entries) = do+ let dirEntry = dir </> entry+ isDirectory <- doesDirectoryExist (topdir </> dirEntry)+ if isDirectory+ then collect files (dirEntry:dirs') entries+ else collect (dirEntry:files) dirs' entries++ ignore ['.'] = True+ ignore ['.', '.'] = True+ ignore _ = False++------------------------+-- Environment variables++-- | Is this directory in the system search path?+isInSearchPath :: FilePath -> IO Bool+isInSearchPath path = fmap (elem path) getSearchPath++----------------+-- File globbing++data FileGlob+ -- | No glob at all, just an ordinary file+ = NoGlob FilePath++ -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to+ -- @FileGlob \"foo\/bar\" \".baz\"@+ | FileGlob FilePath String++parseFileGlob :: FilePath -> Maybe FileGlob+parseFileGlob filepath = case splitExtensions filepath of+ (filepath', ext) -> case splitFileName filepath' of+ (dir, "*") | '*' `elem` dir+ || '*' `elem` ext+ || null ext -> Nothing+ | null dir -> Just (FileGlob "." ext)+ | otherwise -> Just (FileGlob dir ext)+ _ | '*' `elem` filepath -> Nothing+ | otherwise -> Just (NoGlob filepath)++matchFileGlob :: FilePath -> IO [FilePath]+matchFileGlob = matchDirFileGlob "."++matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath]+matchDirFileGlob dir filepath = case parseFileGlob filepath of+ Nothing -> die $ "invalid file glob '" ++ filepath+ ++ "'. Wildcards '*' are only allowed in place of the file"+ ++ " name, not in the directory name or file extension."+ ++ " If a wildcard is used it must be with an file extension."+ Just (NoGlob filepath') -> return [filepath']+ Just (FileGlob dir' ext) -> do+ files <- getDirectoryContents (dir </> dir')+ case [ dir' </> file+ | file <- files+ , let (name, ext') = splitExtensions file+ , not (null name) && ext' == ext ] of+ [] -> die $ "filepath wildcard '" ++ filepath+ ++ "' does not match any files."+ matches -> return matches++----------------------------------------+-- Copying and installing files and dirs++-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels.+--+createDirectoryIfMissingVerbose :: Verbosity+ -> Bool -- ^ Create its parents too?+ -> FilePath+ -> IO ()+createDirectoryIfMissingVerbose verbosity create_parents path0+ | create_parents = createDirs (parents path0)+ | otherwise = createDirs (take 1 (parents path0))+ where+ parents = reverse . scanl1 (</>) . splitDirectories . normalise++ createDirs [] = return ()+ createDirs (dir:[]) = createDir dir throwIOIO+ createDirs (dir:dirs) =+ createDir dir $ \_ -> do+ createDirs dirs+ createDir dir throwIOIO++ createDir :: FilePath -> (IOException -> IO ()) -> IO ()+ createDir dir notExistHandler = do+ r <- tryIO $ createDirectoryVerbose verbosity dir+ case (r :: Either IOException ()) of+ Right () -> return ()+ Left e+ | isDoesNotExistError e -> notExistHandler e+ -- createDirectory (and indeed POSIX mkdir) does not distinguish+ -- between a dir already existing and a file already existing. So we+ -- check for it here. Unfortunately there is a slight race condition+ -- here, but we think it is benign. It could report an exeption in+ -- the case that the dir did exist but another process deletes the+ -- directory and creates a file in its place before we can check+ -- that the directory did indeed exist.+ | isAlreadyExistsError e -> (do+ isDir <- doesDirectoryExist dir+ if isDir then return ()+ else throwIOIO e+ ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())+ | otherwise -> throwIOIO e++createDirectoryVerbose :: Verbosity -> FilePath -> IO ()+createDirectoryVerbose verbosity dir = do+ info verbosity $ "creating " ++ dir+ createDirectory dir+ setDirOrdinary dir++-- | Copies a file without copying file permissions. The target file is created+-- with default permissions. Any existing target file is replaced.+--+-- At higher verbosity levels it logs an info message.+--+copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO ()+copyFileVerbose verbosity src dest = do+ info verbosity ("copy " ++ src ++ " to " ++ dest)+ copyFile src dest++-- | Install an ordinary file. This is like a file copy but the permissions+-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\"+-- while on Windows it uses the default permissions for the target directory.+--+installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO ()+installOrdinaryFile verbosity src dest = do+ info verbosity ("Installing " ++ src ++ " to " ++ dest)+ copyOrdinaryFile src dest++-- | Install an executable file. This is like a file copy but the permissions+-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\"+-- while on Windows it uses the default permissions for the target directory.+--+installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()+installExecutableFile verbosity src dest = do+ info verbosity ("Installing executable " ++ src ++ " to " ++ dest)+ copyExecutableFile src dest++-- | Copies a bunch of files to a target directory, preserving the directory+-- structure in the target location. The target directories are created if they+-- do not exist.+--+-- The files are identified by a pair of base directory and a path relative to+-- that base. It is only the relative part that is preserved in the+-- destination.+--+-- For example:+--+-- > copyFiles normal "dist/src"+-- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")]+--+-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and+-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\".+--+-- This operation is not atomic. Any IO failure during the copy (including any+-- missing source files) leaves the target in an unknown state so it is best to+-- use it with a freshly created directory so that it can be simply deleted if+-- anything goes wrong.+--+copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()+copyFiles verbosity targetDir srcFiles = do++ -- Create parent directories for everything+ let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles+ mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs++ -- Copy all the files+ sequence_ [ let src = srcBase </> srcFile+ dest = targetDir </> srcFile+ in copyFileVerbose verbosity src dest+ | (srcBase, srcFile) <- srcFiles ]++-- | This is like 'copyFiles' but uses 'installOrdinaryFile'.+--+installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()+installOrdinaryFiles verbosity targetDir srcFiles = do++ -- Create parent directories for everything+ let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles+ mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs++ -- Copy all the files+ sequence_ [ let src = srcBase </> srcFile+ dest = targetDir </> srcFile+ in installOrdinaryFile verbosity src dest+ | (srcBase, srcFile) <- srcFiles ]++-- | This installs all the files in a directory to a target location,+-- preserving the directory layout. All the files are assumed to be ordinary+-- rather than executable files.+--+installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO ()+installDirectoryContents verbosity srcDir destDir = do+ info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")+ srcFiles <- getDirectoryContentsRecursive srcDir+ installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]++---------------------------------+-- Deprecated file copy functions++{-# DEPRECATED copyDirectoryRecursiveVerbose+ "You probably want installDirectoryContents instead" #-}+copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO ()+copyDirectoryRecursiveVerbose verbosity srcDir destDir = do+ info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")+ srcFiles <- getDirectoryContentsRecursive srcDir+ copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]++---------------------------+-- Temporary files and dirs++-- | Use a temporary filename that doesn't already exist.+--+withTempFile :: Bool -- ^ Keep temporary files?+ -> FilePath -- ^ Temp dir to create the file in+ -> String -- ^ File name template. See 'openTempFile'.+ -> (FilePath -> Handle -> IO a) -> IO a+withTempFile keepTempFiles tmpDir template action =+ Exception.bracket+ (openTempFile tmpDir template)+ (\(name, handle) -> do hClose handle+ unless keepTempFiles $ removeFile name)+ (uncurry action)++-- | Create and use a temporary directory.+--+-- Creates a new temporary directory inside the given directory, making use+-- of the template. The temp directory is deleted after use. For example:+--+-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ...+--+-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.+-- @src/sdist.342@.+--+withTempDirectory :: Verbosity+ -> Bool -- ^ Keep temporary files?+ -> FilePath -> String -> (FilePath -> IO a) -> IO a+withTempDirectory _verbosity keepTempFiles targetDir template =+ Exception.bracket+ (createTempDirectory targetDir template)+ (unless keepTempFiles . removeDirectoryRecursive)++-----------------------------------+-- Safely reading and writing files++-- | Gets the contents of a file, but guarantee that it gets closed.+--+-- The file is read lazily but if it is not fully consumed by the action then+-- the remaining input is truncated and the file is closed.+--+withFileContents :: FilePath -> (String -> IO a) -> IO a+withFileContents name action =+ Exception.bracket (openFile name ReadMode) hClose+ (\hnd -> hGetContents hnd >>= action)++-- | Writes a file atomically.+--+-- The file is either written sucessfully or an IO exception is raised and+-- the original file is left unchanged.+--+-- On windows it is not possible to delete a file that is open by a process.+-- This case will give an IO exception but the atomic property is not affected.+--+writeFileAtomic :: FilePath -> BS.ByteString -> IO ()+writeFileAtomic targetPath content = do+ let (targetDir, targetFile) = splitFileName targetPath+ Exception.bracketOnError+ (openBinaryTempFile targetDir $ targetFile <.> "tmp")+ (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)+ (\(tmpPath, handle) -> do+ BS.hPut handle content+ hClose handle+ renameFile tmpPath targetPath)++-- | Write a file but only if it would have new content. If we would be writing+-- the same as the existing content then leave the file as is so that we do not+-- update the file's modification time.+--+rewriteFile :: FilePath -> String -> IO ()+rewriteFile path newContent =+ flip catchIO mightNotExist $ do+ existingContent <- readFile path+ _ <- evaluate (length existingContent)+ unless (existingContent == newContent) $+ writeFileAtomic path (BS.Char8.pack newContent)+ where+ mightNotExist e | isDoesNotExistError e = writeFileAtomic path+ (BS.Char8.pack newContent)+ | otherwise = ioError e++-- | The path name that represents the current directory.+-- In Unix, it's @\".\"@, but this is system-specific.+-- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.)+currentDir :: FilePath+currentDir = "."++-- ------------------------------------------------------------+-- * Finding the description file+-- ------------------------------------------------------------++-- |Package description file (/pkgname/@.cabal@)+defaultPackageDesc :: Verbosity -> IO FilePath+defaultPackageDesc _verbosity = findPackageDesc currentDir++-- |Find a package description file in the given directory. Looks for+-- @.cabal@ files.+findPackageDesc :: FilePath -- ^Where to look+ -> IO FilePath -- ^<pkgname>.cabal+findPackageDesc dir+ = do files <- getDirectoryContents dir+ -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal+ -- file we filter to exclude dirs and null base file names:+ cabalFiles <- filterM doesFileExist+ [ dir </> file+ | file <- files+ , let (name, ext) = splitExtension file+ , not (null name) && ext == ".cabal" ]+ case cabalFiles of+ [] -> noDesc+ [cabalFile] -> return cabalFile+ multiple -> multiDesc multiple++ where+ noDesc :: IO a+ noDesc = die $ "No cabal file found.\n"+ ++ "Please create a package description file <pkgname>.cabal"++ multiDesc :: [String] -> IO a+ multiDesc l = die $ "Multiple cabal files found.\n"+ ++ "Please use only one of: "+ ++ intercalate ", " l++-- |Optional auxiliary package information file (/pkgname/@.buildinfo@)+defaultHookedPackageDesc :: IO (Maybe FilePath)+defaultHookedPackageDesc = findHookedPackageDesc currentDir++-- |Find auxiliary package information in the given directory.+-- Looks for @.buildinfo@ files.+findHookedPackageDesc+ :: FilePath -- ^Directory to search+ -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present+findHookedPackageDesc dir = do+ files <- getDirectoryContents dir+ buildInfoFiles <- filterM doesFileExist+ [ dir </> file+ | file <- files+ , let (name, ext) = splitExtension file+ , not (null name) && ext == buildInfoExt ]+ case buildInfoFiles of+ [] -> return Nothing+ [f] -> return (Just f)+ _ -> die ("Multiple files with extension " ++ buildInfoExt)++buildInfoExt :: String+buildInfoExt = ".buildinfo"++-- ------------------------------------------------------------+-- * Unicode stuff+-- ------------------------------------------------------------++-- This is a modification of the UTF8 code from gtk2hs and the+-- utf8-string package.++fromUTF8 :: String -> String+fromUTF8 [] = []+fromUTF8 (c:cs)+ | c <= '\x7F' = c : fromUTF8 cs+ | c <= '\xBF' = replacementChar : fromUTF8 cs+ | c <= '\xDF' = twoBytes c cs+ | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF)+ | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7)+ | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3)+ | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1)+ | otherwise = replacementChar : fromUTF8 cs+ where+ twoBytes c0 (c1:cs')+ | ord c1 .&. 0xC0 == 0x80+ = let d = ((ord c0 .&. 0x1F) `shiftL` 6)+ .|. (ord c1 .&. 0x3F)+ in if d >= 0x80+ then chr d : fromUTF8 cs'+ else replacementChar : fromUTF8 cs'+ twoBytes _ cs' = replacementChar : fromUTF8 cs'++ moreBytes :: Int -> Int -> [Char] -> Int -> [Char]+ moreBytes 1 overlong cs' acc+ | overlong <= acc && acc <= 0x10FFFF+ && (acc < 0xD800 || 0xDFFF < acc)+ && (acc < 0xFFFE || 0xFFFF < acc)+ = chr acc : fromUTF8 cs'++ | otherwise+ = replacementChar : fromUTF8 cs'++ moreBytes byteCount overlong (cn:cs') acc+ | ord cn .&. 0xC0 == 0x80+ = moreBytes (byteCount-1) overlong cs'+ ((acc `shiftL` 6) .|. ord cn .&. 0x3F)++ moreBytes _ _ cs' _+ = replacementChar : fromUTF8 cs'++ replacementChar = '\xfffd'++toUTF8 :: String -> String+toUTF8 [] = []+toUTF8 (c:cs)+ | c <= '\x07F' = c+ : toUTF8 cs+ | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6))+ : chr (0x80 .|. (w .&. 0x3F))+ : toUTF8 cs+ | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12))+ : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F))+ : chr (0x80 .|. (w .&. 0x3F))+ : toUTF8 cs+ | otherwise = chr (0xf0 .|. (w `shiftR` 18))+ : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F))+ : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F))+ : chr (0x80 .|. (w .&. 0x3F))+ : toUTF8 cs+ where w = ord c++-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input+--+ignoreBOM :: String -> String+ignoreBOM ('\xFEFF':string) = string+ignoreBOM string = string++-- | Reads a UTF8 encoded text file as a Unicode String+--+-- Reads lazily using ordinary 'readFile'.+--+readUTF8File :: FilePath -> IO String+readUTF8File f = fmap (ignoreBOM . fromUTF8)+ . hGetContents =<< openBinaryFile f ReadMode++-- | Reads a UTF8 encoded text file as a Unicode String+--+-- Same behaviour as 'withFileContents'.+--+withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a+withUTF8FileContents name action =+ Exception.bracket+ (openBinaryFile name ReadMode)+ hClose+ (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8)++-- | Writes a Unicode String as a UTF8 encoded text file.+--+-- Uses 'writeFileAtomic', so provides the same guarantees.+--+writeUTF8File :: FilePath -> String -> IO ()+writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8++-- | Fix different systems silly line ending conventions+normaliseLineEndings :: String -> String+normaliseLineEndings [] = []+normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows+normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx+normaliseLineEndings ( c :s) = c : normaliseLineEndings s++-- ------------------------------------------------------------+-- * Common utils+-- ------------------------------------------------------------++equating :: Eq a => (b -> a) -> b -> b -> Bool+equating p x y = p x == p y++comparing :: Ord a => (b -> a) -> b -> b -> Ordering+comparing p x y = p x `compare` p y++isInfixOf :: String -> String -> Bool+isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)++lowercase :: String -> String+lowercase = map Char.toLower
+ src_jahm/Distribution/Text.hs view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Text+-- Copyright : Duncan Coutts 2007+--+-- Maintainer : cabal-devel@haskell.org+-- Portability : portable+--+-- This defines a 'Text' class which is a bit like the 'Read' and 'Show'+-- classes. The difference is that is uses a modern pretty printer and parser+-- system and the format is not expected to be Haskell concrete syntax but+-- rather the external human readable representation used by Cabal.+--+module Distribution.Text (+ Text(..),+ display,+ ) where++import qualified Text.PrettyPrint as Disp++import Data.Version (Version(Version))+import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace)++class Text a where+ disp :: a -> Disp.Doc++display :: Text a => a -> String+display = Disp.renderStyle style . disp+ where style = Disp.Style {+ Disp.mode = Disp.PageMode,+ Disp.lineLength = 79,+ Disp.ribbonsPerLine = 1.0+ }++-- -----------------------------------------------------------------------------+-- Instances for types from the base package++instance Text Bool where+ disp = Disp.text . show++instance Text Version where+ disp (Version branch _tags) -- Death to version tags!!+ = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch))
+ src_jahm/Distribution/Verbosity.hs view
@@ -0,0 +1,102 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Verbosity+-- Copyright : Ian Lynagh 2007+--+-- Maintainer : cabal-devel@haskell.org+-- Portability : portable+--+-- A simple 'Verbosity' type with associated utilities. There are 4 standard+-- verbosity levels from 'silent', 'normal', 'verbose' up to 'deafening'. This+-- is used for deciding what logging messages to print.++-- Verbosity for Cabal functions++{- Copyright (c) 2007, Ian Lynagh+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Jones nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++module Distribution.Verbosity (+ -- * Verbosity+ Verbosity,+ silent, normal, verbose, deafening,+ moreVerbose, lessVerbose,+ intToVerbosity,+ showForCabal, showForGHC+ ) where++import Data.List (elemIndex)++data Verbosity = Silent | Normal | Verbose | Deafening+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++-- We shouldn't print /anything/ unless an error occurs in silent mode+silent :: Verbosity+silent = Silent++-- Print stuff we want to see by default+normal :: Verbosity+normal = Normal++-- Be more verbose about what's going on+verbose :: Verbosity+verbose = Verbose++-- Not only are we verbose ourselves (perhaps even noisier than when+-- being "verbose"), but we tell everything we run to be verbose too+deafening :: Verbosity+deafening = Deafening++moreVerbose :: Verbosity -> Verbosity+moreVerbose Silent = Silent --silent should stay silent+moreVerbose Normal = Verbose+moreVerbose Verbose = Deafening+moreVerbose Deafening = Deafening++lessVerbose :: Verbosity -> Verbosity+lessVerbose Deafening = Deafening+lessVerbose Verbose = Normal+lessVerbose Normal = Silent+lessVerbose Silent = Silent++intToVerbosity :: Int -> Maybe Verbosity+intToVerbosity 0 = Just Silent+intToVerbosity 1 = Just Normal+intToVerbosity 2 = Just Verbose+intToVerbosity 3 = Just Deafening+intToVerbosity _ = Nothing++showForCabal, showForGHC :: Verbosity -> String++showForCabal v = maybe (error "unknown verbosity") show $+ elemIndex v [silent,normal,verbose,deafening]+showForGHC v = maybe (error "unknown verbosity") show $+ elemIndex v [silent,normal,__,verbose,deafening]+ where __ = silent -- this will be always ignored by elemIndex
+ src_jahm/Main.hs view
@@ -0,0 +1,37 @@+{-- Jahm: Package installer for (A)jhc.++ Copyright 2013 Metasepi team.+ Contributed by Kiwamu Okabe <kiwamu@debian.or.jp>++This file is part of Metasepi arafura <http://metasepi.masterq.net/>.++Metasepi is free software; you can redistribute it and/or modify it under+the terms of the GNU General Public License as published by the Free+Software Foundation; either version 2, or (at your option) any later+version.++Metasepi is distributed in the hope that it will be useful, but WITHOUT ANY+WARRANTY; without even the implied warranty of MERCHANTABILITY or+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License+for more details.++You should have received a copy of the GNU General Public License+along with Metasepi arafura; see the file metasepi-arafura/COPYING.+If not see <http://www.gnu.org/licenses/old-licenses/gpl-2.0.html>. --}++module Main where+import System.Environment (getArgs)+import System.Directory (getCurrentDirectory)+import System.FilePath ((</>))+import Network.URI (parseURI)+import Distribution.Client.HttpUtils (downloadURI)+import Distribution.Verbosity (verbose)++main :: IO ()+main = getArgs >>= mainWorker++mainWorker :: [String] -> IO ()+mainWorker ("downloadURI":u:f:[]) = do curDir <- getCurrentDirectory+ let Just url = parseURI u+ downloadURI verbose url $ curDir </> f+mainWorker _ = print "help"
+ src_main/Main.hs view
@@ -0,0 +1,116 @@+module Main(main) where++import Control.Exception+import Control.Monad.Identity+import Data.Char+import Prelude+import System.Directory+import System.FilePath as FP+import System.IO+import qualified Data.ByteString.Lazy as LBS++import DataConstructors+import E.Main+import E.Program+import E.Rules+import E.Type+import FrontEnd.Class+import Grin.Main(compileToGrin)+import Grin.Show(render)+import Ho.Build+import Ho.Collected+import Ho.Library+import Name.Name+import Options+import StringTable.Atom+import Support.TempDir+import Util.Gen+import Util.SetLike as S+import Version.Version(versionSimple)+import qualified FlagDump as FD+import qualified Interactive++main = wrapMain $ do+ hSetEncoding stdout utf8+ hSetEncoding stderr utf8+ o <- processOptions+ when (dump FD.Atom) $+ addAtExit dumpStringTableStats+ -- set temporary directory+ maybeDo $ do x <- optWorkDir o; return $ setTempDir x+ let darg = progressM $ do+ (argstring,_) <- getArgString+ return (argstring ++ "\n" ++ versionSimple)+ case optMode o of+ BuildHl hl -> darg >> buildLibrary processInitialHo processDecls hl+ ListLibraries -> listLibraries+ ShowHo ho -> dumpHoFile ho+ PurgeCache -> purgeCache+ Preprocess -> forM_ (optArgs o) $ \fn -> do+ lbs <- LBS.readFile fn+ res <- preprocessHs options fn lbs+ LBS.putStr res+ _ -> darg >> processFiles (optArgs o)++-- we are very careful to only delete cache files.+purgeCache = do+ Just hc <- findHoCache+ ds <- getDirectoryContents hc+ let cacheFile fn = case map toLower (reverse fn) of+ 'o':'h':'.':fs -> length fs == 26 && all isAlphaNum fs+ _ -> False+ forM_ ds $ \fn -> when (cacheFile fn) (removeFile (hc </> fn))++processFiles :: [String] -> IO ()+processFiles cs = f cs (optMainFunc options) where+ f [] Nothing = do+ int <- Interactive.isInteractive+ when (not int) $ putErrDie "ajhc: no input files"+ g [Left preludeModule]+ f [] (Just (b,m)) = do+ m <- getModule (parseName Val m)+ g [Left m]+ f cs _ = g (map fileOrModule cs)+ g fs = processCollectedHo . snd =<< parseFiles options [outputName] []+ fs processInitialHo processDecls+ fileOrModule f = case reverse f of+ ('s':'h':'.':_) -> Right f+ ('s':'h':'l':'.':_) -> Right f+ ('c':'s':'h':'.':_) -> Right f+ _ -> Left $ toModule f++processCollectedHo cho = do+ if optStop options == CompileHo then return () else do+ putProgressLn "Collected Compilation..."++ when (dump FD.ClassSummary) $ do+ putStrLn " ---- class summary ---- "+ printClassSummary (choClassHierarchy cho)+ when (dump FD.Class) $ do+ putStrLn " ---- class hierarchy ---- "+ printClassHierarchy (choClassHierarchy cho)++ let dataTable = choDataTable cho+ combinators = values $ choCombinators cho++ evaluate dataTable+ evaluate combinators++ let prog = programUpdate program {+ progCombinators = combinators,+ progDataTable = dataTable+ }+ -- dump final version of various requested things+ wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable)+ wdump FD.DatatableBuiltin $+ putErrLn (render $ showDataTable samplePrimitiveDataTable)+ dumpRules (Rules $ fromList+ [(combIdent x,combRules x) | x <- combinators, not $ null (combRules x)])++ -- enter interactive mode+ int <- Interactive.isInteractive+ if int then Interactive.interact cho else do+ prog <- compileWholeProgram prog+ compileToGrin prog++progressM c = wdump FD.Progress $ (c >>= putErrLn) >> hFlush stderr
utils/build_extlibs.prl view
@@ -10,9 +10,10 @@ use Cwd; use Getopt::Std; -our ($opt_l,$opt_d,$opt_c);-getopts('ldc:') or die "unknown opt";+our ($opt_l,$opt_d,$opt_c,$opt_j);+getopts('ldc:j:') or die "unknown opt"; $opt_c = "./ajhc" unless $opt_c;+$opt_j = "./jahm" unless $opt_j; # clean out environment delete $ENV{AJHC_PATH};@@ -54,8 +55,7 @@ my $url = "http://hackage.haskell.org/packages/archive/$name/$version/$name-$version.tar.gz"; print "Fetching $url\n"; unless(-e "$tmpdir/$name-$version.tar.gz") {- my $rc = getstore($url, "$tmpdir/$name-$version.tar.gz");- if (is_error $rc) { die "$url: $rc" } ;+ mysystem "$opt_j downloadURI $url $tmpdir/$name-$version.tar.gz"; } mysystem "tar -zxv --directory $tmpdir -f $tmpdir/$name-$version.tar.gz" and die "$!: tar"; my $src = -d "$tmpdir/$name-$version/src" ? "/src" : "";