msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

core2core

Browse Source
This commit is contained in:
crumbtoo
2023-12-11 14:18:48 -07:00
parent e477891bc3
commit 238729cf1e
5 changed files with 193 additions and 63 deletions
Download Patch File Download Diff File Expand all files Collapse all files

30
src/GM.hs
View File

@@ -118,7 +118,7 @@ pure []
----------------------------------------------------------------------------------
evalProg :: CoreProgram -> Maybe (Node, Stats)
evalProg :: Program' -> Maybe (Node, Stats)
evalProg p = res <&> (,sts)
where
final = eval (compile p) & last
@@ -127,7 +127,7 @@ evalProg p = res <&> (,sts)
resAddr = final ^. gmStack ^? _head
res = resAddr >>= flip hLookup h
hdbgProg :: CoreProgram -> 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`
@@ -548,7 +548,7 @@ pop [] = []
----------------------------------------------------------------------------------
compile :: CoreProgram -> GmState
compile :: Program' -> GmState
compile p = GmState c [] [] h g sts
where
-- find the entry point and evaluate it
@@ -575,7 +575,7 @@ compiledPrims =
binop k i = (k, 2, [Push 1, Eval, Push 1, Eval, i, Update 2, Pop 2, Unwind])
buildInitialHeap :: CoreProgram -> (GmHeap, Env)
buildInitialHeap :: Program' -> (GmHeap, Env)
buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
where
compiledScs = fmap compileSc ss <> compiledPrims
@@ -588,20 +588,20 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
-- >> [ref/compileSc]
-- type CompiledSC = (Name, Int, Code)
compileSc :: CoreScDef -> 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 -> CoreExpr -> 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 -> CoreExpr -> 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]
@@ -627,7 +627,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
-- kinda gross. revisit this
addressed = bs `zip` reverse [0 .. d-1]
compileBinder :: Env -> (CoreBinding, Int) -> (Env, Code)
compileBinder :: Env -> (Binding', Int) -> (Env, Code)
compileBinder m (k := v, a) = (m',c)
where
m' = (NameKey k, a) : m
@@ -645,7 +645,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
initialisers = mconcat $ compileBinder <$> addressed
body = compileC g' e
compileBinder :: (CoreBinding, Int) -> Code
compileBinder :: (Binding', Int) -> Code
compileBinder (_ := v, a) = compileC g' v <> [Update a]
compileC _ (Con t n) = [PushConstr t n]
@@ -663,7 +663,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
-- 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 -> CoreExpr -> Code
compileE :: Env -> Expr' -> Code
compileE _ (LitE l) = compileEL l
compileE g (Let NonRec bs e) =
-- we use compileE instead of compileC
@@ -674,7 +674,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
-- kinda gross. revisit this
addressed = bs `zip` reverse [0 .. d-1]
compileBinder :: Env -> (CoreBinding, Int) -> (Env, Code)
compileBinder :: Env -> (Binding', Int) -> (Env, Code)
compileBinder m (k := v, a) = (m',c)
where
m' = (NameKey k, a) : m
@@ -695,7 +695,7 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
body = compileE g' e
-- we use compileE instead of compileC
compileBinder :: (CoreBinding, Int) -> Code
compileBinder :: (Binding', Int) -> Code
compileBinder (_ := v, a) = compileC g' v <> [Update a]
-- special cases for prim functions; essentially inlining
@@ -710,10 +710,10 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compileE g e = compileC g e ++ [Eval]
compileD :: Env -> [CoreAlter] -> [(Tag, Code)]
compileD :: Env -> [Alter'] -> [(Tag, Code)]
compileD g as = fmap (compileA g) as
compileA :: Env -> CoreAlter -> (Tag, Code)
compileA :: Env -> Alter' -> (Tag, Code)
compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n])
where
n = length as