lhc 0.6.20081211.2 → 0.6.20081216
raw patch · 25 files changed
+199/−554 lines, 25 filesdep −haskeline
Dependencies removed: haskeline
Files
- data/ViaGhc.hs +0/−93
- lhc.cabal +5/−6
- lib/base/base.cabal +1/−0
- lib/base/src/Debug/Trace.hs +23/−0
- src/C/Arch.hs +9/−20
- src/C/FromGrin2.hs +5/−5
- src/E/LambdaLift.hs +4/−2
- src/E/ToHs.hs +1/−2
- src/FlagOpts.hs +2/−6
- src/Grin/DeadCode.hs +4/−4
- src/Grin/Devolve.hs +4/−4
- src/Grin/FromE.hs +2/−0
- src/Grin/Grin.hs +23/−23
- src/Grin/Lint.hs +3/−3
- src/Grin/NodeAnalyze.hs +3/−3
- src/Grin/Noodle.hs +26/−26
- src/Grin/Optimize.hs +2/−2
- src/Grin/SSimplify.hs +2/−2
- src/Grin/Show.hs +5/−5
- src/Grin/Simplify.hs +23/−23
- src/Grin/Whiz.hs +4/−4
- src/Interactive.hs +0/−260
- src/Main.hs +38/−41
- src/Options.hs +10/−16
- src/RawFiles.hs +0/−4
− data/ViaGhc.hs
@@ -1,93 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts -fno-implicit-prelude #-}-module Main(main) where--import GHC.Int-import GHC.Word-import GHC.IOBase-import GHC.Prim-import GHC.Base-import GHC.Ptr-import GHC.Err--type World__ = State# RealWorld-type Array__ a = Array# a-type MutArray__ a = MutableArray# RealWorld a-type Ref__ a = MutVar# RealWorld a--type Nothing = ()--theNothing :: Nothing-theNothing = ()--type JIO a = World__ -> (# World__, a #)--main :: IO ()-main = IO $ \rw -> case theRealMain rw of rw' -> (# rw', () #)--unPtr :: Ptr a -> Addr#-unPtr ptr = case ptr of- Ptr addr -> addr--unFunPtr :: FunPtr a -> Addr#-unFunPtr ptr = case ptr of- FunPtr addr -> addr--fromBool :: Bool -> Int#-fromBool b = case b of- False -> 0#- True -> 1#--gteChar# a b = gtChar# a b || eqChar# a b-lteChar# a b = ltChar# a b || eqChar# a b--plusAddr__ :: Addr# -> Addr# -> Addr#-plusAddr__ a1 a2 = plusAddr# a1 (addr2Int# a2)--alloca__ :: Int# -> (Addr# -> JIO a) -> JIO a-alloca__ size action s =- case newPinnedByteArray# size s of { (# s, mbarr# #) ->- case unsafeFreezeByteArray# mbarr# s of { (# s, barr# #) ->- case action (byteArrayContents# barr#) s of { (# s, r #) ->- case touch# barr# s of { s -> (# s, r #) }- }}}--word2Char__ x = chr# (word2Int# x)-char2Word__ x = int2Word# (ord# x)-addr2Word__ x = int2Word# (addr2Int# x)-word2Addr__ x = int2Addr# (word2Int# x)--convertString :: [Char] -> ListTCon Char-convertString [] = lhc_EmptyList-convertString (x:xs) = lhc_Cons x (convertString xs)--{--error__ :: Addr# -> a-error__ s = unsafePerformIO $ do- error_show s- error_exit (I# 255#)--errorInt__ :: Addr# -> Int#-errorInt__ s = seq (unsafePerformIO $ do- error_show s- error_exit (I# 255#)) 0#--errorWord__ :: Addr# -> Word#-errorWord__ s = seq (unsafePerformIO $ do- error_show s- error_exit (I# 255#)) (int2Word# 0#)--errorAddr__ :: Addr# -> Addr#-errorAddr__ s = seq (unsafePerformIO $ do- error_show s- error_exit (I# 255#)) (int2Addr# 0#)-foreign import ccall unsafe "puts" error_show :: Ptr a -> IO ()-foreign import ccall unsafe "exit" error_exit :: Int -> IO a- -}--{-# NOINLINE newWorld__ #-}-newWorld__ :: a -> World__-newWorld__ a = case lazy a of- _ -> realWorld#--theRealMain :: World__ -> World__-
lhc.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.6 name: lhc-version: 0.6.20081211.2+version: 0.6.20081216 synopsis: LHC Haskell Compiler description: lhc is a haskell compiler which aims to produce the most efficient programs possible via whole@@ -19,6 +19,7 @@ lib/base/src/Control/*.hs, lib/base/src/Data/Array/*.hs, lib/base/src/Data/*.hs,+ lib/base/src/Debug/*.hs, lib/base/src/Foreign/C/*.hs, lib/base/src/Foreign/Marshal/*.hs, lib/base/src/Foreign/*.hs,@@ -37,12 +38,10 @@ lib/base/src/Text/Show/*.hs, lib/base/src/Unsafe/*.hs data-dir: data-data-files: HsFFI.h names.txt operators.txt prelude.m4 primitives.txt props.txt wsize.h ViaGhc.hs+data-files: HsFFI.h names.txt operators.txt prelude.m4 primitives.txt props.txt wsize.h rts/lhc_rts.c rts/lhc_rts2.c rts/lhc_rts_alloc.c rts/lhc_rts_header.h flag base4-flag hpc- default: False flag threaded default: False flag lhc-regress@@ -60,7 +59,7 @@ UndecidableInstances, TypeSynonymInstances, ScopedTypeVariables, ParallelListComp, OverlappingInstances, RecursiveDo, GADTs, RankNTypes, PatternGuards, TemplateHaskell build-depends: containers, mtl, pretty, array, bytestring, pureMD5,- binary >= 0.4.4, directory, haskeline, random, regex-compat,+ binary >= 0.4.4, directory, random, regex-compat, graphviz, fgl, unix, zlib, old-time, haskell98, utf8-string, stringtable-atom, derive >= 0.1.4, filepath, ansi-wl-pprint >= 0.5.0, ansi-terminal >= 0.5.0@@ -79,7 +78,7 @@ else x-build-base: False Other-modules:- CharIO, FindFixpoint, FlagOpts, Interactive, Options, PrimitiveOperators,+ CharIO, FindFixpoint, FlagOpts, Options, PrimitiveOperators, DataConstructors, FlagDump, GenUtil, PackedString, RawFiles, Stats, C.FromGrin2 C.Arch C.FFI C.Generate C.Prims Cmm.Op Cmm.OpEval Cmm.Number
lib/base/base.cabal view
@@ -21,6 +21,7 @@ Data.Maybe, Data.Ratio, Data.Unicode,+ Debug.Trace, Foreign, Foreign.C, Foreign.C.Types,
+ lib/base/src/Debug/Trace.hs view
@@ -0,0 +1,23 @@+-- | Tracing library+module Debug.Trace (+ putTraceMsg -- :: String -> IO ()+, trace -- :: String -> a -> a+, traceShow -- :: Show a => a -> b -> b+) where+import System.IO (hPutStrLn,stderr)+import System.IO.Unsafe (unsafePerformIO)++-- | Outputs a trace message to stderr; currently defined as+-- @putTraceMsg = hPutStrLn stderr@+putTraceMsg :: String -> IO ()+putTraceMsg = hPutStrLn stderr++-- | Tracing call+trace :: String -> a -> a+trace s e = unsafePerformIO $ do putTraceMsg s+ return e++-- | Like 'trace', but uses show; defined as+-- @traceShow = trace . show@+traceShow :: Show a => a -> b -> b+traceShow = trace . show
src/C/Arch.hs view
@@ -5,8 +5,8 @@ archInfo, archOpTy, stringToOpTy,- genericArchInfo, determineArch,+ genericArchInfo, primitiveInfo, genericPrimitiveInfo ) where@@ -87,7 +87,7 @@ primMap :: Map.Map ExtType PrimType primMap = Map.fromList [ (primTypeName a,a) | a <- as ] where- (_,_,as,_) = unsafePerformIO determineArch+ (_,as,_) = unsafePerformIO determineArch genericPrimMap :: Map.Map ExtType PrimType genericPrimMap = Map.fromList [ (primTypeName a,a) | a <- arch_generic ] where@@ -122,11 +122,7 @@ determineArch = do let specs = maybe [] (split (== '-')) (optArch options)- (backendGhc,specs') | ("ghc":rs) <- specs = (True,rs)- | ("grin":rs) <- specs = (False,rs)- | ("fgrin":rs) <- specs = (False,rs)- | otherwise = (fopts FO.ViaGhc,specs)- (cpu,bits) = case specs' of+ (cpu,bits) = case specs of ["32"] -> (cpu_alias arch,32) ["64"] -> (cpu_alias arch,64) [cpu,"32"] -> (cpu_alias cpu,32)@@ -134,20 +130,13 @@ [cpu] -> (cpu_alias cpu,WORD_SIZE_IN_BITS) [] -> (cpu_alias arch,WORD_SIZE_IN_BITS) _ -> arch_error- let (fn,mp,opt) = case (backendGhc,cpu,bits) of- (True,!_,32) -> ("ghc-" ++ show bits,arch_i686,[])- (True,!_,64) -> ("ghc-" ++ show bits,arch_x86_64,[])- (_,"generic",_) -> ("generic",arch_generic,[])- (_,"i686",32) -> ("i686",arch_i686,[])- (_,"x86_64",32) -> ("x86_64-32",arch_i686, ["-m32"])- (_,"x86_64",(64::Int)) -> ("x86_64",arch_x86_64,[])+ let (fn,mp,opt) = case (cpu,bits) of+ ("generic",_) -> ("generic",arch_generic,[])+ ("i686",32) -> ("i686",arch_i686,[])+ ("x86_64",32) -> ("x86_64-32",arch_i686, ["-m32"])+ ("x86_64",(64::Int)) -> ("x86_64",arch_x86_64,[]) _ -> arch_error - return (backendGhc,fn,mp,opt)+ return (fn,mp,opt) arch_error = error $ "\nunknown architecture, supported architectures are:\n" ++ show available_archs-----
src/C/FromGrin2.hs view
@@ -8,7 +8,7 @@ import Data.Char import Data.Maybe import Data.Monoid-import Text.PrettyPrint.ANSI.Leijen(nest,(<$$>))+import Text.PrettyPrint.ANSI.Leijen(indent,(<$$>)) import Text.Printf import qualified Data.Map as Map import qualified Data.Set as Set@@ -103,7 +103,7 @@ (header,body) = generateC (Map.elems fm) (Map.elems sm) ((),finalHcHash,Written { wRequires = req, wFunctions = fm, wEnums = wenum, wStructures = sm, wTags = ts }) = runC grin go enum_tag_t | null enums = mempty- | otherwise = text "enum {" <$$> nest 4 (P.vcat (punctuate P.comma $ enums)) <$$> text "};"+ | otherwise = text "enum {" <$$> indent 4 (P.vcat (punctuate P.comma $ enums)) <$$> text "};" where f t n = tshow t <> text " = " <> tshow (n :: Int) enums = map (uncurry f) (Map.toList wenum) ++ (zipWith f (Set.toList (Set.map nodeTagName ts)) [0 ..])@@ -262,7 +262,7 @@ iDeclare action = local (\e -> e { rDeclare = True }) action convertBody :: Exp -> C Statement-convertBody Let { expDefs = defs, expBody = body } = do+{-convertBody Let { expDefs = defs, expBody = body } = do u <- newUniq nn <- flip mapM defs $ \FuncDef { funcDefName = name, funcDefBody = as :-> _ } -> do vs' <- mapM convertVal as@@ -278,7 +278,7 @@ todo <- asks rTodo case todo of TodoReturn -> return (ss & mconcat rs);- _ -> return (ss & goto done & mconcat (intersperse (goto done) rs) & label done);+ _ -> return (ss & goto done & mconcat (intersperse (goto done) rs) & label done);-} convertBody (e :>>= [] :-> e') = do ss <- localTodo TodoNothing (convertBody e) ss' <- convertBody e'@@ -877,7 +877,7 @@ generateArchAssertions :: String generateArchAssertions = unlines (h:map f (filter notVoid as) ++ [t]) where- (_,_,as,_) = unsafePerformIO determineArch+ (_,as,_) = unsafePerformIO determineArch notVoid pt = primTypeName pt /= "void" f pt = printf " assert(sizeof(%s) == %d);" (primTypeName pt) (primTypeSizeOf pt) h = "static void\nlhc_arch_assert(void)\n{"
src/E/LambdaLift.hs view
@@ -151,7 +151,7 @@ findFixpoint Nothing {-"Liftees"-} fixer vs <- supplyReadValues sup- let nlset = (fromList [ x | (x,False) <- vs])+ let nlset = (fromList [ x | (x,False) <- vs]) when verbose $ printf "%d lambdas not lifted\n" (size nlset) return nlset @@ -163,7 +163,9 @@ lambdaLift :: Program -> IO Program lambdaLift prog@Program { progDataTable = dataTable, progCombinators = cs } = do- noLift <- calculateLiftees prog+ --noLift <- calculateLiftees prog+ -- We don't want any local functions in the GRIN code.+ let noLift = sempty :: IdSet let wp = fromList [ combIdent x | x <- cs ] :: IdSet fc <- newIORef [] fm <- newIORef mempty
src/E/ToHs.hs view
@@ -34,7 +34,6 @@ import Name.VConsts import Numeric import Options-import RawFiles(viaghc_hs) import Support.CanType import Support.FreeVars import Util.Gen@@ -60,7 +59,7 @@ 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]+ writeFile cf $ unlines ["-- " ++ argstring,"-- " ++ comm,"",render restate,data_decls,rv,"",foreign_decls] progress ("Running: " ++ comm) r <- System.system comm when (r /= System.ExitSuccess) $ fail "Hs code did not compile."
src/FlagOpts.hs view
@@ -26,7 +26,6 @@ | TypeAnalysis -- ^ perhaps a basic points-to analysis on types right after method generation | UnboxedTuples -- ^ allow unboxed tuple syntax to be recognized | UnboxedValues -- ^ allow unboxed value syntax- | ViaGhc -- ^ compile via ghc | Wrapper -- ^ wrap main in exception handler deriving(Eq,Ord,Bounded) @@ -49,7 +48,6 @@ show TypeAnalysis = "type-analysis" show GlobalOptimize = "global-optimize" show FullInt = "full-int"- show ViaGhc = "via-ghc" show Wrapper = "wrapper" show Boehm = "boehm" show Profile = "profile"@@ -97,8 +95,6 @@ one "default" = Right $ foldr (.) id [ f | Right f <- [ one "inline-pragmas",one "rules",one "wrapper",one "float-in",one "strictness",one "defaulting",one "type-analysis",one "monomorphism-restriction",one "boxy",one "eval-optimize",one "global-optimize"]] one "negate" = Right $ Set.insert Negate one "no-negate" = Right $ Set.delete Negate-one "via-ghc" = Right $ Set.insert ViaGhc-one "no-via-ghc" = Right $ Set.delete ViaGhc one "cpp" = Right $ Set.insert Cpp one "no-cpp" = Right $ Set.delete Cpp one "raw" = Right $ Set.insert Raw@@ -113,6 +109,6 @@ f (Left x) (s,xs) = (s,x:xs) {-# NOINLINE helpMsg #-}-helpMsg = "\n-- Code options --\n cpp\n pass haskell source through c preprocessor\n ffi\n support foreign function declarations\n m4\n pass haskell source through m4 preprocessor\n unboxed-tuples\n allow unboxed tuple syntax to be recognized\n unboxed-values\n allow unboxed value syntax\n\n-- Typechecking --\n defaulting\n perform defaulting of ambiguous types\n monomorphism-restriction\n enforce monomorphism restriction\n\n-- Debugging --\n lint\n perform lots of extra type checks\n\n-- Optimization Options --\n cpr\n do CPR analysis\n float-in\n perform float inward transform\n global-optimize\n perform whole program E optimization\n inline-pragmas\n use inline pragmas\n rules\n use rules\n strictness\n perform strictness analysis\n type-analysis\n perhaps a basic points-to analysis on types right after method generation\n\n-- Code Generation --\n boehm\n use Boehm garbage collector\n debug\n enable debugging code in generated executable\n full-int\n extend Int and Word to 32 bits on a 32 bit machine (rather than 30)\n profile\n enable profiling code in generated executable\n raw\n just evaluate main to WHNF and nothing else.\n via-ghc\n compile via ghc\n wrapper\n wrap main in exception handler\n\n-- Default settings --\n default\n inline-pragmas rules wrapper float-in strictness defaulting type-analysis monomorphism-restriction boxy eval-optimize global-optimize\n"-helpFlags = ["boehm", "controlled", "cpp", "cpr", "debug", "default", "defaulting", "ffi", "float-in", "full-int", "global-optimize", "inline-pragmas", "lint", "m4", "monomorphism-restriction", "negate", "profile", "raw", "rules", "strictness", "type-analysis", "unboxed-tuples", "unboxed-values", "via-ghc", "wrapper"]+helpMsg = "\n-- Code options --\n cpp\n pass haskell source through c preprocessor\n ffi\n support foreign function declarations\n m4\n pass haskell source through m4 preprocessor\n unboxed-tuples\n allow unboxed tuple syntax to be recognized\n unboxed-values\n allow unboxed value syntax\n\n-- Typechecking --\n defaulting\n perform defaulting of ambiguous types\n monomorphism-restriction\n enforce monomorphism restriction\n\n-- Debugging --\n lint\n perform lots of extra type checks\n\n-- Optimization Options --\n cpr\n do CPR analysis\n float-in\n perform float inward transform\n global-optimize\n perform whole program E optimization\n inline-pragmas\n use inline pragmas\n rules\n use rules\n strictness\n perform strictness analysis\n type-analysis\n perhaps a basic points-to analysis on types right after method generation\n\n-- Code Generation --\n boehm\n use Boehm garbage collector\n debug\n enable debugging code in generated executable\n full-int\n extend Int and Word to 32 bits on a 32 bit machine (rather than 30)\n profile\n enable profiling code in generated executable\n raw\n just evaluate main to WHNF and nothing else.\n wrapper\n wrap main in exception handler\n\n-- Default settings --\n default\n inline-pragmas rules wrapper float-in strictness defaulting type-analysis monomorphism-restriction boxy eval-optimize global-optimize\n"+helpFlags = ["boehm", "controlled", "cpp", "cpr", "debug", "default", "defaulting", "ffi", "float-in", "full-int", "global-optimize", "inline-pragmas", "lint", "m4", "monomorphism-restriction", "negate", "profile", "raw", "rules", "strictness", "type-analysis", "unboxed-tuples", "unboxed-values", "wrapper"]
src/Grin/DeadCode.hs view
@@ -127,12 +127,12 @@ g (Store n) = addRule $ doNode n g (Fetch x) = addRule $ doNode x g Alloc { expValue = v, expCount = c, expRegion = r } = addRule $ doNode v `mappend` doNode c `mappend` doNode r- g Let { expDefs = defs, expBody = body } = do+{- g Let { expDefs = defs, expBody = body } = do mapM_ goAgain [ (name,bod) | FuncDef { funcDefBody = bod, funcDefName = name } <- defs] flip mapM_ (map funcDefName defs) $ \n -> do --n' <- supplyValue usedFuncs n --addRule $ fn' `implies` n'- return ()+ return ()-} g Error {} = return () -- TODO - handle function and case return values smartier. g (Return ns) = mapM_ (addRule . doNode) ns@@ -183,8 +183,8 @@ as <- dff' fn' as as <- mapM clearCaf as return $ Update p (NodeC fn as)- f lt@Let { expDefs = defs } = return $ updateLetProps lt { expDefs = defs' } where- defs' = [ updateFuncDefProps df { funcDefBody = margs name body } | df@FuncDef { funcDefName = name, funcDefBody = body } <- defs, name `Set.member` funSet ]+{- f lt@Let { expDefs = defs } = return $ updateLetProps lt { expDefs = defs' } where+ defs' = [ updateFuncDefProps df { funcDefBody = margs name body } | df@FuncDef { funcDefName = name, funcDefBody = body } <- defs, name `Set.member` funSet ]-} f x = return x dff' fn as | fn `Set.member` directFuncs = return as dff' fn as = dff'' fn as
src/Grin/Devolve.hs view
@@ -28,7 +28,7 @@ devolveGrin grin = do col <- newIORef [] let g (n,l :-> r) = f r >>= \r -> return (n,l :-> r)- f lt@Let { expDefs = defs, expBody = body } = do+ {-f lt@Let { expDefs = defs, expBody = body } = do let nonTail = expNonNormal lt (nmaps,rmaps) = splitEither (map z defs) z fd@FuncDef { funcDefName = name, funcDefBody = as :-> r }@@ -42,7 +42,7 @@ mapM_ print (Map.toList pmap) nmaps <- mapM (g . fst) nmaps modifyIORef col (++ nmaps)- mapExpExp f $ updateLetProps lt { expDefs = rmaps, expBody = proc body }+ mapExpExp f $ updateLetProps lt { expDefs = rmaps, expBody = proc body }-} f e = mapExpExp f e nf <- mapM g (grinFuncs grin) lf <- readIORef col@@ -76,10 +76,10 @@ twiddleExp e = f e where f (x :>>= lam) = return (:>>=) `ap` twiddle x `ap` twiddle lam- f l@Let {} = do+ {-f l@Let {} = do ds <- twiddle (expDefs l) b <- twiddle (expBody l)- return . updateLetProps $ l { expDefs = ds, expBody = b }+ return . updateLetProps $ l { expDefs = ds, expBody = b }-} f (Case v as) = return Case `ap` twiddle v `ap` twiddle as f n = do e <- mapExpVal twiddleVal n ; mapExpExp twiddle e
src/Grin/FromE.hs view
@@ -638,6 +638,8 @@ e <- cc e v <- f ds x return $ e :>>= [toVal t] :-> v+ -- All recursive lets should have been lifted to the top-level.+ f (Right bs:ds) x | any (isELam . snd) bs = error "Unlifted let in Grin.FromE.compile'" f (Right bs:ds) x | any (isELam . snd) bs = do let g (t,e@(~ELam {})) = do let (a,as) = fromLam e
src/Grin/Grin.hs view
@@ -159,25 +159,25 @@ expJump :: Bool, -- ^ Jump is equivalent to a call except it deallocates the region it resides in before transfering control expFuncProps :: FuncProps, expInfo :: Info.Info } -- ^ Call or jump to a callable- | NewRegion { expLam :: Lam, expInfo :: Info.Info } -- ^ create a new region and pass it to its argument+-- | NewRegion { expLam :: Lam, expInfo :: Info.Info } -- ^ create a new region and pass it to its argument | Alloc { expValue :: Val, expCount :: Val, expRegion :: Val, expInfo :: Info.Info } -- ^ allocate space for a number of values in the given region- | Let { expDefs :: [FuncDef],+{- | Let { expDefs :: [FuncDef], expBody :: Exp, expFuncCalls :: (Set.Set Atom,Set.Set Atom), -- ^ cache expIsNormal :: Bool, -- ^ cache, True = definitely normal, False = maybe normal expNonNormal :: Set.Set Atom, -- ^ cache, a superset of functions called in non-tail call position.- expInfo :: Info.Info } -- ^ A let of local functions- | MkClosure { expValue :: Val,+ expInfo :: Info.Info }-} -- ^ A let of local functions+{- | MkClosure { expValue :: Val, expArgs :: [Val], expRegion :: Val, expType :: [Ty],- expInfo :: Info.Info } -- ^ create a closure- | MkCont { expCont :: Lam, -- ^ the continuation routine+ expInfo :: Info.Info }-} -- ^ create a closure+{- | MkCont { expCont :: Lam, -- ^ the continuation routine expLam :: Lam, -- ^ the computation that is passed the newly created computation- expInfo :: Info.Info } -- ^ Make a continuation, always allocated on region encompasing expLam+ expInfo :: Info.Info }-} -- ^ Make a continuation, always allocated on region encompasing expLam deriving(Eq,Show,Ord) data Val =@@ -461,12 +461,12 @@ getType (Update w v) = [] getType (Case _ []) = error "empty case" getType (Case _ ((_ :-> e):_)) = getType e- getType NewRegion { expLam = _ :-> body } = getType body+-- getType NewRegion { expLam = _ :-> body } = getType body getType Alloc { expValue = v } = [TyPtr (getType v)]- getType Let { expBody = body } = getType body- getType MkCont { expLam = _ :-> rbody } = getType rbody+-- getType Let { expBody = body } = getType body+-- getType MkCont { expLam = _ :-> rbody } = getType rbody getType Call { expType = ty } = ty- getType MkClosure { expType = ty } = ty+-- getType MkClosure { expType = ty } = ty instance CanType Val Ty where getType (Var _ t) = t@@ -520,12 +520,12 @@ freeVars (Update x y) = freeVars (x,y) freeVars (Prim _ x _) = freeVars x freeVars Error {} = Set.empty- freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (funcFreeVars . funcDefProps) fdefs) `mappend` freeVars body- freeVars NewRegion { expLam = l } = freeVars l+-- freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (funcFreeVars . funcDefProps) fdefs) `mappend` freeVars body+-- freeVars NewRegion { expLam = l } = freeVars l freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r) freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)- freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)- freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)+-- freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)+-- freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as) instance FreeVars Exp (Set.Set (Var,Ty)) where freeVars (a :>>= b) = freeVars (a,b)@@ -537,12 +537,12 @@ freeVars (Update x y) = freeVars (x,y) freeVars (Prim _ x _) = freeVars x freeVars Error {} = Set.empty- freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (freeVars . funcDefBody) fdefs) `mappend` freeVars body- freeVars NewRegion { expLam = l } = freeVars l+-- freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (freeVars . funcDefBody) fdefs) `mappend` freeVars body+-- freeVars NewRegion { expLam = l } = freeVars l freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r) freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)- freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)- freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)+-- freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)+-- freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as) instance FreeVars Exp [Var] where freeVars e = Set.toList $ freeVars e@@ -577,12 +577,12 @@ freeVars (Update x y) = freeVars (x,y) freeVars (Prim _ x _) = freeVars x freeVars Error {} = Set.empty- freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (funcTags . funcDefProps) fdefs) `mappend` freeVars body- freeVars NewRegion { expLam = l } = freeVars l+-- freeVars Let { expDefs = fdefs, expBody = body } = mconcat (map (funcTags . funcDefProps) fdefs) `mappend` freeVars body+-- freeVars NewRegion { expLam = l } = freeVars l freeVars Alloc { expValue = v, expCount = c, expRegion = r } = freeVars (v,c,r) freeVars Call { expValue = v, expArgs = as } = freeVars (v:as)- freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)- freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as)+-- freeVars MkClosure { expValue = v, expArgs = as, expRegion = r } = freeVars (v,as,r)+-- freeVars MkCont { expCont = v, expLam = as} = freeVars (v,as) lamExp (_ :-> e) = e
src/Grin/Lint.hs view
@@ -44,7 +44,7 @@ dumpGrin pname grin = do let fn = optOutName options ++ "_" ++ pname ++ ".grin"- putErrLn $ "Writing: " ++ fn+ --putErrLn $ "Writing: " ++ fn h <- openFile fn WriteMode (argstring,sversion) <- getArgString hPutStrLn h $ unlines [ "-- " ++ argstring,"-- " ++ sversion,""]@@ -180,10 +180,10 @@ tv <- tcVal v es <- mapM (tcLam (Just [tv])) as foldl1M (same $ "case exp: " ++ show (map head $ sortGroupUnder fst (zip es as)) ) es- f (Let { expDefs = defs, expBody = body }) = do+{- f (Let { expDefs = defs, expBody = body }) = do local (\e -> e { envTyEnv = extendTyEnv defs (envTyEnv e) }) $ do mapM_ (tcLam Nothing) [ b | FuncDef { funcDefBody = b } <- defs ]- f body+ f body-} tcVal :: Val -> Tc Ty tcVal v = f v where
src/Grin/NodeAnalyze.hs view
@@ -234,7 +234,7 @@ convertVal v dunno [TyPtr tyINode] -- dres [v']- f NewRegion { expLam = _ :-> body } = fn ret body+-- f NewRegion { expLam = _ :-> body } = fn ret body f (Update (Var vname ty) v) | ty == TyPtr TyNode = do v' <- convertVal v tell $ Left (vr vname ty) `isgte` v'@@ -246,9 +246,9 @@ v' <- convertVal v v' <- convertVal v1 dres []- f Let { expDefs = ds, expBody = e } = do+{- f Let { expDefs = ds, expBody = e } = do mapM_ doFunc (map (\x -> (funcDefName x, funcDefBody x)) ds)- fn ret e+ fn ret e-} f exp = error $ "NodeAnalyze.f: " ++ show exp -- f _ = dres []
src/Grin/Noodle.hs view
@@ -22,11 +22,11 @@ f lf e | False && trace ("modifyTail: " ++ show (lf,e)) False = undefined f _ (Error s ty) = Error s (getType lb) f lf (Case x ls) = Case x (map (g lf) ls)- f _ lt@Let {expIsNormal = False } = lt :>>= lam- f lf lt@Let {expDefs = defs, expBody = body, expIsNormal = True } = updateLetProps lt { expBody = f nlf body, expDefs = defs' } where+-- f _ lt@Let {expIsNormal = False } = lt :>>= lam+{- f lf lt@Let {expDefs = defs, expBody = body, expIsNormal = True } = updateLetProps lt { expBody = f nlf body, expDefs = defs' } where nlf = lf `Set.union` Set.fromList (map funcDefName defs)- defs' = [ updateFuncDefProps d { funcDefBody = g nlf (funcDefBody d) } | d <- defs ]- f lf lt@MkCont {expLam = lam, expCont = cont } = lt { expLam = g lf lam, expCont = g lf cont }+ defs' = [ updateFuncDefProps d { funcDefBody = g nlf (funcDefBody d) } | d <- defs ]-}+-- f lf lt@MkCont {expLam = lam, expCont = cont } = lt { expLam = g lf lam, expCont = g lf cont } f lf (e1 :>>= p :-> e2) = e1 :>>= p :-> f lf e2 f lf e@(App a as t) | a `Set.member` lf = App a as (getType lb) f lf e = e :>>= lam@@ -70,27 +70,27 @@ mapExpLam fn e = f e where f (a :>>= b) = return (a :>>=) `ap` fn b f (Case e as) = return (Case e) `ap` mapM fn as- f lt@Let { expDefs = defs } = do+{- f lt@Let { expDefs = defs } = do defs' <- forM defs $ \d -> do b <- fn $ funcDefBody d return $ updateFuncDefProps d { funcDefBody = b }- return $ updateLetProps lt { expDefs = defs' }- f nr@NewRegion { expLam = lam } = do+ return $ updateLetProps lt { expDefs = defs' }-}+{- f nr@NewRegion { expLam = lam } = do lam <- fn lam- return $ nr { expLam = lam }- f e@MkCont { expCont = c, expLam = l } = do+ return $ nr { expLam = lam }-}+{- f e@MkCont { expCont = c, expLam = l } = do c <- fn c l <- fn l- return $ e { expCont = c, expLam = l }+ return $ e { expCont = c, expLam = l }-} f e = return e mapExpExp fn e = f e where f (a :>>= b) = return (:>>=) `ap` fn a `ap` g b- f l@Let { expBody = b, expDefs = defs } = do+{- f l@Let { expBody = b, expDefs = defs } = do b <- fn b- mapExpLam g l { expBody = b }+ mapExpLam g l { expBody = b }-} f e = mapExpLam g e g (l :-> e) = return (l :->) `ap` fn e @@ -116,13 +116,13 @@ f lf (Return [(NodeC t _)]) = return [t] f lf Error {} = return [] f lf (App a _ _) | a `Set.member` lf = return []- f lf Let { expBody = body, expIsNormal = False } = f lf body- f lf Let { expBody = body, expDefs = defs, expIsNormal = True } = ans where+-- f lf Let { expBody = body, expIsNormal = False } = f lf body+{- f lf Let { expBody = body, expDefs = defs, expIsNormal = True } = ans where nlf = lf `Set.union` Set.fromList (map funcDefName defs) ans = do xs <- mapM (f nlf . lamExp . funcDefBody) defs b <- f nlf body- return (concat (b:xs))+ return (concat (b:xs))-} f lf (Case _ ls) = do cs <- Prelude.mapM (f lf) [ e | _ :-> e <- ls ] return $ concat cs@@ -149,7 +149,7 @@ isOmittable (Store {}) = True isOmittable Prim { expPrimitive = aprim } = aprimIsCheap aprim isOmittable (Case x ds) = all isOmittable [ e | _ :-> e <- ds ]-isOmittable Let { expBody = x } = isOmittable x+--isOmittable Let { expBody = x } = isOmittable x isOmittable (e1 :>>= _ :-> e2) = isOmittable e1 && isOmittable e2 isOmittable _ = False @@ -175,9 +175,9 @@ cfunc (Case _ as) = do rs <- mapM clfunc as return (mconcat rs)- cfunc Let { expFuncCalls = (tail,nonTail) } = do+{- cfunc Let { expFuncCalls = (tail,nonTail) } = do tell nonTail- return tail+ return tail-} cfunc Fetch {} = return mempty cfunc Error {} = return mempty cfunc Prim {} = return mempty@@ -185,14 +185,14 @@ cfunc Store {} = return mempty cfunc Update {} = return mempty cfunc Alloc {} = return mempty- cfunc NewRegion { expLam = l } = clfunc l- cfunc MkCont { expCont = l1, expLam = l2 } = do+-- cfunc NewRegion { expLam = l } = clfunc l+{- cfunc MkCont { expCont = l1, expLam = l2 } = do a <- clfunc l1 b <- clfunc l2- return (a `mappend` b)+ return (a `mappend` b)-} cfunc x = error "Grin.Noodle.collectFuncs: unknown" -grinLet defs body = updateLetProps Let {+grinLet defs body = error "grinLet not defined"{-updateLetProps Let { expDefs = defs, expBody = body, expInfo = mempty,@@ -211,7 +211,7 @@ notNormal = nonTail `Set.intersection` (Set.fromList $ map funcDefName defs) myDefs = Set.fromList $ map funcDefName defs updateLetProps e = e-+-} data ReturnInfo = ReturnNode (Maybe Atom,[Ty]) | ReturnConst Val | ReturnCalls Atom | ReturnOther | ReturnError deriving(Eq,Ord)@@ -225,13 +225,13 @@ f lf Error {} = tells ReturnError f lf (Case _ ls) = do Prelude.mapM_ (f lf) [ e | _ :-> e <- ls ] f lf (_ :>>= _ :-> e) = f lf e- f lf Let { expBody = body, expIsNormal = False } = f lf body+-- f lf Let { expBody = body, expIsNormal = False } = f lf body f lf (App a _ _) | a `Set.member` lf = return ()- f lf Let { expBody = body, expDefs = defs, expIsNormal = True } = ans where+{- f lf Let { expBody = body, expDefs = defs, expIsNormal = True } = ans where nlf = lf `Set.union` Set.fromList (map funcDefName defs) ans = do mapM_ (f nlf . lamExp . funcDefBody) defs- f nlf body+ f nlf body-} f _ (App a _ _) = tells $ ReturnCalls a f _ e = tells ReturnOther
src/Grin/Optimize.hs view
@@ -62,13 +62,13 @@ (_,exp') <- dropAny Nothing exp return exp' - fixupLet lt@Let { expDefs = defs, expBody = b } = do+{- fixupLet lt@Let { expDefs = defs, expBody = b } = do let def = (Set.fromList $ map funcDefName defs) f (e :>>= l :-> r) | Set.null (freeVars e `Set.intersection` def) = do exp <- f r return (e :>>= l :-> exp) f r = return $ updateLetProps lt { expBody = r }- f b+ f b-} fixupLet exp = return exp dropAny mv (exp::Exp) = do (nn,xs) <- get
src/Grin/SSimplify.hs view
@@ -184,10 +184,10 @@ as <- mapM simpLam as return $ Case v as - g lt@Let { expDefs = defs, expBody = body } = do+{- g lt@Let { expDefs = defs, expBody = body } = do body <- f body [] defs <- simpFuncs defs- return $ updateLetProps lt { expBody = body, expDefs = defs }+ return $ updateLetProps lt { expBody = body, expDefs = defs }-} g x = applySubstE x
src/Grin/Show.hs view
@@ -76,8 +76,8 @@ isOneLine (_ :>>= _) = False isOneLine Case {} = False-isOneLine Let {} = False-isOneLine MkCont {} = False+--isOneLine Let {} = False+--isOneLine MkCont {} = False isOneLine _ = True {-# NOINLINE prettyExp #-}@@ -104,10 +104,10 @@ prettyExp vl (Case v vs) = vl <> keyword "case" <+> prettyVal v <+> keyword "of" <$> indent 2 (vsep (map f vs)) where f (~[v] :-> e) | isOneLine e = prettyVal v <+> operator "->" <+> prettyExp empty e f (~[v] :-> e) = prettyVal v <+> operator "->" <+> keyword "do" <$> indent 2 (prettyExp empty e)-prettyExp vl NewRegion { expLam = (r :-> body)} = vl <> keyword "region" <+> text "\\" <> prettyVals r <+> text "-> do" <$> indent 2 (prettyExp empty body)+--prettyExp vl NewRegion { expLam = (r :-> body)} = vl <> keyword "region" <+> text "\\" <> prettyVals r <+> text "-> do" <$> indent 2 (prettyExp empty body) --prettyExp vl MkCont { expCont = (r :-> body) } = vl <> keyword "continuation" <+> text "\\" <> prettyVal r <+> text "-> do" <$> indent 2 (prettyExp empty body)-prettyExp vl Let { expDefs = defs, expBody = body } = vl <> keyword "let" <$> indent 4 (vsep $ map f defs) <$> text " in" <$> indent 2 (prettyExp empty body) where- f FuncDef { funcDefName = name, funcDefBody = as :-> body } = func (show name) <+> hsep (map prettyVal as) <+> operator "=" <+> keyword "do" <$> indent 2 (prettyExp empty body)+{-prettyExp vl Let { expDefs = defs, expBody = body } = vl <> keyword "let" <$> indent 4 (vsep $ map f defs) <$> text " in" <$> indent 2 (prettyExp empty body) where+ f FuncDef { funcDefName = name, funcDefBody = as :-> body } = func (show name) <+> hsep (map prettyVal as) <+> operator "=" <+> keyword "do" <$> indent 2 (prettyExp empty body)-} prettyExp vl Alloc { expValue = val, expCount = Lit n _, expRegion = r }| n == 1 = vl <> keyword "alloc" <+> prettyVal val <+> text "at" <+> prettyVal r prettyExp vl Alloc { expValue = val, expCount = count, expRegion = r } = vl <> keyword "alloc" <+> prettyVal val <> text "[" <> prettyVal count <> text "]" <+> text "at" <+> prettyVal r prettyExp vl Call { expValue = Item t (TyCall fun _ _), expArgs = vs, expJump = jump } | fun `elem` [Function,LocalFunction] = vl <> f jump <+> func (fromAtom t) <+> hsep (map prettyVal vs) where
src/Grin/Simplify.hs view
@@ -214,8 +214,8 @@ f n _ | n <= 0 = False f n (p :-> a :>>= b ) = (f (n - 1) (p :-> a)) && (f (n - 1) b) f _ (_ :-> Case {}) = False- f _ (_ :-> Let {}) = False- f _ (_ :-> MkCont {}) = False+-- f _ (_ :-> Let {}) = False+-- f _ (_ :-> MkCont {}) = False f _ _ = True @@ -227,7 +227,7 @@ isCombinable :: Monad m => Bool -> Exp -> m UnboxingResult isCombinable postEval e = ans where ans = do- mn <- f mempty e+ mn <- f (mempty :: Set.Set Atom) e equal mn equal [] = fail "empty isCombinable" equal [x] = return x@@ -239,14 +239,14 @@ cs <- Prelude.mapM (f lf) [ e | _ :-> e <- ls ] return $ concat cs f lf (_ :>>= _ :-> e) = f lf e- f lf Let { expBody = body, expIsNormal = False } = f lf body+-- f lf Let { expBody = body, expIsNormal = False } = f lf body f lf (App a _ _) | a `member` lf = return []- f lf Let { expBody = body, expDefs = defs, expIsNormal = True } = ans where+{- f lf Let { expBody = body, expDefs = defs, expIsNormal = True } = ans where nlf = lf `union` Set.fromList (map funcDefName defs) ans = do xs <- mapM (f nlf . lamExp . funcDefBody) defs b <- f nlf body- return (concat (b:xs))+ return (concat (b:xs))-} f _ _ = fail "not combinable" @@ -258,19 +258,19 @@ f e = fail $ "combine: " ++ show (postEval,nty,e) editTail :: Monad m => [Ty] -> (Exp -> m Exp) -> Exp -> m Exp-editTail nty mt te = f mempty te where+editTail nty mt te = f (mempty :: Set.Set Atom) te where f _ (Error s ty) = return $ Error s nty f lf (Case x ls) = return (Case x) `ap` mapM (g lf) ls- f lf lt@Let {expIsNormal = False, expBody = body } = do+{- f lf lt@Let {expIsNormal = False, expBody = body } = do body <- f lf body return $ updateLetProps lt { expBody = body } f lf lt@Let {expDefs = defs, expIsNormal = True } = do let nlf = lf `union` Set.fromList (map funcDefName defs)- mapExpExp (f nlf) lt- f lf lt@MkCont {expLam = lam, expCont = cont } = do+ mapExpExp (f nlf) lt-}+{- f lf lt@MkCont {expLam = lam, expCont = cont } = do a <- g lf lam b <- g lf cont- return $ lt { expLam = a, expCont = b }+ return $ lt { expLam = a, expCont = b }-} f lf (e1 :>>= p :-> e2) = do e2 <- f lf e2 return $ e1 :>>= p :-> e2@@ -288,8 +288,8 @@ sizeLam (b :-> exp) = sizeExp exp sizeExp (x :>>= y) = sizeExp x + sizeLam y sizeExp (Case e as) = 1 + sum (map sizeLam as)-sizeExp Let { expDefs = defs, expBody = body } = sizeExp body + sum (map (sizeLam . funcDefBody) defs)-sizeExp MkCont { expCont = l1, expLam = l2 } = 1 + sizeLam l1 + sizeLam l2+--sizeExp Let { expDefs = defs, expBody = body } = sizeExp body + sum (map (sizeLam . funcDefBody) defs)+--sizeExp MkCont { expCont = l1, expLam = l2 } = 1 + sizeLam l1 + sizeLam l2 sizeExp x = 1 optimize1 :: Grin -> Bool -> (Atom,Lam) -> StatT IO Lam@@ -380,15 +380,15 @@ return (mc lt :>>= as :-> Return [NodeC t as] :>>= v :-> lr) -} - f lt@Let { expDefs = defs, expBody = e :>>= l :-> r } | Set.null (freeVars r `Set.intersection` (Set.fromList $ map funcDefName defs)) = do+{- f lt@Let { expDefs = defs, expBody = e :>>= l :-> r } | Set.null (freeVars r `Set.intersection` (Set.fromList $ map funcDefName defs)) = do mtick "Optimize.optimize.let-shrink-tail"- return (updateLetProps lt { expBody = e } :>>= l :-> r)+ return (updateLetProps lt { expBody = e } :>>= l :-> r)-} -- f lt@(Let { expDefs = defs, expBody = e :>>= l :-> r } :>>= lr) | Set.null (freeVars r `Set.intersect` (Set.fromList $ map funcDefName defs)) = do -- mtick "Optimize.optimize.let-shrink-tail" -- f ((updateLetProps lt { expBody = e } :>>= l :-> r) :>>= lr)- f lt@Let { expDefs = defs, expBody = e :>>= l :-> r } | Set.null (freeVars e `Set.intersection` (Set.fromList $ map funcDefName defs)) = do+{- f lt@Let { expDefs = defs, expBody = e :>>= l :-> r } | Set.null (freeVars e `Set.intersection` (Set.fromList $ map funcDefName defs)) = do mtick "Optimize.optimize.let-shrink-head"- return (e :>>= l :-> updateLetProps lt { expBody = r })+ return (e :>>= l :-> updateLetProps lt { expBody = r })-} {- f (Case x as :>>= v@(Var vnum _) :-> rc@(Case v' as') :>>= lr) | v == v', count (== Nothing ) (Prelude.map (isManifestNode . lamExp) as) <= 1, not (vnum `Set.member` freeVars lr) = do@@ -438,7 +438,7 @@ -- caseHoist hexp v as' (getType rc) -- let unboxing- f (cs@Let {} :>>= lr) | Just comb <- isCombinable postEval cs = do+{- f (cs@Let {} :>>= lr) | Just comb <- isCombinable postEval cs = do lr <- g lr case comb of UnboxTup (t,ts) -> do@@ -451,7 +451,7 @@ mtick $ "Optimize.optimize.let-unbox-const.{" ++ show val cpe <- combine postEval [] cs return ((cpe :>>= [] :-> Return [val]) :>>= lr)- where fv = freeVars cs `Set.union` freeVars [ p | p :-> _ <- map funcDefBody (expDefs cs) ]+ where fv = freeVars cs `Set.union` freeVars [ p | p :-> _ <- map funcDefBody (expDefs cs) ]-} -- f (hexp@Let {} :>>= v@(Var vnum _) :-> rc@(Case v' as') :>>= lr) | v == v', not (vnum `Set.member` freeVars lr) = do -- c <- caseHoist hexp v as' (getType rc)@@ -470,7 +470,7 @@ f (Case x as) = do as' <- sequence [ f e >>= return . (b :->)| b :-> e <- as ] return $ Case x as'- f Let { expDefs = [fd], expBody = body } | not (funcDefName fd `Set.member` funcTags (funcDefProps fd)), sizeLTE 1 nocc = ans where+{- f Let { expDefs = [fd], expBody = body } | not (funcDefName fd `Set.member` funcTags (funcDefProps fd)), sizeLTE 1 nocc = ans where (ne,nocc) = runWriter (c body) ans = case nocc of [] -> do@@ -484,7 +484,7 @@ return $ Return xs :>>= funcDefBody fd c e@Let { expDefs = defs } | funcDefName fd `elem` map funcDefName defs = return e c e = mapExpExp c e- f e@Let {} = mapExpExp f e+ f e@Let {} = mapExpExp f e-} f e = return e notReturnNode (ReturnNode (Just _,_)) = False notReturnNode _ = True@@ -670,11 +670,11 @@ case mlookup fn m of Just fn' -> return a { expValue = Item fn' t } _ -> return a- g (e@Let { expDefs = defs }) = do+{- g (e@Let { expDefs = defs }) = do (defs',rs) <- liftM unzip $ flip mapM defs $ \d -> do (nn,rs) <- newName (funcDefName d) return (d { funcDefName = nn },rs)- local (fromList rs `mappend`) $ mapExpExp g e { expDefs = defs' }+ local (fromList rs `mappend`) $ mapExpExp g e { expDefs = defs' }-} g b = mapExpExp g b newName a = do m <- lift get
src/Grin/Whiz.hs view
@@ -84,13 +84,13 @@ as <- mapM (dc env) as return $ Case v as -- g env lt@Let { expDefs = defs, expBody = Let { expDefs = defs', expBody = body } } = g env lt { expDefs = defs `mappend` defs', expBody = body }- g env lt@Let { expDefs = defs, expBody = body } = do+{- g env lt@Let { expDefs = defs, expBody = body } = do body <- f body [] env let f def@FuncDef { funcDefName = n, funcDefBody = b } = do b <- dc env b return $ createFuncDef True n b defs <- mapM f defs- return $ updateLetProps lt { expBody = body, expDefs = defs }+ return $ updateLetProps lt { expBody = body, expDefs = defs }-} g env x = applySubstE env x dc env (p :-> e) = do (p,env') <- renamePattern p@@ -152,13 +152,13 @@ v <- applySubst env v as <- mapM (dc env) as return $ Case v as- g env lt@Let { expDefs = defs, expBody = body } = do+{- g env lt@Let { expDefs = defs, expBody = body } = do body <- f body [] env let f def@FuncDef { funcDefName = n, funcDefBody = b } = do b <- dc env b return $ createFuncDef True n b defs <- mapM f defs- return $ updateLetProps lt { expBody = body, expDefs = defs }+ return $ updateLetProps lt { expBody = body, expDefs = defs }-} g env x = applySubstE env x dc env (p :-> e) = do (p,env') <- renamePattern p
− src/Interactive.hs
@@ -1,260 +0,0 @@-{-# LANGUAGE CPP #-}-module Interactive(Interactive.interact) where--import Control.Monad.Reader-import Control.Monad.Identity-import Control.Monad.Trans-import Control.Exception as CE-import Data.Monoid-import IO(stdout)-import List(sort)-import Maybe-import Monad-import qualified Data.Map as Map-import qualified Text.PrettyPrint.ANSI.Leijen as PP-import Text.Regex---import Text.Regex.Posix(regcomp,regExtended)---import DataConstructors-import Doc.DocLike-import Doc.PPrint-import Doc.Pretty-import FrontEnd.HsParser(parseHsStmt)-import FrontEnd.KindInfer-import FrontEnd.ParseMonad-import FrontEnd.Rename-import FrontEnd.Tc.Main-import FrontEnd.Tc.Monad-import FrontEnd.Tc.Type-import FrontEnd.Tc.Class-import FrontEnd.Desugar(desugarHsStmt)-import GenUtil-import Ho.Type-import Ho.Collected-import FrontEnd.HsPretty()-import FrontEnd.HsSyn-import Name.Name-import Options-import qualified FrontEnd.Infix-import qualified FrontEnd.HsPretty as HsPretty-import FrontEnd.TypeSynonyms(showSynonym)-import FrontEnd.TypeSyns-import FrontEnd.TypeSigs-import Util.Interact-import LHCVersion(versionString)-import FrontEnd.Warning--printDoc doc = do- displayIO stdout (renderPretty 0.9 80 doc)- putStrLn ""--grep_opts = [- "f - match normal value",- "C - match data constructor",- "T - match type constructor",- "L - match class"- ]--nameTag :: NameType -> Char-nameTag TypeConstructor = 'T'-nameTag DataConstructor = 'C'-nameTag ClassName = 'L'-nameTag Val = 'f'-nameTag _ = '?'--data InteractiveState = IS {- stateHo :: HoBuild,- stateInteract :: Interact,- stateModule :: Module,- stateImports :: [(Name,[Name])],- stateOptions :: Opt- }--isInitial = IS {- stateHo = mempty,- stateInteract = emptyInteract,- stateModule = Module "Main",- stateImports = [],- stateOptions = options- }---newtype In a = MkIn (ReaderT InteractiveState IO a)- deriving(MonadIO,Monad,Functor,MonadReader InteractiveState)--runIn :: InteractiveState -> In a -> IO a-runIn is (MkIn x) = runReaderT x is--instance OptionMonad In where- getOptions = asks stateOptions--instance MonadWarn In where- addWarning x = liftIO $ addWarning x----interact :: CollectedHo -> IO ()-interact cho = mre where- hoE = hoExp $ choHo cho- hoB = hoBuild $ choHo cho-- mre = case optStmts options of- [] -> go- xs -> runInteractions initialInteract (concatMap lines $ reverse xs) >> exitSuccess- go = do- putStrLn "--------------------------------------------------------------"- putStrLn "Welcome to the lhc interactive experience. use :help for help."- putStrLn versionString- putStrLn "--------------------------------------------------------------"- runInteraction initialInteract ":execfile lhci.rc"- beginInteraction initialInteract- initialInteract = emptyInteract {- interactSettables = ["prog", "args"],- interactVersion = versionString,- interactCommands = commands,- interactWords = map (show . fst ) $ stateImports isStart,- interactComment = Just "--",- interactExpr = do_expr- }- dataTable = hoDataTable hoB- commands = [cmd_mods,cmd_grep]- cmd_mods = InteractCommand { commandName = ":mods", commandHelp = "mods currently loaded modules", commandAction = do_mods }- do_mods act _ _ = do- printDoc $ fillSep (map tshow $ Map.keys $ hoExports hoE)- return act- cmd_grep = InteractCommand { commandName = ":grep", commandHelp = "show names matching a regex", commandAction = do_grep }- do_grep act _ "" = do- putStrLn ":grep [options] <regex>"- putStrLn "Valid options:"- putStr $ unlines grep_opts- return act- do_grep act _ arg = do- let (opt,reg) = case simpleUnquote arg of- [x] -> ("TCLf",x)- xs -> f "" xs where- f opt [x] = (opt,x)- f opt ~(x:xs) = f (x ++ opt) xs-#if BASE4- rx <- CE.catch ( Just `fmap` evaluate (mkRegex reg)) (\(e::SomeException) -> return Nothing)-#else- rx <- CE.catch ( Just `fmap` evaluate (mkRegex reg)) (\_ -> return Nothing)-#endif- case rx of- Nothing -> putStrLn $ "Invalid regex: " ++ arg- --Just rx -> mapM_ putStrLn $ sort [ nameTag (nameType v):' ':show v <+> "::" <+> ptype v | v <- Map.keys (hoDefs hoE), isJust (matchRegex rx (show v)), nameTag (nameType v) `elem` opt ]- Just rx -> mapM_ putStrLn $ sort [ pshow opt v | v <- Map.keys (hoDefs hoE), isJust (matchRegex rx (show v)), nameTag (nameType v) `elem` opt ]- return act- ptype x | Just r <- pprintTypeOfCons dataTable x = r- ptype k | Just r <- Map.lookup k (hoAssumps hoB) = show (pprint r:: PP.Doc)- ptype x | nameType x == ClassName = hsep (map kindShow $ kindOfClass x (hoKinds hoB))- ptype x = "UNKNOWN: " ++ show (nameType x,x)- isStart = isInitial { stateHo = hoB, stateImports = runIdentity $ calcImports hoE False (Module "Prelude") }- do_expr :: Interact -> String -> IO Interact- do_expr act s = case parseStmt (s ++ "\n") of- Left m -> putStrLn m >> return act- Right e -> do-#if BASE4- CE.catch (runIn isStart { stateInteract = act } $ executeStatement e) $ (\e -> putStrLn $ show (e::SomeException))-#else- CE.catch (runIn isStart { stateInteract = act } $ executeStatement e) $ (\e -> putStrLn $ show e)-#endif- return act- pshow _opt v- | Just d <- showSynonym (show . (pprint :: HsType -> PP.Doc) ) v (hoTypeSynonyms hoB) = nameTag (nameType v):' ':d- | otherwise = nameTag (nameType v):' ':show v <+> "::" <+> ptype v--kindShow (KBase b) = pprint b-kindShow x = parens (pprint x)--parseStmt :: Monad m => String -> m HsStmt-parseStmt s = case runParserWithMode (parseModeOptions options) { parseFilename = "(lhci)" } parseHsStmt s of- ParseOk _ e -> return e- ParseFailed sl err -> fail $ show sl ++ ": " ++ err--printStatement stmt = do- liftIO $ putStrLn $ HsPretty.render $ HsPretty.ppHsStmt $ stmt--procErrors :: In a -> In ()-procErrors act = do- b <- liftIO $ printIOErrors- if b then return () else act >> return ()---executeStatement :: HsStmt -> In ()-executeStatement stmt = do- is@IS { stateHo = hoB } <- ask- stmt <- desugarHsStmt stmt- stmt' <- renameStatement mempty (stateImports is) (stateModule is) stmt- procErrors $ do- --printStatement stmt'- stmt'' <- expandTypeSynsStmt (hoTypeSynonyms hoB) (stateModule is) stmt'- stmt''' <- return $ FrontEnd.Infix.infixStatement (hoFixities hoB) stmt''- procErrors $ do- printStatement stmt'''- tcStatementTc stmt'''--{--tcStatement :: HsStmt -> In ()-tcStatement HsLetStmt {} = liftIO $ putStrLn "let statements not yet supported"-tcStatement HsGenerator {} = liftIO $ putStrLn "generators not yet supported"-tcStatement (HsQualifier e) = do- tcStatementTc (HsQualifier e)- when False $ do- is@IS { stateHo = ho } <- ask- let importVarEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps ho, nameType x == Val ]- importDConsEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps ho, nameType x == DataConstructor ]- ansName = Qual (stateModule is) (HsIdent "ans")- ansName' = toName Val ansName- opt <- getOptions- localVarEnv <- liftIO $ TI.tiProgram- opt -- options- (stateModule is) -- name of the module- mempty -- environment of type signatures- (hoKinds ho) -- kind information about classes and type constructors- (hoClassHierarchy ho) -- class hierarchy with instances- importDConsEnv -- data constructor type environment- importVarEnv -- type environment- [([],[HsPatBind bogusASrcLoc (HsPVar ansName) (HsUnGuardedRhs e) []])] -- binding groups- []- procErrors $ do- vv <- Map.lookup ansName' localVarEnv- liftIO $ putStrLn $ show (text "::" <+> pprint vv :: P.Doc)- -}---tcStatementTc :: HsStmt -> In ()-tcStatementTc HsLetStmt {} = liftIO $ putStrLn "let statements not yet supported"-tcStatementTc HsGenerator {} = liftIO $ putStrLn "generators not yet supported"-tcStatementTc (HsQualifier e) = do- is@IS { stateHo = ho } <- ask- let tcInfo = tcInfoEmpty {- tcInfoEnv = (hoAssumps ho),- tcInfoSigEnv = collectSigEnv (hoKinds ho) (HsQualifier e),- tcInfoModName = show (stateModule is),- tcInfoKindInfo = (hoKinds ho),- tcInfoClassHierarchy = (hoClassHierarchy ho)-- }- runTc tcInfo $ do- box <- newBox kindFunRet- (_,ps') <- listenPreds $ tiExpr e box- ps' <- flattenType ps'- let ps = FrontEnd.Tc.Class.simplify (hoClassHierarchy ho) ps'- (ps :=> vv) <- flattenType (ps :=> box)- TForAll vs (ps :=> t) <- generalize ps vv -- quantify (tv vv) qt- --liftIO $ putStrLn $ show (text "::" <+> pprint vv' :: P.Doc)- liftIO $ putStrLn $ "::" <+> prettyPrintType (TForAll vs (ps :=> t))- ce <- getCollectedEnv- liftIO $ mapM_ putStrLn [ pprint n <+> "::" <+> prettyPrintType s | (n,s) <- Map.toList ce]---calcImports :: Monad m => HoExp -> Bool -> Module -> m [(Name,[Name])]-calcImports ho qual mod = case Map.lookup mod (hoExports ho) of- Nothing -> fail $ "calcImports: module not known " ++ show mod- Just es -> do- let ls = sortGroupUnderFG fst snd- [ (n,if qual then [setModule mod n] else [setModule mod n,toUnqualified n]) | n <- es]- ls' = concat [ zip (concat nns) (repeat [n]) | (n,nns) <- ls ]- return $ Map.toList $ Map.map snub $ Map.fromListWith (++) ls'-
src/Main.hs view
@@ -2,6 +2,7 @@ module Main(main) where import Control.Exception+import qualified Prelude as P (catch) import Control.Monad.Identity import Control.Monad.Writer import Control.Monad.State@@ -9,7 +10,7 @@ import Prelude hiding(putStrLn, putStr,print) import qualified Data.Map as Map import qualified Data.Set as Set-import qualified List+import qualified List(group,union) import qualified System import qualified System.Exit as Exit import Util.Util@@ -75,10 +76,10 @@ import qualified Grin.Simplify import qualified Grin.SSimplify import qualified Info.Info as Info-import qualified Interactive import qualified Stats import qualified System.IO as IO import System.FilePath (takeExtension)+import System.Directory (removeFile) #if BASE4 runMain action = Control.Exception.catches (action >> return ())@@ -125,13 +126,12 @@ processFiles [] | Nothing <- optMainFunc options = do- int <- isInteractive- when (not int) $ putErrDie "lhc: no input files"- processFilesModules [Left (Module "Prelude")]+ putErrDie "lhc: no input files"+ processFilesModules [Left (Module "Prelude")] processFiles [] | Just (b,m) <- optMainFunc options = do- m <- return $ parseName Val m- m <- getModule m- processFilesModules [Left m]+ m <- return $ parseName Val m+ m <- getModule m+ processFilesModules [Left m] processFiles cs = do processFilesModules (map fileOrModule cs) processFilesModules fs = do@@ -481,17 +481,10 @@ --idHistogram e = execWriter $ annotate mempty (\id nfo -> tell (Histogram.singleton id) >> return nfo) (\_ -> return) (\_ -> return) e -isInteractive :: IO Bool-isInteractive = do- pn <- System.getProgName- return $ (optMode options == Interactive)- || "ichj" `isPrefixOf` reverse pn- || not (null $ optStmts options)- transTypeAnalyze = transformParms { transformCategory = "typeAnalyze", transformOperation = typeAnalyze True } compileModEnv cho = do- if optMode options == CompileHo then return () else do+ if optMode options == GenerateHo then return () else do let dataTable = progDataTable prog prog = programUpdate program {@@ -513,10 +506,6 @@ wdump FD.Rules $ putStrLn " ---- user catalysts ---- " >> printRules RuleCatalyst rules' wdump FD.RulesSpec $ putStrLn " ---- specializations ---- " >> printRules RuleSpecialization rules' - -- enter interactive mode- int <- isInteractive- if int then Interactive.interact cho else do- when collectPassStats $ do Stats.print "PassStats" Stats.theStats Stats.clear Stats.theStats@@ -535,11 +524,11 @@ prog <- transformProgram transformParms { transformCategory = "PruneUnreachable", transformOperation = evaluate . programPruneUnreachable } prog prog <- barendregtProg prog - (viaGhc,fn,_,_) <- determineArch+ (fn,_,_) <- determineArch wdump FD.Progress $ putStrLn $ "Arch: " ++ fn let theTarget = ELit litCons { litName = dc_Target, litArgs = [ELit (LitInt targetIndex tEnumzh)], litType = ELit litCons { litName = tc_Target, litArgs = [], litType = eStar } }- targetIndex = if viaGhc then 1 else 0+ targetIndex = 0 prog <- return $ runIdentity $ flip programMapDs prog $ \(t,e) -> return $ if tvrIdent t == toId v_target then (t { tvrInfo = setProperty prop_INLINE mempty },theTarget) else (t,e) --wdump FD.Core $ printProgram prog@@ -573,6 +562,7 @@ prog <- transformProgram transformParms { transformCategory = "LambdaLift", transformDumpProgress = dump FD.Progress, transformOperation = lambdaLift } prog wdump FD.CoreAfterlift $ printProgram prog -- printCheckName dataTable (programE prog) compileToGrin prog+ cleanUp exitSuccess @@ -623,12 +613,6 @@ prog <- barendregtProg prog prog <- return $ runIdentity $ programMapBodies (return . cleanupE) prog - when viaGhc $ do- wdump FD.Core $ printProgram prog- fail "Compiling to GHC currently disabled"- --compileToHs prog- exitSuccess- wdump FD.CoreBeforelift $ printProgram prog prog <- transformProgram transformParms { transformCategory = "LambdaLift", transformDumpProgress = dump FD.Progress, transformOperation = lambdaLift } prog @@ -655,14 +639,22 @@ Stats.clear Stats.theStats compileToGrin prog-+ cleanUp+ where isOptMode = (==) (optMode options)+ rm x = P.catch (mapM_ removeFile x) (const $ return ())+ cleanUp = unless (isOptMode KeepTmpFiles) $ do+ let n = optOutName options+ -- FIXME: do this better+ unless (isOptMode GenerateHo || + isOptMode GenerateHoGrin) $ rm [n++".ho"]+ unless (isOptMode GenerateHoGrin) $ rm [n ++ "_final.grin"]+ unless (isOptMode GenerateC) $ rm [n ++ "_code.c"] -- | this gets rid of all type variables, replacing them with boxes that can hold any type -- the program is still type-safe, but all polymorphism has been removed in favor of -- implicit coercion to a universal type.---+-- -- also, all rules are deleted.- boxifyProgram :: Monad m => Program -> m Program boxifyProgram prog = ans where ans = do programMapDs f (progCombinators_u (map $ combRules_s []) prog)@@ -767,9 +759,9 @@ x <- transformGrin simplifyParms x x <- return $ twiddleGrin x dumpFinalGrin x+ -- don't generate C if we only ask for Ho and Grin files compileGrinToC x - dumpFinalGrin grin = do wdump FD.GrinGraph $ do let dot = graphGrin grin@@ -779,9 +771,10 @@ -compileGrinToC grin | optMode options == Interpret = fail "Interpretation currently not supported."-compileGrinToC grin | optMode options /= CompileExe = return ()-compileGrinToC grin = do++compileGrinToC grin | optMode options `elem` [GenerateExe+ ,GenerateC+ ,KeepTmpFiles] = do let (cg,rls) = FG2.compileGrin grin let fn = optOutName options let cf = (fn ++ "_code.c")@@ -797,12 +790,16 @@ (map ("-l" ++) rls) ++ debug ++ optCCargs options ++ boehmOpts ++ profileOpts debug = if fopts FO.Debug then ["-g"] else ["-DNDEBUG", "-O3", "-fomit-frame-pointer"] globalvar n c = "char " ++ n ++ "[] = \"" ++ c ++ "\";"- writeFile cf $ unlines [globalvar "lhc_c_compile" comm, globalvar "lhc_command" argstring,globalvar "lhc_version" sversion,"",cg]- progress ("Running: " ++ comm)- r <- System.system comm- when (r /= System.ExitSuccess) $ fail "C code did not compile."- return ()-+ compileC = do + progress ("Running: " ++ comm)+ r <- System.system comm+ when (r /= System.ExitSuccess) $ fail "C code did not compile."+ writeFile cf $ unlines [ globalvar "lhc_c_compile" comm+ , globalvar "lhc_command" argstring + , globalvar "lhc_version" sversion,"",cg ]+ -- only compile when we specify GenerateExe or KeepTmpFiles, otherwise we just emit C+ when (optMode options `elem` [KeepTmpFiles, GenerateExe]) compileC+compileGrinToC grin | otherwise = return () dumpCore pname prog = do let fn = optOutName options ++ "_" ++ pname ++ ".lhc_core"
src/Options.hs view
@@ -41,13 +41,13 @@ import LHCVersion data Mode = BuildHl String -- ^ Build the specified hl-file given a description file.- | Interactive -- ^ Run interactively. | Version -- ^ Print version and die. | ShowHelp -- ^ Show help message and die.- | Interpret -- ^ Interpret.- | CompileHo -- ^ Compile ho- | CompileHoGrin -- ^ Compile ho and grin- | CompileExe -- ^ Compile executable+ | GenerateHo -- ^ Generate ho+ | GenerateHoGrin -- ^ Generate ho and grin+ | GenerateC -- ^ Generate C file+ | GenerateExe -- ^ Generate executable+ | KeepTmpFiles -- ^ Keep ho grin C and generate executable | DependencyTree -- ^ show simple dependency tree | ShowHo String -- ^ Show ho-file. | ListLibraries -- ^ List libraries@@ -59,10 +59,8 @@ optColumns :: !Int, -- ^ Width of terminal. optDebug :: !Bool, -- ^ Debugging. optDump :: [String], -- ^ Dump options (raw).- optStmts :: [String], -- ^ statements to execute optFOpts :: [String], -- ^ Flag options (raw). optIncdirs :: [String], -- ^ Include directories.- optProgArgs :: [String], -- ^ Arguments to pass to the interpreted program. optCCargs :: [String], -- ^ Optional arguments to the C compiler. optHls :: [String], -- ^ Load the specified hl-files (haskell libraries). optHlPath :: [String], -- ^ Path to look for libraries.@@ -91,7 +89,7 @@ opt = Opt {- optMode = CompileExe,+ optMode = GenerateExe, optColumns = getColumns, optDebug = False, optIncdirs = initialIncludes,@@ -99,10 +97,8 @@ optHlPath = initialLibIncludes, optIncs = [], optDefs = [],- optProgArgs = [], optDump = [], optStale = [],- optStmts = [], optFOpts = ["default"], optCCargs = [], optHoDir = Nothing,@@ -141,24 +137,22 @@ , Option ['D'] [] (ReqArg (\d -> optDefs_u (d:)) "NAME=VALUE") "add new definitions to set in preprocessor" , Option [] ["optc"] (ReqArg (optCCargs_u . idu) "option") "extra options to pass to c compiler" , Option [] ["progc"] (ReqArg (\d -> optCC_s d) "gcc") "c compiler to use"- , Option [] ["arg"] (ReqArg (\d -> optProgArgs_u (++ [d])) "arg") "arguments to pass interpreted program" , Option ['N'] ["noprelude"] (NoArg (optPrelude_s False)) "no implicit prelude"- , Option ['C'] [] (NoArg (optMode_s CompileHoGrin)) "Typecheck, compile ho and grin."- , Option ['c'] [] (NoArg (optMode_s CompileHo)) "Typecheck and compile ho."- , Option [] ["interpret"] (NoArg (optMode_s Interpret)) "interpret."+ , Option ['C'] [] (NoArg (optMode_s GenerateHo)) "Typecheck and compile ho."+ , Option ['G'] [] (NoArg (optMode_s GenerateHoGrin)) "Typecheck, compile ho and grin."+ , Option ['c'] [] (NoArg (optMode_s GenerateC)) "generate C but don't link"+ , Option [] ["keep-tmp-files"] (NoArg (optMode_s KeepTmpFiles)) "keep all temporary files" , Option ['k'] ["keepgoing"] (NoArg (optKeepGoing_s True)) "keep going on errors." , Option [] ["width"] (ReqArg (optColumns_s . read) "COLUMNS") "width of screen for debugging output." , Option [] ["main"] (ReqArg (optMainFunc_s . Just . (,) False) "Main.main") "main entry point." , Option ['m'] ["arch"] (ReqArg (optArch_s . Just ) "arch") "target architecture." , Option [] ["entry"] (ReqArg (optMainFunc_s . Just . (,) True) "<expr>") "main entry point, showable expression."- , Option ['e'] [] (ReqArg (\d -> optStmts_u (d:)) "<statement>") "run given statement as if on lhci prompt" , Option [] ["debug"] (NoArg (optDebug_s True)) "debugging" , Option [] ["show-ho"] (ReqArg (optMode_s . ShowHo) "file.ho") "Show ho file" , Option [] ["noauto"] (NoArg (optNoAuto_s True)) "Don't automatically load base and haskell98 packages" , Option ['p'] [] (ReqArg (\d -> optHls_u (++ [d])) "file.hl") "Load given haskell library .hl file" , Option ['L'] [] (ReqArg (optHlPath_u . idu) "path") "Look for haskell libraries in the given directory." , Option [] ["build-hl"] (ReqArg (optMode_s . BuildHl) "file.cabal") "Build hakell library from given library description file"- , Option [] ["interactive"] (NoArg (optMode_s Interactive)) "run interactivly" , Option [] ["ignore-ho"] (NoArg (optIgnoreHo_s True)) "Ignore existing haskell object files" , Option [] ["nowrite-ho"] (NoArg (optNoWriteHo_s True)) "Do not write new haskell object files" , Option [] ["no-ho"] (NoArg (optNoWriteHo_s True . optIgnoreHo_s True)) "same as --ignore-ho and --nowrite-ho"
src/RawFiles.hs view
@@ -26,10 +26,6 @@ lhc_rts2_c :: String lhc_rts2_c = readf "rts/lhc_rts2.c" -{-# NOINLINE viaghc_hs #-}-viaghc_hs :: String-viaghc_hs = readf "ViaGhc.hs"- {-# NOINLINE prelude_m4 #-} prelude_m4 :: String prelude_m4 = readf "prelude.m4"