SSTG 0.1.1.1 → 0.1.1.2

raw patch · 10 files changed

+128/−124 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• SSTG.cabal +1/−1
• app/Main.hs +1/−1
• src/SSTG/Core/Execution/Engine.hs +31/−32
• src/SSTG/Core/Execution/Naming.hs +16/−16
• src/SSTG/Core/Execution/Rules.hs +28/−28
• src/SSTG/Core/Execution/Support.hs +3/−1
• src/SSTG/Core/Language/Syntax.hs +6/−6
• src/SSTG/Core/Language/Typing.hs +8/−8
• src/SSTG/Core/Translation/Haskell.hs +26/−23
• src/SSTG/Utils/Printing.hs +8/−8

@@ -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

@@ -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.

@@ -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

@@ -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 

@@ -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

@@ -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 

@@ -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)

@@ -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

@@ -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

@@ -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]