From c4bcf383748aaa5829f62a4f9d7ca89f133ab3be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Mon, 17 Aug 2026 23:44:26 -0600 Subject: [PATCH] factorial --- src/Gyehoek/Stack/Syntax.hs | 9 +++ src/Gyehoek/Stack/VM.hs | 65 ++++++++++++++++++++- test/Gyehoek/Test/Stack/VM.hs | 106 +++++++++++++++++++++++++++++----- 3 files changed, 161 insertions(+), 19 deletions(-) diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index 9c97133..d2653fd 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/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 diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs index 84471b7..b68463f 100644 --- a/src/Gyehoek/Stack/VM.hs +++ b/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 diff --git a/test/Gyehoek/Test/Stack/VM.hs b/test/Gyehoek/Test/Stack/VM.hs index 5f070a0..48ec8f5 100644 --- a/test/Gyehoek/Test/Stack/VM.hs +++ b/test/Gyehoek/Test/Stack/VM.hs @@ -12,7 +12,8 @@ import Data.Generics.Labels root :: IO TestTree root = pure . testGroup "stack machine" $ [ lit_int - , arith + , procedure + , prims ] @@ -29,22 +30,95 @@ lit_int = testCase "lit int" do , CallReg "ktail" [ValImm (ImmInt 3)] ] ] - + +procedure = testGroup "procedure" + [ testCase "return constant" do + evalsTo [ObjImm (ImmInt 123)] + [ MkBlock "main" [] + [ CallLabel "silly" [] + ] + , MkBlock "silly" [] + [ PopCont "ktail" + , CallReg "ktail" [ValImm (ImmInt 123)] + ] + ] + , testCase "identity function" do + evalsTo [ObjImm (ImmInt 45)] + [ MkBlock "main" [] + [ CallLabel "id" [ValImm (ImmInt 45)] + ] + , MkBlock "id" ["x"] + [ PopCont "ktail" + , CallReg "ktail" [ValReg "x"] + ] + ] + , testCase "square" do + evalsTo [ObjImm (ImmInt 16)] + [ MkBlock "main" [] + [ CallLabel "square" [ValImm (ImmInt 4)] + ] + , MkBlock "square" ["x"] + [ PopCont "ktail" + , Prim "x2" $ PrimMul (ValReg "x") (ValReg "x") + , CallReg "ktail" [ValReg "x2"] + ] + ] + , testCase "factorial" do + let 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"] + ] + ] + evalsTo [ObjImm (ImmInt 1)] $ + [ MkBlock "main" [] + [ CallLabel "fac" [ValImm (ImmInt 0)] + ] + ] ++ fac + evalsTo [ObjImm (ImmInt 720)] $ + [ MkBlock "main" [] + [ CallLabel "fac" [ValImm (ImmInt 6)] + ] + ] ++ fac + ] + +prims = testGroup "prims" + [ arith + , testCase "zero?" do + trivialPrimTest [ObjImm (ImmBool True)] $ + PrimZeroP $ ValImm $ ImmInt 0 + trivialPrimTest [ObjImm (ImmBool False)] $ + PrimZeroP $ ValImm $ ImmInt 12 + ] + +trivialPrimTest rs p = + evalsTo rs + [ MkBlock "main" [] + [ PopCont "ktail" + , Prim "x1" p + , CallReg "ktail" [ValReg "x1"] + ] + ] + arith = testGroup "arith" [ testCase "multipy" do - evalsTo [ObjImm (ImmInt 12)] - [ MkBlock "main" [] - [ PopCont "ktail" - , Prim "x1" (PrimMul (ValImm $ ImmInt 3) (ValImm $ ImmInt 4)) - , CallReg "ktail" [ValReg "x1"] - ] - ] + trivialPrimTest [ObjImm (ImmInt 12)] + (PrimMul (ValImm $ ImmInt 3) (ValImm $ ImmInt 4)) , testCase "subtract" do - evalsTo [ObjImm (ImmInt 14)] - [ MkBlock "main" [] - [ PopCont "ktail" - , Prim "x1" (PrimSub (ValImm $ ImmInt 20) (ValImm $ ImmInt 6)) - , CallReg "ktail" [ValReg "x1"] - ] - ] + trivialPrimTest [ObjImm (ImmInt 14)] + (PrimSub (ValImm $ ImmInt 20) (ValImm $ ImmInt 6)) ]