diff --git a/flake.nix b/flake.nix index 038dad4..c8cb77c 100644 --- a/flake.nix +++ b/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 + pkgs.git # tasty uses git diff ]; in '' - # Wasmtime requires a cache in $HOME. This is less - # painful than reconfiguring the cache location. - export HOME=$(mktemp -d) + export GYEHOEK_RUNTIME=${lib.getExe final.gyehoek-runtime} export PATH=${lib.makeBinPath bin}:$PATH ''; })]; @@ -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 diff --git a/golden/arith/out.wat b/golden/arith/out.wat index cc60146..5c5a59c 100644 --- a/golden/arith/out.wat +++ b/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)))) diff --git a/golden/if-false/exec b/golden/if-false/exec index 1b2edc3..7ad99a5 100644 --- a/golden/if-false/exec +++ b/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 > diff --git a/golden/if-false/out.wat b/golden/if-false/out.wat index 88f2ff4..3db0974 100644 --- a/golden/if-false/out.wat +++ b/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) - (result (ref eq)) - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + $halt + (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) ref.i31 + (call $gh-to-bool) (if - (result i32) - (then (i32.const 777) ref.i31) - (else (i32.const 555) ref.i31))) - (export "main" (func 0))) \ No newline at end of file + (then + (global.get $arg-array) + (global.get 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))))) \ No newline at end of file diff --git a/golden/if-true/exec b/golden/if-true/exec index d8d9f0f..974f55a 100644 --- a/golden/if-true/exec +++ b/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 > diff --git a/golden/if-true/out.wat b/golden/if-true/out.wat index 8189412..edcc9e0 100644 --- a/golden/if-true/out.wat +++ b/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) - (result (ref eq)) + $halt + (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 (i32.const 777) ref.i31) - (else (i32.const 555) ref.i31))) - (export "main" (func 0))) \ No newline at end of file + (then + (global.get $arg-array) + (global.get 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))))) \ No newline at end of file diff --git a/runtime/default.nix b/runtime/default.nix index 6423ac3..af1fde4 100644 --- a/runtime/default.nix +++ b/runtime/default.nix @@ -9,4 +9,5 @@ rustPlatform.buildRustPackage (finalAttrs: { lockFile = ./Cargo.lock; }; doCheck = true; + meta.mainProgram = "gyehoek-runtime"; }) diff --git a/runtime/src/gyehoek.rs b/runtime/src/gyehoek.rs index 619c141..8f4cb8e 100644 --- a/runtime/src/gyehoek.rs +++ b/runtime/src/gyehoek.rs @@ -20,3 +20,12 @@ pub fn write (caller : Caller<'_, u32>, x : Rooted) { Scm::Immediate (x) => write_immediate (caller, x) } } + +pub fn truthy_p (caller : Caller<'_, u32>, x : Rooted,) -> u32 { + let r = scm::interpret (&caller, x).unwrap (); + if let Scm::Immediate (Immediate::Bool (false)) = r { + 0 + } else { + 1 + } +} diff --git a/runtime/src/internal.rs b/runtime/src/internal.rs index 7d46c88..abc6133 100644 --- a/runtime/src/internal.rs +++ b/runtime/src/internal.rs @@ -40,3 +40,31 @@ pub fn interpret (store : impl AsContext, x : Rooted) -> Option { 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 { + 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 { + let x = if b { scm_true } else { scm_false }; + let i31 = I31::new_u32 (x).unwrap (); + EqRef::from_i31 (store, i31) +} diff --git a/runtime/src/main.rs b/runtime/src/main.rs index c9ed50f..e4ebeaa 100644 --- a/runtime/src/main.rs +++ b/runtime/src/main.rs @@ -31,13 +31,19 @@ fn get_config () -> Config { cfg } +fn link_primitives (linker : &mut Linker) -> 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 = Store::new (&engine, 4); let instance = linker.instantiate (&mut store, &module)?; let main = instance.get_typed_func::<(),()> (&mut store, "main")?; diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 5230f26..7eb5e0b 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/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| diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index 3f05162..118aa02 100644 --- a/src/Gyehoek/Wasm.hs +++ b/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 = send . Emit +emit :: GenMod :> es => List Sexp -> Eff es () +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 ||] diff --git a/t.wat b/t.wat index 939cfcd..972cff1 100644 --- a/t.wat +++ b/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))) - (i32.const 1) - i32.shr_u - (i32.const 4) - (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 1) - (i32.const 2) - (i32.const 1) - i32.shl - ref.i31 - (i31.get_s (ref.cast (ref i31))) - (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))) + (call $gh-to-bool) + (if + (then + (global.get $arg-array) + (global.get 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)) diff --git a/test/Main.hs b/test/Main.hs index d514954..9ead0b1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -16,6 +16,7 @@ import System.Environment.Blank (getEnvDefault) disabled :: List String disabled = [ "square" + , "lambda" ] main :: IO ()