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]
+#<internals of zero?>      ; [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]
+#<internals of zero?>      ; [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]
+#<internals of zero?>      ; [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]
+#<internals of zero?>      ; [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]
+#<internals of zero?>      ; [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

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

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.

golden/adder/source.scm

@@ -0,0 +1,4 @@
+(let ((make-adder (lambda (x)
+                    (lambda (y)
+                      (+ x y)))))
+  ((make-adder 4) 5))

golden/apply2/source.scm

@@ -0,0 +1,5 @@
+((λ (f g x)
+   (f (g x)))
+ (λ (x) (+ x 4))
+ (λ (x) (* x 2))
+ 3)

golden/fn-of-fn/source.scm

@@ -1 +1,3 @@
-(((λ (f) f) (λ (x) (* x 4))) 32)
+(((λ (f) f)
+  (λ (x) (* x 4)))
+ 32)

golden/let-fn/source.scm

@@ -0,0 +1,2 @@
+(let ((square (λ (x) (* x x))))
+  (square 4))

gyehoek.cabal

@@ -52,6 +52,7 @@ library
 
   -- cabal-fmt: expand src
   exposed-modules:
+    Gyehoek.CPS.Close
     Gyehoek.CPS.Convert
     Gyehoek.CPS.Lower
     Gyehoek.CPS.Syntax
@@ -60,13 +61,15 @@ library
     Gyehoek.Options
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
+    Gyehoek.Stack.Syntax
+    Gyehoek.Stack.VM
     Gyehoek.Wasm
 
   build-depends:
     , base                  ^>=4.21.2.0
     , binary
+    , bytestring
     , containers
-    , typed-process
     , effectful
     , effectful-core
     , effectful-plugin
@@ -87,9 +90,9 @@ library
     , template-haskell
     , text
     , text-short
+    , typed-process
     , unordered-containers
     , vector
-    , bytestring
 
   hs-source-dirs:   src
   default-language: GHC2024
@@ -99,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/CPS/Close.hs

@@ -0,0 +1,29 @@
+module Gyehoek.CPS.Close
+  ( closeProgram
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Effectful
+import Data.Functor.Foldable
+import Control.Monad ((>=>))
+import Control.Lens
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.HashSet as HS
+
+
+cataM
+  :: (Monad m, Traversable (Base t), Recursive t)
+  => (Base t a -> m a) -> t -> m a
+cataM f = cata (sequenceA >=> f)
+
+close :: Exp -> Exp
+close = cata \case
+  ExpLetRecF {bindersF,bodyF} -> ExpLetRec binders bodyF
+    where
+      binders = bindersF & (each . _2 . _AbsLambda' . _3) %~ \e -> _
+  e -> embed e
+
+        -- let frees = freeWithBound' (HS.fromList $ ktail : bs) e'
+
+closeProgram :: Program -> Eff es Program
+closeProgram (MkProgram e) = pure . MkProgram . close $ e

src/Gyehoek/CPS/Convert.hs

@@ -2,6 +2,7 @@
 {- HLINT ignore "Use camelCase" -}
 module Gyehoek.CPS.Convert
   ( convertProgram
+  , convertExp
   ) where
 
 import Gyehoek.CPS.Syntax
@@ -65,6 +66,20 @@ convert (Scm.ExpIf c t f) k =
   convert c \c' ->
     ExpIf c' <$> convert t k <*> convert f k
 
+-- let-bindings are desugared into continuation calls whose parameters
+-- are the left-hand sides and whose arguments are the right-hand
+-- sides.
+convert (Scm.ExpLet bs e) k =
+  let rhss = bs ^.. each . _2
+  in telescope (convert @es) rhss \rhss' -> do
+    e' <- convert e k
+    kbody <- gensym' @Name "letrec-body"
+    let bs' = bs ^.. each . _1
+    pure [cps|
+      (letrec ((#{kbody} (κ #{bs'} #{e'})))
+        (continue #{kbody} ##{rhss'}))
+    |]
+
 convert _ k = _
 
 convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
@@ -73,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)

src/Gyehoek/CPS/Lower.hs

@@ -26,9 +26,12 @@ import Language.Sexp.Located qualified as SL
 import Control.Monad.Fix
 import qualified Gyehoek.Sexp
 import Data.Text qualified as T
+import Data.List qualified
 import Data.Foldable (fold)
 import Gyehoek.Sexp (encodeOrShow, toSexp)
 import Debug.Pretty.Simple
+import GHC.Stack (HasCallStack)
+import Data.String.Interpolate
 
 
 data Env = MkEnv
@@ -58,31 +61,34 @@ makeSmallFixnum = [expr|
     ref.i31
   |]
 
+getArgRegister :: Natural -> SL.Sexp
+getArgRegister n = SL.Symbol [i|$arg#{n}|]
+
 -- | Given an expression @e@ leaving a @ref eq@ atop the stack,
 -- @pushArg rt n e@ sets the nth slot of the arg-passing array to the
 -- result of @e@.
 pushArg :: Natural -> Wasm.Expr -> Wasm.Expr
 pushArg n e = [expr|
-    (@gyehoek "push argument")
+    (@gyehoek begin pushArg)
-    (global.get $arg-array)
-    (i32.const #{n})
     ##{e}
-    (array.set $arg-array-type)
+    (global.set #{reg})
+    (@gyehoek end pushArg)
   |]
+  where reg = getArgRegister n
 
 -- | Pop the nth arg from the arg-passing array onto the stack.
-popArg :: Int -> Wasm.Expr
+popArg :: Natural -> Wasm.Expr
 popArg n = [expr|
-  (@gyehoek "pop argument")
+  (@gyehoek begin popArg)
-  (global.get $arg-array)
+  (global.get #{reg})
-  (i32.const #{n})
-  (array.get $arg-array-type)
   ref.as_non_null
+  (@gyehoek end popArg)
 |]
+  where reg = getArgRegister n
 
 
 
-lowerVal :: GenMod :> es => Env -> Val -> Eff es Wasm.Expr
+lowerVal :: (HasCallStack, GenMod :> es) => Env -> Val -> Eff es Wasm.Expr
 
 lowerVal g (ValLit l) =
   pure $ case l of
@@ -97,17 +103,10 @@ lowerVal g (ValLit l) =
       where b' :: Int = if b then 0b11 else 0b01
     _ -> _
 
-lowerVal g (ValVar x) = pure $ [expr|(local.get #{l})|]
+lowerVal g (ValVar x) = do
+  pure [expr|(global.get #{l})|]
   where
-    l = succ $ V.elemIndex x g.vars ^?! _Just
+    l = getArgRegister . fromIntegral . succ $ V.elemIndex x g.vars ^?! _Just
-
--- lowerVal g (ValLambda lam) = do
---   idx <- lowerLambda g lam
---   pure [expr|
---     (i32.const 0)
---     (ref.func #{idx})
---     (struct.new $closure)
---   |]
 
 lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
 
@@ -159,11 +158,12 @@ lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do
   let g' = g & #vars <>~ [r]
   let n = succ $ length g.vars
   e' <- lower' g' e
+  let reg = getArgRegister . fromIntegral $ n
   pure [expr|
     (i32.const 0)
     (ref.func #{idx})
     (struct.new $closure)
-    (local.set #{n})
+    (global.set #{reg})
     ##{e'}
   |]
 
@@ -219,20 +219,14 @@ lower' g e = error $ case Gyehoek.Sexp.encode e of
 
 lowerKappa :: GenMod :> es => Env -> Kappa -> Eff es Idx
 lowerKappa g e@(MkKappa xs m) = do
-  let g' = g & #vars .~ V.fromList xs
+  let g' = g & #vars <>~ V.fromList xs
   m' <- lower' g' m
-  let body = mconcat
-        [ xs & ifoldMap \n _ ->
-            let n' = succ n
-            in popArg n <> [expr|(local.set #{n'})|]
-        , m'
-        ]
   let origin = encodeOrShow @_ @Text e
   idx <- Wasm.defineFunction [wat|
     (func (param i32)
       (@gyehoek :origin #{origin})
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{body})
+      ##{m'})
   |]
   Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
   pure idx
@@ -242,18 +236,12 @@ lowerLambda g e@(MkLambda xs ktail m) = do
   let g' = g & #vars .~ V.fromList xs
              & #kvars <>~ [ktail]
   m' <- lower' g' m
-  let body = mconcat
-        [ xs & ifoldMap \n _ ->
-            let n' = succ n
-            in popArg n <> [expr|(local.set #{n'})|]
-        , m'
-        ]
   let origin = encodeOrShow @_ @Text e
   idx <- Wasm.defineFunction [wat|
     (func (param i32)
       (@gyehoek :origin #{origin})
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{body})
+      ##{m'})
   |]
   Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
   pure idx
@@ -265,6 +253,7 @@ lowerBinOp op g x y (MkKappa [r] e) = do
   let op' = SL.Symbol op
   let g' = g & #vars <>~ [r]
   let n = succ $ length (g ^. #vars)
+  let reg = getArgRegister . fromIntegral $ n
   x' <- lowerVal g x
   y' <- lowerVal g y
   e' <- lower' g' e
@@ -279,7 +268,7 @@ lowerBinOp op g x y (MkKappa [r] e) = do
     i32.shr_u
     #{op'}
     ##{makeSmallFixnum}
-    (local.set #{n})
+    (global.set #{reg})
     ##{e'}
   |]
 
@@ -306,13 +295,24 @@ emitRuntime = mfix \runtime -> do
     (global $cont-stack (ref $cont-stack-type)
             (array.new_default $cont-stack-type (i32.const 128)))
   |]
-  -- arg array
+  -- arg registers
-  Wasm.defineType [wat|
+  Wasm.defineGlobals [wats|
-    (type $arg-array-type (array (mut (ref null eq))))
+    (global $arg0 (mut (ref null eq)) (ref.null eq))
-  |]
+    (global $arg1 (mut (ref null eq)) (ref.null eq))
-  Wasm.defineGlobal [wat|
+    (global $arg2 (mut (ref null eq)) (ref.null eq))
-    (global $arg-array (ref $arg-array-type)
+    (global $arg3 (mut (ref null eq)) (ref.null eq))
-            (array.new_default $arg-array-type (i32.const 32)))
+    (global $arg4 (mut (ref null eq)) (ref.null eq))
+    (global $arg5 (mut (ref null eq)) (ref.null eq))
+    (global $arg6 (mut (ref null eq)) (ref.null eq))
+    (global $arg7 (mut (ref null eq)) (ref.null eq))
+    (global $arg8 (mut (ref null eq)) (ref.null eq))
+    (global $arg9 (mut (ref null eq)) (ref.null eq))
+    (global $arg10 (mut (ref null eq)) (ref.null eq))
+    (global $arg11 (mut (ref null eq)) (ref.null eq))
+    (global $arg12 (mut (ref null eq)) (ref.null eq))
+    (global $arg13 (mut (ref null eq)) (ref.null eq))
+    (global $arg14 (mut (ref null eq)) (ref.null eq))
+    (global $arg15 (mut (ref null eq)) (ref.null eq))
   |]
   -- other  things 😼
   Wasm.defineGlobal [wat|

src/Gyehoek/CPS/Syntax.hs

@@ -9,6 +9,7 @@ module Gyehoek.CPS.Syntax
   , Kappa(..)
   , Lambda(..)
   , Exp(..)
+  , ExpF(..)
   , Name(..)
   , Prim(..)
   , Program(..)
@@ -20,6 +21,7 @@ module Gyehoek.CPS.Syntax
   , _ExpPrim
   , _ExpLetRec
   , _ExpApply
+  , _AbsLambda'
   , binders
   , body
   , op
@@ -29,8 +31,9 @@ module Gyehoek.CPS.Syntax
   , pattern AbsLambda'
   , pattern AbsKappa'
   , Abs(..)
-  , free
+  , Free(..)
-  , free'
+  , Vars(..)
+  , Subst(..)
   )
   where
 
@@ -55,6 +58,8 @@ import qualified Data.HashSet as HS
 import Data.Hashable (Hashable)
 import Data.Monoid (Endo)
 import Data.Containers.ListUtils (nubOrd)
+import Data.Functor.Foldable.TH
+import Data.Functor.Foldable (Recursive(..), Corecursive (..))
 
 -- Data types
 
@@ -114,6 +119,7 @@ makePrisms ''Exp
 makeFieldsId ''Exp
 makeFieldsId ''Kappa
 makeFieldsId ''Lambda
+makeBaseFunctor ''Exp
 
 instance HasBinders Abs (List Name) where
   binders k (AbsKappa kap) = AbsKappa <$> binders k kap
@@ -123,6 +129,12 @@ instance HasBody Abs Exp where
   body k (AbsKappa kap) = AbsKappa <$> body k kap
   body k (AbsLambda lam) = AbsLambda <$> body k lam
 
+_AbsLambda' :: Prism' Abs (List Name, Name, Exp)
+_AbsLambda' = prism'
+  (\(bs,ktail,e) -> AbsLambda' bs ktail e)
+  (\case AbsLambda' bs ktail e -> Just (bs,ktail,e)
+         _ -> Nothing)
+
 
 -- SexpIso instances
 
@@ -234,49 +246,116 @@ insertFrom = flip $ foldr HS.insert
 toHashSetOf :: Hashable a => Getting (Endo (HashSet a)) s a -> s -> HashSet a
 toHashSetOf l = foldrOf l HS.insert mempty
 
-free :: Exp -> HashSet Name
+class Free a where
-free = go where
+  free :: a -> HashSet Name
-  gokap (MkKappa xs m) = go m & deleteFrom xs
+  free = freeWithBound mempty
-  golam (MkLambda xs k m) = go m & deleteFrom xs & sans k
+
-  goabs = \case
+  freeWithBound :: HashSet Name -> a -> HashSet Name
-    AbsKappa kap -> gokap kap
+  freeWithBound bound = HS.fromList . freeWithBound' bound
-    AbsLambda lam -> golam lam
+
-  go = \case
+  -- | Free variables given in the order of their appearance.
+  free' :: a -> List Name
+  free' = freeWithBound' mempty
+
+  freeWithBound' :: HashSet Name -> a -> List Name
+
+instance Free Abs where
+  freeWithBound' bound (AbsKappa kap) = freeWithBound' bound kap
+  freeWithBound' bound (AbsLambda lam) = freeWithBound' bound lam
+
+instance Free Exp where
+  freeWithBound' bound = \case
     ExpPrim p k ->
-      p & toHashSetOf (folded . #ValVar)
+      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
-        & HS.union (gokap k)
+        & (<> freeWithBound' bound k)
     ExpLetRec bs m ->
-      foldMapOf (each . _2) goabs bs <> go m
+      foldMapOf (each . _2) (freeWithBound' bound') bs
-      & deleteFrom (bs ^.. each . _1)
+      <> freeWithBound' bound' m
-    ExpContinue k xs -> HS.fromList $ k : xs ^.. each . #ValVar
+      where bound' = bound & insertFrom (bs ^.. each . _1)
-    ExpIf c t f -> toHashSetOf #ValVar c <> go t <> go f
+    ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar)
-    ExpApply f xs k -> toHashSetOf (each . #ValVar) (f:xs) <> HS.singleton k
+    ExpIf c t f ->
+      (c ^.. #ValVar . filtered (`notElem` bound))
+      <> freeWithBound' bound t <> freeWithBound' bound f
+    ExpApply f xs k ->
+      (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
+      <> (k ^.. filtered (`notElem` bound))
 
--- | Free variables given in the order of their appearance.
+instance Free Kappa where
-free' :: Exp -> List Name
+  freeWithBound' bound (MkKappa xs m) =
-free' = nubOrd . goFree HS.empty where
+    freeWithBound' (bound & insertFrom xs) m
 
-goFreeKap bound (MkKappa xs m) = goFree (bound & insertFrom xs) m
+instance Free Lambda where
-goFreeLam bound (MkLambda xs k m) = goFree (bound & insertFrom (k:xs)) m
+  freeWithBound' bound (MkLambda xs k m) =
-goFreeAbs bound = \case
+    freeWithBound' (bound & insertFrom (k:xs)) m
-  AbsKappa kap -> goFreeKap bound kap
-  AbsLambda lam -> goFreeLam bound lam
 
-goFree :: HashSet Name -> Exp -> List Name
+
-goFree bound = \case
-  ExpPrim p k ->
-    p & toListOf (folded . #ValVar . filtered (`notElem` bound))
-      & (<> goFreeKap bound k)
-  ExpLetRec bs m ->
-    foldMapOf (each . _2) (goFreeAbs bound') bs <> goFree bound' m
-    where bound' = bound & insertFrom (bs ^.. each . _1)
-  ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar)
-  ExpIf c t f ->
-    (c ^.. #ValVar . filtered (`notElem` bound))
-    <> goFree bound t <> goFree bound f
-  ExpApply f xs k ->
-    (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
-    <> (k ^.. filtered (`notElem` bound))
 
-freeLambda :: Lambda -> List Name
+class Vars a where
-freeLambda (MkLambda {binders,ktail,body}) = _
+  -- | Traverse the immediate variables of an expression.
+  vars :: Traversal' a Name
+
+instance Vars Val where
+  vars k (ValVar x) = ValVar <$> k x
+  vars _ x = pure x
+
+instance Vars a => Vars (Prim a) where
+  vars k p = traverseOf (each . vars) k p
+
+instance Vars Exp where
+  vars k (ExpPrim p kap) = ExpPrim <$> vars k p <*> pure kap
+  vars k (ExpContinue kname xs) = ExpContinue <$> k kname <*> pure xs
+  vars _ e = pure e
+
+
+
+data Scope
+  = Bind (List Name) (List Scope)
+  | Use (List Name) (List Scope)
+  deriving (Show, Eq)
+
+makeBaseFunctor ''Scope
+
+class Scoped a where
+  scope :: a -> Scope
+
+instance Scoped Kappa where
+  scope (MkKappa bs 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] []
+    _ -> Use [] []
+
+instance Scoped Exp where
+  scope = \case
+    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 -> _

src/Gyehoek/Driver.hs

@@ -1,5 +1,5 @@
 module Gyehoek.Driver
-  (main, lower_e2e, convert_e2e, parse_e2e)
+  (main, lower_e2e, convert_e2e, parse_e2e, readScm)
   where
 
 import Gyehoek.Options
@@ -102,10 +102,9 @@ driver opts = do
   when opts.dumpCPS do
     hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
   wat <- lowerProgram cps
-  if not opts.inspectWasm then
+  withFile opts.output FS.WriteMode \h ->
-    withFile opts.output FS.WriteMode \h ->
+    hPutStrLn h wat
-      hPutStrLn h wat
+  when opts.inspectWasm do
-  else
     inspectWasm wat
 
 parse_e2e :: FilePath -> IO Scm.Program

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,6 +79,8 @@ data Prim e
   | PrimWrite e
   | PrimZeroP e
   | PrimNewline
+  | 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'
@@ -94,6 +103,7 @@ data Def
 
 data Exp
   = ExpLet (NonEmpty (Name, Exp)) Exp
+  | ExpLetRec (NonEmpty (Name, Exp)) Exp
   | ExpPrim (Prim Exp)
   | ExpBegin (List Exp)
   | ExpIf Exp Exp Exp
@@ -154,12 +164,16 @@ primSexpIso namefn a = match
     $ With (. unop "write")
     $ With (. unop "zero?")
     $ With (. nullop "newline")
+    $ With (. mkclosure)
+    $ With (. envref)
     $ End
     where
       idn s = el (sym (namefn s))
       nullop s = list $ idn s
       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
@@ -203,6 +217,7 @@ instance SexpIso Def where
 instance SexpIso Exp where
   sexpIso = match
     $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
+    $ With (. Gyehoek.Sexp.let_ "letrec" sexpIso sexpIso sexpIso)
     $ With (. sexpIso)
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
     $ With (. if_)
@@ -254,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 "-" = "<interactive>"
+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))

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 "-" = "<interactive>"
+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)

src/Gyehoek/Stack/Syntax.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module Gyehoek.Stack.Syntax
+  ( Program(..)
+  , Block(..)
+  , Instr(..)
+  , Val(..)
+  , Lit(..)
+  , 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
+  | ValLit Lit
+  deriving stock (Show, Generic, Data, Eq)

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

t.scm

@@ -1 +1,21 @@
-(values 1 2)
+(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))

t.wat

@@ -22,38 +22,60 @@
     $cont-stack
     (ref $cont-stack-type)
     (array.new_default $cont-stack-type (i32.const 128)))
-  (type $arg-array-type (array (mut (ref null eq))))
+  (global $arg0 (mut (ref null eq)) (ref.null eq))
-  (global
+  (global $arg1 (mut (ref null eq)) (ref.null eq))
-    $arg-array
+  (global $arg2 (mut (ref null eq)) (ref.null eq))
-    (ref $arg-array-type)
+  (global $arg3 (mut (ref null eq)) (ref.null eq))
-    (array.new_default $arg-array-type (i32.const 32)))
+  (global $arg4 (mut (ref null eq)) (ref.null eq))
+  (global $arg5 (mut (ref null eq)) (ref.null eq))
+  (global $arg6 (mut (ref null eq)) (ref.null eq))
+  (global $arg7 (mut (ref null eq)) (ref.null eq))
+  (global $arg8 (mut (ref null eq)) (ref.null eq))
+  (global $arg9 (mut (ref null eq)) (ref.null eq))
+  (global $arg10 (mut (ref null eq)) (ref.null eq))
+  (global $arg11 (mut (ref null eq)) (ref.null eq))
+  (global $arg12 (mut (ref null eq)) (ref.null eq))
+  (global $arg13 (mut (ref null eq)) (ref.null eq))
+  (global $arg14 (mut (ref null eq)) (ref.null eq))
+  (global $arg15 (mut (ref null eq)) (ref.null eq))
   (global $result (mut (ref null eq)) (ref.null eq))
   (func
     $halt
     (param i32)
-    (@gyehoek "pop argument")
+    (@gyehoek begin popArg)
-    (global.get $arg-array)
+    (global.get $arg0)
-    (i32.const 0)
-    (array.get $arg-array-type)
     ref.as_non_null
+    (@gyehoek end popArg)
     (global.set $result))
   (func
     (param i32)
-    (@gyehoek :origin "(κ (x5) (continue λ-tail1 x5))")
+    (@gyehoek
+      :origin
+      "(λ (x λ-tail1) (prim (* x x) (κ (r2) (continue λ-tail1 r2))))")
     (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (@gyehoek "pop argument")
+    (@gyehoek
-    (global.get $arg-array)
+      :origin
-    (i32.const 0)
+      "(prim (* x x) (κ (r2) (continue λ-tail1 r2)))")
-    (array.get $arg-array-type)
+    (global.get $arg1)
-    ref.as_non_null
+    (i31.get_s (ref.cast (ref i31)))
-    (local.set 1)
+    (i32.const 1)
-    (@gyehoek :origin "(continue λ-tail1 x5)")
+    i32.shr_u
+    (global.get $arg1)
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
+    i32.mul
+    (@gyehoek "construct small fixnum")
+    (i32.const 1)
+    i32.shl
+    ref.i31
+    (global.set $arg2)
+    (@gyehoek :origin "(continue λ-tail1 r2)")
     (@gyehoek "push args")
-    (@gyehoek "push argument")
+    (@gyehoek begin pushArg)
-    (global.get $arg-array)
+    (global.get $arg2)
-    (i32.const 0)
+    (global.set $arg0)
-    (local.get 4)
+    (@gyehoek end pushArg)
-    (array.set $arg-array-type)
     (@gyehoek "nargs")
     (i32.const 1)
     (@gyehoek "pop cont stack")
@@ -69,58 +91,26 @@
   (elem declare funcref (ref.func 3))
   (func
     (param i32)
-    (@gyehoek
+    (@gyehoek :origin "(κ (x4) (continue halt x4))")
-      :origin
-      "(κ (x3) (letrec ((r4 (κ (x5) (continue λ-tail1 x5)))) (f x3 r4)))")
     (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (@gyehoek "pop argument")
+    (@gyehoek begin pushArg)
-    (global.get $arg-array)
+    (global.get $arg2)
-    (i32.const 0)
+    (global.set $arg0)
-    (array.get $arg-array-type)
+    (@gyehoek end pushArg)
-    ref.as_non_null
+    (return_call $halt (i32.const 1)))
-    (local.set 1)
-    (@gyehoek :origin "(f x3 r4)")
-    (@gyehoek "push cont" :idx 3)
-    (array.set
-      $cont-stack-type
-      (global.get $cont-stack)
-      (global.get $cont-stack-top)
-      (ref.func 3))
-    (global.set
-      $cont-stack-top
-      (i32.add (global.get $cont-stack-top) (i32.const 1)))
-    (@gyehoek :origin "(f x3 r4)")
-    (@gyehoek "load args")
-    (@gyehoek "push argument")
-    (global.get $arg-array)
-    (i32.const 0)
-    (local.get 3)
-    (array.set $arg-array-type)
-    (i32.const 1)
-    (local.get 1)
-    (ref.cast (ref $closure))
-    (struct.get $closure $code)
-    (return_call_ref $cont-type))
   (elem declare funcref (ref.func 4))
   (func
+    $scm-entry
     (param i32)
     (@gyehoek
       :origin
-      "(λ (f x λ-tail1) (letrec ((r2 (κ (x3) (letrec ((r4 (κ (x5) (continue λ-tail1 x5)))) (f x3 r4))))) (f x r2)))")
+      "(letrec ((λ-body0 (λ (x λ-tail1) (prim (* x x) (κ (r2) (continue λ-tail1 r2)))))) (letrec ((r3 (κ (x4) (continue halt x4)))) (λ-body0 5 r3)))")
     (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (@gyehoek "pop argument")
-    (global.get $arg-array)
     (i32.const 0)
-    (array.get $arg-array-type)
+    (ref.func 3)
-    ref.as_non_null
+    (struct.new $closure)
-    (local.set 1)
+    (global.set $arg1)
-    (@gyehoek "pop argument")
+    (@gyehoek :origin "(λ-body0 5 r3)")
-    (global.get $arg-array)
-    (i32.const 1)
-    (array.get $arg-array-type)
-    ref.as_non_null
-    (local.set 2)
-    (@gyehoek :origin "(f x r2)")
     (@gyehoek "push cont" :idx 4)
     (array.set
       $cont-stack-type
@@ -130,135 +120,22 @@
     (global.set
       $cont-stack-top
       (i32.add (global.get $cont-stack-top) (i32.const 1)))
-    (@gyehoek :origin "(f x r2)")
+    (@gyehoek :origin "(λ-body0 5 r3)")
     (@gyehoek "load args")
-    (@gyehoek "push argument")
+    (@gyehoek begin pushArg)
-    (global.get $arg-array)
+    (i32.const 5)
-    (i32.const 0)
+    (@gyehoek "construct small fixnum")
-    (local.get 2)
-    (array.set $arg-array-type)
     (i32.const 1)
-    (local.get 1)
+    i32.shl
+    ref.i31
+    (global.set $arg0)
+    (@gyehoek end pushArg)
+    (i32.const 1)
+    (global.get $arg1)
     (ref.cast (ref $closure))
     (struct.get $closure $code)
-    (return_call_ref $cont-type))
+    (return_call_ref $cont-type)
-  (elem declare funcref (ref.func 5))
+    (@gyehoek todo (f' (global.get $arg1)) (ktail 1)))
-  (func
-    (param i32)
-    (@gyehoek
-      :origin
-      "(λ (x λ-tail7) (prim (+ x 4) (κ (r8) (continue λ-tail7 r8))))")
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (@gyehoek "pop argument")
-    (global.get $arg-array)
-    (i32.const 0)
-    (array.get $arg-array-type)
-    ref.as_non_null
-    (local.set 1)
-    (@gyehoek
-      :origin
-      "(prim (+ x 4) (κ (r8) (continue λ-tail7 r8)))")
-    (local.get 1)
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    (i32.const 4)
-    (@gyehoek "construct small fixnum")
-    (i32.const 1)
-    i32.shl
-    ref.i31
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    i32.add
-    (@gyehoek "construct small fixnum")
-    (i32.const 1)
-    i32.shl
-    ref.i31
-    (local.set 2)
-    (@gyehoek :origin "(continue λ-tail7 r8)")
-    (@gyehoek "push args")
-    (@gyehoek "push argument")
-    (global.get $arg-array)
-    (i32.const 0)
-    (local.get 2)
-    (array.set $arg-array-type)
-    (@gyehoek "nargs")
-    (i32.const 1)
-    (@gyehoek "pop cont stack")
-    (global.get $cont-stack-top)
-    (i32.const 1)
-    i32.sub
-    (global.set $cont-stack-top)
-    (global.get $cont-stack)
-    (global.get $cont-stack-top)
-    (array.get $cont-stack-type)
-    ref.as_non_null
-    (return_call_ref $cont-type))
-  (elem declare funcref (ref.func 6))
-  (func
-    (param i32)
-    (@gyehoek :origin "(κ (x10) (continue halt x10))")
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (@gyehoek "pop argument")
-    (global.get $arg-array)
-    (i32.const 0)
-    (array.get $arg-array-type)
-    ref.as_non_null
-    (local.set 1)
-    (@gyehoek "push argument")
-    (global.get $arg-array)
-    (i32.const 0)
-    (local.get 3)
-    (array.set $arg-array-type)
-    (return_call $halt (i32.const 1)))
-  (elem declare funcref (ref.func 7))
-  (func
-    $scm-entry
-    (param i32)
-    (@gyehoek
-      :origin
-      "(letrec ((λ-body0 (λ (f x λ-tail1) (letrec ((r2 (κ (x3) (letrec ((r4 (κ (x5) (continue λ-tail1 x5)))) (f x3 r4))))) (f x r2))))) (letrec ((λ-body6 (λ (x λ-tail7) (prim (+ x 4) (κ (r8) (continue λ-tail7 r8)))))) (letrec ((r9 (κ (x10) (continue halt x10)))) (λ-body0 λ-body6 9 r9))))")
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (i32.const 0)
-    (ref.func 5)
-    (struct.new $closure)
-    (local.set 1)
-    (i32.const 0)
-    (ref.func 6)
-    (struct.new $closure)
-    (local.set 2)
-    (@gyehoek :origin "(λ-body0 λ-body6 9 r9)")
-    (@gyehoek "push cont" :idx 7)
-    (array.set
-      $cont-stack-type
-      (global.get $cont-stack)
-      (global.get $cont-stack-top)
-      (ref.func 7))
-    (global.set
-      $cont-stack-top
-      (i32.add (global.get $cont-stack-top) (i32.const 1)))
-    (@gyehoek :origin "(λ-body0 λ-body6 9 r9)")
-    (@gyehoek "load args")
-    (@gyehoek "push argument")
-    (global.get $arg-array)
-    (i32.const 0)
-    (local.get 2)
-    (array.set $arg-array-type)
-    (@gyehoek "push argument")
-    (global.get $arg-array)
-    (i32.const 1)
-    (i32.const 9)
-    (@gyehoek "construct small fixnum")
-    (i32.const 1)
-    i32.shl
-    ref.i31
-    (array.set $arg-array-type)
-    (i32.const 1)
-    (local.get 1)
-    (ref.cast (ref $closure))
-    (struct.get $closure $code)
-    (return_call_ref $cont-type))
   (func
     (export "main")
     (call $scm-entry (i32.const 0))

test/Gyehoek/Test/CPS/Syntax.hs

@@ -18,15 +18,17 @@ root = pure . testGroup "cps syntax" $
   ]
 
 freeTree :: TestTree
-freeTree = testCase "free" do
+freeTree = testGroup "free"
-  Sut.free [cps|
+  [ testCase "lambda" do
-    (letrec ((x (lambda (r k1) (continue k1 y)))
+    Sut.free' @Sut.Lambda [cps|
-             (y (lambda (r k2) (continue k2 x))))
+      (lambda (x y z k1) (continue k1 x a b c y))
-      (continue x y k3))|] @=? ["k3"]
+    |] @=? ["a","b","c"]
-  Sut.free' [cps|
+  , testCase "exp" do
-    (letrec ((x (lambda (r k1) (continue k1 y)))
+    Sut.free' @Sut.Exp [cps|
-             (y (lambda (r k2) (continue k2 x))))
+      (letrec ((x (lambda (r k1) (continue k1 y)))
-      (continue x y k3))|] @=? ["k3"]
+               (y (lambda (r k2) (continue k2 x))))
+        (continue x y k3))|] @=? ["k3"]
+  ]
 
 qqTree :: TestTree
 qqTree = testGroup "parser"

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
   ]