refactor stack vm to use a basic block ish structure

2026-08-23 11:42:14 -06:00
parent 8a20c4f4aa
commit 950d123760
21 changed files with 406 additions and 232 deletions
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedLists #-}
 module Gyehoek.Test.Stack.VM where

 import Test.Tasty (TestTree, testGroup)
@@ -7,110 +8,97 @@ import Gyehoek.Stack.VM qualified as Sut
 import Data.List (List)


-test_root = testGroup "stack machine" $
-  [ lit_int
-  , procedure
-  , prims
-  ]
+evalsTo :: List Obj -> Program -> Assertion
+evalsTo rs p = Sut.eval p @?= rs

-
-
-evalsTo :: List Obj -> List Block -> Assertion
-evalsTo rs bs = Sut.eval (MkProgram bs) @?= rs
-
-
-
-lit_int = testCase "lit int" do
-  evalsTo [ObjImm (ImmInt 3)]
-    [ MkBlock "main" []
-      [ PopCont "ktail"
-      , Call (ValReg "ktail") [ValImm (ImmInt 3)]
-      ]
-    ]
-
-procedure = testGroup "procedure"
-  [ testCase "return constant" do
-      evalsTo [ObjImm (ImmInt 123)]
-        [ MkBlock "main" []
-          [ Call (ValLabel "silly") []
-          ]
-        , MkBlock "silly" []
-          [ PopCont "ktail"
-          , Call (ValReg "ktail") [ValImm (ImmInt 123)]
-          ]
-        ]
+test_root = testGroup "stack machine"
+  [ testCase "lit int" do
+      evalsTo [ObjImm (ImmInt 3)] [stkP|
+        (define ($main)
+          (pop-cont! %ktail)
+          (tail-call! %ktail 3))
+      |]
+  , testCase "return constant" do
+      evalsTo [ObjImm (ImmInt 123)] [stkP|
+        (define ($main)
+          (tail-call! $silly))
+        (define ($silly)
+          (pop-cont! %ktail)
+          (tail-call! %ktail 123))
+      |]
  , testCase "identity function" do
-      evalsTo [ObjImm (ImmInt 45)]
-        [ MkBlock "main" []
-          [ Call (ValLabel "id") [ValImm (ImmInt 45)]
-          ]
-        , MkBlock "id" ["x"]
-          [ PopCont "ktail"
-          , Call (ValReg "ktail") [ValReg "x"]
-          ]
-        ]
+      evalsTo [ObjImm (ImmInt 45)] [stkP|
+        (define ($main)
+          (tail-call! $id 45))
+        (define ($id %x)
+          (pop-cont! %ktail)
+          (tail-call! %ktail %x))
+      |]
+  -- , testCase "square" do
+  --     evalsTo [ObjImm (ImmInt 16)] [stkP|
+  --       (define ($main))
+  --     |]
  , testCase "square" do
-      evalsTo [ObjImm (ImmInt 16)]
-        [ MkBlock "main" []
-          [ Call (ValLabel "square") [ValImm (ImmInt 4)]
-          ]
-        , MkBlock "square" ["x"]
-          [ PopCont "ktail"
-          , Prim "x2" $ PrimMul (ValReg "x") (ValReg "x")
-          , Call (ValReg "ktail") [ValReg "x2"]
-          ]
-        ]
+      evalsTo [ObjImm (ImmInt 16)] [stkP|
+        (define ($main)
+          (tail-call! $square 4))
+        (define ($square %x)
+          (prim %x2 (* %x %x))
+          (pop-cont! %ktail)
+          (tail-call! %ktail %x2))
+      |]
  , testCase "factorial" do
-      let fac n =
-            [ MkBlock "fac" ["n"]
-              [ Prim "x0" $ PrimZeroP (ValReg "n")
-              , If (ValReg "x0")
-                [ PopCont "ktail"
-                , Call (ValReg "ktail") [ValImm (ImmInt 1)]
-                ]
-                [ Push (ValReg "n")
-                , Prim "x1" $ PrimSub (ValReg "n") (ValImm (ImmInt 1))
-                , PushCont (ValLabel "fac-k0")
-                , Call (ValLabel "fac") [ValReg "x1"]
-                ]
-              ]
-            , MkBlock "fac-k0" ["x2"]
-              [ Pop "n"
-              , Prim "x3" $ PrimMul (ValReg "x2") (ValReg "n")
-              , PopCont "ktail"
-              , Call (ValReg "ktail") [ValReg "x3"]
-              ]
-            , MkBlock "main" []
-              [ Call (ValLabel "fac") [ValImm (ImmInt n)]
-              ]
-            ]
+      let hsfac (n :: Int) = foldr (*) (1) [1..n]
+      let fac (n :: Int) = [stkP|
+            (define ($fac %n)
+              (prim %x0 (zero? %n))
+              (if %x0
+                (then (pop-cont! %ktail)
+                      (tail-call! %ktail 1))
+                (else (push! %n)
+                      (prim %x1 (- %n 1))
+                      (push-cont! $fac-k0)
+                      (tail-call! $fac %x1))))
+            (define ($fac-k0 %x2)
+              (pop! %n)
+              (prim %x3 (* %x2 %n))
+              (pop-cont! %ktail)
+              (tail-call! %ktail %x3))
+            (define ($main)
+              (tail-call! $fac #{n}))
+          |]
      evalsTo [ObjImm (ImmInt 1)] $ fac 0
+      evalsTo [ObjImm (ImmInt 1)] $ fac 1
      evalsTo [ObjImm (ImmInt 720)] $ fac 6
+      -- 20 is the greatest `n` for which n! ≤ maxBount @Int
+      evalsTo [ObjImm (ImmInt 2432902008176640000)] $ fac 20
  ]

-prims = testGroup "prims"
-  [ arith
-  , testCase "zero?" do
-      trivialPrimTest [ObjImm (ImmBool True)] $
-        PrimZeroP $ ValImm $ ImmInt 0
-      trivialPrimTest [ObjImm (ImmBool False)] $
-        PrimZeroP $ ValImm $ ImmInt 12
-  ]
+--   ]

-trivialPrimTest rs p =
-  evalsTo rs
-  [ MkBlock "main" []
-    [ PopCont "ktail"
-    , Prim "x1" p
-    , Call (ValReg "ktail") [ValReg "x1"]
-    ]
-  ]
+-- prims = testGroup "prims"
+--   [ arith
+--   , testCase "zero?" do
+--       trivialPrimTest [ObjImm (ImmBool True)] $
+--         PrimZeroP $ ValImm $ ImmInt 0
+--       trivialPrimTest [ObjImm (ImmBool False)] $
+--         PrimZeroP $ ValImm $ ImmInt 12
+--   ]

-arith = testGroup "arith"
-  [ testCase "multipy" do
-      trivialPrimTest [ObjImm (ImmInt 12)]
-        (PrimMul (ValImm $ ImmInt 3) (ValImm $ ImmInt 4))
-  , testCase "subtract" do
-      trivialPrimTest [ObjImm (ImmInt 14)]
-        (PrimSub (ValImm $ ImmInt 20) (ValImm $ ImmInt 6))
-  ]
+-- trivialPrimTest rs p =
+--   evalsTo rs
+--   [ MkRoutine "main" []
+--     [ PopCont "ktail"
+--     , Prim "x1" p
+--     , Call (ValReg "ktail") [ValReg "x1"]
+--     ]
+--   ]
+
+-- arith = testGroup "arith"
+--   [ testCase "multipy" do
+--       trivialPrimTest [ObjImm (ImmInt 12)]
+--         (PrimMul (ValImm $ ImmInt 3) (ValImm $ ImmInt 4))
+--   , testCase "subtract" do
+--       trivialPrimTest [ObjImm (ImmInt 14)]
+--         (PrimSub (ValImm $ ImmInt 20) (ValImm $ ImmInt 6))
+--   ]
@@ -1,7 +1,17 @@
+{-# LANGUAGE DoAndIfThenElse #-}
 module Main where
-
+
 import Test.DocTest (mainFromCabal)
-import System.Environment (getArgs)
+import System.Environment (getArgs, lookupEnv)
+import System.IO (stderr, hPutStrLn)
+

 main :: IO ()
-main = mainFromCabal "gyehoek" =<< getArgs
+main = do
+  nix <- maybe False null <$> lookupEnv "GYEHOEK_IN_NIX_BUILD"
+  if nix then do
+    hPutStrLn stderr "\
+     \skipping doctests in Nix build environment. \
+     \see https://github.com/pcapriotti/optparse-applicative/pull/408."
+  else
+    mainFromCabal "gyehoek" =<< getArgs