diff --git a/golden/arith/exec b/golden/arith/exec index 0e2d2b5..1c33224 100644 --- a/golden/arith/exec +++ b/golden/arith/exec @@ -1,5 +1,2 @@ ret > ExitSuccess out > 22 -out > -err > warning: using `--invoke` with a function that returns values is experimental and may break in the future -err > diff --git a/golden/arith/out.wat b/golden/arith/out.wat index 1a9f4c6..cc60146 100644 --- a/golden/arith/out.wat +++ b/golden/arith/out.wat @@ -1,47 +1,91 @@ (module - (type $heap-object (sub (struct (field (mut i32))))) + (import + "gyehoek" + "write" + (func $gh-write (param (ref eq)))) + (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 3) - (i32.const 2) + (i32.const 1) i32.shl ref.i31 - (ref.cast (ref i31)) - i31.get_s + (i31.get_s (ref.cast (ref i31))) + (i32.const 1) + i32.shr_u (i32.const 4) - (i32.const 2) + (i32.const 1) i32.shl ref.i31 - (ref.cast (ref i31)) - i31.get_s + (i31.get_s (ref.cast (ref i31))) + (i32.const 1) + i32.shr_u i32.mul - ref.i31 - (local.set 0) - (i32.const 2) - (i32.const 2) + (i32.const 1) i32.shl ref.i31 - (ref.cast (ref i31)) - i31.get_s - (i32.const 5) - (i32.const 2) - i32.shl - ref.i31 - (ref.cast (ref i31)) - i31.get_s - i32.mul - ref.i31 (local.set 1) - (local.get 0) - (ref.cast (ref i31)) - i31.get_s - (local.get 1) - (ref.cast (ref i31)) - i31.get_s - i32.add + (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 2)) - (export "main" (func 0))) \ No newline at end of file + (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)) + (call $gh-write (ref.as_non_null (global.get $result))))) \ No newline at end of file diff --git a/runtime/src/gyehoek.rs b/runtime/src/gyehoek.rs index 52f4e5f..619c141 100644 --- a/runtime/src/gyehoek.rs +++ b/runtime/src/gyehoek.rs @@ -1,5 +1,22 @@ use wasmtime::*; +use crate::internal as scm; +use crate::internal::{Scm,Immediate}; -pub fn say_hi (_caller : Caller<'_, u32>) { - println! ("hiiii~") +// pub fn small_fixnum_p (_) + +// pub fn immediate_p (caller : Caller<'_, u32>, x : EqRef) -> EqRef { +// x.is_i31 () +// } + +fn write_immediate (_caller : Caller<'_, u32>, imm : Immediate) { + match imm { + Immediate::SmallFixnum (n) => print! ("{}", n), + Immediate::Bool (b) => print! ("{}", if b { "#t" } else { "#f" }), + } +} + +pub fn write (caller : Caller<'_, u32>, x : Rooted) { + match scm::interpret (&caller, x).unwrap () { + Scm::Immediate (x) => write_immediate (caller, x) + } } diff --git a/runtime/src/internal.rs b/runtime/src/internal.rs new file mode 100644 index 0000000..7d46c88 --- /dev/null +++ b/runtime/src/internal.rs @@ -0,0 +1,42 @@ +use wasmtime::*; + +pub fn immediate_p (store : impl AsContext, x : Rooted) -> bool { + x.is_i31 (store).unwrap () +} + +pub enum Immediate { + SmallFixnum (i32), + Bool (bool), +} + +pub enum Scm { + Immediate (Immediate), +} + +#[allow(nonstandard_style)] +pub type scm_bits = u32; + +#[allow(nonstandard_style)] +pub const scm_false : scm_bits = 0b01; +#[allow(nonstandard_style)] +pub const scm_true : scm_bits = 0b11; + +pub fn interpret_immediate (x : scm_bits) -> Option { + if x & 1 == 0 { + Some (Immediate::SmallFixnum ((x >> 1).try_into ().unwrap ())) + } else if x == scm_true { + Some (Immediate::Bool (true)) + } else if x == scm_false { + Some (Immediate::Bool (false)) + } else { + None + } +} + +pub fn interpret (store : impl AsContext, x : Rooted) -> Option { + if let Some (imm) = x.as_i31 (store).unwrap () { + Some (Scm::Immediate (interpret_immediate (imm.get_u32 ())?)) + } else { + todo! () + } +} diff --git a/runtime/src/main.rs b/runtime/src/main.rs index 23d4a41..c9ed50f 100644 --- a/runtime/src/main.rs +++ b/runtime/src/main.rs @@ -1,4 +1,5 @@ mod gyehoek; +mod internal; use std::io; use std::io::Read; @@ -21,12 +22,22 @@ fn read (mut rdr : R) -> io::Result> { Ok (buf) } +fn get_config () -> Config { + let mut cfg = Config::new (); + cfg.wasm_reference_types (true); + cfg.wasm_function_references (true); + cfg.wasm_tail_call (true); + cfg.wasm_gc (true); + cfg +} + pub fn main () -> wasmtime::Result<()> { let args = Args::parse (); - let engine = Engine::default (); + 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", "say-hi", gyehoek::say_hi)?; + linker.func_wrap ("gyehoek", "write", gyehoek::write)?; 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 c9d5181..5230f26 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/src/Gyehoek/CPS/Lower.hs @@ -121,7 +121,7 @@ lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr lower' g (Halt [v]) = pure [expr| ##{arg} - (return_call $halt) + (return_call $halt (i32.const 1)) |] where arg = pushArg 0 (lowerVal g v) @@ -183,6 +183,7 @@ lowerBinOp :: (GenMod :> es) => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr lowerBinOp op g x y r e = do + let op' = SL.Symbol op let g' = g & #vars <>~ [r] let n = succ $ length (g ^. #vars) let x' = lowerVal g x @@ -191,9 +192,15 @@ lowerBinOp op g x y r e = do pure [expr| ##{x'} (i31.get_s (ref.cast (ref i31))) + (i32.const 1) + i32.shr_u ##{y'} (i31.get_s (ref.cast (ref i31))) - (local.set #{n} (ref.i31 #{op})) + (i32.const 1) + i32.shr_u + #{op'} + ##{makeSmallFixnum} + (local.set #{n}) ##{e'} |] @@ -234,6 +241,9 @@ lowerBinOp op g x y r e = do emitRuntime :: GenMod :> es => Eff es () emitRuntime = mfix \runtime -> do + Wasm.emit [wat| + (import "gyehoek" "write" (func $gh-write (param (ref eq)))) + |] -- cont stack Wasm.defineType [wat| (type $heap-object (sub (struct (field $hash (mut i32))))) @@ -257,7 +267,7 @@ emitRuntime = mfix \runtime -> do |] Wasm.defineGlobal [wat| (global $arg-array (ref $arg-array-type) - (array.new_default $arg-array-type) (i32.const 32)) + (array.new_default $arg-array-type (i32.const 32))) |] -- other things 😼 Wasm.defineGlobal [wat| @@ -284,9 +294,9 @@ lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do ##{e'}) |] Wasm.defineFunction [wat| - (func (export "main") (result (ref eq)) + (func (export "main") (call $scm-entry (i32.const 0)) - (ref.as_non_null (global.get $result))) + (call $gh-write (ref.as_non_null (global.get $result)))) |] lowerProgram :: Program -> Eff es Text @@ -325,3 +335,17 @@ antiquote_splicing_example = (func $blah (param i32 i64 f64)) |] in (metavars, e1, e2, e1 == e2) + +antiquote_both_example = + let + m1 = 123 :: Int + ms = [expr|i32 i64|] + + e1 = [expr| + a (b #{m1} c) d ##{ms} e + |] + + e2 = [expr| + a (b 123 c) d i32 i64 e + |] + in (e1,e2,e1==e2) diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index 699f319..a458aeb 100644 --- a/src/Gyehoek/Sexp.hs +++ b/src/Gyehoek/Sexp.hs @@ -56,7 +56,7 @@ import Data.List (List, groupBy) import Data.Text.Encoding import Data.Either (either) import GHC.Generics (Generic) -import Control.Lens +import Control.Lens hiding (para) import Data.Generics.Labels import System.Process import GHC.IO.Unsafe (unsafePerformIO) @@ -71,9 +71,9 @@ import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE import qualified Data.Text as T import qualified Control.Category import Data.Data (Data (..), Typeable, cast) -import Language.Haskell.TH.Syntax (lift, Lift) +import Language.Haskell.TH.Syntax (lift, Lift, liftData) import GHC.IsList (fromList) -import Data.Functor.Foldable (cata) +import Data.Functor.Foldable (cata, para, embed) import Data.Functor.Classes (Show1(..)) import Data.Vector (Vector) import Numeric.Natural (Natural) @@ -81,6 +81,7 @@ import Data.Maybe (fromMaybe) import Control.Applicative (Alternative((<|>))) import Debug.Pretty.Simple import qualified Data.Vector as V +import qualified Data.Vector.Strict sexp :: SexpIso a => Iso' a Text @@ -295,10 +296,12 @@ instance SexpIso Natural where | otherwise = Right $ fromIntegral n g n = fromIntegral n - class SpliceSexp a where spliceSexp :: a -> List Sexp +instance SexpIso a => SpliceSexp (Data.Vector.Strict.Vector a) where + spliceSexp = toSexps + instance SexpIso a => SpliceSexp (Vector a) where spliceSexp = toSexps @@ -329,6 +332,30 @@ unquoteSplicing xs & listE unquoteSplicing _ = Nothing +unquoteSplicingRecursive :: List Sexp.Sexp -> ExpQ +unquoteSplicingRecursive xs = [| mconcat $(spans) |] + where + spans = xs + & groupBy \cases + (UnquoteSplicing _) _ -> False + _ (UnquoteSplicing _) -> False + _ _ -> True + & fmap \case + -- [e@(Unquote _)] -> + -- case unquote e of + -- Just x -> [| [$(x)] |] + -- Nothing -> error "unreachable" + [UnquoteSplicing x] -> + [| spliceSexp $(varE (mkName (T.unpack x))) |] + es -> listE $ unquoteRecursive <$> es + & listE + +unquoteRecursive :: Sexp.Sexp -> ExpQ +unquoteRecursive = \case + Unquote x -> [| stripLocation (toSexp $(varE (mkName (T.unpack x)))) |] + SL.ParenList xs -> [|SL.ParenList $(unquoteSplicingRecursive xs)|] + e -> liftData e + unquote :: Sexp.Sexp -> Maybe ExpQ unquote (Unquote x) = Just [| stripLocation . toSexp $ $(varE (mkName (T.unpack x))) |] @@ -340,13 +367,10 @@ _ParenList = prism' SL.ParenList \case _ -> Nothing metaSexps :: List Sexp.Sexp -> Maybe ExpQ -metaSexps = unquoteSplicing - -metaSexpsV :: Vector Sexp.Sexp -> Maybe ExpQ -metaSexpsV = unquoteSplicing . V.toList +metaSexps = Just . unquoteSplicingRecursive metaSexp :: Sexp.Sexp -> Maybe ExpQ -metaSexp x = unquote x +metaSexp = Just . unquoteRecursive -- 뻘짓뻘짓뻘짓뻘짓뻘짓 class Lift1 f where diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index b2bb0f3..3f05162 100644 --- a/src/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -28,7 +28,7 @@ module Gyehoek.Wasm , defineFunction , defineType , defineGlobal - , declare + , emit , renderModule , wat ) @@ -49,9 +49,9 @@ import Effectful.Dispatch.Dynamic import Effectful.State.Dynamic import Control.Lens import Data.Generics.Labels -import Data.Vector (Vector) +import Data.Vector.Strict (Vector) import Data.String.Interpolate -import qualified Data.Vector as V +import qualified Data.Vector.Strict as V import qualified Data.Text as T import Effectful.Writer.Dynamic import Control.Applicative (Alternative((<|>))) @@ -124,7 +124,7 @@ data GenMod :: Effect where DefineFunction :: Sexp -> GenMod m Idx DefineType :: Sexp -> GenMod m Idx DefineGlobal :: Sexp -> GenMod m Idx - Declare :: Sexp -> GenMod m () + Emit :: Sexp -> GenMod m () type instance DispatchOf GenMod = Dynamic @@ -137,8 +137,8 @@ defineType = send . DefineType defineGlobal :: GenMod :> es => Sexp -> Eff es Idx defineGlobal = send . DefineGlobal -declare :: GenMod :> es => Sexp -> Eff es () -declare = send . Declare +emit :: GenMod :> es => Sexp -> Eff es () +emit = send . Emit appendAndIncrement :: State GenModState :> es @@ -158,7 +158,7 @@ runGenMod = _ (DefineFunction s) -> appendAndIncrement #funcs s _ (DefineType s) -> appendAndIncrement #types s _ (DefineGlobal s) -> appendAndIncrement #globals s - _ (Declare s) -> #mod . #inner <>= V.singleton s + _ (Emit s) -> #mod . #inner <>= V.singleton s execGenMod :: Eff (GenMod : es) a -> Eff es Module execGenMod = fmap snd . runGenMod diff --git a/t.wat b/t.wat index 733234c..939cfcd 100644 --- a/t.wat +++ b/t.wat @@ -1,69 +1,91 @@ (module - (type $heap-object (sub (struct (field (mut i32))))) - (type $open-procedure (func (param i32))) - (type $closure (sub $heap-object - (struct (field (mut i32)) - (field (ref $open-procedure))))) - (type $cont-stack-type (array (mut (ref null $open-procedure)))) - (type $arg-array-type (array (mut (ref null eq)))) - (global $cont-stack-top (mut i32) (i32.const 0)) - (global $cont-stack (ref $cont-stack-type) - (i32.const 128) - (array.new_default $cont-stack-type)) - (global $arg-array (ref $arg-array-type) - (i32.const 32) - (array.new_default $arg-array-type)) - (global (mut (ref null eq)) (ref.null eq)) - (elem declare funcref (ref.func 1)) - (func - (param i32) - (result) - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (global.get 2) - (i32.const 0) - (array.get 3) - ref.as_non_null - (global.set 3)) - (func - (param i32) - (result) - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (global.get 2) - (i32.const 0) - (array.get 3) - ref.as_non_null - (local.set 1) - (global.get 2) - (i32.const 0) - (local.get 1) - (array.set 3) - (i32.const 1) - (global.get 1) - (global.get 0) - (array.get 2) - ref.as_non_null - (global.get 0) - (i32.const 1) - i32.sub - (global.set 0) - (return_call_ref 1)) - (func - (param i32) - (result) - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (ref.func 1) - (local.set 1) - (global.get 2) - (i32.const 0) - (local.get 1) - (array.set 3) - (return_call 1)) - (func - (param) - (result (ref eq)) - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (i32.const 0) - (call 1) - (global.get 3) - ref.as_non_null) - (export "main" (func 3))) + (import + "gyehoek" + "write" + (func $gh-write (param (ref eq)))) + (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 + $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 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))) + (func + (export "main") + (call $scm-entry (i32.const 0)) + (call $gh-write (ref.as_non_null (global.get $result))))) diff --git a/test/Main.hs b/test/Main.hs index 102e17e..d514954 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -10,6 +10,7 @@ import Data.List (List) import Data.Functor ((<&>)) import System.Directory import Data.Function +import System.Environment.Blank (getEnvDefault) disabled :: List String @@ -26,8 +27,8 @@ goldenTests = do let tests = all_cases & filter (`notElem` disabled) & fmap ("golden") - pure $ testGroup "golden" - [ watTests tests + testGroup "golden" <$> sequenceA + [ pure $ watTests tests , executionTests tests ] @@ -43,15 +44,17 @@ watTests files = (Driver.lower_e2e source) id -executionTests :: List FilePath -> TestTree -executionTests files = - testGroup "execution" $ files <&> \test -> +executionTests :: List FilePath -> IO TestTree +executionTests files = do + cmd <- getEnvDefault "GYEHOEK_RUNTIME" + "runtime/target/debug/gyehoek-runtime" + pure $ testGroup "execution" $ files <&> \test -> let wat = test "out.wat" testname = takeFileName test resultfile = test "exec" in goldenVsProg testname resultfile - "wasmtime" - ["--invoke", "main", wat] - "" + cmd + [wat] + "" -- stdin