cli, cps interpreter, stack vm, closure-conversion, fixes, tests, LOL

.dir-locals.el

@@ -4,4 +4,6 @@
                  (haskell-mode-buffer-apply-command "cabal-fmt"))
                (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)
                (add-to-list 'haskell-font-lock-quasi-quote-modes
-                            '("cps" . scheme-mode)))))))
+                            '("cps" . scheme-mode))
+               (add-to-list 'haskell-font-lock-quasi-quote-modes
+                            '("scm" . scheme-mode)))))))

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,134 @@
+#+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.
+
+nice testable properties of closure-converted code:
+- code pointers only appear in function position
+- no function has free variables
+
+multiple ~env-ref~ calls could probably be replaced with a primitive that loads the entire environment at once, returning multiple variables.
+
+* scratchpad
+
+** example
+
+#+caption: scheme source
+#+begin_src scheme
+  (letrec ((curried-add (λ (n)
+                          (λ (m)
+                            (+ n m)))))
+    ((curried-add 3) 4))
+#+end_src
+
+#+caption: cps
+#+begin_src scheme
+  (letrec ((curried-add
+            (λ (n ktail0)
+              (letrec ((curried-add-in
+                        (λ (m ktail1)
+                          (prim (+ n m)
+                                (κ (x0) (continue ktail1 x0))))))
+                (continue ktail0 curried-add-in)))))
+    (letrec ((k0 (κ (adder) (adder 4 halt))))
+      (curried-add 3 k0)))
+#+end_src
+
+#+caption: closure-converted
+#+begin_src scheme
+  (letrec ((curried-add
+            (λ (n ktail0)
+              (letrec ((curried-add-in-code
+                        (λ (env m ktail1)
+                          (prim (env-ref 0 env)
+                                (κ (n)
+                                   (prim (+ n m)
+                                         (κ (x0) (continue ktail1 x0))))))))
+                (prim (make-closure curried-add-in-code n)
+                      (κ (curried-add-in)
+                         (continue ktail0 curried-add-in)))))))
+    (letrec ((k0 (κ (adder-closure)
+                    (prim (closure-code adder-closure)
+                          (κ (adder)
+                             (adder adder-closure 4 halt))))))
+      (curried-add 3 k0)))
+#+end_src
+
+** wasm
+
+#+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/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 9

golden/adder/source.scm

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

golden/apply-twice/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 17

golden/apply2/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 10

golden/apply2/source.scm

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

golden/callcc-constant/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 123

golden/callcc-constant/source.scm

@@ -0,0 +1 @@
+(call/cc (λ (cc) (cc 123)))

golden/callcc-discard/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 1234

golden/callcc-discard/source.scm

@@ -0,0 +1 @@
+(call/cc (λ (_) 1234))

golden/callcc-nested1/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 456

golden/callcc-nested1/source.scm

@@ -0,0 +1,5 @@
+(call/cc
+ (λ (k1)
+   (call/cc
+    (λ (k2)
+      (k1 456)))))

golden/callcc-nested2/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 456

golden/callcc-nested2/source.scm

@@ -0,0 +1,5 @@
+(call/cc
+ (λ (k1)
+   (call/cc
+    (λ (k2)
+      (k2 456)))))

golden/factorial/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 720

golden/factorial/source.scm

@@ -0,0 +1,5 @@
+(letrec ((fac (λ (n)
+                (if (zero? n)
+                    1
+                    (* n (fac (- n 1)))))))
+  (fac 6))

golden/fn-of-fn/source.scm

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

golden/let-fn/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 16

golden/let-fn/source.scm

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

golden/letrec-fn/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 16

golden/letrec-fn/source.scm

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

gyehoek.cabal

@@ -52,21 +52,27 @@ library
 
   -- cabal-fmt: expand src
   exposed-modules:
+    Gyehoek.CPS.Close
     Gyehoek.CPS.Convert
+    Gyehoek.CPS.Eval
     Gyehoek.CPS.Lower
+    Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
     Gyehoek.GenSym
     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
+    , deepseq
     , effectful
     , effectful-core
     , effectful-plugin
@@ -78,6 +84,7 @@ library
     , megaparsec
     , mtl
     , optparse-applicative
+    , ordered-containers
     , pretty-simple
     , prettyprinter
     , process
@@ -87,9 +94,9 @@ library
     , template-haskell
     , text
     , text-short
+    , typed-process
     , unordered-containers
     , vector
-    , bytestring
 
   hs-source-dirs:   src
   default-language: GHC2024
@@ -100,19 +107,29 @@ test-suite test
   hs-source-dirs:   test
   main-is:          Main.hs
   other-modules:
+    Gyehoek.Test.CPS.Eval
+    Gyehoek.Test.CPS.Stackify
     Gyehoek.Test.CPS.Syntax
     Gyehoek.Test.Golden
+    Gyehoek.Test.Scheme.Syntax
     Gyehoek.Test.Sexp
+    Gyehoek.Test.Stack.VM
 
   build-depends:
     , base
+    , deepseq
     , directory
+    , effectful
     , filepath
+    , generic-lens
     , gyehoek
+    , lens
     , process-extras
     , sexp-grammar
     , tasty
+    , tasty-expected-failure
     , tasty-hunit
     , tasty-silver
+    , text
 
   default-language: GHC2024

src/Gyehoek/CPS/Close.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE OverloadedLists #-}
+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
+import qualified Data.Set.Ordered as O
+import Data.Set.Ordered (OSet)
+import Gyehoek.GenSym
+import Data.String.Interpolate (i)
+import Debug.Pretty.Simple
+import Data.HashSet (HashSet)
+
+
+cataM
+  :: (Monad m, Traversable (Base t), Recursive t)
+  => (Base t a -> m a) -> t -> m a
+cataM f = cata (sequenceA >=> f)
+
+close :: GenSym :> es => Exp -> Eff es Exp
+
+close = transformM \case
+
+  ExpLetRec [(f, AbsLambda lam@(MkLambda bs kb m))] e -> do
+    f_code <- gensym' @Name $ f ^. _Wrapped'. to (<> "-code")
+    -- it would probably be most sane to generate a symbol for `env`,
+    -- but we're reusing the lambda binding for the sake of recursive
+    -- reverences.
+    -- env <- gensym' @Name "env"
+    let frees = freeWithBound' [f] lam
+    let m' = ifoldr
+             (\n x q -> [cps|(prim (env-ref #{f} #{n})
+                                (κ (#{x}) #{q}))|])
+             m frees
+    pure [cps|
+      (letrec ((#{f_code} (λ (#{f} ##{bs} #{kb})
+                            #{m'})))
+        (prim (make-closure ($ #{f_code}) ##{frees})
+          (κ (#{f}) #{e})))
+    |]
+
+  ExpApply f xs ktail -> do
+    code <- gensym' @Name "code"
+    pure [cps|
+      (prim (env-code #{f})
+        (κ (#{code})
+          (#{code} #{f} ##{xs} #{ktail})))
+    |]
+
+  e -> pure e
+
+  e -> error [i|unimplemented case: #{e}|]
+
+  -- lam@(ExpLambdaF bs m) -> do
+  --   env <- gensym' @Name "env"
+  --   let upvalBinds = free' (embed lam)
+  --         & itraversed %@~ \i x -> (x, [cps|(env-ref #{env} #{i})|])
+  --   let upvals = upvalBinds ^.. each . _1
+  --   pure [cps|
+  --     (make-closure (λ (#{env} ##{bs})
+  --                     (let #{upvalBinds}
+  --                       #{m}))
+  --                   ##{upvals})
+  --    |]
+  -- ExpApplyF f xs ->
+  --   pure [scm|
+  --     (apply-closure #{f} ##{xs})
+  --   |]
+
+closeProgram :: GenSym :> es => Program -> Eff es Program
+closeProgram = traverseOf #body close
+
+curriedadd :: Program
+curriedadd = [cps|
+  (letrec ((curried-add
+            (λ (n ktail1)
+              (letrec ((curried-add-in
+                        (λ (m ktail2)
+                          (prim (+ n m)
+                                (κ (x0) (continue ktail2 x0))))))
+                (continue ktail1 curried-add-in)))))
+    (letrec ((k0 (κ (adder) (adder 4 halt))))
+      (curried-add 5 k0)))
+|]
+
+square :: Program
+square = [cps|
+(letrec ((lambda-body0 (λ (x lambda-tail1)
+                (prim (* x x) (κ (r2) (continue lambda-tail1 r2))))))
+  (letrec
+    ((r3 (κ (x4) (continue halt x4))))
+    (lambda-body0 5 r3)))
+|]

src/Gyehoek/CPS/Convert.hs

@@ -2,6 +2,7 @@
 {- HLINT ignore "Use camelCase" -}
 module Gyehoek.CPS.Convert
   ( convertProgram
+  , convertExp
   ) where
 
 import Gyehoek.CPS.Syntax
@@ -13,6 +14,11 @@ import Control.Monad.Cont qualified as Cont
 import Control.Lens
 import qualified Data.List.NonEmpty as NE
 import qualified Gyehoek.Sexp
+import Data.String.Interpolate (i)
+import Data.Functor (unzip)
+import Data.List (List)
+import Prelude hiding (unzip)
+import Debug.Pretty.Simple (pTraceShowMForceColor)
 
 
 -- 뻘짓이어라
@@ -37,18 +43,33 @@ convert
 convert (Scm.ExpVar x) k = k $ ValVar x
 convert (Scm.ExpLit l) k = k $ ValLit l
 
+-- special case: call/cc is desugared during cps-conversion...
+convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
+  convert withcc \withcc' -> do
+    cc <- gensym' @Name "cc"
+    r <- gensym' "r"
+    m <- k $ ValVar r
+    ccish <- gensym' @Name "cc-ish"
+    x <- gensym' @Name "x"
+    pure [cps|
+      (letrec ((#{cc} (κ (#{r}) #{m})))
+        (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
+          (#{withcc'} #{ccish} #{cc})))
+    |]
+
+-- ...while all other prims are left as-is for later stages to
+-- handle..
 convert (Scm.ExpPrim p) k =
   telescope (convert @es) p \p' -> do
     r <- gensym' "r"
     ExpPrim p' . MkKappa [r] <$> k (ValVar r)
 
 convert (Scm.ExpLambda xs e) k = do
-  f <- gensym' "λ-body"
+  f <- gensym' "lambda-body"
-  ktail <- gensym' "λ-tail"
+  lam <- convertLambda xs e
-  m <- convert e $ \e' -> pure $ ExpContinue ktail [e']
   ke <- k $ ValVar f
   pure [cps|
-    (letrec ((#{f} (λ (##{xs} #{ktail}) #{m})))
+    (letrec ((#{f} #{lam}))
       #{ke})
   |]
 
@@ -65,7 +86,38 @@ convert (Scm.ExpIf c t f) k =
   convert c \c' ->
     ExpIf c' <$> convert t k <*> convert f k
 
-convert _ 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 "let-body"
+    let bs' = bs ^.. each . _1
+    pure [cps|
+      (letrec ((#{kbody} (κ #{bs'} #{e'})))
+        (continue #{kbody} ##{rhss'}))
+    |]
+
+convert (Scm.ExpLetRec bs m) k = do
+  let bs' = bs & each . _2 %~ (^?! #ExpLambda)
+  let conv = traverseOf _2 (uncurry $ convertLambda @es)
+  bs'' <- traverse conv bs'
+  m' <- convert m k
+  pure [cps|
+    (letrec #{bs''} #{m'})
+  |]
+
+-- convert e k = error [i|unimplemented expr: #{e}|]
+
+convertLambda
+  :: GenSym :> es
+  => List Name -> Scm.Exp -> Eff es Lambda
+convertLambda bs m = do
+  ktail <- gensym' "lambda-tail"
+  m' <- convert m $ pure . ExpContinue ktail . (:[])
+  pure [cps|(λ (##{bs} #{ktail}) #{m'})|]
 
 convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
 convertProgram p =
@@ -73,3 +125,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/Eval.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE ViewPatterns #-}
+module Gyehoek.CPS.Eval
+  ( evalProgram
+  , module Gyehoek.CPS.Syntax
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Data.String.Interpolate (i)
+import Data.HashMap.Strict (HashMap)
+import Control.Lens
+import Data.Maybe (fromMaybe)
+import Data.Generics.Labels ()
+import GHC.Generics (Generic)
+import Data.List (List)
+import Text.Show.Functions ()
+import qualified Data.HashMap.Strict as H
+import Debug.Pretty.Simple (pTraceShowId)
+import qualified Data.Text as T
+
+
+data Code
+  = CodeKap (List Obj -> List Obj)
+  | CodeLam (List Obj -> Name -> List Obj)
+  deriving (Show, Generic)
+
+data Env = MkEnv
+  { vars :: HashMap Name Obj
+  , labels :: HashMap Name (Env, Abs)
+  }
+  deriving (Show, Generic)
+
+eval :: Env -> Exp -> List Obj
+
+eval g (Halt xs) = evalVal g <$> xs
+
+eval g (ExpContinue k xs) =
+  case g ^. #labels . at k of
+    Just (h, AbsKappa' bs m) -> eval h' m
+      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
+    _ -> error [i|not a kappa: #{k}|]
+
+eval g (ExpApply ((^?! #ValVar) -> f) xs ktail) =
+  case g ^?! #labels . at f of
+    Just (h,AbsLambda' bs kb m) -> eval h' m
+      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
+                   & #labels . at kb .~ (g ^. #labels . at ktail)
+    Nothing -> error [i|undefined label: #{f}|]
+
+eval g (ExpLetRec [(b, ab)] e) = eval g' e
+  where g' = g & #labels . at b ?~ (g,ab)
+
+eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
+  PrimAdd x y -> arithBinop (+) x y
+  PrimMul x y -> arithBinop (*) x y
+  PrimSub x y -> arithBinop (-) x y
+  PrimDiv x y -> arithBinop div x y
+  _ -> error [i|unhandled prim: #{p}|]
+  where
+    ret rs = eval
+        (g & #vars <>~ envOfBinds bs rs)
+        e
+    arithBinop f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
+      ret [ObjImm . ImmInt $ f x y]
+    arithBinop _ x y = error [i|bad arith: #{x}, #{y}|]
+
+eval _ e = error [i|unimplemented case: #{e}|]
+
+envOfBinds bs xs = foldMap (uncurry H.singleton) (zip bs xs)
+
+evalVal :: Env -> Val -> Obj
+evalVal g = \case
+  ValVar x -> fromMaybe (error [i|unbound: #{x}|]) $ g ^?! #vars . at x
+  ValImm x -> ObjImm x
+  ValLit l -> ObjImm $ case l of
+    LitInt n -> ImmInt n
+    LitBool b -> ImmBool b
+
+emptyEnv :: Env
+emptyEnv = MkEnv
+  { vars = mempty
+  , labels = H.singleton "halt" $
+    ( emptyEnv
+    , AbsKappa' ["h0"] $ Halt [ValVar "h0"]
+    )
+  }
+
+evalProgram :: Program -> List Obj
+evalProgram (MkProgram e) = eval emptyEnv e
+
+curriedadd :: Program
+curriedadd = [cps|
+(letrec ((curried-add
+          (λ (n ktail1)
+            (letrec ((curried-add-in
+                      (λ (m ktail2)
+                        (prim (+ n m)
+                              (κ (x0) (continue ktail2 x0))))))
+              (continue ktail1 curried-add-in)))))
+  (letrec ((k0 (κ (adder) (adder 4 halt))))
+    (curried-add 5 k0)))
+|]
+
+idfn = [cps|
+        (letrec ((id (λ (x ktail)
+                       (continue ktail x))))
+          (id 456 halt))
+      |] :: Program

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/Stackify.hs

@@ -0,0 +1,153 @@
+{-# LANGUAGE OverloadedLists #-}
+module Gyehoek.CPS.Stackify
+  ( stackifyExp
+  , stackifyProgram
+  , module Gyehoek.CPS.Syntax
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Gyehoek.Stack.Syntax qualified as Stk
+import Data.Sequence (Seq)
+import Data.Sequence qualified as Seq
+import Effectful
+import Gyehoek.GenSym
+import Effectful.Writer.Static.Shared
+import Control.Lens
+import Data.String.Interpolate
+import Gyehoek.Stack.Syntax (Imm(..))
+import GHC.Generics (Generic)
+import Data.Foldable
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as H
+import Data.List (List, elemIndex)
+import GHC.Exts (IsList(fromList))
+
+
+type Stackify = Writer Stk.Program
+
+runStackify :: Eff (Stackify : es) a -> Eff es (a, Stk.Program)
+runStackify = runWriter
+
+live :: Free a => Env -> a -> List Name
+live g e = free' e & filter \x ->
+  x `H.member` g.bound
+  && not (x `elem` g.contStack)
+
+stackify
+  :: (GenSym :> es, Stackify :> es)
+  => Env -> Exp -> Eff es (Seq Stk.Instr)
+
+stackify g (ExpLetRec [(f, kap@(AbsKappa' xs m))] e) = do
+  let vs = (f, Stk.ValLabel f) : (bindReg <$> xs)
+  let ls = live g kap
+  m' <- stackify (g & #bound .~ H.fromList (vs ++ (bindReg <$> ls))) m
+  tell [Stk.MkBlock f xs $
+        [Stk.Pop x | x <- ls] <> toList m']
+  let g' = g & #bound . at f ?~ Stk.ValLabel f
+             & #liveness . at f ?~ ls
+  stackify g' e
+
+stackify g (ExpLetRec [(f, AbsLambda' xs k m)] e) = do
+  let vs = (k:xs) <&> \x -> (x, Stk.ValReg x)
+  m' <- stackify (g & #bound .~ H.fromList vs
+                    & #contStack %~ (k:)) m
+  tell [Stk.MkBlock f xs . toList $ m']
+  stackify g e
+
+stackify g (ExpIf c t f) = do
+  t' <- stackify g t
+  f' <- stackify g f
+  pure [ Stk.If (stackifyVal g c) (toList t') (toList f') ]
+
+stackify g (ExpApply f xs ktail) = do
+  pure $
+    [ Stk.PushCont k ]
+    <> fromList [ Stk.Push (Stk.ValReg l) | l <- ls ]
+    <> [ Stk.Call (stackifyVal g f) (stackifyVal g <$> xs) ]
+  where
+    k = var g ktail
+    ls = fold $ (k ^? #ValImm . #ImmLabel)
+      >>= \klbl -> g ^. #liveness . at klbl
+
+stackify g (ExpContinue k xs) =
+  -- return continuations require popping the stack. how do we know
+  -- when a continuation is a return continuation? is this a correct
+  -- test?
+  case elemIndex k g.contStack of
+    Nothing -> pure [ Stk.Call (Stk.ValLabel k) xs' ]
+    Just j -> do
+      ktail <- gensym' $ k ^. _Wrapped'
+      pure $
+       Seq.replicate j (Stk.PopCont "_")
+       <> [ Stk.PopCont ktail
+          , Stk.Call (Stk.ValReg ktail) (stackifyVal g <$> xs)
+          ]
+
+  where xs' = stackifyVal g <$> xs
+
+stackify g (ExpPrim p (MkKappa [x] e)) = do
+  e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
+  pure $ [ Stk.Prim x (stackifyVal g <$> p) ] <> e'
+
+stackify _ e = error [i|unimplemented exp: #{e}|]
+
+stackifyVal :: Env -> Val -> Stk.Val
+stackifyVal g = \case
+  ValLit (LitInt n) -> Stk.ValImm (ImmInt n)
+  ValLit (LitBool b) -> Stk.ValImm (ImmBool b)
+  ValImm imm -> Stk.ValImm imm
+  ValVar v -> var g v
+  v -> error [i|unimplemented val: #{v}|]
+
+var :: Env -> Name -> Stk.Val
+var g v = case g ^. #bound . at v of
+  Just x -> x
+  Nothing -> Stk.ValLabel v
+
+bindReg :: Name -> (Name, Stk.Val)
+bindReg x = (x, Stk.ValReg x)
+
+
+
+data Env = MkEnv
+  { bound :: HashMap Name Stk.Val
+  -- | for each locally-bound continuation @k@, @liveness@ has an
+  -- entry @(k,ls)@ where @ls@ is the sequence of registers @k@
+  -- expects to find saved on the stack.
+  , liveness :: HashMap Name (List Name)
+  , contStack :: List Name
+  }
+  deriving (Show, Generic)
+
+emptyEnv :: Env
+emptyEnv = MkEnv mempty mempty ["halt"]
+
+
+
+stackifyExp :: GenSym :> es => Name -> Exp -> Eff es Stk.Program
+stackifyExp lbl e = do
+  (code,p) <- runStackify $ stackify emptyEnv e
+  pure $ p <> Stk.MkProgram [ Stk.MkBlock lbl [] (toList code) ]
+
+stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program
+stackifyProgram (MkProgram e) = stackifyExp "main" e
+
+
+
+fac :: Program
+fac = [cps|
+  (letrec ((fac (λ (n ktail)
+                  (prim (zero? n)
+                        (κ (x0)
+                           (if x0
+                               (continue ktail 1)
+                               (prim (- n 1)
+                                 (κ (x1)
+                                    (letrec ((fac-k0
+                                              (κ (x2)
+                                                 (prim (* n x2)
+                                                   (κ (x3)
+                                                     (continue ktail x3))))))
+                                      (fac x1 fac-k0))))))))))
+    (fac 6 halt))
+|]

src/Gyehoek/CPS/Syntax.hs

@@ -4,15 +4,20 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)
   , Lambda(..)
   , Exp(..)
+  , ExpF(..)
   , Name(..)
   , Prim(..)
   , Program(..)
   , Lit(..)
+  , Imm(..)
+  , Obj(..)
+  , Hob(..)
   , pattern Void
   , pattern Halt
   , pattern Halt1
@@ -20,6 +25,7 @@ module Gyehoek.CPS.Syntax
   , _ExpPrim
   , _ExpLetRec
   , _ExpApply
+  , _AbsLambda'
   , binders
   , body
   , op
@@ -29,8 +35,11 @@ module Gyehoek.CPS.Syntax
   , pattern AbsLambda'
   , pattern AbsKappa'
   , Abs(..)
-  , free
+  , Free(..)
-  , free'
+  , Vars(..)
+  , Subst(..)
+  , pattern ValLabel
+  , labelName -- don't like that this is part of the api
   )
   where
 
@@ -39,6 +48,7 @@ import Gyehoek.Sexp qualified
 import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void, getName)
 import Data.List (List)
 import GHC.Generics (Generic)
+import Data.Generics.Labels ()
 import Language.SexpGrammar.Generic
 import Control.Category
 import Control.Lens hiding (op)
@@ -55,14 +65,43 @@ 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 (..))
+import Control.DeepSeq (NFData)
+import qualified Gyehoek.Sexp as GS
+import qualified Language.Sexp.Located as SL
+import Data.Data.Lens (uniplate)
 
 -- Data types
 
 data Val
-  = ValVar Name
+  = ValImm Imm
   | ValLit Lit
+  | ValVar Name
   deriving (Show, Generic, Data, Eq)
 
+pattern ValLabel :: Name -> Val
+pattern ValLabel x = ValImm (ImmLabel x)
+
+data Imm
+  = ImmInt Int
+  | ImmBool Bool
+  | ImmLabel Name
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
+
+data Obj
+  = ObjImm Imm
+  | ObjHob Hob
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
+
+-- | a heap object.
+data Hob
+  = HobClosure { label :: Name, env :: List Obj }
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
+
 data Kappa = MkKappa { binders :: List Name, body :: Exp }
   deriving (Show, Generic, Data, Eq)
 
@@ -74,12 +113,15 @@ data Abs
   | AbsLambda Lambda
   deriving (Show, Generic, Data, Eq)
 
+pattern AbsKappa' :: [Name] -> Exp -> Abs
 pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)
+
+pattern AbsLambda' :: [Name] -> Name -> Exp -> Abs
 pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 
 data Exp
   = ExpPrim (Prim Val) Kappa
-  | ExpLetRec { binders :: NonEmpty (Name, Abs), body :: Exp }
+  | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
   | ExpContinue Name (List Val)
   | ExpIf Val Exp Exp
   | ExpApply
@@ -114,6 +156,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,15 +166,63 @@ 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)
+
+instance Plated Exp where
+  plate = uniplate
+  -- plate k = \case
+  --   ExpPrim p kap -> ExpPrim p <$> body k kap
+  --   ExpLetRec bs e -> ExpLetRec <$> (each . _2 . body) k bs <*> k e
+  --   ExpContinue c xs -> pure $ ExpContinue c xs
+  --   ExpIf c t f -> ExpIf c <$> k t <*> k f
+  --   ExpApply f xs ktail -> pure $ ExpApply f xs ktail
+
 
 -- SexpIso instances
 
 instance S.SexpIso Val where
   sexpIso = match
-    $ With (\var -> var . S.sexpIso)
     $ With (\lit -> lit . S.sexpIso)
+    $ With (\imm -> imm . S.sexpIso)
+    $ With (\var -> var . S.sexpIso)
     $ End
 
+instance S.SexpIso Obj where
+  sexpIso = match
+    $ With (\imm -> imm . S.sexpIso)
+    $ With (\hob -> hob . S.sexpIso)
+    $ End
+
+instance S.SexpIso Imm where
+  sexpIso = match
+    $ With (. S.int)
+    $ With (. GS.schemeBool)
+    $ With (. labelName)
+    $ End
+
+labelName :: S.SexpGrammar Name
+labelName = S.coproduct
+  [ S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
+        (S.expected "label")
+        (prefixed @Name "$")
+  , S.list $ S.el (S.sym "$") >>> S.el (S.sexpIso @Name)
+  ]
+
+instance S.SexpIso Hob where
+  sexpIso = match
+    $ With (. closure)
+    $ End
+    where
+      -- closures can be printed, but not parsed.
+      closure :: S.Grammar S.Position (Sexp :- t) (List Obj :- Name :- t)
+      closure = IG.Flip $ IG.PartialIso
+        (\(env:-code:-t) -> SL.Modified SL.Hash [GS.sx|(#{code} ##{env})|] :- t)
+        (const . Left $ mempty)
+
 instance S.SexpIso Lambda where
   sexpIso = match
     $ With (. lambda)
@@ -219,6 +310,7 @@ instance CPS Val where toCPS = Gyehoek.Sexp.fromSexp
 instance CPS Kappa where toCPS = Gyehoek.Sexp.fromSexp
 instance CPS Lambda where toCPS = Gyehoek.Sexp.fromSexp
 instance CPS Abs where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Program where toCPS = Gyehoek.Sexp.fromSexp
 
 cps :: QuasiQuoter
 cps = Gyehoek.Sexp.makeSx' [| toCPS |]
@@ -234,49 +326,111 @@ 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

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, eval_e2e)
   where
 
 import Gyehoek.Options
@@ -19,7 +19,7 @@ import System.IO (Handle)
 import System.IO qualified as IO
 import Gyehoek.CPS.Convert
 import Gyehoek.CPS.Lower
-import Gyehoek.CPS.Syntax qualified as Cps
+import Gyehoek.CPS.Eval qualified as CPS
 import Control.Monad
 import Text.Pretty.Simple (pShowNoColor)
 import System.Process.Typed
@@ -28,6 +28,16 @@ import System.Environment.Blank (getEnvDefault)
 import GHC.Conc (atomically)
 import qualified Data.Text.IO as TIO
 import qualified Data.ByteString.Lazy as BS
+import Gyehoek.CPS.Stackify (stackifyProgram)
+import Text.Pretty.Simple (pShow)
+import Gyehoek.Stack.VM (eval, writeObj, Obj)
+import qualified Data.Text as T
+import Data.List (List)
+import Gyehoek.Stack.Syntax qualified as Stk
+import Effectful.Exception
+import Gyehoek.CPS.Close (closeProgram)
+import Control.Lens.Extras (is)
+import Control.Arrow ((>>>))
 
 
 main :: IO ()
@@ -91,6 +101,18 @@ inspectWasm wat = do
       IO.hFlush (getStdin pager)
       IO.hClose (getStdin pager)
 
+dumpOrRun
+  :: Monad m
+  => Bool -> Bool
+  -> m a
+  -> (a -> m ()) -> (a -> m ())
+  -> m ()
+dumpOrRun dump run acquire do_dump do_run =
+  when (dump || run) do
+    x <- acquire
+    when dump (do_dump x)
+    when run (do_run x)
+
 driver
   :: (GenSym :> es, FileSystem :> es, IOE :> es)
   => Options -> Eff es ()
@@ -101,20 +123,40 @@ driver opts = do
   cps <- convertProgram scm
   when opts.dumpCPS do
     hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
-  wat <- lowerProgram cps
+  closedCps <- closeProgram cps
-  if not opts.inspectWasm then
+  when opts.dumpClosed do
-    withFile opts.output FS.WriteMode \h ->
+    hPutStrLn FS.stdout $ Sexp.encodePretty closedCps ^?! _Right
-      hPutStrLn h wat
+  let rt_is p = is (_Just . p) opts.runtime
-  else
+  dumpOrRun opts.dumpStackified (rt_is #Stackify)
-    inspectWasm wat
+    (stackifyProgram closedCps)
+    (hPutStrLn FS.stdout . Stk.encodeProgram)
+    (eval >>> fmap writeObj      
+         >>> T.unwords          
+         >>> hPutStrLn FS.stdout)
+  dumpOrRun False (rt_is #CPS)
+    (pure closedCps)
+    (const $ pure ())
+    (CPS.evalProgram >>> fmap writeObj      
+         >>> T.unwords          
+         >>> hPutStrLn FS.stdout)
+  dumpOrRun opts.inspectWasm (rt_is #Wasm)
+    (lowerProgram cps)
+    inspectWasm
+    (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)
 
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runEff . runFileSystem . readScm
 
-convert_e2e :: FilePath -> IO Cps.Program
+convert_e2e :: FilePath -> IO CPS.Program
-convert_e2e = runEff . runFileSystem . runGenSym . (convertProgram <=< readScm)
+convert_e2e = runEff . runFileSystem . runGenSym
+  . (closeProgram <=< convertProgram <=< readScm)
 
 lower_e2e :: FilePath -> IO Text
 lower_e2e =
   runEff . runFileSystem . runGenSym
-  . (lowerProgram <=< convertProgram <=< readScm)
+  . (lowerProgram <=< closeProgram <=< convertProgram <=< readScm)
+
+eval_e2e :: FilePath -> IO (List Obj)
+eval_e2e fp = runEff . runFileSystem . runGenSym $ do
+  stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp
+  pure . eval $ stk

src/Gyehoek/GenSym.hs

@@ -8,7 +8,6 @@ import Effectful.Dispatch.Dynamic
 import Effectful
 import Data.String (IsString(fromString))
 import Data.Text (Text)
-import qualified Data.Text.Short as ST
 
 
 class Gen a where

src/Gyehoek/Options.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE NoFieldSelectors #-}
 module Gyehoek.Options
   ( Options(..)
+  , Runtime(..)
   , parser
   )
   where
@@ -12,13 +13,18 @@ import System.FilePath
 import qualified Data.HashSet as HS
 import Control.Lens hiding (argument)
 import GHC.Generics (Generic)
+import Data.Foldable
 
 
+data Runtime = Stackify | Wasm | CPS
+  deriving (Show, Generic)
+
 data Options = MkOptions
-  { -- dumpANF :: Maybe FilePath
+  { dumpClosed :: Bool
-  -- , dumpQBE :: Maybe FilePath
+  , dumpCPS :: Bool
-  dumpCPS :: Bool
   , dumpParsed :: Bool
+  , dumpStackified :: Bool
+  , runtime :: Maybe Runtime
   , inspectWasm :: Bool
   , output :: FilePath
   , sourceFile :: FilePath
@@ -48,14 +54,32 @@ parseOutput = strOption
     <> value "-"
     )
 
+parseRuntime = option rdr . fold $
+  [ long "runtime"
+  , short 'R'
+  , value Nothing
+  ]
+  where
+    rdr = maybeReader \case
+      "stackify" -> Just (Just Stackify)
+      "wasm" -> Just (Just Wasm)
+      "cps" -> Just (Just CPS)
+      "none" -> Just Nothing
+      _ -> Nothing
+
+parseDumpClosed = switch (long "dump-closed")
 parseDumpCPS = switch (long "dump-cps")
+parseDumpStackified = switch (long "dump-stackified")
 parseDumpParsed = switch (long "dump-parsed")
 parseInspectWasm = switch $ long "inspect-wasm" <> short 'p'
 
 parser :: Parser Options
 parser = MkOptions
-  <$> parseDumpCPS
+  <$> parseDumpClosed
+  <*> parseDumpCPS
   <*> parseDumpParsed
+  <*> parseDumpStackified
+  <*> parseRuntime
   <*> parseInspectWasm
   <*> parseOutput
   <*> argument str (metavar "FILE")

src/Gyehoek/Scheme/Syntax.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -8,12 +9,14 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE OrPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.Scheme.Syntax
   ( Name(..)
   , Prim(..)
   , Lit(..)
   , Def(..)
   , Exp(..)
+  , ExpF(..)
   , Sexp(..)
   , Program(..)
   , CommandOrDef(..)
@@ -23,23 +26,30 @@ module Gyehoek.Scheme.Syntax
   , subst
   , getName
   , scm
+  , readExp
+  , readProgram
+  , free'
+  , freeWithBound'
+  , freeO
+  , encodeProgram
   )
   where
 
 import Data.Text (Text)
-import Data.List (List)
+import Data.List (List, intersperse)
 import Language.SexpGrammar
   ( SexpIso(..), list, el, rest, sym, symbol )
 import Language.SexpGrammar qualified as Sexp
-import Language.Sexp.Located qualified as S
 import Language.SexpGrammar.Generic
-import GHC.Generics
+import Effectful
+import GHC.Generics (Generic)
 import Prelude hiding ((.), id)
 import Control.Category
 import Data.List.NonEmpty (NonEmpty)
-import Gyehoek.Sexp qualified
+import Gyehoek.Sexp qualified as GS
 import Gyehoek.GenSym (Gen)
 import Control.Lens
+import Data.Generics.Labels ()
 import Data.String (IsString)
 import Data.Hashable (Hashable)
 import Data.Data (Data)
@@ -47,13 +57,24 @@ import Data.Functor.Foldable.TH (makeBaseFunctor)
 import Data.Functor.Foldable hiding (fold)
 import Data.HashSet (HashSet)
 import qualified Data.HashSet as HS
-import Data.Foldable (fold)
+import Data.Foldable (fold, toList)
 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
+import Control.DeepSeq (NFData)
+import qualified Data.Set.Ordered as O
+import Data.Sequence (Seq)
 
 
 newtype Name = MkName { inner :: Text }
   deriving newtype (Show, Eq, Ord, IsString, Gen, Hashable)
   deriving stock (Generic, Data)
+  deriving anyclass (Wrapped, NFData)
+
+instance Prefixed Name where
+  prefixed (MkName s) = _Wrapped' . prefixed @Text s . from _Wrapped'
 
 getName :: Name -> Text
 getName (MkName x) = x
@@ -72,7 +93,12 @@ data Prim e
   | PrimWrite e
   | PrimZeroP e
   | PrimNewline
-  deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
+  | PrimMakeClosure { code :: e, env :: List e }
+  | PrimEnvRef e Int
+  | PrimEnvCode e
+  | PrimCallCC e
+  deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
+  deriving anyclass (NFData)
 
 instance Each (Prim e) (Prim e') e e'
 
@@ -82,7 +108,8 @@ data Lit
   | LitBool Bool
   | LitString Text
   | LitQuote Sexp
-  deriving (Show, Generic, Data, Eq)
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
 
 pattern Void :: Lit
 pattern Void = LitNil
@@ -90,10 +117,12 @@ pattern Void = LitNil
 data Def
   = DefConstant Name Exp
   | DefProcedure Name (List Name) (List Exp)
-  deriving (Show, Generic, Data)
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
 
 data Exp
-  = ExpLet (NonEmpty (Name, Exp)) Exp
+  = ExpLet (List (Name, Exp)) Exp
+  | ExpLetRec (List (Name, Exp)) Exp
   | ExpPrim (Prim Exp)
   | ExpBegin (List Exp)
   | ExpIf Exp Exp Exp
@@ -101,24 +130,28 @@ data Exp
   | ExpLambda (List Name) Exp
   | ExpVar Name
   | ExpApply Exp (List Exp)
-  deriving (Show, Generic, Data)
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
 
 data Sexp
   = SexpCons Sexp Sexp
   | SexpSymbol Text
   | SexpLit Lit
-  deriving (Show, Generic, Data, Eq)
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
 
 data CommandOrDef
   = Command Exp
   | Definition Def
   | Begin (List CommandOrDef)
-  deriving (Show, Generic, Data)
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
 
 data Program = MkProgram
   { commandsAndDefs :: List CommandOrDef
   }
-  deriving (Show, Generic, Data)
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
 
 instance Each Program Program (Either Exp Def) (Either Exp Def) where
   each = #commandsAndDefs . each . go
@@ -141,25 +174,30 @@ instance SexpIso Name where
 
 primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
 primSexpIso namefn a = match
-    $ With (. binop "+")
+    $ With (. ht2 "+")
-    $ With (. binop "-")
+    $ With (. ht2 "-")
-    $ With (. binop "*")
+    $ With (. ht2 "*")
-    $ With (. binop "/")
+    $ With (. ht2 "/")
-    $ With (. binop "cons")
+    $ With (. ht2 "cons")
-    $ With (. unop "car")
+    $ With (. ht1 "car")
-    $ With (. unop "cdr")
+    $ With (. ht1 "cdr")
-    $ With (. unop "immediate?")
+    $ With (. ht1 "immediate?")
-    $ With (. unop "cons?")
+    $ With (. ht1 "cons?")
-    $ With (. unop "integer?")
+    $ With (. ht1 "integer?")
-    $ With (. unop "write")
+    $ With (. ht1 "write")
-    $ With (. unop "zero?")
+    $ With (. ht1 "zero?")
     $ With (. nullop "newline")
+    $ With (. ht1' "make-closure")
+    $ With (. GS.headTagged2 (namefn "env-ref") a Sexp.int)
+    $ With (. ht1 "env-code")
+    $ With (. ht1 "call/cc")
     $ End
     where
       idn s = el (sym (namefn s))
       nullop s = list $ idn s
-      unop s = list $ idn s >>> el a
+      ht1 s = GS.headTagged1 (namefn s) a
-      binop s = list $ idn s >>> el a >>> el a
+      ht2 s = GS.headTagged2 (namefn s) a a
+      ht1' s = GS.headTagged1' (namefn s) a a
 
 instance SexpIso a => SexpIso (Prim a) where
   -- sexpIso = primSexpIso ("prim:"<>) sexpIso
@@ -169,23 +207,14 @@ instance SexpIso Lit where
   sexpIso = match
     $ With (. sexpIso)
     $ With (. sym "nil")
-    $ With (. bool)
+    $ With (. GS.schemeBool)
     $ With (. sexpIso)
-    $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
+    $ With (. GS.prefixSugar "quote" Sexp.Quote sexpIso)
     $ End
-    where
-      bool :: Sexp.SexpGrammar Bool
-      bool = Sexp.hashed $ Sexp.partialOsi f g
-        where
-          f (S.Symbol ("t";"true")) = Right True
-          f (S.Symbol ("f";"false")) = Right False
-          f _ = Left $ Sexp.expected "bool"
-          g True = S.Symbol "true"
-          g False = S.Symbol "false"
 
 instance SexpIso Sexp where
   sexpIso = match
-    $ With (\conss -> conss . Gyehoek.Sexp.todo)
+    $ With (\conss -> conss . GS.todo)
     $ With (\s -> s . symbol)
     $ With (\lit -> lit . sexpIso)
     $ End
@@ -202,7 +231,8 @@ instance SexpIso Def where
   
 instance SexpIso Exp where
   sexpIso = match
-    $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
+    $ With (. GS.let_ "let" sexpIso sexpIso sexpIso)
+    $ With (. GS.let_ "letrec" sexpIso sexpIso sexpIso)
     $ With (. sexpIso)
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
     $ With (. if_)
@@ -214,7 +244,7 @@ instance SexpIso Exp where
     where
       if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
       lam = list
-        ( el Gyehoek.Sexp.lambdaKeyword
+        ( el GS.lambdaKeyword
           >>> el (sexpIso @(List Name))
           >>> el sexpIso )
 
@@ -231,7 +261,36 @@ instance SexpIso CommandOrDef where
 -- utilities
 
 scm :: QuasiQuoter
-scm = Gyehoek.Sexp.makeSx [|| Gyehoek.Sexp.fromSexp @Exp ||]
+scm = GS.makeSx [|| GS.fromSexp @Exp ||]
+
+freeWithBound' :: Foldable f => f Name -> Exp -> List Name
+freeWithBound' bound = filter (`elem` bound) . free'
+
+freeO :: Exp -> O.OSet Name
+freeO = O.unbiased . cata \case
+  ExpVarF x -> O.Bias @O.L $ O.singleton x
+  ExpLetF bs e ->
+    foldOf (each . _2) bs
+    <> (e & coerced %~ deleteFromO (bs ^.. each . _1))
+  ExpLetRecF bs e ->
+    (foldOf (each . _2) bs & coerced %~ deleteFromO binds)
+    <> (e & coerced %~ deleteFromO binds)
+    where binds = bs ^.. each . _1
+  ExpLambdaF bs e -> e & coerced %~ deleteFromO bs
+  e -> fold e
+
+free' :: Exp -> List Name
+free' = toList @O.OSet . O.unbiased . cata \case
+  ExpVarF x -> O.Bias @O.L $ O.singleton x
+  ExpLetF bs e ->
+    foldOf (each . _2) bs
+    <> (e & coerced %~ deleteFromO (bs ^.. each . _1))
+  ExpLetRecF bs e ->
+    (foldOf (each . _2) bs & coerced %~ deleteFromO binds)
+    <> (e & coerced %~ deleteFromO binds)
+    where binds = bs ^.. each . _1
+  ExpLambdaF bs e -> e & coerced %~ deleteFromO bs
+  e -> fold e
 
 free :: Exp -> HashSet Name
 free = cata \case
@@ -240,6 +299,9 @@ free = cata \case
   ExpLambdaF binders vs -> deleteFrom binders vs
   e -> fold e
 
+deleteFromO :: (Foldable f, Ord a) => f a -> O.OSet a -> O.OSet a
+deleteFromO = flip $ foldr O.delete
+
 deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
 deleteFrom = flip $ foldr HS.delete
 
@@ -254,3 +316,27 @@ 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 ->
+    GS.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h
+     >>= either error (pure . MkProgram)
+
+readExp :: IOE :> es => FilePath -> Eff es Exp
+readExp fp = readProgram fp <&> (^?! #commandsAndDefs . _head . #Command)
+
+encodeProgram :: Program -> Text
+encodeProgram p = p.commandsAndDefs
+  & fmap ((^?! _Right) . GS.encodePretty)
+  & intersperse "\n\n"
+  & mconcat

src/Gyehoek/Sexp.hs

@@ -25,8 +25,6 @@ module Gyehoek.Sexp
   , lambdaKeyword
   , encodePrettyWith
   , encodePretty
-  , UglySexpIso(..)
-  , AsSexpIso(..)
   , SpliceSexp(..)
   , parseSexpsWithPos
   , parseSexpWithPos
@@ -38,10 +36,17 @@ module Gyehoek.Sexp
   , makeSx'
   , toSexp
   , fromSexp
+  , fromSexp'
   , stripLocation
   , format
   , equivalent
   , encodeOrShow
+  , readSxs
+  , prismIso
+  , schemeBool
+  , headTagged1'
+  , headTagged1
+  , headTagged2
   )
   where
 
@@ -49,44 +54,33 @@ import Data.Text (Text)
 import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp)
 import Language.SexpGrammar qualified as Sexp
 import Language.Sexp qualified as S
-import Language.SexpGrammar.Generic
 import Data.InvertibleGrammar.Base qualified as IGB
 import Data.InvertibleGrammar qualified as IG
 import Data.InvertibleGrammar.Base ((:-)((:-)))
 import Data.List.NonEmpty (NonEmpty ((:|)))
-import Data.List.NonEmpty qualified as NE
 import Data.List (List, groupBy)
 import Data.Text.Encoding
-import Data.Either (either)
 import GHC.Generics (Generic)
 import Control.Lens hiding (para)
-import Data.Generics.Labels
-import System.Process
-import GHC.IO.Unsafe (unsafePerformIO)
-import qualified Data.Text.IO as TIO
 import Control.Monad (join)
 import qualified Language.Sexp.Located as SL
-import Data.Void (absurd, Void)
+import Data.Void (absurd)
-import Data.Coerce (coerce)
-import qualified Data.Map
 import Language.Haskell.TH.Quote
-import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE, Q, Code, unTypeCode)
+import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, Q, Code, unTypeCode)
 import qualified Data.Text as T
 import qualified Control.Category
 import Data.Data (Data (..), Typeable, cast)
 import Language.Haskell.TH.Syntax (lift, Lift, liftData)
-import GHC.IsList (fromList)
+import Data.Functor.Foldable (cata)
-import Data.Functor.Foldable (cata, para, embed)
-import Data.Functor.Classes (Show1(..))
 import Data.Vector (Vector)
 import Numeric.Natural (Natural)
-import Data.Maybe (fromMaybe)
-import Control.Applicative (Alternative((<|>)))
-import Debug.Pretty.Simple
-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 +114,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 +138,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)
@@ -154,23 +170,18 @@ let_
   :: Text
   -> (forall t. Grammar Position (Sexp :- t) (a :- t))
   -> (forall t. Grammar Position (Sexp :- t) (b :- t))
-  -> Grammar Position (Sexp :- (NonEmpty (a, b) :- t1)) t2
+  -> Grammar Position (Sexp :- (List (a, b) :- t1)) t2
   -> Grammar Position (Sexp :- t1) t2
 let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e)
   where
     -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
-    bindings = nonempty binding
+    bindings = list $ rest binding
     binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
     binding = list (el name >>> el rhs) >>> pair
 
 data DotList a = MkDotList (NonEmpty a) a
   deriving (Show, Generic)
 
-dotlist :: (forall t. Grammar Position (Sexp :- t) (a :- t)) -> _
-dotlist x = list $ rest $ coproduct
-  [ x >>> _
-  ]
-
 -- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩.
 prefixSugar
   :: Text -> Prefix
@@ -184,7 +195,7 @@ prefixSugar name prefix e = coproduct
   ]
 
 todo :: Grammar p (Sexp :- t) t'
-todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
+todo = IGB.Flip (IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
   where
     f _ = Left $ unexpected "todo"
     g _ = Left $ unexpected "todo"
@@ -210,39 +221,43 @@ lambda name e = list $
 isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
 isoIso l = Sexp.iso (view l) (review l)
 
+prismIso :: Mismatch -> Prism' s a -> Grammar p (s :- t) (a :- t)
+prismIso mm p = Sexp.partialOsi
+  (maybe (Left mm) Right . preview p)
+  (review p)
+
 kappaKeyword :: Grammar Position (Sexp :- t) t
 kappaKeyword = coproduct [ sym "κ", sym "kappa" ]
 
 lambdaKeyword :: Grammar Position (Sexp :- t) t
 lambdaKeyword = coproduct [ sym "λ", sym "lambda" ]
 
+schemeBool :: SexpGrammar Bool
+schemeBool = Sexp.hashed $ Sexp.partialOsi f g
+  where
+    f (SL.Symbol ("t";"true")) = Right True
+    f (SL.Symbol ("f";"false")) = Right False
+    f _ = Left $ Sexp.expected "bool"
+    g True = SL.Symbol "true"
+    g False = SL.Symbol "false"
+
+headTagged1 :: Text -> SexpGrammar a -> Grammar Position (Sexp :- t) (a :- t)
+headTagged1 s g1 = list $ el (sym s) >>> el g1
+
+headTagged1'
+  :: Text
+  -> SexpGrammar a -> SexpGrammar b
+  -> Grammar Position (Sexp :- t) (List b :- a :- t)
+headTagged1' s g1 gt = list $ el (sym s) >>> el g1 >>> rest gt
+
+headTagged2
+  :: Text
+  -> SexpGrammar a -> SexpGrammar b
+  -> Grammar Position (Sexp :- t) (b :- a :- t)
+headTagged2 s g1 g2 = list $ el (sym s) >>> el g1 >>> el g2
+
 
 
-class UglySexpIso a where
-  uglySexpIso :: SexpGrammar a
-
-newtype AsSexpIso a = AsSexpIso a
-newtype AsUglySexpIso a = AsUglySexpIso a
-
-asSexpIso :: Grammar p (a :- t) (AsSexpIso a :- t)
-asSexpIso = Sexp.iso AsSexpIso (\(AsSexpIso x) -> x)
-
-instance UglySexpIso a => SexpIso (AsUglySexpIso a) where
-  sexpIso = uglySexpIso @a >>> Sexp.iso coerce coerce
-
-instance SexpIso a => UglySexpIso (AsSexpIso a) where
-  uglySexpIso = sexpIso >>> Sexp.iso (\x -> AsSexpIso x) (\(AsSexpIso x) -> x)
-
--- why not work
--- deriving via AsSexpIso Text instance UglySexpIso Text
-
-instance UglySexpIso Text where uglySexpIso = sexpIso
-instance UglySexpIso Integer where uglySexpIso = sexpIso
-instance UglySexpIso Int where uglySexpIso = sexpIso
-instance UglySexpIso Bool where uglySexpIso = sexpIso
-instance UglySexpIso Double where uglySexpIso = sexpIso
-instance UglySexpIso () where uglySexpIso = sexpIso
-
 instance SexpIso Sexp where
   sexpIso = Control.Category.id
 
@@ -272,8 +287,11 @@ toSexp = either error id . Sexp.toSexp sexpIso
 toSexps :: (Foldable f, SexpIso a) => f a -> List Sexp
 toSexps = foldMap \x -> [toSexp x]
 
+pattern Unquote :: Text -> Sexp
 pattern Unquote x =
   SL.Modified Hash (SL.BraceList [SL.Symbol x])
+
+pattern UnquoteSplicing :: Text -> Sexp
 pattern UnquoteSplicing x =
   SL.Modified Hash (SL.Modified Hash (SL.BraceList [SL.Symbol x]))
 
@@ -286,6 +304,7 @@ instance Each Sexp Sexp Sexp Sexp where
   each k (SL.ParenList xs)              = SL.ParenList <$> traverse k xs
   each k (SL.BracketList xs)            = SL.BracketList <$> traverse k xs
   each k (SL.BraceList xs)              = SL.BraceList <$> traverse k xs
+  -- each k (SL.Modified m e)   = SL.Modified m <$> each k e
   each _ e@(SL.Atom _; SL.Modified _ _) = pure e
 
 stripLocation :: Sexp -> Sexp
@@ -330,10 +349,6 @@ unquoteSplicingRecursive xs = [| mconcat $(spans) |]
           _ (UnquoteSplicing _) -> False
           _ _                   -> True
       & fmap \case
-        -- [e@(Unquote _)] ->
-        --   case unquote e of
-        --     Just x -> [| [$(x)] |]
-        --     Nothing -> error "unreachable"
         [UnquoteSplicing x] ->
           [| spliceSexp $(varE (mkName (T.unpack x))) |]
         es -> listE $ unquoteRecursive <$> es

src/Gyehoek/Stack/Syntax.hs

@@ -0,0 +1,128 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveAnyClass #-}
+module Gyehoek.Stack.Syntax
+  ( Program(..)
+  , Block(..)
+  , Instr(..)
+  , Val(..)
+  , Lit(..)
+  , Obj(..)
+  , Imm(..)
+  , Hob(..)
+  , Prim(..)
+  , Name
+  , pattern ValLabel
+  , encodeProgram
+  ) 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(..))
+import GHC.Exts (IsList(..))
+import Data.List (intersperse)
+import Control.DeepSeq (NFData)
+import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName)
+
+
+newtype Program = MkProgram
+  { blocks :: List Block
+  }
+  deriving stock (Show, Generic, Data)
+  deriving newtype (Semigroup, Monoid)
+  deriving anyclass (NFData)
+
+instance IsList Program where
+  type Item Program = Block
+  fromList = MkProgram
+  toList = view #blocks
+
+data Block = MkBlock
+  { label :: Name
+  , params :: List Name
+  , code :: List Instr
+  }
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+instance Each Block Block Instr Instr where
+  each = #code . each
+
+data Instr
+  = Pop Name
+  | Push Val
+  | PopCont Name
+  | PushCont Val
+  | Prim Name (Prim Val)
+  | Call Val (List Val)
+  | If Val (List Instr) (List Instr)
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Val
+  = ValReg Name
+  | ValImm Imm
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
+
+pattern ValLabel :: Name -> Val
+pattern ValLabel x = ValImm (ImmLabel x)
+
+
+--- sexp work
+
+pure []
+
+instance SexpIso Instr where
+  sexpIso = match
+    $ With (Gyehoek.Sexp.headTagged1 "pop!" regName >>>)
+    $ With (Gyehoek.Sexp.headTagged1 "push!" S.sexpIso >>>)
+    $ With (Gyehoek.Sexp.headTagged1 "pop-cont!" regName >>>)
+    $ With (Gyehoek.Sexp.headTagged1 "push-cont!" S.sexpIso >>>)
+    $ With (Gyehoek.Sexp.headTagged2 "prim" regName S.sexpIso >>>)
+    $ With (Gyehoek.Sexp.headTagged1' "call" S.sexpIso S.sexpIso >>>)
+    $ With (if_ >>>)
+    $ End
+    where
+      if_ = S.list $ S.el (S.sym "if")
+        >>> S.el (S.sexpIso @Val)
+        >>> S.el (S.list $ S.el (S.sym "then") >>> S.rest (S.sexpIso @Instr))
+        >>> S.el (S.list $ S.el (S.sym "else") >>> S.rest (S.sexpIso @Instr))
+
+instance SexpIso Val where
+  sexpIso = match
+    $ With (regName >>>)
+    $ With (S.sexpIso >>>)
+    $ End
+
+instance SexpIso Block where
+  sexpIso = with (block >>>)
+    where
+      block = S.list $
+        S.el (S.sym "define")
+        >>> S.el (S.list $ S.el labelName >>> S.rest regName)
+        >>> S.rest (S.sexpIso @Instr)
+
+encodeProgram :: Program -> Text
+encodeProgram p = p.blocks
+  & fmap ((^?! _Right) . Gyehoek.Sexp.encodePretty)
+  & intersperse "\n\n"
+  & mconcat
+
+regName :: S.SexpGrammar Name
+regName = S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
+  (S.expected "register")
+  (prefixed @Name "%")

src/Gyehoek/Stack/VM.hs

@@ -0,0 +1,157 @@
+{-# LANGUAGE ViewPatterns #-}
+module Gyehoek.Stack.VM
+  ( VM(..)
+  , Env(..)
+  , eval
+  , trace
+  , module Gyehoek.Stack.Syntax
+  , writeObj
+  ) 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(..))
+import Debug.Pretty.Simple (pTraceShowIdForceColor)
+import qualified Data.List.NonEmpty as NE
+import Data.Functor (($>))
+import Data.List (unfoldr)
+
+
+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 %~ (evalToLabel e vm 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
+  PrimMakeClosure f env ->
+    case f of
+      ObjImm (ImmLabel l) -> ret . ObjHob $ HobClosure l env
+      _ -> error [i|expected label, got #{f}|]
+  PrimEnvCode env ->
+    case env of
+      ObjHob (HobClosure l _) -> ret . ObjImm . ImmLabel $ l
+      _ -> error [i|expected closure, got #{env}|]
+  PrimEnvRef env n ->
+    case env of
+      ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n
+      _ -> error [i|expected closure, got #{env}|]
+  x -> error [i|unimplemented prim: #{p}|]
+  where
+    ret v = vm & #registers . at r ?~ v
+    arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt 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
+  [] -> error "empty stack"
+  (x:xs) -> vm & #registers . at r ?~ x
+               & #stack .~ xs
+
+stepI e vm ins@(PopCont r) = case vm ^. #kstack of
+  [] -> error [i|empty cont stack: #{ins}|]
+  (x:xs) -> vm & #registers . at r ?~ ObjImm (ImmLabel x)
+               & #kstack .~ xs
+
+stepI e vm (Call v xs) =
+  case evalToLabel e vm v of
+    "halt" -> vm & #result ?~ fmap (evalVal e vm) xs
+    l -> 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 (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}|]
+
+evalToLabel e vm v =
+  case evalVal e vm v of
+    ObjImm (ImmLabel x) -> x
+    x -> error [i|not a label: #{x}|]
+
+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 = [Call (ValImm $ ImmLabel "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
+
+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
+
+writeObj :: Obj -> Text
+writeObj (ObjImm im) = case im of
+  ImmInt n -> [i|#{n}|]
+  ImmBool True -> "#t"
+  ImmBool False -> "#f"
+  ImmLabel l -> "#<procedure>"
+writeObj (ObjHob h) = case h of
+  HobClosure code env -> "#<procedure>"

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/Eval.hs

@@ -0,0 +1,56 @@
+module Gyehoek.Test.CPS.Eval (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Language.SexpGrammar ()
+import Gyehoek.CPS.Syntax (cps, Obj(..), Hob(..), Imm(..))
+import Gyehoek.CPS.Eval qualified as Sut
+import Data.List (List)
+
+
+root :: IO TestTree
+root = pure . testGroup "cps interpreter" $
+  [ prim
+  , testCase "halt with constant" do
+      evalsTo [ObjImm (ImmInt 123)] [cps|
+        (continue halt 123)
+      |]
+  , testCase "identity cont" do
+      evalsTo [ObjImm (ImmInt 154)] [cps|
+        (letrec ((id (κ (x)
+                       (continue halt x))))
+          (continue id 154))
+      |]
+  , testCase "identity function" do
+      evalsTo [ObjImm (ImmInt 456)] [cps|
+        (letrec ((id (λ (x ktail)
+                       (continue ktail x))))
+          (id 456 halt))
+      |]
+  , testCase "square" do
+      evalsTo [ObjImm (ImmInt 81)] [cps|
+        (letrec ((square (λ (x ktail)
+                           (prim (* x x)
+                             (κ (r) (continue ktail r))))))
+          (square 9 halt))
+      |]
+  ]
+
+evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
+evalsTo rs p = Sut.evalProgram p @?= rs
+
+prim = testGroup "primitives"
+  [ testGroup "arith"
+    [ testCase "basic 1" do
+        evalsTo [ObjImm (ImmInt 20)] [cps|
+          (prim (* 4 5)
+            (κ (x) (continue halt x)))
+          |]
+    , testCase "basic 2" do
+        evalsTo [ObjImm (ImmInt 35)] [cps|
+          (prim (* 2 16)
+            (κ (x) (prim (+ x 3)
+                      (κ (r) (continue halt r)))))
+          |]
+    ]
+  ]

test/Gyehoek/Test/CPS/Stackify.hs

@@ -0,0 +1,87 @@
+module Gyehoek.Test.CPS.Stackify (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import qualified Gyehoek.CPS.Stackify as Sut
+import Gyehoek.Stack.VM as Stk
+import Data.List (List)
+import Gyehoek.CPS.Syntax (cps)
+import Gyehoek.GenSym (runGenSym)
+import Effectful
+
+
+root :: IO TestTree
+root = pure . testGroup "stackify" $
+  [ trivialReturn
+  , tailCall
+  , prim
+  , condition
+  , procedure
+  ]
+
+evalsTo :: List Obj -> Sut.Exp -> Assertion
+evalsTo rs e =
+  Stk.eval e' @?= rs
+  where e' = runPureEff . runGenSym $ Sut.stackifyExp "main" e
+
+trivialReturn = testGroup "trivial return"
+  [ testCase "return int" do
+      evalsTo [ObjImm (ImmInt 4)]
+        [cps|(continue halt 4)|]
+  , testCase "return bool" do
+      evalsTo [ObjImm (ImmBool True)]
+        [cps|(continue halt #t)|]
+      evalsTo [ObjImm (ImmBool False)]
+        [cps|(continue halt #f)|]
+  ]
+
+tailCall = testGroup "tail call"
+  [ testCase "square" do
+      evalsTo [ObjImm (ImmInt 16)]
+        [cps|(letrec ((square (λ (x ktail)
+                                (prim (* x x)
+                                  (κ (x0) (continue ktail x0))))))
+               (square 4 halt))|]
+  ]
+
+prim = testGroup "prim"
+  [ testCase "multiply" do
+      evalsTo [ObjImm (ImmInt 20)]
+        [cps|(prim (* 4 5)
+               (κ (x) (continue halt x)))|]
+  , testCase "add" do
+      evalsTo [ObjImm (ImmInt 9)]
+        [cps|(prim (+ 4 5)
+               (κ (x) (continue halt x)))|]
+  -- , testGroup "call/cc"
+  --   [ testCase "trivial" do
+  --       evalsTo [ObjImm (ImmInt 123)]
+  --         [cps|(letrec ((f (λ (cc ktail) (continue cc 123))))
+  --                (prim (call/cc f)))|]
+  --   ]
+  ]
+
+condition = testCase "if" do
+  evalsTo [ObjImm (ImmInt 123)]
+    [cps|(if #t (continue halt 123) (continue halt 456))|]
+  evalsTo [ObjImm (ImmInt 456)]
+    [cps|(if #f (continue halt 123) (continue halt 456))|]
+
+procedure = testGroup "procedure"
+  [ testCase "factorial" do
+      evalsTo [ObjImm (ImmInt 720)]
+        [cps|(letrec ((fac (λ (n ktail)
+                             (prim (zero? n)
+                               (κ (x0)
+                                 (if x0
+                                   (continue ktail 1)
+                                   (prim (- n 1)
+                                     (κ (x1)
+                                       (letrec ((fac-k0
+                                                  (κ (x2)
+                                                    (prim (* n x2)
+                                                      (κ (x3)
+                                                        (continue ktail x3))))))
+                                         (fac x1 fac-k0))))))))))
+               (fac 6 halt))|]
+  ]

test/Gyehoek/Test/CPS/Syntax.hs

@@ -3,12 +3,9 @@ module Gyehoek.Test.CPS.Syntax (root) where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
-import Language.Sexp.Located qualified as SL
 import Language.SexpGrammar ()
 import Gyehoek.CPS.Syntax (cps)
 import Gyehoek.CPS.Syntax qualified as Sut
-import Data.Function (on)
-import Gyehoek.Test.Sexp (equivto)
 
 
 root :: IO TestTree
@@ -18,15 +15,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/Golden.hs

@@ -10,35 +10,72 @@ import System.Directory
 import Data.Function
 import System.Environment.Blank (getEnvDefault)
 import qualified System.Process.Text as PT
+import Control.Exception (SomeException (SomeException), Exception (..), catch)
+import Gyehoek.Stack.VM (writeObj)
+import Data.Text qualified as T
+import System.Exit (ExitCode(..))
+import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
+import Control.DeepSeq (($!!))
 
 
-disabled :: List String
+brokenWasmTests :: List String
-disabled =
+brokenWasmTests =
   [
   ]
 
+brokenStackifyTests :: List String
+brokenStackifyTests =
+  []
+  -- [ "adder"
+  -- , "let-fn"
+  -- , "callcc-nested1" -- requires closure-conversion
+  -- ]
+
 root :: IO TestTree
 root = do
   all_cases <- listDirectory "golden"
   let tests = all_cases
-            & filter (`notElem` disabled)
             & fmap ("golden"</>)
   testGroup "golden" <$> sequenceA
-    [ executionTests tests
+    [ ignoreTestBecause "wasm codegen is on the backburner"
+      <$> wasmTests tests
+    , stackifyTests tests
     ]
 
-executionTests :: List FilePath -> IO TestTree
+maybeBroken name broken = applyWhen (name `elem` broken) expectFail
-executionTests files = do
+wasmTests :: List FilePath -> IO TestTree
+wasmTests files = do
   cmd <- getEnvDefault "GYEHOEK_RUNTIME"
     "runtime/target/debug/gyehoek-runtime"
-  pure $ testGroup "execution" $ files <&> \test ->
+  pure $ testGroup "wasm execution" $ files <&> \test ->
     let testname = takeFileName test
         scmfile = test </> "source.scm"
         resultfile = test </> "exec"
         action = do
           t <- Driver.lower_e2e scmfile
           PT.readProcessWithExitCode cmd ["-"] t
-    in goldenVsAction
+    in maybeBroken testname brokenWasmTests $
+      goldenVsAction
+       testname
+       resultfile
+       action
+       printProcResult
+
+stackifyTests :: List FilePath -> IO TestTree
+stackifyTests files = do
+  pure $ testGroup "stackified execution" $ files <&> \test ->
+    let testname = takeFileName test
+        scmfile = test </> "source.scm"
+        resultfile = test </> "exec"
+        action =
+          catch @SomeException
+            (do rs <- Driver.eval_e2e scmfile
+                pure $!! ( ExitSuccess
+                     , T.unwords . fmap writeObj $ rs
+                     , "" ))
+            \e -> pure (ExitFailure 1, "", T.pack $ displayException e)
+    in maybeBroken testname brokenStackifyTests $
+     goldenVsAction
        testname
        resultfile
        action

test/Gyehoek/Test/Scheme/Syntax.hs

@@ -0,0 +1,27 @@
+module Gyehoek.Test.Scheme.Syntax (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Language.SexpGrammar ()
+import Gyehoek.Scheme.Syntax (scm)
+import Gyehoek.Scheme.Syntax qualified as Sut
+
+
+root :: IO TestTree
+root = pure . testGroup "scheme syntax" $
+  [ freeTree
+  ]
+
+freeTree :: TestTree
+freeTree = testGroup "free"
+  [ testCase "lambda" do
+    Sut.free' [scm|
+      (lambda (x y z k) (f x b a))
+    |] @=? ["f","b","a"]
+  , testCase "exp" do
+    Sut.free' [scm|
+      (letrec ((x (lambda (r) (f a y)))
+               (y (lambda (r b) (f b x))))
+        (g x y z))
+    |] @=? ["f","a","g","z"]
+  ]

test/Gyehoek/Test/Stack/VM.hs

@@ -0,0 +1,117 @@
+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)
+
+
+root :: IO TestTree
+root = pure . testGroup "stack machine" $
+  [ lit_int
+  , procedure
+  , prims
+  ]
+
+
+
+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"
+      , Call (ValReg "ktail") [ValImm (ImmInt 3)]
+      ]
+    ]
+
+procedure = testGroup "procedure"
+  [ testCase "return constant" do
+      evalsTo [ObjImm (ImmInt 123)]
+        [ MkBlock "main" []
+          [ Call (ValLabel "silly") []
+          ]
+        , MkBlock "silly" []
+          [ PopCont "ktail"
+          , Call (ValReg "ktail") [ValImm (ImmInt 123)]
+          ]
+        ]
+  , testCase "identity function" do
+      evalsTo [ObjImm (ImmInt 45)]
+        [ MkBlock "main" []
+          [ Call (ValLabel "id") [ValImm (ImmInt 45)]
+          ]
+        , MkBlock "id" ["x"]
+          [ PopCont "ktail"
+          , Call (ValReg "ktail") [ValReg "x"]
+          ]
+        ]
+  , testCase "square" do
+      evalsTo [ObjImm (ImmInt 16)]
+        [ MkBlock "main" []
+          [ Call (ValLabel "square") [ValImm (ImmInt 4)]
+          ]
+        , MkBlock "square" ["x"]
+          [ PopCont "ktail"
+          , Prim "x2" $ PrimMul (ValReg "x") (ValReg "x")
+          , Call (ValReg "ktail") [ValReg "x2"]
+          ]
+        ]
+  , testCase "factorial" do
+      let fac n =
+            [ MkBlock "fac" ["n"]
+              [ Prim "x0" $ PrimZeroP (ValReg "n")
+              , If (ValReg "x0")
+                [ PopCont "ktail"
+                , Call (ValReg "ktail") [ValImm (ImmInt 1)]
+                ]
+                [ Push (ValReg "n")
+                , Prim "x1" $ PrimSub (ValReg "n") (ValImm (ImmInt 1))
+                , PushCont (ValLabel "fac-k0")
+                , Call (ValLabel "fac") [ValReg "x1"]
+                ]
+              ]
+            , MkBlock "fac-k0" ["x2"]
+              [ Pop "n"
+              , Prim "x3" $ PrimMul (ValReg "x2") (ValReg "n")
+              , PopCont "ktail"
+              , Call (ValReg "ktail") [ValReg "x3"]
+              ]
+            , MkBlock "main" []
+              [ Call (ValLabel "fac") [ValImm (ImmInt n)]
+              ]
+            ]
+      evalsTo [ObjImm (ImmInt 1)] $ fac 0
+      evalsTo [ObjImm (ImmInt 720)] $ fac 6
+  ]
+
+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
+    , Call (ValReg "ktail") [ValReg "x1"]
+    ]
+  ]
+
+arith = testGroup "arith"
+  [ testCase "multipy" do
+      trivialPrimTest [ObjImm (ImmInt 12)]
+        (PrimMul (ValImm $ ImmInt 3) (ValImm $ ImmInt 4))
+  , testCase "subtract" do
+      trivialPrimTest [ObjImm (ImmInt 14)]
+        (PrimSub (ValImm $ ImmInt 20) (ValImm $ ImmInt 6))
+  ]

test/Main.hs

@@ -5,6 +5,10 @@ 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.Scheme.Syntax
+import qualified Gyehoek.Test.Stack.VM
+import qualified Gyehoek.Test.CPS.Stackify
+import qualified Gyehoek.Test.CPS.Eval
 
 
 main :: IO ()
@@ -15,5 +19,9 @@ root = testGroup "test" <$> sequenceA
   [ Gyehoek.Test.Golden.root
   , Gyehoek.Test.Sexp.root
   , Gyehoek.Test.CPS.Syntax.root
+  , Gyehoek.Test.Scheme.Syntax.root
+  , Gyehoek.Test.Stack.VM.root
+  , Gyehoek.Test.CPS.Stackify.root
+  , Gyehoek.Test.CPS.Eval.root
   ]