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

more nightmare GM fixes

Browse Source
This commit is contained in:
crumbtoo
2024-02-13 11:48:03 -07:00
parent bb41d3c196
commit cd2a283493
1 changed files with 10 additions and 9 deletions
Download Patch File Download Diff File Expand all files Collapse all files

19
src/GM.hs
View File

@@ -11,6 +11,7 @@ module GM
, evalProgR , evalProgR
, Node(..) , Node(..)
, gmEvalProg , gmEvalProg
, Stats(..)
, finalStateOf , finalStateOf
, resultOf , resultOf
, resultOfExpr , resultOfExpr
@@ -642,7 +643,7 @@ compiledPrims =
, binop "<#" Lesser , binop "<#" Lesser
, binop ">=#" GreaterEq , binop ">=#" GreaterEq
, ("print#", 1, [ Push 0, Eval, Print, Pack tag_Unit_unit 0, Update 1, Pop 1 , ("print#", 1, [ Push 0, Eval, Print, Pack tag_Unit_unit 0, Update 1, Pop 1
, Unwind]) , Unwind ])
] ]
where where
unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind]) unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind])
@@ -743,17 +744,16 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
compileE _ (Lit l) = compileEL l compileE _ (Lit l) = compileEL l
compileE g (Let NonRec bs e) = compileE g (Let NonRec bs e) =
-- we use compileE instead of compileC -- we use compileE instead of compileC
mconcat binders <> compileE g' e <> [Slide d] mconcat binders <> compileE (trc g') e <> [Slide d]
where where
trc = traceWith (\s -> "compileE.g': "<>show s)
d = length bs d = length bs
(g',binders) = mapAccumL compileBinder (argOffset (d-1) g) addressed (g',binders) = mapAccumL compileBinder g bs
-- kinda gross. revisit this
addressed = bs `zip` reverse [0 .. d-1]
compileBinder :: Env -> (Binding', Int) -> (Env, Code) compileBinder :: Env -> Binding' -> (Env, Code)
compileBinder m (k := v, a) = (m',c) compileBinder m (k := v) = (m',c)
where where
m' = (NameKey k, a) : m m' = (NameKey k, 0) : argOffset 1 m
-- make note that we use m rather than m'! -- make note that we use m rather than m'!
c = compileC m v c = compileC m v
@@ -796,7 +796,8 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
where where
n = length as n = length as
binds = (NameKey <$> as) `zip` [0..] binds = (NameKey <$> as) `zip` [0..]
g' = binds ++ argOffset n g g' = traceWith (\s -> "compileA.g': "<>show s) $
binds ++ argOffset n g
c = compileE g' e c = compileE g' e
compileA _ (Alter _ as e) = error "GM.compileA found an untagged\ compileA _ (Alter _ as e) = error "GM.compileA found an untagged\
\ constructor, which should have\ \ constructor, which should have\