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

gte gm prim

Browse Source
This commit is contained in:
crumbtoo
2024-02-13 10:42:45 -07:00
parent de16bf12df
commit bb41d3c196
1 changed files with 7 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
src/GM.hs
View File

@@ -103,7 +103,7 @@ data Instr = Unwind
-- arith -- arith
| Neg | Add | Sub | Mul | Div | Neg | Add | Sub | Mul | Div
-- comparison -- comparison
| Equals | Lesser | Equals | Lesser | GreaterEq
| Pack Tag Int -- Pack Tag Arity | Pack Tag Int -- Pack Tag Arity
| CaseJump [(Tag, Code)] | CaseJump [(Tag, Code)]
| Split Int | Split Int
@@ -228,6 +228,7 @@ step st = case head (st ^. gmCode) of
Div -> divI Div -> divI
Equals -> equalsI Equals -> equalsI
Lesser -> lesserI Lesser -> lesserI
GreaterEq -> greaterEqI
Split n -> splitI n Split n -> splitI n
Pack t n -> packI t n Pack t n -> packI t n
CaseJump as -> caseJumpI as CaseJump as -> caseJumpI as
@@ -451,9 +452,10 @@ step st = case head (st ^. gmCode) of
mulI = primitive2 boxInt unboxInt (*) st mulI = primitive2 boxInt unboxInt (*) st
divI = primitive2 boxInt unboxInt div st divI = primitive2 boxInt unboxInt div st
lesserI, equalsI :: GmState lesserI, greaterEqI, equalsI :: GmState
equalsI = primitive2 boxBool unboxInt (==) st equalsI = primitive2 boxBool unboxInt (==) st
lesserI = primitive2 boxBool unboxInt (<) st lesserI = primitive2 boxBool unboxInt (<) st
greaterEqI = primitive2 boxBool unboxInt (>=) st
splitI :: Int -> GmState splitI :: Int -> GmState
splitI n = st splitI n = st
@@ -638,6 +640,7 @@ compiledPrims =
, binop "/#" Div , binop "/#" Div
, binop "==#" Equals , binop "==#" Equals
, binop "<#" Lesser , binop "<#" Lesser
, 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])
] ]
@@ -743,7 +746,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
mconcat binders <> compileE g' e <> [Slide d] mconcat binders <> compileE g' e <> [Slide d]
where where
d = length bs d = length bs
(g',binders) = mapAccumL compileBinder (argOffset d g) addressed (g',binders) = mapAccumL compileBinder (argOffset (d-1) g) addressed
-- kinda gross. revisit this -- kinda gross. revisit this
addressed = bs `zip` reverse [0 .. d-1] addressed = bs `zip` reverse [0 .. d-1]
@@ -779,6 +782,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil
compileE g ("/#" :$ a :$ b) = inlineOp2 g Div a b compileE g ("/#" :$ a :$ b) = inlineOp2 g Div a b
compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b compileE g ("==#" :$ a :$ b) = inlineOp2 g Equals a b
compileE g ("<#" :$ a :$ b) = inlineOp2 g Lesser a b compileE g ("<#" :$ a :$ b) = inlineOp2 g Lesser a b
compileE g (">=#" :$ a :$ b) = inlineOp2 g GreaterEq a b
compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)] compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)]