From 88b0fc3685f25009453e85e93f683de2bb74ba9b Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 9 Mar 2023 18:45:48 +0100 Subject: [PATCH 1/2] Effects: double translation of functions and ... dynamic switching between direct-style and CPS code. (#1461) --- CHANGES.md | 1 + compiler/lib/build_info.ml | 9 +- compiler/lib/code.ml | 4 + compiler/lib/code.mli | 2 + compiler/lib/config.ml | 2 + compiler/lib/config.mli | 2 + compiler/lib/driver.ml | 9 +- compiler/lib/effects.ml | 805 +++++++++++++++--- compiler/lib/effects.mli | 11 + compiler/lib/flow.ml | 2 +- compiler/lib/freevars.ml | 15 +- compiler/lib/freevars.mli | 11 +- compiler/lib/generate.ml | 155 ++-- compiler/lib/generate.mli | 1 + compiler/lib/lambda_lifting.ml | 4 +- compiler/lib/lambda_lifting_simple.ml | 344 ++++++++ compiler/lib/lambda_lifting_simple.mli | 53 ++ compiler/lib/linker.ml | 1 + compiler/lib/phisimpl.ml | 2 +- compiler/lib/stdlib.ml | 15 + compiler/lib/subst.ml | 189 ++-- compiler/lib/subst.mli | 43 +- compiler/tests-compiler/direct_calls.ml | 29 +- .../double-translation/direct_calls.ml | 223 +++++ .../tests-compiler/double-translation/dune | 14 + .../double-translation/dune.inc | 60 ++ .../effects_continuations.ml | 298 +++++++ .../double-translation/effects_exceptions.ml | 198 +++++ .../double-translation/effects_toplevel.ml | 89 ++ compiler/tests-compiler/effects.ml | 15 +- .../tests-compiler/effects_continuations.ml | 88 +- compiler/tests-compiler/effects_exceptions.ml | 67 +- compiler/tests-compiler/effects_toplevel.ml | 22 +- compiler/tests-compiler/lambda_lifting.ml | 9 +- compiler/tests-compiler/util/util.ml | 67 +- compiler/tests-compiler/util/util.mli | 5 + .../lib-effects/double-translation/cmphash.ml | 24 + .../double-translation/cmphash.reference | 2 + .../lib-effects/double-translation/dune | 463 ++++++++++ .../lib-effects/double-translation/effects.ml | 226 +++++ .../double-translation/effects.reference | 18 + .../lib-effects/double-translation/evenodd.ml | 22 + .../double-translation/evenodd.reference | 1 + .../double-translation/manylive.ml | 27 + .../double-translation/manylive.reference | 1 + .../lib-effects/double-translation/marshal.ml | 21 + .../double-translation/marshal.reference | 1 + .../double-translation/overflow.ml | 40 + .../double-translation/overflow.reference | 1 + .../lib-effects/double-translation/partial.ml | 28 + .../double-translation/partial.reference | 1 + .../double-translation/reperform.ml | 37 + .../double-translation/reperform.reference | 22 + .../lib-effects/double-translation/sched.ml | 65 ++ .../double-translation/sched.reference | 1 + .../double-translation/shallow_state.ml | 48 ++ .../shallow_state.reference | 3 + .../double-translation/shallow_state_io.ml | 51 ++ .../shallow_state_io.reference | 3 + .../lib-effects/double-translation/test1.ml | 15 + .../double-translation/test1.reference | 1 + .../lib-effects/double-translation/test10.ml | 34 + .../double-translation/test10.reference | 1 + .../lib-effects/double-translation/test11.ml | 22 + .../double-translation/test11.reference | 2 + .../lib-effects/double-translation/test2.ml | 30 + .../double-translation/test2.reference | 6 + .../lib-effects/double-translation/test3.ml | 22 + .../double-translation/test3.reference | 2 + .../lib-effects/double-translation/test4.ml | 21 + .../double-translation/test4.reference | 1 + .../lib-effects/double-translation/test5.ml | 24 + .../double-translation/test5.reference | 1 + .../lib-effects/double-translation/test6.ml | 30 + .../double-translation/test6.reference | 3 + .../double-translation/test_lazy.ml | 49 ++ .../double-translation/test_lazy.reference | 3 + .../double-translation/unhandled_unlinked.ml | 7 + .../unhandled_unlinked.reference | 1 + .../double-translation/used_cont.ml | 21 + .../double-translation/used_cont.reference | 1 + runtime/js/effect.js | 119 ++- runtime/js/jslib.js | 41 +- runtime/js/stdlib.js | 111 ++- runtime/js/stdlib_modern.js | 102 +++ 85 files changed, 4242 insertions(+), 398 deletions(-) create mode 100644 compiler/lib/lambda_lifting_simple.ml create mode 100644 compiler/lib/lambda_lifting_simple.mli create mode 100644 compiler/tests-compiler/double-translation/direct_calls.ml create mode 100644 compiler/tests-compiler/double-translation/dune create mode 100644 compiler/tests-compiler/double-translation/dune.inc create mode 100644 compiler/tests-compiler/double-translation/effects_continuations.ml create mode 100644 compiler/tests-compiler/double-translation/effects_exceptions.ml create mode 100644 compiler/tests-compiler/double-translation/effects_toplevel.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/cmphash.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/cmphash.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/dune create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/effects.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/effects.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/evenodd.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/evenodd.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/manylive.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/manylive.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/marshal.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/marshal.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/overflow.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/overflow.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/partial.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/partial.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/reperform.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/reperform.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/sched.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/sched.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/shallow_state.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/shallow_state.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test1.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test1.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test10.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test10.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test11.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test11.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test2.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test2.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test3.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test3.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test4.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test4.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test5.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test5.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test6.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test6.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test_lazy.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test_lazy.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/used_cont.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/used_cont.reference diff --git a/CHANGES.md b/CHANGES.md index 0e39ba7f9e..f3eed8c510 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -25,6 +25,7 @@ * Runtime: reimplement the runtime of weak and ephemeron (#1707) * Lib: Modify Typed_array API for compatibility with WebAssembly * Toplevel: no longer set globals for toplevel initialization +* Effects: add an optional feature of "dynamic switching" between CPS and direct style, resulting in better performance when no effect handler is installed ## Bug fixes * Runtime: fix parsing of unsigned integers (0u2147483648) (#1633, #1666) diff --git a/compiler/lib/build_info.ml b/compiler/lib/build_info.ml index 9802c9eb81..8f6dd8e79e 100644 --- a/compiler/lib/build_info.ml +++ b/compiler/lib/build_info.ml @@ -56,6 +56,7 @@ let create kind = in [ "use-js-string", string_of_bool (Config.Flag.use_js_string ()) ; "effects", string_of_bool (Config.Flag.effects ()) + ; "doubletranslate", string_of_bool (Config.Flag.double_translation ()) ; "version", version ; "kind", string_of_kind kind ] @@ -126,9 +127,10 @@ let merge fname1 info1 fname2 info2 = match k, v1, v2 with | "kind", v1, v2 -> if Option.equal String.equal v1 v2 then v1 else Some (string_of_kind `Unknown) - | ("effects" | "use-js-string" | "version"), Some v1, Some v2 + | ("effects" | "doubletranslate" | "use-js-string" | "version"), Some v1, Some v2 when String.equal v1 v2 -> Some v1 - | (("effects" | "use-js-string" | "version") as key), v1, v2 -> + | (("effects" | "doubletranslate" | "use-js-string" | "version") as key), v1, v2 + -> raise (Incompatible_build_info { key; first = fname1, v1; second = fname2, v2 }) | _, Some v1, Some v2 when String.equal v1 v2 -> Some v1 @@ -143,6 +145,7 @@ let configure t = StringMap.iter (fun k v -> match k with - | "use-js-string" | "effects" -> Config.Flag.set k (bool_of_string v) + | "use-js-string" | "effects" | "doubletranslate" -> + Config.Flag.set k (bool_of_string v) | _ -> ()) t diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index a260794262..05249533e8 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -112,6 +112,8 @@ module Var : sig val set : 'a t -> key -> 'a -> unit + val length : 'a t -> int + val make : size -> 'a -> 'a t val make_set : size -> 'a DataSet.t t @@ -227,6 +229,8 @@ end = struct let set t x v = t.(x) <- v + let length t = Array.length t + let make () v = Array.make (count ()) v let make_set () = Array.make (count ()) DataSet.Empty diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index deb487987f..e39038a8bc 100644 --- a/compiler/lib/code.mli +++ b/compiler/lib/code.mli @@ -105,6 +105,8 @@ module Var : sig val set : 'a t -> key -> 'a -> unit + val length : 'a t -> int + val make : size -> 'a -> 'a t val make_set : size -> 'a DataSet.t t diff --git a/compiler/lib/config.ml b/compiler/lib/config.ml index 29f39a1f02..a78fef98dc 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -70,6 +70,8 @@ module Flag = struct let effects = o ~name:"effects" ~default:false + let double_translation = o ~name:"doubletranslate" ~default:false + let staticeval = o ~name:"staticeval" ~default:true let share_constant = o ~name:"share" ~default:true diff --git a/compiler/lib/config.mli b/compiler/lib/config.mli index 4954602b1b..b08e4d6fe6 100644 --- a/compiler/lib/config.mli +++ b/compiler/lib/config.mli @@ -41,6 +41,8 @@ module Flag : sig val effects : unit -> bool + val double_translation : unit -> bool + val genprim : unit -> bool val strictmode : unit -> bool diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index b0580bef14..3bd3c74d11 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -112,11 +112,13 @@ let effects ~deadcode_sentinal p = Deadcode.f p else p, live_vars in - p |> Effects.f ~flow_info:info ~live_vars +> map_fst Lambda_lifting.f) + let p, trampolined_calls, in_cps = Effects.f ~flow_info:info ~live_vars p in + let p = if Config.Flag.double_translation () then p else Lambda_lifting.f p in + p, trampolined_calls, in_cps) else ( p , (Code.Var.Set.empty : Effects.trampolined_calls) - , (Code.Var.Set.empty : Effects.in_cps) ) + , (Code.Var.Set.empty : Code.Var.Set.t) ) let exact_calls profile ~deadcode_sentinal p = if not (Config.Flag.effects ()) @@ -202,7 +204,7 @@ let generate ~exported_runtime ~wrap_with_fun ~warn_on_unhandled_effect - { program; variable_uses; trampolined_calls; deadcode_sentinal; in_cps = _ } = + { program; variable_uses; trampolined_calls; deadcode_sentinal; in_cps } = if times () then Format.eprintf "Start Generation...@."; let should_export = should_export wrap_with_fun in Generate.f @@ -210,6 +212,7 @@ let generate ~exported_runtime ~live_vars:variable_uses ~trampolined_calls + ~in_cps ~should_export ~warn_on_unhandled_effect ~deadcode_sentinal diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index e7745994fd..a9c6b492cf 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -38,6 +38,11 @@ open Code let debug = Debug.find "effects" +let double_translate = Config.Flag.double_translation + +let debug_print fmt = + if debug () then Format.(eprintf (fmt ^^ "%!")) else Format.(ifprintf err_formatter fmt) + let get_edges g src = try Hashtbl.find g src with Not_found -> Addr.Set.empty let add_edge g src dst = Hashtbl.replace g src (Addr.Set.add dst (get_edges g src)) @@ -241,7 +246,9 @@ let compute_needed_transformations ~cfg ~idom ~cps_needed ~blocks ~start = dominator of the block. [closure_of_jump] provides the name of the function correspoding to each block. [closures_of_alloc_site] provides the list of functions which should be defined in a given - block. Exception handlers are dealt with separately. + block. In case of double translation, the keys are the addresses of the + original (direct-style) blocks. Exception handlers are dealt with + separately. *) type jump_closures = { closure_of_jump : Var.t Addr.Map.t @@ -278,7 +285,8 @@ type st = ; cfg : control_flow_graph ; idom : (int, int) Hashtbl.t ; jc : jump_closures - ; closure_info : (Addr.t, Var.t * Code.cont) Hashtbl.t + ; closure_info : (Addr.t, Var.t list * (Addr.t * Var.t list)) Hashtbl.t + (* Associates a function's address with its CPS parameters and CPS continuation *) ; cps_needed : Var.Set.t ; blocks_to_transform : Addr.Set.t ; is_continuation : (Addr.t, [ `Param of Var.t | `Loop ]) Hashtbl.t @@ -286,8 +294,13 @@ type st = ; block_order : (Addr.t, int) Hashtbl.t ; live_vars : Deadcode.variable_uses ; flow_info : Global_flow.info - ; trampolined_calls : trampolined_calls ref - ; in_cps : in_cps ref + ; trampolined_calls : trampolined_calls ref (* Call sites that require trampolining *) + ; in_cps : in_cps ref (* Call sites whose callee must have a CPS component *) + ; single_version_closures : Var.Set.t ref + (* Closures that never need CPS translation (lambda-lifting functions) *) + ; cps_pc_of_direct : (int, int) Hashtbl.t + (* Mapping from direct-style to CPS addresses of functions (used when + double translation is enabled) *) } let add_block st block = @@ -295,15 +308,37 @@ let add_block st block = st.new_blocks <- Addr.Map.add free_pc block blocks, free_pc + 1; free_pc +let mk_cps_pc_of_direct cps_pc_of_direct free_pc pc = + if double_translate () + then ( + try Hashtbl.find cps_pc_of_direct pc, free_pc + with Not_found -> + Hashtbl.add cps_pc_of_direct pc free_pc; + free_pc, free_pc + 1) + else pc, free_pc + +(* Provide the address of the CPS translation of a block *) +let mk_cps_pc_of_direct ~st pc = + let new_blocks, free_pc = st.new_blocks in + let cps_pc, free_pc = mk_cps_pc_of_direct st.cps_pc_of_direct free_pc pc in + st.new_blocks <- new_blocks, free_pc; + cps_pc + +let cps_cont_of_direct ~st (pc, args) = mk_cps_pc_of_direct ~st pc, args + let closure_of_pc ~st pc = try Addr.Map.find pc st.jc.closure_of_jump with Not_found -> assert false let allocate_closure ~st ~params ~body ~branch = + debug_print "@[allocate_closure ~branch:(%a)@,@]" Code.Print.last branch; let block = { params = []; body; branch } in let pc = add_block st block in let name = Var.fresh () in [ Let (name, Closure (params, (pc, []))) ], name +let mark_single_version ~st cname = + st.single_version_closures := Var.Set.add cname !(st.single_version_closures) + let tail_call ~st ?(instrs = []) ~exact ~in_cps ~check ~f args = assert (exact || check); let ret = Var.fresh () in @@ -313,7 +348,7 @@ let tail_call ~st ?(instrs = []) ~exact ~in_cps ~check ~f args = let cps_branch ~st ~src (pc, args) = match Addr.Set.mem pc st.blocks_to_transform with - | false -> [], Branch (pc, args) + | false -> [], Branch (mk_cps_pc_of_direct ~st pc, args) | true -> let args, instrs = if List.is_empty args && Hashtbl.mem st.is_continuation pc @@ -338,7 +373,7 @@ let cps_branch ~st ~src (pc, args) = let cps_jump_cont ~st ~src ((pc, _) as cont) = match Addr.Set.mem pc st.blocks_to_transform with - | false -> cont + | false -> cps_cont_of_direct ~st cont | true -> let call_block = let body, branch = cps_branch ~st ~src cont in @@ -346,7 +381,50 @@ let cps_jump_cont ~st ~src ((pc, _) as cont) = in call_block, [] -let allocate_continuation ~st ~alloc_jump_closures ~split_closures pc x cont = +let do_alloc_jump_closures ~st (to_allocate : (Var.t * Code.Addr.t) list) : instr list = + List.map to_allocate ~f:(fun (cname, jump_pc) -> + let params = + let jump_block = Addr.Map.find jump_pc st.blocks in + (* For a function to be used as a continuation, it needs + exactly one parameter. So, we add a parameter if + needed. *) + if List.is_empty jump_block.params && Hashtbl.mem st.is_continuation jump_pc + then + (* We reuse the name of the value of the tail call of + one a the previous blocks. When there is a single + previous block, this is exactly what we want. For a + merge node, the variable is not used so we can just + as well use it. For a loop, we don't want the + return value of a call right before entering the + loop to be overriden by the value returned by the + last call in the loop. So, we may need to use an + additional closure to bind it, and we have to use a + fresh variable here *) + let x = + match Hashtbl.find st.is_continuation jump_pc with + | `Param x -> x + | `Loop -> Var.fresh () + in + [ x ] + else jump_block.params + in + mark_single_version ~st cname; + let cps_jump_pc = mk_cps_pc_of_direct ~st jump_pc in + Let (cname, Closure (params, (cps_jump_pc, [])))) + +let allocate_continuation + ~st + ~alloc_jump_closures + ~split_closures + ~direct_pc + src_pc + x + cont = + debug_print + "@[allocate_continuation ~direct_pc:%d ~src_pc:%d ~cont_pc:%d@,@]" + direct_pc + src_pc + (fst cont); (* We need to allocate an additional closure if [cont] does not correspond to a continuation that binds [x]. This closure binds the return value [x], allocates @@ -355,18 +433,18 @@ let allocate_continuation ~st ~alloc_jump_closures ~split_closures pc x cont = closure to bind [x] if it is used in the loop body. In other cases, we can just pass the closure corresponding to the next block. *) - let pc', args = cont in + let _, args = cont in if (match args with | [] -> true | [ x' ] -> Var.equal x x' | _ -> false) && - match Hashtbl.find st.is_continuation pc' with + match Hashtbl.find st.is_continuation direct_pc with | `Param _ -> true | `Loop -> st.live_vars.(Var.idx x) = List.length args - then alloc_jump_closures, closure_of_pc ~st pc' + then alloc_jump_closures, closure_of_pc ~st direct_pc else - let body, branch = cps_branch ~st ~src:pc cont in + let body, branch = cps_branch ~st ~src:src_pc cont in let inner_closures, outer_closures = (* For [Pushtrap], we need to separate the closures corresponding to the exception handler body (that may make @@ -374,15 +452,18 @@ let allocate_continuation ~st ~alloc_jump_closures ~split_closures pc x cont = of the exception handler. *) if not split_closures then alloc_jump_closures, [] - else if is_merge_node st.cfg pc' + else if is_merge_node st.cfg direct_pc then [], alloc_jump_closures else - List.partition - ~f:(fun i -> - match i with - | Let (_, Closure (_, (pc'', []))) -> dominates st.cfg st.idom pc' pc'' - | _ -> assert false) - alloc_jump_closures + let to_allocate = + try Addr.Map.find src_pc st.jc.closures_of_alloc_site with Not_found -> [] + in + let inner, outer = + List.partition + ~f:(fun (_, pc'') -> dominates st.cfg st.idom direct_pc pc'') + to_allocate + in + do_alloc_jump_closures ~st inner, do_alloc_jump_closures ~st outer in let body, branch = allocate_closure ~st ~params:[ x ] ~body:(inner_closures @ body) ~branch @@ -393,7 +474,7 @@ let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last = match last with | Return x -> assert (List.is_empty alloc_jump_closures); - (* Is the number of successive 'returns' is unbounded is CPS, it + (* If the number of successive 'returns' is unbounded in CPS, it means that we have an unbounded of calls in direct style (even with tail call optimization) *) tail_call ~st ~exact:true ~in_cps:false ~check:false ~f:k [ x ] @@ -453,17 +534,23 @@ let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last = | Pushtrap (body_cont, exn, ((handler_pc, _) as handler_cont)) -> ( assert (Hashtbl.mem st.is_continuation handler_pc); match Addr.Set.mem handler_pc st.blocks_to_transform with - | false -> alloc_jump_closures, last + | false -> + let body_cont = cps_cont_of_direct ~st body_cont in + let handler_cont = cps_cont_of_direct ~st handler_cont in + let last = Pushtrap (body_cont, exn, handler_cont) in + alloc_jump_closures, last | true -> let constr_cont, exn_handler = allocate_continuation ~st ~alloc_jump_closures ~split_closures:true + ~direct_pc:handler_pc pc exn handler_cont in + mark_single_version ~st exn_handler; let push_trap = Let (Var.fresh (), Prim (Extern "caml_push_trap", [ Pv exn_handler ])) in @@ -481,63 +568,186 @@ let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last = @ (Let (exn_handler, Prim (Extern "caml_pop_trap", [])) :: body) , branch )) -let cps_instr ~st (instr : instr) : instr = +module DuplicateSt : sig + type st = Addr.t Addr.Map.t * Addr.t * block Addr.Map.t + + type 'a m = st -> st * 'a + + val return : 'a -> 'a m + + val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m + + val run : 'a m -> st -> st * 'a + + val find_or_add_pc : Addr.t -> Addr.t m + + val add_block : Addr.t -> block -> unit m + + val list_fold_left : f:('acc -> 'a -> 'acc m) -> init:'acc -> 'a list -> 'acc m + + val array_map : f:('a -> 'b m) -> 'a array -> 'b array m +end = struct + type st = Addr.t Addr.Map.t * Addr.t * block Addr.Map.t + + type 'a m = st -> st * 'a + + let return x st = st, x + + let bind f g st = + let st, a = f st in + g a st + + let ( let* ) f g st = bind f g st + + let run f st = f st + + let find_or_add_pc pc (new_pc_of_old, free_pc, new_blocks) = + try (new_pc_of_old, free_pc, new_blocks), Addr.Map.find pc new_pc_of_old + with Not_found -> + (Addr.Map.add pc free_pc new_pc_of_old, free_pc + 1, new_blocks), free_pc + + let add_block pc block (new_pc_of_old, free_pc, new_blocks) = + (new_pc_of_old, free_pc, Addr.Map.add pc block new_blocks), () + + let list_fold_left ~(f : 'acc -> 'a -> 'b m) ~(init : 'acc) (l : 'a list) (st : st) = + List.fold_left + l + ~f:(fun (st, acc) x -> + let st, acc = f acc x st in + st, acc) + ~init:(st, init) + + let array_map ~f arr st = Array.fold_left_map arr ~f:(fun st x -> f x st) ~init:st +end + +let duplicate_code ~st pc = + let rec duplicate ~blocks pc state = + Code.traverse + { fold = Code.fold_children } + (fun pc (state, ()) -> + state + |> DuplicateSt.run + (let open DuplicateSt in + let block = Addr.Map.find pc st.blocks in + (* Also duplicate nested functions *) + let* rev_new_body = + list_fold_left + block.body + ~f:(fun body_acc instr -> + match instr with + | Let (f, Closure (params, (pc', args))) -> + let* () = duplicate ~blocks pc' in + let* new_pc' = find_or_add_pc pc' in + return (Let (f, Closure (params, (new_pc', args))) :: body_acc) + | i -> return (i :: body_acc)) + ~init:[] + in + let new_body = List.rev rev_new_body in + (* Update branch targets *) + let update (pc, args) = + let* pc = find_or_add_pc pc in + return (pc, args) + in + let* branch = + match block.branch with + | (Return _ | Raise _ | Stop) as b -> return b + | Branch cont -> + let* cont = update cont in + return (Branch cont) + | Cond (x, c1, c2) -> + let* c1 = update c1 in + let* c2 = update c2 in + return (Cond (x, c1, c2)) + | Switch (x, conts) -> + let* conts = array_map conts ~f:update in + return (Switch (x, conts)) + | Pushtrap (c1, x, c2) -> + let* c1 = update c1 in + let* c2 = update c2 in + return (Pushtrap (c1, x, c2)) + | Poptrap cont -> + let* cont = update cont in + return (Poptrap cont) + in + let new_block = { block with body = new_body; branch } in + let* new_pc = find_or_add_pc pc in + let* () = add_block new_pc new_block in + return ())) + pc + blocks + (state, ()) + in + let new_blocks, free_pc = st.new_blocks in + let (new_pc_of_old, free_pc, new_blocks), () = + duplicate ~blocks:st.blocks pc (Addr.Map.empty, free_pc, new_blocks) + in + st.new_blocks <- new_blocks, free_pc; + Addr.Map.find pc new_pc_of_old + +let cps_instr ~st (instr : instr) : instr list = match instr with - | Let (x, Closure (params, (pc, _))) when Var.Set.mem x st.cps_needed -> + | Let (x, Closure (_, (pc, _))) + when Var.Set.mem x st.cps_needed && Var.Set.mem x !(st.single_version_closures) -> (* Add the continuation parameter, and change the initial block if needed *) - let k, cont = Hashtbl.find st.closure_info pc in + let cps_params, cps_cont = Hashtbl.find st.closure_info pc in + st.in_cps := Var.Set.add x !(st.in_cps); + [ Let (x, Closure (cps_params, cps_cont)) ] + | Let (x, Closure (params, ((pc, _) as cont))) + when Var.Set.mem x st.cps_needed && not (Var.Set.mem x !(st.single_version_closures)) + -> + let direct_c = Var.fork x in + let cps_c = Var.fork x in + let cps_params, cps_cont = Hashtbl.find st.closure_info pc in st.in_cps := Var.Set.add x !(st.in_cps); - Let (x, Closure (params @ [ k ], cont)) + [ Let (direct_c, Closure (params, cont)) + ; Let (cps_c, Closure (cps_params, cps_cont)) + ; Let (x, Prim (Extern "caml_cps_closure", [ Pv direct_c; Pv cps_c ])) + ] + | Let (x, Closure (params, (pc, args))) + when (not (Var.Set.mem x st.cps_needed)) + && not (Var.Set.mem x !(st.single_version_closures)) -> + (* This function definition does not need to be in CPS. However, we must + duplicate its body lest the same function body will appear twice in + the program with exactly the same variables that are bound, resulting + in double definition, which is not allowed. *) + let new_pc = duplicate_code ~st pc in + (* We leave [params] and [args] unchanged here because they will be + replaced with fresh variables in a later, global substitution pass. *) + [ Let (x, Closure (params, (new_pc, args))) ] | Let (x, Prim (Extern "caml_alloc_dummy_function", [ size; arity ])) -> ( match arity with | Pc (Int a) -> - Let - ( x - , Prim - (Extern "caml_alloc_dummy_function", [ size; Pc (Int (Targetint.succ a)) ]) - ) + [ Let + ( x + , Prim + ( Extern "caml_alloc_dummy_function" + , [ size; Pc (Int (Targetint.succ a)) ] ) ) + ] | _ -> assert false) | Let (x, Apply { f; args; _ }) when not (Var.Set.mem x st.cps_needed) -> (* At the moment, we turn into CPS any function not called with the right number of parameter *) - assert (Global_flow.exact_call st.flow_info f (List.length args)); - Let (x, Apply { f; args; exact = true }) + assert ( + (* If this function is unknown to the global flow analysis, then it was + introduced by the lambda lifting and does not require CPS *) + Var.idx f >= Var.Tbl.length st.flow_info.info_approximation + || Global_flow.exact_call st.flow_info f (List.length args)); + [ Let (x, Apply { f; args; exact = true }) ] + | Let (_, Apply { f; args = _; exact = _ }) + when Var.Set.mem f !(st.single_version_closures) -> + (* Nothing to do for single-version functions. *) + [ instr ] | Let (_, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> assert false - | _ -> instr + | _ -> [ instr ] -let cps_block ~st ~k pc block = +let cps_block ~st ~k ~lifter_functions ~orig_pc block = + debug_print "cps_block %d\n" orig_pc; + debug_print "cps pc evaluates to %d\n" (mk_cps_pc_of_direct ~st orig_pc); let alloc_jump_closures = - match Addr.Map.find pc st.jc.closures_of_alloc_site with - | to_allocate -> - List.map to_allocate ~f:(fun (cname, jump_pc) -> - let params = - let jump_block = Addr.Map.find jump_pc st.blocks in - (* For a function to be used as a continuation, it needs - exactly one parameter. So, we add a parameter if - needed. *) - if List.is_empty jump_block.params && Hashtbl.mem st.is_continuation jump_pc - then - (* We reuse the name of the value of the tail call of - one a the previous blocks. When there is a single - previous block, this is exactly what we want. For a - merge node, the variable is not used so we can just - as well use it. For a loop, we don't want the - return value of a call right before entering the - loop to be overriden by the value returned by the - last call in the loop. So, we may need to use an - additional closure to bind it, and we have to use a - fresh variable here *) - let x = - match Hashtbl.find st.is_continuation jump_pc with - | `Param x -> x - | `Loop -> Var.fresh () - in - [ x ] - else jump_block.params - in - Let (cname, Closure (params, (jump_pc, [])))) + match Addr.Map.find orig_pc st.jc.closures_of_alloc_site with + | to_allocate -> do_alloc_jump_closures ~st to_allocate | exception Not_found -> [] in @@ -556,7 +766,11 @@ let cps_block ~st ~k pc block = Some (fun ~k -> let exact = - exact || Global_flow.exact_call st.flow_info f (List.length args) + exact + (* If this function is unknown to the global flow analysis, then it was + introduced by the lambda lifting and is exact *) + || Var.idx f >= Var.Tbl.length st.flow_info.info_approximation + || 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 ]) -> @@ -580,20 +794,26 @@ let cps_block ~st ~k pc block = let rewritten_block = match block_split_last block.body, block.branch with + | Some (_, Let (_, Apply { f; args = _; exact = _ })), (Return _ | Branch _) + when Var.Set.mem f lifter_functions -> + (* No need to construct a continuation as no effect can be performed from a + lifter function *) + None | Some (body_prefix, Let (x, e)), Return ret -> Option.map (rewrite_instr x e) ~f:(fun f -> assert (List.is_empty alloc_jump_closures); assert (Var.equal x ret); let instrs, branch = f ~k in body_prefix, instrs, branch) - | Some (body_prefix, Let (x, e)), Branch cont -> + | Some (body_prefix, Let (x, e)), Branch ((direct_pc, _) as cont) -> Option.map (rewrite_instr x e) ~f:(fun f -> let constr_cont, k' = allocate_continuation ~st ~alloc_jump_closures ~split_closures:false - pc + ~direct_pc + orig_pc x cont in @@ -607,26 +827,175 @@ let cps_block ~st ~k pc block = let body, last = match rewritten_block with | Some (body_prefix, last_instrs, last) -> - List.map body_prefix ~f:(fun i -> cps_instr ~st i) @ last_instrs, last + let body_prefix = + List.map body_prefix ~f:(fun i -> cps_instr ~st i) |> List.concat + in + body_prefix @ last_instrs, last | None -> - let last_instrs, last = cps_last ~st ~alloc_jump_closures pc block.branch ~k in - let body = List.map block.body ~f:(fun i -> cps_instr ~st i) @ last_instrs in - body, last + let last_instrs, last = + cps_last ~st ~alloc_jump_closures orig_pc block.branch ~k + in + let body = List.map block.body ~f:(fun i -> cps_instr ~st i) |> List.concat in + body @ last_instrs, last in - { params = (if Addr.Set.mem pc st.blocks_to_transform then [] else block.params) + { params = (if Addr.Set.mem orig_pc st.blocks_to_transform then [] else block.params) ; body ; branch = last } -let cps_transform ~live_vars ~flow_info ~cps_needed p = +let rewrite_direct_instr ~st instr = + match instr with + | Let (x, Closure (_, (pc, _))) when Var.Set.mem x st.cps_needed -> + (* Add the continuation parameter, and change the initial block if + needed *) + let cps_params, cps_cont = Hashtbl.find st.closure_info pc in + Let (x, Closure (cps_params, cps_cont)) + | Let (x, Prim (Extern "caml_alloc_dummy_function", [ size; arity ])) -> ( + match arity with + | Pc (Int a) -> + Let + ( x + , Prim + (Extern "caml_alloc_dummy_function", [ size; Pc (Int (Targetint.succ a)) ]) + ) + | _ -> assert false) + | Let (x, Apply { f; args; _ }) when not (Var.Set.mem x st.cps_needed) -> + (* At the moment, we turn into CPS any function not called with + the right number of parameter *) + assert (Global_flow.exact_call st.flow_info f (List.length args)); + Let (x, Apply { f; args; exact = true }) + | Let (_, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> + assert false + | _ -> instr + +(* If double-translating, modify all function applications and closure + creations to take into account the fact that some closures must now have a + CPS version. Also rewrite the effect primitives to switch to the CPS version + of functions (for resume) or fail (for perform). + If not double-translating, then just add continuation arguments to function + definitions, and mark as exact all non-CPS calls. *) +let rewrite_direct_block + ~st + ~cps_needed + ~closure_info + ~ident_fn + ~pc + ~lifter_functions + block = + debug_print "@[rewrite_direct_block %d@,@]" pc; + if double_translate () + then + let rewrite_instr = function + | Let (x, Closure (params, ((pc, _) as cont))) + when Var.Set.mem x cps_needed && not (Var.Set.mem x lifter_functions) -> + let direct_c = Var.fork x in + let cps_c = Var.fork x in + let cps_params, cps_cont = Hashtbl.find closure_info pc in + [ Let (direct_c, Closure (params, cont)) + ; Let (cps_c, Closure (cps_params, cps_cont)) + ; Let (x, Prim (Extern "caml_cps_closure", [ Pv direct_c; Pv cps_c ])) + ] + | Let (x, Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg ])) -> + (* Pass the identity as a continuation and pass to + [caml_trampoline_cps], which will 1. install a trampoline, 2. call + the CPS version of [f] and 3. handle exceptions. *) + let k = Var.fresh_n "cont" in + let args = Var.fresh_n "args" in + [ Let (k, Prim (Extern "caml_resume_stack", [ Pv stack; Pv ident_fn ])) + ; Let (args, Prim (Extern "%js_array", [ Pv arg; Pv k ])) + ; Let (x, Prim (Extern "caml_trampoline_cps", [ Pv f; Pv args ])) + ] + | Let (x, Prim (Extern "%perform", [ Pv effect ])) -> + (* Perform the effect, which should call the "Unhandled effect" handler. *) + let k = Int Targetint.zero in + (* Dummy continuation *) + [ Let + ( x + , Prim + ( Extern "caml_perform_effect" + , [ Pv effect; Pc (Int Targetint.zero); Pc k ] ) ) + ] + | Let (x, Prim (Extern "%reperform", [ Pv effect; Pv continuation ])) -> + (* Similar to previous case *) + let k = Int Targetint.zero in + [ Let + ( x + , Prim (Extern "caml_perform_effect", [ Pv effect; Pv continuation; Pc k ]) + ) + ] + | (Let _ | Assign _ | Set_field _ | Offset_ref _ | Array_set _ | Event _) as instr + -> [ instr ] + in + let body = List.concat_map block.body ~f:(fun i -> rewrite_instr i) in + { block with body } + else { block with body = List.map ~f:(rewrite_direct_instr ~st) block.body } + +(* Apply a substitution in a set of blocks *) +let subst_in_blocks blocks s = + Addr.Map.mapi + (fun pc block -> + if debug () + then ( + debug_print "@[block before first subst: @,"; + Code.Print.block (fun _ _ -> "") pc block; + debug_print "@]"); + let res = Subst.Excluding_Binders.block s block in + if debug () + then ( + debug_print "@[block after first subst: @,"; + Code.Print.block (fun _ _ -> "") pc res; + debug_print "@]"); + res) + blocks + +(* Apply a substitution in a set of blocks, including to bound variables *) +let subst_bound_in_blocks blocks s = + Addr.Map.mapi + (fun pc block -> + if debug () + then ( + debug_print "@[block before first subst: @,"; + Code.Print.block (fun _ _ -> "") pc block; + debug_print "@]"); + let res = Subst.Including_Binders.block s block in + if debug () + then ( + debug_print "@[block after first subst: @,"; + Code.Print.block (fun _ _ -> "") pc res; + debug_print "@]"); + res) + blocks + +let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = + (* Define an identity function, needed for the boilerplate around "resume" *) + let ident_fn = Var.fresh_n "identity" in let closure_info = Hashtbl.create 16 in let trampolined_calls = ref Var.Set.empty in let in_cps = ref Var.Set.empty in - let p = + let single_version_closures = + ref + (if double_translate () + then lifter_functions + else + Code.fold_closures + p + (fun name _ _ acc -> + match name with + | None -> acc + | Some name -> Var.Set.add name acc) + Var.Set.empty) + in + let cps_pc_of_direct = Hashtbl.create 512 in + let p, bound_subst, param_subst, new_blocks = Code.fold_closures_innermost_first p - (fun name_opt _ (start, args) ({ blocks; free_pc; _ } as p) -> + (fun name_opt + params + (start, args) + (({ blocks; free_pc; _ } as p), bound_subst, param_subst, new_blocks) -> + Option.iter name_opt ~f:(fun v -> + debug_print "@[cname = %s@,@]" @@ Var.to_string v); (* We speculatively add a block at the beginning of the function. In case of tail-recursion optimization, the function implementing the loop body may have to be placed @@ -645,9 +1014,10 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = match name_opt with | Some name -> Var.Set.mem name cps_needed | None -> - (* We are handling the toplevel code. There may remain - some CPS calls at toplevel. *) - true + (* We need to handle the CPS calls that are at toplevel, except + if we double-translate (in which case they are like all other + CPS calls from direct code). *) + not (double_translate ()) in let blocks_to_transform, matching_exn_handler, is_continuation = if should_compute_needed_transformations @@ -663,7 +1033,8 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = let closure_jc = jump_closures blocks_to_transform idom in let start, args, blocks, free_pc = (* Insert an initial block if needed. *) - if Addr.Map.mem start' closure_jc.closures_of_alloc_site + if should_compute_needed_transformations + && Addr.Map.mem start' closure_jc.closures_of_alloc_site then start', [], blocks', free_pc + 1 else start, args, blocks, free_pc in @@ -683,16 +1054,21 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = ; live_vars ; trampolined_calls ; in_cps + ; cps_pc_of_direct + ; single_version_closures } in let function_needs_cps = match name_opt with - | Some _ -> should_compute_needed_transformations + | Some name -> + should_compute_needed_transformations + && not (Var.Set.mem name lifter_functions) | None -> - (* We are handling the toplevel code. If it performs no - CPS call, we can leave it in direct style and we - don't need to wrap it within a [caml_callback]. *) - not (Addr.Set.is_empty blocks_to_transform) + (* Toplevel code: if we double-translate, no need to handle it + specially: CPS calls in it are like all other CPS calls from + direct code. Otherwise, it needs to wrapped within a + [caml_callback], but only if it performs CPS calls. *) + (not (double_translate ())) && not (Addr.Set.is_empty blocks_to_transform) in if debug () then ( @@ -709,55 +1085,192 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = start blocks ()); - let blocks = - let transform_block = - if function_needs_cps + let blocks, free_pc, bound_subst, param_subst, new_blocks = + (* For every block in the closure, + 1. CPS-translate it if needed. If we double-translate, add its CPS + translation to the block map at a fresh address. Otherwise, + just replace the original block. + 2. If we double-translate, keep the direct-style block but modify function + definitions to add the CPS version where needed, and turn uses of %resume + and %perform into switchings to CPS. *) + let param_subst, transform_block = + if function_needs_cps && double_translate () + then ( + let k = Var.fresh_n "cont" in + let cps_start = mk_cps_pc_of_direct ~st start in + let params' = List.map ~f:Var.fork params in + let param_subst = + List.fold_left2 + ~f:(fun m p p' -> Var.Map.add p p' m) + ~init:param_subst + params + params' + in + let cps_args = List.map ~f:(Subst.from_map param_subst) args in + Hashtbl.add + st.closure_info + initial_start + (params' @ [ k ], (cps_start, cps_args)); + ( param_subst + , fun pc block -> + let cps_block = cps_block ~st ~lifter_functions ~k ~orig_pc:pc block in + ( rewrite_direct_block + ~st + ~cps_needed + ~closure_info:st.closure_info + ~ident_fn + ~pc + ~lifter_functions + block + , Some cps_block ) )) + else if function_needs_cps && not (double_translate ()) then ( let k = Var.fresh_n "cont" in - Hashtbl.add closure_info initial_start (k, (start, args)); - fun pc block -> cps_block ~st ~k pc block) + Hashtbl.add st.closure_info initial_start (params @ [ k ], (start, args)); + ( param_subst + , fun pc block -> cps_block ~st ~lifter_functions ~k ~orig_pc:pc block, None + )) else - fun _ block -> - { block with body = List.map block.body ~f:(fun i -> cps_instr ~st i) } + ( param_subst + , fun pc block -> + ( rewrite_direct_block + ~st + ~cps_needed + ~closure_info:st.closure_info + ~ident_fn + ~pc + ~lifter_functions + block + , None ) ) in - Code.traverse - { fold = Code.fold_children } - (fun pc blocks -> - Addr.Map.add pc (transform_block pc (Addr.Map.find pc blocks)) blocks) - start - st.blocks - st.blocks + let blocks = + Code.traverse + { fold = Code.fold_children } + (fun pc blocks -> + let block, cps_block_opt = transform_block pc (Addr.Map.find pc blocks) in + let blocks = Addr.Map.add pc block blocks in + match cps_block_opt with + | None -> blocks + | Some b -> + let cps_pc = mk_cps_pc_of_direct ~st pc in + let new_blocks, free_pc = st.new_blocks in + st.new_blocks <- Addr.Map.add cps_pc b new_blocks, free_pc; + Addr.Map.add cps_pc b blocks) + start + st.blocks + st.blocks + in + let new_blocks_this_clos, free_pc = st.new_blocks in + (* If double-translating, all variables bound in the CPS version will have to be + subst with fresh ones to avoid clashing with the definitions in the original + blocks (the actual substitution is done later). *) + let bound_subst = + if double_translate () + then + let bound = + Addr.Map.fold + (fun _ block bound -> + Var.Set.union + bound + (Freevars.block_bound_vars ~closure_params:true block)) + new_blocks_this_clos + Var.Set.empty + in + Var.Set.fold (fun v m -> Var.Map.add v (Var.fork v) m) bound bound_subst + else bound_subst + in + let blocks = Addr.Map.fold Addr.Map.add new_blocks_this_clos blocks in + ( blocks + , free_pc + , bound_subst + , param_subst + , Addr.Map.union (fun _ _ -> assert false) new_blocks new_blocks_this_clos ) in - let new_blocks, free_pc = st.new_blocks in - let blocks = Addr.Map.fold Addr.Map.add new_blocks blocks in - { p with blocks; free_pc }) - p + { p with blocks; free_pc }, bound_subst, param_subst, new_blocks) + (p, Var.Map.empty, Var.Map.empty, Addr.Map.empty) in + let bound_subst = Subst.from_map bound_subst in + let new_blocks = subst_bound_in_blocks new_blocks bound_subst in + (* Also apply that substitution to the sets of trampolined calls, + single-version closures and cps call sites *) + trampolined_calls := Var.Set.map bound_subst !trampolined_calls; + single_version_closures := Var.Set.map bound_subst !single_version_closures; + in_cps := Var.Set.map bound_subst !in_cps; + (* All variables that were a closure parameter in a direct-style block must be + substituted by a fresh name. *) + let param_subst = Subst.from_map param_subst in + let new_blocks = subst_in_blocks new_blocks param_subst in + (* Also apply that 2nd substitution to the sets of trampolined calls, + single-version closures and cps call sites *) + trampolined_calls := Var.Set.map param_subst !trampolined_calls; + single_version_closures := Var.Set.map param_subst !single_version_closures; + in_cps := Var.Set.map param_subst !in_cps; let p = - match Hashtbl.find_opt closure_info p.start with - | None -> p - | Some (k, _) -> - (* Call [caml_callback] to set up the execution context. *) - let new_start = p.free_pc in - let blocks = - let main = Var.fresh () in - let args = Var.fresh () in - let res = Var.fresh () in - Addr.Map.add - new_start - { params = [] - ; body = - [ Let (main, Closure ([ k ], (p.start, []))) - ; Let (args, Prim (Extern "%js_array", [])) - ; Let (res, Prim (Extern "caml_callback", [ Pv main; Pv args ])) - ] - ; branch = Return res - } - p.blocks - in - { start = new_start; blocks; free_pc = new_start + 1 } + { p with + blocks = + Addr.Map.merge + (fun _ a b -> + match a, b with + | _, Some b -> Some b + | a, None -> a) + p.blocks + new_blocks + } + in + let p = + 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 } + 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 ]))) + ; Let (dummy, Prim (Extern "caml_initialize_fiber_stack", [])) + ] + ; branch = Branch (p.start, []) + } + blocks + in + { start = new_start; blocks; free_pc = new_start + 1 } + else + match Hashtbl.find_opt closure_info p.start with + | None -> p + | Some (cps_params, cps_cont) -> + (* Call [caml_callback] to set up the execution context. *) + let new_start = p.free_pc in + let blocks = + let main = Var.fresh () in + let args = Var.fresh () in + let res = Var.fresh () in + Addr.Map.add + new_start + { params = [] + ; body = + [ Let (main, Closure (cps_params, cps_cont)) + ; Let (args, Prim (Extern "%js_array", [])) + ; Let (res, Prim (Extern "caml_callback", [ Pv main; Pv args ])) + ] + ; branch = Return res + } + p.blocks + in + { start = new_start; blocks; free_pc = new_start + 1 } in - p, !trampolined_calls, !in_cps + p, !trampolined_calls, !in_cps, !single_version_closures (****) @@ -842,13 +1355,13 @@ let rewrite_toplevel ~cps_needed p = (****) -let split_blocks ~cps_needed (p : Code.program) = +let split_blocks ~cps_needed ~lifter_functions (p : Code.program) = (* Ensure that function applications and effect primitives are in tail position *) let split_block pc block p = let is_split_point i r branch = match i with - | Let (x, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> + | Let (x, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> ( ((not (empty_body r)) || match branch with @@ -856,6 +1369,11 @@ let split_blocks ~cps_needed (p : Code.program) = | Return x' -> not (Var.equal x x') | _ -> true) && Var.Set.mem x cps_needed + && + match i with + | Let (_, Apply { f; args = _; exact = _ }) -> + not (Var.Set.mem f lifter_functions) + | _ -> true) | _ -> false in let rec split (p : Code.program) pc block accu l branch = @@ -941,9 +1459,40 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program = let f ~flow_info ~live_vars p = let t = Timer.make () in let cps_needed = Partial_cps_analysis.f p flow_info in - let p, cps_needed = rewrite_toplevel ~cps_needed p in - let p = split_blocks ~cps_needed p in - let p, trampolined_calls, in_cps = cps_transform ~live_vars ~flow_info ~cps_needed p in + let p, lifter_functions, cps_needed = + if double_translate () + then ( + let p, lifter_functions, liftings = Lambda_lifting_simple.f ~to_lift:cps_needed p in + let cps_needed = + Var.Set.map + (fun f -> try Subst.from_map liftings f with Not_found -> f) + cps_needed + in + if debug () + then ( + debug_print "@[Lifting closures:@,"; + lifter_functions |> Var.Set.iter (fun v -> debug_print "%s,@ " (Var.to_string v)); + debug_print "@]"; + debug_print "@[cps_needed (after lifting) = @["; + Var.Set.iter (fun v -> debug_print "%s,@ " (Var.to_string v)) cps_needed; + debug_print "@]@,@]"; + debug_print "@[After lambda lifting...@,"; + Code.Print.program (fun _ _ -> "") p; + debug_print "@]"); + p, lifter_functions, cps_needed) + else + let p, cps_needed = rewrite_toplevel ~cps_needed p in + p, Var.Set.empty, cps_needed + in + let p = split_blocks ~cps_needed ~lifter_functions p in + let p, trampolined_calls, in_cps, (* TODO remove? *) _single_version_closures = + cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p + in if Debug.find "times" () then Format.eprintf " effects: %a@." Timer.print t; Code.invariant p; + if debug () + then ( + debug_print "@[After CPS transform:@,"; + Code.Print.program (fun _ _ -> "") p; + debug_print "@]"); p, trampolined_calls, in_cps diff --git a/compiler/lib/effects.mli b/compiler/lib/effects.mli index c32df662ee..b4e499cd99 100644 --- a/compiler/lib/effects.mli +++ b/compiler/lib/effects.mli @@ -27,3 +27,14 @@ val f : -> live_vars:Deadcode.variable_uses -> Code.program -> Code.program * trampolined_calls * in_cps +(** Perform a partial CPS transform in order to translate a program that uses effect + handler primitives to a program with only function calls, preserving the semantics. + + In addition, if the [doubletranslate] feature is enabled, some functions are defined + in two versions (direct-style and CPS) and the generated program switches to CPS + versions when entering the first effect handler, and back to direct style when exiting + it. In addition to this dynamic behavior, the transform performs a static analysis to + detect which functions do not need to be CPS-transformed. As a consequence, some + functions become pairs of functions while others remain in a single version. This + functions returns the set of call sites that require trampolining, as well as the set + of call sites that require the callee to be a pair with a CPS component. *) diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 21712fd03e..e91b61b04a 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -487,7 +487,7 @@ let f ?skip_param p = } in let s = build_subst info vars in - let p = Subst.program (Subst.from_array s) p in + let p = Subst.Excluding_Binders.program (Subst.from_array s) p in if times () then Format.eprintf " flow analysis 5: %a@." Timer.print t5; if times () then Format.eprintf " flow analysis: %a@." Timer.print t; Code.invariant p; diff --git a/compiler/lib/freevars.ml b/compiler/lib/freevars.ml index d377370d88..f2c13ed969 100644 --- a/compiler/lib/freevars.ml +++ b/compiler/lib/freevars.ml @@ -77,8 +77,11 @@ let iter_block_free_vars f block = List.iter block.body ~f:(fun i -> iter_instr_free_vars f i); iter_last_free_var f block.branch -let iter_instr_bound_vars f i = +let iter_instr_bound_vars ?(closure_params = false) f i = match i with + | Let (x, Closure (params, _)) when closure_params -> + f x; + List.iter ~f params | Let (x, _) -> f x | Event _ | Set_field _ | Offset_ref _ | Array_set _ | Assign _ -> () @@ -87,11 +90,17 @@ let iter_last_bound_vars f l = | Return _ | Raise _ | Stop | Branch _ | Cond _ | Switch _ | Poptrap _ -> () | Pushtrap (_, x, _) -> f x -let iter_block_bound_vars f block = +let iter_block_bound_vars ?(closure_params = false) f block = List.iter ~f block.params; - List.iter block.body ~f:(fun i -> iter_instr_bound_vars f i); + List.iter block.body ~f:(fun i -> iter_instr_bound_vars ~closure_params f i); iter_last_bound_vars f block.branch +let block_bound_vars ?(closure_params = false) block = + let open Code.Var.Set in + let bound = ref empty in + iter_block_bound_vars ~closure_params (fun var -> bound := add var !bound) block; + !bound + (****) type st = diff --git a/compiler/lib/freevars.mli b/compiler/lib/freevars.mli index ef07c7540e..bc28735e67 100644 --- a/compiler/lib/freevars.mli +++ b/compiler/lib/freevars.mli @@ -21,7 +21,16 @@ open! Stdlib val iter_block_free_vars : (Code.Var.t -> unit) -> Code.block -> unit -val iter_block_bound_vars : (Code.Var.t -> unit) -> Code.block -> unit +val iter_block_bound_vars : + ?closure_params:bool -> (Code.Var.t -> unit) -> Code.block -> unit +(** Iterate on the variables bound in a block (let-bound identifiers and block + parameters). If [closure_params] is [true] (by default, it is [false]), + these variables include the parameters of closures created in the block. *) + +val block_bound_vars : ?closure_params:bool -> Code.block -> Code.Var.Set.t +(** Computes the set of variables that are bound in a block. If + [closure_params] is [true] (by default, it is [false]), these variables + include the parameters of closures created in the block. *) val iter_instr_free_vars : (Code.Var.t -> unit) -> Code.instr -> unit diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 7784206d67..906d8bf440 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -56,6 +56,7 @@ type application_description = { arity : int ; exact : bool ; trampolined : bool + ; in_cps : bool } module Share = struct @@ -134,6 +135,7 @@ module Share = struct let get ~trampolined_calls + ~in_cps ?alias_strings ?(alias_prims = false) ?(alias_apply = true) @@ -151,8 +153,12 @@ module Share = struct | Let (_, Constant c) -> get_constant c share | Let (x, Apply { args; exact; _ }) -> let trampolined = Var.Set.mem x trampolined_calls in + let in_cps = Var.Set.mem x in_cps in if (not exact) || trampolined - then add_apply { arity = List.length args; exact; trampolined } share + then + add_apply + { arity = List.length args; exact; trampolined; in_cps } + share else share | Let (_, Special (Alias_prim name)) -> let name = Primitive.resolve name in @@ -244,15 +250,20 @@ module Share = struct try J.EVar (AppMap.find desc t.vars.applies) with Not_found -> let x = - let { arity; exact; trampolined } = desc in + let { arity; exact; trampolined; in_cps } = desc in Var.fresh_n (Printf.sprintf "caml_%scall%d" - (match exact, trampolined with - | true, false -> assert false - | true, true -> "cps_exact_" - | false, false -> "" - | false, true -> "cps_") + (match exact, trampolined, in_cps with + | true, false, false -> assert false (* inlined *) + | true, false, true -> "exact_cps_" + | true, true, false -> "exact_trampoline_" + | false, false, true -> + assert false (* CPS functions are always trampolined *) + | false, false, false -> "" + | false, true, false -> "trampoline_" + | false, true, true -> "trampoline_cps_" + | true, true, true -> "exact_trampoline_cps_") arity) in let v = J.V x in @@ -273,6 +284,7 @@ module Ctx = struct ; deadcode_sentinal : Var.t ; mutated_vars : Code.Var.Set.t Code.Addr.Map.t ; freevars : Code.Var.Set.t Code.Addr.Map.t + ; in_cps : Effects.in_cps } let initial @@ -282,6 +294,7 @@ module Ctx = struct ~deadcode_sentinal ~mutated_vars ~freevars + ~in_cps blocks live trampolined_calls @@ -298,6 +311,7 @@ module Ctx = struct ; deadcode_sentinal ; mutated_vars ; freevars + ; in_cps } end @@ -892,49 +906,74 @@ let parallel_renaming loc back_edge params args continuation queue = (****) -let apply_fun_raw ctx f params exact trampolined loc = - let n = List.length params in - let apply_directly = - (* Make sure we are performing a regular call, not a (slower) - method call *) - match f with - | J.EAccess _ | J.EDot _ -> - J.call (J.dot f (Utf8_string.of_string_exn "call")) (s_var "null" :: params) loc - | _ -> J.call f params loc - in - let apply = - (* We skip the arity check when we know that we have the right - number of parameters, since this test is expensive. *) - if exact - then apply_directly - else - let l = Utf8_string.of_string_exn "l" in +let apply_fun_raw = + let cps_field = Utf8_string.of_string_exn "cps" in + fun ctx f params exact trampolined cps loc -> + let n = List.length params in + let apply_directly f params = + (* Make sure we are performing a regular call, not a (slower) + method call *) + match f with + | J.EAccess _ | J.EDot _ -> + J.call (J.dot f (Utf8_string.of_string_exn "call")) (s_var "null" :: params) loc + | _ -> J.call f params loc + in + let apply = + (* Adapt if [f] is a (direct-style, CPS) closure pair *) + let real_closure = + if not (Config.Flag.effects () && Config.Flag.double_translation () && cps) + then f + else + (* Effects enabled, CPS version, not single-version *) + J.EDot (f, J.ANormal, cps_field) + in + (* We skip the arity check when we know that we have the right + number of parameters, since this test is expensive. *) + if exact + then apply_directly real_closure params + else + let l = Utf8_string.of_string_exn "l" in + J.ECond + ( J.EBin + ( J.EqEqEq + , J.ECond + ( J.EBin (J.Ge, J.dot real_closure l, int 0) + , J.dot real_closure l + , J.EBin + ( J.Eq + , J.dot real_closure l + , J.dot real_closure (Utf8_string.of_string_exn "length") ) ) + , int n ) + , apply_directly real_closure params + , J.call + (* Note: when double translation is enabled, [caml_call_gen*] functions takes a two-version function *) + (runtime_fun + ctx + (if cps && Config.Flag.double_translation () + then "caml_call_gen_cps" + else "caml_call_gen")) + [ f; J.array params ] + J.N ) + in + if trampolined + then ( + assert (Config.Flag.effects ()); + (* When supporting effect, we systematically perform tailcall + optimization. To implement it, we check the stack depth and + bounce to a trampoline if needed, to avoid a stack overflow. + The trampoline then performs the call in an shorter stack. *) + let f = + if Config.Flag.double_translation () && not cps + then J.(EObj [ Property (PNS cps_field, f) ]) + else f + in J.ECond - ( J.EBin - ( J.EqEqEq - , J.ECond - ( J.EBin (J.Ge, J.dot f l, int 0) - , J.dot f l - , J.EBin (J.Eq, J.dot f l, J.dot f (Utf8_string.of_string_exn "length")) - ) - , int n ) - , apply_directly - , J.call (runtime_fun ctx "caml_call_gen") [ f; J.array params ] loc ) - in - if trampolined - then ( - assert (Config.Flag.effects ()); - (* When supporting effect, we systematically perform tailcall - optimization. To implement it, we check the stack depth and - bounce to a trampoline if needed, to avoid a stack overflow. - The trampoline then performs the call in an shorter stack. *) - J.ECond - ( J.call (runtime_fun ctx "caml_stack_check_depth") [] loc - , apply - , J.call (runtime_fun ctx "caml_trampoline_return") [ f; J.array params ] loc )) - else apply - -let generate_apply_fun ctx { arity; exact; trampolined } = + ( J.call (runtime_fun ctx "caml_stack_check_depth") [] loc + , apply + , J.call (runtime_fun ctx "caml_trampoline_return") [ f; J.array params ] loc )) + else apply + +let generate_apply_fun ctx { arity; exact; trampolined; in_cps } = let f' = Var.fresh_n "f" in let f = J.V f' in let params = @@ -950,12 +989,12 @@ let generate_apply_fun ctx { arity; exact; trampolined } = , J.fun_ (f :: params) [ ( J.Return_statement - (Some (apply_fun_raw ctx f' params' exact trampolined J.N), J.N) + (Some (apply_fun_raw ctx f' params' exact trampolined in_cps J.N), J.N) , J.N ) ] J.N ) -let apply_fun ctx f params exact trampolined loc = +let apply_fun ctx f params exact trampolined in_cps loc = (* We always go through an intermediate function when doing CPS calls. This function first checks the stack depth to prevent a stack overflow. This makes the code smaller than inlining @@ -963,12 +1002,12 @@ let apply_fun ctx f params exact trampolined loc = since the function should get inlined by the JavaScript engines. *) if Config.Flag.inline_callgen () || (exact && not trampolined) - then apply_fun_raw ctx f params exact trampolined loc + then apply_fun_raw ctx f params exact trampolined in_cps loc else let y = Share.get_apply (generate_apply_fun ctx) - { arity = List.length params; exact; trampolined } + { arity = List.length params; exact; trampolined; in_cps } ctx.Ctx.share in J.call y (f :: params) loc @@ -1185,9 +1224,10 @@ let rec translate_expr ctx loc x e level : (_ * J.statement_list) Expr_builder.t let trampolined = Var.Set.mem x ctx.Ctx.trampolined_calls in let args = remove_unused_tail_args ctx exact trampolined args in let* () = info ~need_loc:true mutator_p in + let in_cps = Var.Set.mem x ctx.Ctx.in_cps in let* args = list_map access args in let* f = access f in - return (apply_fun ctx f args exact trampolined loc, []) + return (apply_fun ctx f args exact trampolined in_cps loc, []) | Block (tag, a, array_or_not, _mut) -> let* contents = list_map @@ -1561,7 +1601,8 @@ and translate_instrs_rev (ctx : Ctx.t) loc expr_queue instrs acc_rev muts_map = List.fold_left pcs ~init:(ctx.blocks, Addr.Set.empty) - ~f:(fun (blocks, visited) pc -> Subst.cont' subst pc blocks visited) + ~f:(fun (blocks, visited) pc -> + Subst.Excluding_Binders.cont' subst pc blocks visited) in { ctx with blocks = p } in @@ -2104,12 +2145,13 @@ let f ~exported_runtime ~live_vars ~trampolined_calls + ~in_cps ~should_export ~warn_on_unhandled_effect ~deadcode_sentinal debug = let t' = Timer.make () in - let share = Share.get ~trampolined_calls ~alias_prims:exported_runtime p in + let share = Share.get ~trampolined_calls ~in_cps ~alias_prims:exported_runtime p in let exported_runtime = if exported_runtime then Some (Code.Var.fresh_n "runtime", ref false) else None in @@ -2123,6 +2165,7 @@ let f ~deadcode_sentinal ~mutated_vars ~freevars + ~in_cps p.blocks live_vars trampolined_calls diff --git a/compiler/lib/generate.mli b/compiler/lib/generate.mli index 453cc2f445..cf6d6983ab 100644 --- a/compiler/lib/generate.mli +++ b/compiler/lib/generate.mli @@ -23,6 +23,7 @@ val f : -> exported_runtime:bool -> live_vars:Deadcode.variable_uses -> trampolined_calls:Effects.trampolined_calls + -> in_cps:Effects.in_cps -> should_export:bool -> warn_on_unhandled_effect:bool -> deadcode_sentinal:Code.Var.t diff --git a/compiler/lib/lambda_lifting.ml b/compiler/lib/lambda_lifting.ml index b14ef61dd3..e37843c4bd 100644 --- a/compiler/lib/lambda_lifting.ml +++ b/compiler/lib/lambda_lifting.ml @@ -174,7 +174,9 @@ let rec traverse var_depth (program, functions) pc depth limit = free_vars Var.Map.empty in - let program = Subst.cont (Subst.from_map s) pc' program in + let program = + Subst.Excluding_Binders.cont (Subst.from_map s) pc' program + in let f' = try Var.Map.find f s with Not_found -> Var.fork f in let s = Var.Map.bindings (Var.Map.remove f s) in let f'' = Var.fork f in diff --git a/compiler/lib/lambda_lifting_simple.ml b/compiler/lib/lambda_lifting_simple.ml new file mode 100644 index 0000000000..78b4a2d84d --- /dev/null +++ b/compiler/lib/lambda_lifting_simple.ml @@ -0,0 +1,344 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open! Stdlib +open Code + +let debug = Debug.find "lifting_simple" + +let baseline = 0 (* Depth to which the functions are lifted *) + +let rec compute_depth program pc = + Code.preorder_traverse + { fold = Code.fold_children } + (fun pc d -> + let block = Code.Addr.Map.find pc program.blocks in + List.fold_left block.body ~init:d ~f:(fun d i -> + match i with + | Let (_, Closure (_, (pc', _))) -> + let d' = compute_depth program pc' in + max d (d' + 1) + | _ -> d)) + pc + program.blocks + 0 + +let collect_free_vars program var_depth depth pc = + let vars = ref Var.Set.empty in + let rec traverse pc = + Code.preorder_traverse + { fold = Code.fold_children } + (fun pc () -> + let block = Code.Addr.Map.find pc program.blocks in + Freevars.iter_block_free_vars + (fun x -> + let idx = Var.idx x in + if idx < Array.length var_depth + then ( + let d = var_depth.(idx) in + assert (d >= 0); + if d > baseline && d < depth then vars := Var.Set.add x !vars)) + block; + List.iter block.body ~f:(fun i -> + match i with + | Let (_, Closure (_, (pc', _))) -> traverse pc' + | _ -> ())) + pc + program.blocks + () + in + traverse pc; + !vars + +let mark_bound_variables var_depth block depth = + Freevars.iter_block_bound_vars + (fun x -> + let idx = Var.idx x in + if idx < Array.length var_depth then var_depth.(idx) <- depth) + block; + List.iter block.body ~f:(fun i -> + match i with + | Let (_, Closure (params, _)) -> + List.iter params ~f:(fun x -> var_depth.(Var.idx x) <- depth + 1) + | _ -> ()) + +let rec traverse ~to_lift var_depth (program, (functions : instr list), lifters) pc depth + : _ * _ * (Var.Set.t * Var.t Var.Map.t) = + Code.preorder_traverse + { fold = Code.fold_children } + (fun pc (program, functions, lifters) -> + let block = Code.Addr.Map.find pc program.blocks in + mark_bound_variables var_depth block depth; + if depth = 0 + then ( + assert (List.is_empty functions); + let program, body, lifters' = + List.fold_right + block.body + ~init:(program, [], (Var.Set.empty, Var.Map.empty)) + ~f:(fun i (program, rem, lifters) -> + match i with + | Let (_, Closure (_, (pc', _))) as i -> + let program, functions, lifters = + traverse ~to_lift var_depth (program, [], lifters) pc' (depth + 1) + in + program, List.rev_append functions (i :: rem), lifters + | i -> program, i :: rem, lifters) + in + ( { program with blocks = Addr.Map.add pc { block with body } program.blocks } + , [] + , ( Var.Set.union (fst lifters) (fst lifters') + , Var.Map.union (fun _ _ -> assert false) (snd lifters) (snd lifters') ) )) + else + (* We lift possibly mutually recursive closures (that are created by + contiguous statements) together. Isolated closures are lambda-lifted + normally. *) + let does_not_start_with_closure l = + match l with + | Let (_, Closure _) :: _ -> false + | _ -> true + in + let rec rewrite_body + current_contiguous + (st : Code.program * instr list * (Var.Set.t * Var.t Var.Map.t)) + l = + match l with + | Let (f, (Closure (_, (pc', _)) as cl)) :: rem + when List.is_empty current_contiguous + && Var.Set.mem f to_lift + && does_not_start_with_closure rem -> + (* We lift an isolated closure *) + if debug () + then Format.eprintf "@[lifting isolated closure %s@,@]" (Var.to_string f); + let program, functions, lifters = + traverse ~to_lift var_depth st pc' (depth + 1) + in + let free_vars = collect_free_vars program var_depth (depth + 1) pc' in + if debug () + then ( + Format.eprintf "@[free variables:@,"; + free_vars + |> Var.Set.iter (fun v -> Format.eprintf "%s,@ " (Var.to_string v)); + Format.eprintf "@]"); + let s = + Var.Set.fold + (fun x m -> Var.Map.add x (Var.fork x) m) + free_vars + Var.Map.empty + in + let program = Subst.Excluding_Binders.cont (Subst.from_map s) pc' program in + let f' = try Var.Map.find f s with Not_found -> Var.fork f in + let s = Var.Map.bindings (Var.Map.remove f s) in + let f'' = Var.fork f in + if debug () + then + Format.eprintf + "LIFT %s (depth:%d free_vars:%d inner_depth:%d)@." + (Code.Var.to_string f'') + depth + (Var.Set.cardinal free_vars) + (compute_depth program pc'); + let pc'' = program.free_pc in + let bl = { params = []; body = [ Let (f', cl) ]; branch = Return f' } in + let program = + { program with + free_pc = pc'' + 1 + ; blocks = Addr.Map.add pc'' bl program.blocks + } + in + let functions = + Let (f'', Closure (List.map s ~f:snd, (pc'', []))) :: functions + in + let lifters = + Var.Set.add f'' (fst lifters), Var.Map.add f f' (snd lifters) + in + let rem', st = rewrite_body [] (program, functions, lifters) rem in + ( Let (f, Apply { f = f''; args = List.map ~f:fst s; exact = true }) :: rem' + , st ) + | Let (cname, Closure (params, (pc', args))) :: rem -> + let st = traverse ~to_lift var_depth st pc' (depth + 1) in + rewrite_body ((cname, params, pc', args) :: current_contiguous) st rem + | l -> ( + assert ( + match current_contiguous with + | [ (f, _, _, _) ] -> not (Var.Set.mem f to_lift) + | _ -> true); + match current_contiguous with + | [] -> ( + match l with + | i :: rem -> + let rem', st = rewrite_body [] st rem in + i :: rem', st + | [] -> [], st) + | _ + when List.exists + ~f:(fun (f, _, _, _) -> Var.Set.mem f to_lift) + current_contiguous -> + let program, functions, lifters = + (if debug () + then + Format.( + eprintf + "@[Need to lift:@,%a@,@]" + (pp_print_list ~pp_sep:pp_print_space pp_print_string) + (List.map + ~f:(fun (f, _, _, _) -> Code.Var.to_string f) + current_contiguous))); + List.fold_left + current_contiguous + ~f:(fun st (_, _, pc, _) -> + traverse ~to_lift var_depth st pc (depth + 1)) + ~init:st + in + let free_vars = + List.fold_left + current_contiguous + ~f:(fun acc (_, _, pc, _) -> + Var.Set.union acc + @@ collect_free_vars program var_depth (depth + 1) pc) + ~init:Var.Set.empty + in + let s = + Var.Set.fold + (fun x m -> Var.Map.add x (Var.fork x) m) + free_vars + Var.Map.empty + in + let program = + List.fold_left + current_contiguous + ~f:(fun program (_, _, pc, _) -> + Subst.Excluding_Binders.cont (Subst.from_map s) pc program) + ~init:program + in + let f's = + List.map current_contiguous ~f:(fun (f, _, _, _) -> + Var.(try Map.find f s with Not_found -> fork f)) + in + let s = + List.fold_left + current_contiguous + ~f:(fun s (f, _, _, _) -> Var.Map.remove f s) + ~init:s + |> Var.Map.bindings + in + let f_tuple = Var.fresh_n "recfuncs" in + (if debug () + then + Format.( + eprintf + "LIFT %a in tuple %s (depth:%d free_vars:%d)@," + (pp_print_list ~pp_sep:pp_print_space pp_print_string) + (List.map ~f:Code.Var.to_string f's) + (Code.Var.to_string f_tuple) + depth + (Var.Set.cardinal free_vars))); + let pc_tuple = program.free_pc in + let lifted_block = + let tuple = Var.fresh_n "tuple" in + { params = [] + ; body = + List.map2 + f's + current_contiguous + ~f:(fun f' (_, params, pc, args) -> + Let (f', Closure (params, (pc, args)))) + @ [ Let (tuple, Block (0, Array.of_list f's, NotArray, Immutable)) + ] + ; branch = Return tuple + } + in + let program = + { program with + free_pc = pc_tuple + 1 + ; blocks = Addr.Map.add pc_tuple lifted_block program.blocks + } + in + let functions = + Let (f_tuple, Closure (List.map s ~f:snd, (pc_tuple, []))) + :: functions + in + let lifters = + ( Var.Set.add f_tuple (fst lifters) + , Var.Map.add_seq + (List.to_seq + @@ List.combine + (List.map current_contiguous ~f:(fun (f, _, _, _) -> f)) + f's) + (snd lifters) ) + in + let rem', st = + match l with + | i :: rem -> + let rem', st = + rewrite_body [] (program, functions, lifters) rem + in + i :: rem', st + | [] -> [], (program, functions, lifters) + in + let tuple = Var.fresh_n "tuple" in + ( Let + ( tuple + , Apply { f = f_tuple; args = List.map ~f:fst s; exact = true } ) + :: List.mapi current_contiguous ~f:(fun i (f, _, _, _) -> + Let (f, Field (tuple, i, Non_float))) + @ rem' + , st ) + | _ :: _ -> + let rem, st = + match l with + | i :: rem -> + let rem, st = rewrite_body [] st rem in + i :: rem, st + | [] -> [], st + in + ( List.map current_contiguous ~f:(fun (f, params, pc, args) -> + Let (f, Closure (params, (pc, args)))) + @ rem + , st )) + in + let body, (program, functions, lifters) = + rewrite_body [] (program, functions, lifters) block.body + in + ( { program with blocks = Addr.Map.add pc { block with body } program.blocks } + , functions + , lifters )) + pc + program.blocks + (program, functions, lifters) + +let f ~to_lift program = + if debug () + then ( + Format.eprintf "@[Program before lambda lifting:@,"; + Code.Print.program (fun _ _ -> "") program; + Format.eprintf "@]"); + let t = Timer.make () in + let nv = Var.count () in + let var_depth = Array.make nv (-1) in + let program, functions, (lifters, liftings) = + traverse + ~to_lift + var_depth + (program, [], (Var.Set.empty, Var.Map.empty)) + program.start + 0 + in + assert (List.is_empty functions); + if Debug.find "times" () then Format.eprintf " lambda lifting: %a@." Timer.print t; + program, lifters, liftings diff --git a/compiler/lib/lambda_lifting_simple.mli b/compiler/lib/lambda_lifting_simple.mli new file mode 100644 index 0000000000..c0f2eea66e --- /dev/null +++ b/compiler/lib/lambda_lifting_simple.mli @@ -0,0 +1,53 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Code + +val f : to_lift:Var.Set.t -> program -> program * Var.Set.t * Var.t Var.Map.t +(** Lambda-lift all functions of the program that are in [to_lift]. All + functions are lifted to toplevel. Functions that may be + mutually recursive are lifted together. Also yields the names of the + lifting closures generated, as well as the names of the lambda-lifted + functions. E.g. consider: + + let y = -3 in + (* ... *) + let rec fib n = + match n with + | 0 | 1 -> 1 + | _ -> fib (n-1) + fib (n-2) + y + in + fib 42 + + After lambda-lifting of [fib], it will look like: + + let y = -3 in + (* ... *) + let fib' y = + let rec fib_l n = + match n with + | 0 | 1 -> 1 + | _ -> fib_l (n-1) + fib_l (n-2) + y + in + fib_l + in + let fib = fib' y in + fib 42 + + [fib_l] is the lifted version of [fib], [fib'] is the lifting closure. + *) diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml index 69be7e08f8..3c7f38d7d6 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -185,6 +185,7 @@ module Fragment = struct ~init:StringMap.empty [ "js-string", Config.Flag.use_js_string ; "effects", Config.Flag.effects + ; "doubletranslate", Config.Flag.double_translation ; ( "wasm" , fun () -> match Config.target () with diff --git a/compiler/lib/phisimpl.ml b/compiler/lib/phisimpl.ml index 68184e9384..c779215a08 100644 --- a/compiler/lib/phisimpl.ml +++ b/compiler/lib/phisimpl.ml @@ -158,6 +158,6 @@ let f p = if times () then Format.eprintf " phi-simpl. 2: %a@." Timer.print t'; Array.iteri subst ~f:(fun idx y -> if Var.idx y = idx then () else Code.Var.propagate_name (Var.of_idx idx) y); - let p = Subst.program (Subst.from_array subst) p in + let p = Subst.Excluding_Binders.program (Subst.from_array subst) p in if times () then Format.eprintf " phi-simpl.: %a@." Timer.print t; p diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index 8cb2de2a4a..4009ecab37 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -1172,6 +1172,21 @@ module Array = struct incr i done; !i = len_a + + let fold_left_map ~f ~init input_array = + let len = length input_array in + if len = 0 + then init, [||] + else + let acc, elt = f init (unsafe_get input_array 0) in + let output_array = make len elt in + let acc = ref acc in + for i = 1 to len - 1 do + let acc', elt = f !acc (unsafe_get input_array i) in + acc := acc'; + unsafe_set output_array i elt + done; + !acc, output_array end module Filename = struct diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml index 11382bc90a..1d0dcbc1d2 100644 --- a/compiler/lib/subst.ml +++ b/compiler/lib/subst.ml @@ -23,75 +23,77 @@ open Code let subst_cont s (pc, arg) = pc, List.map arg ~f:(fun x -> s x) -let expr s e = - match e with - | Constant _ -> e - | Apply { f; args; exact } -> - Apply { f = s f; args = List.map args ~f:(fun x -> s x); exact } - | Block (n, a, k, mut) -> Block (n, Array.map a ~f:(fun x -> s x), k, mut) - | Field (x, n, typ) -> Field (s x, n, typ) - | Closure (l, pc) -> Closure (l, subst_cont s pc) - | Special _ -> e - | Prim (p, l) -> - Prim - ( p - , List.map l ~f:(fun x -> - match x with - | Pv x -> Pv (s x) - | Pc _ -> x) ) - -let instr s i = - match i with - | Let (x, e) -> Let (x, expr s e) - | Assign (x, y) -> Assign (x, s y) (* x is handled like a parameter *) - | Set_field (x, n, typ, y) -> Set_field (s x, n, typ, s y) - | Offset_ref (x, n) -> Offset_ref (s x, n) - | Array_set (x, y, z) -> Array_set (s x, s y, s z) - | Event _ -> i - -let instrs s l = List.map l ~f:(fun i -> instr s i) - -let last s l = - match l with - | Stop -> l - | Branch cont -> Branch (subst_cont s cont) - | Pushtrap (cont1, x, cont2) -> Pushtrap (subst_cont s cont1, x, subst_cont s cont2) - | Return x -> Return (s x) - | Raise (x, k) -> Raise (s x, k) - | Cond (x, cont1, cont2) -> Cond (s x, subst_cont s cont1, subst_cont s cont2) - | Switch (x, a1) -> Switch (s x, Array.map a1 ~f:(fun cont -> subst_cont s cont)) - | Poptrap cont -> Poptrap (subst_cont s cont) - -let block s block = - { params = block.params; body = instrs s block.body; branch = last s block.branch } - -let program s p = - let blocks = Addr.Map.map (fun b -> block s b) p.blocks in - { p with blocks } - -let rec cont' s pc blocks visited = - if Addr.Set.mem pc visited - then blocks, visited - else - let visited = Addr.Set.add pc visited in - let b = Addr.Map.find pc blocks in - let b = block s b in - let blocks = Addr.Map.add pc b blocks in - let blocks, visited = - List.fold_left b.body ~init:(blocks, visited) ~f:(fun (blocks, visited) instr -> - match instr with - | Let (_, Closure (_, (pc, _))) -> cont' s pc blocks visited - | _ -> blocks, visited) - in - Code.fold_children - blocks - pc - (fun pc (blocks, visited) -> cont' s pc blocks visited) - (blocks, visited) - -let cont s addr p = - let blocks, _ = cont' s addr p.blocks Addr.Set.empty in - { p with blocks } +module Excluding_Binders = struct + let expr s e = + match e with + | Constant _ -> e + | Apply { f; args; exact } -> + Apply { f = s f; args = List.map args ~f:(fun x -> s x); exact } + | Block (n, a, k, mut) -> Block (n, Array.map a ~f:(fun x -> s x), k, mut) + | Field (x, n, typ) -> Field (s x, n, typ) + | Closure (l, pc) -> Closure (l, subst_cont s pc) + | Special _ -> e + | Prim (p, l) -> + Prim + ( p + , List.map l ~f:(fun x -> + match x with + | Pv x -> Pv (s x) + | Pc _ -> x) ) + + let instr s i = + match i with + | Let (x, e) -> Let (x, expr s e) + | Assign (x, y) -> Assign (x, s y) (* x is handled like a parameter *) + | Set_field (x, n, typ, y) -> Set_field (s x, n, typ, s y) + | Offset_ref (x, n) -> Offset_ref (s x, n) + | Array_set (x, y, z) -> Array_set (s x, s y, s z) + | Event _ -> i + + let instrs s l = List.map l ~f:(fun i -> instr s i) + + let last s l = + match l with + | Stop -> l + | Branch cont -> Branch (subst_cont s cont) + | Pushtrap (cont1, x, cont2) -> Pushtrap (subst_cont s cont1, x, subst_cont s cont2) + | Return x -> Return (s x) + | Raise (x, k) -> Raise (s x, k) + | Cond (x, cont1, cont2) -> Cond (s x, subst_cont s cont1, subst_cont s cont2) + | Switch (x, a1) -> Switch (s x, Array.map a1 ~f:(fun cont -> subst_cont s cont)) + | Poptrap cont -> Poptrap (subst_cont s cont) + + let block s block = + { params = block.params; body = instrs s block.body; branch = last s block.branch } + + let program s p = + let blocks = Addr.Map.map (fun b -> block s b) p.blocks in + { p with blocks } + + let rec cont' s pc blocks visited = + if Addr.Set.mem pc visited + then blocks, visited + else + let visited = Addr.Set.add pc visited in + let b = Addr.Map.find pc blocks in + let b = block s b in + let blocks = Addr.Map.add pc b blocks in + let blocks, visited = + List.fold_left b.body ~init:(blocks, visited) ~f:(fun (blocks, visited) instr -> + match instr with + | Let (_, Closure (_, (pc, _))) -> cont' s pc blocks visited + | _ -> blocks, visited) + in + Code.fold_children + blocks + pc + (fun pc (blocks, visited) -> cont' s pc blocks visited) + (blocks, visited) + + let cont s addr p = + let blocks, _ = cont' s addr p.blocks Addr.Set.empty in + { p with blocks } +end (****) @@ -106,3 +108,52 @@ let rec build_mapping params args = | _ -> assert false let from_map m x = try Var.Map.find x m with Not_found -> x + +(****) + +module Including_Binders = struct + let expr s e = + match e with + | Constant _ -> e + | Apply { f; args; exact } -> + Apply { f = s f; args = List.map args ~f:(fun x -> s x); exact } + | Block (n, a, k, mut) -> Block (n, Array.map a ~f:(fun x -> s x), k, mut) + | Field (x, n, typ) -> Field (s x, n, typ) + | Closure (l, pc) -> Closure (List.map l ~f:s, subst_cont s pc) + | Special _ -> e + | Prim (p, l) -> + Prim + ( p + , List.map l ~f:(fun x -> + match x with + | Pv x -> Pv (s x) + | Pc _ -> x) ) + + let instr s i = + match i with + | Let (x, e) -> Let (s x, expr s e) + | Assign (x, y) -> Assign (s x, s y) + | Set_field (x, n, typ, y) -> Set_field (s x, n, typ, s y) + | Offset_ref (x, n) -> Offset_ref (s x, n) + | Array_set (x, y, z) -> Array_set (s x, s y, s z) + | Event _ -> i + + let instrs s l = List.map l ~f:(fun i -> instr s i) + + let last s l = + match l with + | Stop -> l + | Branch cont -> Branch (subst_cont s cont) + | Pushtrap (cont1, x, cont2) -> Pushtrap (subst_cont s cont1, s x, subst_cont s cont2) + | Return x -> Return (s x) + | Raise (x, k) -> Raise (s x, k) + | Cond (x, cont1, cont2) -> Cond (s x, subst_cont s cont1, subst_cont s cont2) + | Switch (x, conts) -> Switch (s x, Array.map conts ~f:(fun cont -> subst_cont s cont)) + | Poptrap cont -> Poptrap (subst_cont s cont) + + let block s block = + { params = List.map block.params ~f:s + ; body = instrs s block.body + ; branch = last s block.branch + } +end diff --git a/compiler/lib/subst.mli b/compiler/lib/subst.mli index 9ecd43e6a9..8872b4f0f5 100644 --- a/compiler/lib/subst.mli +++ b/compiler/lib/subst.mli @@ -20,29 +20,46 @@ open Code -val program : (Var.t -> Var.t) -> program -> program +(** The operations of this module substitute variable names that appear in + expressions, except for binders, i.e., names on the right-hand side of a + {!constructor:Code.Let}. *) +module Excluding_Binders : sig + val program : (Var.t -> Var.t) -> program -> program -val expr : (Var.t -> Var.t) -> expr -> expr + val expr : (Var.t -> Var.t) -> expr -> expr -val instr : (Var.t -> Var.t) -> instr -> instr + val instr : (Var.t -> Var.t) -> instr -> instr -val instrs : (Var.t -> Var.t) -> instr list -> instr list + val instrs : (Var.t -> Var.t) -> instr list -> instr list -val block : (Var.t -> Var.t) -> block -> block + val block : (Var.t -> Var.t) -> block -> block -val last : (Var.t -> Var.t) -> last -> last + val last : (Var.t -> Var.t) -> last -> last -val cont : (Var.t -> Var.t) -> int -> program -> program + val cont : (Var.t -> Var.t) -> int -> program -> program -val cont' : - (Var.t -> Var.t) - -> int - -> block Addr.Map.t - -> Addr.Set.t - -> block Addr.Map.t * Addr.Set.t + val cont' : + (Var.t -> Var.t) + -> int + -> block Addr.Map.t + -> Addr.Set.t + -> block Addr.Map.t * Addr.Set.t +end val from_array : Var.t array -> Var.t -> Var.t val build_mapping : Var.t list -> Var.t list -> Var.t Var.Map.t val from_map : Var.t Var.Map.t -> Var.t -> Var.t + +(** The operations of this module also substitute the variables names that + appear on the left-hand-side of a {!constructor:Code.Let}, or as block + parameters, or as closure parameters, or are bound by an exception handler. + *) +module Including_Binders : sig + val instr : (Var.t -> Var.t) -> instr -> instr + + val instrs : (Var.t -> Var.t) -> instr list -> instr list + + val block : (Var.t -> Var.t) -> block -> block +end diff --git a/compiler/tests-compiler/direct_calls.ml b/compiler/tests-compiler/direct_calls.ml index e458e83918..2a81029d9c 100644 --- a/compiler/tests-compiler/direct_calls.ml +++ b/compiler/tests-compiler/direct_calls.ml @@ -158,40 +158,45 @@ let%expect_test "direct calls with --enable effects" = var raise = caml_pop_trap(), e$0 = caml_maybe_attach_backtrace(e, 0); return raise(e$0); }); - return caml_cps_exact_call2 - (g, x, function(_f_){caml_pop_trap(); return cont();}); + return caml_exact_trampoline_cps_call + (g, x, function(_t_){caml_pop_trap(); return cont();}); } - return caml_cps_exact_call3 + return caml_exact_trampoline_cps_call$0 (f, function(x, cont){return cont();}, 7, - function(_d_){ - return caml_cps_exact_call3 + function(_r_){ + return caml_exact_trampoline_cps_call$0 (f, function(x, cont){ - return caml_cps_call3(Stdlib[28], x, cst_a$0, cont); + return caml_trampoline_cps_call3 + (Stdlib[28], x, cst_a$0, cont); }, cst_a, - function(_e_){return cont(0);}); + function(_s_){return cont(0);}); }); } //end function test3(x, cont){ function F(symbol){function f(x){return x + 1 | 0;} return [0, f];} - var M1 = F(), M2 = F(), _c_ = M2[1].call(null, 2); - return cont([0, M1[1].call(null, 1), _c_]); + var M1 = F(), M2 = F(), _q_ = M2[1].call(null, 2); + return cont([0, M1[1].call(null, 1), _q_]); } //end function test4(x, cont){ function F(symbol){ - function f(x, cont){return caml_cps_call3(Stdlib_Printf[2], _a_, x, cont);} + function f(x, cont){ + return caml_trampoline_cps_call3(Stdlib_Printf[2], _o_, x, cont); + } return [0, f]; } var M1 = F(), M2 = F(); - return caml_cps_exact_call2 + return caml_exact_trampoline_cps_call (M1[1], 1, - function(_b_){return caml_cps_exact_call2(M2[1], 2, cont);}); + function(_p_){ + return caml_exact_trampoline_cps_call(M2[1], 2, cont); + }); } //end |}] diff --git a/compiler/tests-compiler/double-translation/direct_calls.ml b/compiler/tests-compiler/double-translation/direct_calls.ml new file mode 100644 index 0000000000..5757f9008c --- /dev/null +++ b/compiler/tests-compiler/double-translation/direct_calls.ml @@ -0,0 +1,223 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Util + +let%expect_test "direct calls with --enable effects,doubletranslate" = + let code = + compile_and_parse + ~effects:true + ~doubletranslate:true + {| + (* Arity of the argument of a function / direct call *) + let test1 () = + let f g x = try g x with e -> raise e in + ignore (f (fun x -> x + 1) 7); + ignore (f (fun x -> x *. 2.) 4.) + + (* Arity of the argument of a function / CPS call *) + let test2 () = + let f g x = try g x with e -> raise e in + ignore (f (fun x -> x + 1) 7); + ignore (f (fun x -> x ^ "a") "a") + + (* Arity of functions in a functor / direct call *) + let test3 x = + let module F(_ : sig end) = struct let f x = x + 1 end in + let module M1 = F (struct end) in + let module M2 = F (struct end) in + (M1.f 1, M2.f 2) + + (* Arity of functions in a functor / CPS call *) + let test4 x = + let module F(_ : sig end) = + struct let f x = Printf.printf "%d" x end in + let module M1 = F (struct end) in + let module M2 = F (struct end) in + M1.f 1; M2.f 2 +|} + in + print_program code; + [%expect + {| + (function(globalThis){ + "use strict"; + var + runtime = globalThis.jsoo_runtime, + caml_cps_closure = runtime.caml_cps_closure, + caml_maybe_attach_backtrace = runtime.caml_maybe_attach_backtrace, + caml_pop_trap = runtime.caml_pop_trap, + caml_string_of_jsbytes = runtime.caml_string_of_jsbytes, + caml_wrap_exception = runtime.caml_wrap_exception; + function caml_call1(f, a0){ + return (f.l >= 0 ? f.l : f.l = f.length) === 1 + ? f(a0) + : runtime.caml_call_gen(f, [a0]); + } + function caml_call2(f, a0, a1){ + return (f.l >= 0 ? f.l : f.l = f.length) === 2 + ? f(a0, a1) + : runtime.caml_call_gen(f, [a0, a1]); + } + function caml_exact_trampoline_cps_call(f, a0, a1){ + return runtime.caml_stack_check_depth() + ? f.cps.call(null, a0, a1) + : runtime.caml_trampoline_return(f, [a0, a1]); + } + function caml_trampoline_cps_call3(f, a0, a1, a2){ + return runtime.caml_stack_check_depth() + ? (f.cps.l + >= 0 + ? f.cps.l + : f.cps.l = f.cps.length) + === 3 + ? f.cps.call(null, a0, a1, a2) + : runtime.caml_call_gen_cps(f, [a0, a1, a2]) + : runtime.caml_trampoline_return(f, [a0, a1, a2]); + } + function caml_exact_trampoline_cps_call$0(f, a0, a1, a2){ + return runtime.caml_stack_check_depth() + ? f.cps.call(null, a0, a1, a2) + : runtime.caml_trampoline_return(f, [a0, a1, a2]); + } + runtime.caml_initialize_fiber_stack(); + var + dummy = 0, + global_data = runtime.caml_get_global_data(), + _s_ = [0, [4, 0, 0, 0, 0], caml_string_of_jsbytes("%d")], + cst_a$0 = caml_string_of_jsbytes("a"), + cst_a = caml_string_of_jsbytes("a"), + Stdlib_Printf = global_data.Stdlib__Printf, + Stdlib = global_data.Stdlib; + function test1$0(param){ + function f(g, x){ + try{caml_call1(g, dummy); return;} + catch(e$0){ + var e = caml_wrap_exception(e$0); + throw caml_maybe_attach_backtrace(e, 0); + } + } + f(function(x){}); + f(function(x){}); + return 0; + } + function test1$1(param, cont){ + function f(g, x){ + try{caml_call1(g, dummy); return;} + catch(e$0){ + var e = caml_wrap_exception(e$0); + throw caml_maybe_attach_backtrace(e, 0); + } + } + f(function(x){}); + f(function(x){}); + return cont(0); + } + var test1 = caml_cps_closure(test1$0, test1$1); + function f$0(){ + function f$0(g, x){ + try{caml_call1(g, x); return;} + catch(e$0){ + var e = caml_wrap_exception(e$0); + throw caml_maybe_attach_backtrace(e, 0); + } + } + function f$1(g, x, cont){ + runtime.caml_push_trap + (function(e){ + var raise = caml_pop_trap(), e$0 = caml_maybe_attach_backtrace(e, 0); + return raise(e$0); + }); + return caml_exact_trampoline_cps_call + (g, x, function(_y_){caml_pop_trap(); return cont();}); + } + var f = caml_cps_closure(f$0, f$1); + return f; + } + function _h_(){ + return caml_cps_closure(function(x){}, function(x, cont){return cont();}); + } + function _j_(){ + return caml_cps_closure + (function(x){return caml_call2(Stdlib[28], x, cst_a$0);}, + function(x, cont){ + return caml_trampoline_cps_call3(Stdlib[28], x, cst_a$0, cont); + }); + } + function test2$0(param){ + var f = f$0(); + f(_h_(), 7); + f(_j_(), cst_a); + return 0; + } + function test2$1(param, cont){ + var f = f$0(); + return caml_exact_trampoline_cps_call$0 + (f, + _h_(), + 7, + function(_w_){ + return caml_exact_trampoline_cps_call$0 + (f, _j_(), cst_a, function(_x_){return cont(0);}); + }); + } + var test2 = caml_cps_closure(test2$0, test2$1); + function test3$0(x){ + function F(symbol){function f(x){return x + 1 | 0;} return [0, f];} + var M1 = F(), M2 = F(), _v_ = caml_call1(M2[1], 2); + return [0, caml_call1(M1[1], 1), _v_]; + } + function test3$1(x, cont){ + function F(symbol){function f(x){return x + 1 | 0;} return [0, f];} + var M1 = F(), M2 = F(), _u_ = M2[1].call(null, 2); + return cont([0, M1[1].call(null, 1), _u_]); + } + var test3 = caml_cps_closure(test3$0, test3$1); + function f(){ + function f$0(x){return caml_call2(Stdlib_Printf[2], _s_, x);} + function f$1(x, cont){ + return caml_trampoline_cps_call3(Stdlib_Printf[2], _s_, x, cont); + } + var f = caml_cps_closure(f$0, f$1); + return f; + } + function test4$0(x){ + function F(symbol){var f$0 = f(); return [0, f$0];} + var M1 = F(), M2 = F(); + caml_call1(M1[1], 1); + return caml_call1(M2[1], 2); + } + function test4$1(x, cont){ + function F(symbol){var f$0 = f(); return [0, f$0];} + var M1 = F(), M2 = F(); + return caml_exact_trampoline_cps_call + (M1[1], + 1, + function(_t_){ + return caml_exact_trampoline_cps_call(M2[1], 2, cont); + }); + } + var + test4 = caml_cps_closure(test4$0, test4$1), + Test = [0, test1, test2, test3, test4]; + runtime.caml_register_global(7, Test, "Test"); + return; + } + (globalThis)); + //end + |}] diff --git a/compiler/tests-compiler/double-translation/dune b/compiler/tests-compiler/double-translation/dune new file mode 100644 index 0000000000..063207b8a9 --- /dev/null +++ b/compiler/tests-compiler/double-translation/dune @@ -0,0 +1,14 @@ +(include dune.inc) + +(rule + (deps + (glob_files *.ml)) + (action + (with-stdout-to + dune.inc.gen + (run ../gen-rules/gen.exe jsoo_compiler_test)))) + +(rule + (alias runtest) + (action + (diff dune.inc dune.inc.gen))) diff --git a/compiler/tests-compiler/double-translation/dune.inc b/compiler/tests-compiler/double-translation/dune.inc new file mode 100644 index 0000000000..1cecd7aa8b --- /dev/null +++ b/compiler/tests-compiler/double-translation/dune.inc @@ -0,0 +1,60 @@ + +(library + ;; compiler/tests-compiler/double-translation/direct_calls.ml + (name direct_calls_47) + (enabled_if true) + (modules direct_calls) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + +(library + ;; compiler/tests-compiler/double-translation/effects_continuations.ml + (name effects_continuations_47) + (enabled_if true) + (modules effects_continuations) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + +(library + ;; compiler/tests-compiler/double-translation/effects_exceptions.ml + (name effects_exceptions_47) + (enabled_if true) + (modules effects_exceptions) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + +(library + ;; compiler/tests-compiler/double-translation/effects_toplevel.ml + (name effects_toplevel_47) + (enabled_if true) + (modules effects_toplevel) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) diff --git a/compiler/tests-compiler/double-translation/effects_continuations.ml b/compiler/tests-compiler/double-translation/effects_continuations.ml new file mode 100644 index 0000000000..3ff2035b45 --- /dev/null +++ b/compiler/tests-compiler/double-translation/effects_continuations.ml @@ -0,0 +1,298 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2019 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Util + +let%expect_test "test-compiler/lib-effects/test1.ml" = + let code = + compile_and_parse + ~effects:true + ~doubletranslate:true + {| + let list_rev = List.rev + (* Avoid to expose the offset of stdlib modules *) + let () = ignore (list_rev []) + + let exceptions s = + (* Compiled using 'try ... catch', + and 'throw' within the try block *) + let n = try int_of_string s with Failure _ -> 0 in + let m = + try if s = "" then raise Not_found else 7 with Not_found -> 0 in + (* Uses caml_{push,pop}_trap. *) + try + if s = "" then raise Not_found; + Some (open_in "toto", n, m) + with Not_found -> + None + + (* Conditional whose result is used *) + let cond1 b = + let ic = if b then open_in "toto" else open_in "titi" in + (ic , 7) + + (* Conditional whose result is not used *) + let cond2 b = + if b then Printf.eprintf "toto" else Printf.eprintf "toto"; + 7 + + (* A dummy argument is used to call the continuation in the + [then] clause *) + let cond3 b = + let x= ref 0 in if b then x := 1 else Printf.eprintf "toto"; + !x + + (* Two continuation functions are created. One to bind [ic] before + entering the loop, and one for the loop. We use a dummy argument + to go back to the begining of the loop if [b] is false *) + let loop1 b = + let all = ref [] in + let ic = open_in "/static/examples.ml" in + while true do + let line = input_line ic in + all := line :: !all; + if b then prerr_endline line + done + + (* There is a single continuation for the loop since the result of + [Printf.eprintf] is ignored. *) + let loop2 () = + let all = ref [] in + let ic = open_in "/static/examples.ml" in + Printf.eprintf "titi"; + while true do + let line = input_line ic in + all := line :: !all; + prerr_endline line + done + + let loop3 () = + let l = list_rev [1;2;3] in + let rec f x = + match x with + | [] -> l + | _ :: r -> f r + in + f l + |} + in + print_double_fun_decl code "exceptions"; + print_double_fun_decl code "cond1"; + print_double_fun_decl code "cond2"; + print_double_fun_decl code "cond3"; + print_double_fun_decl code "loop1"; + print_double_fun_decl code "loop2"; + print_double_fun_decl code "loop3"; + [%expect + {| + function exceptions$0(s){ + try{var _K_ = caml_int_of_string(s), n = _K_;} + catch(_N_){ + var _F_ = caml_wrap_exception(_N_); + if(_F_[1] !== Stdlib[7]) throw caml_maybe_attach_backtrace(_F_, 0); + var n = 0; + } + try{ + if(caml_string_equal(s, cst$0)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _J_ = 7, m = _J_; + } + catch(_M_){ + var _G_ = caml_wrap_exception(_M_); + if(_G_ !== Stdlib[8]) throw caml_maybe_attach_backtrace(_G_, 0); + var m = 0; + } + try{ + if(caml_string_equal(s, cst)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _I_ = [0, [0, caml_call1(Stdlib[79], cst_toto), n, m]]; + return _I_; + } + catch(_L_){ + var _H_ = caml_wrap_exception(_L_); + if(_H_ === Stdlib[8]) return 0; + throw caml_maybe_attach_backtrace(_H_, 0); + } + } + //end + function exceptions$1(s, cont){ + try{var _A_ = caml_int_of_string(s), n = _A_;} + catch(_E_){ + var _w_ = caml_wrap_exception(_E_); + if(_w_[1] !== Stdlib[7]){ + var raise$1 = caml_pop_trap(); + return raise$1(caml_maybe_attach_backtrace(_w_, 0)); + } + var n = 0; + } + try{ + if(caml_string_equal(s, cst$0)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _z_ = 7, m = _z_; + } + catch(_D_){ + var _x_ = caml_wrap_exception(_D_); + if(_x_ !== Stdlib[8]){ + var raise$0 = caml_pop_trap(); + return raise$0(caml_maybe_attach_backtrace(_x_, 0)); + } + var m = 0; + } + runtime.caml_push_trap + (function(_C_){ + if(_C_ === Stdlib[8]) return cont(0); + var raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_C_, 0)); + }); + if(! caml_string_equal(s, cst)) + return caml_trampoline_cps_call2 + (Stdlib[79], + cst_toto, + function(_B_){caml_pop_trap(); return cont([0, [0, _B_, n, m]]);}); + var _y_ = Stdlib[8], raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_y_, 1)); + } + //end + var exceptions = caml_cps_closure(exceptions$0, exceptions$1); + //end + function cond1$0(b){ + var + ic = + b ? caml_call1(Stdlib[79], cst_toto$0) : caml_call1(Stdlib[79], cst_titi); + return [0, ic, 7]; + } + //end + function cond1$1(b, cont){ + function _v_(ic){return cont([0, ic, 7]);} + return b + ? caml_trampoline_cps_call2(Stdlib[79], cst_toto$0, _v_) + : caml_trampoline_cps_call2(Stdlib[79], cst_titi, _v_); + } + //end + var cond1 = caml_cps_closure(cond1$0, cond1$1); + //end + function cond2$0(b){ + if(b) + caml_call1(Stdlib_Printf[3], _h_); + else + caml_call1(Stdlib_Printf[3], _i_); + return 7; + } + //end + function cond2$1(b, cont){ + function _t_(_u_){return cont(7);} + return b + ? caml_trampoline_cps_call2(Stdlib_Printf[3], _h_, _t_) + : caml_trampoline_cps_call2(Stdlib_Printf[3], _i_, _t_); + } + //end + var cond2 = caml_cps_closure(cond2$0, cond2$1); + //end + function cond3$0(b){ + var x = [0, 0]; + if(b) x[1] = 1; else caml_call1(Stdlib_Printf[3], _j_); + return x[1]; + } + //end + function cond3$1(b, cont){ + var x = [0, 0]; + function _r_(_s_){return cont(x[1]);} + return b + ? (x[1] = 1, _r_(0)) + : caml_trampoline_cps_call2(Stdlib_Printf[3], _j_, _r_); + } + //end + var cond3 = caml_cps_closure(cond3$0, cond3$1); + //end + function loop1$0(b){ + var ic = caml_call1(Stdlib[79], cst_static_examples_ml); + for(;;){ + var line = caml_call1(Stdlib[83], ic); + if(b) caml_call1(Stdlib[53], line); + } + } + //end + function loop1$1(b, cont){ + return caml_trampoline_cps_call2 + (Stdlib[79], + cst_static_examples_ml, + function(ic){ + function _p_(_q_){ + return caml_trampoline_cps_call2 + (Stdlib[83], + ic, + function(line){ + return b + ? caml_trampoline_cps_call2(Stdlib[53], line, _p_) + : caml_exact_trampoline_call1(_p_, 0); + }); + } + return _p_(0); + }); + } + //end + var loop1 = caml_cps_closure(loop1$0, loop1$1); + //end + function loop2$0(param){ + var ic = caml_call1(Stdlib[79], cst_static_examples_ml$0); + caml_call1(Stdlib_Printf[3], _k_); + for(;;){var line = caml_call1(Stdlib[83], ic); caml_call1(Stdlib[53], line);} + } + //end + function loop2$1(param, cont){ + return caml_trampoline_cps_call2 + (Stdlib[79], + cst_static_examples_ml$0, + function(ic){ + function _n_(_o_){ + return caml_trampoline_cps_call2 + (Stdlib[83], + ic, + function(line){ + return caml_trampoline_cps_call2(Stdlib[53], line, _n_); + }); + } + return caml_trampoline_cps_call2(Stdlib_Printf[3], _k_, _n_); + }); + } + //end + var loop2 = caml_cps_closure(loop2$0, loop2$1); + //end + function loop3$0(param){ + var l = caml_call1(list_rev, _l_), x = l; + for(;;){if(! x) return l; var r = x[2]; x = r;} + } + //end + function loop3$1(param, cont){ + return caml_trampoline_cps_call2 + (list_rev, + _l_, + function(l){ + function _m_(x){ + if(! x) return cont(l); + var r = x[2]; + return caml_exact_trampoline_call1(_m_, r); + } + return _m_(l); + }); + } + //end + var loop3 = caml_cps_closure(loop3$0, loop3$1); + //end + |}] diff --git a/compiler/tests-compiler/double-translation/effects_exceptions.ml b/compiler/tests-compiler/double-translation/effects_exceptions.ml new file mode 100644 index 0000000000..6870ed6094 --- /dev/null +++ b/compiler/tests-compiler/double-translation/effects_exceptions.ml @@ -0,0 +1,198 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2019 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Util + +let%expect_test "test-compiler/lib-effects/test1.ml" = + let code = + compile_and_parse + ~effects:true + ~doubletranslate:true + {| + let exceptions s = + (* Compiled using 'try ... catch', + and 'throw' within the try block *) + let n = try int_of_string s with Failure _ -> 0 in + let m = + try if s = "" then raise Not_found else 7 with Not_found -> 0 in + (* Uses caml_{push,pop}_trap. *) + try + if s = "" then raise Not_found; + Some (open_in "toto", n, m) + with Not_found -> + None + + let handler_is_loop f g l = + try f () + with exn -> + let rec loop l = + match g l with + | `Fallback l' -> loop l' + | `Raise exn -> raise exn + in + loop l + + let handler_is_merge_node g = + let s = try g () with _ -> "" in + s ^ "aaa" + |} + in + print_double_fun_decl code "exceptions"; + [%expect + {| + function exceptions$0(s){ + try{var _B_ = caml_int_of_string(s), n = _B_;} + catch(_E_){ + var _w_ = caml_wrap_exception(_E_); + if(_w_[1] !== Stdlib[7]) throw caml_maybe_attach_backtrace(_w_, 0); + var n = 0; + } + try{ + if(caml_string_equal(s, cst$0)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _A_ = 7, m = _A_; + } + catch(_D_){ + var _x_ = caml_wrap_exception(_D_); + if(_x_ !== Stdlib[8]) throw caml_maybe_attach_backtrace(_x_, 0); + var m = 0; + } + try{ + if(caml_string_equal(s, cst)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _z_ = [0, [0, caml_call1(Stdlib[79], cst_toto), n, m]]; + return _z_; + } + catch(_C_){ + var _y_ = caml_wrap_exception(_C_); + if(_y_ === Stdlib[8]) return 0; + throw caml_maybe_attach_backtrace(_y_, 0); + } + } + //end + function exceptions$1(s, cont){ + try{var _r_ = caml_int_of_string(s), n = _r_;} + catch(_v_){ + var _n_ = caml_wrap_exception(_v_); + if(_n_[1] !== Stdlib[7]){ + var raise$1 = caml_pop_trap(); + return raise$1(caml_maybe_attach_backtrace(_n_, 0)); + } + var n = 0; + } + try{ + if(caml_string_equal(s, cst$0)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _q_ = 7, m = _q_; + } + catch(_u_){ + var _o_ = caml_wrap_exception(_u_); + if(_o_ !== Stdlib[8]){ + var raise$0 = caml_pop_trap(); + return raise$0(caml_maybe_attach_backtrace(_o_, 0)); + } + var m = 0; + } + caml_push_trap + (function(_t_){ + if(_t_ === Stdlib[8]) return cont(0); + var raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_t_, 0)); + }); + if(! caml_string_equal(s, cst)) + return caml_trampoline_cps_call2 + (Stdlib[79], + cst_toto, + function(_s_){caml_pop_trap(); return cont([0, [0, _s_, n, m]]);}); + var _p_ = Stdlib[8], raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_p_, 1)); + } + //end + var exceptions = caml_cps_closure(exceptions$0, exceptions$1); + //end + |}]; + print_double_fun_decl code "handler_is_loop"; + [%expect + {| + function handler_is_loop$0(f, g, l){ + try{var _l_ = caml_call1(f, 0); return _l_;} + catch(_m_){ + var l$0 = l; + for(;;){ + var match = caml_call1(g, l$0); + if(72330306 > match[1]){ + var exn = match[2]; + throw caml_maybe_attach_backtrace(exn, 1); + } + var l$1 = match[2]; + l$0 = l$1; + } + } + } + //end + function handler_is_loop$1(f, g, l, cont){ + caml_push_trap + (function(_j_){ + function _k_(l){ + return caml_trampoline_cps_call2 + (g, + l, + function(match){ + if(72330306 <= match[1]){ + var l = match[2]; + return caml_exact_trampoline_call1(_k_, l); + } + var + exn = match[2], + raise = caml_pop_trap(), + exn$0 = caml_maybe_attach_backtrace(exn, 1); + return raise(exn$0); + }); + } + return _k_(l); + }); + return caml_trampoline_cps_call2 + (f, 0, function(_i_){caml_pop_trap(); return cont(_i_);}); + } + //end + var handler_is_loop = caml_cps_closure(handler_is_loop$0, handler_is_loop$1); + //end + |}]; + print_double_fun_decl code "handler_is_merge_node"; + [%expect + {| + function handler_is_merge_node$0(g){ + try{var _g_ = caml_call1(g, 0), s = _g_;}catch(_h_){var s = cst$1;} + return caml_call2(Stdlib[28], s, cst_aaa); + } + //end + function handler_is_merge_node$1(g, cont){ + function _d_(s){ + return caml_trampoline_cps_call3(Stdlib[28], s, cst_aaa, cont); + } + caml_push_trap(function(_f_){return _d_(cst$1);}); + return caml_trampoline_cps_call2 + (g, 0, function(_e_){caml_pop_trap(); return _d_(_e_);}); + } + //end + var + handler_is_merge_node = + caml_cps_closure(handler_is_merge_node$0, handler_is_merge_node$1); + //end + |}] diff --git a/compiler/tests-compiler/double-translation/effects_toplevel.ml b/compiler/tests-compiler/double-translation/effects_toplevel.ml new file mode 100644 index 0000000000..dc3d4caa8b --- /dev/null +++ b/compiler/tests-compiler/double-translation/effects_toplevel.ml @@ -0,0 +1,89 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2019 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Util + +let%expect_test "test-compiler/lib-effects/test1.ml" = + let code = + compile_and_parse + ~effects:true + ~doubletranslate:true + {| + (* Function calls at toplevel outside of loops do not use + [caml_callback] when double translation is enabled. *) + let g () = Printf.printf "abc" in + let f () = for i = 1 to 5 do g () done in + g (); f (); g () + |} + in + print_program code; + [%expect + {| + (function(globalThis){ + "use strict"; + var + runtime = globalThis.jsoo_runtime, + caml_string_of_jsbytes = runtime.caml_string_of_jsbytes; + function caml_call1(f, a0){ + return (f.l >= 0 ? f.l : f.l = f.length) === 1 + ? f(a0) + : runtime.caml_call_gen(f, [a0]); + } + function caml_trampoline_cps_call2(f, a0, a1){ + return runtime.caml_stack_check_depth() + ? (f.cps.l + >= 0 + ? f.cps.l + : f.cps.l = f.cps.length) + === 2 + ? f.cps.call(null, a0, a1) + : runtime.caml_call_gen_cps(f, [a0, a1]) + : runtime.caml_trampoline_return(f, [a0, a1]); + } + runtime.caml_initialize_fiber_stack(); + var + dummy = 0, + global_data = runtime.caml_get_global_data(), + _b_ = + [0, + [11, caml_string_of_jsbytes("abc"), 0], + caml_string_of_jsbytes("abc")], + Stdlib_Printf = global_data.Stdlib__Printf; + function g$0(param){return caml_call1(Stdlib_Printf[2], _b_);} + function g$1(param, cont){ + return caml_trampoline_cps_call2(Stdlib_Printf[2], _b_, cont); + } + var g = runtime.caml_cps_closure(g$0, g$1); + g(); + var i = 1; + for(;;){ + g(); + var _c_ = i + 1 | 0; + if(5 === i){ + g(); + var Test = [0]; + runtime.caml_register_global(2, Test, "Test"); + return; + } + i = _c_; + } + } + (globalThis)); + //end + |}] diff --git a/compiler/tests-compiler/effects.ml b/compiler/tests-compiler/effects.ml index 95892eb396..dda41570cc 100644 --- a/compiler/tests-compiler/effects.ml +++ b/compiler/tests-compiler/effects.ml @@ -43,7 +43,7 @@ let fff () = [%expect {| function fff(param, cont){ - return caml_cps_call4 + return caml_trampoline_cps_call4 (Stdlib_Effect[3][5], function(x, cont){return cont(x);}, 10, @@ -53,11 +53,14 @@ let fff () = ? cont([0, function(k, cont){return cont(11);}]) : cont(0); }], - function(_b_){ - return caml_cps_call2 + function(_f_){ + return caml_trampoline_cps_call2 (Stdlib_Printf[2], - _a_, - function(_c_){return caml_cps_call2(_c_, _b_, cont);}); + _e_, + function(_g_){ + return caml_trampoline_cps_call2(_g_, _f_, cont); + }); }); } - //end |}] + //end + |}] diff --git a/compiler/tests-compiler/effects_continuations.ml b/compiler/tests-compiler/effects_continuations.ml index 0da72bd5ee..8111c81fa9 100644 --- a/compiler/tests-compiler/effects_continuations.ml +++ b/compiler/tests-compiler/effects_continuations.ml @@ -101,112 +101,114 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = print_fun_decl code (Some "loop3"); [%expect {| - function exceptions(s, cont){ - try{var _t_ = runtime.caml_int_of_string(s), n = _t_;} - catch(_x_){ - var _p_ = caml_wrap_exception(_x_); - if(_p_[1] !== Stdlib[7]){ + try{var _A_ = runtime.caml_int_of_string(s), n = _A_;} + catch(_E_){ + var _w_ = caml_wrap_exception(_E_); + if(_w_[1] !== Stdlib[7]){ var raise$1 = caml_pop_trap(); - return raise$1(caml_maybe_attach_backtrace(_p_, 0)); + return raise$1(caml_maybe_attach_backtrace(_w_, 0)); } var n = 0; } try{ if(caml_string_equal(s, cst$0)) throw caml_maybe_attach_backtrace(Stdlib[8], 1); - var _s_ = 7, m = _s_; + var _z_ = 7, m = _z_; } - catch(_w_){ - var _q_ = caml_wrap_exception(_w_); - if(_q_ !== Stdlib[8]){ + catch(_D_){ + var _x_ = caml_wrap_exception(_D_); + if(_x_ !== Stdlib[8]){ var raise$0 = caml_pop_trap(); - return raise$0(caml_maybe_attach_backtrace(_q_, 0)); + return raise$0(caml_maybe_attach_backtrace(_x_, 0)); } var m = 0; } runtime.caml_push_trap - (function(_v_){ - if(_v_ === Stdlib[8]) return cont(0); + (function(_C_){ + if(_C_ === Stdlib[8]) return cont(0); var raise = caml_pop_trap(); - return raise(caml_maybe_attach_backtrace(_v_, 0)); + return raise(caml_maybe_attach_backtrace(_C_, 0)); }); if(! caml_string_equal(s, cst)) - return caml_cps_call2 + return caml_trampoline_cps_call2 (Stdlib[79], cst_toto, - function(_u_){caml_pop_trap(); return cont([0, [0, _u_, n, m]]);}); - var _r_ = Stdlib[8], raise = caml_pop_trap(); - return raise(caml_maybe_attach_backtrace(_r_, 1)); + function(_B_){caml_pop_trap(); return cont([0, [0, _B_, n, m]]);}); + var _y_ = Stdlib[8], raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_y_, 1)); } //end function cond1(b, cont){ - function _o_(ic){return cont([0, ic, 7]);} + function _v_(ic){return cont([0, ic, 7]);} return b - ? caml_cps_call2(Stdlib[79], cst_toto$0, _o_) - : caml_cps_call2(Stdlib[79], cst_titi, _o_); + ? caml_trampoline_cps_call2(Stdlib[79], cst_toto$0, _v_) + : caml_trampoline_cps_call2(Stdlib[79], cst_titi, _v_); } //end function cond2(b, cont){ - function _m_(_n_){return cont(7);} + function _t_(_u_){return cont(7);} return b - ? caml_cps_call2(Stdlib_Printf[3], _a_, _m_) - : caml_cps_call2(Stdlib_Printf[3], _b_, _m_); + ? caml_trampoline_cps_call2(Stdlib_Printf[3], _h_, _t_) + : caml_trampoline_cps_call2(Stdlib_Printf[3], _i_, _t_); } //end function cond3(b, cont){ var x = [0, 0]; - function _k_(_l_){return cont(x[1]);} - return b ? (x[1] = 1, _k_(0)) : caml_cps_call2(Stdlib_Printf[3], _c_, _k_); + function _r_(_s_){return cont(x[1]);} + return b + ? (x[1] = 1, _r_(0)) + : caml_trampoline_cps_call2(Stdlib_Printf[3], _j_, _r_); } //end function loop1(b, cont){ - return caml_cps_call2 + return caml_trampoline_cps_call2 (Stdlib[79], cst_static_examples_ml, function(ic){ - function _i_(_j_){ - return caml_cps_call2 + function _p_(_q_){ + return caml_trampoline_cps_call2 (Stdlib[83], ic, function(line){ return b - ? caml_cps_call2(Stdlib[53], line, _i_) - : caml_cps_exact_call1(_i_, 0); + ? caml_trampoline_cps_call2(Stdlib[53], line, _p_) + : caml_exact_trampoline_call1(_p_, 0); }); } - return _i_(0); + return _p_(0); }); } //end function loop2(param, cont){ - return caml_cps_call2 + return caml_trampoline_cps_call2 (Stdlib[79], cst_static_examples_ml$0, function(ic){ - function _g_(_h_){ - return caml_cps_call2 + function _n_(_o_){ + return caml_trampoline_cps_call2 (Stdlib[83], ic, function(line){ - return caml_cps_call2(Stdlib[53], line, _g_); + return caml_trampoline_cps_call2(Stdlib[53], line, _n_); }); } - return caml_cps_call2(Stdlib_Printf[3], _d_, _g_); + return caml_trampoline_cps_call2(Stdlib_Printf[3], _k_, _n_); }); } //end function loop3(param, cont){ - return caml_cps_call2 + return caml_trampoline_cps_call2 (list_rev, - _e_, + _l_, function(l){ - function _f_(x){ + function _m_(x){ if(! x) return cont(l); var r = x[2]; - return caml_cps_exact_call1(_f_, r); + return caml_exact_trampoline_call1(_m_, r); } - return _f_(l); + return _m_(l); }); } - //end |}] + //end + |}] diff --git a/compiler/tests-compiler/effects_exceptions.ml b/compiler/tests-compiler/effects_exceptions.ml index f227b7b881..317384515d 100644 --- a/compiler/tests-compiler/effects_exceptions.ml +++ b/compiler/tests-compiler/effects_exceptions.ml @@ -55,59 +55,59 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = print_fun_decl code (Some "exceptions"); [%expect {| - function exceptions(s, cont){ - try{var _k_ = runtime.caml_int_of_string(s), n = _k_;} - catch(_o_){ - var _g_ = caml_wrap_exception(_o_); - if(_g_[1] !== Stdlib[7]){ + try{var _n_ = runtime.caml_int_of_string(s), n = _n_;} + catch(_r_){ + var _j_ = caml_wrap_exception(_r_); + if(_j_[1] !== Stdlib[7]){ var raise$1 = caml_pop_trap(); - return raise$1(caml_maybe_attach_backtrace(_g_, 0)); + return raise$1(caml_maybe_attach_backtrace(_j_, 0)); } var n = 0; } try{ if(caml_string_equal(s, cst$0)) throw caml_maybe_attach_backtrace(Stdlib[8], 1); - var _j_ = 7, m = _j_; + var _m_ = 7, m = _m_; } - catch(_n_){ - var _h_ = caml_wrap_exception(_n_); - if(_h_ !== Stdlib[8]){ + catch(_q_){ + var _k_ = caml_wrap_exception(_q_); + if(_k_ !== Stdlib[8]){ var raise$0 = caml_pop_trap(); - return raise$0(caml_maybe_attach_backtrace(_h_, 0)); + return raise$0(caml_maybe_attach_backtrace(_k_, 0)); } var m = 0; } caml_push_trap - (function(_m_){ - if(_m_ === Stdlib[8]) return cont(0); + (function(_p_){ + if(_p_ === Stdlib[8]) return cont(0); var raise = caml_pop_trap(); - return raise(caml_maybe_attach_backtrace(_m_, 0)); + return raise(caml_maybe_attach_backtrace(_p_, 0)); }); if(! caml_string_equal(s, cst)) - return caml_cps_call2 + return caml_trampoline_cps_call2 (Stdlib[79], cst_toto, - function(_l_){caml_pop_trap(); return cont([0, [0, _l_, n, m]]);}); - var _i_ = Stdlib[8], raise = caml_pop_trap(); - return raise(caml_maybe_attach_backtrace(_i_, 1)); + function(_o_){caml_pop_trap(); return cont([0, [0, _o_, n, m]]);}); + var _l_ = Stdlib[8], raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_l_, 1)); } - //end |}]; + //end + |}]; print_fun_decl code (Some "handler_is_loop"); [%expect {| function handler_is_loop(f, g, l, cont){ caml_push_trap - (function(_e_){ - function _f_(l){ - return caml_cps_call2 + (function(_h_){ + function _i_(l){ + return caml_trampoline_cps_call2 (g, l, function(match){ if(72330306 <= match[1]){ var l = match[2]; - return caml_cps_exact_call1(_f_, l); + return caml_exact_trampoline_call1(_i_, l); } var exn = match[2], @@ -116,18 +116,23 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = return raise(exn$0); }); } - return _f_(l); + return _i_(l); }); - return caml_cps_call2 - (f, 0, function(_d_){caml_pop_trap(); return cont(_d_);}); + return caml_trampoline_cps_call2 + (f, 0, function(_g_){caml_pop_trap(); return cont(_g_);}); } - //end |}]; + //end + |}]; print_fun_decl code (Some "handler_is_merge_node"); [%expect {| function handler_is_merge_node(g, cont){ - function _a_(s){return caml_cps_call3(Stdlib[28], s, cst_aaa, cont);} - caml_push_trap(function(_c_){return _a_(cst$1);}); - return caml_cps_call2(g, 0, function(_b_){caml_pop_trap(); return _a_(_b_);}); + function _d_(s){ + return caml_trampoline_cps_call3(Stdlib[28], s, cst_aaa, cont); + } + caml_push_trap(function(_f_){return _d_(cst$1);}); + return caml_trampoline_cps_call2 + (g, 0, function(_e_){caml_pop_trap(); return _d_(_e_);}); } - //end |}] + //end + |}] diff --git a/compiler/tests-compiler/effects_toplevel.ml b/compiler/tests-compiler/effects_toplevel.ml index 20eb72768b..9ea488ee9f 100644 --- a/compiler/tests-compiler/effects_toplevel.ml +++ b/compiler/tests-compiler/effects_toplevel.ml @@ -40,12 +40,12 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = runtime = globalThis.jsoo_runtime, caml_callback = runtime.caml_callback, caml_string_of_jsbytes = runtime.caml_string_of_jsbytes; - function caml_cps_exact_call1(f, a0){ + function caml_exact_trampoline_call1(f, a0){ return runtime.caml_stack_check_depth() ? f(a0) : runtime.caml_trampoline_return(f, [a0]); } - function caml_cps_call2(f, a0, a1){ + function caml_trampoline_cps_call2(f, a0, a1){ return runtime.caml_stack_check_depth() ? (f.l >= 0 @@ -56,7 +56,7 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = : runtime.caml_call_gen(f, [a0, a1]) : runtime.caml_trampoline_return(f, [a0, a1]); } - function caml_cps_exact_call2(f, a0, a1){ + function caml_exact_trampoline_cps_call(f, a0, a1){ return runtime.caml_stack_check_depth() ? f(a0, a1) : runtime.caml_trampoline_return(f, [a0, a1]); @@ -67,27 +67,27 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = dummy = 0, global_data = runtime.caml_get_global_data(), Stdlib_Printf = global_data.Stdlib__Printf, - _a_ = + _b_ = [0, [11, caml_string_of_jsbytes("abc"), 0], caml_string_of_jsbytes("abc")]; function g(param, cont){ - return caml_cps_call2(Stdlib_Printf[2], _a_, cont); + return caml_trampoline_cps_call2(Stdlib_Printf[2], _b_, cont); } caml_callback(g, [dummy]); - function _b_(i){ - return caml_cps_exact_call2 + function _c_(i){ + return caml_exact_trampoline_cps_call (g, dummy, - function(_c_){ - var _d_ = i + 1 | 0; - if(5 !== i) return caml_cps_exact_call1(_b_, _d_); + function(_d_){ + var _e_ = i + 1 | 0; + if(5 !== i) return caml_exact_trampoline_call1(_c_, _e_); caml_callback(g, [dummy]); var Test = [0]; runtime.caml_register_global(2, Test, "Test"); }); } - return _b_(1); + return _c_(1); }, []); } diff --git a/compiler/tests-compiler/lambda_lifting.ml b/compiler/tests-compiler/lambda_lifting.ml index 44ba220119..801af1d553 100644 --- a/compiler/tests-compiler/lambda_lifting.ml +++ b/compiler/tests-compiler/lambda_lifting.ml @@ -26,16 +26,17 @@ Printf.printf "%d\n" (f 3) runtime = globalThis.jsoo_runtime, global_data = runtime.caml_get_global_data(), Stdlib_Printf = global_data.Stdlib__Printf, - _b_ = + _e_ = [0, [4, 0, 0, 0, [12, 10, 0]], runtime.caml_string_of_jsbytes("%d\n")]; function h(x, y){function h(z){return (x + y | 0) + z | 0;} return h;} function g(x){function g(y){var h$0 = h(x, y); return h$0(7);} return g;} function f(x){var g$0 = g(x); return g$0(5);} - var _a_ = f(3); - runtime.caml_callback(Stdlib_Printf[2], [_b_, _a_]); + var _d_ = f(3); + runtime.caml_callback(Stdlib_Printf[2], [_e_, _d_]); var Test = [0]; runtime.caml_register_global(2, Test, "Test"); return; } (globalThis)); - //end |}] + //end + |}] diff --git a/compiler/tests-compiler/util/util.ml b/compiler/tests-compiler/util/util.ml index 2a69f3cb81..3dc3d21f07 100644 --- a/compiler/tests-compiler/util/util.ml +++ b/compiler/tests-compiler/util/util.ml @@ -291,6 +291,7 @@ let compile_to_javascript ?(flags = []) ?(use_js_string = false) ?(effects = false) + ?(doubletranslate = false) ~pretty ~sourcemap file = @@ -300,6 +301,9 @@ let compile_to_javascript [ (if pretty then [ "--pretty" ] else []) ; (if sourcemap then [ "--sourcemap" ] else []) ; (if effects then [ "--enable=effects" ] else [ "--disable=effects" ]) + ; (if doubletranslate + then [ "--enable=doubletranslate" ] + else [ "--disable=doubletranslate" ]) ; (if use_js_string then [ "--enable=use-js-string" ] else [ "--disable=use-js-string" ]) @@ -352,6 +356,7 @@ let compile_bc_to_javascript let compile_cmo_to_javascript ?(flags = []) ?effects + ?doubletranslate ?use_js_string ?(pretty = true) ?(sourcemap = true) @@ -359,6 +364,7 @@ let compile_cmo_to_javascript Filetype.path_of_cmo_file file |> compile_to_javascript ?effects + ?doubletranslate ?use_js_string ~flags:([ "--disable"; "header" ] @ flags) ~pretty @@ -510,6 +516,50 @@ let print_fun_decl program n = | [] -> print_endline "not found" | l -> print_endline (Format.sprintf "%d functions found" (List.length l)) +(* Find a doubly-translated function by name, and use the call to [caml_cps_closure] to find the direct-style and CPS closures *) +class find_double_function_declaration r n = + object + inherit Jsoo.Js_traverse.map as super + + method! statement s = + let open Jsoo.Javascript in + (match s with + | Variable_statement (_, l) -> + List.iter l ~f:(function + | DeclIdent + ( S { name = Utf8 name; _ } + , Some + ( ECall + ( EVar (S { name = Utf8 "caml_cps_closure"; _ }) + , _ + , [ Arg e1; Arg e2 ] + , _ ) + , _ ) ) as var_decl -> + let decls = var_decl, e1, e2 in + if String.equal name n then r := decls :: !r else () + | _ -> ()) + | _ -> ()); + super#statement s + end + +let print_double_fun_decl program n = + let r = ref [] in + let o = new find_double_function_declaration r n in + ignore (o#program program); + let module J = Jsoo.Javascript in + let maybe_print_decl = function + | J.EFun _ -> () + | J.(EVar (S { name = Utf8 name; _ })) -> print_fun_decl program (Some name) + | _ -> print_endline "not found" + in + match !r with + | [ (var_decl, e1, e2) ] -> + maybe_print_decl e1; + maybe_print_decl e2; + print_string (program_to_string [ J.(Variable_statement (Var, [ var_decl ]), N) ]) + | [] -> print_endline "not found" + | l -> print_endline (Format.sprintf "%d functions found" (List.length l)) + let compile_and_run_bytecode ?unix s = with_temp_dir ~f:(fun () -> s @@ -580,13 +630,26 @@ let compile_and_parse_whole_program |> compile_bc_to_javascript ?pretty ?flags ?effects ?use_js_string ~sourcemap:debug |> parse_js) -let compile_and_parse ?(debug = true) ?pretty ?flags ?effects ?use_js_string s = +let compile_and_parse + ?(debug = true) + ?pretty + ?flags + ?effects + ?doubletranslate + ?use_js_string + s = with_temp_dir ~f:(fun () -> s |> Filetype.ocaml_text_of_string |> Filetype.write_ocaml ~name:"test.ml" |> compile_ocaml_to_cmo ~debug - |> compile_cmo_to_javascript ?pretty ?flags ?effects ?use_js_string ~sourcemap:debug + |> compile_cmo_to_javascript + ?pretty + ?flags + ?effects + ?doubletranslate + ?use_js_string + ~sourcemap:debug |> parse_js) let normalize_path s = diff --git a/compiler/tests-compiler/util/util.mli b/compiler/tests-compiler/util/util.mli index 5788400928..bac2017770 100644 --- a/compiler/tests-compiler/util/util.mli +++ b/compiler/tests-compiler/util/util.mli @@ -35,6 +35,7 @@ val compile_lib : Filetype.cmo_file list -> string -> Filetype.cmo_file val compile_cmo_to_javascript : ?flags:string list -> ?effects:bool + -> ?doubletranslate:bool -> ?use_js_string:bool -> ?pretty:bool -> ?sourcemap:bool @@ -75,6 +76,9 @@ val find_variable : Javascript.program -> string -> Javascript.expression val find_function : Javascript.program -> string -> Javascript.function_declaration +(* Prints the two versions of a doubly translated function *) +val print_double_fun_decl : Javascript.program -> string -> unit + val compile_and_run : ?debug:bool -> ?pretty:bool @@ -93,6 +97,7 @@ val compile_and_parse : -> ?pretty:bool -> ?flags:string list -> ?effects:bool + -> ?doubletranslate:bool -> ?use_js_string:bool -> string -> Javascript.program diff --git a/compiler/tests-ocaml/lib-effects/double-translation/cmphash.ml b/compiler/tests-ocaml/lib-effects/double-translation/cmphash.ml new file mode 100644 index 0000000000..0bee4ec7b3 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/cmphash.ml @@ -0,0 +1,24 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +type _ t += E : unit t + +let () = + try_with perform E + { effc = fun (type a) (e : a t) -> + match e with + | E -> Some (fun k -> + (* We have to make sure that neither the match nor the call + to caml_equal are eliminated, so we call + print_string and we print the result of caml_equal. *) + begin match print_string ""; k = k with + | b -> Printf.printf "%b" b; assert false + | exception (Invalid_argument _) -> print_endline "ok" + end; + begin match Hashtbl.hash k with + | _ -> print_endline "ok" + end) + | e -> None } diff --git a/compiler/tests-ocaml/lib-effects/double-translation/cmphash.reference b/compiler/tests-ocaml/lib-effects/double-translation/cmphash.reference new file mode 100644 index 0000000000..79ebd0860f --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/cmphash.reference @@ -0,0 +1,2 @@ +ok +ok diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune new file mode 100644 index 0000000000..805d2c3d76 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -0,0 +1,463 @@ +(env + (using-effects + (flags + (:standard -w -38)) + (js_of_ocaml + (flags + (:standard --enable effects,doubletranslate)) + (build_runtime_flags + (:standard --enable effects,doubletranslate)) + ;; separate compilation doesn't work when using + ;; features such as 'effects', 'doubletranslate' or 'use-js-string' + ;; because dune doesn't know that it should compile + ;; multiple versions of the dependencies + (compilation_mode whole_program))) + (_ + (flags + (:standard -w -38)) + (js_of_ocaml + (flags + (:standard --enable effects,doubletranslate)) + ;; separate compilation doesn't work when using + ;; features such as 'effects' or 'use-js-string' + ;; because dune doesn't know that it should compile + ;; multiple versions of the dependencies + (compilation_mode whole_program)))) + +(executables + (enabled_if + (>= %{ocaml_version} 5)) + (names + cmphash + marshal + effects + evenodd + manylive + overflow + partial + reperform + sched + shallow_state_io + shallow_state + test10 + test11 + test1 + test2 + test3 + test4 + test5 + test6 + test_lazy + used_cont) + (modules + (:standard \ unhandled_unlinked)) + (modes js)) + +(executables + (enabled_if + (>= %{ocaml_version} 5)) + (names unhandled_unlinked) + (modules unhandled_unlinked) + (modes js)) + +(rule + (target effects.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps effects.bc.js) + (action + (with-stdout-to + %{target} + (run node ./effects.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps effects.reference effects.referencejs) + (action + (diff effects.reference effects.referencejs))) + +(rule + (target evenodd.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps evenodd.bc.js) + (action + (with-stdout-to + %{target} + (run node ./evenodd.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps evenodd.reference evenodd.referencejs) + (action + (diff evenodd.reference evenodd.referencejs))) + +(rule + (target manylive.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps manylive.bc.js) + (action + (with-stdout-to + %{target} + (run node ./manylive.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps manylive.reference manylive.referencejs) + (action + (diff manylive.reference manylive.referencejs))) + +(rule + (target overflow.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps overflow.bc.js) + (action + (with-stdout-to + %{target} + (run node ./overflow.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps overflow.reference overflow.referencejs) + (action + (diff overflow.reference overflow.referencejs))) + +(rule + (target partial.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps partial.bc.js) + (action + (with-stdout-to + %{target} + (run node ./partial.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps partial.reference partial.referencejs) + (action + (diff partial.reference partial.referencejs))) + +(rule + (target reperform.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps reperform.bc.js) + (action + (with-stdout-to + %{target} + (run node ./reperform.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps reperform.reference reperform.referencejs) + (action + (diff reperform.reference reperform.referencejs))) + +(rule + (target sched.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps sched.bc.js) + (action + (with-stdout-to + %{target} + (run node ./sched.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps sched.reference sched.referencejs) + (action + (diff sched.reference sched.referencejs))) + +(rule + (target shallow_state_io.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps shallow_state_io.bc.js) + (action + (with-stdout-to + %{target} + (run node ./shallow_state_io.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps shallow_state_io.reference shallow_state_io.referencejs) + (action + (diff shallow_state_io.reference shallow_state_io.referencejs))) + +(rule + (target shallow_state.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps shallow_state.bc.js) + (action + (with-stdout-to + %{target} + (run node ./shallow_state.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps shallow_state.reference shallow_state.referencejs) + (action + (diff shallow_state.reference shallow_state.referencejs))) + +(rule + (target test10.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test10.bc.js) + (action + (with-stdout-to + %{target} + (run node ./test10.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test10.reference test10.referencejs) + (action + (diff test10.reference test10.referencejs))) + +(rule + (target test11.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test11.bc.js) + (action + (with-stdout-to + %{target} + (run node ./test11.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test11.reference test11.referencejs) + (action + (diff test11.reference test11.referencejs))) + +(rule + (target test1.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test1.bc.js) + (action + (with-stdout-to + %{target} + (run node ./test1.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test1.reference test1.referencejs) + (action + (diff test1.reference test1.referencejs))) + +(rule + (target test2.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test2.bc.js) + (action + (with-stdout-to + %{target} + (run node ./test2.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test2.reference test2.referencejs) + (action + (diff test2.reference test2.referencejs))) + +(rule + (target test3.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test3.bc.js) + (action + (with-stdout-to + %{target} + (run node ./test3.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test3.reference test3.referencejs) + (action + (diff test3.reference test3.referencejs))) + +(rule + (target test4.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test4.bc.js) + (action + (with-stdout-to + %{target} + (run node ./test4.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test4.reference test4.referencejs) + (action + (diff test4.reference test4.referencejs))) + +(rule + (target test5.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test5.bc.js) + (action + (with-stdout-to + %{target} + (run node ./test5.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test5.reference test5.referencejs) + (action + (diff test5.reference test5.referencejs))) + +(rule + (target test6.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test6.bc.js) + (action + (with-stdout-to + %{target} + (run node ./test6.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test6.reference test6.referencejs) + (action + (diff test6.reference test6.referencejs))) + +(rule + (target test_lazy.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test_lazy.bc.js) + (action + (with-stdout-to + %{target} + (run node ./test_lazy.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps test_lazy.reference test_lazy.referencejs) + (action + (diff test_lazy.reference test_lazy.referencejs))) + +(rule + (target unhandled_unlinked.referencejs) + (enabled_if + (and + (>= %{ocaml_version} 5) + (<> %{profile} using-effects))) + (deps unhandled_unlinked.bc.js) + (action + (with-accepted-exit-codes + 2 + (with-outputs-to + %{target} + (run node ./unhandled_unlinked.bc.js))))) + +(rule + (alias runtest) + (enabled_if + (and + (>= %{ocaml_version} 5) + (<> %{profile} using-effects))) + (deps unhandled_unlinked.reference unhandled_unlinked.referencejs) + (action + (diff unhandled_unlinked.reference unhandled_unlinked.referencejs))) + +(rule + (target used_cont.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps used_cont.bc.js) + (action + (with-stdout-to + %{target} + (run node ./used_cont.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps used_cont.reference used_cont.referencejs) + (action + (diff used_cont.reference used_cont.referencejs))) + +(rule + (target cmphash.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps cmphash.bc.js) + (action + (with-stdout-to + %{target} + (run node ./cmphash.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps cmphash.reference cmphash.referencejs) + (action + (diff cmphash.reference cmphash.referencejs))) + +(rule + (target marshal.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps marshal.bc.js) + (action + (with-stdout-to + %{target} + (run node ./marshal.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps marshal.reference marshal.referencejs) + (action + (diff marshal.reference marshal.referencejs))) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/effects.ml b/compiler/tests-ocaml/lib-effects/double-translation/effects.ml new file mode 100644 index 0000000000..f49a585732 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/effects.ml @@ -0,0 +1,226 @@ + +open Effect +open Effect.Deep + +type _ Effect.t += Xchg: int -> int t + +let comp1 () = let a= Xchg 0 in let x= perform a in let b = Xchg 1 in let y = perform b in x+ y +let comp2 () = let _ = perform (Xchg 0) in raise Not_found + +let comp3 () = let _ = perform (Xchg 0) in int_of_string "fdjsl" + +let handle comp = +(* try*) +Format.printf "%d@." @@ +match_with comp () +{ retc = (fun x -> x - 30); + exnc = (fun _ -> 42); + effc = fun (type a) (eff: a t) -> + match eff with + | Xchg n -> Some (fun (k: (a, _) continuation) -> + continue k (n+17)) + | _ -> None } +(*with Not_found -> assert false*) + +let () = handle comp1; handle comp2; handle comp3 + +type 'a status = + Complete of 'a +| Suspended of {msg: int; cont: (int, 'a status) continuation} + + +let step (f : unit -> 'a) () : 'a status = + match_with f () + { retc = (fun v -> Complete v); + exnc = raise; + effc = fun (type a) (eff: a t) -> + match eff with + | Xchg msg -> Some (fun (cont: (a, _) continuation) -> + Suspended {msg; cont}) + | _ -> None } + + +let rec run_both a b = + match a (), b () with + | Complete va, Complete vb -> (va, vb) + | Suspended {msg = m1; cont = k1}, + Suspended {msg = m2; cont = k2} -> + run_both (fun () -> continue k1 m2) + (fun () -> continue k2 m1) + | _ -> failwith "Improper synchronization" + + +let comp2 () = perform (Xchg 21) * perform (Xchg 21) + +let () = let x, y = run_both (step comp1) (step comp2) in Format.printf ">> %d %d@." x y + + +type _ Effect.t += Fork : (unit -> unit) -> unit t + | Yield : unit t + +let fork f = perform (Fork f) +let yield () = perform Yield +let xchg v = perform (Xchg v) + + +(* A concurrent round-robin scheduler *) +let run (main : unit -> unit) : unit = + let exchanger = ref None in (* waiting exchanger *) + let run_q = Queue.create () in (* scheduler queue *) + let enqueue k v = + let task () = continue k v in + Queue.push task run_q + in + let dequeue () = + if Queue.is_empty run_q then () (* done *) + else begin + let task = Queue.pop run_q in + task () + end + in + let rec spawn (f : unit -> unit) : unit = + match_with f () { + retc = dequeue; + exnc = (fun e -> + print_endline (Printexc.to_string e); + dequeue ()); + effc = fun (type a) (eff : a t) -> + match eff with + | Yield -> Some (fun (k : (a, unit) continuation) -> + enqueue k (); dequeue ()) + | Fork f -> Some (fun (k : (a, unit) continuation) -> + enqueue k (); spawn f) + | Xchg n -> Some (fun (k : (int, unit) continuation) -> + begin match !exchanger with + | Some (n', k') -> + exchanger := None; enqueue k' n; continue k n' + | None -> exchanger := Some (n, k); dequeue () + end) + | _ -> None + } + in + spawn main + +let _ = run (fun _ -> + fork (fun _ -> + Format.printf "[t1] Sending 0@."; + let v = xchg 0 in + Format.printf "[t1] received %d@." v); + fork (fun _ -> + Format.printf "[t2] Sending 1@."; + let v = xchg 1 in + Format.printf "[t2] received %d@." v)) + +(*****) + +type _ Effect.t += E : string t + | F : string t + +let foo () = perform F ^ " " ^ perform E ^ " " ^ perform F + +let bar () = + try_with foo () + { effc = fun (type a) (eff: a t) -> + match eff with + | E -> Some (fun (k: (a,_) continuation) -> + continue k "Coucou!") + | _ -> None } + +let baz () = + try_with bar () + { effc = fun (type a) (eff: a t) -> + match eff with + | F -> Some (fun (k: (a,_) continuation) -> + continue k "Hello, world!") + | _ -> None } + +let () = Format.printf "%s@." (baz()) + +(****) + +let () = + Format.printf "%s@." + (try_with (fun () -> try perform F with Not_found -> "Discontinued") () + { effc = fun (type a) (eff: a t) -> + Some (fun k -> discontinue k Not_found) }) +let () = + Format.printf "%s@." + (try_with (fun () -> try perform F with Unhandled _ -> "Unhandled") () + { effc = fun (type a) (eff: a t) -> None }) + +let () = + Format.printf "%s@." (try bar () with Unhandled _ -> "Saw unhandled exception") + +let () = + try + Format.printf "%d@." @@ + try_with perform (Xchg 0) + { effc = fun (type a) (eff : a t) -> + match eff with + | Xchg n -> Some (fun (k: (a, _) continuation) -> + continue k 21 + continue k 21) + | _ -> None } + with Continuation_already_resumed -> + Format.printf "One-shot@." + +(****) + +let invert (type a) ~(iter : (a -> unit) -> unit) : a Seq.t = + let module M = struct + type _ Effect.t += Yield : a -> unit t + end in + let yield v = perform (M.Yield v) in + fun () -> match_with iter yield + { retc = (fun _ -> Seq.Nil); + exnc = raise; + effc = fun (type b) (eff : b Effect.t) -> + match eff with + | M.Yield v -> Some (fun (k: (b,_) continuation) -> + Seq.Cons (v, continue k)) + | _ -> None } + +let s = invert ~iter:(Fun.flip String.iter "OCaml") +let next = Seq.to_dispenser s;; + +let rec loop () = + match next() with Some c -> Format.printf "%c" c; loop() | None -> Format.printf "@." +let () = loop() + +(****) + +type _ Effect.t += Send : int -> unit Effect.t + | Recv : int Effect.t + +open! Effect.Shallow + +let run (comp: unit -> unit) : unit = + let rec loop_send : type a. (a,unit) continuation -> a -> unit = fun k v -> + continue_with k v + { retc = Fun.id; + exnc = raise; + effc = fun (type b) (eff : b Effect.t) -> + match eff with + | Send n -> Some (fun (k: (b,_) continuation) -> + loop_recv n k ()) + | Recv -> failwith "protocol violation" + | _ -> None } + and loop_recv : type a. int -> (a,unit) continuation -> a -> unit = fun n k v -> + continue_with k v + { retc = Fun.id; + exnc = raise; + effc = fun (type b) (eff : b Effect.t) -> + match eff with + | Recv -> Some (fun (k: (b,_) continuation) -> + loop_send k n) + | Send v -> failwith "protocol violation" + | _ -> None } + in + loop_send (fiber comp) () + +let () = run (fun () -> + Format.printf "Send 42@."; + perform (Send 42); + Format.printf "Recv: %d@." (perform Recv); + Format.printf "Send 43@."; + perform (Send 43); + Format.printf "Recv: %d@." (perform Recv)) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/effects.reference b/compiler/tests-ocaml/lib-effects/double-translation/effects.reference new file mode 100644 index 0000000000..fbb6e38647 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/effects.reference @@ -0,0 +1,18 @@ +5 +42 +42 +>> 42 0 +[t1] Sending 0 +[t2] Sending 1 +[t2] received 0 +[t1] received 1 +Hello, world! Coucou! Hello, world! +Discontinued +Unhandled +Saw unhandled exception +One-shot +OCaml +Send 42 +Recv: 42 +Send 43 +Recv: 43 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/evenodd.ml b/compiler/tests-ocaml/lib-effects/double-translation/evenodd.ml new file mode 100644 index 0000000000..035308b58f --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/evenodd.ml @@ -0,0 +1,22 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +type _ t += E : unit t + +let rec even n = + if n = 0 then true + else try_with odd (n-1) + { effc = fun (type a) (e : a t) -> + match e with + | E -> Some (fun k -> assert false) + | _ -> None } +and odd n = + if n = 0 then false + else even (n-1) + +let _ = + let n = 100_000 in + Printf.printf "even %d is %B\n%!" n (even n) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/evenodd.reference b/compiler/tests-ocaml/lib-effects/double-translation/evenodd.reference new file mode 100644 index 0000000000..8682371075 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/evenodd.reference @@ -0,0 +1 @@ +even 100000 is true diff --git a/compiler/tests-ocaml/lib-effects/double-translation/manylive.ml b/compiler/tests-ocaml/lib-effects/double-translation/manylive.ml new file mode 100644 index 0000000000..96e25e23d8 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/manylive.ml @@ -0,0 +1,27 @@ +(* TEST + *) + +let f x = + let a0 = ref 1 in + let a1 = ref 1 in + let a2 = ref 1 in + let a3 = ref 1 in + let a4 = ref 1 in + let a5 = ref 1 in + let a6 = ref 1 in + let a7 = ref 1 in + let a8 = ref 1 in + let a9 = ref 1 in + let a10 = ref 1 in + let a11 = ref 1 in + let a12 = ref 1 in + if x then raise Not_found; + [| a0; a1; a2; a3; a4; a5; a6; a7; a8; a9; a10; a11; a12 |] + +let () = + for i = 1 to 50000 do + let rs = Sys.opaque_identity f false in + assert (Array.for_all (fun x -> !x = 1) rs); + let _ = Array.make (Random.int 30) 'a' in () + done; + print_string "ok\n" diff --git a/compiler/tests-ocaml/lib-effects/double-translation/manylive.reference b/compiler/tests-ocaml/lib-effects/double-translation/manylive.reference new file mode 100644 index 0000000000..9766475a41 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/manylive.reference @@ -0,0 +1 @@ +ok diff --git a/compiler/tests-ocaml/lib-effects/double-translation/marshal.ml b/compiler/tests-ocaml/lib-effects/double-translation/marshal.ml new file mode 100644 index 0000000000..6c754073e2 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/marshal.ml @@ -0,0 +1,21 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +type _ t += E : string t + +let _ = + try_with perform E + { effc = fun (type a) (e : a t) -> + Some (fun k -> + (* We have to make sure that neither the match nor the call + to Marshal.to_string are eliminated, so we call + print_string and we print the result of the marshalling + function. *) + match print_string ""; + Stdlib.Marshal.to_string k [] with + | x -> Printf.printf "%S" x; assert false + | exception (Invalid_argument _) -> print_endline "ok"; "" + ) } diff --git a/compiler/tests-ocaml/lib-effects/double-translation/marshal.reference b/compiler/tests-ocaml/lib-effects/double-translation/marshal.reference new file mode 100644 index 0000000000..9766475a41 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/marshal.reference @@ -0,0 +1 @@ +ok diff --git a/compiler/tests-ocaml/lib-effects/double-translation/overflow.ml b/compiler/tests-ocaml/lib-effects/double-translation/overflow.ml new file mode 100644 index 0000000000..a187e9e10d --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/overflow.ml @@ -0,0 +1,40 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +type _ t += E : unit t + +let f a b c d e f g h = + let bb = b + b in + let bbb = bb + b in + let cc = c + c in + let ccc = cc + c in + let dd = d + d in + let ddd = dd + d in + let ee = e + e in + let eee = ee + e in + let ff = f + f in + let fff = ff + f in + let gg = g + g in + let ggg = gg + g in + let hh = h + h in + let hhh = hh + h in + min 20 a + + b + bb + bbb + + c + cc + ccc + + d + dd + ddd + + e + ee + eee + + f + ff + fff + + g + gg + ggg + + h + hh + hhh + +let () = + match_with (fun _ -> f 1 2 3 4 5 6 7 8) () + { retc = (fun n -> Printf.printf "%d\n" n); + exnc = (fun e -> raise e); + effc = fun (type a) (e : a t) -> + match e with + | E -> Some (fun k -> assert false) + | _ -> None } diff --git a/compiler/tests-ocaml/lib-effects/double-translation/overflow.reference b/compiler/tests-ocaml/lib-effects/double-translation/overflow.reference new file mode 100644 index 0000000000..dba40afcf7 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/overflow.reference @@ -0,0 +1 @@ +211 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/partial.ml b/compiler/tests-ocaml/lib-effects/double-translation/partial.ml new file mode 100644 index 0000000000..50e4b53cfc --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/partial.ml @@ -0,0 +1,28 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +type _ t += E : unit t +exception Done + +let handle_partial f = + try_with f () + { effc = fun (type a) (e : a t) -> + match e with + | E -> Some (fun k -> assert false) + | _ -> None } + +let f () x = perform E + +let () = + match_with (handle_partial f) () + { retc = (fun x -> assert false); + exnc = (function + | Done -> print_string "ok\n" + | e -> raise e); + effc = fun (type a) (e : a t) -> + match e with + | E -> Some (fun (k : (a, _) continuation) -> discontinue k Done) + | _ -> None } diff --git a/compiler/tests-ocaml/lib-effects/double-translation/partial.reference b/compiler/tests-ocaml/lib-effects/double-translation/partial.reference new file mode 100644 index 0000000000..9766475a41 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/partial.reference @@ -0,0 +1 @@ +ok diff --git a/compiler/tests-ocaml/lib-effects/double-translation/reperform.ml b/compiler/tests-ocaml/lib-effects/double-translation/reperform.ml new file mode 100644 index 0000000000..8aefdd0587 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/reperform.ml @@ -0,0 +1,37 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +type _ t += E : int -> int t + | F : unit t + +let rec nest = function + | 0 -> perform (E 42) + | n -> + match_with (fun _ -> Printf.printf "[%d\n" n; nest (n - 1)) () + { retc = (fun x -> Printf.printf " %d]\n" n; x); + exnc = (fun e -> Printf.printf " !%d]\n" n; raise e); + effc = fun (type a) (e : a t) -> + match e with + | F -> Some (fun k -> assert false) + | _ -> None } + +let () = + match_with nest 5 + { retc = (fun x -> Printf.printf "= %d\n" x); + exnc = (fun e -> raise e); + effc = fun (type a) (e : a t) -> + match e with + | E n -> Some (fun (k : (a, _) continuation) -> continue k (n + 100)) + | _ -> None } + +let () = + match_with nest 5 + { retc = (fun x -> assert false); + exnc = (fun e -> Printf.printf "%s\n" (Printexc.to_string e)); + effc = fun (type a) (e : a t) -> + match e with + | F -> Some (fun k -> assert false) + | _ -> None } diff --git a/compiler/tests-ocaml/lib-effects/double-translation/reperform.reference b/compiler/tests-ocaml/lib-effects/double-translation/reperform.reference new file mode 100644 index 0000000000..4028fa8350 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/reperform.reference @@ -0,0 +1,22 @@ +[5 +[4 +[3 +[2 +[1 + 1] + 2] + 3] + 4] + 5] += 142 +[5 +[4 +[3 +[2 +[1 + !1] + !2] + !3] + !4] + !5] +Stdlib.Effect.Unhandled(Dune__exe__Reperform.E(42)) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/sched.ml b/compiler/tests-ocaml/lib-effects/double-translation/sched.ml new file mode 100644 index 0000000000..3dc14a2cfc --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/sched.ml @@ -0,0 +1,65 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +exception E +type _ t += Yield : unit t + | Fork : (unit -> string) -> unit t + | Ping : unit t +exception Pong + +let say = print_string + +let run main = + let run_q = Queue.create () in + let enqueue k = Queue.push k run_q in + let rec dequeue () = + if Queue.is_empty run_q then `Finished + else continue (Queue.pop run_q) () + in + let rec spawn f = + match_with f () + { retc = (function + | "ok" -> say "."; dequeue () + | s -> failwith ("Unexpected result: " ^ s)); + exnc = (function + | E -> say "!"; dequeue () + | e -> raise e); + effc = fun (type a) (e : a t) -> + match e with + | Yield -> Some (fun (k : (a, _) continuation) -> + say ","; enqueue k; dequeue ()) + | Fork f -> Some (fun (k : (a, _) continuation) -> + say "+"; enqueue k; spawn f) + | Ping -> Some (fun (k : (a, _) continuation) -> + say "["; discontinue k Pong) + | _ -> None } + in + spawn main + +let test () = + say "A"; + perform (Fork (fun () -> + perform Yield; say "C"; perform Yield; + begin match_with (fun () -> perform Ping; failwith "no pong?") () + { retc = (fun x -> x); + exnc = (function + | Pong -> say "]" + | e -> raise e); + effc = fun (type a) (e : a t) -> + match e with + | Yield -> Some (fun (k : (a,_) continuation) -> failwith "what?") + | _ -> None } + end; + raise E)); + perform (Fork (fun () -> say "B"; "ok")); + say "D"; + perform Yield; + say "E"; + "ok" + +let () = + let `Finished = run test in + say "\n" diff --git a/compiler/tests-ocaml/lib-effects/double-translation/sched.reference b/compiler/tests-ocaml/lib-effects/double-translation/sched.reference new file mode 100644 index 0000000000..47294f1ef7 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/sched.reference @@ -0,0 +1 @@ +A+,+B.C,D,[]!E. diff --git a/compiler/tests-ocaml/lib-effects/double-translation/shallow_state.ml b/compiler/tests-ocaml/lib-effects/double-translation/shallow_state.ml new file mode 100644 index 0000000000..56c61b0c3c --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/shallow_state.ml @@ -0,0 +1,48 @@ +(* TEST + *) + +open Effect +open Effect.Shallow + +(* +let handle_state init f x = + let rec loop state k x = + continue k x with + | result -> result, state + | effect Get, k -> loop state k state + | effect Set new_state, k -> loop new_state k () + in + loop init (fiber f) x +*) + +type _ t += Get : int t + | Set : int -> unit t + +let handle_state init f x = + let rec loop : type a r. int -> (a, r) continuation -> a -> r * int = + fun state k x -> + continue_with k x + { retc = (fun result -> result, state); + exnc = (fun e -> raise e); + effc = (fun (type b) (eff : b t) -> + match eff with + | Get -> Some (fun (k : (b,r) continuation) -> + loop state k state) + | Set new_state -> Some (fun (k : (b,r) continuation) -> + loop new_state k ()) + | e -> None) } + in + loop init (fiber f) x + + +let comp () = + Printf.printf "Initial state: %d\n" (perform Get); + perform (Set 42); + Printf.printf "Updated state: %d\n" (perform Get); + perform (Set 43) + +let main () = + let (), i = handle_state 0 comp () in + Printf.printf "Final state: %d\n" i + +let _ = main () diff --git a/compiler/tests-ocaml/lib-effects/double-translation/shallow_state.reference b/compiler/tests-ocaml/lib-effects/double-translation/shallow_state.reference new file mode 100644 index 0000000000..6cb73dd1e2 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/shallow_state.reference @@ -0,0 +1,3 @@ +Initial state: 0 +Updated state: 42 +Final state: 43 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.ml b/compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.ml new file mode 100644 index 0000000000..6b1fa649a7 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.ml @@ -0,0 +1,51 @@ +(* TEST + *) + +open Effect +open Effect.Shallow + +type _ t += Get : int t + | Set : int -> unit t + | Print : string -> unit t + +let handle_state init f x = + let rec loop : type a r. int -> (a, r) continuation -> a -> r * int = + fun state k x -> + continue_with k x + { retc = (fun result -> result, state); + exnc = (fun e -> raise e); + effc = (fun (type b) (eff : b t) -> + match eff with + | Get -> Some (fun (k : (b,r) continuation) -> + loop state k state) + | Set new_state -> Some (fun (k : (b,r) continuation) -> + loop new_state k ()) + | e -> None) } + in + loop init (fiber f) x + +let handle_print f = + let rec loop : type r. (unit, r) continuation -> r = + fun k -> + continue_with k () + { retc = (fun x -> x); + exnc = (fun e -> raise e); + effc = (fun (type a) (eff : a t) -> + match eff with + | Print s -> Some (fun (k : (a,r) continuation) -> + print_string s; loop k) + | e -> None) } + in + loop (fiber f) + +let comp () = + perform (Print (Printf.sprintf "Initial state: %d\n" (perform Get))); + perform (Set 42); + perform (Print (Printf.sprintf "Updated state: %d\n" (perform Get))); + perform (Set 43) + +let main () = + let (), i = handle_print (handle_state 0 comp) in + Printf.printf "Final state: %d\n" i + +let _ = main () diff --git a/compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.reference b/compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.reference new file mode 100644 index 0000000000..6cb73dd1e2 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.reference @@ -0,0 +1,3 @@ +Initial state: 0 +Updated state: 42 +Final state: 43 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test1.ml b/compiler/tests-ocaml/lib-effects/double-translation/test1.ml new file mode 100644 index 0000000000..5d05359f8a --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test1.ml @@ -0,0 +1,15 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +type _ t += E : unit t + +let () = + Printf.printf "%d\n%!" @@ + try_with (fun x -> x) 10 + { effc = (fun (type a) (e : a t) -> + match e with + | E -> Some (fun k -> 11) + | e -> None) } diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test1.reference b/compiler/tests-ocaml/lib-effects/double-translation/test1.reference new file mode 100644 index 0000000000..f599e28b8a --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test1.reference @@ -0,0 +1 @@ +10 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test10.ml b/compiler/tests-ocaml/lib-effects/double-translation/test10.ml new file mode 100644 index 0000000000..29c5f47f25 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test10.ml @@ -0,0 +1,34 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +type _ t += Peek : int t +type _ t += Poke : unit t + +let rec a i = perform Peek + Random.int i +let rec b i = a i + Random.int i +let rec c i = b i + Random.int i + +let rec d i = + Random.int i + + try_with c i + { effc = fun (type a) (e : a t) -> + match e with + | Poke -> Some (fun (k : (a,_) continuation) -> continue k ()) + | _ -> None } + +let rec e i = + Random.int i + + try_with d i + { effc = fun (type a) (e : a t) -> + match e with + | Peek -> Some (fun (k : (a,_) continuation) -> + ignore (Deep.get_callstack k 100); + continue k 42) + | _ -> None } + +let _ = + ignore (e 1); + print_string "ok\n" diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test10.reference b/compiler/tests-ocaml/lib-effects/double-translation/test10.reference new file mode 100644 index 0000000000..9766475a41 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test10.reference @@ -0,0 +1 @@ +ok diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test11.ml b/compiler/tests-ocaml/lib-effects/double-translation/test11.ml new file mode 100644 index 0000000000..6714473e0e --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test11.ml @@ -0,0 +1,22 @@ +(* TEST +*) + +(* Tests RESUMETERM with extra_args != 0 in bytecode, + by calling a handler with a tail-continue that returns a function *) + +open Effect +open Effect.Deep + +type _ t += E : int t + +let handle comp = + try_with comp () + { effc = fun (type a) (e : a t) -> + match e with + | E -> Some (fun (k : (a,_) continuation) -> continue k 10) + | _ -> None } + +let () = + handle (fun () -> + Printf.printf "%d\n" (perform E); + Printf.printf "%d\n") 42 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test11.reference b/compiler/tests-ocaml/lib-effects/double-translation/test11.reference new file mode 100644 index 0000000000..5c8f9eaff1 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test11.reference @@ -0,0 +1,2 @@ +10 +42 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test2.ml b/compiler/tests-ocaml/lib-effects/double-translation/test2.ml new file mode 100644 index 0000000000..e9b8289bb2 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test2.ml @@ -0,0 +1,30 @@ +(* TEST + *) + +open Printf +open Effect +open Effect.Deep + +type _ t += E : int -> int t + +let f () = + printf "perform effect (E 0)\n%!"; + let v = perform (E 0) in + printf "perform returns %d\n%!" v; + v + 1 + +let h : type a. a t -> ((a, 'b) continuation -> 'b) option = function + | E v -> Some (fun k -> + printf "caught effect (E %d). continuing..\n%!" v; + let v = continue k (v + 1) in + printf "continue returns %d\n%!" v; + v + 1) + | e -> None + +let v = + match_with f () + { retc = (fun v -> printf "done %d\n%!" v; v + 1); + exnc = (fun e -> raise e); + effc = h } + +let () = printf "result=%d\n%!" v diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test2.reference b/compiler/tests-ocaml/lib-effects/double-translation/test2.reference new file mode 100644 index 0000000000..652e4a6429 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test2.reference @@ -0,0 +1,6 @@ +perform effect (E 0) +caught effect (E 0). continuing.. +perform returns 1 +done 2 +continue returns 3 +result=4 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test3.ml b/compiler/tests-ocaml/lib-effects/double-translation/test3.ml new file mode 100644 index 0000000000..d76130eaaa --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test3.ml @@ -0,0 +1,22 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +type _ t += E : unit t +exception X + +let () = + Printf.printf "%d\n%!" @@ + match_with (fun () -> + Printf.printf "in handler. raising X\n%!"; + raise X) () + { retc = (fun v -> v); + exnc = (function + | X -> 10 + | e -> raise e); + effc = (fun (type a) (e : a t) -> + match e with + | E -> Some (fun k -> 11) + | e -> None) } diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test3.reference b/compiler/tests-ocaml/lib-effects/double-translation/test3.reference new file mode 100644 index 0000000000..78ea20d6e8 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test3.reference @@ -0,0 +1,2 @@ +in handler. raising X +10 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test4.ml b/compiler/tests-ocaml/lib-effects/double-translation/test4.ml new file mode 100644 index 0000000000..f5cf78cbda --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test4.ml @@ -0,0 +1,21 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +type _ t += Foo : int -> int t + +let r = + try_with perform (Foo 3) + { effc = fun (type a) (e : a t) -> + match e with + | Foo i -> Some (fun (k : (a,_) continuation) -> + try_with (continue k) (i+1) + { effc = fun (type a) (e : a t) -> + match e with + | Foo i -> Some (fun k -> failwith "NO") + | e -> None }) + | e -> None } + +let () = Printf.printf "%d\n" r diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test4.reference b/compiler/tests-ocaml/lib-effects/double-translation/test4.reference new file mode 100644 index 0000000000..b8626c4cff --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test4.reference @@ -0,0 +1 @@ +4 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test5.ml b/compiler/tests-ocaml/lib-effects/double-translation/test5.ml new file mode 100644 index 0000000000..33ed2c23ca --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test5.ml @@ -0,0 +1,24 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +type _ t += Foo : int -> int t + +let f () = (perform (Foo 3)) (* 3 + 1 *) + + (perform (Foo 3)) (* 3 + 1 *) + +let r = + try_with f () + { effc = fun (type a) (e : a t) -> + match e with + | Foo i -> Some (fun (k : (a, _) continuation) -> + try_with (continue k) (i + 1) + { effc = fun (type a) (e : a t) -> + match e with + | Foo i -> Some (fun k -> failwith "NO") + | _ -> None }) + | e -> None } + +let () = Printf.printf "%d\n" r diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test5.reference b/compiler/tests-ocaml/lib-effects/double-translation/test5.reference new file mode 100644 index 0000000000..45a4fb75db --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test5.reference @@ -0,0 +1 @@ +8 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test6.ml b/compiler/tests-ocaml/lib-effects/double-translation/test6.ml new file mode 100644 index 0000000000..40574561bf --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test6.ml @@ -0,0 +1,30 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +type _ t += E : unit t + | F : unit t + +let () = + let ok1 = ref false + and ok2 = ref true + and ok3 = ref false in + let f e r = + try perform e with + | Unhandled E -> r := not !r + in + f E ok1; + Printf.printf "%b\n%!" !ok1; + + begin try f F ok2 with Unhandled _ -> () end; + Printf.printf "%b\n%!" !ok2; + + try_with (f E) ok3 { + effc = fun (type a) (e : a t) -> + match e with + | F -> Some (fun k -> assert false) + | _ -> None + }; + Printf.printf "%b\n%!" !ok3 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test6.reference b/compiler/tests-ocaml/lib-effects/double-translation/test6.reference new file mode 100644 index 0000000000..b979d62f4f --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test6.reference @@ -0,0 +1,3 @@ +true +true +true diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test_lazy.ml b/compiler/tests-ocaml/lib-effects/double-translation/test_lazy.ml new file mode 100644 index 0000000000..24f457f0af --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test_lazy.ml @@ -0,0 +1,49 @@ +(* TEST *) + +open Effect +open Effect.Deep + +type _ t += Stop : unit t + +let f count = + let r = ref 0 in + for i = 1 to count do + incr r; + if i = count / 2 then perform Stop + done; + !r + +let _ = + let l = lazy (f 1_000) in + let v1 = + try_with Lazy.force l + { effc = fun (type a) (e : a t) -> + match e with + | Stop -> Some (fun (k : (a, _) continuation) -> continue k ()) + | _ -> None } + in + Printf.printf "%d\n" v1; + let l2 = lazy (f 2_000) in + let v2 = + try_with Lazy.force l2 + { effc = fun (type a) (e : a t) -> + match e with + | Stop -> Some (fun (k : (a, _) continuation) -> + let d = Domain.spawn(fun () -> continue k ()) in + Domain.join d) + | _ -> None } + in + Printf.printf "%d\n" v2; + let l3 = lazy (f 3_000) in + let _ = + try_with Lazy.force l3 + { effc = fun (type a) (e : a t) -> + match e with + | Stop -> Some (fun _ -> + try + let d = Domain.spawn(fun () -> Lazy.force l3) in + Domain.join d + with CamlinternalLazy.Undefined -> Printf.printf "Undefined\n"; 0) + | _ -> None } + in + () diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test_lazy.reference b/compiler/tests-ocaml/lib-effects/double-translation/test_lazy.reference new file mode 100644 index 0000000000..3e572fff4a --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/test_lazy.reference @@ -0,0 +1,3 @@ +1000 +2000 +Undefined diff --git a/compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.ml b/compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.ml new file mode 100644 index 0000000000..bc2badb8e8 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.ml @@ -0,0 +1,7 @@ +(* TEST + exit_status= "2" +*) + +open Effect +type _ t += E : unit t +let _ = perform E diff --git a/compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.reference b/compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.reference new file mode 100644 index 0000000000..73cee5f415 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.reference @@ -0,0 +1 @@ +Fatal error: exception Effect.Unhandled diff --git a/compiler/tests-ocaml/lib-effects/double-translation/used_cont.ml b/compiler/tests-ocaml/lib-effects/double-translation/used_cont.ml new file mode 100644 index 0000000000..71a33388ec --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/used_cont.ml @@ -0,0 +1,21 @@ +(* TEST + *) + +open Effect +open Effect.Deep + +type _ t += E : unit t + +let r = ref None +let () = + match_with (fun _ -> perform E; 42) () + { retc = (fun n -> assert (n = 42)); + exnc = (fun e -> raise e); + effc = fun (type a) (e : a t) -> + match e with + | E -> Some (fun (k : (a,_) continuation) -> + continue k (); + r := Some (k : (unit, unit) continuation); + Gc.full_major (); + print_string "ok\n") + | _ -> None } diff --git a/compiler/tests-ocaml/lib-effects/double-translation/used_cont.reference b/compiler/tests-ocaml/lib-effects/double-translation/used_cont.reference new file mode 100644 index 0000000000..9766475a41 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/used_cont.reference @@ -0,0 +1 @@ +ok diff --git a/runtime/js/effect.js b/runtime/js/effect.js index d80a444932..2751e96d62 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -41,6 +41,11 @@ is resumed first. 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 +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 @@ -68,6 +73,25 @@ function caml_pop_trap() { return h; } +//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); + 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); + } +} + //Provides: caml_fiber_stack //If: effects // This has the shape {h, r:{k, x, e}} where h is a triple of handlers @@ -75,6 +99,17 @@ function caml_pop_trap() { // exception stack and fiber stack of the parent fiber. 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 }, + }; +} + //Provides:caml_resume_stack //Requires: caml_named_value, caml_raise_constant, caml_exn_stack, caml_fiber_stack //If: effects @@ -108,8 +143,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 @@ -124,18 +173,48 @@ function caml_perform_effect(eff, cont, k0) { var k1 = caml_pop_fiber(); return caml_stack_check_depth() ? handler(eff, cont, k1, k1) - : caml_trampoline_return(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, 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(f, args) + ? caml_call_fun(f, args) : caml_trampoline_return(f, args); } function hval(x) { @@ -146,7 +225,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], 0]; + return [0, hval, [0, hexn, 0], [0, hv, hx, caml_get_fun(hf)], 0]; } //Provides: caml_alloc_stack @@ -206,3 +285,33 @@ function caml_ml_condition_signal(t) { function jsoo_effect_not_supported() { caml_failwith("Effect handlers are 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 }; + do { + caml_stack_depth = 40; + try { + res = caml_call_gen_cps(res.joo_tramp, res.joo_args); + } catch (e) { + /* Handle exception coming from JavaScript or from the runtime. */ + if (!caml_exn_stack.length) throw e; + var handler = caml_exn_stack[1]; + caml_exn_stack = caml_exn_stack[2]; + res = { joo_tramp: { cps: handler }, joo_args: [caml_wrap_exception(e)] }; + } + } while (res && res.joo_args); + return res; +} + +//Provides: caml_cps_closure +//If: effects +//If: doubletranslate +function caml_cps_closure(direct_f, cps_f) { + direct_f.cps = cps_f; + return direct_f; +} diff --git a/runtime/js/jslib.js b/runtime/js/jslib.js index b7d78e6d8c..fceb2ca61c 100644 --- a/runtime/js/jslib.js +++ b/runtime/js/jslib.js @@ -67,7 +67,8 @@ function caml_trampoline_return(f, args) { //Provides:caml_stack_depth //If: effects -var caml_stack_depth = 0; +var caml_stack_depth = 10; // Initialized to a non-zero value in case of +// unhandled effect //Provides:caml_stack_check_depth //If: effects @@ -83,6 +84,7 @@ 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) { @@ -135,6 +137,43 @@ function caml_callback(f, args) { 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) { + 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 }, + }; + return caml_call_gen(f, args); + } finally { + caml_stack_depth = saved_stack_depth; + caml_exn_stack = saved_exn_stack; + caml_fiber_stack = saved_fiber_stack; + } +} + //Provides: caml_is_js function caml_is_js() { return 1; diff --git a/runtime/js/stdlib.js b/runtime/js/stdlib.js index 433f53ab7c..f1df6eb9a6 100644 --- a/runtime/js/stdlib.js +++ b/runtime/js/stdlib.js @@ -68,14 +68,14 @@ function caml_call_gen(f, args) { //Provides: caml_call_gen (const, shallow) //If: effects +//If: !doubletranslate //Weakdef function caml_call_gen(f, args) { var n = f.l >= 0 ? f.l : (f.l = f.length); var argsLen = args.length; var d = n - argsLen; - if (d === 0) { - return f.apply(null, args); - } else if (d < 0) { + if (d === 0) return f(...args); + else if (d < 0) { var rest = args.slice(n - 1); var k = args[argsLen - 1]; args = args.slice(0, n); @@ -85,7 +85,7 @@ function caml_call_gen(f, args) { args[args.length - 1] = k; return caml_call_gen(g, args); }; - return f.apply(null, args); + return f(...args); } else { argsLen--; var k = args[argsLen]; @@ -127,6 +127,109 @@ function caml_call_gen(f, args) { } } +//Provides: caml_call_gen_tuple (const, shallow) +//Requires: caml_fiber_stack, caml_cps_closure +//If: effects +//If: doubletranslate +//Weakdef +var caml_call_gen_tuple = (function () { + function caml_call_gen_direct(f, args) { + var n = f.l >= 0 ? f.l : (f.l = f.length); + var argsLen = args.length; + var d = n - argsLen; + if (d === 0) { + return f.apply(null, args); + } else if (d < 0) { + return caml_call_gen_direct( + f.apply(null, args.slice(0, n)), + args.slice(n), + ); + } else { + // FIXME: Restore the optimization of handling specially d = 1 or 2 + var ret = caml_cps_closure( + function () { + var extra_args = arguments.length === 0 ? 1 : arguments.length; + var nargs = new Array(args.length + extra_args); + for (var i = 0; i < args.length; i++) nargs[i] = args[i]; + for (var i = 0; i < arguments.length; i++) + nargs[args.length + i] = arguments[i]; + return caml_call_gen_direct(f, nargs); + }, + function () { + var extra_args = arguments.length === 0 ? 1 : arguments.length; + var nargs = new Array(argsLen + extra_args); + for (var i = 0; i < argsLen; i++) nargs[i] = args[i]; + for (var i = 0; i < arguments.length; i++) + nargs[argsLen + i] = arguments[i]; + var cont = nargs[argsLen + extra_args - 1]; + return caml_call_gen_cps(f, nargs); + }, + ); + ret.l = d; + ret.cps.l = d + 1; + return ret; + } + } + function caml_call_gen_cps(f, args) { + var n = f.cps.l >= 0 ? f.cps.l : (f.cps.l = f.cps.length); + if (n === 0) return f.cps.apply(null, args); + var argsLen = args.length; + var d = n - argsLen; + if (d === 0) { + return f.cps.apply(null, args); + } else if (d < 0) { + var rest = args.slice(n - 1); + var k = args[argsLen - 1]; + args = args.slice(0, n); + args[n - 1] = function (g) { + var args = rest.slice(); + args[args.length - 1] = k; + return caml_call_gen_cps(g, args); + }; + return f.cps.apply(null, args); + } else { + argsLen--; + var k = args[argsLen]; + var cont = caml_cps_closure( + function () { + var extra_args = arguments.length === 0 ? 1 : arguments.length; + var nargs = new Array(argsLen + extra_args); + for (var i = 0; i < argsLen; i++) nargs[i] = args[i]; + for (var i = 0; i < arguments.length; i++) + nargs[argsLen + i] = arguments[i]; + return caml_call_gen_direct(f, nargs); + }, + function () { + var extra_args = arguments.length === 0 ? 1 : arguments.length; + var nargs = new Array(argsLen + extra_args); + for (var i = 0; i < argsLen; i++) nargs[i] = args[i]; + for (var i = 0; i < arguments.length; i++) + nargs[argsLen + i] = arguments[i]; + return caml_call_gen_cps(f, nargs); + }, + ); + cont.l = d; + cont.cps.l = d + 1; + return k(cont); + } + } + return [caml_call_gen_direct, caml_call_gen_cps]; +})(); + +//Provides: caml_call_gen +//Requires: caml_call_gen_tuple +//If: effects +//If: doubletranslate +//Weakdef +var caml_call_gen = caml_call_gen_tuple[0]; + +//Provides: caml_call_gen_cps +//Requires: caml_call_gen_tuple +//If: effects +//If: doubletranslate +//Weakdef +var caml_call_gen_cps = caml_call_gen_tuple[1]; + //Provides: caml_named_values var caml_named_values = {}; diff --git a/runtime/js/stdlib_modern.js b/runtime/js/stdlib_modern.js index ab779fa6c3..944dc94351 100644 --- a/runtime/js/stdlib_modern.js +++ b/runtime/js/stdlib_modern.js @@ -66,6 +66,8 @@ function caml_call_gen(f, args) { //Provides: caml_call_gen (const, shallow) //If: effects +//If: !doubletranslate +//Weakdef function caml_call_gen(f, args) { var n = f.l >= 0 ? f.l : (f.l = f.length); var argsLen = args.length; @@ -122,3 +124,103 @@ function caml_call_gen(f, args) { return k(g); } } + +//Provides: caml_call_gen_tuple (const, shallow) +//Requires: caml_fiber_stack, caml_cps_closure +//If: effects +//If: doubletranslate +//Weakdef +var caml_call_gen_tuple = (function () { + function caml_call_gen_direct(f, args) { + var n = f.l >= 0 ? f.l : (f.l = f.length); + var argsLen = args.length; + var d = n - argsLen; + if (d === 0) { + return f(...args); + } else if (d < 0) { + return caml_call_gen_direct(f.apply(...args.slice(0, n)), args.slice(n)); + } else { + // FIXME: Restore the optimization of handling specially d = 1 or 2 + var ret = caml_cps_closure( + function () { + var extra_args = arguments.length + extra_args; + var nargs = new Array(args.length + extra_args); + for (var i = 0; i < args.length; i++) nargs[i] = args[i]; + for (var i = 0; i < arguments.length; i++) + nargs[args.length + i] = arguments[i]; + return caml_call_gen_direct(f, nargs); + }, + function () { + var extra_args = arguments.length === 0 ? 1 : arguments.length; + var nargs = new Array(argsLen + extra_args); + for (var i = 0; i < argsLen; i++) nargs[i] = args[i]; + for (var i = 0; i < arguments.length; i++) + nargs[argsLen + i] = arguments[i]; + var cont = nargs[argsLen + extra_args - 1]; + return caml_call_gen_cps(f, nargs); + }, + ); + ret.l = d; + ret.cps.l = d + 1; + return ret; + } + } + function caml_call_gen_cps(f, args) { + var n = f.cps.l >= 0 ? f.cps.l : (f.cps.l = f.cps.length); + if (n === 0) return f.cps(...args); + var argsLen = args.length; + var d = n - argsLen; + if (d === 0) { + return f.cps(...args); + } else if (d < 0) { + var rest = args.slice(n - 1); + var k = args[argsLen - 1]; + args = args.slice(0, n); + args[n - 1] = function (g) { + var args = rest.slice(); + args[args.length - 1] = k; + return caml_call_gen_cps(g, args); + }; + return f.cps(...args); + } else { + argsLen--; + var k = args[argsLen]; + var cont = caml_cps_closure( + function () { + var extra_args = arguments.length === 0 ? 1 : arguments.length; + var nargs = new Array(argsLen + extra_args); + for (var i = 0; i < argsLen; i++) nargs[i] = args[i]; + for (var i = 0; i < arguments.length; i++) + nargs[argsLen + i] = arguments[i]; + return caml_call_gen_direct(f, nargs); + }, + function () { + var extra_args = arguments.length === 0 ? 1 : arguments.length; + var nargs = new Array(argsLen + extra_args); + for (var i = 0; i < argsLen; i++) nargs[i] = args[i]; + for (var i = 0; i < arguments.length; i++) + nargs[argsLen + i] = arguments[i]; + return caml_call_gen_cps(f, nargs); + }, + ); + cont.l = d; + cont.cps.l = d + 1; + return k(cont); + } + } + return [caml_call_gen_direct, caml_call_gen_cps]; +})(); + +//Provides: caml_call_gen +//Requires: caml_call_gen_tuple +//If: effects +//If: doubletranslate +//Weakdef +var caml_call_gen = caml_call_gen_tuple[0]; + +//Provides: caml_call_gen_cps +//Requires: caml_call_gen_tuple +//If: effects +//If: doubletranslate +//Weakdef +var caml_call_gen_cps = caml_call_gen_tuple[1]; From a34c448d9cad44c709f49c924a2fc8544fa666e3 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 11 Jun 2024 15:08:11 +0200 Subject: [PATCH 2/2] Add caml_assume_no_effects primitive and tests Passing a function [f] as argument of `caml_assume_no_effects` guarantees that, when compiling with `--enable doubletranslate`, the direct-style version of [f] is called, which is faster than the CPS version. As a consequence, performing an effect in a transitive callee of [f] will raise `Effect.Unhandled`, regardless of any effect handlers installed before the call to `caml_assume_no_effects`, unless a new effect handler was installed in the meantime. Usage: ``` external assume_no_effects : (unit -> 'a) -> 'a = "caml_assume_no_effects" ... caml_assume_no_effects (fun () -> (* Will be called in direct style... *)) ... ``` When double translation is disabled, `caml_assume_no_effects` simply acts like `fun f -> f ()`. This primitive is exposed via `Js_of_ocaml.Js.Effect.assume_no_perform`. --- compiler/lib/effects.ml | 85 ++++++++- compiler/lib/partial_cps_analysis.ml | 13 ++ compiler/tests-check-prim/main.output | 1 + compiler/tests-check-prim/main.output5 | 1 + compiler/tests-check-prim/unix-unix.output | 1 + compiler/tests-check-prim/unix-unix.output5 | 1 + compiler/tests-check-prim/unix-win32.output | 1 + compiler/tests-check-prim/unix-win32.output5 | 1 + .../lib-effects/assume_no_perform.ml | 164 ++++++++++++++++++ .../double-translation/assume_no_perform.ml | 164 ++++++++++++++++++ .../lib-effects/double-translation/dune | 17 ++ compiler/tests-ocaml/lib-effects/dune | 17 ++ lib/js_of_ocaml/js.ml | 6 + lib/js_of_ocaml/js.mli | 14 ++ lib/js_of_ocaml/js_of_ocaml_stubs.c | 4 + 15 files changed, 483 insertions(+), 7 deletions(-) create mode 100644 compiler/tests-ocaml/lib-effects/assume_no_perform.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform.ml diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index a9c6b492cf..1cd6850ab2 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -168,6 +168,16 @@ let empty_body b = (****) +let effect_primitive_or_application = function + | Prim (Extern ("%resume" | "%perform" | "%reperform" | "caml_assume_no_perform"), _) + | Apply _ -> true + | Block (_, _, _, _) + | Field (_, _, _) + | Closure (_, _) + | Constant _ + | Prim (_, _) + | Special _ -> false + (* We establish the list of blocks that needs to be CPS-transformed. We also mark blocks that correspond to function continuations or @@ -204,10 +214,8 @@ let compute_needed_transformations ~cfg ~idom ~cps_needed ~blocks ~start = (match block.branch with | Branch (dst, _) -> ( match last_instr block.body with - | Some - (Let - (x, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _)))) - when Var.Set.mem x cps_needed -> + | Some (Let (x, e)) + when effect_primitive_or_application e && Var.Set.mem x cps_needed -> (* The block after a function application that needs to be turned to CPS or an effect primitive needs to be transformed. *) @@ -739,7 +747,39 @@ let cps_instr ~st (instr : instr) : instr list = (* Nothing to do for single-version functions. *) [ instr ] | Let (_, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> + (* Applications of CPS functions and effect primitives require more work + (allocating a continuation and/or modifying end-of-block branches) and + are handled in a specialized function below. *) assert false + | Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) -> + if double_translate () + then + (* We just need to call [f] in direct style. *) + let unit = Var.fresh_n "unit" in + let exact = Global_flow.exact_call st.flow_info f 1 in + [ Let (unit, Constant (Int Targetint.zero)) + ; Let (x, Apply { exact; f; args = [ unit ] }) + ] + else ( + (* The "needs CPS" case should have been taken care of by another, specialized + function below. *) + assert (not (Var.Set.mem x st.cps_needed)); + (* Translated like the [Apply] case, with a unit argument *) + assert ( + (* If this function is unknown to the global flow analysis, then it was + introduced by the lambda lifting and does not require CPS *) + Var.idx f >= Var.Tbl.length st.flow_info.info_approximation + || Global_flow.exact_call st.flow_info f 1); + let unit = Var.fresh_n "unit" in + [ Let (unit, Constant (Int Targetint.zero)) + ; Let (x, Apply { f; args = [ unit ]; exact = true }) + ]) + | Let (_, Prim (Extern "caml_assume_no_perform", args)) -> + invalid_arg + @@ Format.sprintf + "Internal primitive `caml_assume_no_perform` takes exactly 1 argument (%d \ + given)" + (List.length args) | _ -> [ instr ] let cps_block ~st ~k ~lifter_functions ~orig_pc block = @@ -773,6 +813,26 @@ let cps_block ~st ~k ~lifter_functions ~orig_pc block = || 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 "caml_assume_no_perform", [ Pv f ]) + when (not (double_translate ())) && Var.Set.mem x st.cps_needed -> + (* Translated like the [Apply] case, with a unit argument *) + Some + (fun ~k -> + let exact = + (* If this function is unknown to the global flow analysis, then it was + introduced by the lambda lifting and is exact *) + Var.idx f >= Var.Tbl.length st.flow_info.info_approximation + || Global_flow.exact_call st.flow_info f 1 + in + let unit = Var.fresh_n "unit" in + tail_call + ~st + ~instrs:[ Let (unit, Constant (Int Targetint.zero)) ] + ~exact + ~in_cps:false + ~check:true + ~f + [ unit; k ]) | Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg ]) -> Some (fun ~k -> @@ -865,8 +925,7 @@ let rewrite_direct_instr ~st instr = the right number of parameter *) assert (Global_flow.exact_call st.flow_info f (List.length args)); Let (x, Apply { f; args; exact = true }) - | Let (_, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> - assert false + | Let (_, e) when effect_primitive_or_application e -> assert false | _ -> instr (* If double-translating, modify all function applications and closure @@ -924,6 +983,18 @@ let rewrite_direct_block , Prim (Extern "caml_perform_effect", [ Pv effect; Pv continuation; Pc k ]) ) ] + | Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) -> + (* We just need to call [f] in direct style. *) + let unit = Var.fresh_n "unit" in + let unit_val = Int Targetint.zero in + let exact = Global_flow.exact_call st.flow_info f 1 in + [ Let (unit, Constant unit_val); Let (x, Apply { exact; f; args = [ unit ] }) ] + | Let (_, Prim (Extern "caml_assume_no_perform", args)) -> + invalid_arg + @@ Format.sprintf + "Internal primitive `caml_assume_no_perform` takes exactly 1 argument (%d \ + given)" + (List.length args) | (Let _ | Assign _ | Set_field _ | Offset_ref _ | Array_set _ | Event _) as instr -> [ instr ] in @@ -1361,7 +1432,7 @@ let split_blocks ~cps_needed ~lifter_functions (p : Code.program) = let split_block pc block p = let is_split_point i r branch = match i with - | Let (x, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> ( + | Let (x, e) when effect_primitive_or_application e -> ( ((not (empty_body r)) || match branch with diff --git a/compiler/lib/partial_cps_analysis.ml b/compiler/lib/partial_cps_analysis.ml index f639e4b067..b0f68a0c36 100644 --- a/compiler/lib/partial_cps_analysis.ml +++ b/compiler/lib/partial_cps_analysis.ml @@ -96,6 +96,15 @@ let block_deps ~info ~vars ~tail_deps ~deps ~blocks ~fun_name pc = (* If a function contains effect primitives, it must be in CPS *) add_dep deps f x) + | Let (x, Prim (Extern "caml_assume_no_perform", _)) -> ( + add_var vars x; + match fun_name with + | None -> () + | Some f -> + add_var vars f; + (* If a function contains effect primitives, it must be + in CPS *) + add_dep deps f x) | Let (x, Closure _) -> add_var vars x | Let (_, (Prim _ | Block _ | Constant _ | Field _ | Special _)) | Event _ | Assign _ | Set_field _ | Offset_ref _ | Array_set _ -> ()) @@ -150,6 +159,10 @@ let cps_needed ~info ~in_mutual_recursion ~rev_deps st x = | Expr (Prim (Extern ("%perform" | "%reperform" | "%resume"), _)) -> (* Effects primitives are in CPS *) true + | Expr (Prim (Extern "caml_assume_no_perform", _)) -> + (* This primitive calls its function argument in direct style when double translation + is enabled. Otherwise, it simply applies its argument to unit. *) + not (Config.Flag.double_translation ()) | Expr (Prim _ | Block _ | Constant _ | Field _ | Special _) | Phi _ -> false module SCC = Strongly_connected_components.Make (struct diff --git a/compiler/tests-check-prim/main.output b/compiler/tests-check-prim/main.output index b5d4c4d6b8..c2f1e8d1a1 100644 --- a/compiler/tests-check-prim/main.output +++ b/compiler/tests-check-prim/main.output @@ -3,6 +3,7 @@ Missing From main.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_dynlink_add_primitive caml_dynlink_close_lib caml_dynlink_get_current_libs diff --git a/compiler/tests-check-prim/main.output5 b/compiler/tests-check-prim/main.output5 index 470dc712b8..ee140695b1 100644 --- a/compiler/tests-check-prim/main.output5 +++ b/compiler/tests-check-prim/main.output5 @@ -3,6 +3,7 @@ Missing From main.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_continuation_use caml_drop_continuation caml_dynlink_add_primitive diff --git a/compiler/tests-check-prim/unix-unix.output b/compiler/tests-check-prim/unix-unix.output index 3d6399954e..190fc5bd42 100644 --- a/compiler/tests-check-prim/unix-unix.output +++ b/compiler/tests-check-prim/unix-unix.output @@ -3,6 +3,7 @@ Missing From unix.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_dynlink_add_primitive caml_dynlink_close_lib caml_dynlink_get_current_libs diff --git a/compiler/tests-check-prim/unix-unix.output5 b/compiler/tests-check-prim/unix-unix.output5 index 3ac8083bb9..057e330917 100644 --- a/compiler/tests-check-prim/unix-unix.output5 +++ b/compiler/tests-check-prim/unix-unix.output5 @@ -3,6 +3,7 @@ Missing From unix.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_continuation_use caml_drop_continuation caml_dynlink_add_primitive diff --git a/compiler/tests-check-prim/unix-win32.output b/compiler/tests-check-prim/unix-win32.output index 9df6df3c02..9f2d1bd18b 100644 --- a/compiler/tests-check-prim/unix-win32.output +++ b/compiler/tests-check-prim/unix-win32.output @@ -3,6 +3,7 @@ Missing From unix.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_dynlink_add_primitive caml_dynlink_close_lib caml_dynlink_get_current_libs diff --git a/compiler/tests-check-prim/unix-win32.output5 b/compiler/tests-check-prim/unix-win32.output5 index 7db584011a..267dca6549 100644 --- a/compiler/tests-check-prim/unix-win32.output5 +++ b/compiler/tests-check-prim/unix-win32.output5 @@ -3,6 +3,7 @@ Missing From unix.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_continuation_use caml_drop_continuation caml_dynlink_add_primitive diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform.ml b/compiler/tests-ocaml/lib-effects/assume_no_perform.ml new file mode 100644 index 0000000000..5818e8f9f1 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/assume_no_perform.ml @@ -0,0 +1,164 @@ +open Printf +open Effect +open Effect.Deep + +module type TREE = sig + type 'a t + (** The type of tree. *) + + val leaf : 'a t + (** A tree with only a leaf. *) + + val node : 'a t -> 'a -> 'a t -> 'a t + (** [node l x r] constructs a new tree with a new node [x] as the value, with + [l] and [r] being the left and right sub-trees. *) + + val deep : int -> int t + (** [deep n] constructs a tree of depth n, in linear time, where every node at + level [l] has value [l]. *) + + val to_iter : 'a t -> ('a -> unit) -> unit + (** Iterator function. *) + + val to_gen : 'a t -> unit -> 'a option + (** Generator function. [to_gen t] returns a generator function [g] for the + tree that traverses the tree in depth-first fashion, returning [Some x] + for each node when [g] is invoked. [g] returns [None] once the traversal + is complete. *) + + val to_gen_cps : 'a t -> unit -> 'a option + (** CPS version of the generator function. *) +end + +module Tree : TREE = struct + type 'a t = + | Leaf + | Node of 'a t * 'a * 'a t + + let leaf = Leaf + + let node l x r = Node (l, x, r) + + let rec deep = function + | 0 -> Leaf + | n -> + let t = deep (n - 1) in + Node (t, n, t) + + let rec iter f = function + | Leaf -> () + | Node (l, x, r) -> + iter f l; + f x; + iter f r + + (* val to_iter : 'a t -> ('a -> unit) -> unit *) + let to_iter t f = iter f t + + (* val to_gen : 'a t -> (unit -> 'a option) *) + let to_gen (type a) (t : a t) = + let module M = struct + type _ Effect.t += Next : a -> unit Effect.t + end in + let open M in + let rec step = + ref (fun () -> + try_with + (fun t -> + iter (fun x -> perform (Next x)) t; + None) + t + { effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Next v -> + Some + (fun (k : (a, _) continuation) -> + (step := fun () -> continue k ()); + Some v) + | _ -> None) + }) + in + fun () -> !step () + + let to_gen_cps t = + let next = ref t in + let cont = ref Leaf in + let rec iter t k = + match t with + | Leaf -> run k + | Node (left, x, right) -> iter left (Node (k, x, right)) + and run = function + | Leaf -> None + | Node (k, x, right) -> + next := right; + cont := k; + Some x + in + fun () -> iter !next !cont +end + +let get_mean_sd l = + let get_mean l = + List.fold_right (fun a v -> a +. v) l 0. /. (float_of_int @@ List.length l) + in + let mean = get_mean l in + let sd = get_mean @@ List.map (fun v -> abs_float (v -. mean) ** 2.) l in + mean, sd + +let benchmark f n = + let rec run acc = function + | 0 -> acc + | n -> + let t1 = Sys.time () in + let () = f () in + let d = Sys.time () -. t1 in + run (d :: acc) (n - 1) + in + let r = run [] n in + get_mean_sd r + +(* Main follows *) + +type _ Effect.t += Dummy : unit t + +let () = + try_with + (fun () -> + let n = try int_of_string Sys.argv.(1) with _ -> 21 in + let t = Tree.deep n in + let iter_fun () = Tree.to_iter t (fun _ -> ()) in + let rec consume_all f = + match f () with + | None -> () + | Some _ -> consume_all f + in + + (* The code below should be called in direct style despite the installed + effect handler *) + Js_of_ocaml.Js.Effect.assume_no_perform (fun () -> + let m, sd = benchmark iter_fun 5 in + let () = printf "Iter: mean = %f, sd = %f\n%!" m sd in + + let gen_cps_fun () = + let f = Tree.to_gen_cps t in + consume_all f + in + + let m, sd = benchmark gen_cps_fun 5 in + printf "Gen_cps: mean = %f, sd = %f\n%!" m sd); + + let gen_fun () = + let f = Tree.to_gen t in + consume_all f + in + + let m, sd = benchmark gen_fun 5 in + printf "Gen_eff: mean = %f, sd = %f\n%!" m sd) + () + { effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Dummy -> Some (fun (k : (a, _) continuation) -> continue k ()) + | _ -> None) + } diff --git a/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform.ml b/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform.ml new file mode 100644 index 0000000000..5818e8f9f1 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform.ml @@ -0,0 +1,164 @@ +open Printf +open Effect +open Effect.Deep + +module type TREE = sig + type 'a t + (** The type of tree. *) + + val leaf : 'a t + (** A tree with only a leaf. *) + + val node : 'a t -> 'a -> 'a t -> 'a t + (** [node l x r] constructs a new tree with a new node [x] as the value, with + [l] and [r] being the left and right sub-trees. *) + + val deep : int -> int t + (** [deep n] constructs a tree of depth n, in linear time, where every node at + level [l] has value [l]. *) + + val to_iter : 'a t -> ('a -> unit) -> unit + (** Iterator function. *) + + val to_gen : 'a t -> unit -> 'a option + (** Generator function. [to_gen t] returns a generator function [g] for the + tree that traverses the tree in depth-first fashion, returning [Some x] + for each node when [g] is invoked. [g] returns [None] once the traversal + is complete. *) + + val to_gen_cps : 'a t -> unit -> 'a option + (** CPS version of the generator function. *) +end + +module Tree : TREE = struct + type 'a t = + | Leaf + | Node of 'a t * 'a * 'a t + + let leaf = Leaf + + let node l x r = Node (l, x, r) + + let rec deep = function + | 0 -> Leaf + | n -> + let t = deep (n - 1) in + Node (t, n, t) + + let rec iter f = function + | Leaf -> () + | Node (l, x, r) -> + iter f l; + f x; + iter f r + + (* val to_iter : 'a t -> ('a -> unit) -> unit *) + let to_iter t f = iter f t + + (* val to_gen : 'a t -> (unit -> 'a option) *) + let to_gen (type a) (t : a t) = + let module M = struct + type _ Effect.t += Next : a -> unit Effect.t + end in + let open M in + let rec step = + ref (fun () -> + try_with + (fun t -> + iter (fun x -> perform (Next x)) t; + None) + t + { effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Next v -> + Some + (fun (k : (a, _) continuation) -> + (step := fun () -> continue k ()); + Some v) + | _ -> None) + }) + in + fun () -> !step () + + let to_gen_cps t = + let next = ref t in + let cont = ref Leaf in + let rec iter t k = + match t with + | Leaf -> run k + | Node (left, x, right) -> iter left (Node (k, x, right)) + and run = function + | Leaf -> None + | Node (k, x, right) -> + next := right; + cont := k; + Some x + in + fun () -> iter !next !cont +end + +let get_mean_sd l = + let get_mean l = + List.fold_right (fun a v -> a +. v) l 0. /. (float_of_int @@ List.length l) + in + let mean = get_mean l in + let sd = get_mean @@ List.map (fun v -> abs_float (v -. mean) ** 2.) l in + mean, sd + +let benchmark f n = + let rec run acc = function + | 0 -> acc + | n -> + let t1 = Sys.time () in + let () = f () in + let d = Sys.time () -. t1 in + run (d :: acc) (n - 1) + in + let r = run [] n in + get_mean_sd r + +(* Main follows *) + +type _ Effect.t += Dummy : unit t + +let () = + try_with + (fun () -> + let n = try int_of_string Sys.argv.(1) with _ -> 21 in + let t = Tree.deep n in + let iter_fun () = Tree.to_iter t (fun _ -> ()) in + let rec consume_all f = + match f () with + | None -> () + | Some _ -> consume_all f + in + + (* The code below should be called in direct style despite the installed + effect handler *) + Js_of_ocaml.Js.Effect.assume_no_perform (fun () -> + let m, sd = benchmark iter_fun 5 in + let () = printf "Iter: mean = %f, sd = %f\n%!" m sd in + + let gen_cps_fun () = + let f = Tree.to_gen_cps t in + consume_all f + in + + let m, sd = benchmark gen_cps_fun 5 in + printf "Gen_cps: mean = %f, sd = %f\n%!" m sd); + + let gen_fun () = + let f = Tree.to_gen t in + consume_all f + in + + let m, sd = benchmark gen_fun 5 in + printf "Gen_eff: mean = %f, sd = %f\n%!" m sd) + () + { effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Dummy -> Some (fun (k : (a, _) continuation) -> continue k ()) + | _ -> None) + } diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index 805d2c3d76..5747b53267 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -461,3 +461,20 @@ (deps marshal.reference marshal.referencejs) (action (diff marshal.reference marshal.referencejs))) + +(executable + (name assume_no_perform) + (enabled_if + (>= %{ocaml_version} 5)) + (modules assume_no_perform) + (modes js) + (libraries js_of_ocaml)) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps assume_no_perform.bc.js) + (action + (ignore-stdout + (run node ./assume_no_perform.bc.js)))) diff --git a/compiler/tests-ocaml/lib-effects/dune b/compiler/tests-ocaml/lib-effects/dune index 7261b03c3f..ea8f7d933c 100644 --- a/compiler/tests-ocaml/lib-effects/dune +++ b/compiler/tests-ocaml/lib-effects/dune @@ -451,3 +451,20 @@ (deps marshal.reference marshal.referencejs) (action (diff marshal.reference marshal.referencejs))) + +(executable + (name assume_no_perform) + (enabled_if + (>= %{ocaml_version} 5)) + (modules assume_no_perform) + (modes js) + (libraries js_of_ocaml)) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps assume_no_perform.bc.js) + (action + (ignore-stdout + (run node ./assume_no_perform.bc.js)))) diff --git a/lib/js_of_ocaml/js.ml b/lib/js_of_ocaml/js.ml index e9972add32..86aeb0f040 100644 --- a/lib/js_of_ocaml/js.ml +++ b/lib/js_of_ocaml/js.ml @@ -841,6 +841,12 @@ let export_all obj = (****) +module Effect = struct + external assume_no_perform : (unit -> 'a) -> 'a = "caml_assume_no_perform" +end + +(****) + (* DEPRECATED *) type float_prop = number_t prop diff --git a/lib/js_of_ocaml/js.mli b/lib/js_of_ocaml/js.mli index 47013b7c95..04fa17e86e 100644 --- a/lib/js_of_ocaml/js.mli +++ b/lib/js_of_ocaml/js.mli @@ -889,6 +889,20 @@ export_all ]} *) +module Effect : sig + external assume_no_perform : (unit -> 'a) -> 'a = "caml_assume_no_perform" + (** Passing a function [f] as argument of `assume_no_perform` guarantees that, + when compiling with `--enable doubletranslate`, the direct-style version of + [f] is called, which is faster than the CPS version. As a consequence, + performing an effect in a transitive callee of [f] will raise + `Effect.Unhandled`, regardless of any effect handlers installed before the + call to `assume_no_perform`, unless a new effect handler was installed in + the meantime. + + When double translation is disabled, `assume_no_perform` simply acts like + [fun f -> f ()]. *) +end + (** {2 Unsafe operations.} *) (** Unsafe Javascript operations *) diff --git a/lib/js_of_ocaml/js_of_ocaml_stubs.c b/lib/js_of_ocaml/js_of_ocaml_stubs.c index 292c88f081..4f52162ed8 100644 --- a/lib/js_of_ocaml/js_of_ocaml_stubs.c +++ b/lib/js_of_ocaml/js_of_ocaml_stubs.c @@ -1,5 +1,9 @@ #include +void caml_assume_no_perform () { + caml_fatal_error("Unimplemented Javascript primitive caml_assume_no_perform!"); +} + void caml_bytes_of_array () { caml_fatal_error("Unimplemented Javascript primitive caml_bytes_of_array!"); }