diff --git a/app/Main.hs b/app/Main.hs index c071dbc..6c11ecd 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -133,7 +133,7 @@ ddumpEval = whenFlag flagDDumpEval do parseProg :: RLPCOptions -> String - -> Either SrcError (Program, [SrcError]) + -> Either SrcError (CoreProgram, [SrcError]) parseProg o = evalRLPC o . (lexCore >=> parseCoreProg) forFiles_ :: (Monad m) diff --git a/rlp.cabal b/rlp.cabal index f604254..c4249e6 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -14,7 +14,7 @@ extra-doc-files: README.md -- extra-source-files: common warnings - ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds +-- ghc-options: -Wall -Wno-incomplete-uni-patterns -Wno-unused-top-binds library import: warnings @@ -23,6 +23,7 @@ library , GM , Compiler.RLPC , Core.Syntax + , Core.Utils other-modules: Data.Heap , Data.Pretty @@ -31,6 +32,7 @@ library , Core.Examples , Core.Lex , Control.Monad.Errorful + , Core2Core build-tool-depends: happy:happy, alex:alex @@ -47,6 +49,7 @@ library , unordered-containers , hashable , pretty + , recursion-schemes hs-source-dirs: src default-language: GHC2021 diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index d828554..b775a8f 100644 --- a/src/Core/Examples.hs +++ b/src/Core/Examples.hs @@ -12,7 +12,6 @@ import Core.TH -- TODO: my shitty lexer isn't inserting semicolons -letrecExample :: Program letrecExample = [coreProg| pair x y f = f x y; @@ -28,7 +27,6 @@ letrecExample = [coreProg| main = f 3 4; |] -idExample :: Program idExample = [coreProg| main = id 3; |] @@ -138,7 +136,7 @@ factorialGM = [coreProg| main = fac 3; |] -corePrelude :: Module +corePrelude :: Module Name corePrelude = Module (Just ("Prelude", [])) $ -- non-primitive defs [coreProg| diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 89a7035..1654038 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -58,7 +58,7 @@ import Data.Default.Class (def) %% -Module :: { Module } +Module :: { Module Name } Module : module conname where Program Eof { Module (Just ($2, [])) $4 } | Program Eof { Module Nothing $1 } @@ -66,36 +66,36 @@ Eof :: { () } Eof : eof { () } | error { () } -StandaloneProgram :: { Program } +StandaloneProgram :: { Program Name } StandaloneProgram : Program eof { $1 } -Program :: { Program } +Program :: { Program Name } Program : ScDefs { Program $1 } -ScDefs :: { [ScDef] } +ScDefs :: { [ScDef Name] } ScDefs : ScDef ';' ScDefs { $1 : $3 } | ScDef ';' { [$1] } | ScDef { [$1] } | {- epsilon -} { [] } -ScDef :: { ScDef } +ScDef :: { ScDef Name } ScDef : Var ParList '=' Expr { ScDef $1 $2 $4 } ParList :: { [Name] } ParList : Var ParList { $1 : $2 } | {- epsilon -} { [] } -StandaloneExpr :: { Expr } +StandaloneExpr :: { Expr Name } StandaloneExpr : Expr eof { $1 } -Expr :: { Expr } +Expr :: { Expr Name } Expr : LetExpr { $1 } | 'λ' Binders '->' Expr { Lam $2 $4 } | Application { $1 } | CaseExpr { $1 } | Expr1 { $1 } -LetExpr :: { Expr } +LetExpr :: { Expr Name } LetExpr : let '{' Bindings '}' in Expr { Let NonRec $3 $6 } | letrec '{' Bindings '}' in Expr { Let Rec $3 $6 } @@ -103,48 +103,48 @@ Binders :: { [Name] } Binders : Var Binders { $1 : $2 } | Var { [$1] } -Application :: { Expr } +Application :: { Expr Name } Application : Expr1 AppArgs { foldl' App $1 $2 } -- TODO: Application can probably be written as a single rule, without AppArgs -AppArgs :: { [Expr] } +AppArgs :: { [Expr Name] } AppArgs : Expr1 AppArgs { $1 : $2 } | Expr1 { [$1] } -CaseExpr :: { Expr } +CaseExpr :: { Expr Name } CaseExpr : case Expr of '{' Alters '}' { Case $2 $5 } -Alters :: { [Alter] } +Alters :: { [Alter Name] } Alters : Alter ';' Alters { $1 : $3 } | Alter ';' { [$1] } | Alter { [$1] } -Alter :: { Alter } -Alter : litint ParList '->' Expr { Alter $1 $2 $4 } +Alter :: { Alter Name } +Alter : litint ParList '->' Expr { Alter (AltData $1) $2 $4 } -Expr1 :: { Expr } -Expr1 : litint { IntE $1 } +Expr1 :: { Expr Name } +Expr1 : litint { LitE $ IntL $1 } | Id { Var $1 } | PackCon { $1 } | ExprPragma { $1 } | '(' Expr ')' { $2 } -ExprPragma :: { Expr } +ExprPragma :: { Expr Name } ExprPragma : '{-#' Words '#-}' {% exprPragma $2 } Words :: { [String] } Words : word Words { $1 : $2 } | word { [$1] } -PackCon :: { Expr } +PackCon :: { Expr Name } PackCon : pack '{' litint litint '}' { Con $3 $4 } -Bindings :: { [Binding] } +Bindings :: { [Binding Name] } Bindings : Binding ';' Bindings { $1 : $3 } | Binding ';' { [$1] } | Binding { [$1] } -Binding :: { Binding } +Binding :: { Binding Name } Binding : Var '=' Expr { $1 := $3 } Id :: { Name } @@ -169,7 +169,7 @@ parseError (Located y x l _ : _) = addFatal err , _errDiagnostic = SrcErrParse } -parseTmp :: IO Module +parseTmp :: IO (Module Name) parseTmp = do s <- readFile "/tmp/t.hs" case parse s of @@ -178,7 +178,7 @@ parseTmp = do where parse = evalRLPC def . (lexCore >=> parseCore) -exprPragma :: [String] -> RLPC SrcError Expr +exprPragma :: [String] -> RLPC SrcError (Expr Name) exprPragma ("AST" : e) = astPragma e exprPragma _ = addFatal err where err = SrcError @@ -187,7 +187,7 @@ exprPragma _ = addFatal err , _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma } -astPragma :: [String] -> RLPC SrcError Expr +astPragma :: [String] -> RLPC SrcError (Expr Name) astPragma = pure . read . unwords } diff --git a/src/Core/Rename.hs b/src/Core/Rename.hs new file mode 100644 index 0000000..bf28005 --- /dev/null +++ b/src/Core/Rename.hs @@ -0,0 +1,11 @@ +module Core.Rename + ( renameCore + ) + where +---------------------------------------------------------------------------------- +import Core.Syntax +---------------------------------------------------------------------------------- + +renameCore :: Program Name -> Program Unique +renameCore = undefined + diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index f68482b..3d0a1ca 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -3,10 +3,13 @@ Module : Core.Syntax Description : Core ASTs and the like -} {-# LANGUAGE PatternSynonyms, OverloadedStrings #-} +{-# LANGUAGE FunctionalDependencies #-} module Core.Syntax ( Expr(..) + , Literal(..) , pattern (:$) , Binding(..) + , AltCon(..) , pattern (:=) , Rec(..) , Alter(..) @@ -15,142 +18,113 @@ module Core.Syntax , ScDef(..) , Module(..) , Program(..) - , bindersOf - , rhssOf - , isAtomic - , insertModule - , extractProgram + , Program' + , Expr' + , ScDef' + , Alter' + , Binding' + , HasRHS(_rhs) ) where ---------------------------------------------------------------------------------- import Data.Coerce import Data.Pretty +import GHC.Generics import Data.List (intersperse) import Data.Function ((&)) import Data.String +-- Lift instances for the Core quasiquoters +import Lens.Micro import Language.Haskell.TH.Syntax (Lift) ---------------------------------------------------------------------------------- -data Expr = Var Name - | Con Tag Int -- Con Tag Arity - | Let Rec [Binding] Expr - | Case Expr [Alter] - | Lam [Name] Expr - | App Expr Expr - | IntE Int - deriving (Show, Read, Lift, Eq) +data Expr b = Var Name + | Con Tag Int -- Con Tag Arity + | Case (Expr b) [Alter b] + | Lam [b] (Expr b) + | Let Rec [Binding b] (Expr b) + | App (Expr b) (Expr b) + | LitE Literal + deriving (Show, Read, Lift) + +deriving instance (Eq b) => Eq (Expr b) infixl 2 :$ -pattern (:$) :: Expr -> Expr -> Expr +pattern (:$) :: Expr b -> Expr b -> Expr b pattern f :$ x = App f x {-# COMPLETE Binding :: Binding #-} {-# COMPLETE (:=) :: Binding #-} -data Binding = Binding Name Expr - deriving (Show, Read, Lift, Eq) +data Binding b = Binding b (Expr b) + deriving (Show, Read, Lift) + +deriving instance (Eq b) => Eq (Binding b) infixl 1 := -pattern (:=) :: Name -> Expr -> Binding +pattern (:=) :: b -> (Expr b) -> (Binding b) pattern k := v = Binding k v +data Alter b = Alter AltCon [b] (Expr b) + deriving (Show, Read, Lift) + +deriving instance (Eq b) => Eq (Alter b) + data Rec = Rec | NonRec deriving (Show, Read, Eq, Lift) -data Alter = Alter Tag [Name] Expr - deriving (Show, Read, Lift, Eq) +data AltCon = AltData Tag + | AltLiteral Literal + | Default + deriving (Show, Read, Eq, Lift) + +data Literal = IntL Int + deriving (Show, Read, Eq, Lift) type Name = String type Tag = Int -data ScDef = ScDef Name [Name] Expr - deriving (Show, Lift, Eq) - -data Module = Module (Maybe (Name, [Name])) Program +data ScDef b = ScDef b [b] (Expr b) deriving (Show, Lift) -newtype Program = Program [ScDef] +data Module b = Module (Maybe (Name, [Name])) (Program b) deriving (Show, Lift) -instance IsString Expr where +newtype Program b = Program [ScDef b] + deriving (Show, Lift) + +type Program' = Program Name +type Expr' = Expr Name +type ScDef' = ScDef Name +type Alter' = Alter Name +type Binding' = Binding Name + +instance IsString (Expr b) where fromString = Var ----------------------------------------------------------------------------------- +instance Semigroup (Program b) where + (<>) = coerce $ (<>) @[ScDef b] -instance Pretty Program where - -- TODO: module header - prettyPrec (Program ss) _ = mconcat $ intersperse "\n\n" $ fmap pretty ss - -instance Pretty ScDef where - prettyPrec (ScDef n as e) _ = - mconcat (intersperse " " $ fmap IStr (n:as)) - <> " = " <> pretty e <> IBreak - -instance Pretty Expr where - prettyPrec (Var k) = withPrec maxBound $ IStr k - prettyPrec (IntE n) = withPrec maxBound $ iShow n - prettyPrec (Con t a) = withPrec maxBound $ - "Pack{" <> iShow t <> " " <> iShow a <> "}" - prettyPrec (Let r bs e) = withPrec 0 $ - IStr (if r == Rec then "letrec " else "let ") - <> binds <> IBreak - <> "in " <> pretty e - where - binds = mconcat (f <$> init bs) - <> IIndent (pretty $ last bs) - f b = IIndent $ pretty b <> IBreak - prettyPrec (Lam ns e) = withPrec 0 $ - IStr "λ" <> binds <> " -> " <> pretty e - where - binds = fmap IStr ns & intersperse " " & mconcat - prettyPrec (Case e as) = withPrec 0 $ - "case " <> IIndent (pretty e <> " of" <> IBreak <> alts) - where - -- TODO: don't break on last alt - alts = mconcat $ fmap palt as - palt x = IIndent $ pretty x <> IBreak - prettyPrec (App f x) = \p -> bracketPrec 0 p $ - case f of - -- application is left-associative; don't increase prec if the - -- expression being applied is itself an application - (_:$_) -> precPretty p f <> " " <> precPretty (succ p) x - _ -> precPretty (succ p) f <> " " <> precPretty (succ p) x - -instance Pretty Alter where - prettyPrec (Alter t bs e) = withPrec 0 $ - "<" <> IStr (show t) <> "> " <> binds <> " -> " <> pretty e - where - binds = mconcat $ intersperse " " (fmap IStr bs) - -instance Pretty Binding where - prettyPrec (k := v) = withPrec 0 $ IStr k <> " = " <> precPretty 0 v - ----------------------------------------------------------------------------------- - -instance Semigroup Program where - (<>) = coerce $ (<>) @[ScDef] - -instance Monoid Program where +instance Monoid (Program b) where mempty = Program [] ---------------------------------------------------------------------------------- -bindersOf :: [(Name, b)] -> [Name] -bindersOf = fmap fst +class HasRHS s z | s -> z where + _rhs :: Lens' s (Expr z) -rhssOf :: [(Name, b)] -> [b] -rhssOf = fmap snd +instance HasRHS (Alter b) b where + _rhs = lens + (\ (Alter _ _ e) -> e) + (\ (Alter t as _) e' -> Alter t as e') -isAtomic :: Expr -> Bool -isAtomic (Var _) = True -isAtomic _ = False +instance HasRHS (ScDef b) b where + _rhs = lens + (\ (ScDef _ _ e) -> e) + (\ (ScDef n as _) e' -> ScDef n as e') ----------------------------------------------------------------------------------- - --- TODO: export list awareness -insertModule :: Module -> Program -> Program -insertModule (Module _ m) p = p <> m - -extractProgram :: Module -> Program -extractProgram (Module _ p) = p +instance HasRHS (Binding b) b where + _rhs = lens + (\ (_ := e) -> e) + (\ (k := _) e' -> k := e') diff --git a/src/Core/Utils.hs b/src/Core/Utils.hs new file mode 100644 index 0000000..dd9c6ed --- /dev/null +++ b/src/Core/Utils.hs @@ -0,0 +1,72 @@ +-- for recursion schemes +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +-- for recursion schemes +{-# LANGUAGE TemplateHaskell, TypeFamilies #-} + +module Core.Utils + ( bindersOf + , rhssOf + , isAtomic + , insertModule + , extractProgram + , freeVariables + , ExprF(..) + ) + where +---------------------------------------------------------------------------------- +import Data.Functor.Foldable.TH (makeBaseFunctor) +import Data.Functor.Foldable +import Data.Set (Set) +import Data.Set qualified as S +import Core.Syntax +import GHC.Exts (IsList(..)) +---------------------------------------------------------------------------------- + +bindersOf :: (IsList l, Item l ~ b) => [Binding b] -> l +bindersOf bs = fromList $ fmap f bs + where f (k := _) = k + +rhssOf :: (IsList l, Item l ~ Expr b) => [Binding b] -> l +rhssOf = fromList . fmap f + where f (_ := v) = v + +isAtomic :: Expr b -> Bool +isAtomic (Var _) = True +isAtomic (LitE _) = True +isAtomic _ = False + +---------------------------------------------------------------------------------- + +-- TODO: export list awareness +insertModule :: Module b -> Program b -> Program b +insertModule (Module _ m) p = p <> m + +extractProgram :: Module b -> Program b +extractProgram (Module _ p) = p + +---------------------------------------------------------------------------------- + +makeBaseFunctor ''Expr + +freeVariables :: Expr' -> Set Name +freeVariables = cata go + where + go :: ExprF Name (Set Name) -> Set Name + go (VarF k) = S.singleton k + -- TODO: collect free vars in rhss of bs + go (LetF _ bs e) = (e `S.union` esFree) `S.difference` ns + where + es = rhssOf bs :: [Expr'] + ns = bindersOf bs + -- TODO: this feels a little wrong. maybe a different scheme is + -- appropriate + esFree = foldMap id $ freeVariables <$> es + + go (CaseF e as) = e `S.union` asFree + where + asFree = foldMap id $ freeVariables <$> (fmap altToLam as) + -- we map alts to lambdas to avoid writing a 'freeVariablesAlt' + altToLam (Alter _ ns e) = Lam ns e + go (LamF bs e) = e `S.difference` (S.fromList bs) + go e = foldMap id e + diff --git a/src/Core2Core.hs b/src/Core2Core.hs new file mode 100644 index 0000000..1211a22 --- /dev/null +++ b/src/Core2Core.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE LambdaCase #-} +module Core2Core + ( core2core + + -- internal utilities for convenience + , floatCase + ) + where +---------------------------------------------------------------------------------- +import Data.Functor.Foldable +import Data.Maybe (fromJust) +import Data.Set qualified as S +import Data.List +import Control.Monad.Writer +import Control.Monad.State +import Lens.Micro +import Core.Syntax +import Core.Utils +---------------------------------------------------------------------------------- + +core2core :: Program' -> Program' +core2core p = undefined + +-- assumes the provided expression is in a strict context +-- replaceNonStrictCases :: [Name] -> Expr' -> (Expr', [ScDef']) +-- replaceNonStrictCases names = runWriter . cata goE +-- where +-- goE :: ExprF Name (Writer [ScDef'] Expr') +-- -> Writer [ScDef'] Expr' +-- -- strict context +-- goE (VarF k) = pure (Var k) +-- goE (CaseF e as) = e *> ae' +-- where +-- ae = (\ (Alter _ _ b) -> b) <$> as +-- ae' = mconcat <$> traverse replaceNonStrictCases ae + +type Replacer = StateT [Name] (Writer [ScDef']) + +-- TODO: formally define a "strict context" and reference that here +replaceNonStrictCases :: [Name] -> Expr' -> (Expr', [ScDef']) +replaceNonStrictCases names = runWriter . flip evalStateT names . goE + where + goE :: Expr' -> Replacer Expr' + goE (Var k) = pure (Var k) + goE (LitE l) = pure (LitE l) + goE (Let Rec bs e) = Let Rec <$> bs' <*> goE e + where bs' = travBs goE bs + goE e = goC e + + goC :: Expr' -> Replacer Expr' + -- the only truly non-trivial case: when a case expr is found in a + -- non-strict context, we float it into a supercombinator, give it a + -- name consumed from the state, record the newly created sc within the + -- Writer, and finally return an expression appropriately calling the sc + goC p@(Case e as) = do + n <- name + let (e',sc) = floatCase n p + altBodies = (\(Alter _ _ b) -> b) <$> as + tell [sc] + goE e + traverse goE altBodies + pure e' + goC (f :$ x) = (:$) <$> goC f <*> goC x + goC (Let r bs e) = Let r <$> bs' <*> goE e + where bs' = travBs goC bs + + name = state (fromJust . uncons) + + -- extract the right-hand sides of a list of bindings, traverse each + -- one, and return the original list of bindings + travBs :: (Expr' -> Replacer Expr') -> [Binding'] -> Replacer [Binding'] + travBs c bs = bs ^.. each . _rhs + & traverse goC + & const (pure bs) + +-- when provided with a case expr, floatCase will float the case into a +-- supercombinator of its free variables. the sc is returned along with an +-- expression that calls the sc with the necessary arguments +floatCase :: Name -> Expr' -> (Expr', ScDef') +floatCase n c@(Case e as) = (e', sc) + where + sc = ScDef n caseFrees c + caseFrees = S.toList $ freeVariables c + e' = foldl App (Var n) (Var <$> caseFrees) + diff --git a/src/GM.hs b/src/GM.hs index c2eac80..38d6e75 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -30,6 +30,21 @@ import Debug.Trace import Core ---------------------------------------------------------------------------------- +{-} + +hdbgProg = undefined +evalProg = undefined + +data Node = NNum Int + | NAp Addr Addr + | NInd Addr + | NUninitialised + | NConstr Tag [Addr] -- NConstr Tag Components + | NMarked Node + deriving (Show, Eq) + +--} + data GmState = GmState { _gmCode :: Code , _gmStack :: Stack @@ -103,7 +118,7 @@ pure [] ---------------------------------------------------------------------------------- -evalProg :: Program -> Maybe (Node, Stats) +evalProg :: Program' -> Maybe (Node, Stats) evalProg p = res <&> (,sts) where final = eval (compile p) & last @@ -112,7 +127,7 @@ evalProg p = res <&> (,sts) resAddr = final ^. gmStack ^? _head res = resAddr >>= flip hLookup h -hdbgProg :: Program -> Handle -> IO (Node, Stats) +hdbgProg :: Program' -> Handle -> IO (Node, Stats) hdbgProg p hio = do (renderOut . showState) `traverse_` states -- TODO: i'd like the statistics to be at the top of the file, but `sts` @@ -533,7 +548,7 @@ pop [] = [] ---------------------------------------------------------------------------------- -compile :: Program -> GmState +compile :: Program' -> GmState compile p = GmState c [] [] h g sts where -- find the entry point and evaluate it @@ -560,7 +575,7 @@ compiledPrims = binop k i = (k, 2, [Push 1, Eval, Push 1, Eval, i, Update 2, Pop 2, Unwind]) -buildInitialHeap :: Program -> (GmHeap, Env) +buildInitialHeap :: Program' -> (GmHeap, Env) buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs where compiledScs = fmap compileSc ss <> compiledPrims @@ -573,20 +588,20 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs -- >> [ref/compileSc] -- type CompiledSC = (Name, Int, Code) - compileSc :: ScDef -> CompiledSC + compileSc :: ScDef' -> CompiledSC compileSc (ScDef n as b) = (n, d, compileR env b) where env = (NameKey <$> as) `zip` [0..] d = length as -- << [ref/compileSc] - compileR :: Env -> Expr -> Code + compileR :: Env -> Expr' -> Code compileR g e = compileE g e <> [Update d, Pop d, Unwind] where d = length g - -- compile an expression in a lazy context - compileC :: Env -> Expr -> Code + -- compile an expression in a non-strict context + compileC :: Env -> Expr' -> Code compileC g (Var k) | k `elem` domain = [Push n] | otherwise = [PushGlobal k] @@ -596,7 +611,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs f (NameKey n, _) = Just n f _ = Nothing - compileC _ (IntE n) = [PushInt n] + compileC _ (LitE l) = compileCL l -- >> [ref/compileC] compileC g (App f x) = compileC g x @@ -612,7 +627,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs -- kinda gross. revisit this addressed = bs `zip` reverse [0 .. d-1] - compileBinder :: Env -> (Binding, Int) -> (Env, Code) + compileBinder :: Env -> (Binding', Int) -> (Env, Code) compileBinder m (k := v, a) = (m',c) where m' = (NameKey k, a) : m @@ -630,7 +645,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs initialisers = mconcat $ compileBinder <$> addressed body = compileC g' e - compileBinder :: (Binding, Int) -> Code + compileBinder :: (Binding', Int) -> Code compileBinder (_ := v, a) = compileC g' v <> [Update a] compileC _ (Con t n) = [PushConstr t n] @@ -640,10 +655,16 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs compileC _ _ = error "yet to be implemented!" + compileCL :: Literal -> Code + compileCL (IntL n) = [PushInt n] + + compileEL :: Literal -> Code + compileEL (IntL n) = [PushInt n] + -- compile an expression in a strict context such that a pointer to the -- expression is left on top of the stack in WHNF - compileE :: Env -> Expr -> Code - compileE _ (IntE n) = [PushInt n] + compileE :: Env -> Expr' -> Code + compileE _ (LitE l) = compileEL l compileE g (Let NonRec bs e) = -- we use compileE instead of compileC mconcat binders <> compileE g' e <> [Slide d] @@ -653,7 +674,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs -- kinda gross. revisit this addressed = bs `zip` reverse [0 .. d-1] - compileBinder :: Env -> (Binding, Int) -> (Env, Code) + compileBinder :: Env -> (Binding', Int) -> (Env, Code) compileBinder m (k := v, a) = (m',c) where m' = (NameKey k, a) : m @@ -674,7 +695,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs body = compileE g' e -- we use compileE instead of compileC - compileBinder :: (Binding, Int) -> Code + compileBinder :: (Binding', Int) -> Code compileBinder (_ := v, a) = compileC g' v <> [Update a] -- special cases for prim functions; essentially inlining @@ -689,11 +710,11 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs compileE g e = compileC g e ++ [Eval] - compileD :: Env -> [Alter] -> [(Tag, Code)] + compileD :: Env -> [Alter'] -> [(Tag, Code)] compileD g as = fmap (compileA g) as - compileA :: Env -> Alter -> (Tag, Code) - compileA g (Alter t as e) = (t, [Split n] <> c <> [Slide n]) + compileA :: Env -> Alter' -> (Tag, Code) + compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n]) where n = length as binds = (NameKey <$> as) `zip` [0..] @@ -921,3 +942,5 @@ sweepNodes st = st & gmHeap %~ thread (f <$> addresses h) thread :: [a -> a] -> (a -> a) thread = appEndo . foldMap Endo + +--} diff --git a/src/TI.hs b/src/TI.hs index 347642b..e51bd0c 100644 --- a/src/TI.hs +++ b/src/TI.hs @@ -28,6 +28,10 @@ import Core.Examples import Core ---------------------------------------------------------------------------------- +hdbgProg = undefined + +{- + data TiState = TiState Stack Dump TiHeap Env Stats deriving Show @@ -611,3 +615,5 @@ gc st@(TiState s d h g sts) = TiState s d h' g sts marked = h & appEndo (foldMap Endo $ markFrom <$> as) h' = scanHeap marked +--} +