Skip to content

Commit

Permalink
Adapt runtime for optional double translation
Browse files Browse the repository at this point in the history
  • Loading branch information
@OlivierNicole
OlivierNicole committed Aug 30, 2023
1 parent 8128607 commit 004aa40
Show file tree
Hide file tree
Showing 3 changed files with 132 additions and 34 deletions.
54 changes: 28 additions & 26 deletions compiler/lib/effects.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1183,32 +1183,34 @@ let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p =
}
in
let p =
(* Initialize the global fiber stack and define a global identity function,
needed to translate [%resume] *)
let id_pc = p.free_pc in
let blocks =
let id_param = Var.fresh_n "x" in
Addr.Map.add
id_pc
{ params = [ id_param ]; body = []; branch = Return id_param, noloc }
p.blocks
in
let id_arg = Var.fresh_n "x" in
let dummy = Var.fresh_n "dummy" in
let new_start = id_pc + 1 in
let blocks =
Addr.Map.add
new_start
{ params = []
; body =
[ Let (ident_fn, Closure ([ id_arg ], (id_pc, [ id_arg ]))), noloc
; Let (dummy, Prim (Extern "caml_initialize_fiber_stack", [])), noloc
]
; branch = Branch (p.start, []), noloc
}
blocks
in
{ start = new_start; blocks; free_pc = new_start + 1 }
if double_translate () then
(* Initialize the global fiber stack and define a global identity function,
needed to translate [%resume] *)
let id_pc = p.free_pc in
let blocks =
let id_param = Var.fresh_n "x" in
Addr.Map.add
id_pc
{ params = [ id_param ]; body = []; branch = Return id_param, noloc }
p.blocks
in
let id_arg = Var.fresh_n "x" in
let dummy = Var.fresh_n "dummy" in
let new_start = id_pc + 1 in
let blocks =
Addr.Map.add
new_start
{ params = []
; body =
[ Let (ident_fn, Closure ([ id_arg ], (id_pc, [ id_arg ]))), noloc
; Let (dummy, Prim (Extern "caml_initialize_fiber_stack", [])), noloc
]
; branch = Branch (p.start, []), noloc
}
blocks
in
{ start = new_start; blocks; free_pc = new_start + 1 }
else p
in
p, !cps_calls, !single_version_closures

Expand Down
64 changes: 56 additions & 8 deletions runtime/effect.js
View file
Original file line number Diff line number Diff line change
Expand Up @@ -43,9 +43,9 @@ The handlers are CPS-transformed functions: they actually take an
additional parameter which is the current low-level continuation.
Effect and exception handlers are CPS, single-version functions, meaning that
are ordinary functions, unlike CPS-transformed functions which exist in both
direct style and continuation-passing style.
Low-level continuations are also ordinary functions.
they are ordinary functions, unlike CPS-transformed functions which, if double
translation is enabled, exist in both direct style and continuation-passing
style. Low-level continuations are also ordinary functions.
*/

//Provides: caml_exn_stack
Expand Down Expand Up @@ -73,6 +73,7 @@ function caml_pop_trap() {
//Provides: uncaught_effect_handler
//Requires: caml_named_value, caml_raise_constant, caml_raise_with_arg, caml_string_of_jsbytes, caml_fresh_oo_id, caml_resume_stack
//If: effects
//If: doubletranslate
function uncaught_effect_handler(eff,k,ms) {
// Resumes the continuation k by raising exception Unhandled.
caml_resume_stack(k[1],ms);
Expand All @@ -94,6 +95,7 @@ var caml_fiber_stack;
//Provides: caml_initialize_fiber_stack
//Requires: caml_fiber_stack, uncaught_effect_handler
//If: effects
//If: doubletranslate
function caml_initialize_fiber_stack() {
caml_fiber_stack = {h:[0, 0, 0, uncaught_effect_handler], r:{k:0, x:0, e:0}};
}
Expand Down Expand Up @@ -127,8 +129,22 @@ function caml_pop_fiber() {
return rem.k;
}

//Provides: caml_prepare_tramp
//If: effects
//If: !doubletranslate
function caml_prepare_tramp(handler) {
return handler;
}

//Provides: caml_prepare_tramp
//If: effects
//If: doubletranslate
function caml_prepare_tramp(handler) {
return {cps: handler};
}

//Provides: caml_perform_effect
//Requires: caml_pop_fiber, caml_stack_check_depth, caml_trampoline_return, caml_exn_stack, caml_fiber_stack
//Requires: caml_pop_fiber, caml_stack_check_depth, caml_trampoline_return, caml_exn_stack, caml_fiber_stack, caml_prepare_tramp
//If: effects
function caml_perform_effect(eff, cont, k0) {
// Allocate a continuation if we don't already have one
Expand All @@ -142,17 +158,47 @@ function caml_perform_effect(eff, cont, k0) {
// The handler is defined in Stdlib.Effect, so we know that the arity matches
var k1 = caml_pop_fiber();
return caml_stack_check_depth()?handler(eff,cont,k1,k1)
:caml_trampoline_return({cps: handler},[eff,cont,k1,k1]);
:caml_trampoline_return(caml_prepare_tramp(handler),[eff,cont,k1,k1]);
}

//Provides: caml_call_fun
//Requires: caml_call_gen
//If: effects
//If: !doubletranslate
function caml_call_fun(f, args) {
return caml_call_gen(f, args);
}

//Provides: caml_call_fun
//Requires: caml_call_gen_cps
//If: effects
//If: doubletranslate
function caml_call_fun(f, args) {
return caml_call_gen_cps(f, args);
}

//Provides: caml_get_fun
//If: effects
//If: !doubletranslate
function caml_get_fun(f) {
return f;
}

//Provides: caml_get_fun
//If: effects
//If: doubletranslate
function caml_get_fun(f) {
return f.cps;
}

//Provides: caml_alloc_stack
//Requires: caml_pop_fiber, caml_fiber_stack, caml_call_gen_cps, caml_stack_check_depth, caml_trampoline_return
//Requires: caml_pop_fiber, caml_fiber_stack, caml_stack_check_depth, caml_trampoline_return, caml_call_fun, caml_get_fun
//If: effects
function caml_alloc_stack(hv, hx, hf) {
function call(i, x) {
var f=caml_fiber_stack.h[i];
var args = [x, caml_pop_fiber()];
return caml_stack_check_depth()?caml_call_gen_cps(f,args)
return caml_stack_check_depth()?caml_call_fun(f,args)
:caml_trampoline_return(f,args);
}
function hval(x) {
Expand All @@ -163,7 +209,7 @@ function caml_alloc_stack(hv, hx, hf) {
// Call [hx] in the parent fiber
return call(2, e);
}
return [0, hval, [0, hexn, 0], [0, hv, hx, hf.cps], 0];
return [0, hval, [0, hexn, 0], [0, hv, hx, caml_get_fun(hf)], 0];
}

//Provides: caml_alloc_stack
Expand Down Expand Up @@ -220,6 +266,7 @@ function jsoo_effect_not_supported(){
//Provides: caml_trampoline_cps
//Requires:caml_stack_depth, caml_call_gen_cps, caml_exn_stack, caml_fiber_stack, caml_wrap_exception
//If: effects
//If: doubletranslate
function caml_trampoline_cps(f, args) {
/* Note: f is not an ordinary function but a (direct-style, CPS) closure pair */
var res = {joo_tramp: f, joo_args: args};
Expand All @@ -241,6 +288,7 @@ function caml_trampoline_cps(f, args) {

//Provides: caml_cps_closure
//If: effects
//If: doubletranslate
function caml_cps_closure(direct_f, cps_f) {
direct_f.cps = cps_f;
return direct_f;
Expand Down
48 changes: 48 additions & 0 deletions runtime/jslib.js
View file
Original file line number Diff line number Diff line change
Expand Up @@ -70,6 +70,54 @@ var caml_callback = caml_call_gen;

//Provides: caml_callback
//If: effects
//If: !doubletranslate
//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) {
// Resumes the continuation k by raising exception Unhandled.
caml_resume_stack(k[1],ms);
var exn = caml_named_value("Effect.Unhandled");
if(exn) caml_raise_with_arg(exn, eff);
else {
exn = [248,caml_string_of_jsbytes("Effect.Unhandled"), caml_fresh_oo_id(0)];
caml_raise_constant(exn);
}
}
var saved_stack_depth = caml_stack_depth;
var saved_exn_stack = caml_exn_stack;
var saved_fiber_stack = caml_fiber_stack;
try {
caml_exn_stack = 0;
caml_fiber_stack =
{h:[0, 0, 0, uncaught_effect_handler], r:{k:0, x:0, e:0}};
var res = {joo_tramp: f,
joo_args: args.concat(function (x){return x;})};
do {
caml_stack_depth = 40;
try {
res = caml_call_gen(res.joo_tramp, res.joo_args);
} catch (e) {
/* Handle exception coming from JavaScript or from the runtime. */
if (!caml_exn_stack) throw e;
var handler = caml_exn_stack[1];
caml_exn_stack = caml_exn_stack[2];
res = {joo_tramp: handler,
joo_args: [caml_wrap_exception(e)]};
}
} while(res && res.joo_args)
} finally {
caml_stack_depth = saved_stack_depth;
caml_exn_stack = saved_exn_stack;
caml_fiber_stack = saved_fiber_stack;
}
return res;
}


//Provides: caml_callback
//If: effects
//If: doubletranslate
//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) {
Expand Down

0 comments on commit 004aa40

Please sign in to comment.