factorial

src/Gyehoek/Stack/Syntax.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
 module Gyehoek.Stack.Syntax
   ( Program(..)
   , Block(..)
@@ -26,12 +27,19 @@ import Data.Data (Data)
 import qualified Data.HashMap.Strict as H
 import Effectful
 import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
+import GHC.Exts (IsList(..))
 
 
 newtype Program = MkProgram
   { blocks :: List Block
   }
   deriving stock (Show, Generic, Data)
+  deriving newtype (Semigroup, Monoid)
+
+instance IsList Program where
+  type Item Program = Block
+  fromList = MkProgram
+  toList = view #blocks
 
 data Block = MkBlock
   { label :: Name
@@ -51,6 +59,7 @@ data Instr
   | Prim Name (Prim Val)
   | CallLabel Name (List Val)
   | CallReg Name (List Val)
+  | If Val (List Instr) (List Instr)
   deriving stock (Show, Generic, Data)
 
 data Val

src/Gyehoek/Stack/VM.hs

@@ -2,6 +2,7 @@ module Gyehoek.Stack.VM
   ( VM(..)
   , Env(..)
   , eval
+  , trace
   ) where
 
 import Gyehoek.Stack.Syntax
@@ -13,6 +14,10 @@ import Data.Text (Text)
 import qualified Data.HashMap.Strict as H
 import Data.String.Interpolate (i)
 import Gyehoek.Scheme.Syntax (Sexp(..))
+import Debug.Pretty.Simple (pTraceShowIdForceColor)
+import qualified Data.List.NonEmpty as NE
+import Data.Functor (($>))
+import Data.List (unfoldr)
 
 
 data VM = MkVM
@@ -42,14 +47,18 @@ stepI e vm (Push v) = vm & #stack %~ (evalVal e vm v :)
 stepI e vm (PushCont k) = vm & #kstack %~ (k:)
 
 stepI e vm (Prim r p) = case evalVal e vm <$> p of
+  PrimZeroP x -> case x of
+    ObjImm (ImmInt n) -> ret . ObjImm . ImmBool $ n == 0
+    _ -> error [i|bad arg to zero?: #{x}|]
   PrimAdd x y -> arith_binop (+) x y
   PrimMul x y -> arith_binop (*) x y
   PrimSub x y -> arith_binop (-) x y
   PrimDiv x y -> arith_binop div x y
   x -> error [i|unimplemented prim: #{p}|]
   where
+    ret v = vm & #registers . at r ?~ v
     arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
-      vm & #registers . at r ?~ ObjImm (ImmInt (op x y))
+      ret $ ObjImm (ImmInt (op x y))
     arith_binop _ x y = error [i|bad arith: #{x}, #{y}|]
 
 stepI e vm (Pop r) = case vm ^. #stack of
@@ -63,7 +72,9 @@ stepI e vm (PopCont r) = case vm ^. #kstack of
                & #kstack .~ xs
 
 stepI e vm (CallReg r xs) = stepI e vm (CallLabel l xs)
-  where l = vm ^?! #registers . at r . _Just . #ObjLabel
+  where l = case vm ^? #registers . at r . _Just . #ObjLabel of
+          Just x -> x
+          Nothing -> error [i|tried to call undefined register: #{r}|]
 
 stepI e vm (CallLabel "halt" xs) = vm & #result ?~ fmap (evalVal e vm) xs
 
@@ -75,7 +86,12 @@ stepI e vm (CallLabel l xs) =
       Just x -> x
       Nothing -> error [i|undefined label: #{l}|]
 
-stepI e vm _ = _
+stepI e vm (If c t f) =
+  case evalVal e vm c of
+    ObjImm (ImmBool False) -> vm & #code .~ f
+    _ -> vm & #code .~ t
+
+stepI e vm ins = error [i|unimplemented instruction: #{ins}|]
 
 evalVal :: Env -> VM -> Val -> Obj
 evalVal e vm = \case
@@ -108,3 +124,46 @@ eval :: Program -> List Obj
 eval p = initialVM & loop \vm -> case vm ^. #result of
   Nothing -> Right $ step (initialEnv p) vm
   Just rs -> Left rs
+
+trace :: Program -> List VM
+trace p = initialVM & unfoldr \vm ->
+    case vm.result of
+      Just _ -> Nothing
+      Nothing -> Just (vm, step e vm)
+  where e = initialEnv p
+
+fac =
+      [ MkBlock "fac" ["n"]
+        [ Prim "x0" $ PrimZeroP (ValReg "n")
+        , If (ValReg "x0")
+          [ PopCont "ktail"
+          , CallReg "ktail" [ValImm (ImmInt 1)]
+          ]
+          [ Push (ValReg "n")
+          , Prim "x1" $ PrimSub (ValReg "n") (ValImm (ImmInt 1))
+          , PushCont "fac-k0"
+          , CallLabel "fac" [ValReg "x1"]
+          ]
+        ]
+      , MkBlock "fac-k0" ["x2"]
+        [ Pop "n"
+        , Prim "x3" $ PrimMul (ValReg "x2") (ValReg "n")
+        , PopCont "ktail"
+        , CallReg "ktail" [ValReg "x3"]
+        ]
+      ]
+
+fac3 = MkProgram $
+  [ MkBlock "main" []
+    [ CallLabel "fac" [ValImm (ImmInt 3)]
+    ]
+  ] <> fac
+
+fac3_trace = trace fac3
+
+showVM :: VM -> Text
+showVM vm = [i|(#{instr}) ; #{stk} #{kstk}|]
+  where
+    instr = vm ^?! #code . _head
+    stk = vm.stack
+    kstk = vm.kstack

test/Gyehoek/Test/Stack/VM.hs

@@ -12,7 +12,8 @@ import Data.Generics.Labels
 root :: IO TestTree
 root = pure . testGroup "stack machine" $
   [ lit_int
-  , arith
+  , procedure
+  , prims
   ]
 
 
@@ -30,21 +31,94 @@ lit_int = testCase "lit int" do
       ]
     ]
 
+procedure = testGroup "procedure"
+  [ testCase "return constant" do
+      evalsTo [ObjImm (ImmInt 123)]
+        [ MkBlock "main" []
+          [ CallLabel "silly" []
+          ]
+        , MkBlock "silly" []
+          [ PopCont "ktail"
+          , CallReg "ktail" [ValImm (ImmInt 123)]
+          ]
+        ]
+  , testCase "identity function" do
+      evalsTo [ObjImm (ImmInt 45)]
+        [ MkBlock "main" []
+          [ CallLabel "id" [ValImm (ImmInt 45)]
+          ]
+        , MkBlock "id" ["x"]
+          [ PopCont "ktail"
+          , CallReg "ktail" [ValReg "x"]
+          ]
+        ]
+  , testCase "square" do
+      evalsTo [ObjImm (ImmInt 16)]
+        [ MkBlock "main" []
+          [ CallLabel "square" [ValImm (ImmInt 4)]
+          ]
+        , MkBlock "square" ["x"]
+          [ PopCont "ktail"
+          , Prim "x2" $ PrimMul (ValReg "x") (ValReg "x")
+          , CallReg "ktail" [ValReg "x2"]
+          ]
+        ]
+  , testCase "factorial" do
+      let fac =
+            [ MkBlock "fac" ["n"]
+              [ Prim "x0" $ PrimZeroP (ValReg "n")
+              , If (ValReg "x0")
+                [ PopCont "ktail"
+                , CallReg "ktail" [ValImm (ImmInt 1)]
+                ]
+                [ Push (ValReg "n")
+                , Prim "x1" $ PrimSub (ValReg "n") (ValImm (ImmInt 1))
+                , PushCont "fac-k0"
+                , CallLabel "fac" [ValReg "x1"]
+                ]
+              ]
+            , MkBlock "fac-k0" ["x2"]
+              [ Pop "n"
+              , Prim "x3" $ PrimMul (ValReg "x2") (ValReg "n")
+              , PopCont "ktail"
+              , CallReg "ktail" [ValReg "x3"]
+              ]
+            ]
+      evalsTo [ObjImm (ImmInt 1)] $
+        [ MkBlock "main" []
+          [ CallLabel "fac" [ValImm (ImmInt 0)]
+          ]
+        ] ++ fac
+      evalsTo [ObjImm (ImmInt 720)] $
+        [ MkBlock "main" []
+          [ CallLabel "fac" [ValImm (ImmInt 6)]
+          ]
+        ] ++ fac
+  ]
+
+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
+    , CallReg "ktail" [ValReg "x1"]
+    ]
+  ]
+
 arith = testGroup "arith"
   [ testCase "multipy" do
-      evalsTo [ObjImm (ImmInt 12)]
+      trivialPrimTest [ObjImm (ImmInt 12)]
-        [ MkBlock "main" []
+        (PrimMul (ValImm $ ImmInt 3) (ValImm $ ImmInt 4))
-          [ PopCont "ktail"
-          , Prim "x1" (PrimMul (ValImm $ ImmInt 3) (ValImm $ ImmInt 4))
-          , CallReg "ktail" [ValReg "x1"]
-          ]
-        ]
   , testCase "subtract" do
-      evalsTo [ObjImm (ImmInt 14)]
+      trivialPrimTest [ObjImm (ImmInt 14)]
-        [ MkBlock "main" []
+        (PrimSub (ValImm $ ImmInt 20) (ValImm $ ImmInt 6))
-          [ PopCont "ktail"
-          , Prim "x1" (PrimSub (ValImm $ ImmInt 20) (ValImm $ ImmInt 6))
-          , CallReg "ktail" [ValReg "x1"]
-          ]
-        ]
   ]