msyds/gyehoek-hs
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

"fix stuff lol"

Browse Source
This commit is contained in:
Madeleine Sydney Slaga
2026-07-18 01:06:12 -06:00
parent aa5b45ec76
commit 9334373f96
10 changed files with 320 additions and 136 deletions
Download Patch File Download Diff File Expand all files Collapse all files
golden/arith/exec
-3
View File
@@ -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
+76 -32
View File
@@ -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)))
(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)))))
runtime/src/gyehoek.rs
+19 -2
View File
@@ -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<EqRef>) {
match scm::interpret (&caller, x).unwrap () {
Scm::Immediate (x) => write_immediate (caller, x)
}
}
runtime/src/internal.rs
+42
View File
@@ -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
+13 -2
View File
@@ -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
+29 -5
View File
@@ -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
+33 -9
View File
@@ -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
src/Gyehoek/Wasm.hs
+7 -7
View File
@@ -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
t.wat
+90 -68
View File
@@ -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)))))
test/Main.hs
+11 -8
View File
@@ -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