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