doc/abi.org

@@ -133,6 +133,8 @@ evaluation of ~(fac 0)~:
 (call! ktail)              ; [1] []
 #+end_src
 
+evaluation of ~(fac 3)~
+
 #+begin_src scheme
 (push! 3)                  ; [] []
 (push-cont! halt)          ; [3] []

gyehoek.cabal

@@ -61,8 +61,8 @@ library
     Gyehoek.Options
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
-    Gyehoek.Stack.Eval
     Gyehoek.Stack.Syntax
+    Gyehoek.Stack.VM
     Gyehoek.Wasm
 
   build-depends:
@@ -102,16 +102,21 @@ test-suite test
   type:             exitcode-stdio-1.0
   hs-source-dirs:   test
   main-is:          Main.hs
+
+  -- cabal-fmt: expand test
   other-modules:
     Gyehoek.Test.CPS.Syntax
     Gyehoek.Test.Golden
     Gyehoek.Test.Sexp
+    Gyehoek.Test.Stack.VM
 
   build-depends:
     , base
     , directory
     , filepath
+    , generic-lens
     , gyehoek
+    , lens
     , process-extras
     , sexp-grammar
     , tasty

src/Gyehoek/Stack/Eval.hs

@@ -1,4 +0,0 @@
-module Gyehoek.Stack.Eval
-  (
-  ) where
-

src/Gyehoek/Stack/Syntax.hs

@@ -3,13 +3,13 @@ module Gyehoek.Stack.Syntax
   ( Program(..)
   , Block(..)
   , Instr(..)
-  , stk
+  , Val(..)
-  , readProgram
+  , Lit(..)
+  , Name
   ) where
 
 import Control.Lens
 import Data.List (List)
-import Gyehoek.Scheme.Syntax (Name)
 import GHC.Generics (Generic)
 import Data.HashMap.Strict (HashMap)
 import Language.SexpGrammar (SexpIso, (>>>), (:-))
@@ -22,92 +22,36 @@ import Language.Haskell.TH.Quote (QuasiQuoter)
 import Data.Data (Data)
 import qualified Data.HashMap.Strict as H
 import Effectful
+import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
 
 
 newtype Program = MkProgram
-  { blocks :: HashMap Name Block
+  { blocks :: List Block
   }
   deriving stock (Show, Generic, Data)
 
-newtype Block = MkBlock { code :: List Instr }
+data Block = MkBlock
+  { label :: Name
+  , params :: List Name
+  , code :: List Instr
+  }
   deriving stock (Show, Generic, Data)
 
 instance Each Block Block Instr Instr where
   each = #code . each
 
 data Instr
-  = DefinePop Name
+  = Pop Name
-  | DefinePopCont Name
+  | Push Val
-  | PushCont Cont
+  | PopCont Name
-  | Push Name
+  | PushCont Name
-  | Call Name
+  | Prim Name (Prim Val)
+  | CallLabel Name (List Val)
+  | CallReg Name (List Val)
   deriving stock (Show, Generic, Data)
 
-data Cont
+data Val
-  = KVar Name
+  = ValLabel Name
-  | Kappa Kappa
+  | ValReg Name
-  deriving stock (Show, Generic, Data)
+  | ValLit Lit
-
+  deriving stock (Show, Generic, Data, Eq)
-data Kappa = MkKappa (List Name) Block
-  deriving stock (Show, Generic, Data)
-
-
--- Sexp work
-
-blockGrammar :: S.SexpGrammar (Name, Block)
-blockGrammar = g >>> S.pair where
-  g :: S.Grammar S.Position (S.Sexp :- t) (Block :- (Name :- t))
-  g = S.list $
-    S.el (S.sym "define")
-    >>> S.el (S.list $ S.el $ S.sexpIso @Name)
-    >>> S.rest (S.sexpIso @Instr)
-    >>> S.onTail (S.iso coerce coerce)
-
-instance SexpIso Instr where
-  sexpIso = match
-    $ With (g_DefinePop >>>)
-    $ With (g_DefinePopCont >>>)
-    $ With (g_PushCont >>>)
-    $ With (g_Push >>>)
-    $ With (g_Call >>>)
-    $ End
-    where
-      def :: Text -> S.SexpGrammar Name
-      def s = S.list $
-        S.el (S.sym "define")
-        >>> S.el (S.sexpIso @Name)
-        >>> S.el (S.list $ S.el $ S.sym s)
-      g_DefinePop = def "pop!"
-      g_DefinePopCont = def "pop-cont!"
-      g_PushCont = S.list $
-        S.el (S.sym "push-cont!")
-        >>> S.el (S.sexpIso @Cont)
-      g_Push = S.list $ S.el (S.sym "push!") >>> S.el S.sexpIso
-      g_Call = S.list $ S.el (S.sym "call!") >>> S.el S.sexpIso
-
-instance SexpIso Cont where
-  sexpIso = match
-    $ With (S.sexpIso @Name >>>)
-    $ With (S.sexpIso @Kappa >>>)
-    $ End
-  
-instance SexpIso Kappa where
-  sexpIso = with \g_kappa ->
-    (S.list $
-      S.el Gyehoek.Sexp.kappaKeyword
-      >>> S.el (S.sexpIso @(List Name))
-      >>> S.rest (S.sexpIso @Instr)
-      >>> S.onTail (S.iso coerce coerce))
-    >>> g_kappa
-
-programFromSexps :: Foldable f => f S.Sexp -> Program
-programFromSexps = MkProgram . foldMap f
-  where f = uncurry H.singleton . Gyehoek.Sexp.fromSexp' blockGrammar
-
-stk :: QuasiQuoter
-stk = Gyehoek.Sexp.makeSxs [|| programFromSexps ||]
-
-readProgram
-  :: IOE :> es
-  => FilePath -> Eff es Program
-readProgram = fmap (MkProgram . H.fromList) . Gyehoek.Sexp.readSxs blockGrammar

src/Gyehoek/Stack/VM.hs

@@ -0,0 +1,84 @@
+module Gyehoek.Stack.VM
+  ( VM(..)
+  , Env(..)
+  , eval
+  ) where
+
+import Gyehoek.Stack.Syntax
+import Data.List (List)
+import GHC.Generics (Generic)
+import Control.Lens
+import Data.HashMap.Strict (HashMap)
+import Data.Text (Text)
+import qualified Data.HashMap.Strict as H
+import Data.String.Interpolate (i)
+
+
+data VM = MkVM
+  { stack :: List Val
+  , kstack :: List Name
+  , code :: List Instr
+  , registers :: HashMap Name Val
+  , stdout :: Text
+  }
+  deriving (Show, Generic)
+
+data Env = MkEnv
+  { blocks :: HashMap Name Block
+  }
+  deriving (Show, Generic)
+
+step :: Env -> VM -> Either (List Val) VM
+step e vm = case vm ^. #code of
+  CallLabel "halt" xs :_ -> Left xs
+  i:is -> Right $ stepI e (vm & #code .~ is) i
+  _ -> error "halt never called"
+
+stepI :: Env -> VM -> Instr -> VM
+
+stepI e vm (Push v) = vm & #stack %~ (v:)
+
+stepI e vm (Pop r) = case vm ^. #stack of
+  [] -> error "empty stack"
+  (x:xs) -> vm & #registers . at r ?~ x
+               & #stack .~ xs
+
+stepI e vm (PopCont r) = case vm ^. #kstack of
+  [] -> error "empty stack"
+  (x:xs) -> vm & #registers . at r ?~ ValLabel x
+               & #kstack .~ xs
+
+stepI e vm (CallReg r xs) = stepI e vm (CallLabel l xs)
+  where l = vm ^?! #registers . at r . _Just . #ValLabel
+
+stepI e vm (CallLabel l xs) =
+  vm & #code .~ b.code
+     & #registers .~ H.fromList (b.params `zip` xs)
+  where
+    b = case e ^. #blocks . at l of
+      Just x -> x
+      Nothing -> error [i|undefined label: #{l}|]
+
+stepI e vm _ = _
+
+initialVM :: VM
+initialVM = MkVM
+  { stack = []
+  , kstack = ["halt"]
+  , code = [CallLabel "main" []]
+  , registers = mempty
+  , stdout = ""
+  }
+
+initialEnv :: Program -> Env
+initialEnv (MkProgram bs) = MkEnv
+  { blocks = bs & foldMap \b -> H.singleton b.label b
+  }
+
+loop :: (a -> Either b a) -> a -> b
+loop f a = case f a of
+  Right a' -> loop f a'
+  Left b -> b
+
+eval :: Program -> List Val
+eval p = loop (step $ initialEnv p) initialVM

test/Gyehoek/Test/Stack/VM.hs

@@ -0,0 +1,30 @@
+module Gyehoek.Test.Stack.VM (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Gyehoek.Stack.Syntax
+import Gyehoek.Stack.VM qualified as Sut
+import Data.List (List)
+import Control.Lens
+import Data.Generics.Labels
+
+
+root :: IO TestTree
+root = pure . testGroup "stack machine" $
+  [ add
+  ]
+
+
+
+evalsTo :: List Val -> List Block -> Assertion
+evalsTo rs bs = Sut.eval (MkProgram bs) @?= rs
+
+
+
+add = testCase "lit int" do
+  evalsTo [ValLit (LitInt 3)]
+    [ MkBlock "main" []
+      [ PopCont "ktail"
+      , CallReg "ktail" [ValLit (LitInt 3)]
+      ]]
+  

test/Main.hs

@@ -5,6 +5,7 @@ import Test.Tasty.Silver.Interactive (defaultMain)
 import qualified Gyehoek.Test.Golden
 import qualified Gyehoek.Test.Sexp
 import qualified Gyehoek.Test.CPS.Syntax
+import qualified Gyehoek.Test.Stack.VM
 
 
 main :: IO ()
@@ -15,5 +16,6 @@ root = testGroup "test" <$> sequenceA
   [ Gyehoek.Test.Golden.root
   , Gyehoek.Test.Sexp.root
   , Gyehoek.Test.CPS.Syntax.root
+  , Gyehoek.Test.Stack.VM.root
   ]