@@ -5,11 +5,18 @@
|
||||
(func $gh-write (param (ref eq))))
|
||||
(import
|
||||
"gyehoek"
|
||||
"to-bool"
|
||||
(func $gh-to-bool (param (ref eq)) (result i32)))
|
||||
"truthy?"
|
||||
(func $gh-truthy? (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))))
|
||||
(type
|
||||
$closure
|
||||
(sub
|
||||
$heap-object
|
||||
(struct
|
||||
(field $hash (mut i32))
|
||||
(field $code (ref $cont-type)))))
|
||||
(global $cont-stack-top (mut i32) (i32.const 0))
|
||||
(global
|
||||
$cont-stack
|
||||
|
||||
+10
-3
@@ -5,11 +5,18 @@
|
||||
(func $gh-write (param (ref eq))))
|
||||
(import
|
||||
"gyehoek"
|
||||
"to-bool"
|
||||
(func $gh-to-bool (param (ref eq)) (result i32)))
|
||||
"truthy?"
|
||||
(func $gh-truthy? (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))))
|
||||
(type
|
||||
$closure
|
||||
(sub
|
||||
$heap-object
|
||||
(struct
|
||||
(field $hash (mut i32))
|
||||
(field $code (ref $cont-type)))))
|
||||
(global $cont-stack-top (mut i32) (i32.const 0))
|
||||
(global
|
||||
$cont-stack
|
||||
@@ -35,7 +42,7 @@
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 1)
|
||||
ref.i31
|
||||
(call $gh-to-bool)
|
||||
(call $gh-truthy?)
|
||||
(if
|
||||
(then
|
||||
(global.get $arg-array)
|
||||
|
||||
@@ -0,0 +1,2 @@
|
||||
ret > ExitSuccess
|
||||
out > 777
|
||||
@@ -0,0 +1,70 @@
|
||||
(module
|
||||
(import
|
||||
"gyehoek"
|
||||
"write"
|
||||
(func $gh-write (param (ref eq))))
|
||||
(import
|
||||
"gyehoek"
|
||||
"truthy?"
|
||||
(func $gh-truthy? (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))))
|
||||
(type
|
||||
$closure
|
||||
(sub
|
||||
$heap-object
|
||||
(struct
|
||||
(field $hash (mut i32))
|
||||
(field $code (ref $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 123)
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(call $gh-truthy?)
|
||||
(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))
|
||||
(call $gh-write (ref.as_non_null (global.get $result)))))
|
||||
@@ -0,0 +1 @@
|
||||
(if 123 777 555)
|
||||
+10
-3
@@ -5,11 +5,18 @@
|
||||
(func $gh-write (param (ref eq))))
|
||||
(import
|
||||
"gyehoek"
|
||||
"to-bool"
|
||||
(func $gh-to-bool (param (ref eq)) (result i32)))
|
||||
"truthy?"
|
||||
(func $gh-truthy? (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))))
|
||||
(type
|
||||
$closure
|
||||
(sub
|
||||
$heap-object
|
||||
(struct
|
||||
(field $hash (mut i32))
|
||||
(field $code (ref $cont-type)))))
|
||||
(global $cont-stack-top (mut i32) (i32.const 0))
|
||||
(global
|
||||
$cont-stack
|
||||
@@ -35,7 +42,7 @@
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 3)
|
||||
ref.i31
|
||||
(call $gh-to-bool)
|
||||
(call $gh-truthy?)
|
||||
(if
|
||||
(then
|
||||
(global.get $arg-array)
|
||||
|
||||
@@ -0,0 +1,2 @@
|
||||
ret > ExitSuccess
|
||||
out > #<procedure>
|
||||
@@ -0,0 +1,78 @@
|
||||
(module
|
||||
(import
|
||||
"gyehoek"
|
||||
"write"
|
||||
(func $gh-write (param (ref eq))))
|
||||
(import
|
||||
"gyehoek"
|
||||
"truthy?"
|
||||
(func $gh-truthy? (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))))
|
||||
(type
|
||||
$closure
|
||||
(sub
|
||||
$heap-object
|
||||
(struct
|
||||
(field $hash (mut i32))
|
||||
(field $code (ref $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
|
||||
(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
|
||||
(local.set 1)
|
||||
(global.get $arg-array)
|
||||
(global.get 0)
|
||||
(local.get 1)
|
||||
(array.set $arg-array-type)
|
||||
(i32.const 1)
|
||||
(global.get $cont-stack)
|
||||
(global.get $cont-stack-top)
|
||||
(array.get $cont-stack-type)
|
||||
ref.as_non_null
|
||||
(global.get $cont-stack-top)
|
||||
(i32.const 1)
|
||||
i32.sub
|
||||
(global.set $cont-stack-top)
|
||||
(return_call_ref $cont-type))
|
||||
(elem declare funcref (ref.func 3))
|
||||
(func
|
||||
$scm-entry
|
||||
(param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 0)
|
||||
(ref.func 3)
|
||||
(struct.new $closure)
|
||||
(local.set 1)
|
||||
(global.get $arg-array)
|
||||
(global.get 0)
|
||||
(local.get 1)
|
||||
(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)))))
|
||||
Generated
+79
-9
@@ -11,6 +11,17 @@ dependencies = [
|
||||
"gimli",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "ahash"
|
||||
version = "0.7.8"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "891477e0c6a8957309ee5c45a6368af3ae14bb510732d2684ffa19af310920f9"
|
||||
dependencies = [
|
||||
"getrandom 0.2.17",
|
||||
"once_cell",
|
||||
"version_check",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "allocator-api2"
|
||||
version = "0.2.21"
|
||||
@@ -87,7 +98,7 @@ checksum = "9035ad2d096bed7955a320ee7e2230574d28fd3c3a0f186cbea1ff3c7eed5dbb"
|
||||
dependencies = [
|
||||
"proc-macro2",
|
||||
"quote",
|
||||
"syn",
|
||||
"syn 2.0.119",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
@@ -169,7 +180,7 @@ dependencies = [
|
||||
"heck",
|
||||
"proc-macro2",
|
||||
"quote",
|
||||
"syn",
|
||||
"syn 2.0.119",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
@@ -657,9 +668,19 @@ version = "0.1.0"
|
||||
dependencies = [
|
||||
"clap",
|
||||
"clio",
|
||||
"memoize",
|
||||
"wasmtime",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "hashbrown"
|
||||
version = "0.12.3"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "8a9ee70c43aaf417c914396645a0fa852624801b24ebb7ae78fe8272889ac888"
|
||||
dependencies = [
|
||||
"ahash",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "hashbrown"
|
||||
version = "0.16.1"
|
||||
@@ -780,6 +801,12 @@ dependencies = [
|
||||
"wasm-bindgen",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "lazy_static"
|
||||
version = "1.5.0"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "bbd2bcb4c963f2ddae06a2efc7e9f3591312473c50c6685e1f298068316e66fe"
|
||||
|
||||
[[package]]
|
||||
name = "leb128fmt"
|
||||
version = "0.1.0"
|
||||
@@ -819,6 +846,15 @@ version = "0.4.33"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "0ceec5bc11778974d1bcb055b18002eba7f4b3518b6a0081b3af5f21666da9ad"
|
||||
|
||||
[[package]]
|
||||
name = "lru"
|
||||
version = "0.7.8"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "e999beba7b6e8345721bd280141ed958096a2e4abdf74f67ff4ce49b4b54e47a"
|
||||
dependencies = [
|
||||
"hashbrown 0.12.3",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "mach2"
|
||||
version = "0.6.0"
|
||||
@@ -840,6 +876,29 @@ dependencies = [
|
||||
"rustix",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "memoize"
|
||||
version = "0.6.0"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "71e73b7be6eeec913659aed78e8c72208f5e9c6a5fb7e0831a491946fd234104"
|
||||
dependencies = [
|
||||
"lazy_static",
|
||||
"lru",
|
||||
"memoize-inner",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "memoize-inner"
|
||||
version = "0.5.1"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "6dd8f89255d8ff313afabed9a3c83ef0993cc056679dfd001f5111a026f876f7"
|
||||
dependencies = [
|
||||
"lazy_static",
|
||||
"proc-macro2",
|
||||
"quote",
|
||||
"syn 1.0.109",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "object"
|
||||
version = "0.39.1"
|
||||
@@ -927,7 +986,7 @@ checksum = "5a7ac85c0bb3fb351f10d531230aaa5e366b46d7c4e5328e5f02801d6dac1165"
|
||||
dependencies = [
|
||||
"proc-macro2",
|
||||
"quote",
|
||||
"syn",
|
||||
"syn 2.0.119",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
@@ -1068,7 +1127,7 @@ checksum = "d540f220d3187173da220f885ab66608367b6574e925011a9353e4badda91d79"
|
||||
dependencies = [
|
||||
"proc-macro2",
|
||||
"quote",
|
||||
"syn",
|
||||
"syn 2.0.119",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
@@ -1137,6 +1196,17 @@ version = "0.11.1"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "7da8b5736845d9f2fcb837ea5d9e2628564b3b043a70948a3f0b778838c5fb4f"
|
||||
|
||||
[[package]]
|
||||
name = "syn"
|
||||
version = "1.0.109"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "72b64191b275b66ffe2469e8af2c1cfe3bafa67b529ead792a6d0160888b4237"
|
||||
dependencies = [
|
||||
"proc-macro2",
|
||||
"quote",
|
||||
"unicode-ident",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "syn"
|
||||
version = "2.0.119"
|
||||
@@ -1202,7 +1272,7 @@ checksum = "4fee6c4efc90059e10f81e6d42c60a18f76588c3d74cb83a0b242a2b6c7504c1"
|
||||
dependencies = [
|
||||
"proc-macro2",
|
||||
"quote",
|
||||
"syn",
|
||||
"syn 2.0.119",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
@@ -1213,7 +1283,7 @@ checksum = "ebc4ee7f67670e9b64d05fa4253e753e016c6c95ff35b89b7941d6b856dec1d5"
|
||||
dependencies = [
|
||||
"proc-macro2",
|
||||
"quote",
|
||||
"syn",
|
||||
"syn 2.0.119",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
@@ -1349,7 +1419,7 @@ dependencies = [
|
||||
"bumpalo",
|
||||
"proc-macro2",
|
||||
"quote",
|
||||
"syn",
|
||||
"syn 2.0.119",
|
||||
"wasm-bindgen-shared",
|
||||
]
|
||||
|
||||
@@ -1547,7 +1617,7 @@ dependencies = [
|
||||
"anyhow",
|
||||
"proc-macro2",
|
||||
"quote",
|
||||
"syn",
|
||||
"syn 2.0.119",
|
||||
"wasmtime-internal-component-util",
|
||||
"wasmtime-internal-wit-bindgen",
|
||||
"wit-parser",
|
||||
@@ -1658,7 +1728,7 @@ checksum = "e747f4a074699ba1b4e4d841fb263f9b7df5bd1555181c4752bf5990d21ba676"
|
||||
dependencies = [
|
||||
"proc-macro2",
|
||||
"quote",
|
||||
"syn",
|
||||
"syn 2.0.119",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
|
||||
@@ -6,4 +6,5 @@ edition = "2024"
|
||||
[dependencies]
|
||||
clap = { version = "4.6.1", features = ["derive"] }
|
||||
clio = { version = "0.3.5", features = ["clap-parse"] }
|
||||
memoize = "0.6.0"
|
||||
wasmtime = "46.0.1"
|
||||
|
||||
+11
-4
@@ -1,6 +1,6 @@
|
||||
use wasmtime::*;
|
||||
use crate::internal as scm;
|
||||
use crate::internal::{Scm,Immediate};
|
||||
use crate::internal::{Scm,Immediate,HeapObject};
|
||||
|
||||
// pub fn small_fixnum_p (_)
|
||||
|
||||
@@ -16,13 +16,20 @@ fn write_immediate (_caller : Caller<'_, u32>, imm : Immediate) {
|
||||
}
|
||||
|
||||
pub fn write (caller : Caller<'_, u32>, x : Rooted<EqRef>) {
|
||||
match scm::interpret (&caller, x).unwrap () {
|
||||
Scm::Immediate (x) => write_immediate (caller, x)
|
||||
match scm::interpret (&caller, x).unwrap ().unwrap () {
|
||||
Scm::Immediate (x) => write_immediate (caller, x),
|
||||
Scm::HeapObject (x) => write_heap_object (caller, x),
|
||||
}
|
||||
}
|
||||
|
||||
fn write_heap_object (_caller : Caller<'_, u32>, x : HeapObject) {
|
||||
match x {
|
||||
HeapObject::Procedure => print! ("#<procedure>"),
|
||||
}
|
||||
}
|
||||
|
||||
pub fn truthy_p (caller : Caller<'_, u32>, x : Rooted<EqRef>,) -> u32 {
|
||||
let r = scm::interpret (&caller, x).unwrap ();
|
||||
let r = scm::interpret (&caller, x).unwrap ().unwrap ();
|
||||
if let Scm::Immediate (Immediate::Bool (false)) = r {
|
||||
0
|
||||
} else {
|
||||
|
||||
+32
-3
@@ -1,4 +1,5 @@
|
||||
use wasmtime::*;
|
||||
use crate::types;
|
||||
|
||||
pub fn immediate_p (store : impl AsContext, x : Rooted<EqRef>) -> bool {
|
||||
x.is_i31 (store).unwrap ()
|
||||
@@ -9,8 +10,13 @@ pub enum Immediate {
|
||||
Bool (bool),
|
||||
}
|
||||
|
||||
pub enum HeapObject {
|
||||
Procedure
|
||||
}
|
||||
|
||||
pub enum Scm {
|
||||
Immediate (Immediate),
|
||||
HeapObject (HeapObject),
|
||||
}
|
||||
|
||||
#[allow(nonstandard_style)]
|
||||
@@ -33,14 +39,34 @@ pub fn interpret_immediate (x : scm_bits) -> Option<Immediate> {
|
||||
}
|
||||
}
|
||||
|
||||
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 ())?))
|
||||
pub fn interpret_heap_object (
|
||||
store : impl AsContext,
|
||||
x : Rooted<EqRef>
|
||||
) -> Result<Option<HeapObject>> {
|
||||
if x.matches_ty (&store, &types::closure (&store)?)? {
|
||||
Ok (Some (HeapObject::Procedure))
|
||||
} else {
|
||||
todo! ()
|
||||
}
|
||||
}
|
||||
|
||||
pub fn interpret (
|
||||
store : impl AsContext,
|
||||
x : Rooted<EqRef>
|
||||
) -> Result<Option<Scm>> {
|
||||
if let Some (imm) = x.as_i31 (&store)? {
|
||||
Ok (
|
||||
interpret_immediate (imm.get_u32 ())
|
||||
.map (Scm::Immediate)
|
||||
)
|
||||
} else {
|
||||
Ok (
|
||||
interpret_heap_object (&store, x)?
|
||||
.map (Scm::HeapObject)
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
pub fn encode_immediate (
|
||||
store : impl AsContext,
|
||||
imm : Immediate
|
||||
@@ -60,6 +86,9 @@ pub fn encode (store : impl AsContextMut, x : Scm) -> Rooted<EqRef> {
|
||||
.unwrap ();
|
||||
EqRef::from_i31 (store, i31)
|
||||
}
|
||||
Scm::HeapObject (ho) => {
|
||||
todo! ()
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
+2
-1
@@ -1,5 +1,6 @@
|
||||
mod gyehoek;
|
||||
mod internal;
|
||||
mod types;
|
||||
|
||||
use std::io;
|
||||
use std::io::Read;
|
||||
@@ -33,7 +34,7 @@ fn get_config () -> Config {
|
||||
|
||||
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)?;
|
||||
linker.func_wrap ("gyehoek", "truthy?", gyehoek::truthy_p)?;
|
||||
Ok (())
|
||||
}
|
||||
|
||||
|
||||
@@ -0,0 +1,62 @@
|
||||
use wasmtime::*;
|
||||
use memoize::memoize;
|
||||
|
||||
pub fn heap_object_struct (store : impl AsContext) -> Result<StructType> {
|
||||
let ctx = store.as_context ();
|
||||
let engine = ctx.engine ();
|
||||
Ok (
|
||||
StructType::with_finality_and_supertype (
|
||||
engine,
|
||||
Finality::NonFinal,
|
||||
None,
|
||||
vec![
|
||||
hash_field ()
|
||||
]
|
||||
)?
|
||||
)
|
||||
}
|
||||
|
||||
pub fn heap_object (_store : impl AsContext) -> Result<HeapType> {
|
||||
todo! ()
|
||||
}
|
||||
|
||||
#[memoize]
|
||||
pub fn hash_field () -> FieldType {
|
||||
FieldType::new (
|
||||
Mutability::Var,
|
||||
StorageType::ValType (ValType::I32)
|
||||
)
|
||||
}
|
||||
|
||||
pub fn closure (store : impl AsContext) -> Result<HeapType> {
|
||||
let ctx = store.as_context ();
|
||||
let engine = ctx.engine ();
|
||||
Ok (
|
||||
HeapType::ConcreteStruct (
|
||||
StructType::with_finality_and_supertype (
|
||||
engine,
|
||||
Finality::NonFinal,
|
||||
Some (&heap_object_struct (&store)?),
|
||||
vec![
|
||||
hash_field (),
|
||||
FieldType::new (
|
||||
Mutability::Const,
|
||||
StorageType::ValType (ValType::Ref (
|
||||
RefType::new (
|
||||
false,
|
||||
HeapType::ConcreteFunc (
|
||||
FuncType::new (
|
||||
engine,
|
||||
vec![ValType::I32],
|
||||
vec![],
|
||||
)
|
||||
)
|
||||
)
|
||||
))
|
||||
),
|
||||
]
|
||||
)?
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
+57
-83
@@ -54,18 +54,6 @@ type instance IxValue Env = Name
|
||||
instance Ixed Env where
|
||||
ix i = #vars . ix (fromIntegral i)
|
||||
|
||||
-- data Runtime = MkRuntime
|
||||
-- { argArrayType :: Idx
|
||||
-- , argArray :: Idx
|
||||
-- , contType :: Idx
|
||||
-- , contStackType :: Idx
|
||||
-- , contStackTop :: Idx
|
||||
-- , contStack :: Idx
|
||||
-- , result :: Idx
|
||||
-- , halt :: Idx
|
||||
-- }
|
||||
-- deriving (Show, Generic)
|
||||
|
||||
|
||||
|
||||
-- | @makeSmallFixnum@ emits an expression injecting the i32 on top
|
||||
@@ -139,18 +127,43 @@ lower' g (ExpIf c t f) = do
|
||||
let c' = lowerVal g c
|
||||
pure [expr|
|
||||
##{c'}
|
||||
(call $gh-to-bool)
|
||||
(call $gh-truthy?)
|
||||
(if (then ##{t'})
|
||||
(else ##{f'}))
|
||||
|]
|
||||
|
||||
lower' g e = error . show $ e
|
||||
lower' g (ExpLet [(r,lam)] e) = do
|
||||
idx <- lowerLambda g lam
|
||||
let g' = g & #vars <>~ [r]
|
||||
let n = succ $ length g.vars
|
||||
e' <- lower' g' e
|
||||
pure [expr|
|
||||
(i32.const 0)
|
||||
(ref.func #{idx})
|
||||
(struct.new $closure)
|
||||
(local.set #{n})
|
||||
##{e'}
|
||||
|]
|
||||
|
||||
-- lower' g (ExpIf c t f) = do
|
||||
-- t' <- lower' g t
|
||||
-- f' <- lower' g f
|
||||
-- pure $ lowerVal g c
|
||||
-- <> Wasm.if' (Wasm.result [i32]) t' f'
|
||||
lower' g (ExpContinue k [x]) = pure . mconcat $
|
||||
[ pushArg 0 (lowerVal g x)
|
||||
, [expr|
|
||||
(i32.const 1)
|
||||
(global.get $cont-stack)
|
||||
(global.get $cont-stack-top)
|
||||
(array.get $cont-stack-type)
|
||||
ref.as_non_null
|
||||
(global.get $cont-stack-top)
|
||||
(i32.const #{l})
|
||||
i32.sub
|
||||
(global.set $cont-stack-top)
|
||||
(return_call_ref $cont-type)
|
||||
|]
|
||||
]
|
||||
where
|
||||
l = succ $ V.elemIndex k g.kvars ^?! _Just
|
||||
|
||||
lower' g e = error . show $ e
|
||||
|
||||
-- lower' g (ExpContinue k [x]) = pure . mconcat $
|
||||
-- [ pushArg rt 0 (lowerVal g x)
|
||||
@@ -171,27 +184,24 @@ lower' g e = error . show $ e
|
||||
-- rt = g.runtime
|
||||
-- l = V.elemIndex k g.kvars ^?! _Just
|
||||
|
||||
-- lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
|
||||
-- idx <- defun [i32] [] (replicate 5 scm) \_ -> do
|
||||
-- let g' = g & #vars <>~ V.fromList xs
|
||||
-- & #kvars <>~ [ktail]
|
||||
-- m' <- lower' g' m
|
||||
-- pure . mconcat $
|
||||
-- [ xs & ifoldMap \n _ ->
|
||||
-- popArg g.runtime n <> ins "local.set" [sxp (1+n)]
|
||||
-- , m'
|
||||
-- ]
|
||||
-- declareFuncref idx
|
||||
-- let g' = g & #vars <>~ [r]
|
||||
-- let n = length g.vars
|
||||
-- e' <- lower' g' e
|
||||
-- pure . mconcat $
|
||||
-- [ ins "ref.func" [sxp idx]
|
||||
-- , ins "local.set" [sxp (n+1)]
|
||||
-- , e'
|
||||
-- ]
|
||||
|
||||
-- lower' g e = error . show $ e
|
||||
lowerLambda :: GenMod :> es => Env -> Lambda -> Eff es Idx
|
||||
lowerLambda g (MkLambda xs ktail m) = do
|
||||
let g' = g & #vars .~ V.fromList xs
|
||||
& #kvars <>~ [ktail]
|
||||
m' <- lower' g' m
|
||||
let body = mconcat
|
||||
[ xs & ifoldMap \n _ ->
|
||||
let n' = succ n
|
||||
in popArg n <> [expr|(local.set #{n'})|]
|
||||
, m'
|
||||
]
|
||||
idx <- Wasm.defineFunction [wat|
|
||||
(func (param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
##{body})
|
||||
|]
|
||||
Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
|
||||
pure idx
|
||||
|
||||
lowerBinOp
|
||||
:: (GenMod :> es)
|
||||
@@ -220,60 +230,24 @@ lowerBinOp op g x y r e = do
|
||||
|
||||
|
||||
|
||||
-- scm = ref eq
|
||||
|
||||
|
||||
|
||||
-- emitRuntime :: GenMod :> es => Eff es Runtime
|
||||
-- emitRuntime = mfix \runtime -> do
|
||||
-- heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
|
||||
-- [ Wasm.mut i32 ]
|
||||
-- -- cont stack
|
||||
-- contType <- Wasm.deftype $ Wasm.func [i32] []
|
||||
-- contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType)
|
||||
-- contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0]
|
||||
-- contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $
|
||||
-- ins "i32.const" [sxp @Int 128]
|
||||
-- <> ins "array.new_default" [sxp contStackType]
|
||||
-- -- arg array
|
||||
-- argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq
|
||||
-- argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $
|
||||
-- ins "i32.const" [sxp @Int 32]
|
||||
-- <> ins "array.new_default" [sxp argArrayType]
|
||||
-- -- consIdx <- Wasm.defun _ _ _ _
|
||||
-- result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq]
|
||||
-- halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
|
||||
-- pure . mconcat $
|
||||
-- [ popArg runtime 0
|
||||
-- , ins "global.set" [sxp result]
|
||||
-- ]
|
||||
-- pure $ MkRuntime
|
||||
-- {argArray,argArrayType
|
||||
-- ,contStack,contStackTop,contStackType,contType
|
||||
-- ,result,halt}
|
||||
-- -- pure $ error "todo"
|
||||
|
||||
emitRuntime :: GenMod :> es => Eff es ()
|
||||
emitRuntime = mfix \runtime -> do
|
||||
Wasm.emit [wats|
|
||||
Wasm.defineFunctions [wats|
|
||||
(import "gyehoek" "write" (func $gh-write (param (ref eq))))
|
||||
(import "gyehoek" "to-bool" (func $gh-to-bool (param (ref eq))
|
||||
(import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq))
|
||||
(result i32)))
|
||||
|]
|
||||
-- cont stack
|
||||
Wasm.defineType [wat|
|
||||
Wasm.defineTypes [wats|
|
||||
(type $heap-object (sub (struct (field $hash (mut i32)))))
|
||||
|]
|
||||
Wasm.defineType [wat|
|
||||
(type $cont-type (func (param i32)))
|
||||
|]
|
||||
Wasm.defineType [wat|
|
||||
(type $cont-stack-type (array (mut (ref null $cont-type))))
|
||||
(type $closure (sub $heap-object
|
||||
(struct (field $hash (mut i32))
|
||||
(field $code (ref $cont-type)))))
|
||||
|]
|
||||
Wasm.defineGlobal [wat|
|
||||
Wasm.defineGlobals [wats|
|
||||
(global $cont-stack-top (mut i32) (i32.const 0))
|
||||
|]
|
||||
Wasm.defineGlobal [wat|
|
||||
(global $cont-stack (ref $cont-stack-type)
|
||||
(array.new_default $cont-stack-type (i32.const 128)))
|
||||
|]
|
||||
|
||||
@@ -32,6 +32,9 @@ module Gyehoek.Wasm
|
||||
, renderModule
|
||||
, wat
|
||||
, wats
|
||||
, defineFunctions
|
||||
, defineTypes
|
||||
, defineGlobals
|
||||
)
|
||||
where
|
||||
|
||||
@@ -133,12 +136,21 @@ type instance DispatchOf GenMod = Dynamic
|
||||
defineFunction :: GenMod :> es => Sexp -> Eff es Idx
|
||||
defineFunction = send . DefineFunction
|
||||
|
||||
defineFunctions :: GenMod :> es => List Sexp -> Eff es (List Idx)
|
||||
defineFunctions = traverse (send . DefineFunction)
|
||||
|
||||
defineType :: GenMod :> es => Sexp -> Eff es Idx
|
||||
defineType = send . DefineType
|
||||
|
||||
defineTypes :: GenMod :> es => List Sexp -> Eff es (List Idx)
|
||||
defineTypes = traverse (send . DefineType)
|
||||
|
||||
defineGlobal :: GenMod :> es => Sexp -> Eff es Idx
|
||||
defineGlobal = send . DefineGlobal
|
||||
|
||||
defineGlobals :: GenMod :> es => List Sexp -> Eff es (List Idx)
|
||||
defineGlobals = traverse (send . DefineGlobal)
|
||||
|
||||
emit :: GenMod :> es => List Sexp -> Eff es ()
|
||||
emit = traverse_ (send . Emit)
|
||||
|
||||
|
||||
@@ -0,0 +1,70 @@
|
||||
(module
|
||||
(import
|
||||
"gyehoek"
|
||||
"write"
|
||||
(func $gh-write (param (ref eq))))
|
||||
(import
|
||||
"gyehoek"
|
||||
"truthy?"
|
||||
(func $gh-truthy? (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))))
|
||||
(type
|
||||
$closure
|
||||
(sub
|
||||
$heap-object
|
||||
(struct
|
||||
(field $hash (mut i32))
|
||||
(field $code (ref $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 123)
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(call $gh-truthy?)
|
||||
(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))
|
||||
(call $gh-write (ref.as_non_null (global.get $result)))))
|
||||
@@ -16,7 +16,6 @@ import System.Environment.Blank (getEnvDefault)
|
||||
disabled :: List String
|
||||
disabled =
|
||||
[ "square"
|
||||
, "lambda"
|
||||
]
|
||||
|
||||
main :: IO ()
|
||||
|
||||
Reference in New Issue
Block a user