더 간단한 신택스 annotations

.dir-locals.el

@@ -8,4 +8,12 @@
   . ((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)))))
+ (scheme-mode
+  . ((eval . (dolist (s '(kappa κ prim))
+               (put s 'scheme-indent-function 1)))))
+ (nil
+  . ((eval
+      . (progn (defun display-ansi ()
+                 (interactive)
+                 (ansi-color-apply-on-region (point-min) (point-max))))))))

.envrc

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

.gitignore

@@ -8,4 +8,5 @@ dist-newstyle
 *.tix
 .direnv
 result
-play/
+play/
+trace.html

cabal.project

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

doc/closure-conversion.org

@@ -132,3 +132,34 @@ multiple ~env-ref~ calls could probably be replaced with a primitive that loads
                                  $code)
                      1))))
 #+end_src
+
+** example
+
+#+begin_src scheme
+  (λ (n m ktail)
+    (letrec ((f (λ (x ktail-0) (+ x n ktail-0)))
+             (g (λ (y ktail-1) (+ y g ktail-1))))
+      (prim (cons f g) ktail)))
+#+end_src
+
+#+begin_src scheme
+  (λ (n m ktail)
+    (letrec ((f-code (λ (x ktail-0)
+                       (prim (env-get 2)
+                         (κ (n)
+                           (+ x n ktail-0)))))
+             (g-code (λ (y ktail-1)
+                       (prim (env-get 3)
+                         (κ (m)
+                           (+ y m ktail-1))))))
+      (letrec ((with-closure-code
+                (κ (f g)
+                  (prim (get-env 0)
+                    (κ (ktail)
+                      (prim cons f g ktail))))))
+        (prim (make-shared-closure (with-closure-code)
+                                   ktail)
+          (κ (with-closure)
+            (prim (make-shared-closure (f-code g-code) n m)
+              with-closure))))))
+#+end_src

doc/libraries.org

@@ -0,0 +1,19 @@
+#+title: on libraries
+
+* libraries and the file system
+
+R⁷RS leaves it unspecified how exactly libraries correspond to files:
+
+#+begin_quote
+Programs and libraries are typically stored in files, although in some implementations they can be entered interactively into a running Scheme system. Other paradigms are possible. Implementations which store libraries in files should document the mapping from the name of a library to its location in the file system.
+#+end_quote
+
+thus the implementation of ~define-library~ is open to much interpretation. we could possibly define libraries as first-class objects, or deal with them statically. the former case is appealing to me, as it could massively simplify interactive use.
+
+* semantics of declaration order
+
+mercifully, R⁷RS is similarly ambiguous when it comes to the significance of declaration order. the authors note explicitly example two equally acceptable approaches:
+
+#+begin_quote
+One possible implementation of libraries is as follows: _After all cond-expand library declarations are expanded, a new environment is constructed for the library consisting of all imported bindings._ The expressions from all begin, include and include-ci library declarations are expanded in that environment in the order in which they occur in the library. _Alternatively, cond-expand and import declarations may be processed in left to right order interspersed with the processing of other declarations_, with the environment growing as imported bindings are added to it by each import declaration.
+#+end_quote

doc/make-vm-stackier.org

@@ -0,0 +1,100 @@
+* rationale?
+
+previously, the VM's stack was used for storing local variables across blocks; a Scheme procedure was split into several low-level routines (one for the procedure itself and one for each continuation), and the stack was used as a communication channel for these separate routines. in contrast, registers were local to each routine. this aligns with Wasm's model of functions pretty well, with Wasm /locals/ acting as the VM's /registers/, and a global mutable stack serving as fallback.
+
+this worked quite well until it became time to implement ~call/cc~.
+
+we are considering making the following alterations to the VM:
+- explicitly segment the stack into frames.
+- passing procedures and return addresses on the stack.
+- new instructions:
+  + ~(tail-call /n/)~
+  + ~(call /n/)~
+  + ~(load /r/ /n/)~
+  + ~(return /n/)~
+
+* scratchpad
+
+#+begin_src scheme
+  (letrec ((fac (λ (n)
+                (if (zero? n)
+                    1
+                    (* n (fac (- n 1)))))))
+  (fac 3))
+#+end_src
+
+#+begin_src scheme
+  (λ (ktail0)
+  (letrec ((fac
+            (λ (n ktail1)
+              (zero?
+               n
+               (κ (x0)
+                  (if x0
+                      (continue ktail1 1)
+                      (- n 1
+                         (κ (x1)
+                            (fac x1
+                                 (κ (x2)
+                                    (* n x2 ktail1)))))))))))
+    (fac 3)))
+#+end_src
+
+#+begin_example
+n ktail1
+| |
+| | x0
+| | |
+| | ^
+| |
+| | x1
+| | |
+| | ^
+| | 
+| | x2
+| | |
+^ ^ ^
+#+end_example
+
+#+begin_src scheme
+  (define $fac-c0
+    (pop! %x0 0) ; [ x0 $fac-c0 n $fac ktail1 ]
+    (if %x0 ; [ $fac-c0 n $fac ktail1 ]
+        ;; every variable but `ktail1' is dead so we pop them all.
+        ;; this probably means that `if' should take two continuations
+        ;; rather than two blocks.
+        (then (push! 1) ; [ $fac-c0 n $fac ktail1 ]
+              (return 1)) ; [ 1 $fac-c0 n $fac ktail1 ]
+        (else (load %n 1) ; [ $fac-c0 n $fac ktail1 ]
+              (prim %x1 (- %n 1)) ; [ $fac-c0 n $fac ktail1 ]
+              (push! $fac-c1) ; [ $fac-c0 n $fac ktail1 ]
+              (push! $fac) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
+              (push! %x1) ; [ $fac $fac-c1 $fac-c0 n $fac ktail1 ]
+              (call 1) ; [ x1 $fac $fac-c1 $fac-c0 n $fac ktail1 ]
+              )))
+
+  (define $fac-c1
+    (pop! %x2) ; [ x2 $fac-c1 $fac-c0 n $fac ktail1 ]
+    (load %n 3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
+    (prim %x3 (* %n %x2))
+    (push! %x3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
+    (return 1) ; [ x3 $fac-c1 $fac-c0 n $fac ktail1 ]
+    )
+
+  (define $fac
+    (load %ktail1 2) ; [ n $fac ktail1 ]
+    (load %n 0) ; [ n $fac ktail1 ]
+    (push! $fac-c0) ; [ n $fac ktail1 ]
+    (push! $zero?) ; [ $fac-c0 n $fac ktail1 ]
+    (push! %n) ; [ $zero? $fac-c0 n $fac ktail1 ]
+    (call 1) ; [ n $zero? $fac-c0 n $fac ktail1 ]
+    )
+
+  (define $start
+    (push! $fac) ; [ $start ktail0 ]
+    (push! 3) ; [ $fac $start ktail0 ]
+    (tail-call 1) ; [ 3 $fac $start ktail0 ]
+    ;; ↑ `tail-call' knows how to dispose of the caller's stack frame.
+    )
+#+end_src
+

flake.nix

@@ -20,12 +20,13 @@
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          gyehoek-runtime = final.callPackage ./runtime {
+          gyehoek-wasm-runtime = final.callPackage ./wasm-runtime {
             crane-lib = inputs.crane.mkLib final;
           };
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
+            configureArgs = "-f-doctest";
             modules = [({ pkgs, lib, ...}: {
               packages.gyehoek.components.tests.test.preCheck =
                 let
@@ -33,14 +34,16 @@
                     pkgs.git # tasty uses git diff
                   ];
                 in ''
-                  export GYEHOEK_RUNTIME=${lib.getExe final.gyehoek-runtime}
+                  export GYEHOEK_WASM_RUNTIME=${
+                    lib.getExe final.gyehoek-wasm-runtime
+                  }
                   export PATH=${lib.makeBinPath bin}:$PATH
                 '';
             })];
             shell = {
               withHoogle = true;
               inputsFrom = [
-                final.gyehoek-runtime
+                final.gyehoek-wasm-runtime
               ];
               tools = {
                 cabal = {};
@@ -52,7 +55,7 @@
                 nodejs
                 wasm-tools
                 wac-cli
-                guile
+                gauche
                 rust-analyzer
                 wasmtime
                 # bashInteractive is necessary to work around an
@@ -91,7 +94,7 @@
         hf.packages.${system} // lib.fix (packages: {
           gyehoek = hf.packages.${system}."gyehoek:exe:gyehoek";
           default = packages.gyehoek;
-          inherit (pkgs) gyehoek-runtime;
+          inherit (pkgs) gyehoek-wasm-runtime;
         }));
 
       devShells = each-system

golden/exec/begin-1/source.scm

@@ -0,0 +1 @@
+(begin 123 456) ; => 456

golden/exec/callcc-early-exit-1/exec

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

golden/exec/callcc-early-exit-1/source.scm

@@ -0,0 +1,12 @@
+(letrec ((iter (λ (n f)
+                 (if (zero? n)
+                     #f
+                     (begin (f n)
+                            (iter (- n 1) f))))))
+  (call/cc
+   (λ (k)
+     (iter 10 (λ (n)
+                ;; i don't feel like implementing (= n 5) right now lmfao
+                (if (zero? (- n 5))
+                    (k #t)
+                    #f))))))

golden/exec/callcc-early-exit-2/exec

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

golden/exec/callcc-early-exit-2/source.scm

@@ -0,0 +1,4 @@
+(call/cc
+ (λ (k)
+   (begin (k #t)
+          #f)))

golden/exec/callcc-early-exit-3/exec

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

golden/exec/callcc-early-exit-3/source.scm

@@ -0,0 +1,5 @@
+;; confer ../callcc-early-exit-4
+(letrec ((app (λ (f x)
+                (begin (f x)
+                       #f))))
+  (call/cc (λ (k) (app k #t))))

golden/exec/callcc-early-exit-4/exec

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

golden/exec/callcc-early-exit-4/source.scm

@@ -0,0 +1,5 @@
+;; confer ../callcc-early-exit-3
+(letrec ((app (λ (f x)
+                (begin (f x)
+                       #f))))
+  (call/cc (λ (k) (app (λ (x) (k x)) #t))))

golden/exec/callcc-early-exit-5/exec

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

golden/exec/callcc-early-exit-5/source.scm

@@ -0,0 +1,4 @@
+(call/cc
+ (λ (k)
+   (begin ((λ () (k #t)))
+          #f)))

golden/exec/callcc-early-exit-6/exec

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

golden/exec/callcc-early-exit-6/source.scm

@@ -0,0 +1,4 @@
+(* 2 (call/cc
+      (λ (k)
+        (begin (k 6)
+               3))))

golden/exec/callcc-nested-2/exec

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

golden/exec/complicated-1/exec

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

golden/exec/complicated-1/source.scm

@@ -0,0 +1,10 @@
+(letrec ((factorial (λ (n)
+                      (if (zero? n)
+                          1
+                          (* n (factorial (- n 1)))))))
+  (letrec ((sum-of-factorials
+            (λ (n)
+              (if (zero? n)
+                  0
+                  (+ (factorial n) (sum-of-factorials (- n 1)))))))
+    (+ 2 (sum-of-factorials 5))))

golden/exec/cons-1/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > (6 . 7)

golden/exec/cons-1/source.scm

@@ -0,0 +1 @@
+(cons 6 7)

golden/exec/cons-2/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > (456 . 123)

golden/exec/cons-2/source.scm

@@ -0,0 +1,2 @@
+(let ((p (cons 123 456)))
+  (cons (cdr p) (car p)))

golden/exec/factorial/exec

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

golden/exec/factorial/source.scm

@@ -2,4 +2,4 @@
                 (if (zero? n)
                     1
                     (* n (fac (- n 1)))))))
-  (fac 6))
+  (fac 20))

golden/exec/lit-int/exec

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

golden/exec/lit-int/source.scm

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

golden/exec/map/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > (0 . (1 . (4 . (9 . (16 . ())))))

golden/exec/map/source.scm

@@ -0,0 +1,7 @@
+(letrec ((my-map (λ (f l)
+                   (if (pair? l)
+                       (cons (f (car l))
+                             (my-map f (cdr l)))
+                       (list)))))
+  (my-map (λ (x) (* x x))
+          (list 0 1 2 3 4)))

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,37 @@
+[ MkAnn
+    { position = Just
+        ( SourcePos
+            { sourceName = "golden/read/bool/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF ( SimpleBoolean True )
+, MkAnn
+    { position = Just
+        ( SourcePos
+            { sourceName = "golden/read/bool/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 4
+            }
+        )
+    } :< SimpleF ( SimpleBoolean True )
+, MkAnn
+    { position = Just
+        ( SourcePos
+            { sourceName = "golden/read/bool/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 10
+            }
+        )
+    } :< SimpleF ( SimpleBoolean False )
+, MkAnn
+    { position = Just
+        ( SourcePos
+            { sourceName = "golden/read/bool/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 13
+            }
+        )
+    } :< SimpleF ( SimpleBoolean False )
+]

golden/read/datum-comment/source.scm

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

golden/read/decimal/read

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

golden/read/list-dot-flat/read

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

golden/read/list-flat/read

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

golden/read/list/read

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

golden/read/meta-expression/read

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

golden/read/meta-expression/source.scm

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

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

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

golden/read/meta-splice-expression/read

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

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

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

golden/read/meta-splice-variable/read

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

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

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

golden/read/meta-variable/read

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

golden/read/meta-variable/source.scm

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

golden/read/peculiar-identifier-dot/read

@@ -0,0 +1,61 @@
+[ MkAnn
+    { position = Just
+        ( SourcePos
+            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "..." )
+, MkAnn
+    { position = Just
+        ( SourcePos
+            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
+            , sourceLine = Pos 2
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol ".." )
+, MkAnn
+    { position = Just
+        ( SourcePos
+            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
+            , sourceLine = Pos 3
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol ".abc" )
+, MkAnn
+    { position = Just
+        ( SourcePos
+            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
+            , sourceLine = Pos 4
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol "....abcc" )
+, MkAnn
+    { position = Just
+        ( SourcePos
+            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
+            , sourceLine = Pos 5
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol ".++-" )
+, MkAnn
+    { position = Just
+        ( SourcePos
+            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
+            , sourceLine = Pos 6
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
+    ( SimpleSymbol ".-" )
+]

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

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

golden/read/peculiar-identifier-sign/read

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

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

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

golden/read/string/read

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

golden/read/typical-identifier-token/read

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

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

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

golden/read/typical-identifier/read

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

golden/read/typical-identifier/source.scm

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

golden/reader/bool/read

@@ -1,9 +0,0 @@
-[ Fix
-    ( SimpleF ( Boolean True ) )
-, Fix
-    ( SimpleF ( Boolean True ) )
-, Fix
-    ( SimpleF ( Boolean False ) )
-, Fix
-    ( SimpleF ( Boolean False ) )
-]

golden/reader/decimal/read

@@ -1,15 +0,0 @@
-[ Fix
-    ( SimpleF
-        ( Number 45.0 )
-    )
-, Fix
-    ( SimpleF
-        ( Number 5667.0 )
-    )
-, Fix
-    ( SimpleF
-        ( Number
-            ( -123.0 )
-        )
-    )
-]

golden/reader/list-dot-flat/read

@@ -1,25 +0,0 @@
-[ Fix
-    ( CompoundF
-        ( DotListF
-            ( Fix
-                ( SimpleF
-                    ( Symbol "가" )
-                ) :|
-                [ Fix
-                    ( SimpleF
-                        ( Symbol "나" )
-                    )
-                , Fix
-                    ( SimpleF
-                        ( Symbol "다" )
-                    )
-                ]
-            )
-            ( Fix
-                ( SimpleF
-                    ( Symbol "라" )
-                )
-            )
-        )
-    )
-]

golden/reader/list-flat/read

@@ -1,35 +0,0 @@
-[ Fix
-    ( CompoundF
-        ( ListF
-            [ Fix
-                ( SimpleF
-                    ( Symbol "가" )
-                )
-            , Fix
-                ( SimpleF
-                    ( Symbol "나" )
-                )
-            , Fix
-                ( SimpleF
-                    ( Symbol "다" )
-                )
-            , Fix
-                ( SimpleF
-                    ( Symbol "라" )
-                )
-            , Fix
-                ( SimpleF
-                    ( Number 1.0 )
-                )
-            , Fix
-                ( SimpleF
-                    ( Number 2.0 )
-                )
-            , Fix
-                ( SimpleF
-                    ( Number 3.0 )
-                )
-            ]
-        )
-    )
-]

golden/reader/list/read

@@ -1,60 +0,0 @@
-[ Fix
-    ( CompoundF
-        ( DotListF
-            ( Fix
-                ( SimpleF
-                    ( Symbol "a" )
-                ) :|
-                [ Fix
-                    ( SimpleF
-                        ( Symbol "b" )
-                    )
-                , Fix
-                    ( CompoundF
-                        ( ListF
-                            [ Fix
-                                ( SimpleF
-                                    ( Symbol "c" )
-                                )
-                            , Fix
-                                ( SimpleF
-                                    ( Symbol "d" )
-                                )
-                            ]
-                        )
-                    )
-                ]
-            )
-            ( Fix
-                ( CompoundF
-                    ( ListF
-                        [ Fix
-                            ( SimpleF
-                                ( Symbol "가" )
-                            )
-                        , Fix
-                            ( CompoundF
-                                ( DotListF
-                                    ( Fix
-                                        ( SimpleF
-                                            ( Symbol "나" )
-                                        ) :| []
-                                    )
-                                    ( Fix
-                                        ( SimpleF
-                                            ( Symbol "다" )
-                                        )
-                                    )
-                                )
-                            )
-                        , Fix
-                            ( SimpleF
-                                ( Symbol "라" )
-                            )
-                        ]
-                    )
-                )
-            )
-        )
-    )
-]

golden/reader/peculiar-identifier/read

@@ -1,9 +0,0 @@
-[ Fix
-    ( SimpleF
-        ( Symbol "+" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "-" )
-    )
-]

golden/reader/peculiar-identifier/source.scm

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

golden/reader/string/read

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

golden/reader/typical-identifier/read

@@ -1,37 +0,0 @@
-[ Fix
-    ( SimpleF
-        ( Symbol "abc" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "balahwa$" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "x!!!" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "z" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "z123" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "나는너무졸리다" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "學" )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "車室." )
-    )
-, Fix
-    ( SimpleF
-        ( Symbol "三個女人一臺戲。" )
-    )
-]

golden/reader/typical-identifier/source.scm

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

gyehoek.cabal

@@ -13,6 +13,11 @@ build-type:    Simple
 -- extra-doc-files:    CHANGELOG.md
 -- extra-source-files:
 
+flag doctest
+  description: enable the doctest suite
+  default:     True
+  manual:      True
+
 common ghcstuffs-dev
   ghc-options:
     -Wno-unused-matches -Wno-missing-signatures -Wno-typed-holes
@@ -21,6 +26,7 @@ common ghcstuffs
   ghc-options:
     -Wall -fdefer-type-errors -fno-show-valid-hole-fits
     -fdefer-out-of-scope-variables -threaded
+    -Wno-name-shadowing -Wno-partial-type-signatures
 
   default-extensions:
     BlockArguments
@@ -49,32 +55,37 @@ executable gyehoek
 library
   import:           ghcstuffs, ghcstuffs-dev
   ghc-options:      -fplugin=Effectful.Plugin
+  -- build-tool-depends: retrie:retrie
 
   -- cabal-fmt: expand src
   exposed-modules:
     Gyehoek.CPS.Close
     Gyehoek.CPS.Convert
     Gyehoek.CPS.Eval
-    Gyehoek.CPS.Lower
+    Gyehoek.CPS.Hoist
-    Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
     Gyehoek.GenSym
+    Gyehoek.Jalmot
     Gyehoek.Language
+    Gyehoek.Language.Common
+    Gyehoek.Lift1
     Gyehoek.Options
     Gyehoek.Prelude
+    Gyehoek.Scheme.Expand
+    Gyehoek.Scheme.Expand.Old
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
     Gyehoek.Sexp.Grammar
+    Gyehoek.Sexp.Grammar.Base
     Gyehoek.Sexp.Print
+    Gyehoek.Sexp.QQ
     Gyehoek.Sexp.Read
     Gyehoek.Sexp.Syntax
-    Gyehoek.Stack.Syntax
-    Gyehoek.Stack.VM
     Gyehoek.Wasm
 
   build-depends:
-    , base                  ^>=4.21.2.0
+    , base                         ^>=4.21.2.0
     , binary
     , bytestring
     , comonad
@@ -91,23 +102,29 @@ library
     , hashable
     , invertible-grammar
     , lens
+    , lucid
     , megaparsec
     , mtl
     , optparse-applicative
     , ordered-containers
     , pretty-simple
     , prettyprinter
+    , prettyprinter-ansi-terminal
+    , prettyprinter-lucid
     , process
     , recursion-schemes
     , scientific
-    , sexp-grammar
+    , semialign
     , string-interpolate
+    , tardis
     , template-haskell
     , text
     , text-short
+    , these
     , typed-process
     , unordered-containers
     , vector
+    , witherable
 
   hs-source-dirs:   src
   default-language: GHC2024
@@ -122,12 +139,12 @@ test-suite test
   -- cabal-fmt: expand test -Main
   other-modules:
     Gyehoek.Test.CPS.Eval
-    Gyehoek.Test.CPS.Stackify
     Gyehoek.Test.CPS.Syntax
-    Gyehoek.Test.Golden
     Gyehoek.Test.Scheme.Syntax
-    Gyehoek.Test.Sexp
+    Gyehoek.Test.Sexp.Print
-    Gyehoek.Test.Stack.VM
+    Gyehoek.Test.Sexp.QQ
+    Gyehoek.Test.Sexp.Read
+    Gyehoek.TestUtil
     Root
 
   build-depends:
@@ -141,7 +158,6 @@ test-suite test
     , lens
     , pretty-simple
     , process-extras
-    , sexp-grammar
     , tasty
     , tasty-expected-failure
     , tasty-hunit
@@ -149,3 +165,21 @@ test-suite test
     , text
 
   default-language:   GHC2024
+
+-- https://github.com/martijnbastiaan/doctest-parallel/pull/66
+test-suite doctest
+  import:             ghcstuffs, ghcstuffs-dev
+  type:               exitcode-stdio-1.0
+  hs-source-dirs:     test
+  build-depends:
+    , base
+    , gyehoek
+
+  default-extensions: CPP
+  main-is:            doctest.hs
+
+  if flag(doctest)
+    build-depends: doctest-parallel >=0.1
+
+  else
+    cpp-options: -DGYEHOEK_NO_DOCTEST

macroexpand.scm

@@ -0,0 +1,11 @@
+(define-syntax if-not
+  (syntax-rules ()
+    ((_ c t f) (if (not c) t f))
+    ((_ c t) (if (not c) t))))
+
+(write (macroexpand-1 '(if-not #t 123 456)))
+
+(define (main)
+  (let loop ((datum (read)))
+    (unless (eof-object? datum)
+      ())))

src/Gyehoek/CPS/Close.hs

@@ -4,38 +4,52 @@ module Gyehoek.CPS.Close
   ) where
 
 import Gyehoek.CPS.Syntax
+import Data.List (nub)
 import Gyehoek.GenSym
 import Gyehoek.Prelude
+import Debug.Pretty.Simple
+import Gyehoek.Sexp qualified as S
+import Data.HashSet.Lens
+import Data.Traversable
 
 
-close :: GenSym :> es => Exp -> Eff es Exp
+genCodeName :: GenSym :> es => Name -> Eff es Name
-close = transformM \case
+genCodeName f = gensym' @Name $ f ^. _Wrapped' . to (<> "-code")
-  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
+bindEnv :: List Name -> Exp -> Exp
-    code <- gensym' @Name "code"
+bindEnv frees m = [cps|
+  (builtin (get-env) (κ #{frees} #{m}))
+|]
+
+close1 :: forall es. GenSym :> es => Exp -> Eff es Exp
+close1 = \case
+  lr@(ExpLetRec bs e) -> do
+    let boundNames = bs ^.. each . _1
+    let boundNames' = setOf each boundNames
+    let frees = bs
+          & foldMapOf
+            (each . _2)
+            (freeWithBound' boundNames')
+          & nub
+    env_cont_l <- gensym' @Name "env-cont"
+    e_l <- gensym' @Name "letrec-body-cont"
+    bs' <- for bs \(f,ab) -> do
+      f_code_l <- genCodeName f
+      pure ( f_code_l
+           , ab & absBody %~ bindEnv (boundNames ++ frees)
+           )
+    let codes = bs' ^.. each . _1 . to MkLabel
     pure [cps|
-      (prim (env-code #{f})
+      (letrec #{bs'}
-        (κ (#{code})
+        (builtin (make-shared-closure #{codes} #{frees})
-          (#{code} #{f} ##{xs} #{ktail})))
+          (κ #{boundNames}
+            #{e})))
     |]
 
   e -> pure e
 
+close :: forall es. GenSym :> es => Exp -> Eff es Exp
+close = transformM close1
+
 closeProgram :: GenSym :> es => Program -> Eff es Program
-closeProgram = traverseOf #body close
+closeProgram = traverseOf (#body . #body) close

src/Gyehoek/CPS/Convert.hs

@@ -12,6 +12,7 @@ import Data.List.NonEmpty (NonEmpty((:|)))
 import Control.Monad.Cont qualified as Cont
 import qualified Data.List.NonEmpty as NE
 import Gyehoek.Prelude
+import Debug.Pretty.Simple
 
 
 -- 뻘짓이어라
@@ -23,66 +24,73 @@ telescope f = Cont.runCont . traverse (Cont.cont . f)
 
 
 
+one :: a -> List a
+one a = [a]
+
+oneOrUndefined :: List Val -> Val
+oneOrUndefined = \case
+  [x] -> x
+  _ -> ValImm ImmUndefined
+
+convert1 :: (GenSym :> es) => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
+convert1 e k = convert e (k . oneOrUndefined)
+
 -- | Transform an expression with a meta-continuation.
 convert
   :: forall es. (GenSym :> es)
-  => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
+  => Scm.Exp -> (List Val -> Eff es Exp) -> Eff es Exp
 
-convert (Scm.ExpVar x) k = k $ ValVar x
+convert (Scm.ExpVar x) k = k [ValVar x]
-convert (Scm.ExpLit l) k = k . ValImm $ case l of
+convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
   LitInt n -> ImmInt n
   LitBool b -> ImmBool b
   _ -> _
 
--- special case: call/cc is desugared during cps-conversion...
+convert (Scm.ExpBuiltin p) k =
-convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
+  telescope (convert1 @es) p \p' -> do
-  convert withcc \withcc' -> do
+    r_l <- gensym' "r"
-    cc <- gensym' @Name "cc"
+    m <- k [ValVar r_l]
-    r <- gensym' "r"
-    m <- k $ ValVar r
-    ccish <- gensym' @Name "cc-ish"
-    x <- gensym' @Name "x"
     pure [cps|
-      (letrec ((#{cc} (κ (#{r}) #{m})))
+      (builtin #{p'} (κ (#{r_l}) #{m}))
-        (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
-          (#{withcc'} #{ccish} #{cc})))
     |]
 
--- ...while all other prims are left as-is for later stages to
--- handle..
-convert (Scm.ExpPrim p) k =
-  telescope (convert @es) p \p' -> do
-    r <- gensym' "r"
-    ExpPrim p' . MkKappa [r] <$> k (ValVar r)
-
 convert (Scm.ExpLambda xs e) k = do
   f <- gensym' "lambda-body"
   lam <- convertLambda xs e
-  ke <- k $ ValVar f
+  ke <- k [ValVar f]
   pure [cps|
     (letrec ((#{f} #{lam}))
       #{ke})
   |]
 
 convert (Scm.ExpApply f xs) k =
-  telescope (convert @es) (f:|xs) \(f':|xs') -> do
+  telescope (convert1 @es) (f:|xs) \(f':|xs') -> do
-    r <- gensym' "r"
+    r <- gensym' @Name "r"
     x <- gensym' "x"
-    m <- k (ValVar x)
+    m <- k [ValVar x]
-    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $ ExpApply f' xs' r
+    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $
+      ExpApply f' xs' (KexpVar r)
 
-convert (Scm.ExpBegin xs) k = _
+convert (Scm.ExpBegin xs) k = telescope (convert @es) xs (k . NE.last)
 
-convert (Scm.ExpIf c t f) k =
+convert (Scm.ExpIf c t (Just f)) k =
-  convert c \c' ->
+  convert1 c \c' -> do
-    ExpIf c' <$> convert t k <*> convert f k
+    t_l <- gensym' @Name "truthy-cont"
+    f_l <- gensym' @Name "falsey-cont"
+    t' <- convert t k
+    f' <- convert f k
+    pure [cps|
+      (letrec ((#{t_l} (κ () #{t'}))
+               (#{f_l} (κ () #{f'})))
+        (if #{c'} #{t_l} #{f_l}))
+    |]
 
 -- 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
+  in telescope (convert1 @es) rhss \rhss' -> do
     e' <- convert e k
     kbody <- gensym' @Name "let-body"
     let bs' = bs ^.. each . _1
@@ -105,12 +113,15 @@ convertLambda
   => List Name -> Scm.Exp -> Eff es Lambda
 convertLambda bs m = do
   ktail <- gensym' "lambda-tail"
-  m' <- convert m $ pure . ExpContinue ktail . (:[])
+  m' <- convert1 m $ pure . ExpContinue (ValVar ktail) . (:[])
   pure [cps|(λ (##{bs} #{ktail}) #{m'})|]
 
 convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
-convertProgram p =
+convertProgram p = do
-  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) (pure . Halt)
+  ktail <- gensym' "start-ktail"
+  m <- telescope (convert1 @es) (p ^.. each . _Left)
+        (pure . ExpContinue (ValVar ktail))
+  pure . MkProgram $ MkLambda [] ktail m
 
 convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
-convertExp e = convert e (pure . Halt1)
+convertExp e = convert e (pure . Halt)

src/Gyehoek/CPS/Eval.hs

@@ -1,79 +1,303 @@
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedLists #-}
 module Gyehoek.CPS.Eval
   ( evalProgram
   , module Gyehoek.CPS.Syntax
+  , evalExp
+  , eGrammar
   ) where
 
-import Gyehoek.CPS.Syntax
+import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont)
-import Control.Lens
+import Gyehoek.Sexp qualified as S
-import Data.Maybe (fromMaybe)
+import Control.Lens hiding (assign)
+import Data.Maybe (fromMaybe, isJust)
 import Text.Show.Functions ()
 import qualified Data.HashMap.Strict as H
-import Gyehoek.Prelude
+import Gyehoek.Prelude hiding (assign)
+import Debug.Pretty.Simple
+import Gyehoek.Jalmot
+import Control.Monad.Cont
+import Gyehoek.Sexp qualified as S
+import GHC.Generics (Generically(..))
+import Gyehoek.Sexp ((:-)(..))
+import Data.List (nub, mapAccumR, compareLength)
+import Data.HashSet.Lens (setOf)
+import Data.IntMap.Strict (IntMap)
+import Data.IntMap.Strict qualified as IM
+import Data.Monoid
+import Control.Monad.State
+import Data.Traversable (for)
+import Data.Foldable (traverse_, foldrM)
 
 
-data Env = MkEnv
+newtype Loc = MkLoc { getLoc :: Int }
-  { vars :: HashMap Name Obj
+  deriving stock (Generic, Data)
-  , labels :: HashMap Name (Env, Abs)
+  deriving newtype (Show, Eq, Ord, Enum)
+
+data Store = MkStore
+  { nextLoc :: Loc
+  , heap :: IntMap E
   }
-  deriving (Show, Generic)
+  deriving stock (Show, Generic)
 
-eval :: Env -> Exp -> List Obj
+type instance Index Store = Loc
+type instance IxValue Store = E
 
-eval g (Halt xs) = evalVal g <$> xs
+instance Ixed Store where ix (MkLoc j) = #heap . ix j
+instance At Store where at (MkLoc j) = #heap . at j
 
-eval g (ExpContinue k xs) =
+emptyStore :: Store
-  case g ^. #labels . at k of
+emptyStore = MkStore
-    Just (h, AbsKappa' bs m) -> eval h' m
+  { nextLoc = MkLoc 0
-      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
+  , heap = mempty
-    _ -> error [i|not a kappa: #{k}|]
+  }
 
-eval g (ExpApply ((^?! #ValVar) -> f) xs ktail) =
+newtype Env = MkEnv { getEnv :: HashMap Name Loc }
-  case g ^?! #labels . at f of
+  deriving stock (Show, Generic, Data)
-    Just (h,AbsLambda' bs kb m) -> eval h' m
+  deriving newtype (Semigroup, Monoid)
-      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
-                   & #labels . at kb .~ (g ^. #labels . at ktail)
-    Nothing -> error [i|undefined label: #{f}|]
-
-eval g (ExpLetRec [(b, ab)] e) = eval g' e
-  where g' = g & #labels . at b ?~ (g,ab)
-
-eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
-  PrimAdd x y -> arithBinop (+) x y
-  PrimMul x y -> arithBinop (*) x y
-  PrimSub x y -> arithBinop (-) x y
-  PrimDiv x y -> arithBinop div x y
-  _ -> error [i|unhandled prim: #{p}|]
-  where
-    ret rs = eval
-        (g & #vars <>~ envOfBinds bs rs)
-        e
-    arithBinop f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
-      ret [ObjImm . ImmInt $ f x y]
-    arithBinop _ x y = error [i|bad arith: #{x}, #{y}|]
-
-eval _ e = error [i|unimplemented case: #{e}|]
-
-envOfBinds bs xs = foldMap (uncurry H.singleton) (zip bs xs)
-
-evalVal :: Env -> Val -> Obj
-evalVal g = \case
-  ValVar x -> fromMaybe (error [i|unbound: #{x}|]) $ g ^?! #vars . at x
-  ValImm x -> ObjImm x
 
 emptyEnv :: Env
-emptyEnv = MkEnv
+emptyEnv = mempty
-  { vars = mempty
-  -- a kinda silly hack to make sure `halt` is handled correctly when
-  -- it appears as the tail continuation of an application. the
-  -- special case of `eval` responsible for `halt` only covers terms
-  -- of the form `(continue $halt xs …)`; other terms such as
-  -- `($some-fn xs $halt)` just see an undefined label `$halt`.
-  , labels = H.singleton "halt"
-    ( emptyEnv
-    , AbsKappa' ["h0"] $ Halt [ValVar "h0"]
-    )
-  }
 
-evalProgram :: Program -> List Obj
+type instance Index Env = Name
-evalProgram (MkProgram e) = eval emptyEnv e
+type instance IxValue Env = Loc
+
+instance Ixed Env where ix j = #getEnv . ix j
+instance At Env where at j = #getEnv . at j
+
+update :: Loc -> E -> Store -> Store
+update (MkLoc loc) v = #heap %~ IM.alter f loc
+  where
+    f (Just _) = Just v
+    f Nothing = error "segfault lol"
+
+updates :: Foldable f => f (Loc, E) -> Store -> Store
+updates = alaf Endo foldMap (uncurry update)
+
+fetch :: Loc -> M r E
+fetch (MkLoc loc) = gets (^?! #heap . ix loc)
+
+new :: M r Loc
+new = state \st -> (st.nextLoc, st & #nextLoc %~ succ)
+
+new' :: E -> M r Loc
+new' e = state \st ->
+  ( st.nextLoc
+  , st & #nextLoc %~ succ & at st.nextLoc ?~ e
+  )
+
+defines :: Traversable t => t (Name, E) -> M Answer Env
+defines = alaf Ap foldMap \(name,e) -> do
+  l <- new' e
+  pure $ bind name l
+
+var :: HasCallStack => Env -> Name -> M Answer Loc
+var g x = case g ^. at x of
+  Just l -> pure l
+  Nothing -> wrong [i|unbound variable #{x}|]
+
+type CmdCont = Store -> Answer
+type ExpCont = List E -> CmdCont
+
+type M r = ContT r (State Store)
+
+data Answer
+  = AnswerValues (List E)
+  | AnswerError AJalmot
+  deriving (Show, Generic)
+
+data Mutability
+  = Mut
+  | NoMut
+  deriving (Show, Generic, Data, Eq)
+
+wrong :: Text -> M Answer a
+wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
+
+orWrong
+  :: Getting (First a) s a
+  -> Text -> s -> M Answer a
+orWrong p msg s = case getFirst . getConst $ p (Const . First . Just) s of
+  Nothing -> wrong msg
+  Just x -> pure x
+
+bind :: Name -> Loc -> Env
+bind k = MkEnv . H.singleton k
+
+extends :: Foldable f => f (Name, Loc) -> Env -> Env
+extends xs g = g <> foldMap (uncurry bind) xs
+
+assign :: Loc -> E -> M Answer ()
+assign l e = do
+  use (at l) >>= \case
+    Just _ -> at l ?= e
+    Nothing -> wrong [i|#{e}에서 #{l}이라는 주소는 없다|]
+
+
+
+-- | The denotation of an expressed value.
+data E
+  = ESymbol Text
+  | ECharacter Char
+  | EInt Int
+  | EBool Bool
+  | EUndefined
+  | EUnspecified
+  | ENull
+  | EPair Mutability Loc Loc
+  | EVec Mutability (List Loc)
+  | EString Mutability (List Loc)
+  | EProcedure Procedure
+  deriving stock (Show, Generic)
+
+type Procedure = List E -> DynPoints -> M Answer (List E)
+
+eGrammar :: Store -> S.DatumGrammar E
+eGrammar st = S.partialOsi (const . Left $ mempty) go
+  where
+    gofetch x = go $ st ^?! ix x
+    go = \case
+      ESymbol s -> S.Symbol s
+      ECharacter c -> S.Character c
+      EInt n -> S.Number (fromIntegral n)
+      EBool b -> S.Boolean b
+      EUndefined -> S.Unreadable "#<undefined>"
+      EUnspecified -> S.Unreadable "#<unspecified>"
+      EProcedure _ -> S.Unreadable "#<procedure>"
+      ENull -> S.List []
+      EPair _mut car cdr -> S.DotList [gofetch car] (gofetch cdr)
+      EVec _mut xs -> S.Vector . fmap gofetch $ xs
+      EString _mut xs -> S.String _
+
+data DynPoints = MkDynPoints
+  deriving (Generic, Data)
+
+
+
+truthy :: E -> Bool
+truthy (EBool False) = False
+truthy _ = True
+
+
+
+evalVal :: Env -> Val -> M Answer E
+
+evalVal g (ValVar x) = var g x >>= fetch
+
+evalVal g (ValImm imm) = case imm of
+  ImmLabel (MkLabel l) -> var g l >>= fetch
+  ImmInt n -> pure $ EInt n
+  ImmBool b -> pure $ EBool b
+  ImmUndefined -> pure EUndefined
+
+evalKexp :: Env -> Kexp -> M Answer E
+evalKexp g (KexpVar x) = var g x >>= fetch
+evalKexp g (KexpKappa kap) = evalAbs g (AbsKappa kap)
+
+evalAbs :: Env -> Abs -> M Answer E
+evalAbs g (MkAbs formals ktail e) = pure . EProcedure $ \xs dps ->
+  let
+    formals' = formals ++ foldMap (:[]) ktail
+    lformals = length formals'
+    lxs = length xs
+  in if lformals /= lxs
+  then wrong [i|함수는 #{lformals}개의 인자를 필요로 하는데 #{lxs}개 받았다.|]
+  else do
+    ls <- xs & traverse new'
+    let g' = g & extends (zip formals' ls)
+    eval g' dps e
+
+eval :: Env -> DynPoints -> Exp -> M Answer (List E)
+
+eval g dps (ExpJump f xs ktail) = do
+  f' <- evalVal g f
+  xs' <- traverse (evalVal g) xs
+  ktail' <- traverse (evalKexp g) (ktail ^.. _Just)
+  case f' of
+    EProcedure p -> p (xs' ++ ktail') dps
+    _ -> wrong "bad procedure"
+
+eval g dps (ExpLetRec bs e) = do
+  ls <- for bs . const $ new' EUndefined
+  let g' = g & extends (zip (bs ^.. each . _1) ls)
+  bs' <- forOf (each . _2) bs (evalAbs g')
+  traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2)
+  eval g' dps e
+
+eval g dps (ExpBuiltin (BuiltinCallCC withcc) k) = do
+  withcc' <- evalVal g withcc >>= orWrong #_EProcedure
+    [i|call/cc: 함수가 아닌 것을 받았다|]
+  k' <- evalKexp g k
+  kproc <- orWrong #_EProcedure [i|call/cc: 몰라...|] k'
+  let cc = EProcedure \xs dps -> case unsnoc xs of
+        Just (xs',_) -> kproc xs' dps
+        Nothing -> wrong [i|call/cc: 잘못하는데!|]
+  withcc' [cc,k'] dps
+
+eval g dps (ExpBuiltin p k) = do
+  p' <- evalBuiltin g dps =<< traverse (evalVal g) p
+  evalKexp g k >>= \case
+    EProcedure fp -> fp p' dps
+    _ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
+
+eval g dps (ExpIf c t f) = do
+  c' <- evalVal g c
+  let b = if truthy c' then t else f
+  var g b >>= fetch >>= \case
+    EProcedure fp -> fp [] dps
+    _ -> wrong [i|if의 계속을 나쁘다|]
+
+eval g dps e = error [i|unimplemented #{e}|]
+
+evalBuiltin :: Env -> DynPoints -> Builtin E -> M Answer (List E)
+evalBuiltin g dps = \case
+  BuiltinAdd x y -> arith2 (+) x y
+  BuiltinMul x y -> arith2 (*) x y
+  BuiltinSub x y -> arith2 (-) x y
+  BuiltinDiv x y -> arith2 div x y
+  BuiltinZeroP x -> pure1 . EBool . isJust $ x ^? #EInt . only 0
+  BuiltinCons x y -> pcons x y >>= pure1
+  BuiltinCar p -> cr p _2
+  BuiltinCdr p -> cr p _3
+  BuiltinPairP p -> pure1 . EBool . maybe False (const True) $
+    p ^? #_EPair
+  BuiltinValues xs -> pure xs
+  BuiltinList xs -> foldrM pcons ENull xs >>= pure1
+  p -> wrong [i|prim(#{p})은 벌써 나지 않다|]
+  where
+    pure1 x = pure [x]
+    pcons x y = do
+      (x',y') <- traverseOf both new' (x,y)
+      pure $ EPair Mut x' y'
+    arith2 f (EInt x) (EInt y) = pure [EInt $ f x y]
+    arith2 f x y = wrong [i|나쁜 인자: #{x}, #{y}|]
+    cr p l = orWrong (#_EPair . l) [i|car/cdr는 pair을 받지 않다|] p
+      >>= fmap (:[]) . fetch
+
+
+
+evalExp :: Jalmot :> es => Exp -> Eff es _
+evalExp e = _
+
+evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum)
+evalProgram (MkProgram lam) = case run (pure . AnswerValues) of
+  (AnswerError jm, _) -> throwError jm
+  (AnswerValues vs, st) -> traverse (S.toDatum $ eGrammar st) vs
+  where
+    run f = (`runState` emptyStore) . (`runContT` f) $ do
+      g <- setup
+      eval g MkDynPoints (ExpLetRec
+        [("_start",AbsLambda lam)]
+        (ExpApply (ValVar "_start") [] (KexpVar "halt")))
+
+
+
+setup :: M Answer Env
+setup = defines @List
+  [ ("halt", EProcedure prim_halt)
+  ]
+
+prim_halt :: Procedure
+prim_halt xs _dps = ContT \_ -> pure $ AnswerValues xs

src/Gyehoek/CPS/Hoist.hs

@@ -0,0 +1,24 @@
+module Gyehoek.CPS.Hoist
+  ( hoistProgram
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Gyehoek.Prelude
+import qualified Data.HashMap.Strict as H
+import Effectful.Writer.Static.Local
+import Data.Foldable
+
+
+type Hoist = Writer (HashMap Label Abs)
+
+hoist :: Hoist :> es => Exp -> Eff es Exp
+hoist = transformM \case
+  ExpLetRec bs m -> do
+    traverse_ (\(k,v) -> tell $ H.singleton (MkLabel k) v) bs
+    pure m
+  e -> pure e
+
+hoistProgram :: Program -> Eff es HoistedProgram
+hoistProgram p = do
+  (body,bindings) <- runWriter $ traverseOf #body hoist p.body
+  pure $ MkHoistedProgram {body,bindings}

src/Gyehoek/CPS/Lower.hs

@@ -1,342 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MultilineStrings #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE RecursiveDo #-}
-{- HLINT ignore "Use camelCase" -}
-module Gyehoek.CPS.Lower
-  (lower, lowerProgram) where
-
-import Gyehoek.CPS.Syntax
-import Data.Vector.Strict (Vector)
-import Control.Lens hiding (op)
-import Numeric.Natural
-import qualified Data.Vector.Strict as V
-import Gyehoek.Wasm qualified as Wasm
-import Gyehoek.Wasm hiding (Expr)
-import Language.Sexp.Located qualified as SL
-import Control.Monad.Fix
-import qualified Gyehoek.Sexp
-import Data.Text qualified as T
-import Data.Foldable (fold)
-import Gyehoek.Sexp (encodeOrShow)
-import Gyehoek.Prelude
-
-
-data Env = MkEnv
-  { vars :: Vector Name
-  , kvars :: Vector Name
-  }
-  deriving (Show, Generic)
-
-type instance Index Env = Natural
-type instance IxValue Env = Name
-
-instance Ixed Env where
-  ix i = #vars . ix (fromIntegral i)
-
-
-
-tonat :: Integral a => a -> Natural
-tonat = fromIntegral
-
--- | @makeSmallFixnum@ emits an expression injecting the i32 on top
--- of the stack into the SCM unitype.
-makeSmallFixnum :: Wasm.Expr
-makeSmallFixnum = [expr|
-    (@gyehoek "construct small fixnum")
-    (i32.const 1)
-    i32.shl
-    ref.i31
-  |]
-
-getArgRegister :: Natural -> SL.Sexp
-getArgRegister n = SL.Symbol [i|$arg#{n}|]
-
--- | Given an expression @e@ leaving a @ref eq@ atop the stack,
--- @pushArg rt n e@ sets the nth slot of the arg-passing array to the
--- result of @e@.
-pushArg :: Natural -> Wasm.Expr -> Wasm.Expr
-pushArg n e = [expr|
-    (@gyehoek 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 :: Natural -> Wasm.Expr
-popArg n = [expr|
-  (@gyehoek begin popArg)
-  (global.get #{reg})
-  ref.as_non_null
-  (@gyehoek end popArg)
-|]
-  where reg = getArgRegister n
-
-
-
-lowerVal :: (HasCallStack, GenMod :> es) => Env -> Val -> Eff es Wasm.Expr
-
-lowerVal g (ValImm imm) =
-  pure $ case imm of
-    ImmInt n -> [expr|
-      (i32.const #{n})
-      ##{makeSmallFixnum}
-    |]
-    ImmBool b -> [expr|
-      (i32.const #{b'})
-      ref.i31
-    |]
-      where b' :: Int = if b then 0b11 else 0b01
-    _ -> _
-
-lowerVal g (ValVar x) = do
-  pure [expr|(global.get #{l})|]
-  where
-    l = getArgRegister . fromIntegral . succ $ V.elemIndex x g.vars ^?! _Just
-
-lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
-
-lower' g (Halt [v]) = do
-  arg <- pushArg 0 <$> lowerVal g v
-  pure [expr|
-    ##{arg}
-    (return_call $halt (i32.const 1))
-  |]
-
-lower' g e@(ExpPrim p k) =
-  ([expr|(@gyehoek :origin #{origin})|]<>)
-  <$> case p of
-    PrimAdd x y -> lowerBinOp "i32.add" g x y k
-    PrimMul x y -> lowerBinOp "i32.mul" g x y k
-  where origin = encodeOrShow @_ @Text e
-
-lower' g (ExpIf c t f) = do
-  c' <- lowerVal g c
-  t' <- lower' g t
-  f' <- lower' g f
-  pure [expr|
-    ##{c'}
-    (call $gh-truthy?)
-    (if (then ##{t'})
-        (else ##{f'}))
-  |]
-
-lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do
-  idx <- lowerKappa g kap
-  let g' = g & #kvars <>~ [r]
-  e' <- lower' g' e
-  let origin = encodeOrShow @_ @Text e
-  pure [expr|
-    (@gyehoek :origin #{origin})
-    (@gyehoek "push cont" :idx #{idx})
-    (array.set $cont-stack-type
-               (global.get $cont-stack)
-               (global.get $cont-stack-top)
-               (ref.func #{idx}))
-    (global.set $cont-stack-top
-                (i32.add (global.get $cont-stack-top)
-                         (i32.const 1)))
-    ##{e'}
-  |]
-
-lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do
-  idx <- lowerLambda g lam
-  let g' = g & #vars <>~ [r]
-  let n = succ $ length g.vars
-  e' <- lower' g' e
-  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 -> 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 [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'}
-  |]
-
-
-
-emitRuntime :: GenMod :> es => Eff es ()
-emitRuntime = mfix \runtime -> do
-  Wasm.defineFunctions [wats|
-    (import "gyehoek" "write" (func $gh-write (param (ref eq))))
-    (import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq))
-                                  (result i32)))
-  |]
-  -- cont stack
-  Wasm.defineTypes [wats|
-    (type $heap-object (sub (struct (field $hash (mut i32)))))
-    (type $cont-type (func (param i32)))
-    (type $cont-stack-type (array (mut (ref null $cont-type))))
-    (type $closure (sub $heap-object
-                        (struct (field $hash (mut i32))
-                                (field $code (ref $cont-type)))))
-  |]
-  Wasm.defineGlobals [wats|
-    (global $cont-stack-top (mut i32) (i32.const 0))
-    (global $cont-stack (ref $cont-stack-type)
-            (array.new_default $cont-stack-type (i32.const 128)))
-  |]
-  -- arg 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 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

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