fix tests }:3

flake.nix

@@ -16,11 +16,10 @@
         "x86_64-darwin" "x86_64-linux"
       ];
 
-
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          gyehoek-wasmtime-wrapper = final.callPackage ./wasmtime.nix {};
+          shake-wrapper = final.callPackage ./shake-wrapper.nix {};
           gyehoek-runtime = final.callPackage ./runtime {};
           gyehoek = final.haskell-nix.project' {
             src = ./.;
@@ -29,13 +28,10 @@
               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
                 '';
             })];
@@ -50,14 +46,14 @@
               };
               buildInputs = with final; [
                 haskellPackages.cabal-fmt
-                self.packages.${final.stdenv.hostPlatform.system}.shake
+                shake-wrapper
                 wabt
                 nodejs
                 wasm-tools
                 wac-cli
                 guile
-                gyehoek-wasmtime-wrapper
                 rust-analyzer
+                wasmtime
               ];
             };
           };
@@ -89,7 +85,7 @@
         hf.packages.${system} // lib.fix (packages: {
           gyehoek = hf.packages.${system}."gyehoek:exe:gyehoek";
           default = packages.gyehoek;
-          shake = pkgs.callPackage ./shake-wrapper.nix {};
+          inherit (pkgs) gyehoek-runtime shake-wrapper;
         }));
 
       devShells = each-system

golden/arith/out.wat

@@ -3,6 +3,10 @@
     "gyehoek"
     "write"
     (func $gh-write (param (ref eq))))
+  (import
+    "gyehoek"
+    "to-bool"
+    (func $gh-to-bool (param (ref eq)) (result i32)))
   (type $heap-object (sub (struct (field $hash (mut i32)))))
   (type $cont-type (func (param i32)))
   (type $cont-stack-type (array (mut (ref null $cont-type))))

golden/if-false/exec

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

golden/if-false/out.wat

@@ -1,13 +1,61 @@
 (module
-  (type (sub (struct (field (mut i32)))))
+  (import
+    "gyehoek"
+    "write"
+    (func $gh-write (param (ref eq))))
+  (import
+    "gyehoek"
+    "to-bool"
+    (func $gh-to-bool (param (ref eq)) (result i32)))
+  (type $heap-object (sub (struct (field $hash (mut i32)))))
+  (type $cont-type (func (param i32)))
+  (type $cont-stack-type (array (mut (ref null $cont-type))))
+  (global $cont-stack-top (mut i32) (i32.const 0))
+  (global
+    $cont-stack
+    (ref $cont-stack-type)
+    (array.new_default $cont-stack-type (i32.const 128)))
+  (type $arg-array-type (array (mut (ref null eq))))
+  (global
+    $arg-array
+    (ref $arg-array-type)
+    (array.new_default $arg-array-type (i32.const 32)))
+  (global $result (mut (ref null eq)) (ref.null eq))
   (func
-    (param)
+    $halt
-    (result (ref eq))
+    (param i32)
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (global.get $arg-array)
     (i32.const 0)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (global.set $result))
+  (func
+    $scm-entry
+    (param i32)
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (i32.const 1)
     ref.i31
+    (call $gh-to-bool)
     (if
-      (result i32)
+      (then
-      (then (i32.const 777) ref.i31)
+        (global.get $arg-array)
-      (else (i32.const 555) ref.i31)))
+        (global.get 0)
-  (export "main" (func 0)))
+        (i32.const 777)
+        (i32.const 1)
+        i32.shl
+        ref.i31
+        (array.set $arg-array-type)
+        (return_call $halt (i32.const 1)))
+      (else
+        (global.get $arg-array)
+        (global.get 0)
+        (i32.const 555)
+        (i32.const 1)
+        i32.shl
+        ref.i31
+        (array.set $arg-array-type)
+        (return_call $halt (i32.const 1)))))
+  (func
+    (export "main")
+    (call $scm-entry (i32.const 0))
+    (call $gh-write (ref.as_non_null (global.get $result)))))

golden/if-true/exec

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

golden/if-true/out.wat

@@ -1,13 +1,61 @@
 (module
-  (type (sub (struct (field (mut i32)))))
+  (import
+    "gyehoek"
+    "write"
+    (func $gh-write (param (ref eq))))
+  (import
+    "gyehoek"
+    "to-bool"
+    (func $gh-to-bool (param (ref eq)) (result i32)))
+  (type $heap-object (sub (struct (field $hash (mut i32)))))
+  (type $cont-type (func (param i32)))
+  (type $cont-stack-type (array (mut (ref null $cont-type))))
+  (global $cont-stack-top (mut i32) (i32.const 0))
+  (global
+    $cont-stack
+    (ref $cont-stack-type)
+    (array.new_default $cont-stack-type (i32.const 128)))
+  (type $arg-array-type (array (mut (ref null eq))))
+  (global
+    $arg-array
+    (ref $arg-array-type)
+    (array.new_default $arg-array-type (i32.const 32)))
+  (global $result (mut (ref null eq)) (ref.null eq))
   (func
-    (param)
+    $halt
-    (result (ref eq))
+    (param i32)
+    (global.get $arg-array)
+    (i32.const 0)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (global.set $result))
+  (func
+    $scm-entry
+    (param i32)
     (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (i32.const 1)
+    (i32.const 3)
     ref.i31
+    (call $gh-to-bool)
     (if
-      (result i32)
+      (then
-      (then (i32.const 777) ref.i31)
+        (global.get $arg-array)
-      (else (i32.const 555) ref.i31)))
+        (global.get 0)
-  (export "main" (func 0)))
+        (i32.const 777)
+        (i32.const 1)
+        i32.shl
+        ref.i31
+        (array.set $arg-array-type)
+        (return_call $halt (i32.const 1)))
+      (else
+        (global.get $arg-array)
+        (global.get 0)
+        (i32.const 555)
+        (i32.const 1)
+        i32.shl
+        ref.i31
+        (array.set $arg-array-type)
+        (return_call $halt (i32.const 1)))))
+  (func
+    (export "main")
+    (call $scm-entry (i32.const 0))
+    (call $gh-write (ref.as_non_null (global.get $result)))))

runtime/default.nix

@@ -9,4 +9,5 @@ rustPlatform.buildRustPackage (finalAttrs: {
     lockFile = ./Cargo.lock;
   };
   doCheck = true;
+  meta.mainProgram = "gyehoek-runtime";
 })

runtime/src/gyehoek.rs

@@ -20,3 +20,12 @@ pub fn write (caller : Caller<'_, u32>, x : Rooted<EqRef>) {
         Scm::Immediate (x) => write_immediate (caller, x)
     }
 }
+
+pub fn truthy_p (caller : Caller<'_, u32>, x : Rooted<EqRef>,) -> u32 {
+    let r = scm::interpret (&caller, x).unwrap ();
+    if let Scm::Immediate (Immediate::Bool (false)) = r {
+        0
+    } else {
+        1
+    }
+}

runtime/src/internal.rs

@@ -40,3 +40,31 @@ pub fn interpret (store : impl AsContext, x : Rooted<EqRef>) -> Option<Scm> {
         todo! ()
     }
 }
+
+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)
+        }
+    }
+}
+
+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

@@ -31,13 +31,19 @@ fn get_config () -> Config {
     cfg
 }
 
+fn link_primitives (linker : &mut Linker<u32>) -> wasmtime::Result<()> {
+    linker.func_wrap ("gyehoek", "write", gyehoek::write)?;
+    linker.func_wrap ("gyehoek", "to-bool", 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);
-    linker.func_wrap ("gyehoek", "write", gyehoek::write)?;
+    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")?;

src/Gyehoek/CPS/Lower.hs

@@ -39,6 +39,7 @@ import Debug.Pretty.Simple
 import Control.Monad.Fix
 import Language.Sexp.Located (Sexp)
 import Data.Functor.Foldable (cata)
+import qualified Gyehoek.Sexp
 
 
 data Env = MkEnv
@@ -132,6 +133,19 @@ lower' g (ExpPrim p rs e) =
   where
     r = head rs
 
+lower' g (ExpIf c t f) = do
+  t' <- lower' g t
+  f' <- lower' g f
+  let c' = lowerVal g c
+  pure [expr|
+    ##{c'}
+    (call $gh-to-bool)
+    (if (then ##{t'})
+        (else ##{f'}))
+  |]
+
+lower' g e = error . show $ e
+
 -- lower' g (ExpIf c t f) = do
 --   t' <- lower' g t
 --   f' <- lower' g f
@@ -241,8 +255,10 @@ lowerBinOp op g x y r e = do
 
 emitRuntime :: GenMod :> es => Eff es ()
 emitRuntime = mfix \runtime -> do
-  Wasm.emit [wat|
+  Wasm.emit [wats|
     (import "gyehoek" "write" (func $gh-write (param (ref eq))))
+    (import "gyehoek" "to-bool" (func $gh-to-bool (param (ref eq))
+                                  (result i32)))
   |]
   -- cont stack
   Wasm.defineType [wat|

src/Gyehoek/Wasm.hs

@@ -31,6 +31,7 @@ module Gyehoek.Wasm
   , emit
   , renderModule
   , wat
+  , wats
   )
   where
 
@@ -69,6 +70,7 @@ import Data.Data (Data)
 import Data.Functor.Foldable (cata)
 import Gyehoek.Sexp (sx)
 import qualified Language.Sexp as SL
+import Data.Foldable (traverse_)
 
 
 newtype Module = MkModule { inner :: Vector Sexp }
@@ -137,12 +139,12 @@ defineType = send . DefineType
 defineGlobal :: GenMod :> es => Sexp -> Eff es Idx
 defineGlobal = send . DefineGlobal
 
-emit :: GenMod :> es => Sexp -> Eff es ()
+emit :: GenMod :> es => List Sexp -> Eff es ()
-emit = send . Emit
+emit = traverse_ (send . Emit)
 
 appendAndIncrement
   :: State GenModState :> es
-  => LensLike' ((,) _) GenModState Natural
+  => LensLike' ((,) Natural) GenModState Natural
   -> Sexp
   -> Eff es Idx
 appendAndIncrement l s =
@@ -197,3 +199,6 @@ expr = Gyehoek.Sexp.makeSxs
 
 wat :: QuasiQuoter
 wat = Gyehoek.Sexp.makeSx [|| id ||]
+
+wats :: QuasiQuoter
+wats = Gyehoek.Sexp.makeSxs [|| id ||]

t.wat

@@ -3,6 +3,10 @@
     "gyehoek"
     "write"
     (func $gh-write (param (ref eq))))
+  (import
+    "gyehoek"
+    "to-bool"
+    (func $gh-to-bool (param (ref eq)) (result i32)))
   (type $heap-object (sub (struct (field $hash (mut i32)))))
   (type $cont-type (func (param i32)))
   (type $cont-stack-type (array (mut (ref null $cont-type))))
@@ -30,61 +34,27 @@
     (param i32)
     (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
     (i32.const 3)
-    (i32.const 1)
-    i32.shl
     ref.i31
-    (i31.get_s (ref.cast (ref i31)))
+    (call $gh-to-bool)
-    (i32.const 1)
+    (if
-    i32.shr_u
+      (then
-    (i32.const 4)
+        (global.get $arg-array)
-    (i32.const 1)
+        (global.get 0)
-    i32.shl
+        (i32.const 777)
-    ref.i31
+        (i32.const 1)
-    (i31.get_s (ref.cast (ref i31)))
+        i32.shl
-    (i32.const 1)
+        ref.i31
-    i32.shr_u
+        (array.set $arg-array-type)
-    i32.mul
+        (return_call $halt (i32.const 1)))
-    (i32.const 1)
+      (else
-    i32.shl
+        (global.get $arg-array)
-    ref.i31
+        (global.get 0)
-    (local.set 1)
+        (i32.const 555)
-    (i32.const 2)
+        (i32.const 1)
-    (i32.const 1)
+        i32.shl
-    i32.shl
+        ref.i31
-    ref.i31
+        (array.set $arg-array-type)
-    (i31.get_s (ref.cast (ref i31)))
+        (return_call $halt (i32.const 1)))))
-    (i32.const 1)
-    i32.shr_u
-    (i32.const 5)
-    (i32.const 1)
-    i32.shl
-    ref.i31
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    i32.mul
-    (i32.const 1)
-    i32.shl
-    ref.i31
-    (local.set 2)
-    (local.get 1)
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    (local.get 2)
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    i32.add
-    (i32.const 1)
-    i32.shl
-    ref.i31
-    (local.set 3)
-    (global.get $arg-array)
-    (global.get 0)
-    (local.get 3)
-    (array.set $arg-array-type)
-    (return_call $halt (i32.const 1)))
   (func
     (export "main")
     (call $scm-entry (i32.const 0))

test/Main.hs

@@ -16,6 +16,7 @@ import System.Environment.Blank (getEnvDefault)
 disabled :: List String
 disabled =
   [ "square"
+  , "lambda"
   ]
 
 main :: IO ()