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

arith fixes

Browse Source
This commit is contained in:
crumbtoo
2023-12-13 11:35:09 -07:00
parent f45c06cad5
commit 9c7c9c4730
2 changed files with 16 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
src/GM.hs
View File

@@ -701,12 +701,12 @@ buildInitialHeap (Program ss) = mapAccumL allocateSc mempty compiledScs
compileBinder (_ := v, a) = compileC g' v <> [Update a] compileBinder (_ := v, a) = compileC g' v <> [Update a]
-- special cases for prim functions; essentially inlining -- special cases for prim functions; essentially inlining
compileE g ("negate#" :$ a) = compileE g a <> [Neg] compileE g ("negate#" :$ a) = compileE g a <> [Neg]
compileE g ("+#" :$ a :$ b) = compileE g a <> compileE g b <> [Add] compileE g ("+#" :$ a :$ b) = compileE g b <> compileE g a <> [Add]
compileE g ("-#" :$ a :$ b) = compileE g a <> compileE g b <> [Sub] compileE g ("-#" :$ a :$ b) = compileE g b <> compileE g a <> [Sub]
compileE g ("*#" :$ a :$ b) = compileE g a <> compileE g b <> [Mul] compileE g ("*#" :$ a :$ b) = compileE g b <> compileE g a <> [Mul]
compileE g ("/#" :$ a :$ b) = compileE g a <> compileE g b <> [Div] compileE g ("/#" :$ a :$ b) = compileE g b <> compileE g a <> [Div]
compileE g ("==#" :$ a :$ b) = compileE g a <> compileE g b <> [Equals] compileE g ("==#" :$ a :$ b) = compileE g b <> compileE g a <> [Equals]
compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)] compileE g (Case e as) = compileE g e <> [CaseJump (compileD g as)]

19
tst/Arith.hs
View File

@@ -35,7 +35,7 @@ instance Arbitrary ArithExpr where
gen :: Int -> Gen ArithExpr gen :: Int -> Gen ArithExpr
gen n gen n
| n > 0 = oneof | n > 0 = oneof
-- i don't feel like dealing with zero at the moment -- i don't feel like dealing with division at the moment
[ IntA <$> int [ IntA <$> int
, NegateA <$> arbitrary , NegateA <$> arbitrary
-- , IdA <$> arbitrary -- , IdA <$> arbitrary
@@ -47,7 +47,8 @@ instance Arbitrary ArithExpr where
where where
b f = liftA2 f s s b f = liftA2 f s s
s = gen (n `div` 2) s = gen (n `div` 2)
int = chooseInt (minBound,maxBound) -- int = chooseInt (minBound,maxBound)
int = chooseInt (-500,500)
prop_ArithExprEqCoreExpr :: ArithExpr -> Bool prop_ArithExprEqCoreExpr :: ArithExpr -> Bool
prop_ArithExprEqCoreExpr e = arithResult `eq1` coreResult prop_ArithExprEqCoreExpr e = arithResult `eq1` coreResult
@@ -55,23 +56,23 @@ prop_ArithExprEqCoreExpr e = arithResult `eq1` coreResult
arithResult = Just (evalA e) arithResult = Just (evalA e)
coreResult = evalCore (toCore e) coreResult = evalCore (toCore e)
toCore :: ArithExpr -> Program toCore :: ArithExpr -> Program'
toCore expr = Program toCore expr = Program
[ ScDef "id" ["x"] $ Var "x" [ ScDef "id" ["x"] $ Var "x"
, ScDef "main" [] $ go expr , ScDef "main" [] $ go expr
] ]
where where
go :: ArithExpr -> Expr go :: ArithExpr -> Expr'
go (IntA n) = IntE n go (IntA n) = LitE (IntL n)
go (NegateA e) = "negate#" :$ go e go (NegateA e) = "negate#" :$ go e
go (IdA e) = "id" :$ go e go (IdA e) = "id" :$ go e
go (a :+ b) = f "+#" a b go (a :+ b) = f "+#" a b
go (a :- b) = f "-#" a b go (a :- b) = f "-#" a b
go (a :* b) = f "*#" a b go (a :* b) = f "*#" a b
f n a b = n :$ go a :$ go b f n a b = n :$ go a :$ go b
evalCore :: Program -> Maybe Int evalCore :: Program' -> Maybe Int
evalCore p = do evalCore p = do
a <- fst <$> evalProg p a <- fst <$> evalProg p
case a of case a of