.dir-locals.el

@@ -1,7 +1,16 @@
-((haskell-cabal-mode
+((haskell-mode
+  . ((eval
+      . (progn (add-to-list 'haskell-font-lock-quasi-quote-modes
+                            '("cps" . scheme-mode))
+               (add-to-list 'haskell-font-lock-quasi-quote-modes
+                            '("scm" . scheme-mode))))))
+ (haskell-cabal-mode
   . ((eval
       . (progn (defun apply-cabal-fmt-h ()
                  (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)))))))
+               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)))))
+ (nil
+  . ((eval
+      . (progn (defun display-ansi ()
+                 (interactive)
+                 (ansi-color-apply-on-region (point-min) (point-max))))))))

.envrc

@@ -1 +1,3 @@
 use flake
+watch_file gyehoek.cabal cabal.project
+PATH_add $(dirname $(cabal list-bin gyehoek))

README.md

@@ -1,3 +1,3 @@
-# gyehoek-hs (계획)
+# 계획
 
-a (wip) toy compiler for a Scheme-like language. currently targetting [QBE](https://c9x.me/compile/). nabbing from GHC and GNU Guile.
+a WIP compiler for R⁷RS Scheme targeting WebAssembly.

cabal.project

@@ -1,5 +1,10 @@
 packages: *.cabal
 tests: True
+-- required for doctest-parallel
+write-ghc-environment-files: always
+
+-- https://github.com/martijnbastiaan/doctest-parallel/pull/66
+allow-older: Cabal:process 
 
 source-repository-package
     type: git

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.

flake.nix

@@ -20,13 +20,13 @@
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          shake-wrapper = final.callPackage ./shake-wrapper.nix {};
-          gyehoek-runtime = final.callPackage ./runtime {
+          gyehoek-wasm-runtime = final.callPackage ./wasm-runtime {
             crane-lib = inputs.crane.mkLib final;
           };
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
+            configureArgs = "-f-doctest";
             modules = [({ pkgs, lib, ...}: {
               packages.gyehoek.components.tests.test.preCheck =
                 let
@@ -34,14 +34,16 @@
                     pkgs.git # tasty uses git diff
                   ];
                 in ''
-                  export GYEHOEK_RUNTIME=${lib.getExe final.gyehoek-runtime}
+                  export GYEHOEK_WASM_RUNTIME=${
+                    lib.getExe final.gyehoek-wasm-runtime
+                  }
                   export PATH=${lib.makeBinPath bin}:$PATH
                 '';
             })];
             shell = {
               withHoogle = true;
               inputsFrom = [
-                final.gyehoek-runtime
+                final.gyehoek-wasm-runtime
               ];
               tools = {
                 cabal = {};
@@ -49,7 +51,6 @@
               };
               buildInputs = with final; [
                 haskellPackages.cabal-fmt
-                shake-wrapper
                 wabt
                 nodejs
                 wasm-tools
@@ -57,6 +58,11 @@
                 guile
                 rust-analyzer
                 wasmtime
+                # bashInteractive is necessary to work around an
+                # optparse-applicative issue
+                #
+                # https://github.com/pcapriotti/optparse-applicative/pull/408
+                bashInteractive
               ];
             };
           };
@@ -88,7 +94,7 @@
         hf.packages.${system} // lib.fix (packages: {
           gyehoek = hf.packages.${system}."gyehoek:exe:gyehoek";
           default = packages.gyehoek;
-          inherit (pkgs) gyehoek-runtime shake-wrapper;
+          inherit (pkgs) gyehoek-wasm-runtime;
         }));
 
       devShells = each-system

golden/exec/adder/exec

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

golden/exec/adder/source.scm

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

golden/exec/apply-twice/exec

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

golden/exec/apply2/exec

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

golden/exec/apply2/source.scm

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

golden/exec/callcc-constant/exec

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

golden/exec/callcc-constant/source.scm

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

golden/exec/callcc-discard/exec

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

golden/exec/callcc-discard/source.scm

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

golden/exec/callcc-nested1/exec

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

golden/exec/callcc-nested1/source.scm

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

golden/exec/callcc-nested2/exec

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

golden/exec/callcc-nested2/source.scm

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

golden/exec/factorial/exec

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

golden/exec/factorial/source.scm

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

golden/exec/fn-of-fn/source.scm

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

golden/exec/let-fn/exec

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

golden/exec/let-fn/source.scm

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

golden/exec/letrec-fn/exec

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

golden/exec/letrec-fn/source.scm

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

golden/fn-of-fn/source.scm

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

golden/print/begin-nonempty-thin

@@ -0,0 +1,4 @@
+(begin
+  책을
+  더
+  먹으세요~!)

golden/print/begin-nonempty-wide

@@ -0,0 +1,4 @@
+(begin
+  책을
+  더
+  먹으세요~!)

golden/print/lambda-thin

@@ -0,0 +1,5 @@
+(lambda
+    (어간
+     어미)
+  (display
+   꾸깃))

golden/print/lambda-wide

@@ -0,0 +1,2 @@
+(lambda (어간 어미)
+  (display 꾸깃))

golden/print/null

@@ -0,0 +1 @@
+()

golden/print/rainbow

@@ -0,0 +1 @@
+((((()))))

golden/print/simple-list-thin

@@ -0,0 +1,4 @@
+(가
+ 나
+ 다
+ 라)

golden/print/simple-list-wide

@@ -0,0 +1 @@
+(가 나 다 라)

golden/read/bool/read

@@ -0,0 +1,41 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/bool/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF ( SimpleBoolean True )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/bool/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 4
+            }
+        )
+    } :< SimpleF ( SimpleBoolean True )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/bool/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 10
+            }
+        )
+    } :< SimpleF ( SimpleBoolean False )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/bool/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 13
+            }
+        )
+    } :< SimpleF ( SimpleBoolean False )
+]

golden/read/bool/source.scm

@@ -0,0 +1 @@
+#t #true #f #false

golden/read/datum-comment/source.scm

@@ -0,0 +1,4 @@
+#;(a datum comment can
+span multiple lines)
+
+(but it ends here)

golden/read/decimal/read

@@ -0,0 +1,36 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/decimal/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleNumber 45.0 )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/decimal/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 4
+            }
+        )
+    } :< SimpleF
+    ( SimpleNumber 5667.0 )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/decimal/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 10
+            }
+        )
+    } :< SimpleF
+    ( SimpleNumber
+        ( -123.0 )
+    )
+]

golden/read/decimal/source.scm

@@ -0,0 +1 @@
+45 +5667 -123

golden/read/delimited-identifier/read

@@ -0,0 +1,5 @@
+[ Fix
+    ( SimpleF
+        ( Symbol "aaaa bc" )
+    )
+]

golden/read/delimited-identifier/source.scm

@@ -0,0 +1 @@
+|aaaa bc|

golden/read/empty/read

@@ -0,0 +1 @@
+[]

golden/read/list-dot-flat/read

@@ -0,0 +1,62 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/list-dot-flat/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< CompoundF
+    ( DotListF
+        (
+            ( MkAnn
+                { syntax = SynNone
+                , position = Just
+                    ( SourcePos
+                        { sourceName = "golden/read/list-dot-flat/source.scm"
+                        , sourceLine = Pos 1
+                        , sourceColumn = Pos 2
+                        }
+                    )
+                } :< SimpleF
+                ( SimpleSymbol "가" )
+            ) :|
+            [ MkAnn
+                { syntax = SynNone
+                , position = Just
+                    ( SourcePos
+                        { sourceName = "golden/read/list-dot-flat/source.scm"
+                        , sourceLine = Pos 1
+                        , sourceColumn = Pos 5
+                        }
+                    )
+                } :< SimpleF
+                ( SimpleSymbol "나" )
+            , MkAnn
+                { syntax = SynNone
+                , position = Just
+                    ( SourcePos
+                        { sourceName = "golden/read/list-dot-flat/source.scm"
+                        , sourceLine = Pos 1
+                        , sourceColumn = Pos 8
+                        }
+                    )
+                } :< SimpleF
+                ( SimpleSymbol "다" )
+            ]
+        )
+        ( MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-dot-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 13
+                    }
+                )
+            } :< SimpleF
+            ( SimpleSymbol "라" )
+        )
+    )
+]

golden/read/list-dot-flat/source.scm

@@ -0,0 +1 @@
+(가 나 다 . 라)

golden/read/list-flat/read

@@ -0,0 +1,91 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/list-flat/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< CompoundF
+    ( ListF Ordinary
+        [ MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 2
+                    }
+                )
+            } :< SimpleF
+            ( SimpleSymbol "가" )
+        , MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 5
+                    }
+                )
+            } :< SimpleF
+            ( SimpleSymbol "나" )
+        , MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 8
+                    }
+                )
+            } :< SimpleF
+            ( SimpleSymbol "다" )
+        , MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 11
+                    }
+                )
+            } :< SimpleF
+            ( SimpleSymbol "라" )
+        , MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 14
+                    }
+                )
+            } :< SimpleF
+            ( SimpleNumber 1.0 )
+        , MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 16
+                    }
+                )
+            } :< SimpleF
+            ( SimpleNumber 2.0 )
+        , MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 18
+                    }
+                )
+            } :< SimpleF
+            ( SimpleNumber 3.0 )
+        ]
+    )
+]

golden/read/list-flat/source.scm

@@ -0,0 +1 @@
+(가 나 다 라 1 2 3)

golden/read/list/read

@@ -0,0 +1,148 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/list/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< CompoundF
+    ( DotListF
+        (
+            ( MkAnn
+                { syntax = SynNone
+                , position = Just
+                    ( SourcePos
+                        { sourceName = "golden/read/list/source.scm"
+                        , sourceLine = Pos 1
+                        , sourceColumn = Pos 2
+                        }
+                    )
+                } :< SimpleF
+                ( SimpleSymbol "a" )
+            ) :|
+            [ MkAnn
+                { syntax = SynNone
+                , position = Just
+                    ( SourcePos
+                        { sourceName = "golden/read/list/source.scm"
+                        , sourceLine = Pos 1
+                        , sourceColumn = Pos 4
+                        }
+                    )
+                } :< SimpleF
+                ( SimpleSymbol "b" )
+            , MkAnn
+                { syntax = SynNone
+                , position = Just
+                    ( SourcePos
+                        { sourceName = "golden/read/list/source.scm"
+                        , sourceLine = Pos 1
+                        , sourceColumn = Pos 6
+                        }
+                    )
+                } :< CompoundF
+                ( ListF Ordinary
+                    [ MkAnn
+                        { syntax = SynNone
+                        , position = Just
+                            ( SourcePos
+                                { sourceName = "golden/read/list/source.scm"
+                                , sourceLine = Pos 1
+                                , sourceColumn = Pos 7
+                                }
+                            )
+                        } :< SimpleF
+                        ( SimpleSymbol "c" )
+                    , MkAnn
+                        { syntax = SynNone
+                        , position = Just
+                            ( SourcePos
+                                { sourceName = "golden/read/list/source.scm"
+                                , sourceLine = Pos 1
+                                , sourceColumn = Pos 9
+                                }
+                            )
+                        } :< SimpleF
+                        ( SimpleSymbol "d" )
+                    ]
+                )
+            ]
+        )
+        ( MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 14
+                    }
+                )
+            } :< CompoundF
+            ( ListF Ordinary
+                [ MkAnn
+                    { syntax = SynNone
+                    , position = Just
+                        ( SourcePos
+                            { sourceName = "golden/read/list/source.scm"
+                            , sourceLine = Pos 1
+                            , sourceColumn = Pos 15
+                            }
+                        )
+                    } :< SimpleF
+                    ( SimpleSymbol "가" )
+                , MkAnn
+                    { syntax = SynNone
+                    , position = Just
+                        ( SourcePos
+                            { sourceName = "golden/read/list/source.scm"
+                            , sourceLine = Pos 1
+                            , sourceColumn = Pos 18
+                            }
+                        )
+                    } :< CompoundF
+                    ( DotListF
+                        (
+                            ( MkAnn
+                                { syntax = SynNone
+                                , position = Just
+                                    ( SourcePos
+                                        { sourceName = "golden/read/list/source.scm"
+                                        , sourceLine = Pos 1
+                                        , sourceColumn = Pos 19
+                                        }
+                                    )
+                                } :< SimpleF
+                                ( SimpleSymbol "나" )
+                            ) :| []
+                        )
+                        ( MkAnn
+                            { syntax = SynNone
+                            , position = Just
+                                ( SourcePos
+                                    { sourceName = "golden/read/list/source.scm"
+                                    , sourceLine = Pos 1
+                                    , sourceColumn = Pos 24
+                                    }
+                                )
+                            } :< SimpleF
+                            ( SimpleSymbol "다" )
+                        )
+                    )
+                , MkAnn
+                    { syntax = SynNone
+                    , position = Just
+                        ( SourcePos
+                            { sourceName = "golden/read/list/source.scm"
+                            , sourceLine = Pos 1
+                            , sourceColumn = Pos 28
+                            }
+                        )
+                    } :< SimpleF
+                    ( SimpleSymbol "라" )
+                ]
+            )
+        )
+    )
+]

golden/read/list/source.scm

@@ -0,0 +1 @@
+(a b (c d) . (가 (나 . 다) 라))

golden/read/meta-expression/read

@@ -0,0 +1,11 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/meta-expression/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< MetaF "aHaskellVariable + abc * 2"
+]

golden/read/meta-expression/source.scm

@@ -0,0 +1 @@
+#{aHaskellVariable + abc * 2}

golden/read/meta-splice-expression-interior-brace/source.scm

@@ -0,0 +1,2 @@
+##{case 123 of { 123 -> blah
+               ; xyz -> flah }}

golden/read/meta-splice-expression/read

@@ -0,0 +1,11 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/meta-splice-expression/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< MetaSpliceF "takeWhile (\x -> even x) aHaskellList"
+]

golden/read/meta-splice-expression/source.scm

@@ -0,0 +1 @@
+##{takeWhile (\x -> even x) aHaskellList}

golden/read/meta-splice-variable/read

@@ -0,0 +1,11 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/meta-splice-variable/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< MetaSpliceF "aHaskellList"
+]

golden/read/meta-splice-variable/source.scm

@@ -0,0 +1 @@
+##{aHaskellList}

golden/read/meta-variable/read

@@ -0,0 +1,11 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/meta-variable/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< MetaF "aHaskellVariable"
+]

golden/read/meta-variable/source.scm

@@ -0,0 +1 @@
+#{aHaskellVariable}

golden/read/peculiar-identifier-dot/read

@@ -0,0 +1,7 @@
+[ SynNone :< SimpleF
+    ( SimpleSymbol ".." )
+, SynNone :< SimpleF
+    ( SimpleSymbol ".abc" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "....abcc" )
+]

golden/read/peculiar-identifier-dot/source.scm

@@ -0,0 +1 @@
+.. .abc ....abcc

golden/read/peculiar-identifier-sign/read

@@ -0,0 +1,23 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "+" )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 3
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "-" )
+]

golden/read/peculiar-identifier-sign/source.scm

@@ -0,0 +1 @@
++ -

golden/read/string-line-continuation/read

@@ -0,0 +1,5 @@
+[ Fix
+    ( SimpleF
+        ( String "가나다라마바" )
+    )
+]

golden/read/string-line-continuation/source.scm

@@ -0,0 +1,2 @@
+"가나다\
+      라마바"

golden/read/string/read

@@ -0,0 +1,12 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/string/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleString "가나다라" )
+]

golden/read/string/source.scm

@@ -0,0 +1 @@
+"가나다라"

golden/read/typical-identifier-token/read

@@ -0,0 +1,58 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier-token/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "abc" )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier-token/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 4
+            }
+        )
+    } :< SimpleF
+    ( SimpleString "xyz" )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier-token/source.scm"
+            , sourceLine = Pos 2
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "수학" )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier-token/source.scm"
+            , sourceLine = Pos 2
+            , sourceColumn = Pos 5
+            }
+        )
+    } :< CompoundF
+    ( ListF Ordinary
+        [ MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/typical-identifier-token/source.scm"
+                    , sourceLine = Pos 2
+                    , sourceColumn = Pos 6
+                    }
+                )
+            } :< SimpleF
+            ( SimpleSymbol "數學" )
+        ]
+    )
+]

golden/read/typical-identifier-token/source.scm

@@ -0,0 +1,2 @@
+abc"xyz"
+수학(數學)

golden/read/typical-identifier/read

@@ -0,0 +1,100 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "abc" )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 5
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "bala-hwa$" )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 15
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "x!!!" )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 20
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "z" )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 22
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "z123" )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 27
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "나는너무졸리다" )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 42
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "學" )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 3
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "車室." )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 5
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "三個女人一臺戲。" )
+]

golden/read/typical-identifier/source.scm

@@ -0,0 +1,5 @@
+abc bala-hwa$ x!!! z z123 나는너무졸리다 學
+
+車室.
+
+三個女人一臺戲。

gyehoek.cabal

@@ -13,6 +13,11 @@ build-type:    Simple
 -- extra-doc-files:    CHANGELOG.md
 -- extra-source-files:
 
+flag doctest
+  description: enable the doctest suite
+  default:     True
+  manual:      True
+
 common ghcstuffs-dev
   ghc-options:
     -Wno-unused-matches -Wno-missing-signatures -Wno-typed-holes
@@ -52,25 +57,44 @@ library
 
   -- cabal-fmt: expand src
   exposed-modules:
+    Gyehoek.CPS.Close
     Gyehoek.CPS.Convert
-    Gyehoek.CPS.Lower
+    Gyehoek.CPS.Eval
+    Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
     Gyehoek.GenSym
+    Gyehoek.Jalmot
+    Gyehoek.Lift1
     Gyehoek.Options
+    Gyehoek.Prelude
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
+    Gyehoek.Sexp.Grammar
+    Gyehoek.Sexp.Grammar.Base
+    Gyehoek.Sexp.Print
+    Gyehoek.Sexp.QQ
+    Gyehoek.Sexp.Read
+    Gyehoek.Sexp.Syntax
+    Gyehoek.Stack.Lower
+    Gyehoek.Stack.Syntax
+    Gyehoek.Stack.VM
     Gyehoek.Wasm
 
   build-depends:
-    , base                  ^>=4.21.2.0
+    , base                         ^>=4.21.2.0
     , binary
+    , bytestring
+    , comonad
     , containers
-    , typed-process
+    , data-fix
+    , deepseq
+    , deriving-compat
     , effectful
     , effectful-core
     , effectful-plugin
     , filepath
+    , free
     , generic-lens
     , hashable
     , invertible-grammar
@@ -78,41 +102,75 @@ library
     , megaparsec
     , mtl
     , optparse-applicative
+    , ordered-containers
     , pretty-simple
     , prettyprinter
+    , prettyprinter-ansi-terminal
     , process
     , recursion-schemes
-    , sexp-grammar
+    , scientific
     , string-interpolate
     , template-haskell
     , text
     , text-short
+    , typed-process
     , unordered-containers
     , vector
-    , bytestring
 
   hs-source-dirs:   src
   default-language: GHC2024
 
 test-suite test
-  import:           ghcstuffs, ghcstuffs-dev
-  type:             exitcode-stdio-1.0
-  hs-source-dirs:   test
-  main-is:          Main.hs
+  import:             ghcstuffs, ghcstuffs-dev
+  type:               exitcode-stdio-1.0
+  hs-source-dirs:     test
+  main-is:            Main.hs
+  build-tool-depends: tasty-discover:tasty-discover
+
+  -- cabal-fmt: expand test -Main
   other-modules:
+    Gyehoek.Test.CPS.Eval
+    Gyehoek.Test.CPS.Stackify
     Gyehoek.Test.CPS.Syntax
     Gyehoek.Test.Golden
-    Gyehoek.Test.Sexp
+    Gyehoek.Test.Scheme.Syntax
+    Gyehoek.Test.Sexp.Print
+    Gyehoek.Test.Sexp.QQ
+    Gyehoek.Test.Sexp.Read
+    Gyehoek.Test.Stack.VM
+    Gyehoek.TestUtil
+    Root
 
   build-depends:
     , base
+    , deepseq
     , directory
+    , effectful
     , filepath
+    , generic-lens
     , gyehoek
+    , lens
+    , pretty-simple
     , process-extras
-    , sexp-grammar
     , tasty
+    , tasty-expected-failure
     , tasty-hunit
     , tasty-silver
+    , text
 
-  default-language: GHC2024
+  default-language:   GHC2024
+
+-- https://github.com/martijnbastiaan/doctest-parallel/pull/66
+test-suite doctest
+  import:             ghcstuffs, ghcstuffs-dev
+  type:               exitcode-stdio-1.0
+  hs-source-dirs:     test
+  build-depends:      base
+  default-extensions: CPP
+  main-is:            doctest.hs
+
+  if flag(doctest)
+    build-depends: doctest-parallel >=0.1
+
+  else
+    cpp-options: -DGYEHOEK_NO_DOCTEST

repl

@@ -1,2 +0,0 @@
-#!/usr/bin/env sh
-cabal repl --repl-options "-interactive-print=Text.Pretty.Simple.pPrint" --build-depends pretty-simple

shake-wrapper.nix

@@ -1,14 +0,0 @@
-{ runCommandLocal, makeWrapper, lib, haskellPackages }:
-
-let
-  our-ghc = haskellPackages.ghc.withPackages (ps: [
-    ps.shake
-  ]);
-in runCommandLocal
-  "shake-wrapper"
-  { nativeBuildInputs = [ makeWrapper ]; }
-  ''
-    mkdir -p $out/bin
-    makeWrapper ${lib.getExe haskellPackages.shake} $out/bin/shake \
-      --prefix PATH : ${lib.makeBinPath [our-ghc]}
-  ''

src/Gyehoek/CPS/Close.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE OverloadedLists #-}
+module Gyehoek.CPS.Close
+  ( closeProgram
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Gyehoek.GenSym
+import Gyehoek.Prelude
+
+
+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 so we don't have to
+    -- explicitly substitute recursive calls.
+    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
+
+closeProgram :: GenSym :> es => Program -> Eff es Program
+closeProgram = traverseOf #body close

src/Gyehoek/CPS/Convert.hs

@@ -2,17 +2,16 @@
 {- HLINT ignore "Use camelCase" -}
 module Gyehoek.CPS.Convert
   ( convertProgram
+  , convertExp
   ) where
 
 import Gyehoek.CPS.Syntax
 import Gyehoek.Scheme.Syntax qualified as Scm
 import Gyehoek.GenSym
 import Data.List.NonEmpty (NonEmpty((:|)))
-import Effectful
 import Control.Monad.Cont qualified as Cont
-import Control.Lens
 import qualified Data.List.NonEmpty as NE
-import qualified Gyehoek.Sexp
+import Gyehoek.Prelude
 
 
 -- 뻘짓이어라
@@ -24,31 +23,44 @@ telescope f = Cont.runCont . traverse (Cont.cont . f)
 
 
 
-pattern Atomic e <-
-  e@( Scm.ExpLambda _ _
-  ; Scm.ExpVar _
-  ; Scm.ExpLit _ )
-
 -- | Transform an expression with a meta-continuation.
 convert
   :: forall es. (GenSym :> es)
   => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
 
 convert (Scm.ExpVar x) k = k $ ValVar x
-convert (Scm.ExpLit l) k = k $ ValLit l
+convert (Scm.ExpLit l) k = k . ValImm $ case l of
+  LitInt n -> ImmInt n
+  LitBool b -> ImmBool b
+  _ -> _
 
+-- 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"
-  ktail <- gensym' "λ-tail"
-  m <- convert e $ \e' -> pure $ ExpContinue ktail [e']
+  f <- gensym' "lambda-body"
+  lam <- convertLambda xs e
   ke <- k $ ValVar f
   pure [cps|
-    (letrec ((#{f} (λ (##{xs} #{ktail}) #{m})))
+    (letrec ((#{f} #{lam}))
       #{ke})
   |]
 
@@ -65,11 +77,40 @@ 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'})
+  |]
+
+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 =
-  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) \exps ->
-    pure . Halt1 $ case NE.nonEmpty exps of
-      Nothing -> ValLit Void
-      Just es -> NE.last es
+  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) (pure . Halt)
+
+convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
+convertExp e = convert e (pure . Halt1)

src/Gyehoek/CPS/Eval.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE ViewPatterns #-}
+module Gyehoek.CPS.Eval
+  ( evalProgram
+  , module Gyehoek.CPS.Syntax
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Control.Lens
+import Data.Maybe (fromMaybe)
+import Text.Show.Functions ()
+import qualified Data.HashMap.Strict as H
+import Gyehoek.Prelude
+
+
+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
+
+emptyEnv :: Env
+emptyEnv = MkEnv
+  { vars = mempty
+  -- a kinda silly hack to make sure `halt` is handled correctly when
+  -- it appears as the tail continuation of an application. the
+  -- special case of `eval` responsible for `halt` only covers terms
+  -- of the form `(continue $halt xs …)`; other terms such as
+  -- `($some-fn xs $halt)` just see an undefined label `$halt`.
+  , labels = H.singleton "halt"
+    ( emptyEnv
+    , AbsKappa' ["h0"] $ Halt [ValVar "h0"]
+    )
+  }
+
+evalProgram :: Program -> List Obj
+evalProgram (MkProgram e) = eval emptyEnv e

src/Gyehoek/CPS/Lower.hs

@@ -1,350 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MultilineStrings #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE ApplicativeDo #-}
-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
-{-# LANGUAGE RecursiveDo #-}
-{- HLINT ignore "Use camelCase" -}
-module Gyehoek.CPS.Lower
-  (lower, lowerProgram) where
-
-import Gyehoek.CPS.Syntax
-import Data.Generics.Labels ()
-import Effectful
-import Data.Text (Text)
-import Data.Vector.Strict (Vector)
-import Control.Lens hiding (op)
-import Numeric.Natural
-import GHC.Generics (Generic)
-import qualified Data.Vector.Strict as V
-import Gyehoek.Wasm qualified as Wasm
-import Gyehoek.Wasm hiding (Expr)
-import Language.Sexp.Located qualified as SL
-import Control.Monad.Fix
-import qualified Gyehoek.Sexp
-import Data.Text qualified as T
-import Data.Foldable (fold)
-import Gyehoek.Sexp (encodeOrShow, toSexp)
-import Debug.Pretty.Simple
-
-
-data Env = MkEnv
-  { vars :: Vector Name
-  , kvars :: Vector Name
-  }
-  deriving (Show, Generic)
-
-type instance Index Env = Natural
-type instance IxValue Env = Name
-
-instance Ixed Env where
-  ix i = #vars . ix (fromIntegral i)
-
-
-
-tonat :: Integral a => a -> Natural
-tonat = fromIntegral
-
--- | @makeSmallFixnum@ emits an expression injecting the i32 on top
--- of the stack into the SCM unitype.
-makeSmallFixnum :: Wasm.Expr
-makeSmallFixnum = [expr|
-    (@gyehoek "construct small fixnum")
-    (i32.const 1)
-    i32.shl
-    ref.i31
-  |]
-
--- | 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")
-    (global.get $arg-array)
-    (i32.const #{n})
-    ##{e}
-    (array.set $arg-array-type)
-  |]
-
--- | Pop the nth arg from the arg-passing array onto the stack.
-popArg :: Int -> Wasm.Expr
-popArg n = [expr|
-  (@gyehoek "pop argument")
-  (global.get $arg-array)
-  (i32.const #{n})
-  (array.get $arg-array-type)
-  ref.as_non_null
-|]
-
-
-
-lowerVal :: GenMod :> es => Env -> Val -> Eff es Wasm.Expr
-
-lowerVal g (ValLit l) =
-  pure $ case l of
-    LitInt n -> [expr|
-      (i32.const #{n})
-      ##{makeSmallFixnum}
-    |]
-    LitBool b -> [expr|
-      (i32.const #{b'})
-      ref.i31
-    |]
-      where b' :: Int = if b then 0b11 else 0b01
-    _ -> _
-
-lowerVal g (ValVar x) = pure $ [expr|(local.get #{l})|]
-  where
-    l = 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
-
-lower' g (Halt [v]) = do
-  arg <- pushArg 0 <$> lowerVal g v
-  pure [expr|
-    ##{arg}
-    (return_call $halt (i32.const 1))
-  |]
-
-lower' g e@(ExpPrim p k) =
-  ([expr|(@gyehoek :origin #{origin})|]<>)
-  <$> case p of
-    PrimAdd x y -> lowerBinOp "i32.add" g x y k
-    PrimMul x y -> lowerBinOp "i32.mul" g x y k
-  where origin = encodeOrShow @_ @Text e
-
-lower' g (ExpIf c t f) = do
-  c' <- lowerVal g c
-  t' <- lower' g t
-  f' <- lower' g f
-  pure [expr|
-    ##{c'}
-    (call $gh-truthy?)
-    (if (then ##{t'})
-        (else ##{f'}))
-  |]
-
-lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do
-  idx <- lowerKappa g kap
-  let g' = g & #kvars <>~ [r]
-  e' <- lower' g' e
-  let origin = encodeOrShow @_ @Text e
-  pure [expr|
-    (@gyehoek :origin #{origin})
-    (@gyehoek "push cont" :idx #{idx})
-    (array.set $cont-stack-type
-               (global.get $cont-stack)
-               (global.get $cont-stack-top)
-               (ref.func #{idx}))
-    (global.set $cont-stack-top
-                (i32.add (global.get $cont-stack-top)
-                         (i32.const 1)))
-    ##{e'}
-  |]
-
-lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do
-  idx <- lowerLambda g lam
-  let g' = g & #vars <>~ [r]
-  let n = succ $ length g.vars
-  e' <- lower' g' e
-  pure [expr|
-    (i32.const 0)
-    (ref.func #{idx})
-    (struct.new $closure)
-    (local.set #{n})
-    ##{e'}
-  |]
-
-lower' g e@(ExpApply f xs ktail) = do
-  let nargs = length xs
-  f' <- lowerVal g f
-  let l = succ $ V.elemIndex ktail g.kvars ^?! _Just
-  args <- fold <$>
-    itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
-  let origin = encodeOrShow @_ @Text e
-  pure [expr|
-    (@gyehoek :origin #{origin})
-    (@gyehoek "load args")
-    ##{args}
-    (i32.const 1)
-    ##{f'}
-    (ref.cast (ref $closure))
-    (struct.get $closure $code)
-    (return_call_ref $cont-type)
-    (@gyehoek todo
-     (f' ##{f'})
-     (ktail #{l}))
-  |]
-
-lower' g e@(ExpContinue k xs) = do
-  let nargs = length xs
-  args <- fold <$>
-    itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
-  let origin = encodeOrShow @_ @Text e
-  pure [expr|
-    (@gyehoek :origin #{origin})
-    (@gyehoek "push args")
-    ##{args}
-    (@gyehoek "nargs")
-    (i32.const #{nargs})
-    (@gyehoek "pop cont stack")
-    (global.get $cont-stack-top)
-    (i32.const #{l})
-    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)
-  |]
-  where
-    l = succ $ V.elemIndex k g.kvars ^?! _Just
-
-lower' g e = error $ case Gyehoek.Sexp.encode e of
-  Left _ -> show e
-  Right x -> T.unpack x
-
-lowerKappa :: GenMod :> es => Env -> Kappa -> Eff es Idx
-lowerKappa g e@(MkKappa xs m) = do
-  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})
-  |]
-  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
-  pure idx
-
-lowerLambda :: GenMod :> es => Env -> Lambda -> Eff es Idx
-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})
-  |]
-  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
-  pure idx
-
-lowerBinOp
-  :: (GenMod :> es)
-  => Text -> Env -> Val -> Val -> Kappa -> Eff es Wasm.Expr
-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)
-  x' <- lowerVal g x
-  y' <- lowerVal g y
-  e' <- lower' g' e
-  pure [expr|
-    ##{x'}
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    ##{y'}
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    #{op'}
-    ##{makeSmallFixnum}
-    (local.set #{n})
-    ##{e'}
-  |]
-
-
-
-emitRuntime :: GenMod :> es => Eff es ()
-emitRuntime = mfix \runtime -> do
-  Wasm.defineFunctions [wats|
-    (import "gyehoek" "write" (func $gh-write (param (ref eq))))
-    (import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq))
-                                  (result i32)))
-  |]
-  -- cont stack
-  Wasm.defineTypes [wats|
-    (type $heap-object (sub (struct (field $hash (mut i32)))))
-    (type $cont-type (func (param i32)))
-    (type $cont-stack-type (array (mut (ref null $cont-type))))
-    (type $closure (sub $heap-object
-                        (struct (field $hash (mut i32))
-                                (field $code (ref $cont-type)))))
-  |]
-  Wasm.defineGlobals [wats|
-    (global $cont-stack-top (mut i32) (i32.const 0))
-    (global $cont-stack (ref $cont-stack-type)
-            (array.new_default $cont-stack-type (i32.const 128)))
-  |]
-  -- arg array
-  Wasm.defineType [wat|
-    (type $arg-array-type (array (mut (ref null eq))))
-  |]
-  Wasm.defineGlobal [wat|
-    (global $arg-array (ref $arg-array-type)
-            (array.new_default $arg-array-type (i32.const 32)))
-  |]
-  -- other  things 😼
-  Wasm.defineGlobal [wat|
-    (global $result (mut (ref null eq))
-            (ref.null eq))
-  |]
-  -- procedures
-  let arg = popArg 0
-  Wasm.defineFunction [wat|
-    (func $halt (param i32)
-      ##{arg}
-      (global.set $result))
-  |]
-  pure ()
-
-lower :: Exp -> Eff es Text
-lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
-  runtime <- emitRuntime
-  let g = MkEnv mempty mempty
-  e' <- lower' g e
-  let origin = encodeOrShow @_ @Text e
-  Wasm.defineFunction [wat|
-    (func $scm-entry (param i32)
-      (@gyehoek :origin #{origin})
-      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{e'})
-  |]
-  Wasm.defineFunction [wat|
-    (func (export "main")
-      (call $scm-entry (i32.const 0))
-      (call $gh-write (ref.as_non_null (global.get $result))))
-  |]
-  
-lowerProgram :: Program -> Eff es Text
-lowerProgram (MkProgram e) = lower e

src/Gyehoek/CPS/Stackify.hs

@@ -0,0 +1,159 @@
+{-# 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 Gyehoek.GenSym
+import Effectful.Writer.Static.Shared
+import Data.Foldable
+import qualified Data.HashMap.Strict as H
+import Data.List (elemIndex)
+import Gyehoek.Prelude
+
+
+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)
+
+data BlockBuilder
+  = Code (List Stk.Instr) BlockBuilder
+  | Tail Stk.Tail
+  deriving (Show, Generic)
+
+buildBlock :: BlockBuilder -> Stk.Block
+buildBlock = go [] where
+  go acc (Code xs bb) = go (acc ++ xs) bb
+  go acc (Tail t) = Stk.MkBlock acc t
+
+emitRoutine :: Stackify :> es => Stk.Routine -> Eff es ()
+emitRoutine rt = tell [rt]
+
+stackify
+  :: (GenSym :> es, Stackify :> es)
+  => Env -> Exp -> Eff es BlockBuilder
+
+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
+  emitRoutine $
+    Stk.MkRoutine f xs . buildBlock $
+      Code [Stk.Pop x | x <- ls] 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
+  emitRoutine $ Stk.MkRoutine f xs (buildBlock m')
+  stackify g e
+
+stackify g (ExpIf c t f) = do
+  let c' = stackifyVal g c
+  t' <- buildBlock <$> stackify g t
+  f' <- buildBlock <$> stackify g f
+  pure . Tail $ Stk.If c' t' f'
+
+stackify g (ExpApply f xs ktail) = pure $
+    Code [ Stk.PushCont k ] $
+    Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
+    Tail (Stk.TailCall (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 . Tail $ Stk.TailCall (Stk.ValLabel k) xs'
+    Just j -> do
+      ktail <- gensym' @Name $ k ^. _Wrapped'
+      pure $
+        Code (replicate j $ Stk.PopCont "_") $
+        Code [Stk.PopCont ktail] $
+        Tail (Stk.TailCall (Stk.ValReg ktail) 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 $
+    Code [ Stk.Prim x (stackifyVal g <$> p) ] $
+    e'
+
+stackify _ e = error [i|unimplemented exp: #{e}|]
+
+stackifyVal :: Env -> Val -> Stk.Val
+stackifyVal g = \case
+  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.MkRoutine lbl [] (buildBlock 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,22 +4,27 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)
   , Lambda(..)
   , Exp(..)
+  , ExpF(..)
   , Name(..)
   , Prim(..)
   , Program(..)
   , Lit(..)
-  , pattern Void
+  , Imm(..)
+  , Obj(..)
+  , Hob(..)
   , pattern Halt
   , pattern Halt1
   , _MkKappa
   , _ExpPrim
   , _ExpLetRec
   , _ExpApply
+  , _AbsLambda'
   , binders
   , body
   , op
@@ -29,40 +34,54 @@ module Gyehoek.CPS.Syntax
   , pattern AbsLambda'
   , pattern AbsKappa'
   , Abs(..)
-  , free
-  , free'
+  , Free(..)
+  , pattern ValLabel
+  , labelName -- don't like that this is part of the api
   )
   where
 
-import Language.SexpGrammar qualified as S
-import Gyehoek.Sexp qualified
-import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void, getName)
-import Data.List (List)
-import GHC.Generics (Generic)
-import Language.SexpGrammar.Generic
+import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primDatumIso, Lit(..))
+import Gyehoek.Sexp qualified as S
 import Control.Category
-import Control.Lens hiding (op)
 import Prelude hiding ((.), id)
-import Data.List.NonEmpty (NonEmpty)
-import Language.Haskell.TH.Quote (QuasiQuoter)
-import Data.Data (Data)
-import Language.Sexp.Located (Sexp)
-import qualified Data.InvertibleGrammar.Base as IG
-import qualified Gyehoek.Scheme.Syntax as Gyehoek
-import Data.InvertibleGrammar.Base (type (:-)((:-)))
-import Data.HashSet (HashSet)
 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.Data.Lens (uniplate)
+import Gyehoek.Prelude hiding (op)
+import Gyehoek.Sexp (Datum)
+import Gyehoek.Sexp (G, (:-)(..))
+import qualified Data.InvertibleGrammar.Base as IG
 
 -- Data types
 
 data Val
-  = ValVar Name
-  | ValLit Lit
+  = ValImm Imm
+  | 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 +93,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
@@ -104,16 +126,11 @@ data Program = MkProgram
   deriving (Show, Generic, Data)
 
 makePrisms ''Kappa
--- makeLenses ''Kappa
 makePrisms ''Exp
--- makeLenses ''Exp
--- makeFieldsNoPrefix ''Exp
--- makeFieldsNoPrefix ''Kappa
--- makeLensesWith abbreviatedFields ''Exp
--- makeLensesFor [("binders", "_binders"), ("body", "_body")] ''Exp
 makeFieldsId ''Exp
 makeFieldsId ''Kappa
 makeFieldsId ''Lambda
+makeBaseFunctor ''Exp
 
 instance HasBinders Abs (List Name) where
   binders k (AbsKappa kap) = AbsKappa <$> binders k kap
@@ -123,28 +140,67 @@ 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
+
 
--- SexpIso instances
+-- DatumIso instances
 
-instance S.SexpIso Val where
-  sexpIso = match
-    $ With (\var -> var . S.sexpIso)
-    $ With (\lit -> lit . S.sexpIso)
-    $ End
+instance S.DatumIso Val where
+  datumIso = S.match
+    $ S.With (\imm -> imm . S.datumIso)
+    $ S.With (\var -> var . S.datumIso)
+    $ S.End
 
-instance S.SexpIso Lambda where
-  sexpIso = match
-    $ With (. lambda)
-    $ End
+instance S.DatumIso Obj where
+  datumIso = S.match
+    $ S.With (\imm -> imm . S.datumIso)
+    $ S.With (\hob -> hob . S.datumIso)
+    $ S.End
+
+instance S.DatumIso Imm where
+  datumIso = S.match
+    $ S.With (. S.int)
+    $ S.With (. S.datumIso)
+    $ S.With (. labelName)
+    $ S.End
+
+labelName :: S.DatumGrammar Name
+labelName = S.coproduct
+  [ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
+        (S.expected "label")
+        (prefixed @Name "$")
+  , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
+  ]
+
+instance S.DatumIso Hob where
+  datumIso = S.match
+    $ S.With (. closure)
+    $ S.End
+    where
+      -- closures can be printed, but not parsed.
+      closure :: G (Datum :- t) (List Obj :- Name :- t)
+      closure = IG.Flip $ IG.PartialIso
+        (\(env:-code:-t) -> [S.sx|(<closure> #{code} ##{env})|] :- t)
+        (const . Left $ mempty)
+
+instance S.DatumIso Lambda where
+  datumIso = S.match
+    $ S.With (. lambda)
+    $ S.End
     where
       lambda = S.list $
-        S.el Gyehoek.Sexp.lambdaKeyword
+        S.el S.lambdaKeyword
         >>> S.el binders
-        >>> S.el S.sexpIso
-      binders :: forall t.
-        IG.Grammar S.Position (Sexp :- t) (Name :- List Name :- t)
+        >>> S.el S.datumIso
+      binders :: forall t. G (Datum :- t) (Name :- List Name :- t)
       binders = S.list $
-        S.rest (S.sexpIso @Name)
+        S.rest (S.datumIso @Name)
         >>> S.onTail (S.flipped $ IG.PartialIso
                      (\(ktail:-args:-t) -> (args ++ [ktail]) :- t)
                      (\(args:-t) -> case args ^? _Snoc of
@@ -152,43 +208,40 @@ instance S.SexpIso Lambda where
                          Nothing -> Left $ S.expected "cont param")
                      )
 
-instance S.SexpIso Kappa where
-  sexpIso = match
-    $ With (. kappa)
-    $ End
-    where
-      kappa = S.list $
-        S.el Gyehoek.Sexp.kappaKeyword
-        >>> S.el (S.list $ S.rest S.sexpIso)
-        >>> S.el S.sexpIso
+instance S.DatumIso Kappa where
+  datumIso = S.with \g ->
+    S.lambdaLike S.kappaKeyword
+      (S.list $ S.rest (S.datumIso @Name))
+      (S.el $ S.datumIso @Exp)
+    >>> g
 
-instance S.SexpIso Abs where
-  sexpIso = match
-    $ With (\lambda -> lambda . S.sexpIso)
-    $ With (\kappa -> kappa . S.sexpIso)
-    $ End
+instance S.DatumIso Abs where
+  datumIso = S.match
+    $ S.With (\lambda -> lambda . S.datumIso)
+    $ S.With (\kappa -> kappa . S.datumIso)
+    $ S.End
 
-instance S.SexpIso Exp where
-  sexpIso = match
-    $ With (. prim)
-    $ With (. letrec)
-    $ With (. continue)
-    $ With (. if_)
-    $ With (. app)
-    $ End
+instance S.DatumIso Exp where
+  datumIso = S.match
+    $ S.With (. prim)
+    $ S.With (. letrec)
+    $ S.With (. continue)
+    $ S.With (. if_)
+    $ S.With (. app)
+    $ S.End
     where
       continue = S.list $
-        S.el (S.sym "continue")
-        >>> S.el S.sexpIso
-        >>> S.rest S.sexpIso
-      letrec = Gyehoek.Sexp.let_ "letrec" S.sexpIso S.sexpIso S.sexpIso
-      if_ = S.list $ S.el (S.sym "if")
-        >>> S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso
+        S.el (S.decorate S.SynBuiltin >>> S.sym "continue")
+        >>> S.el (S.decorate S.SynProcedure >>> S.datumIso)
+        >>> S.rest S.datumIso
+      letrec = S.letLike "letrec" S.datumIso S.datumIso S.datumIso
+      if_ = S.ifLike "if"
+        S.datumIso S.datumIso S.datumIso
       app :: forall t.
-        IG.Grammar S.Position (Sexp :- t) (Name :- ([Val] :- (Val :- t)))
-      app = S.list $ S.el (S.sexpIso @Val)
-        -- >>> S.flipped Gyehoek.Sexp.nonEmptyGrammar
-        >>> S.rest (S.sexpIso @Val)
+        G (Datum :- t) (Name :- ([Val] :- (Val :- t)))
+      app = S.list $ S.el (S.datumIso @Val)
+        -- >>> S.flipped Gyehoek.Datum.nonEmptyGrammar
+        >>> S.rest (S.datumIso @Val)
         -- >>> _
         >>> S.onTail (S.flipped $ IG.PartialIso
                       (\(karg :- args :- op :- t) ->
@@ -198,30 +251,32 @@ instance S.SexpIso Exp where
                             Right $ karg:- args :- op :- t
                           _ -> Left $ S.expected "continuation arg"
                       ))
-        where
-          _ = S.flipped $ Gyehoek.Sexp.nonEmptyGrammar @S.Position @Val
+      -- prim = S.headTagged2 "prim"
+      --   (primDatumIso id (S.datumIso @Val))
+      --   (S.datumIso @Kappa)
       prim = S.list $
-        S.el (S.sym "prim")
-        >>> S.el (primSexpIso id (S.sexpIso @Val))
-        >>> S.el S.sexpIso
+        S.el (S.decorate S.SynBuiltin >>> S.sym "prim")
+        >>> S.el (primDatumIso id (S.datumIso @Val))
+        >>> S.el S.datumIso
 
-instance S.SexpIso Program where
-  sexpIso = with \prog -> S.sexpIso @Exp >>> prog
+instance S.DatumIso Program where
+  datumIso = S.with \prog -> S.datumIso @Exp >>> prog
 
 
 -- quasiquoters
 
 class Data a => CPS a where
-  toCPS :: Sexp -> a
+  toCPS :: Datum -> a
 
-instance CPS Exp where toCPS = Gyehoek.Sexp.fromSexp
-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 Exp where toCPS = S.fromDatumUnsafe S.datumIso
+instance CPS Val where toCPS = S.fromDatumUnsafe S.datumIso
+instance CPS Kappa where toCPS = S.fromDatumUnsafe S.datumIso
+instance CPS Lambda where toCPS = S.fromDatumUnsafe S.datumIso
+instance CPS Abs where toCPS = S.fromDatumUnsafe S.datumIso
+instance CPS Program where toCPS = S.fromDatumUnsafe S.datumIso
 
-cps :: QuasiQuoter
-cps = Gyehoek.Sexp.makeSx' [| toCPS |]
+cps :: S.QuasiQuoter
+cps = S.makeSx' [| toCPS |]
 
 
 
@@ -234,49 +289,62 @@ 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
-free = go where
-  gokap (MkKappa xs m) = go m & deleteFrom xs
-  golam (MkLambda xs k m) = go m & deleteFrom xs & sans k
-  goabs = \case
-    AbsKappa kap -> gokap kap
-    AbsLambda lam -> golam lam
-  go = \case
+class Free a where
+  free :: a -> HashSet Name
+  free = freeWithBound mempty
+
+  freeWithBound :: HashSet Name -> a -> HashSet Name
+  freeWithBound bound = HS.fromList . freeWithBound' bound
+
+  -- | 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)
-        & HS.union (gokap k)
+      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
+        & (<> freeWithBound' bound k)
     ExpLetRec bs m ->
-      foldMapOf (each . _2) goabs bs <> go m
-      & deleteFrom (bs ^.. each . _1)
-    ExpContinue k xs -> HS.fromList $ k : xs ^.. each . #ValVar
-    ExpIf c t f -> toHashSetOf #ValVar c <> go t <> go f
-    ExpApply f xs k -> toHashSetOf (each . #ValVar) (f:xs) <> HS.singleton k
+      foldMapOf (each . _2) (freeWithBound' bound') bs
+      <> freeWithBound' 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))
+      <> 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.
-free' :: Exp -> List Name
-free' = nubOrd . goFree HS.empty where
+instance Free Kappa where
+  freeWithBound' bound (MkKappa xs m) =
+    freeWithBound' (bound & insertFrom xs) m
 
-goFreeKap bound (MkKappa xs m) = goFree (bound & insertFrom xs) m
-goFreeLam bound (MkLambda xs k m) = goFree (bound & insertFrom (k:xs)) m
-goFreeAbs bound = \case
-  AbsKappa kap -> goFreeKap bound kap
-  AbsLambda lam -> goFreeLam bound lam
+instance Free Lambda where
+  freeWithBound' bound (MkLambda xs k m) =
+    freeWithBound' (bound & insertFrom (k:xs)) m
 
-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
-freeLambda (MkLambda {binders,ktail,body}) = _
+class Vars a where
+  -- | 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