Skip to content

Commit 226063f

Browse files
vouillonvouillon
committed
Effects based on Stack Switching proposal
1 parent 0bacf91 commit 226063f

File tree

8 files changed

+240
-16
lines changed

8 files changed

+240
-16
lines changed

‎.github/workflows/build-wasm_of_ocaml.yml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -214,7 +214,7 @@ jobs:
214214
run: opam exec -- dune build @runtest-wasm --profile with-effects
215215

216216
- name: Run tests (WASI runtime - node)
217-
if: ${{ matrix.wasi }}
217+
if: ${{ false }}
218218
working-directory: ./wasm_of_ocaml
219219
run: opam exec -- dune build @runtest-wasm --profile wasi
220220

@@ -226,7 +226,7 @@ jobs:
226226
run: opam exec -- dune build @runtest-wasm --profile wasi
227227

228228
- name: Run tests (WASI runtime - wasmtime)
229-
if: ${{ matrix.wasi }}
229+
if: ${{ false }}
230230
working-directory: ./wasm_of_ocaml
231231
env:
232232
WASM_ENGINE: wasmtime

‎compiler/lib-wasm/binaryen.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ let common_options () =
3737
; "--enable-nontrapping-float-to-int"
3838
; "--enable-strings"
3939
; "--enable-multimemory" (* To keep wasm-merge happy *)
40+
; "--enable-stack-switching"
4041
]
4142
in
4243
if Config.Flag.pretty () then "-g" :: l else l

‎compiler/tests-jsoo/lib-effects/dune

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,10 @@
11
(env
22
(with-effects-double-translation)
33
(with-effects)
4-
(wasi
5-
(wasm_of_ocaml
6-
(flags
7-
(:standard --enable effects))))
4+
; (wasi
5+
; (wasm_of_ocaml
6+
; (flags
7+
; (:standard --enable effects))))
88
(_
99
(js_of_ocaml
1010
(flags

‎compiler/tests-ocaml/effect-syntax/dune

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,10 @@
11
(env
22
(with-effects-double-translation)
33
(with-effects)
4-
(wasi
5-
(wasm_of_ocaml
6-
(flags
7-
(:standard --enable=effects))))
4+
; (wasi
5+
; (wasm_of_ocaml
6+
; (flags
7+
; (:standard --enable=effects))))
88
(_
99
(js_of_ocaml
1010
(flags

‎compiler/tests-ocaml/effects/dune

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,10 @@
11
(env
22
(with-effects-double-translation)
33
(with-effects)
4-
(wasi
5-
(wasm_of_ocaml
6-
(flags
7-
(:standard --enable=effects))))
4+
; (wasi
5+
; (wasm_of_ocaml
6+
; (flags
7+
; (:standard --enable=effects))))
88
(_
99
(js_of_ocaml
1010
(flags

‎runtime/wasm/effect-native.wat

Lines changed: 213 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,213 @@
1+
(module
2+
(@if (and wasi (<> effects "cps"))
3+
(@then
4+
(import "fail" "caml_raise_constant"
5+
(func $caml_raise_constant (param (ref eq))))
6+
(import "fail" "caml_raise_with_arg"
7+
(func $caml_raise_with_arg (param $tag (ref eq)) (param $arg (ref eq))))
8+
(import "obj" "caml_fresh_oo_id"
9+
(func $caml_fresh_oo_id (param (ref eq)) (result (ref eq))))
10+
(import "obj" "cont_tag" (global $cont_tag i32))
11+
(import "stdlib" "caml_named_value"
12+
(func $caml_named_value (param (ref eq)) (result (ref null eq))))
13+
(import "fail" "ocaml_exception" (tag $ocaml_exception (param (ref eq))))
14+
(import "fail" "javascript_exception"
15+
(tag $javascript_exception (param externref)))
16+
(import "jslib" "caml_wrap_exception"
17+
(func $caml_wrap_exception (param externref) (result (ref eq))))
18+
(import "stdlib" "caml_main_wrapper"
19+
(global $caml_main_wrapper (mut (ref null $wrapper_func))))
20+
(import "effect" "effect_allowed" (global $effect_allowed (mut i32)))
21+
22+
(type $block (array (mut (ref eq))))
23+
(type $bytes (array (mut i8)))
24+
(type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq))))
25+
(type $closure (sub (struct (;(field i32);) (field (ref $function_1)))))
26+
(type $function_3
27+
(func (param (ref eq) (ref eq) (ref eq) (ref eq)) (result (ref eq))))
28+
(type $closure_3
29+
(sub $closure
30+
(struct (field (ref $function_1)) (field (ref $function_3)))))
31+
32+
;; Effect types
33+
34+
(tag $effect (param (ref eq)) (result (ref eq) (ref eq)))
35+
36+
(type $cont_function (func (param (ref eq) (ref eq)) (result (ref eq))))
37+
38+
(type $cont (cont $cont_function))
39+
40+
(type $generic_fiber
41+
(sub
42+
(struct
43+
(field $value (mut (ref eq)))
44+
(field $exn (mut (ref eq)))
45+
(field $effect (mut (ref eq))))))
46+
47+
(type $fiber
48+
(sub final $generic_fiber
49+
(struct
50+
(field $value (mut (ref eq)))
51+
(field $exn (mut (ref eq)))
52+
(field $effect (mut (ref eq)))
53+
(field $cont (mut (ref $cont))))))
54+
55+
;; Unhandled effects
56+
57+
(@string $effect_unhandled "Effect.Unhandled")
58+
59+
(func $raise_unhandled
60+
(param $eff (ref eq)) (param (ref eq)) (result (ref eq))
61+
(block $null
62+
(call $caml_raise_with_arg
63+
(br_on_null $null
64+
(call $caml_named_value (global.get $effect_unhandled)))
65+
(local.get $eff)))
66+
(call $caml_raise_constant
67+
(array.new_fixed $block 3 (ref.i31 (i32.const 248))
68+
(global.get $effect_unhandled)
69+
(call $caml_fresh_oo_id (ref.i31 (i32.const 0)))))
70+
(ref.i31 (i32.const 0)))
71+
72+
(global $raise_unhandled (ref $closure)
73+
(struct.new $closure (ref.func $raise_unhandled)))
74+
75+
(type $func (func (result (ref eq))))
76+
(type $wrapper_func (func (param (ref $func))))
77+
(type $func_closure (struct (field (ref $func))))
78+
79+
(func $wrapper_cont
80+
(param $f (ref eq)) (param (ref eq)) (result (ref eq))
81+
(return_call_ref $func
82+
(local.get $f)
83+
(struct.get $func_closure 0
84+
(ref.cast (ref $func_closure) (local.get $f)))))
85+
86+
(func $unhandled_effect_wrapper (param $start (ref $func))
87+
(local $cont (ref $cont))
88+
(local $f (ref eq)) (local $v (ref eq))
89+
(local $resume_res (tuple (ref eq) (ref $cont)))
90+
(local.set $cont (cont.new $cont (ref.func $wrapper_cont)))
91+
(local.set $f (struct.new $func_closure (local.get $start)))
92+
(local.set $v (ref.i31 (i32.const 0)))
93+
(loop $loop
94+
(local.set $resume_res
95+
(block $handle_effect (result (ref eq) (ref $cont))
96+
(resume $cont (on $effect $handle_effect)
97+
(local.get $f) (local.get $v) (local.get $cont))
98+
(return)))
99+
(local.set $cont (tuple.extract 2 1 (local.get $resume_res)))
100+
(local.set $v (tuple.extract 2 0 (local.get $resume_res)))
101+
(local.set $f (global.get $raise_unhandled))
102+
(br $loop)))
103+
104+
(func $init
105+
(global.set $caml_main_wrapper (ref.func $unhandled_effect_wrapper)))
106+
107+
(start $init)
108+
109+
;; Resume
110+
111+
(@string $already_resumed "Effect.Continuation_already_resumed")
112+
113+
(func $resume (export "%resume")
114+
(param $vfiber (ref eq)) (param $f (ref eq)) (param $v (ref eq))
115+
(param $tail (ref eq)) (result (ref eq))
116+
(local $fiber (ref $fiber))
117+
(local $res (ref eq))
118+
(local $exn (ref eq))
119+
(local $resume_res (tuple (ref eq) (ref $cont)))
120+
(if (ref.eq (local.get $vfiber) (ref.i31 (i32.const 0)))
121+
(then
122+
(call $caml_raise_constant
123+
(ref.as_non_null
124+
(call $caml_named_value (global.get $already_resumed))))))
125+
(local.set $fiber (ref.cast (ref $fiber) (local.get $vfiber)))
126+
(local.set $exn
127+
(block $handle_exception (result (ref eq))
128+
(local.set $resume_res
129+
(block $handle_effect (result (ref eq) (ref $cont))
130+
(local.set $res
131+
(try (result (ref eq))
132+
(do
133+
(resume $cont
134+
(on $effect $handle_effect)
135+
(local.get $f) (local.get $v)
136+
(struct.get $fiber $cont (local.get $fiber))))
137+
(@if (not wasi)
138+
(@then
139+
(catch $javascript_exception
140+
(br $handle_exception
141+
(call $caml_wrap_exception (pop externref))))
142+
))
143+
(catch $ocaml_exception
144+
(br $handle_exception (pop (ref eq))))))
145+
;; handle return
146+
(return_call_ref $function_1 (local.get $res)
147+
(local.tee $f
148+
(struct.get $fiber $value (local.get $fiber)))
149+
(struct.get $closure 0
150+
(ref.cast (ref $closure) (local.get $f))))))
151+
;; handle effect
152+
(struct.set $fiber $cont (local.get $fiber)
153+
(tuple.extract 2 1 (local.get $resume_res)))
154+
(return_call_ref $function_3
155+
(tuple.extract 2 0 (local.get $resume_res))
156+
(array.new_fixed $block 3 (ref.i31 (global.get $cont_tag))
157+
(local.get $fiber)
158+
(local.get $fiber))
159+
(local.get $tail)
160+
(local.tee $f
161+
(struct.get $fiber $effect (local.get $fiber)))
162+
(struct.get $closure_3 1
163+
(ref.cast (ref $closure_3) (local.get $f))))))
164+
;; handle exception
165+
(return_call_ref $function_1 (local.get $exn)
166+
(local.tee $f
167+
(struct.get $fiber $exn (local.get $fiber)))
168+
(struct.get $closure 0 (ref.cast (ref $closure) (local.get $f)))))
169+
170+
;; Perform
171+
172+
(func (export "%reperform")
173+
(param $eff (ref eq)) (param $cont (ref eq)) (param $tail (ref eq))
174+
(result (ref eq))
175+
(local $res (tuple (ref eq) (ref eq)))
176+
(local.set $res (suspend $effect (local.get $eff)))
177+
(return_call $resume
178+
(ref.as_non_null
179+
(array.get $block
180+
(ref.cast (ref $block) (local.get $cont))
181+
(i32.const 1)))
182+
(tuple.extract 2 0 (local.get $res))
183+
(tuple.extract 2 1 (local.get $res))
184+
(local.get $tail)))
185+
186+
(func (export "%perform") (param $eff (ref eq)) (result (ref eq))
187+
(local $res (tuple (ref eq) (ref eq)))
188+
(if (i32.eqz (global.get $effect_allowed))
189+
(then
190+
(return_call $raise_unhandled
191+
(local.get $eff) (ref.i31 (i32.const 0)))))
192+
(local.set $res (suspend $effect (local.get $eff)))
193+
(return_call_ref $function_1 (tuple.extract 2 1 (local.get $res))
194+
(tuple.extract 2 0 (local.get $res))
195+
(struct.get $closure 0
196+
(ref.cast (ref $closure) (tuple.extract 2 0 (local.get $res))))))
197+
198+
;; Allocate a stack
199+
200+
(func $initial_cont
201+
(param $f (ref eq)) (param $x (ref eq)) (result (ref eq))
202+
(return_call_ref $function_1 (local.get $x)
203+
(local.get $f)
204+
(struct.get $closure 0 (ref.cast (ref $closure) (local.get $f)))))
205+
206+
(func (export "caml_alloc_stack")
207+
(param $hv (ref eq)) (param $hx (ref eq)) (param $hf (ref eq))
208+
(result (ref eq))
209+
(struct.new $fiber
210+
(local.get $hv) (local.get $hx) (local.get $hf)
211+
(cont.new $cont (ref.func $initial_cont))))
212+
))
213+
)

‎runtime/wasm/effect.wat

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -88,7 +88,7 @@
8888
(global $raise_unhandled (ref $closure)
8989
(struct.new $closure (ref.func $raise_unhandled)))
9090

91-
(global $effect_allowed (mut i32) (i32.const 1))
91+
(global $effect_allowed (export "effect_allowed") (mut i32) (i32.const 1))
9292

9393
(func $caml_continuation_use_noexc (export "caml_continuation_use_noexc")
9494
(param (ref eq)) (result (ref eq))
@@ -139,7 +139,7 @@
139139
(ref.i31 (global.get $cont_tag))))))
140140
(i32.const 0))
141141

142-
(@if (= effects "jspi")
142+
(@if (and (not wasi) (= effects "jspi"))
143143
(@then
144144
;; Apply a function f to a value v, both contained in a pair (f, v)
145145

‎runtime/wasm/stdlib.wat

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -213,6 +213,11 @@
213213
(call $caml_main (ref.func $reraise_exception)))
214214
))
215215

216+
(type $wrapper_func (func (param (ref $func))))
217+
(global $caml_main_wrapper (export "caml_main_wrapper")
218+
(mut (ref null $wrapper_func))
219+
(ref.null $wrapper_func))
220+
216221
(func $caml_main (export "caml_main") (param $start (ref func))
217222
(local $exn (ref eq))
218223
(local $msg (ref eq))
@@ -225,6 +230,11 @@
225230
))
226231
(try
227232
(do
233+
(block $fallback
234+
(call_ref $wrapper_func
235+
(ref.cast (ref $func) (local.get $start))
236+
(br_on_null $fallback (global.get $caml_main_wrapper)))
237+
(return))
228238
(drop (call_ref $func (ref.cast (ref $func) (local.get $start)))))
229239
(catch $ocaml_exit)
230240
(catch $ocaml_exception

0 commit comments

Comments
 (0)