wip: abstract stack/continuation machine

src/Gyehoek/Stack/Syntax.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module Gyehoek.Stack.Syntax
+  ( Program(..)
+  , Block(..)
+  , Instr(..)
+  , Val(..)
+  , Lit(..)
+  , Obj(..)
+  , Imm(..)
+  , Prim(..)
+  , Name
+  ) where
+
+import Control.Lens
+import Data.List (List)
+import GHC.Generics (Generic)
+import Data.HashMap.Strict (HashMap)
+import Language.SexpGrammar (SexpIso, (>>>), (:-))
+import Language.SexpGrammar qualified as S
+import Language.SexpGrammar.Generic
+import Data.Coerce (coerce)
+import Data.Text (Text)
+import qualified Gyehoek.Sexp
+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 :: List Block
+  }
+  deriving stock (Show, Generic, Data)
+
+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
+  = Pop Name
+  | Push Val
+  | PopCont Name
+  | PushCont Name
+  | Prim Name (Prim Val)
+  | CallLabel Name (List Val)
+  | CallReg Name (List Val)
+  deriving stock (Show, Generic, Data)
+
+data Val
+  = ValLabel Name
+  | ValReg Name
+  | 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, Data, Eq)

src/Gyehoek/Stack/VM.hs

@@ -0,0 +1,110 @@
+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)
+import Gyehoek.Scheme.Syntax (Sexp(..))
+
+
+data VM = MkVM
+  { stack :: List Obj
+  , kstack :: List Name
+  , code :: List Instr
+  , registers :: HashMap Name Obj
+  , stdout :: Text
+  , result :: Maybe (List Obj)
+  }
+  deriving (Show, Generic)
+
+data Env = MkEnv
+  { blocks :: HashMap Name Block
+  }
+  deriving (Show, Generic)
+
+step :: Env -> VM -> VM
+step e vm = case vm ^. #code of
+  c:cs -> stepI e (vm & #code .~ cs) c
+  _ -> error "halt never called"
+
+stepI :: Env -> VM -> Instr -> VM
+
+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 -> error [i|unimplemented prim: #{p}|]
+  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"
+  (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 ?~ ObjLabel x
+               & #kstack .~ xs
+
+stepI e vm (CallReg r xs) = stepI e vm (CallLabel l xs)
+  where l = vm ^?! #registers . at r . _Just . #ObjLabel
+
+stepI e vm (CallLabel "halt" xs) = vm & #result ?~ fmap (evalVal e vm) xs
+
+stepI e vm (CallLabel l xs) =
+  vm & #code .~ b.code
+     & #registers .~ fmap (evalVal e vm) (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 _ = _
+
+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 = []
+  , kstack = ["halt"]
+  , code = [CallLabel "main" []]
+  , registers = mempty
+  , stdout = ""
+  , result = Nothing
+  }
+
+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 Obj
+eval p = initialVM & loop \vm -> case vm ^. #result of
+  Nothing -> Right $ step (initialEnv p) vm
+  Just rs -> Left rs