diff --git a/doc/abi.org b/doc/abi.org index d6b6db2..26b54ea 100644 --- a/doc/abi.org +++ b/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] [] diff --git a/gyehoek.cabal b/gyehoek.cabal index 29b66c2..b621664 100644 --- a/gyehoek.cabal +++ b/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 diff --git a/src/Gyehoek/Stack/Eval.hs b/src/Gyehoek/Stack/Eval.hs deleted file mode 100644 index d0a79fe..0000000 --- a/src/Gyehoek/Stack/Eval.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Gyehoek.Stack.Eval - ( - ) where - diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index c74207a..5ca45c9 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/src/Gyehoek/Stack/Syntax.hs @@ -3,13 +3,13 @@ module Gyehoek.Stack.Syntax ( Program(..) , Block(..) , Instr(..) - , stk - , readProgram + , Val(..) + , 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 - | DefinePopCont Name - | PushCont Cont - | Push Name - | Call Name + = 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 Cont - = KVar Name - | Kappa Kappa - deriving stock (Show, Generic, Data) - -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 +data Val + = ValLabel Name + | ValReg Name + | ValLit Lit + deriving stock (Show, Generic, Data, Eq) diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs new file mode 100644 index 0000000..821afc3 --- /dev/null +++ b/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 diff --git a/test/Gyehoek/Test/Stack/VM.hs b/test/Gyehoek/Test/Stack/VM.hs new file mode 100644 index 0000000..12da486 --- /dev/null +++ b/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)] + ]] + diff --git a/test/Main.hs b/test/Main.hs index c6eff44..8c3677d 100644 --- a/test/Main.hs +++ b/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 ]