wip: stackify

test/Gyehoek/Test/CPS/Stackify.hs

@@ -0,0 +1,54 @@
+module Gyehoek.Test.CPS.Stackify (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import qualified Gyehoek.CPS.Stackify as Sut
+import Gyehoek.Stack.VM as Stk
+import Data.List (List)
+import Gyehoek.CPS.Syntax (cps)
+import Gyehoek.GenSym (runGenSym)
+import Effectful
+
+
+root :: IO TestTree
+root = pure . testGroup "stackify" $
+  [ trivialReturn
+  , tailCall
+  , prim
+  ]
+
+evalsTo :: List Obj -> Sut.Exp -> Assertion
+evalsTo rs e =
+  Stk.eval e' @?= rs
+  where e' = runPureEff . runGenSym $ Sut.stackifyExp "main" e
+
+trivialReturn = testGroup "trivial return"
+  [ testCase "return int" do
+      evalsTo [ObjImm (ImmInt 4)]
+        [cps|(continue halt 4)|]
+  , testCase "return bool" do
+      evalsTo [ObjImm (ImmBool True)]
+        [cps|(continue halt #t)|]
+      evalsTo [ObjImm (ImmBool False)]
+        [cps|(continue halt #f)|]
+  ]
+
+tailCall = testGroup "tail call"
+  [ testCase "square" do
+      evalsTo [ObjImm (ImmInt 16)]
+        [cps|(letrec ((square (λ (x ktail)
+                                (prim (* x x)
+                                  (κ (x0) (continue ktail x0))))))
+               (square 4 halt))|]
+  ]
+
+prim = testGroup "prim"
+  [ testCase "multiply" do
+      evalsTo [ObjImm (ImmInt 20)]
+        [cps|(prim (* 4 5)
+               (κ (x) (continue halt x)))|]
+  , testCase "add" do
+      evalsTo [ObjImm (ImmInt 9)]
+        [cps|(prim (+ 4 5)
+               (κ (x) (continue halt x)))|]
+  ]

test/Gyehoek/Test/Stack/VM.hs

@@ -27,40 +27,42 @@ lit_int = testCase "lit int" do
   evalsTo [ObjImm (ImmInt 3)]
     [ MkBlock "main" []
       [ PopCont "ktail"
-      , CallReg "ktail" [ValImm (ImmInt 3)]
+      , Call (ValReg "ktail") [ValImm (ImmInt 3)]
       ]
     ]
 
+vlb = ValImm . ImmLabel
+
 procedure = testGroup "procedure"
   [ testCase "return constant" do
       evalsTo [ObjImm (ImmInt 123)]
         [ MkBlock "main" []
-          [ CallLabel "silly" []
+          [ Call (ValLabel "silly") []
           ]
         , MkBlock "silly" []
           [ PopCont "ktail"
-          , CallReg "ktail" [ValImm (ImmInt 123)]
+          , Call (ValReg "ktail") [ValImm (ImmInt 123)]
           ]
         ]
   , testCase "identity function" do
       evalsTo [ObjImm (ImmInt 45)]
         [ MkBlock "main" []
-          [ CallLabel "id" [ValImm (ImmInt 45)]
+          [ Call (ValLabel "id") [ValImm (ImmInt 45)]
           ]
         , MkBlock "id" ["x"]
           [ PopCont "ktail"
-          , CallReg "ktail" [ValReg "x"]
+          , Call (ValReg "ktail") [ValReg "x"]
           ]
         ]
   , testCase "square" do
       evalsTo [ObjImm (ImmInt 16)]
         [ MkBlock "main" []
-          [ CallLabel "square" [ValImm (ImmInt 4)]
+          [ Call (ValLabel "square") [ValImm (ImmInt 4)]
           ]
         , MkBlock "square" ["x"]
           [ PopCont "ktail"
           , Prim "x2" $ PrimMul (ValReg "x") (ValReg "x")
-          , CallReg "ktail" [ValReg "x2"]
+          , Call (ValReg "ktail") [ValReg "x2"]
           ]
         ]
   , testCase "factorial" do
@@ -69,29 +71,29 @@ procedure = testGroup "procedure"
               [ Prim "x0" $ PrimZeroP (ValReg "n")
               , If (ValReg "x0")
                 [ PopCont "ktail"
-                , CallReg "ktail" [ValImm (ImmInt 1)]
+                , Call (ValReg "ktail") [ValImm (ImmInt 1)]
                 ]
                 [ Push (ValReg "n")
                 , Prim "x1" $ PrimSub (ValReg "n") (ValImm (ImmInt 1))
                 , PushCont "fac-k0"
-                , CallLabel "fac" [ValReg "x1"]
+                , Call (ValLabel "fac") [ValReg "x1"]
                 ]
               ]
             , MkBlock "fac-k0" ["x2"]
               [ Pop "n"
               , Prim "x3" $ PrimMul (ValReg "x2") (ValReg "n")
               , PopCont "ktail"
-              , CallReg "ktail" [ValReg "x3"]
+              , Call (ValReg "ktail") [ValReg "x3"]
               ]
             ]
       evalsTo [ObjImm (ImmInt 1)] $
         [ MkBlock "main" []
-          [ CallLabel "fac" [ValImm (ImmInt 0)]
+          [ Call (ValLabel "fac") [ValImm (ImmInt 0)]
           ]
         ] ++ fac
       evalsTo [ObjImm (ImmInt 720)] $
         [ MkBlock "main" []
-          [ CallLabel "fac" [ValImm (ImmInt 6)]
+          [ Call (ValLabel "fac") [ValImm (ImmInt 6)]
           ]
         ] ++ fac
   ]
@@ -110,7 +112,7 @@ trivialPrimTest rs p =
   [ MkBlock "main" []
     [ PopCont "ktail"
     , Prim "x1" p
-    , CallReg "ktail" [ValReg "x1"]
+    , Call (ValReg "ktail") [ValReg "x1"]
     ]
   ]
 

test/Main.hs

@@ -6,6 +6,7 @@ import qualified Gyehoek.Test.Golden
 import qualified Gyehoek.Test.Sexp
 import qualified Gyehoek.Test.CPS.Syntax
 import qualified Gyehoek.Test.Stack.VM
+import qualified Gyehoek.Test.CPS.Stackify
 
 
 main :: IO ()
@@ -17,5 +18,6 @@ root = testGroup "test" <$> sequenceA
   ,-} Gyehoek.Test.Sexp.root
   , Gyehoek.Test.CPS.Syntax.root
   , Gyehoek.Test.Stack.VM.root
+  , Gyehoek.Test.CPS.Stackify.root
   ]