Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Compiler: prepare compiler for 1658 #1765

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Compiler: prepare compiler for 1658 #1765

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
18 changes: 11 additions & 7 deletions compiler/lib/effects.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -543,11 +543,11 @@ let cps_block ~st ~k pc block =
in

let rewrite_instr x e =
let perform_effect ~effect_ ~continuation =
let perform_effect ~effect_ ~continuation ~tail =
Some
(fun ~k ->
let e =
Prim (Extern "caml_perform_effect", [ Pv effect_; continuation; Pv k ])
Prim (Extern "caml_perform_effect", [ Pv effect_; continuation; tail; Pv k ])
in
let x = Var.fresh () in
[ Let (x, e) ], Return x)
Expand All @@ -560,22 +560,26 @@ let cps_block ~st ~k pc block =
exact || Global_flow.exact_call st.flow_info f (List.length args)
in
tail_call ~st ~exact ~in_cps:true ~check:true ~f (args @ [ k ]))
| Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg ]) ->
| Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg; tail ]) ->
Some
(fun ~k ->
let k' = Var.fresh_n "cont" in
tail_call
~st
~instrs:[ Let (k', Prim (Extern "caml_resume_stack", [ Pv stack; Pv k ])) ]
~instrs:
[ Let (k', Prim (Extern "caml_resume_stack", [ Pv stack; tail; Pv k ])) ]
~exact:(Global_flow.exact_call st.flow_info f 1)
~in_cps:true
~check:true
~f
[ arg; k' ])
| Prim (Extern "%perform", [ Pv effect_ ]) ->
perform_effect ~effect_ ~continuation:(Pc (Int Targetint.zero))
| Prim (Extern "%reperform", [ Pv effect_; continuation ]) ->
perform_effect ~effect_ ~continuation
perform_effect
~effect_
~continuation:(Pc (Int Targetint.zero))
~tail:(Pc (Int Targetint.zero))
| Prim (Extern "%reperform", [ Pv effect_; continuation; tail ]) ->
perform_effect ~effect_ ~continuation ~tail
| _ -> None
in

Expand Down
26 changes: 16 additions & 10 deletions compiler/lib/parse_bytecode.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2368,7 +2368,6 @@ and compile infos pc state (instrs : instr list) =
let func = State.peek 0 state in
let arg = State.peek 1 state in
let x, state = State.fresh_var state in

if debug_parser ()
then
Format.printf
Expand All @@ -2381,23 +2380,30 @@ and compile infos pc state (instrs : instr list) =
func
Var.print
arg;
let state =
let state, tail =
match Ocaml_version.compare Ocaml_version.current [ 5; 2 ] < 0 with
| true -> State.pop 2 state
| false -> State.pop 3 state
| true -> State.pop 2 state, Pc (Int (Targetint.of_int_exn 0))
| false ->
let tail = State.peek 2 state in
State.pop 3 state, Pv tail
in

compile
infos
(pc + 1)
state
(Let (x, Prim (Extern "%resume", [ Pv stack; Pv func; Pv arg ])) :: instrs)
(Let (x, Prim (Extern "%resume", [ Pv stack; Pv func; Pv arg; tail ])) :: instrs)
| RESUMETERM ->
let stack = State.accu state in
let func = State.peek 0 state in
let arg = State.peek 1 state in
let x, state = State.fresh_var state in

let tail =
match Ocaml_version.compare Ocaml_version.current [ 5; 2 ] < 0 with
| true -> Pc (Int (Targetint.of_int_exn 0))
| false ->
let tail = State.peek 2 state in
Pv tail
in
if debug_parser ()
then
Format.printf
Expand All @@ -2408,7 +2414,7 @@ and compile infos pc state (instrs : instr list) =
func
Var.print
arg;
( Let (x, Prim (Extern "%resume", [ Pv stack; Pv func; Pv arg ])) :: instrs
( Let (x, Prim (Extern "%resume", [ Pv stack; Pv func; Pv arg; tail ])) :: instrs
, Return x
, state )
| PERFORM ->
Expand All @@ -2425,13 +2431,13 @@ and compile infos pc state (instrs : instr list) =
| REPERFORMTERM ->
let eff = State.accu state in
let stack = State.peek 0 state in
(* We don't need [State.peek 1 state] *)
let tail = State.peek 1 state in
let state = State.pop 2 state in
let x, state = State.fresh_var state in

if debug_parser ()
then Format.printf "return reperform(%a, %a)@." Var.print eff Var.print stack;
( Let (x, Prim (Extern "%reperform", [ Pv eff; Pv stack ])) :: instrs
( Let (x, Prim (Extern "%reperform", [ Pv eff; Pv stack; Pv tail ])) :: instrs
, Return x
, state )
| EVENT | BREAK | FIRST_UNIMPLEMENTED_OP -> assert false)
Expand Down
11 changes: 6 additions & 5 deletions runtime/js/effect.js
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -78,7 +78,7 @@ var caml_fiber_stack;
//Provides:caml_resume_stack
//Requires: caml_named_value, caml_raise_constant, caml_exn_stack, caml_fiber_stack
//If: effects
function caml_resume_stack(stack, k) {
function caml_resume_stack(stack, last, k) {
if (!stack)
caml_raise_constant(
caml_named_value("Effect.Continuation_already_resumed"),
Expand Down Expand Up @@ -111,9 +111,9 @@ function caml_pop_fiber() {
//Provides: caml_perform_effect
//Requires: caml_pop_fiber, caml_stack_check_depth, caml_trampoline_return, caml_exn_stack, caml_fiber_stack
//If: effects
function caml_perform_effect(eff, cont, k0) {
function caml_perform_effect(eff, cont, last, k0) {
// Allocate a continuation if we don't already have one
if (!cont) cont = [245 /*continuation*/, 0];
if (!cont) cont = [245 /*continuation*/, 0, 0];
// Get current effect handler
var handler = caml_fiber_stack.h[3];
// Cons the current fiber onto the continuation:
Expand All @@ -122,9 +122,10 @@ function caml_perform_effect(eff, cont, k0) {
// Move to parent fiber and execute the effect handler there
// The handler is defined in Stdlib.Effect, so we know that the arity matches
var k1 = caml_pop_fiber();
var last_fiber = "last_fiber"; // FIXME
return caml_stack_check_depth()
? handler(eff, cont, k1, k1)
: caml_trampoline_return(handler, [eff, cont, k1, k1]);
? handler(eff, cont, last_fiber, k1)
: caml_trampoline_return(handler, [eff, cont, last_fiber, k1]);
}

//Provides: caml_alloc_stack
Expand Down
4 changes: 2 additions & 2 deletions runtime/js/jslib.js
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -86,9 +86,9 @@ var caml_callback = caml_call_gen;
//Requires:caml_stack_depth, caml_call_gen, caml_exn_stack, caml_fiber_stack, caml_wrap_exception, caml_resume_stack, caml_fresh_oo_id, caml_named_value, caml_raise_with_arg, caml_string_of_jsbytes
//Requires: caml_raise_constant
function caml_callback(f, args) {
function uncaught_effect_handler(eff, k, ms) {
function uncaught_effect_handler(eff, k, last, ms) {
// Resumes the continuation k by raising exception Unhandled.
caml_resume_stack(k[1], ms);
caml_resume_stack(k[1], last, ms);
var exn = caml_named_value("Effect.Unhandled");
if (exn) caml_raise_with_arg(exn, eff);
else {
Expand Down
12 changes: 7 additions & 5 deletions runtime/wasm/effect.wat
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -218,7 +218,7 @@
(data $already_resumed "Effect.Continuation_already_resumed")

(func (export "%resume")
(param $stack (ref eq)) (param $f (ref eq)) (param $v (ref eq))
(param $stack (ref eq)) (param $f (ref eq)) (param $v (ref eq)) (param $tail (ref eq))
(result (ref eq))
(local $k (ref $cont))
(local $pair (ref $pair))
Expand Down Expand Up @@ -297,7 +297,7 @@
(struct.get $cont $cont_func (local.get $k1))))

(func $reperform (export "%reperform")
(param $eff (ref eq)) (param $cont (ref eq))
(param $eff (ref eq)) (param $cont (ref eq)) (param $tail (ref eq))
(result (ref eq))
(return_call $capture_continuation
(ref.func $do_perform)
Expand All @@ -306,7 +306,8 @@
(func (export "%perform") (param $eff (ref eq)) (result (ref eq))
(return_call $reperform (local.get $eff)
(array.new_fixed $block 3 (ref.i31 (global.get $cont_tag))
(ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)))))
(ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)))
(ref.i31 (i32.const 0))))

;; Allocate a stack

Expand Down Expand Up @@ -614,7 +615,7 @@
(struct.get $cps_fiber $cont (local.get $top)))

(func $caml_resume_stack (export "caml_resume_stack")
(param $vstack (ref eq)) (param $k (ref eq)) (result (ref eq))
(param $vstack (ref eq)) (param $last (ref eq)) (param $k (ref eq)) (result (ref eq))
(local $stack (ref $cps_fiber))
(drop (block $already_resumed (result (ref eq))
(local.set $stack
Expand Down Expand Up @@ -644,7 +645,7 @@
(ref.i31 (i32.const 0)))

(func (export "caml_perform_effect")
(param $eff (ref eq)) (param $vcont (ref eq)) (param $k0 (ref eq))
(param $eff (ref eq)) (param $vcont (ref eq)) (param $last (ref eq)) (param $k0 (ref eq))
(result (ref eq))
(local $handlers (ref $handlers))
(local $handler (ref eq)) (local $k1 (ref eq))
Expand Down Expand Up @@ -727,6 +728,7 @@
(call $caml_resume_stack
(array.get $block
(ref.cast (ref $block) (local.get $k)) (i32.const 1))
(ref.i31 (i32.const 0))
(local.get $ms)))
(call $raise_unhandled (local.get $eff) (ref.i31 (i32.const 0))))

Expand Down
Loading