diff --git a/SSTG.cabal b/SSTG.cabal --- a/SSTG.cabal +++ b/SSTG.cabal @@ -1,5 +1,5 @@ name: SSTG -version: 0.1.1.1 +version: 0.1.1.2 synopsis: STG Symbolic Execution description: Prototype of STG-based Symbolic Execution for Haskell. homepage: https://github.com/AntonXue/SSTG#readme diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -58,7 +58,7 @@ -- Get command line arguments. (proj:src:tail_args) <- getArgs -- Make bindings. - binds <- mkTargetBindings proj src + binds <- mkTargetBinds proj src -- Configure entry. let entry = if length tail_args > 0 then tail_args !! 0 else "main" -- Get the flags. diff --git a/src/SSTG/Core/Execution/Engine.hs b/src/SSTG/Core/Execution/Engine.hs --- a/src/SSTG/Core/Execution/Engine.hs +++ b/src/SSTG/Core/Execution/Engine.hs @@ -16,7 +16,7 @@ -- | Load Result data LoadResult = LoadOkay State - | LoadGuess State [Binding] + | LoadGuess State [Bind] | LoadError String deriving (Show, Eq, Read) @@ -43,7 +43,7 @@ heap0 = empty_heap (glist, heap1, bnd_addrss) = initGlobals bnds heap0 globals0 = insertGlobalsList glist empty_globals - (heap2, localss) = liftBindings bnd_addrss globals0 heap1 + (heap2, localss) = liftBinds bnd_addrss globals0 heap1 bnd_locs = zip bnds localss -- Code loading. Completes heap and globals with symbolic injection. matches = entryMatches entry bnd_locs @@ -62,29 +62,28 @@ -- Gather information on all variables. state = state0 { state_names = allNames state0 } --- | Allocate Binding -allocBinding :: Binding -> Heap -> (Heap, [MemAddr]) -allocBinding (Binding _ pairs) heap = (heap', addrs) +-- | Allocate Bind +allocBind :: Bind -> Heap -> (Heap, [MemAddr]) +allocBind (Bind _ pairs) heap = (heap', addrs) where hfakes = map (const Blackhole) pairs (heap', addrs) = allocHeapList hfakes heap --- | Allocate List of Bindings -allocBindingList :: [Binding] -> Heap -> (Heap, [[MemAddr]]) -allocBindingList [] heap = (heap, []) -allocBindingList (b:bs) heap = (heapf, addrs : as) - where (heap', addrs) = allocBinding b heap - (heapf, as) = allocBindingList bs heap' +-- | Allocate List of `Bind`s +allocBindList :: [Bind] -> Heap -> (Heap, [[MemAddr]]) +allocBindList [] heap = (heap, []) +allocBindList (b:bs) heap = (heapf, addrs : as) + where (heap', addrs) = allocBind b heap + (heapf, as) = allocBindList bs heap' --- | Binding Address to Name Values -bndAddrsToVarVals :: (Binding, [MemAddr]) -> [(Var, Value)] -bndAddrsToVarVals (Binding _ rhss, addrs) = zip (map fst rhss) mem_vals +-- | Bind Address to Name Values +bndAddrsToVarVals :: (Bind, [MemAddr]) -> [(Var, Value)] +bndAddrsToVarVals (Bind _ rhss, addrs) = zip (map fst rhss) mem_vals where mem_vals = map (\a -> MemVal a) addrs -- | Initialize Globals -initGlobals :: [Binding] -> Heap -> - ([(Var, Value)], Heap, [(Binding, [MemAddr])]) +initGlobals :: [Bind] -> Heap -> ([(Var, Value)], Heap, [(Bind, [MemAddr])]) initGlobals bnds heap = (var_vals, heap', bnd_addrss) - where (heap', addrss) = allocBindingList bnds heap + where (heap', addrss) = allocBindList bnds heap bnd_addrss = zip bnds addrss var_vals = concatMap bndAddrsToVarVals bnd_addrss @@ -102,9 +101,9 @@ forceRhsObj (ConForm dcon args) locals globals = ConObj dcon arg_vals where arg_vals = map (\a -> forceLookupValue a locals globals) args --- | Lift Binding -liftBinding :: (Binding, [MemAddr]) -> Globals -> Heap -> (Heap, Locals) -liftBinding (Binding rec pairs, addrs) globals heap = (heap', locals) +-- | Lift `Bind`. +liftBind :: (Bind, [MemAddr]) -> Globals -> Heap -> (Heap, Locals) +liftBind (Bind rec pairs, addrs) globals heap = (heap', locals) where (vars, rhss) = unzip pairs mem_vals = map (\a -> MemVal a) addrs e_locs = empty_locals @@ -113,24 +112,24 @@ hobjs = map (\r -> forceRhsObj r locals globals) rhss heap' = insertHeapList (zip addrs hobjs) heap --- | Lift Binding List -liftBindings :: [(Binding, [MemAddr])] -> Globals -> Heap -> (Heap, [Locals]) -liftBindings [] _ heap = (heap, []) -liftBindings (bm:bms) globals heap = (heapf, locals : ls) - where (heap', locals) = liftBinding bm globals heap - (heapf, ls) = liftBindings bms globals heap' +-- | Lift Bind List +liftBinds :: [(Bind, [MemAddr])] -> Globals -> Heap -> (Heap, [Locals]) +liftBinds [] _ heap = (heap, []) +liftBinds (bm:bms) globals heap = (heapf, locals : ls) + where (heap', locals) = liftBind bm globals heap + (heapf, ls) = liftBinds bms globals heap' --- | Return a sub-list of bindings in which the entry candidate appears. -entryMatches :: String -> [(Binding, Locals)] -> [(Binding, Locals)] +-- | Return a sub-list of binds in which the entry candidate appears. +entryMatches :: String -> [(Bind, Locals)] -> [(Bind, Locals)] entryMatches entry bnd_locs = filter (bindFilter entry) bnd_locs -- | Bind Filtering -bindFilter :: String -> (Binding, Locals) -> Bool +bindFilter :: String -> (Bind, Locals) -> Bool bindFilter entry (bnd, _) = lhsMatches entry bnd /= [] --- | Sub-Bindings String Match -lhsMatches :: String -> Binding -> [(Var, BindRhs)] -lhsMatches st (Binding _ pairs) = +-- | Sub-Binds String Match +lhsMatches :: String -> Bind -> [(Var, BindRhs)] +lhsMatches st (Bind _ pairs) = filter (\(var, _) -> st == (nameOccStr . varName) var) pairs -- | Load Code diff --git a/src/SSTG/Core/Execution/Naming.hs b/src/SSTG/Core/Execution/Naming.hs --- a/src/SSTG/Core/Execution/Naming.hs +++ b/src/SSTG/Core/Execution/Naming.hs @@ -22,7 +22,7 @@ glbls_ns = globalsNames (state_globals state) expr_ns = codeNames (state_code state) pcons_ns = pconsNames (state_paths state) - acc_ns = stack_ns ++ heap_ns ++ glbls_ns ++ expr_ns ++ pcons_ns + acc_ns = stack_ns ++ heap_ns ++ glbls_ns ++ expr_ns ++ pcons_ns -- | `Name`s in a `Stack`. stackNames :: Stack -> [Name] @@ -37,7 +37,7 @@ -- | `Name`s in an `Alt`. altNames :: Alt -> [Name] -altNames (Alt _ vars expr) = (concatMap varNames vars) ++ exprNames expr +altNames (Alt _ vars expr) = concatMap varNames vars ++ exprNames expr -- | `Name`s in the `Locals` localsNames :: Locals -> [Name] @@ -66,7 +66,7 @@ -- | `Name`s in a `BindRhs`. bindRhsNames :: BindRhs -> [Name] -bindRhsNames (FunForm prms expr) = concatMap varNames prms ++ exprNames expr +bindRhsNames (FunForm prms expr) = concatMap varNames prms ++ exprNames expr bindRhsNames (ConForm dcon args) = concatMap atomNames args ++ dataNames dcon -- | `Name`s in a `Var`. @@ -90,21 +90,21 @@ -- | `Name`s in an `Expr`. exprNames :: Expr -> [Name] exprNames (Atom atom) = atomNames atom +exprNames (Let bnd expr) = exprNames expr ++ bindNames bnd exprNames (FunApp fun args) = varNames fun ++ concatMap atomNames args exprNames (PrimApp prim args) = pfunNames prim ++ concatMap atomNames args exprNames (ConApp dcon args) = dataNames dcon ++ concatMap atomNames args -exprNames (Let bnd expr) = exprNames expr ++ bindingNames bnd -exprNames (Case expr var alts) = exprNames expr ++ varNames var - ++ concatMap altNames alts +exprNames (Case expr var alts) = exprNames expr ++ concatMap altNames alts + ++ varNames var -- | `Name`s in a `Type`. typeNames :: Type -> [Name] typeNames (TyVarTy n ty) = n : typeNames ty typeNames (CoercionTy coer) = coercionNames coer -typeNames (AppTy t1 t2) = typeNames t1 ++ typeNames t2 -typeNames (CastTy ty coer) = typeNames ty ++ coercionNames coer +typeNames (AppTy t1 t2) = typeNames t1 ++ typeNames t2 +typeNames (CastTy ty coer) = typeNames ty ++ coercionNames coer +typeNames (ForAllTy bnd ty) = typeNames ty ++ tyBinderNames bnd +typeNames (FunTy t1 t2) = typeNames t1 ++ typeNames t2 typeNames (TyConApp tc ty) = tyConNames tc ++ concatMap typeNames ty -typeNames (ForAllTy bnd ty) = typeNames ty ++ tyBinderNames bnd -typeNames (FunTy t1 t2) = typeNames t1 ++ typeNames t2 typeNames (LitTy _) = [] typeNames (Bottom) = [] @@ -123,10 +123,10 @@ -- | `Name`s in a `TyCon`. tyConNames :: TyCon -> [Name] -tyConNames (FunTyCon n bs) = n : concatMap tyBinderNames bs -tyConNames (AlgTyCon n ns r) = n : ns ++ algTyRhsNames r -tyConNames (SynonymTyCon n ns) = n : ns tyConNames (FamilyTyCon n ns) = n : ns +tyConNames (SynonymTyCon n ns) = n : ns +tyConNames (AlgTyCon n ns r) = n : ns ++ algTyRhsNames r +tyConNames (FunTyCon n bs) = n : concatMap tyBinderNames bs tyConNames (PrimTyCon n bs) = n : concatMap tyBinderNames bs tyConNames (Promoted n bs dc) = n : concatMap tyBinderNames bs ++ dataNames dc @@ -141,9 +141,9 @@ algTyRhsNames (TupleTyCon n) = [n] algTyRhsNames (NewTyCon n) = [n] --- | `Name`s in a `Binding`. -bindingNames :: Binding -> [Name] -bindingNames (Binding _ bnd) = lhs ++ rhs +-- | `Name`s in a `Bind`. +bindNames :: Bind -> [Name] +bindNames (Bind _ bnd) = lhs ++ rhs where lhs = concatMap (varNames . fst) bnd rhs = concatMap (bindRhsNames . snd) bnd diff --git a/src/SSTG/Core/Execution/Rules.hs b/src/SSTG/Core/Execution/Rules.hs --- a/src/SSTG/Core/Execution/Rules.hs +++ b/src/SSTG/Core/Execution/Rules.hs @@ -107,13 +107,13 @@ -- | Lift a list of `Atom`s. liftAtomList :: LiftAct [Atom] -> LiftAct [Value] liftAtomList (LiftAct [] locals globals heap confs) = pass_out - where pass_out = LiftAct [] locals globals heap confs + where pass_out = LiftAct [] locals globals heap confs liftAtomList (LiftAct (atom:as) locals globals heap confs) = pass_out - where pass_in = LiftAct atom locals globals heap confs + where pass_in = LiftAct atom locals globals heap confs + pass_rest = LiftAct as locals' globals' heap' confs' + pass_out = LiftAct (val : vs) localsf globalsf heapf confsf LiftAct val locals' globals' heap' confs' = liftAtom pass_in - pass_rest = LiftAct as locals' globals' heap' confs' LiftAct vs localsf globalsf heapf confsf = liftAtomList pass_rest - pass_out = LiftAct (val : vs) localsf globalsf heapf confsf -- | Lift `BindRhs`. liftBindRhs :: LiftAct BindRhs -> LiftAct HeapObj @@ -121,40 +121,40 @@ where pass_out = LiftAct (FunObj prms expr locals) locals globals heap confs liftBindRhs (LiftAct (ConForm dcon args) locals globals heap confs) = pass_out where pass_in = LiftAct args locals globals heap confs - LiftAct vals locals' globals' heap' confs' = liftAtomList pass_in pass_out = LiftAct (ConObj dcon vals) locals' globals' heap' confs' + LiftAct vals locals' globals' heap' confs' = liftAtomList pass_in -- | Lift `BindRhs` list. liftBindRhsList :: LiftAct [BindRhs] -> LiftAct [HeapObj] liftBindRhsList (LiftAct [] locals globals heap confs) = pass_out - where pass_out = LiftAct [] locals globals heap confs + where pass_out = LiftAct [] locals globals heap confs liftBindRhsList (LiftAct (rhs:rs) locals globals heap confs) = pass_out - where pass_in = LiftAct rhs locals globals heap confs - LiftAct hobj locals' globals' heap' confs' = liftBindRhs pass_in - pass_rest = LiftAct rs locals' globals' heap' confs' - LiftAct hos localsf globalsf heapf confsf = liftBindRhsList pass_rest + where pass_in = LiftAct rhs locals globals heap confs + pass_rest = LiftAct rs locals' globals' heap' confs' pass_out = LiftAct (hobj : hos) localsf globalsf heapf confsf + LiftAct hobj locals' globals' heap' confs' = liftBindRhs pass_in + LiftAct hos localsf globalsf heapf confsf = liftBindRhsList pass_rest --- | Lift `Binding`. -liftBinding :: LiftAct Binding -> LiftAct () -liftBinding (LiftAct (Binding NonRec bnd) locals globals heap confs) = pass_out - where pass_in = LiftAct (map snd bnd) locals globals heap confs - LiftAct hobjs locals' globals' heap' confs' = liftBindRhsList pass_in - (heapf, addrs) = allocHeapList hobjs heap' +-- | Lift `Bind`. +liftBind :: LiftAct Bind -> LiftAct () +liftBind (LiftAct (Bind NonRec bnd) locals globals heap confs) = pass_out + where (heapf, addrs) = allocHeapList hobjs heap' mem_vals = map MemVal addrs localsf = insertLocalsList (zip (map fst bnd) mem_vals) locals' + pass_in = LiftAct (map snd bnd) locals globals heap confs pass_out = LiftAct () localsf globals' heapf confs' -liftBinding (LiftAct (Binding Rec bnd) locals globals heap confs) = pass_out + LiftAct hobjs locals' globals' heap' confs' = liftBindRhsList pass_in +liftBind (LiftAct (Bind Rec bnd) locals globals heap confs) = pass_out where hfakes = map (const Blackhole) bnd -- Allocate dummy BLACKHOLEs (heap', addrs) = allocHeapList hfakes heap mem_vals = map MemVal addrs -- Use the reigstered loca BLACKHOLEs to construct the locals closure. locals' = insertLocalsList (zip (map fst bnd) mem_vals) locals - pass_in = LiftAct (map snd bnd) locals' globals heap' confs - LiftAct hobjs localsf globals' heap'' confs' = liftBindRhsList pass_in heapf = insertHeapList (zip addrs hobjs) heap'' + pass_in = LiftAct (map snd bnd) locals' globals heap' confs pass_out = LiftAct () localsf globals' heapf confs' + LiftAct hobjs localsf globals' heap'' confs' = liftBindRhsList pass_in -- | `Default` `Alt` branches in a `Case`. defaultAlts :: [Alt] -> [Alt] @@ -331,7 +331,7 @@ -- Rule Let | Evaluate (Let bnd expr) locals <- code = let pass_in = LiftAct bnd locals globals heap confs - LiftAct _ locals' globals' heap' confs' = liftBinding pass_in + LiftAct _ locals' globals' heap' confs' = liftBind pass_in in Just (RuleLet ,[state { state_heap = heap' , state_globals = globals' @@ -390,9 +390,9 @@ acon_sts = map (liftedAltToState state) acon_lifts -- Make DEFAULT states next. all_conss = concatMap (\(LiftAct (_, c) _ _ _ _) -> c) acon_lifts - negs = map negateConstraint all_conss + negatives = map negateConstraint all_conss def_lifts' = map (\(LiftAct (e, _) l g h c) -> - (LiftAct (e, negs) l g h c)) def_lifts + (LiftAct (e, negatives) l g h c)) def_lifts def_sts = map (liftedAltToState state) def_lifts' in Just (RuleCaseSym, acon_sts ++ def_sts) @@ -498,14 +498,14 @@ -- Rule Apply Frame Delete ReturnPtr Sym | Just (ApplyFrame args frm_locs, stack') <- popStack stack , Return (MemVal addr) <- code - , Just hobj <- lookupHeap addr heap - , SymObj (Symbol sym _) <- hobj = - let sname = freshSeededName (varName sym) confs - svar = Var sname (varType sym) - frm_locs' = insertLocals (svar, MemVal addr) frm_locs + , Just hobj <- lookupHeap addr heap + , SymObj (Symbol svar _) <- hobj = + let sname = freshSeededName (varName svar) confs + svar' = Var sname (varType svar) + frm_locs' = insertLocals (svar', MemVal addr) frm_locs in Just (RuleApplyDReturnSym ,[state { state_stack = stack' - , state_code = Evaluate (FunApp svar args) frm_locs' + , state_code = Evaluate (FunApp svar' args) frm_locs' , state_names = sname : confs }]) -- State is Value Form diff --git a/src/SSTG/Core/Execution/Support.hs b/src/SSTG/Core/Execution/Support.hs --- a/src/SSTG/Core/Execution/Support.hs +++ b/src/SSTG/Core/Execution/Support.hs @@ -83,12 +83,14 @@ -- | Applicative instance of Symbolic Transformation. instance Applicative (SymbolicT s) where pure a = SymbolicT (\s -> (s, a)) + sf <*> st = SymbolicT (\s0 -> let (s1, a1) = (run st) s0 (s2, f2) = (run sf) s1 in (s2, f2 a1)) -- | Monad instance of Symbolic Transformation. instance Monad (SymbolicT s) where return a = pure a + st >>= fs = SymbolicT (\s0 -> let (s1, a1) = (run st) s0 (s2, a2) = (run (fs a1)) s1 in (s2, a2)) @@ -340,7 +342,7 @@ AddrObj redir -> memAddrType redir heap LitObj lit -> Just (litType lit) SymObj (Symbol s _) -> Just (varType s) - ConObj dcon _ -> Just (dataConType dcon) + ConObj dcon _ -> Just (dataconType dcon) FunObj ps e _ -> Just (foldr FunTy (exprType e) (map varType ps)) Blackhole -> Just Bottom diff --git a/src/SSTG/Core/Language/Syntax.hs b/src/SSTG/Core/Language/Syntax.hs --- a/src/SSTG/Core/Language/Syntax.hs +++ b/src/SSTG/Core/Language/Syntax.hs @@ -11,7 +11,7 @@ type Expr = GenExpr Name Var type Alt = GenAlt Name Var type AltCon = GenAltCon Name Var -type Binding = GenBinding Name Var +type Bind = GenBind Name Var type BindRhs = GenBindRhs Name Var type DataCon = GenDataCon Name @@ -24,7 +24,7 @@ -- | A `Program` is defined as a list of bindings. The @bnd@ is an identifier -- that determines a unique binder to the @var@. In practice, these are defined -- to be `Name` and `Var` respectively. -newtype GenProgram bnd var = Program [GenBinding bnd var] +newtype GenProgram bnd var = Program [GenBind bnd var] deriving (Show, Eq, Read) -- | Variables, data constructors, type variables, and type constructors. @@ -74,7 +74,7 @@ | PrimApp (GenPrimFun bnd var) [GenAtom bnd var] | ConApp (GenDataCon bnd) [GenAtom bnd var] | FunApp var [GenAtom bnd var] - | Let (GenBinding bnd var) (GenExpr bnd var) + | Let (GenBind bnd var) (GenExpr bnd var) | Case (GenExpr bnd var) var [GenAlt bnd var] deriving (Show, Eq, Read) @@ -89,9 +89,9 @@ | Default deriving (Show, Eq, Read) --- | Binding -data GenBinding bnd var = Binding RecForm [(var, GenBindRhs bnd var)] - deriving (Show, Eq, Read) +-- | Bind +data GenBind bnd var = Bind RecForm [(var, GenBindRhs bnd var)] + deriving (Show, Eq, Read) -- | Recursive? data RecForm = Rec | NonRec deriving (Show, Eq, Read) diff --git a/src/SSTG/Core/Language/Typing.hs b/src/SSTG/Core/Language/Typing.hs --- a/src/SSTG/Core/Language/Typing.hs +++ b/src/SSTG/Core/Language/Typing.hs @@ -22,20 +22,20 @@ litType (BlankAddr) = Bottom litType (AddrLit _) = Bottom litType (SymLit var) = varType var -litType (SymLitEval pf args) = foldl AppTy (primFunType pf) (map litType args) +litType (SymLitEval pf args) = foldl AppTy (primfunType pf) (map litType args) -- | Atom type. atomType :: Atom -> Type -atomType (VarAtom var) = varType var atomType (LitAtom lit) = litType lit +atomType (VarAtom var) = varType var -- | Primitive function type. -primFunType :: PrimFun -> Type -primFunType (PrimFun _ ty) = ty +primfunType :: PrimFun -> Type +primfunType (PrimFun _ ty) = ty -- | Data constructor type denoted as a function. -dataConType :: DataCon -> Type -dataConType (DataCon _ ty tys) = foldr FunTy ty tys +dataconType :: DataCon -> Type +dataconType (DataCon _ ty tys) = foldr FunTy ty tys -- | Alt type altType :: Alt -> Type @@ -44,8 +44,8 @@ -- | I wonder what this could possibly be? exprType :: Expr -> Type exprType (Atom atom) = atomType atom -exprType (PrimApp pf args) = foldl AppTy (primFunType pf) (map atomType args) -exprType (ConApp dc args) = foldl AppTy (dataConType dc) (map atomType args) +exprType (PrimApp pf args) = foldl AppTy (primfunType pf) (map atomType args) +exprType (ConApp dc args) = foldl AppTy (dataconType dc) (map atomType args) exprType (FunApp fun args) = foldl AppTy (varType fun) (map atomType args) exprType (Let _ expr) = exprType expr exprType (Case _ _ (a:_)) = altType a diff --git a/src/SSTG/Core/Translation/Haskell.hs b/src/SSTG/Core/Translation/Haskell.hs --- a/src/SSTG/Core/Translation/Haskell.hs +++ b/src/SSTG/Core/Translation/Haskell.hs @@ -1,8 +1,9 @@ -- | Haskell Translation module SSTG.Core.Translation.Haskell - ( mkCompileClosure - , mkTargetBindings - , mkIOStr + ( CompileClosure + , mkCompileClosure + , mkTargetBinds + , mkIOString ) where import qualified SSTG.Core.Language as SL @@ -30,16 +31,16 @@ import qualified Data.Maybe as MB -- | Make IO String from Outputable. -mkIOStr :: (Outputable a) => a -> IO String -mkIOStr obj = runGhc (Just libdir) $ do +mkIOString :: (Outputable a) => a -> IO String +mkIOString obj = runGhc (Just libdir) $ do dflags <- getSessionDynFlags let ppr_str = showPpr dflags obj return ppr_str -- | Given the project directory and the source file path, compiles the --- `ModuleGraph` and translates it into a SSTG `Binding`s. -mkTargetBindings :: FilePath -> FilePath -> IO [SL.Binding] -mkTargetBindings proj src = do +-- `ModuleGraph` and translates it into a SSTG `Bind`s. +mkTargetBinds :: FilePath -> FilePath -> IO [SL.Bind] +mkTargetBinds proj src = do (sums_gutss, dflags, env) <- mkCompileClosure proj src let (sums, gutss) = (map fst sums_gutss, map snd sums_gutss) let mod_lcs = map (\s -> (ms_mod s, ms_location s)) sums @@ -50,16 +51,18 @@ preps <- mapM (\((m, l), b, t) -> corePrepPgm env m l b t) z1 let z2 = zip (map fst mod_lcs) preps s_bndss <- mapM (\(m, p) -> coreToStg dflags m p) z2 - -- Create the bindings. - let sl_bnds = map mkBinding (concat s_bndss) + -- Create the binds. + let sl_bnds = map mkBind (concat s_bndss) return sl_bnds +-- | Compilation closure type. +type CompileClosure = ([(ModSummary, ModGuts)], DynFlags, HscEnv) + -- | Captures a snapshot of the `DynFlags` and `HscEnv` in addition to the -- `ModGuts` in the `ModuleGraph`. This allows compilation to be, in theory, -- more portable across different applications, since `ModGuts` is a crucial -- intermediary for compilation in general. -mkCompileClosure :: FilePath -> FilePath -> - IO ([(ModSummary, ModGuts)], DynFlags, HscEnv) +mkCompileClosure :: FilePath -> FilePath -> IO CompileClosure mkCompileClosure proj src = runGhc (Just libdir) $ do beta_flags <- getSessionDynFlags let dflags = beta_flags { importPaths = [proj] } @@ -85,7 +88,7 @@ mkExpr (StgOpApp op args _) = SL.PrimApp (mkPrimOp op) (map mkAtom args) mkExpr (StgTick _ expr) = mkExpr expr mkExpr (StgLam _ _) = error "mkExpr: StgLam detected" -mkExpr (StgLet bnd expr) = SL.Let (mkBinding bnd) (mkExpr expr) +mkExpr (StgLet bnd expr) = SL.Let (mkBind bnd) (mkExpr expr) mkExpr (StgLetNoEscape _ _ bnd expr) = mkExpr (StgLet bnd expr) mkExpr (StgCase mexpr _ _ bndr _ _ alts) = SL.Case (mkExpr mexpr) (mkVar bndr) (map mkAlt alts) @@ -119,11 +122,11 @@ where vname = (mkName . V.varName) var vtype = (mkType . varType) var --- | Make SSTG Binding -mkBinding :: StgBinding -> SL.Binding -mkBinding (StgNonRec bnd r) = SL.Binding SL.NonRec [(mkVar bnd, mkRhs r)] -mkBinding (StgRec bnd) = SL.Binding SL.Rec (map (\(b, r) -> - (mkVar b, mkRhs r)) bnd) +-- | Make SSTG `Bind`. +mkBind :: StgBinding -> SL.Bind +mkBind (StgNonRec bnd r) = SL.Bind SL.NonRec [(mkVar bnd, mkRhs r)] +mkBind (StgRec bnd) = SL.Bind SL.Rec (map (\(b, r) -> + (mkVar b, mkRhs r)) bnd) -- | Make SSTG `BindRhs`. mkRhs :: StgRhs -> SL.BindRhs @@ -180,7 +183,7 @@ mkType :: Type -> SL.Type mkType (AppTy t1 t2) = SL.AppTy (mkType t1) (mkType t2) mkType (TyConApp tc ts) = SL.TyConApp (mkTyCon tc) (map mkType ts) -mkType (ForAllTy b ty) = SL.ForAllTy (mkTyBndr b) (mkType ty) +mkType (ForAllTy b ty) = SL.ForAllTy (mkTyBinder b) (mkType ty) mkType (LitTy tlit) = SL.LitTy (mkTyLit tlit) mkType (CastTy ty cor) = SL.CastTy (mkType ty) (mkCoercion cor) mkType (CoercionTy cor) = SL.CoercionTy (mkCoercion cor) @@ -198,7 +201,7 @@ | otherwise = error "mkTyCon: unrecognized TyCon" where name = (mkName . tyConName) tc algrhs = (mkAlgTyConRhs . algTyConRhs) tc - tcbndrs = map mkTyBndr (tyConBinders tc) + tcbndrs = map mkTyBinder (tyConBinders tc) tvnames = map (mkName. V.varName) (tyConTyVars tc) dcon = (mkData . MB.fromJust . isPromotedDataCon_maybe) tc @@ -210,9 +213,9 @@ mkAlgTyConRhs (NewTyCon {data_con = d}) = SL.NewTyCon (mkDataName d) -- | make SSTG `TyBinder`. -mkTyBndr :: TyBinder -> SL.TyBinder -mkTyBndr (Anon _) = SL.AnonTyBndr -mkTyBndr (Named v _) = SL.NamedTyBndr (mkName (V.varName v)) +mkTyBinder :: TyBinder -> SL.TyBinder +mkTyBinder (Anon _) = SL.AnonTyBndr +mkTyBinder (Named v _) = SL.NamedTyBndr (mkName (V.varName v)) -- | Make SSTG `Type` literals. mkTyLit :: TyLit -> SL.TyLit diff --git a/src/SSTG/Utils/Printing.hs b/src/SSTG/Utils/Printing.hs --- a/src/SSTG/Utils/Printing.hs +++ b/src/SSTG/Utils/Printing.hs @@ -2,7 +2,7 @@ module SSTG.Utils.Printing ( pprStateStr , pprLivesDeadsStr - , pprBindingStr + , pprBindStr ) where import SSTG.Core @@ -283,17 +283,17 @@ acc_strs = [header, dcon_str, args_str] -- | Print @(Var, BindRhs)@. -pprBindStr :: (Var, BindRhs) -> String -pprBindStr (var, lamf) = (sub . injComma) acc_strs +pprBindKVStr :: (Var, BindRhs) -> String +pprBindKVStr (var, lamf) = (sub . injComma) acc_strs where var_str = pprVarStr var lamf_str = pprBindRhsStr lamf acc_strs = [var_str, lamf_str] --- | Print `Binding`. -pprBindingStr :: Binding -> String -pprBindingStr (Binding rec bnd) = injSpace acc_strs +-- | Print `Bind`. +pprBindStr :: Bind -> String +pprBindStr (Bind rec bnd) = injSpace acc_strs where header = case rec of { Rec -> "Rec"; NonRec -> "NonRec" } - bnds_str = injIntoList (map pprBindStr bnd) + bnds_str = injIntoList (map pprBindKVStr bnd) acc_strs = [header, bnds_str] -- | Print `Expr`. @@ -325,7 +325,7 @@ acc_strs = [header, expr_str, var_str, alts_str] pprExprStr (Let bnd expr) = injSpace acc_strs where header = "Let" - bnd_str = (sub . pprBindingStr) bnd + bnd_str = (sub . pprBindStr) bnd expr_str = (sub . pprExprStr) expr acc_strs = [header, bnd_str, expr_str]