convert (limited) letrec

.dir-locals.el

@@ -2,4 +2,6 @@
   . ((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-hook 'before-save-hook #'apply-cabal-fmt-h nil t)
+               (add-to-list 'haskell-font-lock-quasi-quote-modes
+                            '("cps" . 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,83 @@
+#+title: closure-conversion
+
+the closure-conversion phase makes closed-over variables explicit by addition of the primitive ~make-closure~, taking a code pointer (in the CPS language, bare lambda) and the environment.
+
+* scratchpad
+
+#+begin_src scheme
+(letrec ((make-adder
+        (lambda (n)
+          (lambda (x)
+            (+ n x)))))
+((make-adder 3) 2))
+#+end_src
+
+#+begin_src scheme
+(define add-code
+  (lambda (n env)
+    (+ n (env-ref env 'x))))
+
+(define make-adder-code
+  (lambda (n)
+    (make-closure add-code ('x n))))
+
+(define make-adder (make-closure make-adder-code))
+
+(apply-closure (apply-closure make-addder 3) 2)
+#+end_src
+
+#+begin_src wat
+(module
+ (type $heap-object (sub (struct (field $hash (mut i32)))))
+ (type $closure (sub $heap-object
+                     (struct (field $hash (mut i32))
+                             (field $code (ref $cont-type)))))
+ (type $closure1 (sub $closure
+                      (struct (field $hash (mut i32))
+                              (field $code (ref $cont-type))
+                              (field $env0 (ref eq)))))
+ (global $arg0 (mut (ref null eq)) (ref.null eq))
+ (global $arg1 (mut (ref null eq)) (ref.null eq))
+ (global $arg2 (mut (ref null eq)) (ref.null eq))
+ (global $arg3 (mut (ref null eq)) (ref.null eq))
+ (global $arg4 (mut (ref null eq)) (ref.null eq))
+ (global $arg5 (mut (ref null eq)) (ref.null eq))
+ ;; ⋮
+ ;; (global $argn (mut (ref null eq)) (ref.null eq))
+
+ (global $current-closure (mut (ref null $closure)) (ref.null $closure))
+
+ (func $add-code (param $nargs i32)
+       (local $n (ref eq))
+       (local $x (ref eq))
+       (local.set $n (global.get $arg0))
+       (local.set $x (struct.get $closure1
+                                 (global.get $current-closure)
+                                 $env0))
+       (return (i32.add $n $x)))
+
+ (func $make-adder-code (param $nargs i32)
+       (local $n (ref eq))
+       (local.set $n (global.get $arg0))
+       (return (struct.new $closure1
+                           0
+                           $add-code)))
+
+ (func $main
+       (local.set $make-adder
+                  (struct.new $closure
+                              0
+                              $make-adder-code))
+       (global.set $current-closure $make-adder)
+       (global.set $arg0 (i32.const 3))
+       (local.set $f (call (struct.get $closure
+                                       $make-adder
+                                       $code)
+                           1))
+       (global.set $current-closure $f)
+       (global.set $arg0 (i32.const 2))
+       (return (call (struct.get $closure
+                                 $f
+                                 $code)
+                     1))))
+#+end_src

doc/data-model.org

@@ -15,3 +15,9 @@ XXXX XXXX XXXX XXXX XXXX XXXX XXXX XX00
       zero indicates a 30-bit fixnum /
       in the upper bits
 #+end_example
+
+| type/value | low bits |
+|------------+----------|
+| small int  |        0 |
+| ~false~      |       01 |
+| ~true~       |       11 |

doc/index.org

@@ -0,0 +1,53 @@
+#+title: Gyehoek Scheme
+
+#+begin_center
+(this document is written in present tense as if the project is complete, but Gyehoek is a work-in-progress.)
+#+end_center
+
+Gyehoek is an R⁷RS-compliant Scheme compiler targeting WebAssembly 3.0, relying principally on the recently standardised garbage collector and tail call proposals. the Gyehoek compiler is implemented in Haskell, and the Gyehoek runtime is a Rust program providing primitive routines and WebAssembly execution via the Wasmtime library.
+
+primitives are implemented as native Rust functions made available to the guest by Wasmtime. in the future, it would be ideal to provide the primitives as a WASI interface to help decouple ourselves from a specific Wasm runtime, but it is not a priority.
+
+Gyehoek allows separate compilation, ~eval~, first-class continuations, and so on.
+
+* pipeline
+
+a Scheme program's journey through Gyehoek is as follows:
+1. read (source code → Scheme data)
+2. parse (Scheme data → AST)
+3. expand(?) (AST → AST)
+4. contify (AST → CPS)
+5. close (CPS → CPS)
+6. lower (CPS → Wasm)
+
+** read
+
+in the read phase, Gyehoek's reader serialises textual source code into a sequence of tokens, which are then parsed into S-expressions. this phase is completely agnostic towards any interpretation of the data — it's just data, not code (yet). this distinction between reading and parsing is made so that the reader can easily be shared amongst many parsers, allowing convenient definition of human-readable representations for all sorts of compiler internals. Gyehoek's intermediate languages and WebAssembly text format are of particular interest.
+
+the reader may be configured to extend R⁷RS's syntax with a special "antiquotation" notation, used internally in the compiler to elegantly interpolate and splice S-expression literals via Haskell's quasiquotation.
+#+begin_src haskell
+  let meta = 123 :: Int
+  in [sx|(a b c #{meta} d)|] -- ⇒ (a b c 123 d)
+
+  let metas = ["c","d"] :: List Text
+  in [sx|(a b ##{metas} e f)|] -- ⇒ (a b "c" "d" e f)
+#+end_src
+
+Gyehoek's lexer and parser are generated by Alex and Happy, respectively.
+
+unless otherwise noted, the term "parse" will be used in reference to the phase taking S-expressions to ASTs, while "read" refers to the combined Alex/Happy process. if the tokenisation process (Alex) must be distinguished from the "parse" process (Happy), the former is called "lexical analysis" and the latter "syntactic analysis."
+
+** parse
+
+- use invertible-grammar library
+
+** expand
+
+** contify
+
+- procedures are distinguished from continuations, and procedure applications are distinguished from continuation jumps.
+- all continuations and lambda will be named i think. the exception is continuations for primitive calls.
+
+** close
+
+** lower

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.lock

@@ -66,6 +66,21 @@
         "type": "github"
       }
     },
+    "crane": {
+      "locked": {
+        "lastModified": 1784248371,
+        "narHash": "sha256-0l0Y4D4wbZhp1Oi6h8OpbLtIm/4FN88oCf54MK2ZgiM=",
+        "owner": "ipetkov",
+        "repo": "crane",
+        "rev": "f7d151ec0bf52cf9662e2f59d7bea28588c2f070",
+        "type": "github"
+      },
+      "original": {
+        "owner": "ipetkov",
+        "repo": "crane",
+        "type": "github"
+      }
+    },
     "flake-compat": {
       "flake": false,
       "locked": {
@@ -587,6 +602,7 @@
     },
     "root": {
       "inputs": {
+        "crane": "crane",
         "haskellNix": "haskellNix",
         "nixpkgs": [
           "haskellNix",

flake.nix

@@ -7,6 +7,7 @@
       url = "git+https://git.deertopia.net/msyds/sydpkgs";
       inputs.nixpkgs.follows = "nixpkgs";
     };
+    crane.url = "github:ipetkov/crane";
   };
 
   outputs = { self, nixpkgs, sydpkgs, haskellNix, ... }@inputs:
@@ -16,13 +17,13 @@
         "x86_64-darwin" "x86_64-linux"
       ];
 
-
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          gyehoek-wasmtime-wrapper = final.callPackage ./wasmtime.nix {};
-        })
-        (final: prev: {
+          shake-wrapper = final.callPackage ./shake-wrapper.nix {};
+          gyehoek-runtime = final.callPackage ./runtime {
+            crane-lib = inputs.crane.mkLib final;
+          };
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
@@ -30,32 +31,32 @@
               packages.gyehoek.components.tests.test.preCheck =
                 let
                   bin = [
-                    pkgs.gyehoek-wasmtime-wrapper
-                    pkgs.git
+                    pkgs.git # tasty uses git diff
                   ];
                 in ''
-                  # Wasmtime requires a cache in $HOME. This is less
-                  # painful than reconfiguring the cache location.
-                  export HOME=$(mktemp -d)
+                  export GYEHOEK_RUNTIME=${lib.getExe final.gyehoek-runtime}
                   export PATH=${lib.makeBinPath bin}:$PATH
                 '';
             })];
             shell = {
               withHoogle = true;
-              inputsFrom = [];
+              inputsFrom = [
+                final.gyehoek-runtime
+              ];
               tools = {
                 cabal = {};
                 haskell-language-server = {};
               };
               buildInputs = with final; [
                 haskellPackages.cabal-fmt
-                self.packages.${final.stdenv.hostPlatform.system}.shake
-                final.wabt
-                final.nodejs
-                final.wasm-tools
-                final.wac-cli
-                final.guile
-                final.gyehoek-wasmtime-wrapper
+                shake-wrapper
+                wabt
+                nodejs
+                wasm-tools
+                wac-cli
+                guile
+                rust-analyzer
+                wasmtime
               ];
             };
           };
@@ -87,7 +88,7 @@
         hf.packages.${system} // lib.fix (packages: {
           gyehoek = hf.packages.${system}."gyehoek:exe:gyehoek";
           default = packages.gyehoek;
-          shake = pkgs.callPackage ./shake-wrapper.nix {};
+          inherit (pkgs) gyehoek-runtime shake-wrapper;
         }));
 
       devShells = each-system

golden/adder/source.scm

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

golden/apply-twice/source.scm

@@ -0,0 +1,5 @@
+;; apply `f' to `x' twice.
+((λ (f x)
+   (f (f x)))
+ (λ (x) (+ x 4))
+ 9)

golden/apply2/source.scm

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

golden/arith/exec

@@ -1,5 +1,2 @@
 ret > ExitSuccess
 out > 22
-out >
-err > warning: using `--invoke` with a function that returns values is experimental and may break in the future
-err >

golden/arith/out.wat

@@ -1,47 +0,0 @@
-(module
-  (type $heap-object (sub (struct (field (mut i32)))))
-  (func
-    (param)
-    (result (ref eq))
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (i32.const 3)
-    (i32.const 2)
-    i32.shl
-    ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
-    (i32.const 4)
-    (i32.const 2)
-    i32.shl
-    ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
-    i32.mul
-    ref.i31
-    (local.set 0)
-    (i32.const 2)
-    (i32.const 2)
-    i32.shl
-    ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
-    (i32.const 5)
-    (i32.const 2)
-    i32.shl
-    ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
-    i32.mul
-    ref.i31
-    (local.set 1)
-    (local.get 0)
-    (ref.cast (ref i31))
-    i31.get_s
-    (local.get 1)
-    (ref.cast (ref i31))
-    i31.get_s
-    i32.add
-    ref.i31
-    (local.set 2)
-    (local.get 2))
-  (export "main" (func 0)))

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/false/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #f

golden/false/source.scm

@@ -0,0 +1 @@
+#f

golden/fn-of-fn/exec

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

golden/fn-of-fn/source.scm

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

golden/if-false/exec

@@ -1,5 +1,2 @@
 ret > ExitSuccess
 out > 555
-out >
-err > warning: using `--invoke` with a function that returns values is experimental and may break in the future
-err >

golden/if-false/out.wat

@@ -1,13 +0,0 @@
-(module
-  (type (sub (struct (field (mut i32)))))
-  (func
-    (param)
-    (result (ref eq))
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (i32.const 0)
-    ref.i31
-    (if
-      (result i32)
-      (then (i32.const 777) ref.i31)
-      (else (i32.const 555) ref.i31)))
-  (export "main" (func 0)))

golden/if-number/exec

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

golden/if-number/source.scm

@@ -0,0 +1 @@
+(if 123 777 555)

golden/if-true/exec

@@ -1,5 +1,2 @@
 ret > ExitSuccess
 out > 777
-out >
-err > warning: using `--invoke` with a function that returns values is experimental and may break in the future
-err >

golden/if-true/out.wat

@@ -1,13 +0,0 @@
-(module
-  (type (sub (struct (field (mut i32)))))
-  (func
-    (param)
-    (result (ref eq))
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (i32.const 1)
-    ref.i31
-    (if
-      (result i32)
-      (then (i32.const 777) ref.i31)
-      (else (i32.const 555) ref.i31)))
-  (export "main" (func 0)))

golden/lambda/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #<procedure>

golden/let-fn/source.scm

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

golden/square/exec

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

golden/true/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #t

golden/true/source.scm

@@ -0,0 +1 @@
+#t

gyehoek.cabal

@@ -25,6 +25,11 @@ common ghcstuffs
   default-extensions:
     BlockArguments
     DeriveGeneric
+    DerivingVia
+    DuplicateRecordFields
+    NoFieldSelectors
+    OrPatterns
+    OverloadedLabels
     OverloadedRecordDot
     OverloadedStrings
     PartialTypeSignatures
@@ -34,9 +39,8 @@ common ghcstuffs
 executable gyehoek
   import:           ghcstuffs, ghcstuffs-dev
   main-is:          Main.hs
-
   build-depends:
-    , base                  ^>=4.21.2.0
+    , base     ^>=4.21.2.0
     , gyehoek
 
   hs-source-dirs:   app
@@ -44,25 +48,29 @@ executable gyehoek
 
 library
   import:           ghcstuffs, ghcstuffs-dev
-  ghc-options: -fplugin=Effectful.Plugin
+  ghc-options:      -fplugin=Effectful.Plugin
 
   -- cabal-fmt: expand src
   exposed-modules:
+    Gyehoek.CPS.Close
     Gyehoek.CPS.Convert
     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
-    Gyehoek.Driver
 
   build-depends:
     , base                  ^>=4.21.2.0
     , binary
+    , bytestring
     , containers
-    , cradle
     , effectful
     , effectful-core
     , effectful-plugin
@@ -74,30 +82,48 @@ library
     , megaparsec
     , mtl
     , optparse-applicative
+    , pretty-simple
     , prettyprinter
     , process
     , recursion-schemes
     , sexp-grammar
+    , string-interpolate
     , template-haskell
     , text
     , text-short
+    , typed-process
     , unordered-containers
     , vector
-    , string-interpolate
-    , pretty-simple
 
   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
-    build-depends:    base
-                    , gyehoek
-                    , filepath
-                    , tasty
-                    , tasty-silver
-                    , directory
-    default-language: GHC2024
+  import:           ghcstuffs, ghcstuffs-dev
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   test
+  main-is:          Main.hs
+  other-modules:
+    Gyehoek.Test.CPS.Stackify
+    Gyehoek.Test.CPS.Syntax
+    Gyehoek.Test.Golden
+    Gyehoek.Test.Sexp
+    Gyehoek.Test.Stack.VM
+
+  build-depends:
+    , base
+    , directory
+    , effectful
+    , filepath
+    , generic-lens
+    , gyehoek
+    , lens
+    , process-extras
+    , text
+    , sexp-grammar
+    , tasty
+    , tasty-hunit
+    , tasty-silver
+    , tasty-expected-failure
+
+  default-language: GHC2024

index.html

@@ -1,20 +0,0 @@
-<html>
-  <head>
-    <script>
-      const imports = {
-          guppy: {
-              print: (arg) => console.log (arg)
-          }
-      }
-
-      fetch("u.wasm")
-    .then((response) => response.arrayBuffer())
-    .then((bytes) => WebAssembly.instantiate(bytes, imports))
-    .then((results) => {
-        results.instance.exports.main ();
-    });
-    </script>
-  </head>
-  <body>
-  </body>
-</html>

runtime/.gitignore

@@ -0,0 +1 @@
+target/

runtime/Cargo.toml

@@ -0,0 +1,10 @@
+[package]
+name = "gyehoek-runtime"
+version = "0.1.0"
+edition = "2024"
+
+[dependencies]
+clap = { version = "4.6.1", features = ["derive"] }
+clio = { version = "0.3.5", features = ["clap-parse"] }
+memoize = "0.6.0"
+wasmtime = "46.0.1"

runtime/default.nix

@@ -0,0 +1,13 @@
+{ rustPlatform
+, lib
+, crane-lib
+}:
+
+crane-lib.buildPackage (lib.fix (finalAttrs: {
+  pname = "gyehoek-runtime";
+  version = "0.1.0";
+  src = ./.;
+  # cargoLock = ./Cargo.lock;
+  doCheck = true;
+  meta.mainProgram = "gyehoek-runtime";
+}))

runtime/src/gyehoek.rs

@@ -0,0 +1,38 @@
+use wasmtime::*;
+use crate::internal as scm;
+use crate::internal::{Scm,Immediate,HeapObject};
+
+// pub fn small_fixnum_p (_)
+
+// pub fn immediate_p (caller : Caller<'_, u32>, x : EqRef) -> EqRef {
+//     x.is_i31 ()
+// }
+
+fn write_immediate (_caller : Caller<'_, u32>, imm : Immediate) {
+    match imm {
+        Immediate::SmallFixnum (n) => print! ("{}", n),
+        Immediate::Bool (b) => print! ("{}", if b { "#t" } else { "#f" }),
+    }
+}
+
+pub fn write (caller : Caller<'_, u32>, x : Rooted<EqRef>) {
+    match scm::interpret (&caller, x).unwrap ().unwrap () {
+        Scm::Immediate (x) => write_immediate (caller, x),
+        Scm::HeapObject (x) => write_heap_object (caller, x),
+    }
+}
+
+fn write_heap_object (_caller : Caller<'_, u32>, x : HeapObject) {
+    match x {
+        HeapObject::Procedure => print! ("#<procedure>"),
+    }
+}
+
+pub fn truthy_p (caller : Caller<'_, u32>, x : Rooted<EqRef>,) -> u32 {
+    let r = scm::interpret (&caller, x).unwrap ().unwrap ();
+    if let Scm::Immediate (Immediate::Bool (false)) = r {
+        0
+    } else {
+        1
+    }
+}

runtime/src/internal.rs

@@ -0,0 +1,99 @@
+use wasmtime::*;
+use crate::types;
+
+pub fn immediate_p (store : impl AsContext, x : Rooted<EqRef>) -> bool {
+    x.is_i31 (store).unwrap ()
+}
+
+pub enum Immediate {
+    SmallFixnum (i32),
+    Bool (bool),
+}
+
+pub enum HeapObject {
+    Procedure
+}
+
+pub enum Scm {
+    Immediate (Immediate),
+    HeapObject (HeapObject),
+}
+
+#[allow(nonstandard_style)]
+pub type scm_bits = u32;
+
+#[allow(nonstandard_style)]
+pub const scm_false : scm_bits = 0b01;
+#[allow(nonstandard_style)]
+pub const scm_true : scm_bits = 0b11;
+
+pub fn interpret_immediate (x : scm_bits) -> Option<Immediate> {
+    if x & 1 == 0 {
+        Some (Immediate::SmallFixnum ((x >> 1).try_into ().unwrap ()))
+    } else if x == scm_true {
+        Some (Immediate::Bool (true))
+    } else if x == scm_false {
+        Some (Immediate::Bool (false))
+    } else {
+        None
+    }
+}
+
+pub fn interpret_heap_object (
+    store : impl AsContext,
+    x : Rooted<EqRef>
+) -> Result<Option<HeapObject>> {
+    if x.matches_ty (&store, &types::closure (&store)?)? {
+        Ok (Some (HeapObject::Procedure))
+    } else {
+        todo! ()
+    }
+}
+
+pub fn interpret (
+    store : impl AsContext,
+    x : Rooted<EqRef>
+) -> Result<Option<Scm>> {
+    if let Some (imm) = x.as_i31 (&store)? {
+        Ok (
+            interpret_immediate (imm.get_u32 ())
+                .map (Scm::Immediate)
+        )
+    } else {
+        Ok (
+            interpret_heap_object (&store, x)?
+                .map (Scm::HeapObject)
+        )
+    }
+}
+
+pub fn encode_immediate (
+    store : impl AsContext,
+    imm : Immediate
+) -> scm_bits {
+    use Immediate::*;
+    match imm {
+        SmallFixnum (n) => (n << 1).try_into ().unwrap (),
+        Bool (false) => scm_false,
+        Bool (true) => scm_true,
+    }
+}
+
+pub fn encode (store : impl AsContextMut, x : Scm) -> Rooted<EqRef> {
+    match x {
+        Scm::Immediate (imm) => {
+            let i31 = I31::new_u32 (encode_immediate (&store, imm))
+                .unwrap ();
+            EqRef::from_i31 (store, i31)
+        }
+        Scm::HeapObject (ho) => {
+            todo! ()
+        }
+    }
+}
+
+pub fn encode_bool (store : impl AsContextMut, b : bool) -> Rooted<EqRef> {
+    let x = if b { scm_true } else { scm_false };
+    let i31 = I31::new_u32 (x).unwrap ();
+    EqRef::from_i31 (store, i31)
+}

runtime/src/main.rs

@@ -0,0 +1,53 @@
+mod gyehoek;
+mod internal;
+mod types;
+
+use std::io;
+use std::io::Read;
+use clio::*;
+use clap::Parser;
+use wasmtime::*;
+
+/// A runtime for Gyehoek scheme.
+#[derive(Parser, Debug)]
+#[command(name = "gyehoek", version, about, long_about = None)]
+struct Args {
+    /// Path to Wasm binary or textual source
+    #[clap(value_parser)]
+    wasm: Input,
+}
+
+fn read<R : Read> (mut rdr : R) -> io::Result<Vec<u8>> {
+    let mut buf = vec! [];
+    rdr.read_to_end (&mut buf)?;
+    Ok (buf)
+}
+
+fn get_config () -> Config {
+    let mut cfg = Config::new ();
+    cfg.wasm_reference_types (true);
+    cfg.wasm_function_references (true);
+    cfg.wasm_tail_call (true);
+    cfg.wasm_gc (true);
+    cfg
+}
+
+fn link_primitives (linker : &mut Linker<u32>) -> wasmtime::Result<()> {
+    linker.func_wrap ("gyehoek", "write", gyehoek::write)?;
+    linker.func_wrap ("gyehoek", "truthy?", gyehoek::truthy_p)?;
+    Ok (())
+}
+
+pub fn main () -> wasmtime::Result<()> {
+    let args = Args::parse ();
+    let wasm_config = get_config ();
+    let engine = Engine::new (&wasm_config)?;
+    let module = Module::new (&engine, read (args.wasm)?)?;
+    let mut linker = Linker::new (&engine);
+    link_primitives (&mut linker)?;
+    let mut store : Store<u32> = Store::new (&engine, 4);
+    let instance = linker.instantiate (&mut store, &module)?;
+    let main = instance.get_typed_func::<(),()> (&mut store, "main")?;
+    main.call (&mut store, ())?;
+    Ok (())
+}

runtime/src/types.rs

@@ -0,0 +1,62 @@
+use wasmtime::*;
+use memoize::memoize;
+
+pub fn heap_object_struct (store : impl AsContext) -> Result<StructType> {
+    let ctx = store.as_context ();
+    let engine = ctx.engine ();
+    Ok (
+        StructType::with_finality_and_supertype (
+            engine,
+            Finality::NonFinal,
+            None,
+            vec![
+                hash_field ()
+            ]
+        )?
+    )
+}
+
+pub fn heap_object (_store : impl AsContext) -> Result<HeapType> {
+    todo! ()
+}
+
+#[memoize]
+pub fn hash_field () -> FieldType {
+    FieldType::new (
+        Mutability::Var,
+        StorageType::ValType (ValType::I32)
+    )
+}
+
+pub fn closure (store : impl AsContext) -> Result<HeapType> {
+    let ctx = store.as_context ();
+    let engine = ctx.engine ();
+    Ok (
+        HeapType::ConcreteStruct (
+            StructType::with_finality_and_supertype (
+                engine,
+                Finality::NonFinal,
+                Some (&heap_object_struct (&store)?),
+                vec![
+                    hash_field (),
+                    FieldType::new (
+                        Mutability::Const,
+                        StorageType::ValType (ValType::Ref (
+                            RefType::new (
+                                false,
+                                HeapType::ConcreteFunc (
+                                    FuncType::new (
+                                        engine,
+                                        vec![ValType::I32],
+                                        vec![],
+                                    )
+                                )
+                            )
+                        ))
+                    ),
+                ]
+            )?
+        )
+    )
+}
+

src/Gyehoek/CPS/Close.hs

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

src/Gyehoek/CPS/Convert.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE OverloadedLists #-}
+{- HLINT ignore "Use camelCase" -}
 module Gyehoek.CPS.Convert
-  ( convert
-  , convertProgram
+  ( convertProgram
+  , convertExp
   ) where
 
 import Gyehoek.CPS.Syntax
@@ -12,6 +13,11 @@ import Effectful
 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)
 
 
 -- 뻘짓이어라
@@ -21,6 +27,14 @@ telescope
   -> t a -> (t b -> r) -> r
 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
@@ -31,21 +45,23 @@ convert (Scm.ExpLit l) k = k $ ValLit l
 convert (Scm.ExpPrim p) k =
   telescope (convert @es) p \p' -> do
     r <- gensym' "r"
-    ExpPrim p' [r] <$> k (ValVar 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']
-  ExpLet [(f, MkLambda xs ktail m)] <$> k (ValVar f)
+  lam <- convertLambda xs e
+  ke <- k $ ValVar f
+  pure [cps|
+    (letrec ((#{f} #{lam}))
+      #{ke})
+  |]
 
 convert (Scm.ExpApply f xs) k =
   telescope (convert @es) (f:|xs) \(f':|xs') -> do
     r <- gensym' "r"
     x <- gensym' "x"
     m <- k (ValVar x)
-    pure $ ExpFix [(r, MkKappa [x] m)] $ ExpApply f' (xs' ++ [ValVar r])
+    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $ ExpApply f' xs' r
 
 convert (Scm.ExpBegin xs) k = _
 
@@ -53,7 +69,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 "letrec-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 =
@@ -61,3 +108,6 @@ convertProgram p =
     pure . Halt1 $ case NE.nonEmpty exps of
       Nothing -> ValLit Void
       Just es -> NE.last es
+
+convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
+convertExp e = convert e (pure . Halt1)

src/Gyehoek/CPS/Lower.hs

@@ -6,40 +6,36 @@
 {-# 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 Gyehoek.Scheme.Syntax qualified as Scm
-import Gyehoek.GenSym
-import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.Generics.Labels ()
 import Effectful
-import Control.Monad.Cont qualified as Cont
-import Effectful.Writer.Static.Local
 import Data.Text (Text)
 import Data.Vector.Strict (Vector)
-import Control.Lens
-import Data.Foldable
-import Data.HashMap.Strict (HashMap)
+import Control.Lens hiding (op)
 import Numeric.Natural
 import GHC.Generics (Generic)
-import Gyehoek.Scheme.Syntax (Lit(..))
-import Text.Printf
-import qualified Data.Text as T
 import qualified Data.Vector.Strict as V
-import Data.IntMap.Strict (IntMap)
-import Data.String.Interpolate
 import Gyehoek.Wasm qualified as Wasm
 import Gyehoek.Wasm hiding (Expr)
-import Language.Sexp.Located (pattern ParenList)
-import Debug.Pretty.Simple
+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
-  { runtime :: Runtime
-  , vars :: Vector Name
+  { vars :: Vector Name
   , kvars :: Vector Name
   }
   deriving (Show, Generic)
@@ -50,201 +46,305 @@ type instance IxValue Env = Name
 instance Ixed Env where
   ix i = #vars . ix (fromIntegral i)
 
-data Runtime = MkRuntime
-  { argArrayType :: Idx
-  , argArray :: Idx
-  , contType :: Idx
-  , contStackType :: Idx
-  , contStackTop :: Idx
-  , contStack :: Idx
-  , result :: Idx
-  , halt :: Idx
-  }
-  deriving (Show, Generic)
-
 
 
+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 = mconcat
-  [ ins "i32.const" [sxp @Int 1]
-  , ins "i32.shl" []
-  , ins "ref.i31" []
-  ]
+makeSmallFixnum = [expr|
+    (@gyehoek "construct small fixnum")
+    (i32.const 1)
+    i32.shl
+    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 :: Runtime -> Int -> Wasm.Expr -> Wasm.Expr
-pushArg (MkRuntime {argArrayType,argArray}) n e = mconcat
-  [ ins "global.get" [sxp argArray]
-  , ins "i32.const" [sxp n]
-  , e
-  , ins "array.set" [sxp argArrayType]
-  ]
+pushArg :: Natural -> Wasm.Expr -> Wasm.Expr
+pushArg n e = [expr|
+    (@gyehoek begin pushArg)
+    ##{e}
+    (global.set #{reg})
+    (@gyehoek end pushArg)
+  |]
+  where reg = getArgRegister n
 
 -- | Pop the nth arg from the arg-passing array onto the stack.
-popArg :: Runtime -> Int -> Wasm.Expr
-popArg (MkRuntime {argArrayType,argArray}) n = mconcat
-  [ ins "global.get" [sxp argArray]
-  , ins "i32.const" [sxp n]
-  , ins "array.get" [sxp argArrayType]
-  , ins "ref.as_non_null" []
-  ]
+popArg :: Natural -> Wasm.Expr
+popArg n = [expr|
+  (@gyehoek begin popArg)
+  (global.get #{reg})
+  ref.as_non_null
+  (@gyehoek end popArg)
+|]
+  where reg = getArgRegister n
 
 
 
-lowerVal :: Env -> Val -> Wasm.Expr
+lowerVal :: (HasCallStack, GenMod :> es) => Env -> Val -> Eff es Wasm.Expr
 
 lowerVal g (ValLit l) =
-  case l of
-    LitInt n -> 
-      ins "i32.const" [sxp n]
-      <> makeSmallFixnum
-    LitBool b ->
-      ins "i32.const" [sxp @Int $ if b then 1 else 0]
-      <> ins "ref.i31" []
+  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) = ins "local.get" [sxp (1+l)]
+lowerVal g (ValVar x) = do
+  pure [expr|(global.get #{l})|]
   where
-    l = V.elemIndex x g.vars ^?! _Just
+    l = getArgRegister . fromIntegral . succ $ V.elemIndex x g.vars ^?! _Just
 
 lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
 
-lower' g (Halt [v]) = pure . mconcat $
-  [ pushArg g.runtime 0 (lowerVal g v)
-  , ins "return_call" [sxp @Int 1]
-  ]
+lower' g (Halt [v]) = do
+  arg <- pushArg 0 <$> lowerVal g v
+  pure [expr|
+    ##{arg}
+    (return_call $halt (i32.const 1))
+  |]
 
-lower' g (ExpPrim p rs e) =
-  case p of
-    PrimAdd x y -> lowerBinOp "i32.add" g x y r e
-    PrimMul x y -> lowerBinOp "i32.mul" g x y r e
-  where
-    r = head rs
+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 $ lowerVal g c
-    <> Wasm.if' (Wasm.result [i32]) t' f'
+  pure [expr|
+    ##{c'}
+    (call $gh-truthy?)
+    (if (then ##{t'})
+        (else ##{f'}))
+  |]
 
-lower' g (ExpContinue k [x]) = pure . mconcat $
-  [ pushArg rt 0 (lowerVal g x)
-  , ins "i32.const" [sxp @Int 1] -- nargs
-  -- get the return continuation.
-  , ins "global.get" [sxp rt.contStack]
-  , ins "global.get" [sxp rt.contStackTop]
-  , ins "array.get" [sxp rt.contStackType]
-  , ins "ref.as_non_null" []
-  -- decrement contStackTop, completing the "pop."
-  , ins "global.get" [sxp rt.contStackTop]
-  , ins "i32.const" [sxp @Int (1 + l)]
-  , ins "i32.sub" []
-  , ins "global.set" [sxp rt.contStackTop]
-  , ins "return_call_ref" [sxp rt.contType]
-  ]
-  where
-    rt = g.runtime
-    l = V.elemIndex k g.kvars ^?! _Just
-
-lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
-  idx <- defun [i32] [] (replicate 5 scm) \_ -> do
-    let g' = g & #vars <>~ V.fromList xs
-               & #kvars <>~ [ktail]
-    m' <- lower' g' m
-    pure . mconcat $
-      [ xs & ifoldMap \n _ ->
-          popArg g.runtime n <> ins "local.set" [sxp (1+n)]
-      , m'
-      ]
-  declareFuncref idx
-  let g' = g & #vars <>~ [r]
-  let n = length g.vars
+lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do
+  idx <- lowerKappa g kap
+  let g' = g & #kvars <>~ [r]
   e' <- lower' g' e
-  pure . mconcat $
-    [ ins "ref.func" [sxp idx]
-    , ins "local.set" [sxp (n+1)]
-    , 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 e = error . show $ 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
+  let reg = getArgRegister . fromIntegral $ n
+  pure [expr|
+    (i32.const 0)
+    (ref.func #{idx})
+    (struct.new $closure)
+    (global.set #{reg})
+    ##{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 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))
+      ##{m'})
+  |]
+  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 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))
+      ##{m'})
+  |]
+  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
+  pure idx
 
 lowerBinOp
   :: (GenMod :> es)
-  => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
-lowerBinOp op g x y r e = do
+  => 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)
+  let reg = getArgRegister . fromIntegral $ n
+  x' <- lowerVal g x
+  y' <- lowerVal g y
   e' <- lower' g' e
-  pure . mconcat $
-    [ lowerVal g x
-    , ins "ref.cast" [sxp $ ref i31]
-    , ins "i31.get_s" []
-    , lowerVal g y
-    , ins "ref.cast" [sxp $ ref i31]
-    , ins "i31.get_s" []
-    , ins op []
-    , ins "ref.i31" []
-    , ins "local.set" [sxp (1+n)]
-    , e'
-    ]
-  where
-    g' = g & #vars <>~ [r]
-    n = length (g ^. #vars)
+  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}
+    (global.set #{reg})
+    ##{e'}
+  |]
 
 
 
-scm = ref eq
-
-
-
-emitRuntime :: GenMod :> es => Eff es Runtime
+emitRuntime :: GenMod :> es => Eff es ()
 emitRuntime = mfix \runtime -> do
-  heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
-    [ Wasm.mut i32 ]
+  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
-  contType <- Wasm.deftype $ Wasm.func [i32] []
-  contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType)
-  contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0]
-  contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $
-    ins "i32.const" [sxp @Int 128]
-    <> ins "array.new_default" [sxp contStackType]
-  -- arg array
-  argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq
-  argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $
-    ins "i32.const" [sxp @Int 32]
-    <> ins "array.new_default" [sxp argArrayType]
-  -- consIdx <- Wasm.defun _ _ _ _
-  result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq]
-  halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
-    pure . mconcat $
-      [ popArg runtime 0
-      , ins "global.set" [sxp result]
-      ]
-  pure $ MkRuntime
-    {argArray,argArrayType
-    ,contStack,contStackTop,contStackType,contType
-    ,result,halt}
-  -- pure $ error "todo"
+  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 registers
+  Wasm.defineGlobals [wats|
+    (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 $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|
+    (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 runtime mempty mempty
-  scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
-    lower' g e
-  main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
-    pure . mconcat $
-      -- push return cont
-      [--  ins "ref.func" [sxp halt]
-      -- make call
-      ins "i32.const" [sxp @Int 0]
-      , ins "call" [sxp scm_entry]
-      , ins "global.get" [sxp runtime.result]
-      , ins "ref.as_non_null" []
-      ]
-  Wasm.export "main" "func" main
-
+  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,148 @@
+{-# 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 Effectful
+import Gyehoek.GenSym
+import Effectful.Writer.Static.Shared
+import Control.Lens
+import Data.String.Interpolate
+import Gyehoek.Stack.Syntax (Imm(..))
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HS
+import GHC.Generics (Generic)
+import Data.Foldable
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as H
+import Data.HashSet.Lens (hashMap)
+import Data.List (List)
+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 && x /= g.returnLabel
+
+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)
+  lam_body <- gensym' "lambda-body"
+  m' <- stackify (g & #bound .~ H.fromList vs
+                    & #bound . at f ?~ Stk.ValLabel lam_body
+                    & #returnLabel .~ k) m
+  tell [Stk.MkBlock lam_body xs . toList $ m']
+  stackify (g & #bound . at f ?~ Stk.ValLabel lam_body) 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 (Stk.ValLabel k) ]
+    <> fromList [ Stk.Push (Stk.ValReg l) | l <- ls ]
+    <> [ Stk.Call (stackifyVal g f) (stackifyVal g <$> xs) ]
+  where
+    k = case var g ktail of
+      Stk.ValLabel x -> x
+      x -> error [i|expected a label, got #{x} (i guess)|]
+    ls = fold $ g ^. #liveness . at k
+
+-- this probably won't work for call/cc, for cps-converted code it'll
+-- be fine i think. notice how, instead of calling `var g k`, we just
+-- assume it's the return continuation on top of the stack.
+stackify g (ExpContinue k xs) = do
+  ktail <- gensym' $ k ^. _Wrapped'
+  pure [ Stk.PopCont ktail
+       , Stk.Call (Stk.ValReg ktail) (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)
+  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
+  , returnLabel :: Name
+  -- | 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)
+  }
+  deriving (Show, Generic)
+
+emptyEnv :: Env
+emptyEnv = MkEnv mempty "halt" mempty
+
+
+
+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

@@ -1,10 +1,15 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FunctionalDependencies #-}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)
   , Lambda(..)
   , Exp(..)
+  , ExpF(..)
   , Name(..)
   , Prim(..)
   , Program(..)
@@ -14,80 +19,130 @@ module Gyehoek.CPS.Syntax
   , pattern Halt1
   , _MkKappa
   , _ExpPrim
-  , _ExpFix
+  , _ExpLetRec
   , _ExpApply
+  , _AbsLambda'
+  , binders
+  , body
+  , op
+  , args
+  , cont
+  , cps
+  , pattern AbsLambda'
+  , pattern AbsKappa'
+  , Abs(..)
+  , Free(..)
+  , Vars(..)
+  , Subst(..)
   )
   where
 
 import Language.SexpGrammar qualified as S
 import Gyehoek.Sexp qualified
-import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void)
-import Data.Text (Text)
+import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void, getName)
 import Data.List (List)
 import GHC.Generics (Generic)
 import Language.SexpGrammar.Generic
 import Control.Category
-import Control.Lens
-import Data.Text qualified as T
-import Data.Generics.Labels
+import Control.Lens hiding (op)
 import Prelude hiding ((.), id)
 import Data.List.NonEmpty (NonEmpty)
-import Data.InvertibleGrammar.Base qualified as IGB
-import Data.InvertibleGrammar.Base ((:-)((:-)))
-import qualified Data.InvertibleGrammar as IG
+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.Functor.Foldable (Recursive(..), Corecursive (..))
 
 -- Data types
 
 data Val
-  = ValLabel Name
-  | ValVar Name
+  = ValVar Name
   | ValLit Lit
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data, Eq)
 
-data Kappa = MkKappa (List Name) Exp
-  deriving (Show, Generic)
+data Kappa = MkKappa { binders :: List Name, body :: Exp }
+  deriving (Show, Generic, Data, Eq)
 
-data Lambda = MkLambda (List Name) Name Exp
-  deriving (Show, Generic)
+data Lambda = MkLambda { binders :: List Name, ktail :: Name, body :: Exp }
+  deriving (Show, Generic, Data, Eq)
+
+data Abs
+  = AbsKappa Kappa
+  | AbsLambda Lambda
+  deriving (Show, Generic, Data, Eq)
+
+pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)
+pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 
 data Exp
-  = ExpPrim (Prim Val) (List Name) Exp
-  | ExpFix (NonEmpty (Name, Kappa)) Exp
-  | ExpLet (NonEmpty (Name, Lambda)) Exp
+  = ExpPrim (Prim Val) Kappa
+  | ExpLetRec { binders :: NonEmpty (Name, Abs), body :: Exp }
   | ExpContinue Name (List Val)
   | ExpIf Val Exp Exp
-  | ExpApply Val (List Val)
-  deriving (Show, Generic)
+  | ExpApply
+    { op :: Val
+    , args :: List Val
+    , cont :: Name
+    }
+  deriving (Show, Generic, Data, Eq)
 
 pattern Halt :: List Val -> Exp
-pattern Halt xs = ExpApply (ValVar "halt") xs
+pattern Halt xs = ExpContinue "halt" xs
 
 pattern Halt1 :: Val -> Exp
-pattern Halt1 x = ExpApply (ValVar "halt") [x]
+pattern Halt1 x = ExpContinue "halt" [x]
 
 data Def = DefConstant Name Exp
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data Program = MkProgram
   { body :: Exp
   }
-  deriving (Show, Generic)
+  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
+  binders k (AbsLambda lam) = AbsLambda <$> binders k lam
+
+instance HasBody Abs Exp where
+  body k (AbsKappa kap) = AbsKappa <$> body k kap
+  body k (AbsLambda lam) = AbsLambda <$> body k lam
+
+_AbsLambda' :: Prism' Abs (List Name, Name, Exp)
+_AbsLambda' = prism'
+  (\(bs,ktail,e) -> AbsLambda' bs ktail e)
+  (\case AbsLambda' bs ktail e -> Just (bs,ktail,e)
+         _ -> Nothing)
 
 
 -- SexpIso instances
 
 instance S.SexpIso Val where
   sexpIso = match
-    $ With (. label)
-    $ With (. var)
-    $ With (. S.sexpIso)
+    $ With (\var -> var . S.sexpIso)
+    $ With (\lit -> lit . S.sexpIso)
     $ End
-    where
-      label = S.keyword >>> S.iso MkName getName
-      var = S.sexpIso
 
 instance S.SexpIso Lambda where
   sexpIso = match
@@ -96,9 +151,18 @@ instance S.SexpIso Lambda where
     where
       lambda = S.list $
         S.el Gyehoek.Sexp.lambdaKeyword
-        >>> S.el (S.list (S.rest S.sexpIso))
-        >>> S.el S.sexpIso
+        >>> S.el binders
         >>> S.el S.sexpIso
+      binders :: forall t.
+        IG.Grammar S.Position (Sexp :- t) (Name :- List Name :- t)
+      binders = S.list $
+        S.rest (S.sexpIso @Name)
+        >>> S.onTail (S.flipped $ IG.PartialIso
+                     (\(ktail:-args:-t) -> (args ++ [ktail]) :- t)
+                     (\(args:-t) -> case args ^? _Snoc of
+                         Just (args',ktail) -> Right $ ktail :- args' :- t
+                         Nothing -> Left $ S.expected "cont param")
+                     )
 
 instance S.SexpIso Kappa where
   sexpIso = match
@@ -110,11 +174,16 @@ instance S.SexpIso Kappa where
         >>> S.el (S.list $ S.rest S.sexpIso)
         >>> S.el S.sexpIso
 
+instance S.SexpIso Abs where
+  sexpIso = match
+    $ With (\lambda -> lambda . S.sexpIso)
+    $ With (\kappa -> kappa . S.sexpIso)
+    $ End
+
 instance S.SexpIso Exp where
   sexpIso = match
     $ With (. prim)
-    $ With (. fix)
-    $ With (. let_)
+    $ With (. letrec)
     $ With (. continue)
     $ With (. if_)
     $ With (. app)
@@ -124,16 +193,170 @@ instance S.SexpIso Exp where
         S.el (S.sym "continue")
         >>> S.el S.sexpIso
         >>> S.rest S.sexpIso
-      fix = Gyehoek.Sexp.let_ "fix" S.sexpIso S.sexpIso S.sexpIso
-      let_ = Gyehoek.Sexp.let_ "let" S.sexpIso S.sexpIso 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
-      app = S.list $ S.el S.sexpIso >>> S.rest S.sexpIso
+      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)
+        -- >>> _
+        >>> S.onTail (S.flipped $ IG.PartialIso
+                      (\(karg :- args :- op :- t) ->
+                         (args ++ [ValVar karg]) :- op :- t)
+                      (\(xs :- op :- t) -> case xs ^? _Snoc of
+                          Just (args,preview #ValVar -> Just karg) ->
+                            Right $ karg:- args :- op :- t
+                          _ -> Left $ S.expected "continuation arg"
+                      ))
+        where
+          _ = S.flipped $ Gyehoek.Sexp.nonEmptyGrammar @S.Position @Val
       prim = S.list $
         S.el (S.sym "prim")
         >>> S.el (primSexpIso id (S.sexpIso @Val))
         >>> S.el S.sexpIso
-        >>> S.el S.sexpIso
 
 instance S.SexpIso Program where
   sexpIso = with \prog -> S.sexpIso @Exp >>> prog
+
+
+-- quasiquoters
+
+class Data a => CPS a where
+  toCPS :: Sexp -> 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 Program where toCPS = Gyehoek.Sexp.fromSexp
+
+cps :: QuasiQuoter
+cps = Gyehoek.Sexp.makeSx' [| toCPS |]
+
+
+
+deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
+deleteFrom = flip $ foldr HS.delete
+
+insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
+insertFrom = flip $ foldr HS.insert
+
+toHashSetOf :: Hashable a => Getting (Endo (HashSet a)) s a -> s -> HashSet a
+toHashSetOf l = foldrOf l HS.insert mempty
+
+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 & toListOf (folded . #ValVar . filtered (`notElem` bound))
+        & (<> freeWithBound' bound k)
+    ExpLetRec bs m ->
+      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))
+
+instance Free Kappa where
+  freeWithBound' bound (MkKappa xs m) =
+    freeWithBound' (bound & insertFrom xs) m
+
+instance Free Lambda where
+  freeWithBound' bound (MkLambda xs k m) =
+    freeWithBound' (bound & insertFrom (k:xs)) m
+
+
+
+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
+
+
+
+data Scope
+  = Bind (List Name) (List Scope)
+  | Use (List Name) (List Scope)
+  deriving (Show, Eq)
+
+makeBaseFunctor ''Scope
+
+class Scoped a where
+  scope :: a -> Scope
+
+instance Scoped Kappa where
+  scope (MkKappa bs e) =
+    Bind bs [scope e]
+
+instance Scoped Lambda where
+  scope (MkLambda bs k e) = Bind (bs ++ [k]) [scope e]
+
+instance Scoped Abs where
+  scope = \case
+    AbsKappa k -> scope k
+    AbsLambda l -> scope l
+
+instance Scoped Val where
+  scope = \case
+    ValVar x -> Use [x] []
+    _ -> Use [] []
+
+instance Scoped Exp where
+  scope = \case
+    ExpApply f xs k ->
+      Use (((f:xs) ^.. each . _ValVar) ++ [k]) []
+    ExpLetRec bs e ->
+      Bind (bs ^.. each . _1) $
+        (bs ^.. each . _2 . to scope)
+        ++ [scope e]
+    ExpPrim p k ->
+      Use (p ^.. each . _ValVar) [scope k]
+    ExpContinue k xs ->
+      Use (k : (xs ^.. each . _ValVar)) []
+    ExpIf c t f ->
+      Use (c ^.. _ValVar) [ scope t, scope f ]
+
+
+
+class Subst a where
+  substWith :: (Name -> Maybe Val) -> a -> a
+
+instance Subst Exp where
+  substWith f = go HS.empty where
+    go bound e = case scope e of
+      Use xs ss -> _

src/Gyehoek/Driver.hs

@@ -1,44 +1,39 @@
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE OrPatterns #-}
 module Gyehoek.Driver
-  (main, lower_e2e, convert_e2e, parse_e2e)
+  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e)
   where
 
 import Gyehoek.Options
-import qualified Data.Text.IO as TIO
 import Data.Text (Text)
 import Prelude hiding (readFile)
 import Options.Applicative
 import Control.Lens
-import Data.Generics.Labels
-import System.OsPath (OsPath)
-import System.FilePath ((-<.>), dropExtension)
 import Effectful.FileSystem
 import Effectful
 import Effectful.FileSystem.IO qualified as FS
 import Effectful.FileSystem.IO.ByteString qualified as FB
-import Gyehoek.GenSym (runGenSym, GenSym, gensym, gensym')
+import Gyehoek.GenSym (runGenSym, GenSym)
 import qualified Gyehoek.Sexp as Sexp
-import Data.Text.Lens
-import Data.List (List)
 import qualified Gyehoek.Scheme.Syntax as Scm
-import Effectful.Exception
-import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import System.IO (Handle)
-import Data.List.NonEmpty (NonEmpty)
-import qualified Cradle as C
+import System.IO qualified as IO
 import Gyehoek.CPS.Convert
 import Gyehoek.CPS.Lower
-import Data.Foldable
-import qualified Gyehoek.Scheme.Syntax
 import Gyehoek.CPS.Syntax qualified as Cps
-import Data.Maybe (fromMaybe)
 import Control.Monad
-import Text.Pretty.Simple (pShow, pShowNoColor)
+import Text.Pretty.Simple (pShowNoColor)
+import System.Process.Typed
+import Data.Text.Encoding (encodeUtf8)
+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 (encodeProgram)
 
 
 main :: IO ()
@@ -48,8 +43,8 @@ main = do
 
 
 
-hPutStr :: FileSystem :> es => Handle -> Text -> Eff es ()
-hPutStr h = FB.hPutStr h . T.encodeUtf8
+-- hPutStr :: FileSystem :> es => Handle -> Text -> Eff es ()
+-- hPutStr h = FB.hPutStr h . T.encodeUtf8
 
 hPutStrLn :: FileSystem :> es => Handle -> Text -> Eff es ()
 hPutStrLn h = FB.hPutStrLn h . T.encodeUtf8
@@ -57,8 +52,8 @@ hPutStrLn h = FB.hPutStrLn h . T.encodeUtf8
 hGetContents :: FileSystem :> es => Handle -> Eff es Text
 hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
 
-readFile :: FileSystem :> es => FilePath -> Eff es Text
-readFile f = FS.withFile f FS.ReadMode hGetContents
+-- readFile :: FileSystem :> es => FilePath -> Eff es Text
+-- readFile f = FS.withFile f FS.ReadMode hGetContents
 
 withFile
   :: (FileSystem :> es)
@@ -67,12 +62,41 @@ withFile "-" FS.ReadMode k = k FS.stdin
 withFile "-" (FS.WriteMode; FS.AppendMode) k = k FS.stdout
 withFile f m k = FS.withFile f m k
 
+fileName :: FilePath -> FilePath
+fileName "-" = "<interactive>"
+fileName e = e
+
 readScm :: FileSystem :> es => FilePath -> Eff es Scm.Program
 readScm f =
   withFile f FS.ReadMode $ \h ->
-    Sexp.parseSexps @Scm.CommandOrDef f <$> hGetContents h
+    Sexp.parseSexps @Scm.CommandOrDef (fileName f) <$> hGetContents h
      >>= either error (pure . Scm.MkProgram)
 
+inspectWasm :: IOE :> es => Text -> Eff es ()
+inspectWasm wat = do
+  pager_cmd <- liftIO $ getEnvDefault "PAGER" "less"
+  let wasmtools_cfg
+        = proc "wasm-tools" ["print", "-pf", "--print-operand-stack"
+                            ,"--color", "always", "-"]
+          -- & setStdin (byteStringInput . view lazy . encodeUtf8 $ wat)
+          -- & setStdout byteStringOutput
+          & setStdin createPipe
+          & setStdout createPipe
+          & setStderr inherit
+  let pager_cfg = proc pager_cmd []
+                & setStdin createPipe
+                & setStdout inherit
+                & setStderr inherit
+  liftIO $ withProcessWait_ wasmtools_cfg \wasmtools -> do
+    TIO.hPutStrLn (getStdin wasmtools) wat
+    IO.hFlush (getStdin wasmtools)
+    IO.hClose (getStdin wasmtools)
+    withProcessWait_ pager_cfg \pager -> do
+      t <- BS.hGetContents (getStdout wasmtools)
+      BS.hPut (getStdin pager) t
+      IO.hFlush (getStdin pager)
+      IO.hClose (getStdin pager)
+
 driver
   :: (GenSym :> es, FileSystem :> es, IOE :> es)
   => Options -> Eff es ()
@@ -83,9 +107,19 @@ driver opts = do
   cps <- convertProgram scm
   when opts.dumpCPS do
     hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
-  wat <- lowerProgram cps
-  withFile opts.output FS.WriteMode \h ->
-    hPutStrLn h wat
+  stk <- stackifyProgram cps
+  if opts.dumpStackified then do
+    hPutStrLn FS.stdout . encodeProgram $ stk
+  else if opts.stackify then do
+    eval stk & fmap writeObj
+             & T.unwords
+             & hPutStrLn FS.stdout
+  else do
+    wat <- lowerProgram cps
+    withFile opts.output FS.WriteMode \h ->
+      hPutStrLn h wat
+    when opts.inspectWasm do
+      inspectWasm wat
 
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runEff . runFileSystem . readScm
@@ -97,3 +131,8 @@ lower_e2e :: FilePath -> IO Text
 lower_e2e =
   runEff . runFileSystem . runGenSym
   . (lowerProgram <=< convertProgram <=< readScm)
+
+eval_e2e :: FilePath -> IO (List Obj)
+eval_e2e fp = runEff . runFileSystem . runGenSym $ do
+  stk <- stackifyProgram <=< convertProgram <=< readScm $ fp
+  pure . eval $ stk

src/Gyehoek/Options.hs

@@ -15,10 +15,11 @@ import GHC.Generics (Generic)
 
 
 data Options = MkOptions
-  { -- dumpANF :: Maybe FilePath
-  -- , dumpQBE :: Maybe FilePath
-  dumpCPS :: Bool
+  { dumpCPS :: Bool
   , dumpParsed :: Bool
+  , dumpStackified :: Bool
+  , stackify :: Bool
+  , inspectWasm :: Bool
   , output :: FilePath
   , sourceFile :: FilePath
   }
@@ -48,11 +49,17 @@ parseOutput = strOption
     )
 
 parseDumpCPS = switch (long "dump-cps")
+parseDumpStackified = switch (long "dump-stackified")
+parseStackify = switch (long "stackify")
 parseDumpParsed = switch (long "dump-parsed")
+parseInspectWasm = switch $ long "inspect-wasm" <> short 'p'
 
 parser :: Parser Options
 parser = MkOptions
   <$> parseDumpCPS
   <*> parseDumpParsed
+  <*> parseDumpStackified
+  <*> parseStackify
+  <*> parseInspectWasm
   <*> parseOutput
   <*> argument str (metavar "FILE")

src/Gyehoek/Scheme/Syntax.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE OrPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.Scheme.Syntax
   ( Name(..)
   , Prim(..)
@@ -20,41 +21,54 @@ module Gyehoek.Scheme.Syntax
   , primSexpIso
   , pattern Void
   , free
-  , qexp
-  , qprog
   , subst
-  , freeVariables
+  , getName
+  , scm
+  , readExp
+  , readProgram
   )
   where
 
 import Data.Text (Text)
 import Data.List (List)
 import Language.SexpGrammar
-  ( SexpIso(..), list, el, (>>>), rest, sym, symbol )
+  ( 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 Data.List.NonEmpty (NonEmpty)
 import Gyehoek.Sexp qualified
 import Gyehoek.GenSym (Gen)
 import Control.Lens
 import Data.String (IsString)
 import Data.Hashable (Hashable)
-import Control.Lens.Unsound (prismSum)
 import Data.Data (Data)
 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 Language.Haskell.TH.Quote (QuasiQuoter)
+import Effectful.FileSystem (runFileSystem)
+import qualified Effectful.FileSystem.IO as FS
+import qualified Data.Text.Encoding as T
+import qualified Effectful.FileSystem.IO.ByteString as FB
 
 
-newtype Name = MkName { getName :: Text }
-  deriving newtype (Show, Eq, IsString, Gen, Hashable)
+newtype Name = MkName { inner :: Text }
+  deriving newtype (Show, Eq, Ord, IsString, Gen, Hashable)
   deriving stock (Generic, Data)
+  deriving anyclass (Wrapped)
+
+instance Prefixed Name where
+  prefixed (MkName s) = _Wrapped' . prefixed @Text s . from _Wrapped'
+
+getName :: Name -> Text
+getName (MkName x) = x
 
 data Prim e
   = PrimAdd e e
@@ -70,7 +84,9 @@ data Prim e
   | PrimWrite e
   | PrimZeroP e
   | PrimNewline
-  deriving (Show, Generic, Functor, Foldable, Traversable, Data)
+  | PrimMakeClosure { code :: e, env :: List e }
+  | PriEnvRef e Int
+  deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
 
 instance Each (Prim e) (Prim e') e e'
 
@@ -80,7 +96,7 @@ data Lit
   | LitBool Bool
   | LitString Text
   | LitQuote Sexp
-  deriving (Show, Generic, Data)
+  deriving (Show, Generic, Data, Eq)
 
 pattern Void :: Lit
 pattern Void = LitNil
@@ -92,6 +108,7 @@ data Def
 
 data Exp
   = ExpLet (NonEmpty (Name, Exp)) Exp
+  | ExpLetRec (NonEmpty (Name, Exp)) Exp
   | ExpPrim (Prim Exp)
   | ExpBegin (List Exp)
   | ExpIf Exp Exp Exp
@@ -105,7 +122,7 @@ data Sexp
   = SexpCons Sexp Sexp
   | SexpSymbol Text
   | SexpLit Lit
-  deriving (Show, Generic, Data)
+  deriving (Show, Generic, Data, Eq)
 
 data CommandOrDef
   = Command Exp
@@ -122,8 +139,6 @@ instance Each Program Program (Either Exp Def) (Either Exp Def) where
   each = #commandsAndDefs . each . go
     where
       inj = either Command Definition
-      toeither (Command e) = Left e
-      toeither (Definition d) = Right d
       go :: Traversal' CommandOrDef (Either Exp Def)
       go k (Command e) = inj <$> k (Left e)
       go k (Definition d) = inj <$> k (Right d)
@@ -154,12 +169,16 @@ primSexpIso namefn a = match
     $ With (. unop "write")
     $ With (. unop "zero?")
     $ With (. nullop "newline")
+    $ With (. mkclosure)
+    $ With (. envref)
     $ End
     where
       idn s = el (sym (namefn s))
       nullop s = list $ idn s
       unop s = list $ idn s >>> el a
       binop s = list $ idn s >>> el a >>> el a
+      mkclosure = list $ idn "make-closure" >>> el a >>> rest a
+      envref = list $ idn "env-ref" >>> el a >>> el Sexp.int
 
 instance SexpIso a => SexpIso (Prim a) where
   -- sexpIso = primSexpIso ("prim:"<>) sexpIso
@@ -169,23 +188,14 @@ instance SexpIso Lit where
   sexpIso = match
     $ With (. sexpIso)
     $ With (. sym "nil")
-    $ With (. bool)
+    $ With (. Gyehoek.Sexp.schemeBool)
     $ With (. sexpIso)
     $ With (. Gyehoek.Sexp.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 (\cons -> cons . Gyehoek.Sexp.todo)
+    $ With (\conss -> conss . Gyehoek.Sexp.todo)
     $ With (\s -> s . symbol)
     $ With (\lit -> lit . sexpIso)
     $ End
@@ -203,6 +213,7 @@ instance SexpIso Def where
 instance SexpIso Exp where
   sexpIso = match
     $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
+    $ With (. Gyehoek.Sexp.let_ "letrec" sexpIso sexpIso sexpIso)
     $ With (. sexpIso)
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
     $ With (. if_)
@@ -230,8 +241,8 @@ instance SexpIso CommandOrDef where
 
 -- utilities
 
-qexp = Gyehoek.Sexp.makeSx $ sexpIso @Exp
-qprog = Gyehoek.Sexp.makeSxs (sexpIso @CommandOrDef) MkProgram
+scm :: QuasiQuoter
+scm = Gyehoek.Sexp.makeSx [|| Gyehoek.Sexp.fromSexp @Exp ||]
 
 free :: Exp -> HashSet Name
 free = cata \case
@@ -255,12 +266,21 @@ subst f = \e -> cata go e mempty where
   go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
   go e bound = embed $ fmap ($ bound) e
 
--- | Unlawful!
-freeVariables :: Traversal Exp Exp Name Exp
-freeVariables k = \e -> cataA go e mempty where
-  go (ExpVarF x) bound
-    | not (x `HS.member` bound) = k x
-    | otherwise                 = pure $ ExpVar x
-  go (ExpLetF _ _) _ = error "todo lol"
-  go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
-  go e bound = embed <$> traverse ($ bound) e
+
+
+fileName :: FilePath -> FilePath
+fileName "-" = "<interactive>"
+fileName e = e
+
+hGetContents :: FS.FileSystem :> es => FS.Handle -> Eff es Text
+hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
+
+readProgram :: IOE :> es => FilePath -> Eff es Program
+readProgram fp = runFileSystem $
+  FS.withFile fp FS.ReadMode $ \h ->
+    Gyehoek.Sexp.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h
+     >>= either error (pure . MkProgram)
+
+readExp :: IOE :> es => FilePath -> Eff es Program
+readExp fp = readProgram fp <&>
+  (^?! (#commandsAndDefs . _head . _Comm))

src/Gyehoek/Sexp.hs

@@ -27,6 +27,7 @@ module Gyehoek.Sexp
   , encodePretty
   , UglySexpIso(..)
   , AsSexpIso(..)
+  , SpliceSexp(..)
   , parseSexpsWithPos
   , parseSexpWithPos
   , parseSexp
@@ -34,11 +35,25 @@ module Gyehoek.Sexp
   , sxs
   , makeSx
   , makeSxs
+  , makeSx'
+  , toSexp
+  , fromSexp
+  , fromSexp'
+  , stripLocation
+  , format
+  , equivalent
+  , encodeOrShow
+  , readSxs
+  , prismIso
+  , schemeBool
+  , headTagged1'
+  , headTagged1
+  , headTagged2
   )
-where
+  where
 
 import Data.Text (Text)
-import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty)
+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
@@ -51,7 +66,7 @@ import Data.List (List, groupBy)
 import Data.Text.Encoding
 import Data.Either (either)
 import GHC.Generics (Generic)
-import Control.Lens
+import Control.Lens hiding (para)
 import Data.Generics.Labels
 import System.Process
 import GHC.IO.Unsafe (unsafePerformIO)
@@ -62,11 +77,27 @@ import Data.Void (absurd, Void)
 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)
+import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE, 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)
+import Data.Data (Data (..), Typeable, cast)
+import Language.Haskell.TH.Syntax (lift, Lift, liftData)
+import GHC.IsList (fromList)
+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
@@ -74,6 +105,9 @@ sexp = iso
   (either error id . encode)
   (either error id . decode)
 
+format :: Sexp -> Text
+format = decodeUtf8 . view strict . SL.format
+
 encode :: SexpIso a => a -> Either String Text
 encode = encodeWith sexpIso
 
@@ -91,25 +125,53 @@ decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8
 
 encodePrettyWith :: SexpGrammar a -> a -> Either String Text
 encodePrettyWith g =
-  (_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g 
+  (_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g
 
 parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
 parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
-  where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
+  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 (fromSexp sexpIso)
+  where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso)
+
+readSexpWithPos :: Position -> Text -> Either String Sexp
+readSexpWithPos pos = SL.parseSexpWithPos pos . view lazy . encodeUtf8
+
+readSexpsWithPos :: Position -> Text -> Either String (List Sexp)
+readSexpsWithPos pos = SL.parseSexpsWithPos pos . view lazy . encodeUtf8
 
 parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a)
 parseSexpsWithPos g pos =
   marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8
-  where marshal = join . traverseOf (_Right . each) (fromSexp g)
+  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g)
 
 parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a
 parseSexpWithPos g pos =
   marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8
-  where marshal = join . traverseOf _Right (fromSexp g)
+  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
@@ -181,12 +243,41 @@ 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
@@ -231,21 +322,18 @@ getPos = do
   Loc {loc_filename,loc_start} <- location
   pure $ SL.Position loc_filename (fst loc_start) (snd loc_start)
 
-makeSxs :: Data b => SexpGrammar a -> (List a -> b) -> QuasiQuoter
-makeSxs g f = QuasiQuoter
-  { quoteExp = \str -> do
-      pos <- getPos
-      case parseSexpsWithPos g pos (T.pack str) of
-        Left e -> fail e
-        Right xs -> dataToExpQ (const Nothing) (f xs)
-  , quotePat = undefined
-  , quoteType = undefined
-  , quoteDec = undefined
-  }
+fromSexp :: SexpIso a => Sexp -> a
+fromSexp = either error id . Sexp.fromSexp sexpIso
+
+fromSexp' :: SexpGrammar a -> Sexp -> a
+fromSexp' g = either error id . Sexp.fromSexp g
 
 toSexp :: SexpIso a => a -> Sexp
 toSexp = either error id . Sexp.toSexp sexpIso
 
+toSexps :: (Foldable f, SexpIso a) => f a -> List Sexp
+toSexps = foldMap \x -> [toSexp x]
+
 pattern Unquote x =
   SL.Modified Hash (SL.BraceList [SL.Symbol x])
 pattern UnquoteSplicing x =
@@ -262,12 +350,41 @@ instance Each Sexp Sexp Sexp Sexp where
   each k (SL.BraceList xs)              = SL.BraceList <$> traverse k xs
   each _ e@(SL.Atom _; SL.Modified _ _) = pure e
 
-metaSexp :: Sexp.Sexp -> Maybe ExpQ
-metaSexp (Unquote x) =
-  Just [| toSexp $(varE (mkName (T.unpack x))) |]
-metaSexp (SL.ParenList xs)
-  | (_:_) <- xs ^.. each . _UnquoteSplicing
-  = Just [| SL.ParenList (mconcat $(listE spans)) |]
+stripLocation :: Sexp -> Sexp
+stripLocation = cata \case
+  SL.Compose (a SL.:< e) ->
+    SL.Fix . SL.Compose $ SL.dummyPos SL.:< e
+
+-- | @('==')@ for 'Sexp's modulo source location — return true if the
+-- two sexps are equal in all but 'Position' fields.
+equivalent :: Sexp -> Sexp -> Bool
+equivalent = (==) `on` stripLocation
+
+instance SexpIso Natural where
+  sexpIso = Sexp.integer >>> Sexp.partialOsi f g
+    where
+      f n | n < 0 = Left $ Sexp.unexpected "negative"
+                        <> Sexp.expected "natural"
+          | otherwise = Right $ fromIntegral n
+      g n = fromIntegral n
+
+class SpliceSexp a where
+  spliceSexp :: a -> List Sexp
+
+instance SexpIso a => SpliceSexp (Data.Vector.Strict.Vector a) where
+  spliceSexp = toSexps
+
+instance SexpIso a => SpliceSexp (Vector a) where
+  spliceSexp = toSexps
+
+instance SexpIso a => SpliceSexp (List a) where
+  spliceSexp = toSexps
+
+instance SpliceSexp Sexp where
+  spliceSexp = toListOf each
+
+unquoteSplicingRecursive :: List Sexp.Sexp -> ExpQ
+unquoteSplicingRecursive xs = [| mconcat $(spans) |]
   where
     spans = xs
       & groupBy \cases
@@ -275,9 +392,31 @@ metaSexp (SL.ParenList xs)
           _ (UnquoteSplicing _) -> False
           _ _                   -> True
       & fmap \case
-        [UnquoteSplicing x] -> varE (mkName (T.unpack x))
-        x -> lift x
-metaSexp _ = Nothing
+        -- [e@(Unquote _)] ->
+        --   case unquote e of
+        --     Just x -> [| [$(x)] |]
+        --     Nothing -> error "unreachable"
+        [UnquoteSplicing x] ->
+          [| spliceSexp $(varE (mkName (T.unpack x))) |]
+        es -> listE $ unquoteRecursive <$> es
+      & listE
+
+unquoteRecursive :: Sexp.Sexp -> ExpQ
+unquoteRecursive = \case
+  Unquote x -> [| toSexp $(varE (mkName (T.unpack x))) |]
+  SL.ParenList xs -> [|SL.ParenList $(unquoteSplicingRecursive xs)|]
+  e -> liftData e
+
+_ParenList :: Prism' Sexp (List Sexp)
+_ParenList = prism' SL.ParenList \case
+  SL.ParenList xs -> Just xs
+  _ -> Nothing
+
+metaSexps :: List Sexp.Sexp -> Maybe ExpQ
+metaSexps = Just . unquoteSplicingRecursive
+
+metaSexp :: Sexp.Sexp -> Maybe ExpQ
+metaSexp = Just . unquoteRecursive
 
 -- 뻘짓뻘짓뻘짓뻘짓뻘짓
 class Lift1 f where
@@ -287,10 +426,10 @@ lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
 lift1 = liftLift lift
 
 instance Lift1 f => Lift (SL.Fix f) where
-  lift (SL.Fix inner) = appE [|Fix|] (lift1 inner)
+  lift (SL.Fix inner) = appE [|SL.Fix|] (lift1 inner)
 
 instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where
-  liftLift l (SL.Compose fga) = [|Compose $(liftLift (liftLift l) fga)|]
+  liftLift l (SL.Compose fga) = [|SL.Compose $(liftLift (liftLift l) fga)|]
 
 instance Lift a => Lift1 (SL.LocatedBy a) where
   liftLift l (a SL.:< e) = [|(SL.:<) $(lift a) $(l e)|]
@@ -304,27 +443,57 @@ instance Lift1 SL.SexpF where
     SL.ParenListF es -> [|SL.ParenListF $(liftLift l es)|]
     SL.BracketListF es -> [|SL.BracketListF $(liftLift l es)|]
     SL.BraceListF es -> [|SL.BraceListF $(liftLift l es)|]
-    SL.ModifiedF p e -> [|SL.Modified $(lift p) $(l e)|]
+    SL.ModifiedF p e -> [|SL.ModifiedF $(lift p) $(l e)|]
 
 -- deriving instance Lift a => Lift (SL.SexpF a)
 deriving instance Lift SL.Atom
 deriving instance Lift SL.Position
 deriving instance Lift SL.Prefix
 
+encodeOrShow :: (SexpIso a, Show a, IsString s) => a -> s
+encodeOrShow a = fromString case encode a of
+  Left _ -> show a
+  Right e -> T.unpack e
+
 extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
 extQ f g a = maybe (f a) g (cast a)
 
-makeSx :: Data a => SexpGrammar a -> QuasiQuoter
-makeSx g = QuasiQuoter
+makeSxs :: Data r => Code Q (List Sexp -> r) -> QuasiQuoter
+makeSxs f = QuasiQuoter
   { quoteExp = \str -> do
       pos <- getPos
-      case parseSexpWithPos g pos (T.pack str) of
+      case readSexpsWithPos pos (T.pack str) of
         Left e -> fail e
-        Right x -> dataToExpQ (const Nothing `extQ` metaSexp) x
+        Right xs -> [| $(unTypeCode f) $e |]
+          where
+            e = dataToExpQ
+              (const Nothing `extQ` metaSexp `extQ` metaSexps)
+              xs
   , quotePat = undefined
   , quoteType = undefined
   , quoteDec = undefined
   }
 
-sxs = makeSxs (sexpIso @Sexp) id
-sx = makeSx (sexpIso @Sexp)
+-- | An untyped variant of 'makeSx', useful when the user function is
+-- polymorphic in its return value.
+makeSx' :: ExpQ -> QuasiQuoter
+makeSx' f = QuasiQuoter
+  { quoteExp = \str -> do
+      pos <- getPos
+      case readSexpWithPos pos (T.pack str) of
+        Left e -> fail e
+        Right x -> [| $f $e |]
+          where
+            e = dataToExpQ
+              (const Nothing `extQ` metaSexp `extQ` metaSexps)
+              x
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+makeSx :: Data r => Code Q (Sexp -> r) -> QuasiQuoter
+makeSx = makeSx' . unTypeCode
+
+sxs = makeSxs [||id||]
+sx = makeSx [||id||]

src/Gyehoek/Stack/Syntax.hs

@@ -0,0 +1,142 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Gyehoek.Stack.Syntax
+  ( Program(..)
+  , Block(..)
+  , Instr(..)
+  , Val(..)
+  , Lit(..)
+  , Obj(..)
+  , Imm(..)
+  , 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)
+
+
+newtype Program = MkProgram
+  { blocks :: List Block
+  }
+  deriving stock (Show, Generic, Data)
+  deriving newtype (Semigroup, Monoid)
+
+instance IsList Program where
+  type Item Program = Block
+  fromList = MkProgram
+  toList = view #blocks
+
+data Block = MkBlock
+  { label :: Name
+  , params :: List Name
+  , code :: List Instr
+  }
+  deriving stock (Show, Generic, Data)
+
+instance Each Block Block Instr Instr where
+  each = #code . each
+
+data Instr
+  = Pop Name
+  | Push Val
+  | PopCont Name
+  | PushCont Val
+  | Prim Name (Prim Val)
+  | Call Val (List Val)
+  | If Val (List Instr) (List Instr)
+  deriving stock (Show, Generic, Data)
+
+data Val
+  = ValReg Name
+  | ValImm Imm
+  deriving stock (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)
+
+data Obj
+  = ObjImm Imm
+  deriving (Show, Generic, Data, Eq)
+
+
+--- 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 Imm where
+  sexpIso = match
+    $ With (S.sexpIso @Int >>>)
+    $ With (Gyehoek.Sexp.schemeBool >>>)
+    $ With (labelName >>>)
+    $ 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 "%")
+
+labelName :: S.SexpGrammar Name
+labelName = S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
+        (S.expected "label")
+        (prefixed @Name "$")

src/Gyehoek/Stack/VM.hs

@@ -0,0 +1,143 @@
+{-# 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
+  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 (PopCont r) = case vm ^. #kstack of
+  [] -> error "empty stack"
+  (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>"

src/Gyehoek/Wasm.hs

@@ -1,62 +1,75 @@
 {- HLINT ignore "Use newtype instead of data" -}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DeepSubsumption #-}
-{-# LANGUAGE NoFieldSelectors #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE RecordPuns #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE ImpredicativeTypes #-}
-{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 module Gyehoek.Wasm
-  ( Module
+  (
+    -- * syntax
+    Module
+  , Idx
+  , Expr
+    -- ** quasiquoters
+  , expr
+  , Gyehoek.Sexp.sx
+  , Gyehoek.Sexp.sxs
+  -- * GenMod effect
+  , GenMod
+  , runGenMod
+  , execGenMod
+  , defineFunction
+  , defineType
+  , defineGlobal
+  , emit
+  , renderModule
+  , wat
+  , wats
+  , defineFunctions
+  , defineTypes
+  , defineGlobals
   )
   where
 
 import Language.SexpGrammar
-  ( SexpIso(..), list, el, (>>>), rest, sym, symbol, (:-) )
+  ( SexpIso(..), (>>>) )
 import Language.SexpGrammar qualified as Sexp
 import Language.SexpGrammar.Generic
 import Data.List (List)
-import GHC.Generics (Generic, Generically(..))
+import GHC.Generics (Generic)
 import Data.Text (Text)
-import Data.String (IsString (fromString))
-import Text.Printf
 import Effectful
 import Numeric.Natural (Natural)
 import Effectful.Dispatch.Dynamic
 import Effectful.State.Dynamic
 import Control.Lens
-import Data.Generics.Labels
-import Data.Vector (Vector)
-import Data.String.Interpolate
-import qualified Data.Vector as V
-import qualified Data.Text as T
-import Effectful.Writer.Dynamic
-import Control.Applicative (Alternative((<|>)))
-import Control.Category qualified as Cat
-import Data.Vector.Lens
-import Data.Either (fromLeft, fromRight)
+import Data.Vector.Strict (Vector)
+import qualified Data.Vector.Strict as V
 import Language.Sexp.Located
 import qualified Gyehoek.Sexp
 import GHC.IsList (IsList(..))
-import Data.Coerce (coerce)
-import qualified Control.Category
-import Data.Functor (void)
+import Language.Haskell.TH.Quote (QuasiQuoter)
+import Data.Data (Data)
+import Gyehoek.Sexp (sx)
+import Data.Foldable (traverse_)
 
 
 newtype Module = MkModule { inner :: Vector Sexp }
   deriving (Show, Generic)
   deriving newtype (Semigroup, Monoid)
 
-newtype Expr = MkExpr { inner :: Vector Sexp }
-  deriving (Show, Generic)
+newtype Expr = MkExpr { inner :: Vector Instr }
+  deriving (Show, Generic, Data, Eq)
   deriving newtype (Semigroup, Monoid)
 
+instance IsList Expr where
+  type Item Expr = Instr
+  fromList = MkExpr . V.fromList
+  toList = V.toList . view #inner
+
+newtype Instr = MkInstr { inner :: Sexp }
+  deriving (Show, Generic, Data, Eq)
+
 newtype Idx = MkIdx { inner :: Natural }
-  deriving (Generic)
+  deriving (Generic, Data)
   deriving newtype (Show)
 
 
@@ -68,9 +81,112 @@ data GenModState = MkGenModState
   { mod :: Module
   , funcs :: Natural
   , types :: Natural
+  , globals :: Natural
   }
   deriving (Show, Generic)
 
+instance Semigroup GenModState where
+  m1 <> m2 = MkGenModState
+    { mod = m1.mod <> m2.mod
+    , funcs = m1.funcs + m2.funcs
+    , types = m1.types + m2.types
+    , globals = m1.globals + m2.globals
+    }
+
+instance Monoid GenModState where
+  mempty = MkGenModState
+    { mod = mempty
+    , funcs = 0
+    , types = 0
+    , globals = 0
+    }
+
 data GenMod :: Effect where
   DefineFunction :: Sexp -> GenMod m Idx
   DefineType :: Sexp -> GenMod m Idx
+  DefineGlobal :: Sexp -> GenMod m Idx
+  Emit :: Sexp -> GenMod m ()
+
+type instance DispatchOf GenMod = Dynamic
+
+defineFunction :: GenMod :> es => Sexp -> Eff es Idx
+defineFunction = send . DefineFunction
+
+defineFunctions :: GenMod :> es => List Sexp -> Eff es (List Idx)
+defineFunctions = traverse (send . DefineFunction)
+
+defineType :: GenMod :> es => Sexp -> Eff es Idx
+defineType = send . DefineType
+
+defineTypes :: GenMod :> es => List Sexp -> Eff es (List Idx)
+defineTypes = traverse (send . DefineType)
+
+defineGlobal :: GenMod :> es => Sexp -> Eff es Idx
+defineGlobal = send . DefineGlobal
+
+defineGlobals :: GenMod :> es => List Sexp -> Eff es (List Idx)
+defineGlobals = traverse (send . DefineGlobal)
+
+emit :: GenMod :> es => List Sexp -> Eff es ()
+emit = traverse_ (send . Emit)
+
+appendAndIncrement
+  :: State GenModState :> es
+  => LensLike' ((,) Natural) GenModState Natural
+  -> Sexp
+  -> Eff es Idx
+appendAndIncrement l s =
+  state \st -> st
+    & #mod . #inner <>~ V.singleton s
+    & l <<%~ succ
+    & _1 %~ MkIdx
+
+runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module)
+runGenMod =
+  let run = (mapped . _2 %~ view #mod) . runStateLocal (mempty @GenModState)
+  in reinterpret run \cases
+    _ (DefineFunction s) -> appendAndIncrement #funcs s
+    _ (DefineType s) -> appendAndIncrement #types s
+    _ (DefineGlobal s) -> appendAndIncrement #globals s
+    _ (Emit s) -> #mod . #inner <>= V.singleton s
+
+execGenMod :: Eff (GenMod : es) a -> Eff es Module
+execGenMod = fmap snd . runGenMod
+
+renderModule :: Module -> Text
+renderModule (MkModule ss) = Gyehoek.Sexp.format [sx|
+  (module ##{ss})
+|]
+
+
+-- SexpIso instances
+
+instance SexpIso Idx where
+  sexpIso = with \idx ->
+    Sexp.integer >>> Sexp.partialOsi f g
+    >>> idx
+    where
+      f n | n < 0 = Left $ Sexp.unexpected "negative"
+                        <> Sexp.expected "natural"
+          | otherwise = Right $ fromIntegral n
+      g = fromIntegral
+
+instance SexpIso Instr where
+  sexpIso = with id
+
+instance Gyehoek.Sexp.SpliceSexp Expr where
+  spliceSexp = toListOf $ #inner . each . #inner
+
+
+-- quasiquoters
+
+expr :: QuasiQuoter
+expr = Gyehoek.Sexp.makeSxs
+  [||MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation)
+   . fmap (Gyehoek.Sexp.fromSexp @Instr) ||]
+
+wat :: QuasiQuoter
+wat = Gyehoek.Sexp.makeSx [|| id ||]
+
+wats :: QuasiQuoter
+wats = Gyehoek.Sexp.makeSxs [|| id ||]

t.js

@@ -1,18 +0,0 @@
-const imports = {
-    guppy: {
-        print: (arg) => console.log (arg)
-    }
-}
-
-// Assume add.wasm file exists that contains a single function adding 2 provided arguments
-const fs = require('node:fs');
-
-// Use the readFileSync function to read the contents of the "add.wasm" file
-const wasmBuffer = fs.readFileSync('u.wasm');
-
-// Use the WebAssembly.instantiate method to instantiate the WebAssembly module
-WebAssembly.instantiate(wasmBuffer, imports).then(wasmModule => {
-    // Exported function lives under instance.exports object
-    const { main } = wasmModule.instance.exports;
-    main ()
-});

t.scm

@@ -0,0 +1,21 @@
+(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

@@ -1,69 +1,142 @@
 (module
- (type $heap-object (sub (struct (field (mut i32)))))
- (type $open-procedure (func (param i32)))
- (type $closure (sub $heap-object
-                     (struct (field (mut i32))
-                             (field (ref $open-procedure)))))
- (type $cont-stack-type (array (mut (ref null $open-procedure))))
- (type $arg-array-type (array (mut (ref null eq))))
- (global $cont-stack-top (mut i32) (i32.const 0))
- (global $cont-stack (ref $cont-stack-type)
-         (i32.const 128)
-         (array.new_default $cont-stack-type))
- (global $arg-array (ref $arg-array-type)
-         (i32.const 32)
-         (array.new_default $arg-array-type))
- (global (mut (ref null eq)) (ref.null eq))
- (elem declare funcref (ref.func 1))
- (func
-  (param i32)
-  (result)
-  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-  (global.get 2)
-  (i32.const 0)
-  (array.get 3)
-  ref.as_non_null
-  (global.set 3))
- (func
-  (param i32)
-  (result)
-  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-  (global.get 2)
-  (i32.const 0)
-  (array.get 3)
-  ref.as_non_null
-  (local.set 1)
-  (global.get 2)
-  (i32.const 0)
-  (local.get 1)
-  (array.set 3)
-  (i32.const 1)
-  (global.get 1)
-  (global.get 0)
-  (array.get 2)
-  ref.as_non_null
-  (global.get 0)
-  (i32.const 1)
-  i32.sub
-  (global.set 0)
-  (return_call_ref 1))
- (func
-  (param i32)
-  (result)
-  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-  (ref.func 1)
-  (local.set 1)
-  (global.get 2)
-  (i32.const 0)
-  (local.get 1)
-  (array.set 3)
-  (return_call 1))
- (func
-  (param)
-  (result (ref eq))
-  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-  (i32.const 0)
-  (call 1)
-  (global.get 3)
-  ref.as_non_null)
- (export "main" (func 3)))
+  (import
+    "gyehoek"
+    "write"
+    (func $gh-write (param (ref eq))))
+  (import
+    "gyehoek"
+    "truthy?"
+    (func $gh-truthy? (param (ref eq)) (result i32)))
+  (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)))))
+  (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)))
+  (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 $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 begin popArg)
+    (global.get $arg0)
+    ref.as_non_null
+    (@gyehoek end popArg)
+    (global.set $result))
+  (func
+    (param i32)
+    (@gyehoek
+      :origin
+      "(λ (x λ-tail1) (prim (* x x) (κ (r2) (continue λ-tail1 r2))))")
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (@gyehoek
+      :origin
+      "(prim (* x x) (κ (r2) (continue λ-tail1 r2)))")
+    (global.get $arg1)
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    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 begin pushArg)
+    (global.get $arg2)
+    (global.set $arg0)
+    (@gyehoek end pushArg)
+    (@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 3))
+  (func
+    (param i32)
+    (@gyehoek :origin "(κ (x4) (continue halt x4))")
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (@gyehoek begin pushArg)
+    (global.get $arg2)
+    (global.set $arg0)
+    (@gyehoek end pushArg)
+    (return_call $halt (i32.const 1)))
+  (elem declare funcref (ref.func 4))
+  (func
+    $scm-entry
+    (param i32)
+    (@gyehoek
+      :origin
+      "(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))
+    (i32.const 0)
+    (ref.func 3)
+    (struct.new $closure)
+    (global.set $arg1)
+    (@gyehoek :origin "(λ-body0 5 r3)")
+    (@gyehoek "push cont" :idx 4)
+    (array.set
+      $cont-stack-type
+      (global.get $cont-stack)
+      (global.get $cont-stack-top)
+      (ref.func 4))
+    (global.set
+      $cont-stack-top
+      (i32.add (global.get $cont-stack-top) (i32.const 1)))
+    (@gyehoek :origin "(λ-body0 5 r3)")
+    (@gyehoek "load args")
+    (@gyehoek begin pushArg)
+    (i32.const 5)
+    (@gyehoek "construct small fixnum")
+    (i32.const 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)
+    (@gyehoek todo (f' (global.get $arg1)) (ktail 1)))
+  (func
+    (export "main")
+    (call $scm-entry (i32.const 0))
+    (call $gh-write (ref.as_non_null (global.get $result)))))

t2.wat

@@ -1,65 +0,0 @@
-(module
- (type $heap-object (sub (struct (field (mut i32)))))
- (type $open-procedure (func (param i32)))
- (type $closure (sub $heap-object
-                     (struct (field (mut i32))
-                             (field (ref $open-procedure)))))
- (type $cont-stack-type (array (mut (ref null $open-procedure))))
- (type $arg-array-type (array (mut eqref)))
- (type (func (result (ref eq))))
- (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)))
- (global $arg-array (ref $arg-array-type)
-         (array.new_default $arg-array-type (i32.const 32)))
- (global (mut eqref) (ref.null eq))
- (elem declare funcref (ref.func 1))
- (func $halt (param i32)
-       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-       (global.set 3
-                   (ref.as_non_null
-                    (array.get $arg-array-type
-                               (global.get $arg-array)
-                               (i32.const 0)))))
- (func $f1 (param i32)
-       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-       ;; pop arg 0
-       (local.set
-        1
-        (ref.as_non_null
-         (array.get $arg-array-type
-                    (global.get $arg-array)
-                    (i32.const 0))))
-       ;; push arg 0
-       (array.set $arg-array-type
-                  (global.get $arg-array)
-                  (i32.const 0)
-                  (local.get 1))
-       ;; pop continuation
-       (return_call_ref
-        $open-procedure
-        (i32.const 1)
-        (ref.as_non_null (array.get $cont-stack-type
-                                    (global.get $cont-stack)
-                                    (global.get $cont-stack-top)))
-        (global.set $cont-stack-top
-                    (i32.sub
-                     (global.get $cont-stack-top)
-                     (i32.const 1)))))
- (func $f2 (type $open-procedure) (param i32)
-       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-       (local.set 1
-                  (struct.new $closure
-                              (i32.const 0)
-                              (ref.func $f1)))
-       (array.set $arg-array-type
-                  (global.get $arg-array)
-                  (i32.const 0)
-                  (local.get 1))
-       (i32.const 1)
-       (return_call $f1))
- (func $main (export "main") (result (ref eq))
-       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-       (call $f2 (i32.const 0))
-       (ref.as_non_null
-        (global.get 3))))

test/Gyehoek/Test/CPS/Stackify.hs

@@ -0,0 +1,82 @@
+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
+import Test.Tasty.ExpectedFailure (expectFail)
+
+
+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)))|]
+  ]
+
+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

@@ -0,0 +1,54 @@
+{-# LANGUAGE OverloadedLists #-}
+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
+root = pure . testGroup "cps syntax" $
+  [ qqTree
+  , freeTree
+  ]
+
+freeTree :: TestTree
+freeTree = testGroup "free"
+  [ testCase "lambda" do
+    Sut.free' @Sut.Lambda [cps|
+      (lambda (x y z k1) (continue k1 x a b c y))
+    |] @=? ["a","b","c"]
+  , testCase "exp" do
+    Sut.free' @Sut.Exp [cps|
+      (letrec ((x (lambda (r k1) (continue k1 y)))
+               (y (lambda (r k2) (continue k2 x))))
+        (continue x y k3))|] @=? ["k3"]
+  ]
+
+qqTree :: TestTree
+qqTree = testGroup "parser"
+  [ testCase "lambda" do
+      assertEqual "" (Sut.MkLambda ["x","y"] "ktail"
+               (Sut.ExpContinue "ktail" [Sut.ValVar "x"]))
+        [cps|(λ (x y ktail) (continue ktail x))|]
+      assertEqual "" (Sut.MkLambda [] "ktail"
+               (Sut.ExpContinue "ktail" [Sut.ValVar "x"]))
+        [cps|(λ (ktail) (continue ktail x))|]
+  , testCase "kappa" do
+      assertEqual "" (Sut.MkKappa ["x","y"]
+               (Sut.ExpContinue "k123" [Sut.ValVar "x", Sut.ValVar "y"]))
+        [cps|(κ (x y) (continue k123 x y))|]
+  , testCase "application" do
+      assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
+                     [Sut.ValVar "x",Sut.ValVar "y"]
+                     "k")
+        [cps|(f x y k)|]
+      assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
+                     [] "k")
+        [cps|(f k)|]
+  ]

test/Gyehoek/Test/Golden.hs

@@ -0,0 +1,87 @@
+module Gyehoek.Test.Golden (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Silver
+import Gyehoek.Driver qualified as Driver
+import System.FilePath
+import Data.List (List)
+import Data.Functor ((<&>))
+import System.Directory
+import Data.Function
+import System.Environment.Blank (getEnvDefault)
+import qualified System.Process.Text as PT
+import Control.Exception (catches, ErrorCall(..), Handler(..))
+import Gyehoek.Stack.VM (writeObj)
+import Data.Text qualified as T
+import System.Exit (ExitCode(..))
+import Test.Tasty.ExpectedFailure (expectFail)
+
+
+brokenWasmTests :: List String
+brokenWasmTests =
+  [ "adder"
+  , "apply-twice"
+  , "square"
+  , "fn-of-fn"
+  , "let-fn"
+  , "apply2"
+  , "factorial"
+  ]
+
+brokenStackifyTests :: List String
+brokenStackifyTests =
+  [ "apply-twice"
+  , "adder"
+  , "apply2"
+  , "let-fn"
+  ]
+
+root :: IO TestTree
+root = do
+  all_cases <- listDirectory "golden"
+  let tests = all_cases
+            & fmap ("golden"</>)
+  testGroup "golden" <$> sequenceA
+    [ wasmTests tests
+    , stackifyTests tests
+    ]
+
+maybeBroken name broken = applyWhen (name `elem` broken) expectFail
+wasmTests :: List FilePath -> IO TestTree
+wasmTests files = do
+  cmd <- getEnvDefault "GYEHOEK_RUNTIME"
+    "runtime/target/debug/gyehoek-runtime"
+  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 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 =
+          catches (do rs <- Driver.eval_e2e scmfile
+                      pure ( ExitSuccess
+                           , T.unwords . fmap writeObj $ rs
+                           , "" ))
+            [ Handler \(ErrorCall s) ->
+                pure (ExitFailure 1, "", T.pack s)
+            ]
+    in maybeBroken testname brokenStackifyTests $
+     goldenVsAction
+       testname
+       resultfile
+       action
+       printProcResult

test/Gyehoek/Test/Sexp.hs

@@ -0,0 +1,56 @@
+module Gyehoek.Test.Sexp
+  ( root
+  , EquivSexp(..)
+  , assertEquiv
+  , equivto
+  )
+  where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Language.Sexp.Located qualified as SL
+import Language.SexpGrammar ()
+import Gyehoek.Sexp (sx, equivalent)
+import Data.Function (on)
+
+
+root :: IO TestTree
+root = pure . testGroup "sexp" $
+  [ sxTree
+  ]
+
+newtype EquivSexp = MkEquiv SL.Sexp
+  deriving newtype (Show)
+
+instance Eq EquivSexp where
+  MkEquiv x == MkEquiv y = equivalent x y
+
+assertEquiv
+  :: HasCallStack
+  => String -> SL.Sexp -> SL.Sexp -> Assertion
+assertEquiv prefix = assertEqual prefix `on` MkEquiv
+
+equivto = assertEquiv ""
+
+sxTree :: TestTree
+sxTree = testGroup "sx"
+  [ testCase "quotation" do
+      equivto (SL.Symbol "abc") [sx|abc|]
+      equivto (SL.ParenList [SL.Symbol "a", SL.Symbol "b"]) [sx|(a b)|]
+  , testCase "antiquotation" do
+      equivto [sx|123|]
+        let meta = 123 :: Int
+        in [sx|#{meta}|]
+      equivto [sx|(blah (blah blah) blah)|]
+        let meta = [sx|blah|]
+        in [sx|(#{meta} (#{meta} #{meta}) #{meta})|]
+  , testCase "splicing" do
+      equivto [sx|(a b c d e f g)|]
+        let metas = SL.Symbol <$> ["c","d","e"]
+        in [sx|(a b ##{metas} f g)|]
+      equivto [sx|(a (b c d) e f g)|]
+        let
+          e1 = SL.Symbol "c"
+          e2 = SL.Symbol <$> ["e","f"]
+        in [sx|(a (b #{e1} d) ##{e2} g)|]
+  ]

test/Gyehoek/Test/Stack/VM.hs

@@ -0,0 +1,126 @@
+module Gyehoek.Test.Stack.VM (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Gyehoek.Stack.Syntax
+import Gyehoek.Stack.VM qualified as Sut
+import Data.List (List)
+import Control.Lens
+import Data.Generics.Labels
+
+
+root :: IO TestTree
+root = pure . testGroup "stack machine" $
+  [ lit_int
+  , 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)]
+      ]
+    ]
+
+vlb = ValImm . ImmLabel
+
+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 =
+            [ 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"]
+              ]
+            ]
+      evalsTo [ObjImm (ImmInt 1)] $
+        [ MkBlock "main" []
+          [ Call (ValLabel "fac") [ValImm (ImmInt 0)]
+          ]
+        ] ++ fac
+      evalsTo [ObjImm (ImmInt 720)] $
+        [ MkBlock "main" []
+          [ Call (ValLabel "fac") [ValImm (ImmInt 6)]
+          ]
+        ] ++ fac
+  ]
+
+prims = testGroup "prims"
+  [ arith
+  , testCase "zero?" do
+      trivialPrimTest [ObjImm (ImmBool True)] $
+        PrimZeroP $ ValImm $ ImmInt 0
+      trivialPrimTest [ObjImm (ImmBool False)] $
+        PrimZeroP $ ValImm $ ImmInt 12
+  ]
+
+trivialPrimTest rs p =
+  evalsTo rs
+  [ MkBlock "main" []
+    [ PopCont "ktail"
+    , Prim "x1" p
+    , 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

@@ -1,57 +1,23 @@
 module Main (main) where
 
 import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.Silver
 import Test.Tasty.Silver.Interactive (defaultMain)
-import Data.Traversable
-import Gyehoek.Driver qualified as Driver
-import System.FilePath
-import Data.List (List)
-import Data.Functor ((<&>))
-import System.Directory
-import Data.Function
+import qualified Gyehoek.Test.Golden
+import qualified Gyehoek.Test.Sexp
+import qualified Gyehoek.Test.CPS.Syntax
+import qualified Gyehoek.Test.Stack.VM
+import qualified Gyehoek.Test.CPS.Stackify
 
 
-disabled :: List String
-disabled =
-  [ "square"
+main :: IO ()
+main = defaultMain =<< root
+
+root :: IO TestTree
+root = testGroup "test" <$> sequenceA
+  [ Gyehoek.Test.Golden.root
+  , Gyehoek.Test.Sexp.root
+  , Gyehoek.Test.CPS.Syntax.root
+  , Gyehoek.Test.Stack.VM.root
+  , Gyehoek.Test.CPS.Stackify.root
   ]
 
-main :: IO ()
-main = defaultMain =<< goldenTests
-
-goldenTests :: IO TestTree
-goldenTests = do
-  all_cases <- listDirectory "golden"
-  let tests = all_cases
-            & filter (`notElem` disabled)
-            & fmap ("golden"</>)
-  pure $ testGroup "golden"
-    [ watTests tests
-    , executionTests tests
-    ]
-
-watTests :: List FilePath -> TestTree
-watTests files =
-  testGroup "wat" $ files <&> \test ->
-    let source = test </> "source.scm"
-        golden = test </> "out.wat"
-        testname = takeFileName test
-    in goldenVsAction
-      testname
-      golden
-      (Driver.lower_e2e source)
-      id
-
-executionTests :: List FilePath -> TestTree
-executionTests files =
-  testGroup "execution" $ files <&> \test ->
-    let wat = test </> "out.wat"
-        testname = takeFileName test
-        resultfile = test </> "exec"
-    in goldenVsProg
-       testname
-       resultfile
-       "wasmtime"
-       ["--invoke", "main", wat]
-       ""

u.wat

@@ -1,78 +1,127 @@
 (module
- (func $print (import "guppy" "print") (param i32))
- (table 2 funcref)
- (elem (i32.const 0) $halt)
-
- (type $cont (func (param i32)))
- (type $cont-stack-type (array (mut (ref null $cont))))
- (global $cont-stack (ref $cont-stack-type)
-         (array.new_default $cont-stack-type (i32.const 128)))
+ (import "gyehoek" "write" (func $gh-write (param (ref eq))))
+ (import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq)) (result i32)))
+ (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)))))
  (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)))
  (type $arg-array-type (array (mut (ref null eq))))
- (global $arg-array (ref $arg-array-type)
-         (array.new_default $arg-array-type (i32.const 32)))
-
- ;; (memory $memory i32 1)
- ;; (global $arg-stack-base i32 (i32.const 0))
- ;; (global $arg-stack-ptr i32 (global.get $arg-stack-base))
- ;; (global $cont-stack-base i32 (i32.const 32))
- ;; (global $cont-stack-ptr i32 (global.get $cont-stack-base))
-
- (func $add (param $nargs i32)
-       (local $x (ref eq))
-       (local $y (ref eq))
-       (local $return (ref $cont))
-       (local.set $x (ref.as_non_null
-                      (array.get $arg-array-type
-                                 (global.get $arg-array)
-                                 (i32.const 0))))
-       (local.set $y (ref.as_non_null
-                      (array.get $arg-array-type
-                                 (global.get $arg-array)
-                                 (i32.const 1))))
-       (array.set $arg-array-type
-                  (global.get $arg-array)
-                  (i32.const 0)
-                  (ref.i31
-                   (i32.add (i31.get_s (ref.cast (ref i31) (local.get $x)))
-                            (i31.get_s (ref.cast (ref i31) (local.get $y))))))
-       (return_call_ref
-        $cont
-        (i32.const 1)
-        (block (result (ref $cont))
-               (ref.as_non_null
-                (array.get $cont-stack-type
-                           (global.get $cont-stack)
-                           (global.get $cont-stack-top)))
-               (global.set $cont-stack-top
-                           (i32.sub (global.get $cont-stack-top)
-                                    (i32.const 1))))))
- (func $halt (param $nargs i32)
-       (call $print
-             (i31.get_s
-              (ref.cast
-               (ref i31)
-               (ref.as_non_null
-                (array.get $arg-array-type
-                           (global.get $arg-array)
-                           (i32.const 0)))))))
- (func (export "main")
-       ;; push args
-       (array.set $arg-array-type
-                  (global.get $arg-array)
-                  (i32.const 0)
-                  (ref.i31 (i32.const 4)))
-       (array.set $arg-array-type
-                  (global.get $arg-array)
-                  (i32.const 1)
-                  (ref.i31 (i32.const 5)))
-       ;; push return continuation
-       (array.set $cont-stack-type
-                  (global.get $cont-stack)
-                  (i32.const 0)
-                  (ref.func $halt))
-       ;; make call }:)
-       (return_call $add
-                    ;; inform $add how many arguments we called it with
-                    (i32.const 2))))
+ (global
+  $arg-array
+  (ref $arg-array-type)
+  (array.new_default $arg-array-type (i32.const 32)))
+ (global $result (mut (ref null eq)) (ref.null eq))
+ (func
+  $halt
+  (param i32)
+  (global.get $arg-array)
+  (i32.const 0)
+  (array.get $arg-array-type)
+  ref.as_non_null
+  (global.set $result))
+ (func
+  (param i32)
+  (@gyehoek
+   :origin
+   (lambda (x lambda-tail1)
+     (prim (* x x) (kappa (r2) (continue lambda-tail1 r2)))))
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (global.get $arg-array)
+  (i32.const 0)
+  (array.get $arg-array-type)
+  ref.as_non_null
+  (local.set 1)
+  (local.get 1)
+  (i31.get_s (ref.cast (ref i31)))
+  (i32.const 1)
+  i32.shr_u
+  (local.get 1)
+  (i31.get_s (ref.cast (ref i31)))
+  (i32.const 1)
+  i32.shr_u
+  i32.mul
+  (i32.const 1)
+  i32.shl
+  ref.i31
+  (local.set 2)
+  (global.get $arg-array)
+  (i32.const 0)
+  (local.get 2)
+  (array.set $arg-array-type)
+  (i32.const 1)
+  (global.get $cont-stack)
+  (global.get $cont-stack-top)
+  (array.get $cont-stack-type)
+  ref.as_non_null
+  (global.get $cont-stack-top)
+  (i32.const 1)
+  i32.sub
+  (global.set $cont-stack-top)
+  (return_call_ref $cont-type))
+ (elem declare funcref (ref.func 3))
+ (func
+  (param i32)
+  (@gyehoek :origin (kappa (x4) (continue halt x4)))
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (global.get $arg-array)
+  (i32.const 0)
+  (array.get $arg-array-type)
+  ref.as_non_null
+  (local.set 1)
+  (global.get $arg-array)
+  (i32.const 0)
+  (local.get 1)
+  (array.set $arg-array-type)
+  (return_call $halt (i32.const 1)))
+ (func
+  $scm-entry
+  (param i32)
+  (@gyehoek
+   :origin
+   (letrec ((lambda-body0
+             (lambda (x lambda-tail1)
+               (prim (* x x) (kappa (r2) (continue lambda-tail1 r2))))))
+     (letrec ((r3 (kappa (x4) (continue halt x4))))
+       (lambda-body0 5 r3))))
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (i32.const 0)
+  (ref.func 3)
+  (struct.new $closure)
+  (local.set 1)
+  (@gyehoek "push return cont" :idx 4)
+  (array.set $cont-stack-type
+             (global.get $cont-stack)
+             (global.get $cont-stack-top)
+             (ref.func 4))
+  (global.set $cont-stack-top
+              (i32.add (global.get $cont-stack-top)
+                       (i32.const 1)))
+  (@gyehoek "load args")
+  (global.get $arg-array)
+  (i32.const 0)
+  (i32.const 5)
+  (i32.const 1)
+  i32.shl
+  ref.i31
+  (array.set $arg-array-type)
+  (@gyehoek todo (f' (local.get 1)) (ktail 1))
+  (return_call_ref $cont-type
+                   (i32.const 1)
+                   (struct.get $closure $code
+                               (ref.cast (ref $closure) (local.get 1)))))
+ (elem declare funcref (ref.func 4))
+ (func
+  (export "main")
+  (call $scm-entry (i32.const 0))
+  (call $gh-write (ref.as_non_null (global.get $result)))))