src/Gyehoek/Stack/Syntax.hs

@@ -5,6 +5,9 @@ module Gyehoek.Stack.Syntax
   , Instr(..)
   , Val(..)
   , Lit(..)
+  , Obj(..)
+  , Imm(..)
+  , Prim(..)
   , Name
   ) where
 
@@ -53,5 +56,15 @@ data Instr
 data Val
   = ValLabel Name
   | ValReg Name
-  | ValLit Lit
+  | ValImm Imm
   deriving stock (Show, Generic, Data, Eq)
+
+data Imm
+  = ImmInt Int
+  | ImmBool Bool
+  deriving stock (Show, Generic, Data, Eq)
+
+data Obj
+  = ObjImm Imm
+  | ObjLabel Name
+  deriving (Show, Generic)

src/Gyehoek/Stack/VM.hs

@@ -12,15 +12,16 @@ import Data.HashMap.Strict (HashMap)
 import Data.Text (Text)
 import qualified Data.HashMap.Strict as H
 import Data.String.Interpolate (i)
+import Gyehoek.Scheme.Syntax (Sexp(..))
 
 
 data VM = MkVM
-  { stack :: List Val
+  { stack :: List Obj
   , kstack :: List Name
   , code :: List Instr
-  , registers :: HashMap Name Val
+  , registers :: HashMap Name Obj
   , stdout :: Text
-  , result :: Maybe (List Val)
+  , result :: Maybe (List Obj)
   }
   deriving (Show, Generic)
 
@@ -31,12 +32,25 @@ data Env = MkEnv
 
 step :: Env -> VM -> VM
 step e vm = case vm ^. #code of
-  i:is -> stepI e (vm & #code .~ is) i
+  c:cs -> stepI e (vm & #code .~ cs) c
   _ -> error "halt never called"
 
 stepI :: Env -> VM -> Instr -> VM
 
-stepI e vm (Push v) = vm & #stack %~ (v:)
+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
+  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 -> [i|unimplemented prim: #{i}|]
+  where
+    arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
+      vm & #registers . at r ?~ ObjImm (ImmInt (op x y))
+    arith_binop _ x y = error [i|bad arith: #{x}, #{y}|]
 
 stepI e vm (Pop r) = case vm ^. #stack of
   [] -> error "empty stack"
@@ -45,17 +59,17 @@ stepI e vm (Pop r) = case vm ^. #stack of
 
 stepI e vm (PopCont r) = case vm ^. #kstack of
   [] -> error "empty stack"
-  (x:xs) -> vm & #registers . at r ?~ ValLabel x
+  (x:xs) -> vm & #registers . at r ?~ ObjLabel x
                & #kstack .~ xs
 
 stepI e vm (CallReg r xs) = stepI e vm (CallLabel l xs)
-  where l = vm ^?! #registers . at r . _Just . #ValLabel
+  where l = vm ^?! #registers . at r . _Just . #ObjLabel
 
-stepI e vm (CallLabel "halt" xs) = vm & #result ?~ xs
+stepI e vm (CallLabel "halt" xs) = vm & #result ?~ fmap (evalVal e vm) xs
 
 stepI e vm (CallLabel l xs) =
   vm & #code .~ b.code
-     & #registers .~ H.fromList (b.params `zip` xs)
+     & #registers .~ fmap (evalVal e vm) (H.fromList $ b.params `zip` xs)
   where
     b = case e ^. #blocks . at l of
       Just x -> x
@@ -63,6 +77,13 @@ stepI e vm (CallLabel l xs) =
 
 stepI e vm _ = _
 
+evalVal :: Env -> VM -> Val -> Obj
+evalVal e vm = \case
+  ValImm imm -> ObjImm imm
+  ValReg r -> case vm ^. #registers . at r of
+    Just x -> x
+    Nothing -> error [i|undefined register: #{r}|]
+
 initialVM :: VM
 initialVM = MkVM
   { stack = []

test/Gyehoek/Test/Stack/VM.hs

@@ -11,7 +11,8 @@ import Data.Generics.Labels
 
 root :: IO TestTree
 root = pure . testGroup "stack machine" $
-  [ add
+  [ lit_int
+  , arith
   ]
 
 
@@ -21,10 +22,17 @@ evalsTo rs bs = Sut.eval (MkProgram bs) @?= rs
 
 
 
-add = testCase "lit int" do
+lit_int = testCase "lit int" do
   evalsTo [ValLit (LitInt 3)]
     [ MkBlock "main" []
       [ PopCont "ktail"
       , CallReg "ktail" [ValLit (LitInt 3)]
       ]]
   
+arith = testCase "arith" do
+  evalsTo [ValLit (LitInt 12)]
+    [ MkBlock "main" []
+      [ PopCont "ktail"
+      , Prim "x1" (PrimAdd (ValLit $ LitInt 3) (ValLit $ LitInt 4))
+      , CallReg "ktail" [ValReg "x1"]
+      ]]