print begin

.dir-locals.el

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

README.md

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

doc/abi.org

@@ -0,0 +1,218 @@
+#+title: ABI
+
+largely based on the Guile Hoot's [[https://codeberg.org/spritely/hoot/src/branch/main/design/ABI.md][ABI]].
+
+* calling convention
+
+** non-tail calls
+
+- set the global variable ~$current-closure~ to the callee's closure.
+- load arguments into globals ~$arg0~, ~$arg1~, ~$arg2~, …
+- push return continuation onto ~$cont-stack~
+
+* scratchpad
+
+#+begin_src scheme
+  ;; Scheme source
+  (define (silly f g h x)
+    (f (h x) (g x)))
+
+
+  ;; continuation-passing style
+  (define (silly f g h x ktail)
+    (h x (κ (x0)
+            (g x (κ (x1)
+                    (f x0 x1 ktail))))))
+
+  ;; with explicit stacks
+  (define (silly)
+    (define f (pop!))
+    (define g (pop!))
+    (define h (pop!))
+    (define x (pop!))
+    (define ktail (pop-cont!))
+    (push-cont! (κ (x0)
+                   (define x* (pop!))
+                   (define g* (pop!))
+                   (push-cont! (κ (x1)
+                                  (define f* (pop!))
+                                  (define x0* (pop!))
+                                  (push-cont! ktail)
+                                  (push! x0*)
+                                  (push! x1)
+                                  (call! f)))
+                   (push! x*)
+                   (call! g)))
+    (push! x)
+    (call! h))
+#+end_src
+
+** fac
+
+*** Scheme source
+
+#+begin_src scheme
+(define fac
+  (λ (n)
+    (if (zero? n)
+        1
+        (* n (fac (- n 1))))))
+
+(fac 3)
+#+end_src
+
+*** CPS
+
+#+begin_src scheme
+  (define fac
+  (λ (n ktail)
+    (zero? n (κ (x0)
+                (if x0
+                    1
+                    (- n 1
+                       (κ (x1)
+                          (fac x1
+                               (κ (x2)
+                                  (* n x2 ktail))))))))))
+
+(fac 3 halt)
+
+#+end_src
+
+*** tailified
+
+#+begin_src scheme
+(define (fac-k1)
+  (define n (pop!))
+  (define x2 (pop!))
+  (define x3 (* n x2))
+  (define ktail (pop-cont!))
+  (push! x3)
+  (call! ktail))
+
+(define (fac-k0)
+  (define x0 (pop!))
+  (define n (pop!))
+  (if x0
+      (begin (define ktail (pop-cont!))
+             (push! 1)
+             (call! ktail))
+      (begin (define x1 (- n 1))
+             (push! x1)
+             (push-cont! fac-k1)
+             (call! fac))))
+
+(define (fac)
+  (define n (pop!))
+  (push! n)
+  (push-cont! fac-k0)
+  (push! n)
+  (call! zero?))
+
+(push! 3)
+(push-cont! halt)
+(call! fac)
+#+end_src
+
+evaluation of ~(fac 0)~:
+
+#+begin_src scheme
+(push! 0)                  ; [] []
+(push-cont! halt)          ; [0] []
+(call! fac)                ; [0] [halt]
+(define n (pop!))          ; [0] [halt]
+(push! n)                  ; [] [halt]
+(push-cont! fac-k0)        ; [0] [halt]
+(push! n)                  ; [0] [halt fac-k0]
+(call! zero?)              ; [0 0] [halt fac-k0]
+#<internals of zero?>      ; [0 0] [halt fac-k0]
+(define x0 (pop!))         ; [0 #t] [halt]
+(define n (pop!))          ; [0] [halt]
+(define ktail (pop-cont!)) ; [] [halt]
+(push! 1)                  ; [] []
+(call! ktail)              ; [1] []
+#+end_src
+
+evaluation of ~(fac 3)~
+
+#+begin_src scheme
+(push! 3)                  ; [] []
+(push-cont! halt)          ; [3] []
+(call! fac)                ; [3] [halt]
+
+(define n (pop!))          ; [3] [halt]
+(push! n)                  ; [] [halt]
+(push-cont! fac-k0)        ; [3] [halt]
+(push! n)                  ; [3] [halt fac-k0]
+(call! zero?)              ; [3 3] [halt fac-k0]
+#<internals of zero?>      ; [3 3] [halt fac-k0]
+(define x0 (pop!))         ; [3 #f] [halt]
+(define n (pop!))          ; [3] [halt]
+(define x1 (- n 1))        ; [] [halt]
+(push! n)                  ; [] [halt]
+(push! x1)                 ; [3] [halt]
+(push-cont! fac-k1)        ; [3 2] [halt]
+(call! fac)                ; [3 2] [halt fac-k1]
+
+(define n (pop!))          ; [3 2] [halt fac-k1]
+(push! n)                  ; [3 ] [halt fac-k1]
+(push-cont! fac-k0)        ; [3 2] [halt fac-k1]
+(push! n)                  ; [3 2] [halt fac-k1 fac-k0]
+(call! zero?)              ; [3 2 2] [halt fac-k1 fac-k0]
+#<internals of zero?>      ; [3 2 2] [halt fac-k1 fac-k0]
+(define x0 (pop!))         ; [3 2 #f] [halt fac-k1]
+(define n (pop!))          ; [3 2] [halt fac-k1]
+(define x1 (- n 1))        ; [3] [halt fac-k1]
+(push! n)                  ; [3] [halt fac-k1]
+(push! x1)                 ; [3 2] [halt fac-k1]
+(push-cont! fac-k1)        ; [3 2 1] [halt fac-k1]
+(call! fac)                ; [3 2 1] [halt fac-k1 fac-k1]
+
+(define n (pop!))          ; [3 2 1] [halt fac-k1 fac-k1]
+(push! n)                  ; [3 2] [halt fac-k1 fac-k1]
+(push-cont! fac-k0)        ; [3 2 1] [halt fac-k1 fac-k1]
+(push! n)                  ; [3 2 1] [halt fac-k1 fac-k1 fac-k0]
+(call! zero?)              ; [3 2 1 1] [halt fac-k1 fac-k1 fac-k0]
+#<internals of zero?>      ; [3 2 1 1] [halt fac-k1 fac-k1 fac-k0]
+(define x0 (pop!))         ; [3 2 1 #f] [halt fac-k1 fac-k1]
+(define n (pop!))          ; [3 2 1] [halt fac-k1 fac-k1]
+(define x1 (- n 1))        ; [3 2] [halt fac-k1 fac-k1]
+(push! n)                  ; [3 2] [halt fac-k1]
+(push! x1)                 ; [3 2 1] [halt fac-k1 fac-k1]
+(push-cont! fac-k1)        ; [3 2 1 0] [halt fac-k1 fac-k1]
+(call! fac)                ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1]
+
+(define n (pop!))          ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1]
+(push! n)                  ; [3 2 1] [halt fac-k1 fac-k1 fac-k1]
+(push-cont! fac-k0)        ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1]
+(push! n)                  ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1 fac-k0]
+(call! zero?)              ; [3 2 1 0 0] [halt fac-k1 fac-k1 fac-k1 fac-k0]
+#<internals of zero?>      ; [3 2 1 0 0] [halt fac-k1 fac-k1 fac-k1 fac-k0]
+(define x0 (pop!))         ; [3 2 1 0 #t] [halt fac-k1 fac-k1 fac-k1]
+(define n (pop!))          ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1]
+(define ktail (pop-cont!)) ; [3 2 1] [halt fac-k1 fac-k1 fac-k1]
+(push! 1)                  ; [3 2 1 1] [halt fac-k1 fac-k1]
+(call! ktail)              ; [3 2 1 1] [halt fac-k1 fac-k1]
+
+(define n (pop!))          ; [3 2 1 1] [halt fac-k1 fac-k1]
+(define x2 (pop!))         ; [3 2 1] [halt fac-k1 fac-k1]
+(define x3 (* n x2))       ; [3 2] [halt fac-k1 fac-k1]
+(define ktail (pop-cont!)) ; [3 2] [halt fac-k1 fac-k1]
+(push! x3)                 ; [3 2] [halt fac-k1]
+(call! ktail)              ; [3 2 1] [halt fac-k1]
+
+(define n (pop!))          ; [3 2 1] [halt fac-k1]
+(define x2 (pop!))         ; [3 2] [halt fac-k1]
+(define x3 (* n x2))       ; [3] [halt fac-k1]
+(define ktail (pop-cont!)) ; [3] [halt fac-k1]
+(push! x3)                 ; [3] [halt]
+(call! ktail)              ; [3 2] [halt]
+
+(define n (pop!))          ; [3 2] [halt]
+(define x2 (pop!))         ; [3] [halt]
+(define x3 (* n x2))       ; [] [halt]
+(define ktail (pop-cont!)) ; [] [halt]
+(push! x3)                 ; [] []
+(call! ktail)              ; [6] []
+;; => (halt 6)
+#+end_src

doc/closure-conversion.org

@@ -0,0 +1,134 @@
+#+title: closure-conversion
+
+the closure-conversion phase makes closed-over variables explicit by addition of the primitive ~make-closure~, taking a code pointer (in the CPS language, bare lambda) and the environment.
+
+nice testable properties of closure-converted code:
+- code pointers only appear in function position
+- no function has free variables
+
+multiple ~env-ref~ calls could probably be replaced with a primitive that loads the entire environment at once, returning multiple variables.
+
+* scratchpad
+
+** example
+
+#+caption: scheme source
+#+begin_src scheme
+  (letrec ((curried-add (λ (n)
+                          (λ (m)
+                            (+ n m)))))
+    ((curried-add 3) 4))
+#+end_src
+
+#+caption: cps
+#+begin_src scheme
+  (letrec ((curried-add
+            (λ (n ktail0)
+              (letrec ((curried-add-in
+                        (λ (m ktail1)
+                          (prim (+ n m)
+                                (κ (x0) (continue ktail1 x0))))))
+                (continue ktail0 curried-add-in)))))
+    (letrec ((k0 (κ (adder) (adder 4 halt))))
+      (curried-add 3 k0)))
+#+end_src
+
+#+caption: closure-converted
+#+begin_src scheme
+  (letrec ((curried-add
+            (λ (n ktail0)
+              (letrec ((curried-add-in-code
+                        (λ (env m ktail1)
+                          (prim (env-ref 0 env)
+                                (κ (n)
+                                   (prim (+ n m)
+                                         (κ (x0) (continue ktail1 x0))))))))
+                (prim (make-closure curried-add-in-code n)
+                      (κ (curried-add-in)
+                         (continue ktail0 curried-add-in)))))))
+    (letrec ((k0 (κ (adder-closure)
+                    (prim (closure-code adder-closure)
+                          (κ (adder)
+                             (adder adder-closure 4 halt))))))
+      (curried-add 3 k0)))
+#+end_src
+
+** wasm
+
+#+begin_src scheme
+(letrec ((make-adder
+        (lambda (n)
+          (lambda (x)
+            (+ n x)))))
+((make-adder 3) 2))
+#+end_src
+
+#+begin_src scheme
+(define add-code
+  (lambda (n env)
+    (+ n (env-ref env 'x))))
+
+(define make-adder-code
+  (lambda (n)
+    (make-closure add-code ('x n))))
+
+(define make-adder (make-closure make-adder-code))
+
+(apply-closure (apply-closure make-addder 3) 2)
+#+end_src
+
+#+begin_src wat
+(module
+ (type $heap-object (sub (struct (field $hash (mut i32)))))
+ (type $closure (sub $heap-object
+                     (struct (field $hash (mut i32))
+                             (field $code (ref $cont-type)))))
+ (type $closure1 (sub $closure
+                      (struct (field $hash (mut i32))
+                              (field $code (ref $cont-type))
+                              (field $env0 (ref eq)))))
+ (global $arg0 (mut (ref null eq)) (ref.null eq))
+ (global $arg1 (mut (ref null eq)) (ref.null eq))
+ (global $arg2 (mut (ref null eq)) (ref.null eq))
+ (global $arg3 (mut (ref null eq)) (ref.null eq))
+ (global $arg4 (mut (ref null eq)) (ref.null eq))
+ (global $arg5 (mut (ref null eq)) (ref.null eq))
+ ;; ⋮
+ ;; (global $argn (mut (ref null eq)) (ref.null eq))
+
+ (global $current-closure (mut (ref null $closure)) (ref.null $closure))
+
+ (func $add-code (param $nargs i32)
+       (local $n (ref eq))
+       (local $x (ref eq))
+       (local.set $n (global.get $arg0))
+       (local.set $x (struct.get $closure1
+                                 (global.get $current-closure)
+                                 $env0))
+       (return (i32.add $n $x)))
+
+ (func $make-adder-code (param $nargs i32)
+       (local $n (ref eq))
+       (local.set $n (global.get $arg0))
+       (return (struct.new $closure1
+                           0
+                           $add-code)))
+
+ (func $main
+       (local.set $make-adder
+                  (struct.new $closure
+                              0
+                              $make-adder-code))
+       (global.set $current-closure $make-adder)
+       (global.set $arg0 (i32.const 3))
+       (local.set $f (call (struct.get $closure
+                                       $make-adder
+                                       $code)
+                           1))
+       (global.set $current-closure $f)
+       (global.set $arg0 (i32.const 2))
+       (return (call (struct.get $closure
+                                 $f
+                                 $code)
+                     1))))
+#+end_src

doc/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,12 @@
         "x86_64-darwin" "x86_64-linux"
       ];
 
-
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          gyehoek-wasmtime-wrapper = final.callPackage ./wasmtime.nix {};
+          gyehoek-runtime = final.callPackage ./runtime {
-        })
+            crane-lib = inputs.crane.mkLib final;
-        (final: prev: {
+          };
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
@@ -30,32 +30,36 @@
               packages.gyehoek.components.tests.test.preCheck =
                 let
                   bin = [
-                    pkgs.gyehoek-wasmtime-wrapper
+                    pkgs.git # tasty uses git diff
-                    pkgs.git
                   ];
                 in ''
-                  # Wasmtime requires a cache in $HOME. This is less
+                  export GYEHOEK_RUNTIME=${lib.getExe final.gyehoek-runtime}
-                  # painful than reconfiguring the cache location.
-                  export HOME=$(mktemp -d)
                   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
+                wabt
-                final.wabt
+                nodejs
-                final.nodejs
+                wasm-tools
-                final.wasm-tools
+                wac-cli
-                final.wac-cli
+                guile
-                final.guile
+                rust-analyzer
-                final.gyehoek-wasmtime-wrapper
+                wasmtime
+                # bashInteractive is necessary to work around an
+                # optparse-applicative issue
+                #
+                # https://github.com/pcapriotti/optparse-applicative/pull/408
+                bashInteractive
               ];
             };
           };
@@ -87,7 +91,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;
         }));
 
       devShells = each-system

golden/arith/exec

@@ -1,5 +0,0 @@
-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/exec/adder/exec

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

golden/exec/adder/source.scm

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

golden/exec/apply-twice/exec

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

golden/exec/apply-twice/source.scm

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

golden/exec/apply2/exec

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

golden/exec/apply2/source.scm

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

golden/exec/arith/exec

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

golden/exec/callcc-constant/exec

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

golden/exec/callcc-constant/source.scm

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

golden/exec/callcc-discard/exec

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

golden/exec/callcc-discard/source.scm

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

golden/exec/callcc-nested1/exec

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

golden/exec/callcc-nested1/source.scm

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

golden/exec/callcc-nested2/exec

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

golden/exec/callcc-nested2/source.scm

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

golden/exec/factorial/exec

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

golden/exec/factorial/source.scm

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

golden/exec/false/exec

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

golden/exec/false/source.scm

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

golden/exec/fn-of-fn/exec

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

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

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

golden/exec/if-false/exec

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

golden/exec/if-number/exec

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

golden/exec/if-number/source.scm

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

golden/exec/if-true/exec

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

golden/exec/lambda/exec

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

golden/exec/let-fn/exec

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

golden/exec/let-fn/source.scm

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

golden/exec/letrec-fn/exec

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

golden/exec/letrec-fn/source.scm

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

golden/exec/square/exec

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

golden/exec/true/exec

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

golden/exec/true/source.scm

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

golden/if-false/exec

@@ -1,5 +0,0 @@
-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-true/exec

@@ -1,5 +0,0 @@
-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/print/begin-nonempty-thin

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

golden/print/begin-nonempty-wide

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

golden/print/lambda-thin

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

golden/print/lambda-wide

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

golden/print/null

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

golden/print/rainbow

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

golden/print/simple-list-thin

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

golden/print/simple-list-wide

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

golden/read/bool/read

@@ -0,0 +1,5 @@
+[ SynNone :< SimpleF ( SimpleBoolean True )
+, SynNone :< SimpleF ( SimpleBoolean True )
+, SynNone :< SimpleF ( SimpleBoolean False )
+, SynNone :< SimpleF ( SimpleBoolean False )
+]

golden/read/bool/source.scm

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

golden/read/decimal/read

@@ -0,0 +1,9 @@
+[ SynNone :< SimpleF
+    ( SimpleNumber 45.0 )
+, SynNone :< SimpleF
+    ( SimpleNumber 5667.0 )
+, SynNone :< SimpleF
+    ( SimpleNumber
+        ( -123.0 )
+    )
+]

golden/read/decimal/source.scm

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

golden/read/delimited-identifier/read

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

golden/read/delimited-identifier/source.scm

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

golden/read/empty/read

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

golden/read/list-dot-flat/read

@@ -0,0 +1,17 @@
+[ SynNone :< CompoundF
+    ( DotListF
+        (
+            ( SynNone :< SimpleF
+                ( SimpleSymbol "가" )
+            ) :|
+            [ SynNone :< SimpleF
+                ( SimpleSymbol "나" )
+            , SynNone :< SimpleF
+                ( SimpleSymbol "다" )
+            ]
+        )
+        ( SynNone :< SimpleF
+            ( SimpleSymbol "라" )
+        )
+    )
+]

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

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

golden/read/list-flat/read

@@ -0,0 +1,19 @@
+[ SynNone :< CompoundF
+    ( ListF Ordinary
+        [ SynNone :< SimpleF
+            ( SimpleSymbol "가" )
+        , SynNone :< SimpleF
+            ( SimpleSymbol "나" )
+        , SynNone :< SimpleF
+            ( SimpleSymbol "다" )
+        , SynNone :< SimpleF
+            ( SimpleSymbol "라" )
+        , SynNone :< SimpleF
+            ( SimpleNumber 1.0 )
+        , SynNone :< SimpleF
+            ( SimpleNumber 2.0 )
+        , SynNone :< SimpleF
+            ( SimpleNumber 3.0 )
+        ]
+    )
+]

golden/read/list-flat/source.scm

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

golden/read/list/read

@@ -0,0 +1,40 @@
+[ SynNone :< CompoundF
+    ( DotListF
+        (
+            ( SynNone :< SimpleF
+                ( SimpleSymbol "a" )
+            ) :|
+            [ SynNone :< SimpleF
+                ( SimpleSymbol "b" )
+            , SynNone :< CompoundF
+                ( ListF Ordinary
+                    [ SynNone :< SimpleF
+                        ( SimpleSymbol "c" )
+                    , SynNone :< SimpleF
+                        ( SimpleSymbol "d" )
+                    ]
+                )
+            ]
+        )
+        ( SynNone :< CompoundF
+            ( ListF Ordinary
+                [ SynNone :< SimpleF
+                    ( SimpleSymbol "가" )
+                , SynNone :< CompoundF
+                    ( DotListF
+                        (
+                            ( SynNone :< SimpleF
+                                ( SimpleSymbol "나" )
+                            ) :| []
+                        )
+                        ( SynNone :< SimpleF
+                            ( SimpleSymbol "다" )
+                        )
+                    )
+                , SynNone :< SimpleF
+                    ( SimpleSymbol "라" )
+                ]
+            )
+        )
+    )
+]

golden/read/list/source.scm

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

golden/read/peculiar-identifier-dot/read

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

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

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

golden/read/peculiar-identifier-sign/read

@@ -0,0 +1,5 @@
+[ SynNone :< SimpleF
+    ( SimpleSymbol "+" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "-" )
+]

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

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

golden/read/string-line-continuation/read

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

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

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

golden/read/string/read

@@ -0,0 +1,3 @@
+[ SynNone :< SimpleF
+    ( SimpleString "가나다라" )
+]

golden/read/string/source.scm

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

golden/read/typical-identifier-token/read

@@ -0,0 +1,13 @@
+[ SynNone :< SimpleF
+    ( SimpleSymbol "abc" )
+, SynNone :< SimpleF
+    ( SimpleString "xyz" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "수학" )
+, SynNone :< CompoundF
+    ( ListF Ordinary
+        [ SynNone :< SimpleF
+            ( SimpleSymbol "數學" )
+        ]
+    )
+]

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

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

golden/read/typical-identifier/read

@@ -0,0 +1,19 @@
+[ SynNone :< SimpleF
+    ( SimpleSymbol "abc" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "bala-hwa$" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "x!!!" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "z" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "z123" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "나는너무졸리다" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "學" )
+, SynNone :< SimpleF
+    ( SimpleSymbol "車室." )
+, SynNone :< SimpleF
+    ( SimpleSymbol "三個女人一臺戲。" )
+]

golden/read/typical-identifier/source.scm

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

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,29 +48,45 @@ 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.Eval
     Gyehoek.CPS.Lower
+    Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
+    Gyehoek.Driver
     Gyehoek.GenSym
+    Gyehoek.Language
     Gyehoek.Options
+    Gyehoek.Prelude
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
+    Gyehoek.Sexp.Grammar
+    Gyehoek.Sexp.Print
+    Gyehoek.Sexp.Read
+    Gyehoek.Sexp.Syntax
+    Gyehoek.Stack.Syntax
+    Gyehoek.Stack.VM
     Gyehoek.Wasm
-    Gyehoek.Driver
 
   build-depends:
-    , base                  ^>=4.21.2.0
+    , base                         ^>=4.21.2.0
     , binary
+    , bytestring
+    , comonad
     , containers
-    , cradle
+    , data-fix
+    , deepseq
+    , deriving-compat
     , effectful
     , effectful-core
     , effectful-plugin
     , filepath
+    , free
     , generic-lens
     , hashable
     , invertible-grammar
@@ -74,30 +94,60 @@ library
     , megaparsec
     , mtl
     , optparse-applicative
+    , ordered-containers
+    , pretty-simple
     , prettyprinter
+    , prettyprinter-ansi-terminal
     , process
     , recursion-schemes
+    , scientific
     , 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
+  import:             ghcstuffs, ghcstuffs-dev
-    type:             exitcode-stdio-1.0
+  type:               exitcode-stdio-1.0
-    hs-source-dirs:   test
+  hs-source-dirs:     test
-    main-is:          Main.hs
+  main-is:            Main.hs
-    build-depends:    base
+  build-tool-depends: tasty-discover:tasty-discover
-                    , gyehoek
+
-                    , filepath
+  -- cabal-fmt: expand test -Main
-                    , tasty
+  other-modules:
-                    , tasty-silver
+    Gyehoek.Test.CPS.Eval
-                    , directory
+    Gyehoek.Test.CPS.Stackify
-    default-language: GHC2024
+    Gyehoek.Test.CPS.Syntax
+    Gyehoek.Test.Golden
+    Gyehoek.Test.Scheme.Syntax
+    Gyehoek.Test.Sexp
+    Gyehoek.Test.Sexp.Print
+    Gyehoek.Test.Stack.VM
+    Root
+
+  build-depends:
+    , base
+    , deepseq
+    , directory
+    , effectful
+    , filepath
+    , generic-lens
+    , gyehoek
+    , lens
+    , pretty-simple
+    , process-extras
+    , sexp-grammar
+    , tasty
+    , tasty-expected-failure
+    , tasty-hunit
+    , tasty-silver
+    , text
+
+  default-language:   GHC2024

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>

repl

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

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![],
+                                    )
+                                )
+                            )
+                        ))
+                    ),
+                ]
+            )?
+        )
+    )
+}
+

shake-wrapper.nix

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

src/Gyehoek/CPS/Close.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE OverloadedLists #-}
+module Gyehoek.CPS.Close
+  ( closeProgram
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Gyehoek.GenSym
+import Gyehoek.Prelude
+
+
+close :: GenSym :> es => Exp -> Eff es Exp
+close = transformM \case
+  ExpLetRec [(f, AbsLambda lam@(MkLambda bs kb m))] e -> do
+    f_code <- gensym' @Name $ f ^. _Wrapped'. to (<> "-code")
+    -- it would probably be most sane to generate a symbol for `env`,
+    -- but we're reusing the lambda binding so we don't have to
+    -- explicitly substitute recursive calls.
+    let frees = freeWithBound' [f] lam
+    let m' = ifoldr
+             (\n x q -> [cps|(prim (env-ref #{f} #{n})
+                                (κ (#{x}) #{q}))|])
+             m frees
+    pure [cps|
+      (letrec ((#{f_code} (λ (#{f} ##{bs} #{kb})
+                            #{m'})))
+        (prim (make-closure ($ #{f_code}) ##{frees})
+          (κ (#{f}) #{e})))
+    |]
+
+  ExpApply f xs ktail -> do
+    code <- gensym' @Name "code"
+    pure [cps|
+      (prim (env-code #{f})
+        (κ (#{code})
+          (#{code} #{f} ##{xs} #{ktail})))
+    |]
+
+  e -> pure e
+
+closeProgram :: GenSym :> es => Program -> Eff es Program
+closeProgram = traverseOf #body close