"fix stuff lol"

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 >

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)
+    $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 3)
-    (i32.const 2)
+    (i32.const 1)
     i32.shl
     ref.i31
-    (ref.cast (ref i31))
+    (i31.get_s (ref.cast (ref i31)))
-    i31.get_s
+    (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 (ref.cast (ref i31)))
-    i31.get_s
+    (i32.const 1)
+    i32.shr_u
     i32.mul
-    ref.i31
+    (i32.const 1)
-    (local.set 0)
-    (i32.const 2)
-    (i32.const 2)
     i32.shl
     ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
-    (i32.const 5)
-    (i32.const 2)
-    i32.shl
-    ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
-    i32.mul
-    ref.i31
     (local.set 1)
-    (local.get 0)
+    (i32.const 2)
-    (ref.cast (ref i31))
+    (i32.const 1)
-    i31.get_s
+    i32.shl
-    (local.get 1)
+    ref.i31
-    (ref.cast (ref i31))
+    (i31.get_s (ref.cast (ref i31)))
-    i31.get_s
+    (i32.const 1)
-    i32.add
+    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))
+    (local.get 1)
-  (export "main" (func 0)))
+    (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)))))

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>) {
+// pub fn small_fixnum_p (_)
-    println! ("hiiii~")
+
+// pub fn immediate_p (caller : Caller<'_, u32>, x : EqRef) -> EqRef {
+//     x.is_i31 ()
+// }
+
+fn write_immediate (_caller : Caller<'_, u32>, imm : Immediate) {
+    match imm {
+        Immediate::SmallFixnum (n) => print! ("{}", n),
+        Immediate::Bool (b) => print! ("{}", if b { "#t" } else { "#f" }),
+    }
+}
+
+pub fn write (caller : Caller<'_, u32>, x : Rooted<EqRef>) {
+    match scm::interpret (&caller, x).unwrap () {
+        Scm::Immediate (x) => write_immediate (caller, x)
+    }
 }

runtime/src/internal.rs

@@ -0,0 +1,42 @@
+use wasmtime::*;
+
+pub fn immediate_p (store : impl AsContext, x : Rooted<EqRef>) -> bool {
+    x.is_i31 (store).unwrap ()
+}
+
+pub enum Immediate {
+    SmallFixnum (i32),
+    Bool (bool),
+}
+
+pub enum 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<Immediate> {
+    if x & 1 == 0 {
+        Some (Immediate::SmallFixnum ((x >> 1).try_into ().unwrap ()))
+    } else if x == scm_true {
+        Some (Immediate::Bool (true))
+    } else if x == scm_false {
+        Some (Immediate::Bool (false))
+    } else {
+        None
+    }
+}
+
+pub fn interpret (store : impl AsContext, x : Rooted<EqRef>) -> Option<Scm> {
+    if let Some (imm) = x.as_i31 (store).unwrap () {
+        Some (Scm::Immediate (interpret_immediate (imm.get_u32 ())?))
+    } else {
+        todo! ()
+    }
+}

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<R : Read> (mut rdr : R) -> io::Result<Vec<u8>> {
     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<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

@@ -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)

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
+metaSexps = Just . unquoteSplicingRecursive
-
-metaSexpsV :: Vector Sexp.Sexp -> Maybe ExpQ
-metaSexpsV = unquoteSplicing . V.toList
 
 metaSexp :: Sexp.Sexp -> Maybe ExpQ
-metaSexp x = unquote x
+metaSexp = Just . unquoteRecursive
 
 -- 뻘짓뻘짓뻘짓뻘짓뻘짓
 class Lift1 f where

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 ()
+emit :: GenMod :> es => Sexp -> Eff es ()
-declare = send . Declare
+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

t.wat

@@ -1,69 +1,91 @@
 (module
- (type $heap-object (sub (struct (field (mut i32)))))
+  (import
- (type $open-procedure (func (param i32)))
+    "gyehoek"
- (type $closure (sub $heap-object
+    "write"
-                     (struct (field (mut i32))
+    (func $gh-write (param (ref eq))))
-                             (field (ref $open-procedure)))))
+  (type $heap-object (sub (struct (field $hash (mut i32)))))
- (type $cont-stack-type (array (mut (ref null $open-procedure))))
+  (type $cont-type (func (param i32)))
- (type $arg-array-type (array (mut (ref null eq))))
+  (type $cont-stack-type (array (mut (ref null $cont-type))))
- (global $cont-stack-top (mut i32) (i32.const 0))
+  (global $cont-stack-top (mut i32) (i32.const 0))
- (global $cont-stack (ref $cont-stack-type)
+  (global
-         (i32.const 128)
+    $cont-stack
-         (array.new_default $cont-stack-type))
+    (ref $cont-stack-type)
- (global $arg-array (ref $arg-array-type)
+    (array.new_default $cont-stack-type (i32.const 128)))
-         (i32.const 32)
+  (type $arg-array-type (array (mut (ref null eq))))
-         (array.new_default $arg-array-type))
+  (global
- (global (mut (ref null eq)) (ref.null eq))
+    $arg-array
- (elem declare funcref (ref.func 1))
+    (ref $arg-array-type)
- (func
+    (array.new_default $arg-array-type (i32.const 32)))
-  (param i32)
+  (global $result (mut (ref null eq)) (ref.null eq))
-  (result)
+  (func
-  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    $halt
-  (global.get 2)
+    (param i32)
-  (i32.const 0)
+    (global.get $arg-array)
-  (array.get 3)
+    (i32.const 0)
-  ref.as_non_null
+    (array.get $arg-array-type)
-  (global.set 3))
+    ref.as_non_null
- (func
+    (global.set $result))
-  (param i32)
+  (func
-  (result)
+    $scm-entry
-  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (param i32)
-  (global.get 2)
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-  (i32.const 0)
+    (i32.const 3)
-  (array.get 3)
+    (i32.const 1)
-  ref.as_non_null
+    i32.shl
-  (local.set 1)
+    ref.i31
-  (global.get 2)
+    (i31.get_s (ref.cast (ref i31)))
-  (i32.const 0)
+    (i32.const 1)
-  (local.get 1)
+    i32.shr_u
-  (array.set 3)
+    (i32.const 4)
-  (i32.const 1)
+    (i32.const 1)
-  (global.get 1)
+    i32.shl
-  (global.get 0)
+    ref.i31
-  (array.get 2)
+    (i31.get_s (ref.cast (ref i31)))
-  ref.as_non_null
+    (i32.const 1)
-  (global.get 0)
+    i32.shr_u
-  (i32.const 1)
+    i32.mul
-  i32.sub
+    (i32.const 1)
-  (global.set 0)
+    i32.shl
-  (return_call_ref 1))
+    ref.i31
- (func
+    (local.set 1)
-  (param i32)
+    (i32.const 2)
-  (result)
+    (i32.const 1)
-  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    i32.shl
-  (ref.func 1)
+    ref.i31
-  (local.set 1)
+    (i31.get_s (ref.cast (ref i31)))
-  (global.get 2)
+    (i32.const 1)
-  (i32.const 0)
+    i32.shr_u
-  (local.get 1)
+    (i32.const 5)
-  (array.set 3)
+    (i32.const 1)
-  (return_call 1))
+    i32.shl
- (func
+    ref.i31
-  (param)
+    (i31.get_s (ref.cast (ref i31)))
-  (result (ref eq))
+    (i32.const 1)
-  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    i32.shr_u
-  (i32.const 0)
+    i32.mul
-  (call 1)
+    (i32.const 1)
-  (global.get 3)
+    i32.shl
-  ref.as_non_null)
+    ref.i31
- (export "main" (func 3)))
+    (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)))))

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"
+  testGroup "golden" <$> sequenceA
-    [ watTests tests
+    [ pure $ watTests tests
     , executionTests tests
     ]
 
@@ -43,15 +44,17 @@ watTests files =
       (Driver.lower_e2e source)
       id
 
-executionTests :: List FilePath -> TestTree
+executionTests :: List FilePath -> IO TestTree
-executionTests files =
+executionTests files = do
-  testGroup "execution" $ files <&> \test ->
+  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"
+       cmd
-       ["--invoke", "main", wat]
+       [wat]
-       ""
+       "" -- stdin