From 745277ed1a94722ac243d1c41b4c2f7f4bcf4b6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Mon, 17 Aug 2026 16:17:53 -0600 Subject: [PATCH] wip: abstract stack/continuation machine --- doc/abi.org | 218 ++++++++++++++++++++++++++++++++++ doc/closure-conversion.org | 83 +++++++++++++ doc/notes.org | 53 +++++++++ golden/apply2/source.scm | 5 + golden/fn-of-fn/source.scm | 4 +- golden/let-fn/source.scm | 2 + gyehoek.cabal | 7 ++ src/Gyehoek/CPS/Convert.hs | 5 +- src/Gyehoek/CPS/Syntax.hs | 49 +++++--- src/Gyehoek/Scheme/Syntax.hs | 31 ++++- src/Gyehoek/Sexp.hs | 28 +++++ src/Gyehoek/Stack/Syntax.hs | 70 +++++++++++ src/Gyehoek/Stack/VM.hs | 110 +++++++++++++++++ t.scm | 24 +++- test/Gyehoek/Test/Stack/VM.hs | 50 ++++++++ test/Main.hs | 6 +- 16 files changed, 723 insertions(+), 22 deletions(-) create mode 100644 doc/abi.org create mode 100644 doc/closure-conversion.org create mode 100644 doc/notes.org create mode 100644 golden/apply2/source.scm create mode 100644 golden/let-fn/source.scm create mode 100644 src/Gyehoek/Stack/Syntax.hs create mode 100644 src/Gyehoek/Stack/VM.hs create mode 100644 test/Gyehoek/Test/Stack/VM.hs diff --git a/doc/abi.org b/doc/abi.org new file mode 100644 index 0000000..26b54ea --- /dev/null +++ b/doc/abi.org @@ -0,0 +1,218 @@ +#+title: ABI + +largely based on the Guile Hoot's [[https://codeberg.org/spritely/hoot/src/branch/main/design/ABI.md][ABI]]. + +* calling convention + +** non-tail calls + +- set the global variable ~$current-closure~ to the callee's closure. +- load arguments into globals ~$arg0~, ~$arg1~, ~$arg2~, … +- push return continuation onto ~$cont-stack~ + +* scratchpad + +#+begin_src scheme + ;; Scheme source + (define (silly f g h x) + (f (h x) (g x))) + + + ;; continuation-passing style + (define (silly f g h x ktail) + (h x (κ (x0) + (g x (κ (x1) + (f x0 x1 ktail)))))) + + ;; with explicit stacks + (define (silly) + (define f (pop!)) + (define g (pop!)) + (define h (pop!)) + (define x (pop!)) + (define ktail (pop-cont!)) + (push-cont! (κ (x0) + (define x* (pop!)) + (define g* (pop!)) + (push-cont! (κ (x1) + (define f* (pop!)) + (define x0* (pop!)) + (push-cont! ktail) + (push! x0*) + (push! x1) + (call! f))) + (push! x*) + (call! g))) + (push! x) + (call! h)) +#+end_src + +** fac + +*** Scheme source + +#+begin_src scheme +(define fac + (λ (n) + (if (zero? n) + 1 + (* n (fac (- n 1)))))) + +(fac 3) +#+end_src + +*** CPS + +#+begin_src scheme + (define fac + (λ (n ktail) + (zero? n (κ (x0) + (if x0 + 1 + (- n 1 + (κ (x1) + (fac x1 + (κ (x2) + (* n x2 ktail)))))))))) + +(fac 3 halt) + +#+end_src + +*** tailified + +#+begin_src scheme +(define (fac-k1) + (define n (pop!)) + (define x2 (pop!)) + (define x3 (* n x2)) + (define ktail (pop-cont!)) + (push! x3) + (call! ktail)) + +(define (fac-k0) + (define x0 (pop!)) + (define n (pop!)) + (if x0 + (begin (define ktail (pop-cont!)) + (push! 1) + (call! ktail)) + (begin (define x1 (- n 1)) + (push! x1) + (push-cont! fac-k1) + (call! fac)))) + +(define (fac) + (define n (pop!)) + (push! n) + (push-cont! fac-k0) + (push! n) + (call! zero?)) + +(push! 3) +(push-cont! halt) +(call! fac) +#+end_src + +evaluation of ~(fac 0)~: + +#+begin_src scheme +(push! 0) ; [] [] +(push-cont! halt) ; [0] [] +(call! fac) ; [0] [halt] +(define n (pop!)) ; [0] [halt] +(push! n) ; [] [halt] +(push-cont! fac-k0) ; [0] [halt] +(push! n) ; [0] [halt fac-k0] +(call! zero?) ; [0 0] [halt fac-k0] +# ; [0 0] [halt fac-k0] +(define x0 (pop!)) ; [0 #t] [halt] +(define n (pop!)) ; [0] [halt] +(define ktail (pop-cont!)) ; [] [halt] +(push! 1) ; [] [] +(call! ktail) ; [1] [] +#+end_src + +evaluation of ~(fac 3)~ + +#+begin_src scheme +(push! 3) ; [] [] +(push-cont! halt) ; [3] [] +(call! fac) ; [3] [halt] + +(define n (pop!)) ; [3] [halt] +(push! n) ; [] [halt] +(push-cont! fac-k0) ; [3] [halt] +(push! n) ; [3] [halt fac-k0] +(call! zero?) ; [3 3] [halt fac-k0] +# ; [3 3] [halt fac-k0] +(define x0 (pop!)) ; [3 #f] [halt] +(define n (pop!)) ; [3] [halt] +(define x1 (- n 1)) ; [] [halt] +(push! n) ; [] [halt] +(push! x1) ; [3] [halt] +(push-cont! fac-k1) ; [3 2] [halt] +(call! fac) ; [3 2] [halt fac-k1] + +(define n (pop!)) ; [3 2] [halt fac-k1] +(push! n) ; [3 ] [halt fac-k1] +(push-cont! fac-k0) ; [3 2] [halt fac-k1] +(push! n) ; [3 2] [halt fac-k1 fac-k0] +(call! zero?) ; [3 2 2] [halt fac-k1 fac-k0] +# ; [3 2 2] [halt fac-k1 fac-k0] +(define x0 (pop!)) ; [3 2 #f] [halt fac-k1] +(define n (pop!)) ; [3 2] [halt fac-k1] +(define x1 (- n 1)) ; [3] [halt fac-k1] +(push! n) ; [3] [halt fac-k1] +(push! x1) ; [3 2] [halt fac-k1] +(push-cont! fac-k1) ; [3 2 1] [halt fac-k1] +(call! fac) ; [3 2 1] [halt fac-k1 fac-k1] + +(define n (pop!)) ; [3 2 1] [halt fac-k1 fac-k1] +(push! n) ; [3 2] [halt fac-k1 fac-k1] +(push-cont! fac-k0) ; [3 2 1] [halt fac-k1 fac-k1] +(push! n) ; [3 2 1] [halt fac-k1 fac-k1 fac-k0] +(call! zero?) ; [3 2 1 1] [halt fac-k1 fac-k1 fac-k0] +# ; [3 2 1 1] [halt fac-k1 fac-k1 fac-k0] +(define x0 (pop!)) ; [3 2 1 #f] [halt fac-k1 fac-k1] +(define n (pop!)) ; [3 2 1] [halt fac-k1 fac-k1] +(define x1 (- n 1)) ; [3 2] [halt fac-k1 fac-k1] +(push! n) ; [3 2] [halt fac-k1] +(push! x1) ; [3 2 1] [halt fac-k1 fac-k1] +(push-cont! fac-k1) ; [3 2 1 0] [halt fac-k1 fac-k1] +(call! fac) ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1] + +(define n (pop!)) ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1] +(push! n) ; [3 2 1] [halt fac-k1 fac-k1 fac-k1] +(push-cont! fac-k0) ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1] +(push! n) ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1 fac-k0] +(call! zero?) ; [3 2 1 0 0] [halt fac-k1 fac-k1 fac-k1 fac-k0] +# ; [3 2 1 0 0] [halt fac-k1 fac-k1 fac-k1 fac-k0] +(define x0 (pop!)) ; [3 2 1 0 #t] [halt fac-k1 fac-k1 fac-k1] +(define n (pop!)) ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1] +(define ktail (pop-cont!)) ; [3 2 1] [halt fac-k1 fac-k1 fac-k1] +(push! 1) ; [3 2 1 1] [halt fac-k1 fac-k1] +(call! ktail) ; [3 2 1 1] [halt fac-k1 fac-k1] + +(define n (pop!)) ; [3 2 1 1] [halt fac-k1 fac-k1] +(define x2 (pop!)) ; [3 2 1] [halt fac-k1 fac-k1] +(define x3 (* n x2)) ; [3 2] [halt fac-k1 fac-k1] +(define ktail (pop-cont!)) ; [3 2] [halt fac-k1 fac-k1] +(push! x3) ; [3 2] [halt fac-k1] +(call! ktail) ; [3 2 1] [halt fac-k1] + +(define n (pop!)) ; [3 2 1] [halt fac-k1] +(define x2 (pop!)) ; [3 2] [halt fac-k1] +(define x3 (* n x2)) ; [3] [halt fac-k1] +(define ktail (pop-cont!)) ; [3] [halt fac-k1] +(push! x3) ; [3] [halt] +(call! ktail) ; [3 2] [halt] + +(define n (pop!)) ; [3 2] [halt] +(define x2 (pop!)) ; [3] [halt] +(define x3 (* n x2)) ; [] [halt] +(define ktail (pop-cont!)) ; [] [halt] +(push! x3) ; [] [] +(call! ktail) ; [6] [] +;; => (halt 6) +#+end_src diff --git a/doc/closure-conversion.org b/doc/closure-conversion.org new file mode 100644 index 0000000..1f58588 --- /dev/null +++ b/doc/closure-conversion.org @@ -0,0 +1,83 @@ +#+title: closure-conversion + +the closure-conversion phase makes closed-over variables explicit by addition of the primitive ~make-closure~, taking a code pointer (in the CPS language, bare lambda) and the environment. + +* scratchpad + +#+begin_src scheme +(letrec ((make-adder + (lambda (n) + (lambda (x) + (+ n x))))) +((make-adder 3) 2)) +#+end_src + +#+begin_src scheme +(define add-code + (lambda (n env) + (+ n (env-ref env 'x)))) + +(define make-adder-code + (lambda (n) + (make-closure add-code ('x n)))) + +(define make-adder (make-closure make-adder-code)) + +(apply-closure (apply-closure make-addder 3) 2) +#+end_src + +#+begin_src wat +(module + (type $heap-object (sub (struct (field $hash (mut i32))))) + (type $closure (sub $heap-object + (struct (field $hash (mut i32)) + (field $code (ref $cont-type))))) + (type $closure1 (sub $closure + (struct (field $hash (mut i32)) + (field $code (ref $cont-type)) + (field $env0 (ref eq))))) + (global $arg0 (mut (ref null eq)) (ref.null eq)) + (global $arg1 (mut (ref null eq)) (ref.null eq)) + (global $arg2 (mut (ref null eq)) (ref.null eq)) + (global $arg3 (mut (ref null eq)) (ref.null eq)) + (global $arg4 (mut (ref null eq)) (ref.null eq)) + (global $arg5 (mut (ref null eq)) (ref.null eq)) + ;; ⋮ + ;; (global $argn (mut (ref null eq)) (ref.null eq)) + + (global $current-closure (mut (ref null $closure)) (ref.null $closure)) + + (func $add-code (param $nargs i32) + (local $n (ref eq)) + (local $x (ref eq)) + (local.set $n (global.get $arg0)) + (local.set $x (struct.get $closure1 + (global.get $current-closure) + $env0)) + (return (i32.add $n $x))) + + (func $make-adder-code (param $nargs i32) + (local $n (ref eq)) + (local.set $n (global.get $arg0)) + (return (struct.new $closure1 + 0 + $add-code))) + + (func $main + (local.set $make-adder + (struct.new $closure + 0 + $make-adder-code)) + (global.set $current-closure $make-adder) + (global.set $arg0 (i32.const 3)) + (local.set $f (call (struct.get $closure + $make-adder + $code) + 1)) + (global.set $current-closure $f) + (global.set $arg0 (i32.const 2)) + (return (call (struct.get $closure + $f + $code) + 1)))) +#+end_src diff --git a/doc/notes.org b/doc/notes.org new file mode 100644 index 0000000..910895c --- /dev/null +++ b/doc/notes.org @@ -0,0 +1,53 @@ +#+title: assorted notes on compilation + +* letrec + +consider: + +#+begin_src scheme + (letrec ((even? (lambda (n) + (if (zero? n) + #t + (odd? (- n 1))))) + (odd? (lambda (n) + (if (zero? n) + #f + (even? (- n 1)))))) + (even? 12)) +#+end_src + +#+RESULTS: +: #t + +since ~letrec~ is a primitive construct in the CPS language, the translation of mutually recursive functions is straightforward: + +#+begin_src scheme + (define (-& x y k) (k (- x y))) + (define (zero?& x k) (k (zero? x))) + (define (halt x) x) + + (letrec ((even? (lambda (n ktail) + (zero?& n + (lambda (x1) + (if x1 + #t + (-& n 1 + (lambda (x2) + (odd? x2 ktail)))))))) + (odd? (lambda (n ktail) + (zero?& n + (lambda (x1) + (if x1 + #f + (-& n 1 + (lambda (x2) + (even? x2 ktail))))))))) + (even? 12 halt)) +#+end_src + +#+RESULTS: +: #t + +however, Scheme permits ~letrec~-expressions with non-lambda right-hand sides, while the CPS language permits only kappa and lambda forms. thus, the handling of these forms is less trivial. + +for now we'll just reject any ~letrec~ forms with non-lambda right-hand sides, lol. they aren't very important. diff --git a/golden/apply2/source.scm b/golden/apply2/source.scm new file mode 100644 index 0000000..f1d25c6 --- /dev/null +++ b/golden/apply2/source.scm @@ -0,0 +1,5 @@ +((λ (f g x) + (f (g x))) + (λ (x) (+ x 4)) + (λ (x) (* x 2)) + 3) diff --git a/golden/fn-of-fn/source.scm b/golden/fn-of-fn/source.scm index 23de627..51e5d04 100644 --- a/golden/fn-of-fn/source.scm +++ b/golden/fn-of-fn/source.scm @@ -1 +1,3 @@ -(((λ (f) f) (λ (x) (* x 4))) 32) +(((λ (f) f) + (λ (x) (* x 4))) + 32) diff --git a/golden/let-fn/source.scm b/golden/let-fn/source.scm new file mode 100644 index 0000000..6224cea --- /dev/null +++ b/golden/let-fn/source.scm @@ -0,0 +1,2 @@ +(let ((square (λ (x) (* x x)))) + (square 4)) diff --git a/gyehoek.cabal b/gyehoek.cabal index 91a6714..b621664 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -61,6 +61,8 @@ library Gyehoek.Options Gyehoek.Scheme.Syntax Gyehoek.Sexp + Gyehoek.Stack.Syntax + Gyehoek.Stack.VM Gyehoek.Wasm build-depends: @@ -100,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/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs index 80232d0..11270dd 100644 --- a/src/Gyehoek/CPS/Convert.hs +++ b/src/Gyehoek/CPS/Convert.hs @@ -2,6 +2,7 @@ {- HLINT ignore "Use camelCase" -} module Gyehoek.CPS.Convert ( convertProgram + , convertExp ) where import Gyehoek.CPS.Syntax @@ -79,7 +80,6 @@ convert (Scm.ExpLet bs e) k = (continue #{kbody} ##{rhss'})) |] - convert _ k = _ convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program @@ -88,3 +88,6 @@ convertProgram p = pure . Halt1 $ case NE.nonEmpty exps of Nothing -> ValLit Void Just es -> NE.last es + +convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp +convertExp e = convert e (pure . Halt1) diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 419aa20..7840226 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -309,32 +309,53 @@ instance Vars Exp where data Scope - = Bind (List Name) Scope - | Use (List Name) Scope - | Leaf + = Bind (List Name) (List Scope) + | Use (List Name) (List Scope) deriving (Show, Eq) makeBaseFunctor ''Scope -class Subst a where - substWith :: (Name -> Val) -> a -> a - -instance Subst Exp where - substWith sub = cata \e -> - _ - class Scoped a where scope :: a -> Scope instance Scoped Kappa where scope (MkKappa bs e) = - Bind bs (scope e) + Bind bs [scope e] + +instance Scoped Lambda where + scope (MkLambda bs k e) = Bind (bs ++ [k]) [scope e] + +instance Scoped Abs where + scope = \case + AbsKappa k -> scope k + AbsLambda l -> scope l instance Scoped Val where scope = \case - ValVar x -> Use [x] Leaf - _ -> Leaf + ValVar x -> Use [x] [] + _ -> Use [] [] instance Scoped Exp where scope = \case - ExpApply f xs k = _ + ExpApply f xs k -> + Use (((f:xs) ^.. each . _ValVar) ++ [k]) [] + ExpLetRec bs e -> + Bind (bs ^.. each . _1) $ + (bs ^.. each . _2 . to scope) + ++ [scope e] + ExpPrim p k -> + Use (p ^.. each . _ValVar) [scope k] + ExpContinue k xs -> + Use (k : (xs ^.. each . _ValVar)) [] + ExpIf c t f -> + Use (c ^.. _ValVar) [ scope t, scope f ] + + + +class Subst a where + substWith :: (Name -> Maybe Val) -> a -> a + +instance Subst Exp where + substWith f = go HS.empty where + go bound e = case scope e of + Use xs ss -> _ diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index f173d46..e36b655 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -23,6 +23,8 @@ module Gyehoek.Scheme.Syntax , subst , getName , scm + , readExp + , readProgram ) where @@ -33,6 +35,7 @@ import Language.SexpGrammar import Language.SexpGrammar qualified as Sexp import Language.Sexp.Located qualified as S import Language.SexpGrammar.Generic +import Effectful import GHC.Generics import Prelude hiding ((.), id) import Control.Category @@ -49,6 +52,10 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HS import Data.Foldable (fold) import Language.Haskell.TH.Quote (QuasiQuoter) +import Effectful.FileSystem (runFileSystem) +import qualified Effectful.FileSystem.IO as FS +import qualified Data.Text.Encoding as T +import qualified Effectful.FileSystem.IO.ByteString as FB newtype Name = MkName { inner :: Text } @@ -72,7 +79,8 @@ data Prim e | PrimWrite e | PrimZeroP e | PrimNewline - | PrimMakeClosure { code :: e, upvals :: List e } + | PrimMakeClosure { code :: e, env :: List e } + | PriEnvRef e Int deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq) instance Each (Prim e) (Prim e') e e' @@ -157,6 +165,7 @@ primSexpIso namefn a = match $ With (. unop "zero?") $ With (. nullop "newline") $ With (. mkclosure) + $ With (. envref) $ End where idn s = el (sym (namefn s)) @@ -164,6 +173,7 @@ primSexpIso namefn a = match unop s = list $ idn s >>> el a binop s = list $ idn s >>> el a >>> el a mkclosure = list $ idn "make-closure" >>> el a >>> rest a + envref = list $ idn "env-ref" >>> el a >>> el Sexp.int instance SexpIso a => SexpIso (Prim a) where -- sexpIso = primSexpIso ("prim:"<>) sexpIso @@ -259,3 +269,22 @@ subst f = \e -> cata go e mempty where go (ExpLetF _ _) _ = error "todo lol" go (ExpLambdaF bs e) bound = e $ insertFrom bs bound go e bound = embed $ fmap ($ bound) e + + + +fileName :: FilePath -> FilePath +fileName "-" = "" +fileName e = e + +hGetContents :: FS.FileSystem :> es => FS.Handle -> Eff es Text +hGetContents h = T.decodeUtf8 <$> FB.hGetContents h + +readProgram :: IOE :> es => FilePath -> Eff es Program +readProgram fp = runFileSystem $ + FS.withFile fp FS.ReadMode $ \h -> + Gyehoek.Sexp.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h + >>= either error (pure . MkProgram) + +readExp :: IOE :> es => FilePath -> Eff es Program +readExp fp = readProgram fp <&> + (^?! (#commandsAndDefs . _head . _Comm)) diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index aa73a49..a8c0066 100644 --- a/src/Gyehoek/Sexp.hs +++ b/src/Gyehoek/Sexp.hs @@ -38,10 +38,12 @@ module Gyehoek.Sexp , makeSx' , toSexp , fromSexp + , fromSexp' , stripLocation , format , equivalent , encodeOrShow + , readSxs ) where @@ -87,6 +89,10 @@ import qualified Data.Vector as V import qualified Data.Vector.Strict import Data.Function (on) import Data.String (IsString (fromString)) +import Effectful +import qualified Effectful.FileSystem.IO as FS +import qualified Effectful.FileSystem.IO.ByteString as FB +import qualified Data.Text.Encoding as T sexp :: SexpIso a => Iso' a Text @@ -120,6 +126,10 @@ parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a) parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8 where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp sexpIso) +parseSexpsWith :: SexpGrammar a -> FilePath -> Text -> Either String (List a) +parseSexpsWith g f = marshal . SL.parseSexps f . view lazy . encodeUtf8 + where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g) + parseSexp :: SexpIso a => FilePath -> Text -> Either String a parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8 where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso) @@ -140,6 +150,24 @@ parseSexpWithPos g pos = marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8 where marshal = join . traverseOf _Right (Sexp.fromSexp g) +fileName :: FilePath -> FilePath +fileName "-" = "" +fileName e = e + +hGetContents :: FS.FileSystem :> es => FS.Handle -> Eff es Text +hGetContents h = T.decodeUtf8 <$> FB.hGetContents h + +readSxs + :: IOE :> es + => SexpGrammar a + -> FilePath -> Eff es (List a) +readSxs g fp = FS.runFileSystem $ + FS.withFile fp FS.ReadMode $ \h -> + parseSexpsWith g (fileName fp) <$> hGetContents h + >>= either error pure + + + nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t) nonEmptyGrammar = IGB.Iso (\((x:|xs) :- t) -> reverse xs :- x :- t) diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs new file mode 100644 index 0000000..9c97133 --- /dev/null +++ b/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) diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs new file mode 100644 index 0000000..84471b7 --- /dev/null +++ b/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 diff --git a/t.scm b/t.scm index ac4a5ee..6b87d22 100644 --- a/t.scm +++ b/t.scm @@ -1,3 +1,21 @@ -(letrec ((x 3) - (y 4)) - (values x y)) +(define (-& x y k) (k (- x y))) +(define (zero?& x k) (k (zero? x))) +(define (halt x) x) + +(letrec ((even? (lambda (n ktail) + (zero?& n + (lambda (x1) + (if x1 + #t + (-& n 1 + (lambda (x2) + (odd? x2 ktail)))))))) + (odd? (lambda (n ktail) + (zero?& n + (lambda (x1) + (if x1 + #f + (-& n 1 + (lambda (x2) + (even? x2 ktail))))))))) + (even? 12 halt)) diff --git a/test/Gyehoek/Test/Stack/VM.hs b/test/Gyehoek/Test/Stack/VM.hs new file mode 100644 index 0000000..5f070a0 --- /dev/null +++ b/test/Gyehoek/Test/Stack/VM.hs @@ -0,0 +1,50 @@ +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" $ + [ lit_int + , arith + ] + + + +evalsTo :: List Obj -> List Block -> Assertion +evalsTo rs bs = Sut.eval (MkProgram bs) @?= rs + + + +lit_int = testCase "lit int" do + evalsTo [ObjImm (ImmInt 3)] + [ MkBlock "main" [] + [ PopCont "ktail" + , CallReg "ktail" [ValImm (ImmInt 3)] + ] + ] + +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"] + ] + ] + , testCase "subtract" do + evalsTo [ObjImm (ImmInt 14)] + [ MkBlock "main" [] + [ PopCont "ktail" + , Prim "x1" (PrimSub (ValImm $ ImmInt 20) (ValImm $ ImmInt 6)) + , CallReg "ktail" [ValReg "x1"] + ] + ] + ] diff --git a/test/Main.hs b/test/Main.hs index c6eff44..23a804c 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 () @@ -12,8 +13,9 @@ main = defaultMain =<< root root :: IO TestTree root = testGroup "test" <$> sequenceA - [ Gyehoek.Test.Golden.root - , Gyehoek.Test.Sexp.root + [ {- Gyehoek.Test.Golden.root + ,-} Gyehoek.Test.Sexp.root , Gyehoek.Test.CPS.Syntax.root + , Gyehoek.Test.Stack.VM.root ]