From 120f2351ffbceff892bc475202b3e7f90c4e8988 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 9 Mar 2023 18:45:48 +0100 Subject: [PATCH 01/80] 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 | 807 +++++++++++++++--- 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, 4244 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 c8ab3043b8..2f3fe8ba7d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -48,6 +48,7 @@ * Toplevel: no longer set globals for toplevel initialization * Runtime: precompute constants used in `caml_lxm_next` (#1730) * Runtime: cleanup runtime +* 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 5c3438ab00..f43dfb5b03 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,19 +433,19 @@ 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 @@ -375,15 +453,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 @@ -394,7 +475,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 ] @@ -454,17 +535,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 @@ -482,63 +569,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 @@ -557,7 +767,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 ]) -> @@ -581,20 +795,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 @@ -608,26 +828,176 @@ 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 @@ -646,9 +1016,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 @@ -664,7 +1035,9 @@ 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 @@ -684,16 +1057,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 ( @@ -710,55 +1088,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 (****) @@ -843,13 +1358,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 @@ -857,6 +1372,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 = @@ -943,9 +1463,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 0a3f8ea295..2d1225c474 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -513,7 +513,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 6fe65b106a..90340672b4 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 35612ae98c..ab7c13d52a 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 @@ -896,49 +910,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 = @@ -954,12 +993,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 @@ -967,12 +1006,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 @@ -1189,9 +1228,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 @@ -1565,7 +1605,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 @@ -2111,12 +2152,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 @@ -2130,6 +2172,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 416376ec3e..310b4ab61d 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -186,6 +186,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 923e22a388..075d8fbe0b 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -1179,6 +1179,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 e19f6f8c46..ff5c148c8b 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 3856e76bf4..8b47297eac 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,11 +173,41 @@ 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 //Version: >= 5.0 function caml_alloc_stack(hv, hx, hf) { @@ -136,7 +215,7 @@ function caml_alloc_stack(hv, hx, hf) { 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) { @@ -147,7 +226,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 @@ -215,3 +294,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 03fbdbefe9..05ca000ebd 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 307986787d..f4f3197b67 100644 --- a/runtime/js/stdlib.js +++ b/runtime/js/stdlib.js @@ -64,14 +64,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); @@ -81,7 +81,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]; @@ -120,6 +120,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 88c4806a1f..436501b8bd 100644 --- a/runtime/js/stdlib_modern.js +++ b/runtime/js/stdlib_modern.js @@ -62,6 +62,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; @@ -115,3 +117,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 38f0462f20ef225f66747ca38aa2c65f3e01cca4 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 11 Jun 2024 15:08:11 +0200 Subject: [PATCH 02/80] 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.4.14.output | 1 + compiler/tests-check-prim/main.5.2.output | 1 + .../tests-check-prim/unix-Unix.4.14.output | 1 + .../tests-check-prim/unix-Unix.5.2.output | 1 + .../tests-check-prim/unix-Win32.4.14.output | 1 + .../tests-check-prim/unix-Win32.5.2.output | 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 | 13 ++ 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, 479 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 f43dfb5b03..cb68df76a6 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. *) @@ -740,7 +748,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 = @@ -774,6 +814,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 -> @@ -866,8 +926,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 @@ -925,6 +984,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 @@ -1364,7 +1435,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.4.14.output b/compiler/tests-check-prim/main.4.14.output index 139954b7ee..79dccf4286 100644 --- a/compiler/tests-check-prim/main.4.14.output +++ b/compiler/tests-check-prim/main.4.14.output @@ -3,6 +3,7 @@ Missing From main.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_int64_add_native caml_int64_and_native caml_int64_div_native diff --git a/compiler/tests-check-prim/main.5.2.output b/compiler/tests-check-prim/main.5.2.output index 3c5ba47eab..c35328f37b 100644 --- a/compiler/tests-check-prim/main.5.2.output +++ b/compiler/tests-check-prim/main.5.2.output @@ -3,6 +3,7 @@ Missing From main.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_continuation_use caml_drop_continuation caml_int_as_pointer diff --git a/compiler/tests-check-prim/unix-Unix.4.14.output b/compiler/tests-check-prim/unix-Unix.4.14.output index 21af5e2974..072c9a3757 100644 --- a/compiler/tests-check-prim/unix-Unix.4.14.output +++ b/compiler/tests-check-prim/unix-Unix.4.14.output @@ -3,6 +3,7 @@ Missing From unix.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_int64_add_native caml_int64_and_native caml_int64_div_native diff --git a/compiler/tests-check-prim/unix-Unix.5.2.output b/compiler/tests-check-prim/unix-Unix.5.2.output index 630bcaf2fd..28d8771404 100644 --- a/compiler/tests-check-prim/unix-Unix.5.2.output +++ b/compiler/tests-check-prim/unix-Unix.5.2.output @@ -3,6 +3,7 @@ Missing From unix.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_continuation_use caml_drop_continuation caml_int_as_pointer diff --git a/compiler/tests-check-prim/unix-Win32.4.14.output b/compiler/tests-check-prim/unix-Win32.4.14.output index f49ad3383a..507d923f0c 100644 --- a/compiler/tests-check-prim/unix-Win32.4.14.output +++ b/compiler/tests-check-prim/unix-Win32.4.14.output @@ -3,6 +3,7 @@ Missing From unix.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_int64_add_native caml_int64_and_native caml_int64_div_native diff --git a/compiler/tests-check-prim/unix-Win32.5.2.output b/compiler/tests-check-prim/unix-Win32.5.2.output index f2c49c3ded..e935be7e8e 100644 --- a/compiler/tests-check-prim/unix-Win32.5.2.output +++ b/compiler/tests-check-prim/unix-Win32.5.2.output @@ -3,6 +3,7 @@ Missing From unix.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_continuation_use caml_drop_continuation caml_int_as_pointer 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 b025306dc4..c98c83eabb 100644 --- a/compiler/tests-ocaml/lib-effects/dune +++ b/compiler/tests-ocaml/lib-effects/dune @@ -47,3 +47,16 @@ (run node %{test})) (run cat))) (modes js wasm)) + +(tests + (build_if + (>= %{ocaml_version} 5)) + (names assume_no_perform) + (modules assume_no_perform) + (libraries js_of_ocaml) + (action + (ignore-outputs + (with-accepted-exit-codes + 0 + (run node %{test})))) + (modes js wasm)) diff --git a/lib/js_of_ocaml/js.ml b/lib/js_of_ocaml/js.ml index 9caa734de4..ce38502bfa 100644 --- a/lib/js_of_ocaml/js.ml +++ b/lib/js_of_ocaml/js.ml @@ -843,6 +843,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 cdaf7ad8f4..e24ebc2126 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 0ddf5aee81..8481e80555 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!"); } From 7f769bee1c9211cf7cbf9c601d2b643a7a3e6104 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 20 Nov 2024 17:04:56 +0100 Subject: [PATCH 03/80] CR: Fix non-raised Unhandled with assume_no_perform --- compiler/lib/effects.ml | 20 ++-------- .../lib-effects/double-translation/dune | 30 +++++++++++++++ runtime/js/effect.js | 18 ++++++--- runtime/js/jslib.js | 37 ++----------------- 4 files changed, 51 insertions(+), 54 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index cb68df76a6..2cab14e64d 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -967,23 +967,11 @@ let rewrite_direct_block ; 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 ])) -> + (* In direct-style code, we just raise [Effect.Unhandled]. *) + [ Let (x, Prim (Extern "caml_raise_unhandled", [ Pv effect ])) ] + | 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 (x, Prim (Extern "caml_raise_unhandled", [ Pv effect ])) ] | 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 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index 5747b53267..624fba4254 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -478,3 +478,33 @@ (action (ignore-stdout (run node ./assume_no_perform.bc.js)))) + +(executable + (name assume_no_perform_unhandled) + (enabled_if + (>= %{ocaml_version} 5)) + (modules assume_no_perform_unhandled) + (modes js) + (libraries js_of_ocaml)) + +(rule + (target assume_no_perform_unhandled.referencejs) + (enabled_if + (>= %{ocaml_version} 5)) + (deps assume_no_perform_unhandled.bc.js) + (action + (with-stdout-to + %{target} + (run node ./assume_no_perform_unhandled.bc.js)))) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps + assume_no_perform_unhandled.reference + assume_no_perform_unhandled.referencejs) + (action + (diff + assume_no_perform_unhandled.reference + assume_no_perform_unhandled.referencejs))) diff --git a/runtime/js/effect.js b/runtime/js/effect.js index 8b47297eac..20cc2cb260 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -73,13 +73,11 @@ 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 +//Provides: caml_raise_unhandled +//Requires: caml_named_value, caml_raise_with_arg, caml_raise_constant, caml_string_of_jsbytes, caml_fresh_oo_id //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); +function caml_raise_unhandled(eff) { var exn = caml_named_value("Effect.Unhandled"); if (exn) caml_raise_with_arg(exn, eff); else { @@ -92,6 +90,16 @@ function uncaught_effect_handler(eff, k, ms) { } } +//Provides: caml_uncaught_effect_handler +//Requires: caml_resume_stack, caml_raise_unhandled +//If: effects +//If: doubletranslate +function caml_uncaught_effect_handler(eff, k, ms) { + // Resumes the continuation k by raising exception Unhandled. + caml_resume_stack(k[1], ms); + caml_raise_unhandled(eff); +} + //Provides: caml_fiber_stack //If: effects // This has the shape {h, r:{k, x, e}} where h is a triple of handlers diff --git a/runtime/js/jslib.js b/runtime/js/jslib.js index 05ca000ebd..21a401612d 100644 --- a/runtime/js/jslib.js +++ b/runtime/js/jslib.js @@ -85,30 +85,15 @@ 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 +//Requires:caml_stack_depth, caml_call_gen, caml_exn_stack, caml_fiber_stack, caml_wrap_exception, caml_uncaught_effect_handler 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], + h: [0, 0, 0, caml_uncaught_effect_handler], r: { k: 0, x: 0, e: 0 }, }; var res = { @@ -140,30 +125,16 @@ function caml_callback(f, args) { //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_stack_depth, caml_call_gen, caml_exn_stack, caml_fiber_stack, caml_uncaught_effect_handler //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], + h: [0, 0, 0, caml_uncaught_effect_handler], r: { k: 0, x: 0, e: 0 }, }; return caml_call_gen(f, args); From 0192c16cb8d1e7b7abf1eb311533c8aa5c22a305 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 20 Nov 2024 17:22:57 +0100 Subject: [PATCH 04/80] CR: Commit suggestion for compiler/lib/driver.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Jérôme Vouillon --- compiler/lib/driver.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 3bd3c74d11..662f6544cc 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -112,9 +112,9 @@ let effects ~deadcode_sentinal p = Deadcode.f p else p, live_vars in - 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) + p + |> Effects.f ~flow_info:info ~live_vars + |> map_fst (if Config.Flag.double_translation () then Fun.id else Lambda_lifting.f)) else ( p , (Code.Var.Set.empty : Effects.trampolined_calls) From 10f8752a83b4504e30fc700ffc14c618be06f787 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 20 Nov 2024 17:51:29 +0100 Subject: [PATCH 05/80] Fix runtime deps, add missing test --- .../assume_no_perform_unhandled.ml | 26 +++++++++++++++++++ .../assume_no_perform_unhandled.reference | 1 + .../assume_no_perform_unhandled.ml | 26 +++++++++++++++++++ .../assume_no_perform_unhandled.reference | 1 + runtime/js/effect.js | 6 ++--- runtime/js/jslib.js | 8 +++--- 6 files changed, 60 insertions(+), 8 deletions(-) create mode 100644 compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml create mode 100644 compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.reference create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.reference diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml new file mode 100644 index 0000000000..c81d984806 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml @@ -0,0 +1,26 @@ +open Printf +open Effect +open Effect.Deep + +type _ Effect.t += Dummy : unit t + +let must_raise () = + try_with + (fun () -> + Js_of_ocaml.Js.Effect.assume_no_perform (fun () -> + (* Should raise [Effect.Unhandled] despite the installed handler *) + perform Dummy + ) + ) + () + { effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Dummy -> Some (fun (k : (a, _) continuation) -> continue k ()) + | _ -> None) + } + +let () = + try + must_raise (); print_endline "failed"; exit 2 + with Effect.Unhandled Dummy -> print_endline "ok" diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.reference b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.reference new file mode 100644 index 0000000000..9766475a41 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.reference @@ -0,0 +1 @@ +ok diff --git a/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.ml b/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.ml new file mode 100644 index 0000000000..c81d984806 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.ml @@ -0,0 +1,26 @@ +open Printf +open Effect +open Effect.Deep + +type _ Effect.t += Dummy : unit t + +let must_raise () = + try_with + (fun () -> + Js_of_ocaml.Js.Effect.assume_no_perform (fun () -> + (* Should raise [Effect.Unhandled] despite the installed handler *) + perform Dummy + ) + ) + () + { effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Dummy -> Some (fun (k : (a, _) continuation) -> continue k ()) + | _ -> None) + } + +let () = + try + must_raise (); print_endline "failed"; exit 2 + with Effect.Unhandled Dummy -> print_endline "ok" diff --git a/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.reference b/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.reference new file mode 100644 index 0000000000..9766475a41 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.reference @@ -0,0 +1 @@ +ok diff --git a/runtime/js/effect.js b/runtime/js/effect.js index 20cc2cb260..b510f4e677 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -76,7 +76,6 @@ function caml_pop_trap() { //Provides: caml_raise_unhandled //Requires: caml_named_value, caml_raise_with_arg, caml_raise_constant, caml_string_of_jsbytes, caml_fresh_oo_id //If: effects -//If: doubletranslate function caml_raise_unhandled(eff) { var exn = caml_named_value("Effect.Unhandled"); if (exn) caml_raise_with_arg(exn, eff); @@ -90,11 +89,10 @@ function caml_raise_unhandled(eff) { } } -//Provides: caml_uncaught_effect_handler +//Provides: uncaught_effect_handler //Requires: caml_resume_stack, caml_raise_unhandled //If: effects -//If: doubletranslate -function caml_uncaught_effect_handler(eff, k, ms) { +function uncaught_effect_handler(eff, k, ms) { // Resumes the continuation k by raising exception Unhandled. caml_resume_stack(k[1], ms); caml_raise_unhandled(eff); diff --git a/runtime/js/jslib.js b/runtime/js/jslib.js index 21a401612d..1c319c7d59 100644 --- a/runtime/js/jslib.js +++ b/runtime/js/jslib.js @@ -85,7 +85,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_uncaught_effect_handler +//Requires:caml_stack_depth, caml_call_gen, caml_exn_stack, caml_fiber_stack, caml_wrap_exception, uncaught_effect_handler function caml_callback(f, args) { var saved_stack_depth = caml_stack_depth; var saved_exn_stack = caml_exn_stack; @@ -93,7 +93,7 @@ function caml_callback(f, args) { try { caml_exn_stack = 0; caml_fiber_stack = { - h: [0, 0, 0, caml_uncaught_effect_handler], + h: [0, 0, 0, uncaught_effect_handler], r: { k: 0, x: 0, e: 0 }, }; var res = { @@ -125,7 +125,7 @@ function caml_callback(f, args) { //Provides: caml_callback //If: effects //If: doubletranslate -//Requires:caml_stack_depth, caml_call_gen, caml_exn_stack, caml_fiber_stack, caml_uncaught_effect_handler +//Requires:caml_stack_depth, caml_call_gen, caml_exn_stack, caml_fiber_stack, uncaught_effect_handler //Requires: caml_raise_constant function caml_callback(f, args) { var saved_stack_depth = caml_stack_depth; @@ -134,7 +134,7 @@ function caml_callback(f, args) { try { caml_exn_stack = 0; caml_fiber_stack = { - h: [0, 0, 0, caml_uncaught_effect_handler], + h: [0, 0, 0, uncaught_effect_handler], r: { k: 0, x: 0, e: 0 }, }; return caml_call_gen(f, args); From 92e41d8cd821c7c832311c9a91d1128fe0c7b971 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 22 Nov 2024 11:58:45 +0100 Subject: [PATCH 06/80] CR --- compiler/lib/driver.ml | 2 +- runtime/js/stdlib.js | 5 ++--- runtime/js/stdlib_modern.js | 1 - 3 files changed, 3 insertions(+), 5 deletions(-) diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 662f6544cc..7dfbe6cce1 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -118,7 +118,7 @@ let effects ~deadcode_sentinal p = else ( p , (Code.Var.Set.empty : Effects.trampolined_calls) - , (Code.Var.Set.empty : Code.Var.Set.t) ) + , (Code.Var.Set.empty : Effects.in_cps) ) let exact_calls profile ~deadcode_sentinal p = if not (Config.Flag.effects ()) diff --git a/runtime/js/stdlib.js b/runtime/js/stdlib.js index f4f3197b67..81d0de81e5 100644 --- a/runtime/js/stdlib.js +++ b/runtime/js/stdlib.js @@ -70,7 +70,7 @@ 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(...args); + if (d === 0) return f.apply(null, args); else if (d < 0) { var rest = args.slice(n - 1); var k = args[argsLen - 1]; @@ -81,7 +81,7 @@ function caml_call_gen(f, args) { args[args.length - 1] = k; return caml_call_gen(g, args); }; - return f(...args); + return f.apply(null, args); } else { argsLen--; var k = args[argsLen]; @@ -165,7 +165,6 @@ var caml_call_gen_tuple = (function () { } 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) { diff --git a/runtime/js/stdlib_modern.js b/runtime/js/stdlib_modern.js index 436501b8bd..f921365218 100644 --- a/runtime/js/stdlib_modern.js +++ b/runtime/js/stdlib_modern.js @@ -160,7 +160,6 @@ var caml_call_gen_tuple = (function () { } 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) { From de30b43e68531c938a9d2e3a0a772211e5b13eb8 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 22 Nov 2024 18:08:47 +0100 Subject: [PATCH 07/80] CR --- runtime/js/effect.js | 73 +++++++++++++++++--------------------------- runtime/js/stdlib.js | 7 +++++ 2 files changed, 35 insertions(+), 45 deletions(-) diff --git a/runtime/js/effect.js b/runtime/js/effect.js index b510f4e677..b0c7b276f5 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -41,11 +41,6 @@ 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 @@ -92,12 +87,30 @@ function caml_raise_unhandled(eff) { //Provides: uncaught_effect_handler //Requires: caml_resume_stack, caml_raise_unhandled //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); caml_raise_unhandled(eff); } +//Provides: uncaught_effect_handler_cps +//Requires: caml_resume_stack, caml_raise_unhandled +//If: effects +//If: doubletranslate +function uncaught_effect_handler_cps(eff, k, ms, cont) { + // Resumes the continuation k by raising exception Unhandled. + caml_resume_stack(k[1], ms); + caml_raise_unhandled(eff); +} + +//Provides: uncaught_effect_handler +//Requires: uncaught_effect_handler_cps +//If: effects +//If: doubletranslate +//Weakdef +var uncaught_effect_handler = { cps : uncaught_effect_handler_cps }; + //Provides: caml_fiber_stack //If: effects // This has the shape {h, r:{k, x, e}} where h is a triple of handlers @@ -149,22 +162,8 @@ 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, caml_prepare_tramp +//Requires: caml_pop_fiber, caml_stack_check_depth, caml_trampoline_return, caml_exn_stack, caml_fiber_stack, caml_get_cps_fun //If: effects function caml_perform_effect(eff, cont, k0) { // Allocate a continuation if we don't already have one @@ -178,42 +177,26 @@ function caml_perform_effect(eff, cont, k0) { // The handler is defined in Stdlib.Effect, so we know that the arity matches var k1 = caml_pop_fiber(); return caml_stack_check_depth() - ? handler(eff, cont, k1, k1) - : caml_trampoline_return(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); + ? (caml_get_cps_fun(handler))(eff, cont, k1, k1) + : caml_trampoline_return(handler, [eff, cont, k1, k1]); } -//Provides: caml_get_fun +//Provides: caml_get_cps_fun //If: effects //If: !doubletranslate -function caml_get_fun(f) { +function caml_get_cps_fun(f) { return f; } -//Provides: caml_get_fun +//Provides: caml_get_cps_fun //If: effects //If: doubletranslate -function caml_get_fun(f) { +function caml_get_cps_fun(f) { return f.cps; } //Provides: caml_alloc_stack -//Requires: caml_pop_fiber, caml_fiber_stack, caml_stack_check_depth, caml_trampoline_return, caml_call_fun, caml_get_fun +//Requires: caml_pop_fiber, caml_fiber_stack, caml_stack_check_depth, caml_trampoline_return, caml_call_gen_cps //If: effects //Version: >= 5.0 function caml_alloc_stack(hv, hx, hf) { @@ -221,7 +204,7 @@ function caml_alloc_stack(hv, hx, hf) { var f = caml_fiber_stack.h[i]; var args = [x, caml_pop_fiber()]; return caml_stack_check_depth() - ? caml_call_fun(f, args) + ? caml_call_gen_cps(f, args) : caml_trampoline_return(f, args); } function hval(x) { @@ -232,7 +215,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, caml_get_fun(hf)], 0]; + return [0, hval, [0, hexn, 0], [0, hv, hx, hf], 0]; } //Provides: caml_alloc_stack diff --git a/runtime/js/stdlib.js b/runtime/js/stdlib.js index 81d0de81e5..45c795a1d3 100644 --- a/runtime/js/stdlib.js +++ b/runtime/js/stdlib.js @@ -120,6 +120,13 @@ function caml_call_gen(f, args) { } } +//Provides: caml_call_gen_cps +//Requires: caml_call_gen +//If: effects +//If: !doubletranslate +//Weakdef +var caml_call_gen_cps = caml_call_gen; + //Provides: caml_call_gen_tuple (const, shallow) //Requires: caml_fiber_stack, caml_cps_closure //If: effects From 77c233173f741baa503904f2a4288cbfb5be3c1a Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 22 Nov 2024 18:16:01 +0100 Subject: [PATCH 08/80] Runtime format --- runtime/js/effect.js | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/runtime/js/effect.js b/runtime/js/effect.js index b0c7b276f5..eb0a7039c9 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -109,7 +109,7 @@ function uncaught_effect_handler_cps(eff, k, ms, cont) { //If: effects //If: doubletranslate //Weakdef -var uncaught_effect_handler = { cps : uncaught_effect_handler_cps }; +var uncaught_effect_handler = { cps: uncaught_effect_handler_cps }; //Provides: caml_fiber_stack //If: effects @@ -177,7 +177,7 @@ function caml_perform_effect(eff, cont, k0) { // The handler is defined in Stdlib.Effect, so we know that the arity matches var k1 = caml_pop_fiber(); return caml_stack_check_depth() - ? (caml_get_cps_fun(handler))(eff, cont, k1, k1) + ? caml_get_cps_fun(handler)(eff, cont, k1, k1) : caml_trampoline_return(handler, [eff, cont, k1, k1]); } From 22584e4dcddca3b85e8812d794943ade3aa5d7d9 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 27 Nov 2024 17:51:37 +0100 Subject: [PATCH 09/80] Factorize substitution logic --- compiler/lib/duplicate.ml | 49 +------------------------------------- compiler/lib/duplicate.mli | 6 +++++ compiler/lib/subst.ml | 29 ++++++++++++++++++---- compiler/lib/subst.mli | 6 +++++ 4 files changed, 38 insertions(+), 52 deletions(-) diff --git a/compiler/lib/duplicate.ml b/compiler/lib/duplicate.ml index c4e6242355..683bba7d4b 100644 --- a/compiler/lib/duplicate.ml +++ b/compiler/lib/duplicate.ml @@ -19,53 +19,6 @@ open! Stdlib open Code -let subst_cont m s (pc, arg) = Addr.Map.find pc m, 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, field_type) -> Field (s x, n, field_type) - | Closure _ -> failwith "Inlining/Duplicating closure is currenly not supported" - | Special x -> Special x - | Prim (p, l) -> - Prim - ( p - , List.map l ~f:(function - | Pv x -> Pv (s x) - | Pc _ as x -> 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 m s l = - match l with - | Stop -> l - | Branch cont -> Branch (subst_cont m s cont) - | Pushtrap (cont1, x, cont2) -> - Pushtrap (subst_cont m s cont1, s x, subst_cont m s cont2) - | Return x -> Return (s x) - | Raise (x, k) -> Raise (s x, k) - | Cond (x, cont1, cont2) -> Cond (s x, subst_cont m s cont1, subst_cont m s cont2) - | Switch (x, a1) -> Switch (s x, Array.map a1 ~f:(fun cont -> subst_cont m s cont)) - | Poptrap cont -> Poptrap (subst_cont m s cont) - -let block m s block = - { params = List.map ~f:s block.params - ; body = instrs s block.body - ; branch = last m s block.branch - } - let closure p ~bound_vars ~f ~params ~cont:(pc, args) = let s = Subst.from_map @@ -84,7 +37,7 @@ let closure p ~bound_vars ~f ~params ~cont:(pc, args) = { fold = Code.fold_children } (fun pc blocks -> let b = Addr.Map.find pc blocks in - let b = block m s b in + let b = Subst.Including_Binders.And_Continuations.block m s b in Addr.Map.add (Addr.Map.find pc m) b blocks) pc p.blocks diff --git a/compiler/lib/duplicate.mli b/compiler/lib/duplicate.mli index 94ce7b7588..3ebbea1866 100644 --- a/compiler/lib/duplicate.mli +++ b/compiler/lib/duplicate.mli @@ -23,3 +23,9 @@ val closure : -> params:Code.Var.t list -> cont:int * Code.Var.t list -> Code.program * Code.Var.t * Code.Var.t list * (int * Code.Var.t list) +(** Given a program and a closure [f] -- defined by its name, parameters, and its + continuation --, return a program in which the body of [f] has been updated with fresh + variable names to replace elements of [bound_vars]. Also returns the new name of [f] + (fresh if [f] is in [bound_vars]), and the similarly substituted parameter list and + continuation. + *) diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml index 1d0dcbc1d2..30f06d38da 100644 --- a/compiler/lib/subst.ml +++ b/compiler/lib/subst.ml @@ -21,7 +21,7 @@ open! Stdlib open Code -let subst_cont s (pc, arg) = pc, List.map arg ~f:(fun x -> s x) +let subst_cont s (pc, arg) = pc, List.map arg ~f:s module Excluding_Binders = struct let expr s e = @@ -115,9 +115,8 @@ 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) + | Apply { f; args; exact } -> Apply { f = s f; args = List.map args ~f:s; exact } + | Block (n, a, k, mut) -> Block (n, Array.map a ~f:s, 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 @@ -156,4 +155,26 @@ module Including_Binders = struct ; body = instrs s block.body ; branch = last s block.branch } + + module And_Continuations = struct + let subst_cont m s (pc, arg) = Addr.Map.find pc m, List.map arg ~f:s + + let last m s l = + match l with + | Stop -> l + | Branch cont -> Branch (subst_cont m s cont) + | Pushtrap (cont1, x, cont2) -> + Pushtrap (subst_cont m s cont1, s x, subst_cont m s cont2) + | Return x -> Return (s x) + | Raise (x, k) -> Raise (s x, k) + | Cond (x, cont1, cont2) -> Cond (s x, subst_cont m s cont1, subst_cont m s cont2) + | Switch (x, a1) -> Switch (s x, Array.map a1 ~f:(fun cont -> subst_cont m s cont)) + | Poptrap cont -> Poptrap (subst_cont m s cont) + + let block m s block = + { params = List.map ~f:s block.params + ; body = instrs s block.body + ; branch = last m s block.branch + } + end end diff --git a/compiler/lib/subst.mli b/compiler/lib/subst.mli index 8872b4f0f5..a3920f0650 100644 --- a/compiler/lib/subst.mli +++ b/compiler/lib/subst.mli @@ -62,4 +62,10 @@ module Including_Binders : sig val instrs : (Var.t -> Var.t) -> instr list -> instr list val block : (Var.t -> Var.t) -> block -> block + + module And_Continuations : sig + val block : Addr.t Addr.Map.t -> (Var.t -> Var.t) -> block -> block + (** Same as [Including_Binders.block], but also substitutes continuation + addresses. *) + end end From 370a0b0d742e9308874772ae051247c6ddd79cf2 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 28 Nov 2024 16:37:19 +0100 Subject: [PATCH 10/80] CR: make caml_callback an alias of caml_call_gen... ... when double translation is enabled. --- compiler/lib/effects.ml | 19 ++++++++----------- runtime/js/jslib.js | 21 ++------------------- 2 files changed, 10 insertions(+), 30 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 2cab14e64d..2bf8a3a7e9 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -957,12 +957,14 @@ let rewrite_direct_block ; 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. *) + (* Pass the identity as a continuation and pass to [caml_trampoline_cps], which + will 1. install a trampoline, 2. initialize the fiber stack, 3. call the CPS + version of [f] and handle exceptions. *) let k = Var.fresh_n "cont" in + let dummy = Var.fresh_n "dummy" in let args = Var.fresh_n "args" in - [ Let (k, Prim (Extern "caml_resume_stack", [ Pv stack; Pv ident_fn ])) + [ Let (dummy, Prim (Extern "caml_initialize_fiber_stack", [])) + ; 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 ])) ] @@ -1282,8 +1284,7 @@ let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = let p = if double_translate () then - (* Initialize the global fiber stack and define a global identity function, - needed to translate [%resume] *) + (* Define a global identity function, used when translating [%resume] *) let id_pc = p.free_pc in let blocks = let id_param = Var.fresh_n "x" in @@ -1293,16 +1294,12 @@ let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = 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", [])) - ] + ; body = [ Let (ident_fn, Closure ([ id_arg ], (id_pc, [ id_arg ]))) ] ; branch = Branch (p.start, []) } blocks diff --git a/runtime/js/jslib.js b/runtime/js/jslib.js index 1c319c7d59..224ce92876 100644 --- a/runtime/js/jslib.js +++ b/runtime/js/jslib.js @@ -125,25 +125,8 @@ function caml_callback(f, args) { //Provides: caml_callback //If: effects //If: doubletranslate -//Requires:caml_stack_depth, caml_call_gen, caml_exn_stack, caml_fiber_stack, uncaught_effect_handler -//Requires: caml_raise_constant -function caml_callback(f, args) { - 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; - } -} +//Requires: caml_call_gen +var caml_callback = caml_call_gen; //Provides: caml_is_js function caml_is_js() { From e980a1b2320bb9cd8db7c9f10daa3ce5adbe5383 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 28 Nov 2024 16:53:07 +0100 Subject: [PATCH 11/80] Promote tests --- compiler/tests-compiler/double-translation/direct_calls.ml | 1 - compiler/tests-compiler/double-translation/effects_toplevel.ml | 1 - 2 files changed, 2 deletions(-) diff --git a/compiler/tests-compiler/double-translation/direct_calls.ml b/compiler/tests-compiler/double-translation/direct_calls.ml index 5757f9008c..c0db69b7f6 100644 --- a/compiler/tests-compiler/double-translation/direct_calls.ml +++ b/compiler/tests-compiler/double-translation/direct_calls.ml @@ -95,7 +95,6 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = ? 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(), diff --git a/compiler/tests-compiler/double-translation/effects_toplevel.ml b/compiler/tests-compiler/double-translation/effects_toplevel.ml index dc3d4caa8b..baeaba0350 100644 --- a/compiler/tests-compiler/double-translation/effects_toplevel.ml +++ b/compiler/tests-compiler/double-translation/effects_toplevel.ml @@ -56,7 +56,6 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = : 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(), From 55cbe59a91fa7ee996b45378b96f9b93b3d7c0ec Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 28 Nov 2024 18:32:04 +0100 Subject: [PATCH 12/80] CR: Fix caml_trampoline_cps and rename it to caml_resume --- compiler/lib/effects.ml | 47 ++----------------------------- runtime/js/effect.js | 62 ++++++++++++++++++++++------------------- 2 files changed, 36 insertions(+), 73 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 2bf8a3a7e9..a8bb5cb9b2 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -935,14 +935,7 @@ let rewrite_direct_instr ~st instr = 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 = +let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc ~lifter_functions block = debug_print "@[rewrite_direct_block %d@,@]" pc; if double_translate () then @@ -957,17 +950,7 @@ let rewrite_direct_block ; 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. initialize the fiber stack, 3. call the CPS - version of [f] and handle exceptions. *) - let k = Var.fresh_n "cont" in - let dummy = Var.fresh_n "dummy" in - let args = Var.fresh_n "args" in - [ Let (dummy, Prim (Extern "caml_initialize_fiber_stack", [])) - ; 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 "caml_resume", [ Pv f; Pv arg; Pv stack ])) ] | Let (x, Prim (Extern "%perform", [ Pv effect ])) -> (* In direct-style code, we just raise [Effect.Unhandled]. *) [ Let (x, Prim (Extern "caml_raise_unhandled", [ Pv effect ])) ] @@ -1031,7 +1014,6 @@ let subst_bound_in_blocks blocks s = 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 @@ -1182,7 +1164,6 @@ let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = ~st ~cps_needed ~closure_info:st.closure_info - ~ident_fn ~pc ~lifter_functions block @@ -1201,7 +1182,6 @@ let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = ~st ~cps_needed ~closure_info:st.closure_info - ~ident_fn ~pc ~lifter_functions block @@ -1283,28 +1263,7 @@ let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = in let p = if double_translate () - then - (* Define a global identity function, used when translating [%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 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 ]))) ] - ; branch = Branch (p.start, []) - } - blocks - in - { start = new_start; blocks; free_pc = new_start + 1 } + then p else match Hashtbl.find_opt closure_info p.start with | None -> p diff --git a/runtime/js/effect.js b/runtime/js/effect.js index eb0a7039c9..5f292c8ae7 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -118,17 +118,6 @@ var uncaught_effect_handler = { cps: uncaught_effect_handler_cps }; // 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 @@ -284,26 +273,41 @@ 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 +//Provides: caml_resume +//Requires:caml_stack_depth, caml_call_gen_cps, caml_exn_stack, caml_fiber_stack, caml_wrap_exception, uncaught_effect_handler, caml_resume_stack //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; +function caml_resume(f, arg, stack) { + var saved_stack_depth = caml_stack_depth; + var saved_exn_stack = caml_exn_stack; + var saved_fiber_stack = caml_fiber_stack; + try { + caml_exn_stack = 0; + caml_fiber_stack = { + h: [0, 0, 0, uncaught_effect_handler], + r: { k: 0, x: 0, e: 0 }, + }; + var k = caml_resume_stack(stack, x => x); + /* Note: f is not an ordinary function but a (direct-style, CPS) closure pair */ + var res = { joo_tramp: f, joo_args: [arg, k] }; + 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; + } finally { + caml_stack_depth = saved_stack_depth; + caml_exn_stack = saved_exn_stack; + caml_fiber_stack = saved_fiber_stack; + } } //Provides: caml_cps_closure From ef3bc27383a4d0666a46eb918977b122d794f0b3 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 28 Nov 2024 18:32:29 +0100 Subject: [PATCH 13/80] CR: First fixes to Lambda_lifting_simple --- compiler/lib/lambda_lifting_simple.ml | 23 ++--------------------- 1 file changed, 2 insertions(+), 21 deletions(-) diff --git a/compiler/lib/lambda_lifting_simple.ml b/compiler/lib/lambda_lifting_simple.ml index 78b4a2d84d..32c32b0a08 100644 --- a/compiler/lib/lambda_lifting_simple.ml +++ b/compiler/lib/lambda_lifting_simple.ml @@ -66,11 +66,7 @@ let collect_free_vars program var_depth depth 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; + Freevars.iter_block_bound_vars (fun x -> var_depth.(Var.idx x) <- depth) block; List.iter block.body ~f:(fun i -> match i with | Let (_, Closure (params, _)) -> @@ -189,22 +185,7 @@ let rec traverse ~to_lift var_depth (program, (functions : instr list), lifters) 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 program, functions, lifters = st in let free_vars = List.fold_left current_contiguous From c2f39d3682ba7157ba218d1e72a99b24b5264dbe Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 29 Nov 2024 13:27:50 +0100 Subject: [PATCH 14/80] Simplify and clarify Lambda_lifting_simple --- compiler/lib/lambda_lifting_simple.ml | 476 +++++++++++++------------- 1 file changed, 245 insertions(+), 231 deletions(-) diff --git a/compiler/lib/lambda_lifting_simple.ml b/compiler/lib/lambda_lifting_simple.ml index 32c32b0a08..0667ff2c94 100644 --- a/compiler/lib/lambda_lifting_simple.ml +++ b/compiler/lib/lambda_lifting_simple.ml @@ -73,235 +73,259 @@ let mark_bound_variables var_depth block depth = 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) = +let starts_with_closure = function + | Let (_, Closure _) :: _ -> true + | _ :: _ | [] -> false + +(* Replace closures to lift by lifter applications; returns definitions and names of the + lifter functions (to be defined before the new body). *) +let rec rewrite_blocks + ~to_lift + ~var_depth + ~st:(program, (functions : instr list), lifters) + ~pc + ~depth : _ * _ * (Var.Set.t * Var.t Var.Map.t) = + assert (depth > 0); 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 + let body, (program, functions, lifters) = + rewrite_body + ~to_lift + ~var_depth + ~current_contiguous:[] + ~st:(program, functions, lifters) + ~depth + ~acc_instr:[] + block.body + in + ( { program with blocks = Addr.Map.add pc { block with body } program.blocks } + , functions + , lifters )) + pc + program.blocks + (program, functions, lifters) + +and rewrite_body + ~to_lift + ~depth + ~var_depth + ~current_contiguous + ~acc_instr + ~(st : Code.program * instr list * (Var.Set.t * Var.t Var.Map.t)) + body = + (* We lift possibly mutually recursive closures (that are created by contiguous + statements) together. Isolated closures are lambda-lifted normally. *) + match body with + | Let (f, (Closure (_, (pc', _)) as cl)) :: rem + when List.is_empty current_contiguous + && Var.Set.mem f to_lift + && not (starts_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 = + rewrite_blocks ~to_lift ~var_depth ~st ~pc:pc' ~depth:(depth + 1) + in + let free_vars = collect_free_vars program var_depth (depth + 1) pc' in + if debug () 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:@,"; + 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 + (* Add to returned list of lifter functions definitions *) + 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 + rewrite_body + ~to_lift + ~current_contiguous:[] + ~st:(program, functions, lifters) + ~var_depth + ~acc_instr: + (* Replace closure with application of the lifter function *) + (Let (f, Apply { f = f''; args = List.map ~f:fst s; exact = true }) :: acc_instr) + ~depth + rem + | Let (cname, Closure (params, (pc', args))) :: rem -> + (* More closure definitions follow: accumulate and lift later *) + let st = rewrite_blocks ~to_lift ~var_depth ~st ~pc:pc' ~depth:(depth + 1) in + rewrite_body + ~to_lift + ~var_depth + ~current_contiguous:((cname, params, pc', args) :: current_contiguous) + ~st + ~acc_instr + ~depth + rem + | _ :: _ | [] -> ( + (* Process the accumulated closure definitions *) + assert ( + match current_contiguous with + | [ (f, _, _, _) ] -> not (Var.Set.mem f to_lift) + | _ -> true); + let st, acc_instr = + match current_contiguous with + | [] -> st, acc_instr + | _ :: _ + when List.exists + ~f:(fun (f, _, _, _) -> Var.Set.mem f to_lift) + current_contiguous -> + (* Lift several closures at once *) + let program, functions, lifters = 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.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 = 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 )) + 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 rev_decl = + let tuple = Var.fresh_n "tuple" in + List.rev + (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)))) + in + (program, functions, lifters), rev_decl @ acc_instr + | _ :: _ -> + (* No need to lift the accumulated closures: just keep their definitions + unchanged *) + let rev_decls = + List.map current_contiguous ~f:(fun (f, params, pc, args) -> + Let (f, Closure (params, (pc, args)))) + in + st, rev_decls @ acc_instr + in + match body with + | [] -> List.rev acc_instr, st + | i :: rem -> + rewrite_body + ~to_lift + ~var_depth + ~depth + ~current_contiguous:[] + ~st + ~acc_instr:(i :: acc_instr) + rem) + +let lift ~to_lift ~pc program : program * Var.Set.t * Var.t Var.Map.t = + let nv = Var.count () in + let var_depth = Array.make nv (-1) in + Code.preorder_traverse + { fold = Code.fold_children } + (fun pc (program, lifter_names, lifter_map) -> + let block = Code.Addr.Map.find pc program.blocks in + mark_bound_variables var_depth block 0; + let program, body, (lifter_names', lifter_map') = + 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 = + rewrite_blocks + ~to_lift + ~var_depth + ~st:(program, [], lifters) + ~pc: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 lifter_names lifter_names' + , Var.Map.union (fun _ _ -> assert false) lifter_map lifter_map' )) pc program.blocks - (program, functions, lifters) + (program, Var.Set.empty, Var.Map.empty) let f ~to_lift program = if debug () @@ -310,16 +334,6 @@ let f ~to_lift program = 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); + let program, lifters, liftings = lift ~to_lift ~pc:program.start program in if Debug.find "times" () then Format.eprintf " lambda lifting: %a@." Timer.print t; program, lifters, liftings From 21c955b9d28e878d679881c95fd89c9cc73dfa6a Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 29 Nov 2024 13:30:40 +0100 Subject: [PATCH 15/80] Format runtime --- runtime/js/effect.js | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/runtime/js/effect.js b/runtime/js/effect.js index 5f292c8ae7..e8a83972b1 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -287,7 +287,7 @@ function caml_resume(f, arg, stack) { h: [0, 0, 0, uncaught_effect_handler], r: { k: 0, x: 0, e: 0 }, }; - var k = caml_resume_stack(stack, x => x); + var k = caml_resume_stack(stack, (x) => x); /* Note: f is not an ordinary function but a (direct-style, CPS) closure pair */ var res = { joo_tramp: f, joo_args: [arg, k] }; do { @@ -299,7 +299,10 @@ function caml_resume(f, arg, stack) { 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)] }; + res = { + joo_tramp: { cps: handler }, + joo_args: [caml_wrap_exception(e)], + }; } } while (res && res.joo_args); return res; From 5ed1a30c97ae373dfe5488f4ac9bf286b301d940 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 29 Nov 2024 13:42:01 +0100 Subject: [PATCH 16/80] Fix bug: functions inside CPS functions were not lambda-lifted --- compiler/lib/lambda_lifting_simple.ml | 34 ++++++++++++++++++++++----- 1 file changed, 28 insertions(+), 6 deletions(-) diff --git a/compiler/lib/lambda_lifting_simple.ml b/compiler/lib/lambda_lifting_simple.ml index 0667ff2c94..a17063185b 100644 --- a/compiler/lib/lambda_lifting_simple.ml +++ b/compiler/lib/lambda_lifting_simple.ml @@ -81,6 +81,7 @@ let starts_with_closure = function lifter functions (to be defined before the new body). *) let rec rewrite_blocks ~to_lift + ~inside_lifted ~var_depth ~st:(program, (functions : instr list), lifters) ~pc @@ -94,6 +95,7 @@ let rec rewrite_blocks let body, (program, functions, lifters) = rewrite_body ~to_lift + ~inside_lifted ~var_depth ~current_contiguous:[] ~st:(program, functions, lifters) @@ -110,6 +112,7 @@ let rec rewrite_blocks and rewrite_body ~to_lift + ~inside_lifted ~depth ~var_depth ~current_contiguous @@ -121,13 +124,19 @@ and rewrite_body match body with | Let (f, (Closure (_, (pc', _)) as cl)) :: rem when List.is_empty current_contiguous - && Var.Set.mem f to_lift + && (inside_lifted || Var.Set.mem f to_lift) && not (starts_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 = - rewrite_blocks ~to_lift ~var_depth ~st ~pc:pc' ~depth:(depth + 1) + rewrite_blocks + ~to_lift + ~inside_lifted:true + ~var_depth + ~st + ~pc:pc' + ~depth:(depth + 1) in let free_vars = collect_free_vars program var_depth (depth + 1) pc' in if debug () @@ -160,6 +169,7 @@ and rewrite_body let lifters = Var.Set.add f'' (fst lifters), Var.Map.add f f' (snd lifters) in rewrite_body ~to_lift + ~inside_lifted ~current_contiguous:[] ~st:(program, functions, lifters) ~var_depth @@ -170,9 +180,18 @@ and rewrite_body rem | Let (cname, Closure (params, (pc', args))) :: rem -> (* More closure definitions follow: accumulate and lift later *) - let st = rewrite_blocks ~to_lift ~var_depth ~st ~pc:pc' ~depth:(depth + 1) in + let st = + rewrite_blocks + ~to_lift + ~inside_lifted:(inside_lifted || Var.Set.mem cname to_lift) + ~var_depth + ~st + ~pc:pc' + ~depth:(depth + 1) + in rewrite_body ~to_lift + ~inside_lifted ~var_depth ~current_contiguous:((cname, params, pc', args) :: current_contiguous) ~st @@ -189,9 +208,10 @@ and rewrite_body match current_contiguous with | [] -> st, acc_instr | _ :: _ - when List.exists - ~f:(fun (f, _, _, _) -> Var.Set.mem f to_lift) - current_contiguous -> + when inside_lifted + || List.exists + ~f:(fun (f, _, _, _) -> Var.Set.mem f to_lift) + current_contiguous -> (* Lift several closures at once *) let program, functions, lifters = st in let free_vars = @@ -287,6 +307,7 @@ and rewrite_body | i :: rem -> rewrite_body ~to_lift + ~inside_lifted ~var_depth ~depth ~current_contiguous:[] @@ -312,6 +333,7 @@ let lift ~to_lift ~pc program : program * Var.Set.t * Var.t Var.Map.t = let program, functions, lifters = rewrite_blocks ~to_lift + ~inside_lifted:false ~var_depth ~st:(program, [], lifters) ~pc:pc' From efb789238bf2fb242e051b4adb91a95e5bb0f3f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 29 Nov 2024 15:38:00 +0100 Subject: [PATCH 17/80] Runtime: fix caml_uncaught_effect_handler We can use a single definition for the CPS transformation and the double translation. The definition for the CPS transformation was wrong, since it did not take a continuation as parameter. --- runtime/js/effect.js | 26 ++++---------------------- runtime/js/jslib.js | 4 ++-- 2 files changed, 6 insertions(+), 24 deletions(-) diff --git a/runtime/js/effect.js b/runtime/js/effect.js index e8a83972b1..cb1d1d79f2 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -84,33 +84,15 @@ function caml_raise_unhandled(eff) { } } -//Provides: uncaught_effect_handler +//Provides: caml_uncaught_effect_handler //Requires: caml_resume_stack, caml_raise_unhandled //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); - caml_raise_unhandled(eff); -} - -//Provides: uncaught_effect_handler_cps -//Requires: caml_resume_stack, caml_raise_unhandled -//If: effects -//If: doubletranslate -function uncaught_effect_handler_cps(eff, k, ms, cont) { +function caml_uncaught_effect_handler(eff, k, ms, cont) { // Resumes the continuation k by raising exception Unhandled. caml_resume_stack(k[1], ms); caml_raise_unhandled(eff); } -//Provides: uncaught_effect_handler -//Requires: uncaught_effect_handler_cps -//If: effects -//If: doubletranslate -//Weakdef -var uncaught_effect_handler = { cps: uncaught_effect_handler_cps }; - //Provides: caml_fiber_stack //If: effects // This has the shape {h, r:{k, x, e}} where h is a triple of handlers @@ -274,7 +256,7 @@ function jsoo_effect_not_supported() { } //Provides: caml_resume -//Requires:caml_stack_depth, caml_call_gen_cps, caml_exn_stack, caml_fiber_stack, caml_wrap_exception, uncaught_effect_handler, caml_resume_stack +//Requires:caml_stack_depth, caml_call_gen_cps, caml_exn_stack, caml_fiber_stack, caml_wrap_exception, caml_uncaught_effect_handler, caml_resume_stack //If: effects //If: doubletranslate function caml_resume(f, arg, stack) { @@ -284,7 +266,7 @@ function caml_resume(f, arg, stack) { try { caml_exn_stack = 0; caml_fiber_stack = { - h: [0, 0, 0, uncaught_effect_handler], + h: [0, 0, 0, { cps: caml_uncaught_effect_handler }], r: { k: 0, x: 0, e: 0 }, }; var k = caml_resume_stack(stack, (x) => x); diff --git a/runtime/js/jslib.js b/runtime/js/jslib.js index 224ce92876..67ba1c4245 100644 --- a/runtime/js/jslib.js +++ b/runtime/js/jslib.js @@ -85,7 +85,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, uncaught_effect_handler +//Requires:caml_stack_depth, caml_call_gen, caml_exn_stack, caml_fiber_stack, caml_wrap_exception, caml_uncaught_effect_handler function caml_callback(f, args) { var saved_stack_depth = caml_stack_depth; var saved_exn_stack = caml_exn_stack; @@ -93,7 +93,7 @@ function caml_callback(f, args) { try { caml_exn_stack = 0; caml_fiber_stack = { - h: [0, 0, 0, uncaught_effect_handler], + h: [0, 0, 0, caml_uncaught_effect_handler], r: { k: 0, x: 0, e: 0 }, }; var res = { From 5b7c9e43c2faca2b8959c8ffa2f1a2bfbb0291a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 29 Nov 2024 15:44:46 +0100 Subject: [PATCH 18/80] Runtime: the trampoline now distinguish direct and CPS calls --- compiler/lib/generate.ml | 10 ++++------ .../double-translation/direct_calls.ml | 6 +++--- .../double-translation/effects_toplevel.ml | 2 +- compiler/tests-compiler/effects_toplevel.ml | 6 +++--- runtime/js/effect.js | 13 ++++++++----- runtime/js/jslib.js | 4 ++-- 6 files changed, 21 insertions(+), 20 deletions(-) diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index ab7c13d52a..ecc38babeb 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -966,15 +966,13 @@ let apply_fun_raw = 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.call (runtime_fun ctx "caml_stack_check_depth") [] loc , apply - , J.call (runtime_fun ctx "caml_trampoline_return") [ f; J.array params ] loc )) + , J.call + (runtime_fun ctx "caml_trampoline_return") + [ f; J.array params; (if cps then zero else one) ] + loc )) else apply let generate_apply_fun ctx { arity; exact; trampolined; in_cps } = diff --git a/compiler/tests-compiler/double-translation/direct_calls.ml b/compiler/tests-compiler/double-translation/direct_calls.ml index c0db69b7f6..14d509140c 100644 --- a/compiler/tests-compiler/double-translation/direct_calls.ml +++ b/compiler/tests-compiler/double-translation/direct_calls.ml @@ -77,7 +77,7 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = 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]); + : runtime.caml_trampoline_return(f, [a0, a1], 0); } function caml_trampoline_cps_call3(f, a0, a1, a2){ return runtime.caml_stack_check_depth() @@ -88,12 +88,12 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = === 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]); + : runtime.caml_trampoline_return(f, [a0, a1, a2], 0); } 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_trampoline_return(f, [a0, a1, a2], 0); } var dummy = 0, diff --git a/compiler/tests-compiler/double-translation/effects_toplevel.ml b/compiler/tests-compiler/double-translation/effects_toplevel.ml index baeaba0350..0eb8ef9f3e 100644 --- a/compiler/tests-compiler/double-translation/effects_toplevel.ml +++ b/compiler/tests-compiler/double-translation/effects_toplevel.ml @@ -54,7 +54,7 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = === 2 ? f.cps.call(null, a0, a1) : runtime.caml_call_gen_cps(f, [a0, a1]) - : runtime.caml_trampoline_return(f, [a0, a1]); + : runtime.caml_trampoline_return(f, [a0, a1], 0); } var dummy = 0, diff --git a/compiler/tests-compiler/effects_toplevel.ml b/compiler/tests-compiler/effects_toplevel.ml index 9ea488ee9f..255c7a40ad 100644 --- a/compiler/tests-compiler/effects_toplevel.ml +++ b/compiler/tests-compiler/effects_toplevel.ml @@ -43,7 +43,7 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = function caml_exact_trampoline_call1(f, a0){ return runtime.caml_stack_check_depth() ? f(a0) - : runtime.caml_trampoline_return(f, [a0]); + : runtime.caml_trampoline_return(f, [a0], 1); } function caml_trampoline_cps_call2(f, a0, a1){ return runtime.caml_stack_check_depth() @@ -54,12 +54,12 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = === 2 ? f(a0, a1) : runtime.caml_call_gen(f, [a0, a1]) - : runtime.caml_trampoline_return(f, [a0, a1]); + : runtime.caml_trampoline_return(f, [a0, a1], 0); } 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]); + : runtime.caml_trampoline_return(f, [a0, a1], 0); } return caml_callback (function(cont){ diff --git a/runtime/js/effect.js b/runtime/js/effect.js index cb1d1d79f2..8156b4f4a9 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -149,7 +149,7 @@ function caml_perform_effect(eff, cont, k0) { var k1 = caml_pop_fiber(); return caml_stack_check_depth() ? caml_get_cps_fun(handler)(eff, cont, k1, k1) - : caml_trampoline_return(handler, [eff, cont, k1, k1]); + : caml_trampoline_return(handler, [eff, cont, k1, k1], 0); } //Provides: caml_get_cps_fun @@ -176,7 +176,7 @@ function caml_alloc_stack(hv, hx, hf) { var args = [x, caml_pop_fiber()]; return caml_stack_check_depth() ? caml_call_gen_cps(f, args) - : caml_trampoline_return(f, args); + : caml_trampoline_return(f, args, 0); } function hval(x) { // Call [hv] in the parent fiber @@ -271,19 +271,22 @@ function caml_resume(f, arg, stack) { }; var k = caml_resume_stack(stack, (x) => x); /* Note: f is not an ordinary function but a (direct-style, CPS) closure pair */ - var res = { joo_tramp: f, joo_args: [arg, k] }; + var res = { joo_tramp: f, joo_args: [arg, k], joo_direct: 0 }; do { caml_stack_depth = 40; try { - res = caml_call_gen_cps(res.joo_tramp, res.joo_args); + res = res.joo_direct + ? res.joo_tramp.apply(null, res.joo_args) + : 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_tramp: handler, joo_args: [caml_wrap_exception(e)], + joo_direct: 1, }; } } while (res && res.joo_args); diff --git a/runtime/js/jslib.js b/runtime/js/jslib.js index 67ba1c4245..2fef127f8d 100644 --- a/runtime/js/jslib.js +++ b/runtime/js/jslib.js @@ -61,8 +61,8 @@ function caml_trampoline(res) { } //Provides:caml_trampoline_return -function caml_trampoline_return(f, args) { - return { joo_tramp: f, joo_args: args }; +function caml_trampoline_return(f, args, direct) { + return { joo_tramp: f, joo_args: args, joo_direct: direct }; } //Provides:caml_stack_depth From 1d34f2b568b1799682b49a0d985637ea82038c04 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 3 Dec 2024 15:20:26 +0100 Subject: [PATCH 19/80] Fix unregistered test and add one for nested handler --- .../assume_no_perform_nested_handler.ml | 25 +++++++++++++++++++ .../assume_no_perform_unhandled.ml | 11 +++++--- .../assume_no_perform_nested_handler.ml | 25 +++++++++++++++++++ .../lib-effects/double-translation/dune | 17 +++++++++++++ compiler/tests-ocaml/lib-effects/dune | 13 +++++++--- 5 files changed, 84 insertions(+), 7 deletions(-) create mode 100644 compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml create mode 100644 compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_nested_handler.ml diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml b/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml new file mode 100644 index 0000000000..0d91ba09b2 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml @@ -0,0 +1,25 @@ +open Printf +open Effect +open Effect.Deep + +type _ Effect.t += Dummy : unit t + +let () = + try_with + (fun () -> + Js_of_ocaml.Js.Effect.assume_no_perform (fun () -> + try_with + (fun () -> ()) + () + { effc = (fun (type a) (_ : a Effect.t) -> None) }; + perform Dummy + ) + ) + () + { effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Dummy -> + Some (fun (k : (a, _) continuation) -> print_endline "ok"; continue k ()) + | _ -> None) + } diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml index c81d984806..a647cbe951 100644 --- a/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml +++ b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml @@ -4,11 +4,10 @@ open Effect.Deep type _ Effect.t += Dummy : unit t -let must_raise () = +let f () = try_with (fun () -> Js_of_ocaml.Js.Effect.assume_no_perform (fun () -> - (* Should raise [Effect.Unhandled] despite the installed handler *) perform Dummy ) ) @@ -22,5 +21,9 @@ let must_raise () = let () = try - must_raise (); print_endline "failed"; exit 2 - with Effect.Unhandled Dummy -> print_endline "ok" + (* When double translation is not enabled, [f] should not raise *) + f (); print_endline "ok" + with Effect.Unhandled Dummy -> ( + print_endline "failed"; + exit 2 + ) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_nested_handler.ml b/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_nested_handler.ml new file mode 100644 index 0000000000..7be1f1aacd --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_nested_handler.ml @@ -0,0 +1,25 @@ +open Printf +open Effect +open Effect.Deep + +type _ Effect.t += Dummy : unit t + +let () = + try_with + (fun () -> + Js_of_ocaml.Js.Effect.assume_no_perform (fun () -> + try_with + (fun () -> ()) + () + { effc = (fun (type a) (_ : a Effect.t) -> None) }; + ); + perform Dummy + ) + () + { effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Dummy -> + Some (fun (k : (a, _) continuation) -> print_endline "ok"; continue k ()) + | _ -> None) + } diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index 624fba4254..1dbb44d02e 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -508,3 +508,20 @@ (diff assume_no_perform_unhandled.reference assume_no_perform_unhandled.referencejs))) + +(executable + (name assume_no_perform_nested_handler) + (enabled_if + (>= %{ocaml_version} 5)) + (modules assume_no_perform_nested_handler) + (modes js) + (libraries js_of_ocaml)) + +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} 5)) + (deps assume_no_perform_nested_handler.bc.js) + (action + (ignore-stdout + (run node ./assume_no_perform_nested_handler.bc.js)))) diff --git a/compiler/tests-ocaml/lib-effects/dune b/compiler/tests-ocaml/lib-effects/dune index c98c83eabb..e1258a9fbc 100644 --- a/compiler/tests-ocaml/lib-effects/dune +++ b/compiler/tests-ocaml/lib-effects/dune @@ -32,7 +32,12 @@ test_lazy used_cont) (modules - (:standard \ unhandled_unlinked)) + (:standard + \ + unhandled_unlinked + assume_no_perform + assume_no_perform_unhandled + assume_no_perform_nested_handler)) (modes js wasm)) (tests @@ -51,8 +56,10 @@ (tests (build_if (>= %{ocaml_version} 5)) - (names assume_no_perform) - (modules assume_no_perform) + (names + assume_no_perform + assume_no_perform_unhandled + assume_no_perform_nested_handler) (libraries js_of_ocaml) (action (ignore-outputs From 425e5264764d2522c7381f23e8c9233d40c4dac2 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 3 Dec 2024 16:28:53 +0100 Subject: [PATCH 20/80] Uses 'tests' dune stanza --- ...e => assume_no_perform_unhandled.expected} | 0 .../{cmphash.reference => cmphash.expected} | 0 .../lib-effects/double-translation/dune | 498 +----------------- .../{effects.reference => effects.expected} | 0 .../{evenodd.reference => evenodd.expected} | 0 .../{manylive.reference => manylive.expected} | 0 .../{marshal.reference => marshal.expected} | 0 .../{overflow.reference => overflow.expected} | 0 .../{partial.reference => partial.expected} | 0 ...reperform.reference => reperform.expected} | 0 .../{sched.reference => sched.expected} | 0 ...state.reference => shallow_state.expected} | 0 ...io.reference => shallow_state_io.expected} | 0 .../{test1.reference => test1.expected} | 0 .../{test10.reference => test10.expected} | 0 .../{test11.reference => test11.expected} | 0 .../{test2.reference => test2.expected} | 0 .../{test3.reference => test3.expected} | 0 .../{test4.reference => test4.expected} | 0 .../{test5.reference => test5.expected} | 0 .../{test6.reference => test6.expected} | 0 ...test_lazy.reference => test_lazy.expected} | 0 ....reference => unhandled_unlinked.expected} | 0 ...used_cont.reference => used_cont.expected} | 0 24 files changed, 29 insertions(+), 469 deletions(-) rename compiler/tests-ocaml/lib-effects/double-translation/{assume_no_perform_unhandled.reference => assume_no_perform_unhandled.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{cmphash.reference => cmphash.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{effects.reference => effects.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{evenodd.reference => evenodd.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{manylive.reference => manylive.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{marshal.reference => marshal.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{overflow.reference => overflow.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{partial.reference => partial.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{reperform.reference => reperform.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{sched.reference => sched.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{shallow_state.reference => shallow_state.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{shallow_state_io.reference => shallow_state_io.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{test1.reference => test1.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{test10.reference => test10.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{test11.reference => test11.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{test2.reference => test2.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{test3.reference => test3.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{test4.reference => test4.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{test5.reference => test5.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{test6.reference => test6.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{test_lazy.reference => test_lazy.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{unhandled_unlinked.reference => unhandled_unlinked.expected} (100%) rename compiler/tests-ocaml/lib-effects/double-translation/{used_cont.reference => used_cont.expected} (100%) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.reference b/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.reference rename to compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/cmphash.reference b/compiler/tests-ocaml/lib-effects/double-translation/cmphash.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/cmphash.reference rename to compiler/tests-ocaml/lib-effects/double-translation/cmphash.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index 1dbb44d02e..bd4262aca0 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -24,8 +24,8 @@ ;; multiple versions of the dependencies (compilation_mode whole_program)))) -(executables - (enabled_if +(tests + (build_if (>= %{ocaml_version} 5)) (names cmphash @@ -50,478 +50,38 @@ test_lazy used_cont) (modules - (:standard \ unhandled_unlinked)) + (:standard + \ + unhandled_unlinked + assume_no_perform + assume_no_perform_unhandled + assume_no_perform_nested_handler)) (modes js)) -(executables - (enabled_if +(tests + (build_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))) - -(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)))) - -(executable - (name assume_no_perform_unhandled) - (enabled_if - (>= %{ocaml_version} 5)) - (modules assume_no_perform_unhandled) - (modes js) - (libraries js_of_ocaml)) - -(rule - (target assume_no_perform_unhandled.referencejs) - (enabled_if - (>= %{ocaml_version} 5)) - (deps assume_no_perform_unhandled.bc.js) - (action - (with-stdout-to - %{target} - (run node ./assume_no_perform_unhandled.bc.js)))) - -(rule - (alias runtest) - (enabled_if - (>= %{ocaml_version} 5)) - (deps - assume_no_perform_unhandled.reference - assume_no_perform_unhandled.referencejs) - (action - (diff - assume_no_perform_unhandled.reference - assume_no_perform_unhandled.referencejs))) - -(executable - (name assume_no_perform_nested_handler) - (enabled_if - (>= %{ocaml_version} 5)) - (modules assume_no_perform_nested_handler) - (modes js) - (libraries js_of_ocaml)) + (pipe-outputs + (with-accepted-exit-codes + 2 + (run node %{test})) + (run cat))) + (modes js)) -(rule - (alias runtest) - (enabled_if +(tests + (build_if (>= %{ocaml_version} 5)) - (deps assume_no_perform_nested_handler.bc.js) - (action - (ignore-stdout - (run node ./assume_no_perform_nested_handler.bc.js)))) + (names + assume_no_perform + assume_no_perform_unhandled + assume_no_perform_nested_handler) + (libraries js_of_ocaml) + (action + (ignore-outputs + (with-accepted-exit-codes + 0 + (run node %{test})))) + (modes js)) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/effects.reference b/compiler/tests-ocaml/lib-effects/double-translation/effects.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/effects.reference rename to compiler/tests-ocaml/lib-effects/double-translation/effects.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/evenodd.reference b/compiler/tests-ocaml/lib-effects/double-translation/evenodd.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/evenodd.reference rename to compiler/tests-ocaml/lib-effects/double-translation/evenodd.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/manylive.reference b/compiler/tests-ocaml/lib-effects/double-translation/manylive.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/manylive.reference rename to compiler/tests-ocaml/lib-effects/double-translation/manylive.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/marshal.reference b/compiler/tests-ocaml/lib-effects/double-translation/marshal.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/marshal.reference rename to compiler/tests-ocaml/lib-effects/double-translation/marshal.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/overflow.reference b/compiler/tests-ocaml/lib-effects/double-translation/overflow.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/overflow.reference rename to compiler/tests-ocaml/lib-effects/double-translation/overflow.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/partial.reference b/compiler/tests-ocaml/lib-effects/double-translation/partial.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/partial.reference rename to compiler/tests-ocaml/lib-effects/double-translation/partial.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/reperform.reference b/compiler/tests-ocaml/lib-effects/double-translation/reperform.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/reperform.reference rename to compiler/tests-ocaml/lib-effects/double-translation/reperform.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/sched.reference b/compiler/tests-ocaml/lib-effects/double-translation/sched.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/sched.reference rename to compiler/tests-ocaml/lib-effects/double-translation/sched.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/shallow_state.reference b/compiler/tests-ocaml/lib-effects/double-translation/shallow_state.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/shallow_state.reference rename to compiler/tests-ocaml/lib-effects/double-translation/shallow_state.expected 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.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.reference rename to compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test1.reference b/compiler/tests-ocaml/lib-effects/double-translation/test1.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/test1.reference rename to compiler/tests-ocaml/lib-effects/double-translation/test1.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test10.reference b/compiler/tests-ocaml/lib-effects/double-translation/test10.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/test10.reference rename to compiler/tests-ocaml/lib-effects/double-translation/test10.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test11.reference b/compiler/tests-ocaml/lib-effects/double-translation/test11.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/test11.reference rename to compiler/tests-ocaml/lib-effects/double-translation/test11.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test2.reference b/compiler/tests-ocaml/lib-effects/double-translation/test2.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/test2.reference rename to compiler/tests-ocaml/lib-effects/double-translation/test2.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test3.reference b/compiler/tests-ocaml/lib-effects/double-translation/test3.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/test3.reference rename to compiler/tests-ocaml/lib-effects/double-translation/test3.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test4.reference b/compiler/tests-ocaml/lib-effects/double-translation/test4.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/test4.reference rename to compiler/tests-ocaml/lib-effects/double-translation/test4.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test5.reference b/compiler/tests-ocaml/lib-effects/double-translation/test5.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/test5.reference rename to compiler/tests-ocaml/lib-effects/double-translation/test5.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test6.reference b/compiler/tests-ocaml/lib-effects/double-translation/test6.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/test6.reference rename to compiler/tests-ocaml/lib-effects/double-translation/test6.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test_lazy.reference b/compiler/tests-ocaml/lib-effects/double-translation/test_lazy.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/test_lazy.reference rename to compiler/tests-ocaml/lib-effects/double-translation/test_lazy.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.reference b/compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.reference rename to compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.expected diff --git a/compiler/tests-ocaml/lib-effects/double-translation/used_cont.reference b/compiler/tests-ocaml/lib-effects/double-translation/used_cont.expected similarity index 100% rename from compiler/tests-ocaml/lib-effects/double-translation/used_cont.reference rename to compiler/tests-ocaml/lib-effects/double-translation/used_cont.expected From f605852147ef443b7aaa202b4e17e476ec747911 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 3 Dec 2024 17:18:35 +0100 Subject: [PATCH 21/80] Reformat dune files and remove leftover files --- .../lib-effects/assume_no_perform_unhandled.reference | 1 - .../double-translation/assume_no_perform_unhandled.expected | 1 - 2 files changed, 2 deletions(-) delete mode 100644 compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.reference delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.expected diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.reference b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.reference deleted file mode 100644 index 9766475a41..0000000000 --- a/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.reference +++ /dev/null @@ -1 +0,0 @@ -ok diff --git a/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.expected b/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.expected deleted file mode 100644 index 9766475a41..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.expected +++ /dev/null @@ -1 +0,0 @@ -ok From 95867426a175943e7bf0fec30d93f74557ebb462 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 3 Dec 2024 17:21:52 +0100 Subject: [PATCH 22/80] CR: Fixes in Lambda_lifting_simple --- compiler/lib/lambda_lifting_simple.ml | 24 +++---- .../double-translation/direct_calls.ml | 66 +++++++++---------- 2 files changed, 44 insertions(+), 46 deletions(-) diff --git a/compiler/lib/lambda_lifting_simple.ml b/compiler/lib/lambda_lifting_simple.ml index a17063185b..630218dbcf 100644 --- a/compiler/lib/lambda_lifting_simple.ml +++ b/compiler/lib/lambda_lifting_simple.ml @@ -132,7 +132,7 @@ and rewrite_body let program, functions, lifters = rewrite_blocks ~to_lift - ~inside_lifted:true + ~inside_lifted:(Var.Set.mem f to_lift) ~var_depth ~st ~pc:pc' @@ -183,7 +183,7 @@ and rewrite_body let st = rewrite_blocks ~to_lift - ~inside_lifted:(inside_lifted || Var.Set.mem cname to_lift) + ~inside_lifted:(Var.Set.mem cname to_lift) ~var_depth ~st ~pc:pc' @@ -261,7 +261,7 @@ and rewrite_body let tuple = Var.fresh_n "tuple" in { params = [] ; body = - List.map2 f's current_contiguous ~f:(fun f' (_, params, pc, args) -> + List.rev_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 @@ -285,14 +285,16 @@ and rewrite_body f's) (snd lifters) ) in + let tuple = Var.fresh_n "tuple" in let rev_decl = - let tuple = Var.fresh_n "tuple" in - List.rev - (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)))) + 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))) in - (program, functions, lifters), rev_decl @ acc_instr + ( (program, functions, lifters) + , rev_decl + @ Let (tuple, Apply { f = f_tuple; args = List.map ~f:fst s; exact = true }) + :: acc_instr ) | _ :: _ -> (* No need to lift the accumulated closures: just keep their definitions unchanged *) @@ -329,11 +331,11 @@ let lift ~to_lift ~pc program : program * Var.Set.t * Var.t Var.Map.t = ~init:(program, [], (Var.Set.empty, Var.Map.empty)) ~f:(fun i (program, rem, lifters) -> match i with - | Let (_, Closure (_, (pc', _))) as i -> + | Let (f, Closure (_, (pc', _))) as i -> let program, functions, lifters = rewrite_blocks ~to_lift - ~inside_lifted:false + ~inside_lifted:(Var.Set.mem f to_lift) ~var_depth ~st:(program, [], lifters) ~pc:pc' diff --git a/compiler/tests-compiler/double-translation/direct_calls.ml b/compiler/tests-compiler/double-translation/direct_calls.ml index 14d509140c..ea53a9e2ce 100644 --- a/compiler/tests-compiler/double-translation/direct_calls.ml +++ b/compiler/tests-compiler/double-translation/direct_calls.ml @@ -98,12 +98,12 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = var dummy = 0, global_data = runtime.caml_get_global_data(), - _s_ = [0, [4, 0, 0, 0, 0], caml_string_of_jsbytes("%d")], + _x_ = [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$1(){ function f(g, x){ try{caml_call1(g, dummy); return;} catch(e$0){ @@ -111,20 +111,15 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = throw caml_maybe_attach_backtrace(e, 0); } } - f(function(x){}); - f(function(x){}); - return 0; + return f; } + function _d_(){return function(x){};} + function _f_(){return function(x){};} + function test1$0(param){var f = f$1(); f(_d_()); f(_f_()); 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){}); + var f = f$1(); + f(_d_()); + f(_f_()); return cont(0); } var test1 = caml_cps_closure(test1$0, test1$1); @@ -143,15 +138,15 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = return raise(e$0); }); return caml_exact_trampoline_cps_call - (g, x, function(_y_){caml_pop_trap(); return cont();}); + (g, x, function(_D_){caml_pop_trap(); return cont();}); } var f = caml_cps_closure(f$0, f$1); return f; } - function _h_(){ + function _k_(){ return caml_cps_closure(function(x){}, function(x, cont){return cont();}); } - function _j_(){ + function _m_(){ return caml_cps_closure (function(x){return caml_call2(Stdlib[28], x, cst_a$0);}, function(x, cont){ @@ -160,54 +155,55 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = } function test2$0(param){ var f = f$0(); - f(_h_(), 7); - f(_j_(), cst_a); + f(_k_(), 7); + f(_m_(), cst_a); return 0; } function test2$1(param, cont){ var f = f$0(); return caml_exact_trampoline_cps_call$0 (f, - _h_(), + _k_(), 7, - function(_w_){ + function(_B_){ return caml_exact_trampoline_cps_call$0 - (f, _j_(), cst_a, function(_x_){return cont(0);}); + (f, _m_(), cst_a, function(_C_){return cont(0);}); }); } var test2 = caml_cps_closure(test2$0, test2$1); - function test3$0(x){ + function F$0(){ 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_]; + return F; + } + function test3$0(x){ + var F = F$0(), M1 = F(), M2 = F(), _A_ = caml_call1(M2[1], 2); + return [0, caml_call1(M1[1], 1), _A_]; } 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 F = F$0(), M1 = F(), M2 = F(), _z_ = M2[1].call(null, 2); + return cont([0, M1[1].call(null, 1), _z_]); } 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$0(x){return caml_call2(Stdlib_Printf[2], _x_, x);} function f$1(x, cont){ - return caml_trampoline_cps_call3(Stdlib_Printf[2], _s_, x, cont); + return caml_trampoline_cps_call3(Stdlib_Printf[2], _x_, x, cont); } var f = caml_cps_closure(f$0, f$1); return f; } + function F(){function F(symbol){var f$0 = f(); return [0, f$0];} return F;} function test4$0(x){ - function F(symbol){var f$0 = f(); return [0, f$0];} - var M1 = F(), M2 = F(); + var F$0 = F(), M1 = F$0(), M2 = F$0(); 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(); + var F$0 = F(), M1 = F$0(), M2 = F$0(); return caml_exact_trampoline_cps_call (M1[1], 1, - function(_t_){ + function(_y_){ return caml_exact_trampoline_cps_call(M2[1], 2, cont); }); } From b62ba9adcf987d52f9e9e502be56f6a8966673f8 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 3 Dec 2024 18:19:39 +0100 Subject: [PATCH 23/80] CR: remove unnecessary conditionals in Effects --- compiler/lib/effects.ml | 173 +++------------------------------------- 1 file changed, 12 insertions(+), 161 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index a8bb5cb9b2..a6f14b2ad6 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -577,134 +577,17 @@ let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last = @ (Let (exn_handler, Prim (Extern "caml_pop_trap", [])) :: body) , branch )) -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 (_, (pc, _))) - when Var.Set.mem x st.cps_needed && Var.Set.mem x !(st.single_version_closures) -> + when (not (double_translate ())) && 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 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)) - -> + when double_translate () && Var.Set.mem x st.cps_needed -> 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 @@ -713,17 +596,6 @@ let cps_instr ~st (instr : instr) : instr list = ; 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) -> @@ -743,10 +615,6 @@ let cps_instr ~st (instr : instr) : instr list = 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"), _))) -> (* Applications of CPS functions and effect primitives require more work (allocating a continuation and/or modifying end-of-block branches) and @@ -783,7 +651,7 @@ let cps_instr ~st (instr : instr) : instr list = (List.length args) | _ -> [ instr ] -let cps_block ~st ~k ~lifter_functions ~orig_pc block = +let cps_block ~st ~k ~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 = @@ -855,11 +723,6 @@ let cps_block ~st ~k ~lifter_functions ~orig_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); @@ -935,13 +798,12 @@ let rewrite_direct_instr ~st instr = 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 ~pc ~lifter_functions block = +let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc 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 (x, Closure (params, ((pc, _) as cont))) when Var.Set.mem x cps_needed -> 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 @@ -1106,15 +968,13 @@ let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = in let function_needs_cps = match name_opt with - | Some name -> - should_compute_needed_transformations - && not (Var.Set.mem name lifter_functions) + | Some _ -> should_compute_needed_transformations | None -> (* 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) + not (double_translate () || Addr.Set.is_empty blocks_to_transform) in if debug () then ( @@ -1159,22 +1019,19 @@ let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = (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 + let cps_block = cps_block ~st ~k ~orig_pc:pc block in ( rewrite_direct_block ~st ~cps_needed ~closure_info:st.closure_info ~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 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 - )) + param_subst, fun pc block -> cps_block ~st ~k ~orig_pc:pc block, None) else ( param_subst , fun pc block -> @@ -1183,7 +1040,6 @@ let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = ~cps_needed ~closure_info:st.closure_info ~pc - ~lifter_functions block , None ) ) in @@ -1373,13 +1229,13 @@ let rewrite_toplevel ~cps_needed p = (****) -let split_blocks ~cps_needed ~lifter_functions (p : Code.program) = +let split_blocks ~cps_needed (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, e) when effect_primitive_or_application e -> ( + | Let (x, e) when effect_primitive_or_application e -> ((not (empty_body r)) || match branch with @@ -1387,11 +1243,6 @@ let split_blocks ~cps_needed ~lifter_functions (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 = @@ -1503,7 +1354,7 @@ let f ~flow_info ~live_vars p = 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 = split_blocks ~cps_needed 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 From ffa361b2c4e8f91e2eed23d7cf030118bfb584f3 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 4 Dec 2024 15:01:46 +0100 Subject: [PATCH 24/80] CR: Remove duplicate instruction --- compiler/lib/lambda_lifting_simple.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/compiler/lib/lambda_lifting_simple.ml b/compiler/lib/lambda_lifting_simple.ml index 630218dbcf..8f38fef662 100644 --- a/compiler/lib/lambda_lifting_simple.ml +++ b/compiler/lib/lambda_lifting_simple.ml @@ -287,9 +287,8 @@ and rewrite_body in let tuple = Var.fresh_n "tuple" in let rev_decl = - 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))) + List.mapi current_contiguous ~f:(fun i (f, _, _, _) -> + Let (f, Field (tuple, i, Non_float))) in ( (program, functions, lifters) , rev_decl From d5cb751a07f0ccc7c17442863b54e4b8aab720be Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 4 Dec 2024 16:23:10 +0100 Subject: [PATCH 25/80] CR: Apply suggested simplifications --- compiler/lib/effects.ml | 76 +++++++++++------------------------------ 1 file changed, 19 insertions(+), 57 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index a6f14b2ad6..08b5d48044 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -304,8 +304,6 @@ type st = ; flow_info : Global_flow.info ; 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) *) @@ -316,21 +314,17 @@ 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 = +(* Provide the address of the CPS translation of a block *) +let mk_cps_pc_of_direct ~st pc = if double_translate () then ( - try Hashtbl.find cps_pc_of_direct pc, free_pc + try Hashtbl.find st.cps_pc_of_direct 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 new_blocks, free_pc = st.new_blocks in + st.new_blocks <- new_blocks, free_pc + 1; + Hashtbl.add st.cps_pc_of_direct pc free_pc; + free_pc) + else pc let cps_cont_of_direct ~st (pc, args) = mk_cps_pc_of_direct ~st pc, args @@ -344,9 +338,6 @@ let allocate_closure ~st ~params ~body ~branch = 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 @@ -416,23 +407,14 @@ let do_alloc_jump_closures ~st (to_allocate : (Var.t * Code.Addr.t) list) : inst [ 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 = +let allocate_continuation ~st ~alloc_jump_closures ~split_closures src_pc x direct_cont = debug_print - "@[allocate_continuation ~direct_pc:%d ~src_pc:%d ~cont_pc:%d@,@]" - direct_pc + "@[allocate_continuation ~src_pc:%d ~cont:(%d,@ _)@,@]" src_pc - (fst cont); + (fst direct_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 @@ -441,7 +423,7 @@ let allocate_continuation 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 _, args = cont in + let direct_pc, args = direct_cont in if (match args with | [] -> true @@ -453,7 +435,7 @@ let allocate_continuation | `Loop -> st.live_vars.(Var.idx x) = List.length args then alloc_jump_closures, closure_of_pc ~st direct_pc else - let body, branch = cps_branch ~st ~src:src_pc cont in + let body, branch = cps_branch ~st ~src:src_pc direct_cont in let inner_closures, outer_closures = (* For [Pushtrap], we need to separate the closures corresponding to the exception handler body (that may make @@ -554,12 +536,10 @@ let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last = ~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 @@ -729,14 +709,13 @@ let cps_block ~st ~k ~orig_pc block = assert (Var.equal x ret); let instrs, branch = f ~k in body_prefix, instrs, branch) - | Some (body_prefix, Let (x, e)), Branch ((direct_pc, _) as cont) -> + | Some (body_prefix, Let (x, e)), Branch cont -> Option.map (rewrite_instr x e) ~f:(fun f -> let constr_cont, k' = allocate_continuation ~st ~alloc_jump_closures ~split_closures:false - ~direct_pc orig_pc x cont @@ -774,6 +753,7 @@ let rewrite_direct_instr ~st instr = (* Add the continuation parameter, and change the initial block if needed *) 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, Prim (Extern "caml_alloc_dummy_function", [ size; arity ])) -> ( match arity with @@ -874,24 +854,11 @@ let subst_bound_in_blocks blocks s = res) blocks -let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = +let cps_transform ~live_vars ~flow_info ~cps_needed p = (* Define an identity function, needed for the boilerplate around "resume" *) let closure_info = Hashtbl.create 16 in let trampolined_calls = ref Var.Set.empty in let in_cps = ref Var.Set.empty in - 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 @@ -963,7 +930,6 @@ let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = ; trampolined_calls ; in_cps ; cps_pc_of_direct - ; single_version_closures } in let function_needs_cps = @@ -1094,7 +1060,6 @@ let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = (* 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. *) @@ -1103,7 +1068,6 @@ let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = (* 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 = { p with @@ -1144,7 +1108,7 @@ let cps_transform ~lifter_functions ~live_vars ~flow_info ~cps_needed p = in { start = new_start; blocks; free_pc = new_start + 1 } in - p, !trampolined_calls, !in_cps, !single_version_closures + p, !trampolined_calls, !in_cps (****) @@ -1329,7 +1293,7 @@ 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, lifter_functions, cps_needed = + let p, _, cps_needed = if double_translate () then ( let p, lifter_functions, liftings = Lambda_lifting_simple.f ~to_lift:cps_needed p in @@ -1355,9 +1319,7 @@ let f ~flow_info ~live_vars p = p, Var.Set.empty, cps_needed in let p = split_blocks ~cps_needed 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 + let p, trampolined_calls, in_cps = cps_transform ~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 () From 49ca07ecffb6d655f5bca32550ba436ceb31890f Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 4 Dec 2024 16:42:36 +0100 Subject: [PATCH 26/80] Add test for lambda-lifting of mutually recursive functions --- .../double-translation/direct_calls.ml | 92 ++++++++++++++++--- 1 file changed, 77 insertions(+), 15 deletions(-) diff --git a/compiler/tests-compiler/double-translation/direct_calls.ml b/compiler/tests-compiler/double-translation/direct_calls.ml index ea53a9e2ce..b21e3230e7 100644 --- a/compiler/tests-compiler/double-translation/direct_calls.ml +++ b/compiler/tests-compiler/double-translation/direct_calls.ml @@ -50,6 +50,17 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = let module M1 = F (struct end) in let module M2 = F (struct end) in M1.f 1; M2.f 2 + + (* Result of double-translating two mutually recursive functions *) + let test5 () = + let g x = + let rec f y = if y = 0 then 1 else x + h (y - 1) + and h z = if z = 0 then 1 else x + f (z - 1) + in + print_int (f 12 + h 100) + in + ignore (g 42); + ignore (g (-5)); |} in print_program code; @@ -74,6 +85,17 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = ? f(a0, a1) : runtime.caml_call_gen(f, [a0, a1]); } + 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], 0); + } function caml_exact_trampoline_cps_call(f, a0, a1){ return runtime.caml_stack_check_depth() ? f.cps.call(null, a0, a1) @@ -98,11 +120,11 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = var dummy = 0, global_data = runtime.caml_get_global_data(), - _x_ = [0, [4, 0, 0, 0, 0], caml_string_of_jsbytes("%d")], + _D_ = [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; + Stdlib = global_data.Stdlib, + Stdlib_Printf = global_data.Stdlib__Printf; function f$1(){ function f(g, x){ try{caml_call1(g, dummy); return;} @@ -138,7 +160,7 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = return raise(e$0); }); return caml_exact_trampoline_cps_call - (g, x, function(_D_){caml_pop_trap(); return cont();}); + (g, x, function(_P_){caml_pop_trap(); return cont();}); } var f = caml_cps_closure(f$0, f$1); return f; @@ -165,9 +187,9 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = (f, _k_(), 7, - function(_B_){ + function(_N_){ return caml_exact_trampoline_cps_call$0 - (f, _m_(), cst_a, function(_C_){return cont(0);}); + (f, _m_(), cst_a, function(_O_){return cont(0);}); }); } var test2 = caml_cps_closure(test2$0, test2$1); @@ -176,18 +198,18 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = return F; } function test3$0(x){ - var F = F$0(), M1 = F(), M2 = F(), _A_ = caml_call1(M2[1], 2); - return [0, caml_call1(M1[1], 1), _A_]; + var F = F$0(), M1 = F(), M2 = F(), _M_ = caml_call1(M2[1], 2); + return [0, caml_call1(M1[1], 1), _M_]; } function test3$1(x, cont){ - var F = F$0(), M1 = F(), M2 = F(), _z_ = M2[1].call(null, 2); - return cont([0, M1[1].call(null, 1), _z_]); + var F = F$0(), M1 = F(), M2 = F(), _L_ = M2[1].call(null, 2); + return cont([0, M1[1].call(null, 1), _L_]); } var test3 = caml_cps_closure(test3$0, test3$1); function f(){ - function f$0(x){return caml_call2(Stdlib_Printf[2], _x_, x);} + function f$0(x){return caml_call2(Stdlib_Printf[2], _D_, x);} function f$1(x, cont){ - return caml_trampoline_cps_call3(Stdlib_Printf[2], _x_, x, cont); + return caml_trampoline_cps_call3(Stdlib_Printf[2], _D_, x, cont); } var f = caml_cps_closure(f$0, f$1); return f; @@ -203,13 +225,53 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = return caml_exact_trampoline_cps_call (M1[1], 1, - function(_y_){ + function(_K_){ return caml_exact_trampoline_cps_call(M2[1], 2, cont); }); } + var test4 = caml_cps_closure(test4$0, test4$1); + function recfuncs(x){ + function f(y){return 0 === y ? 1 : x + h(y - 1 | 0) | 0;} + function h(z){return 0 === z ? 1 : x + f(z - 1 | 0) | 0;} + var tuple = [0, h, f]; + return tuple; + } + function g(){ + function g$0(x){ + var + tuple = recfuncs(x), + f = tuple[2], + h = tuple[1], + _I_ = h(100), + _J_ = f(12) + _I_ | 0; + return caml_call1(Stdlib[44], _J_); + } + function g$1(x, cont){ + var + tuple = recfuncs(x), + f = tuple[2], + h = tuple[1], + _G_ = h(100), + _H_ = f(12) + _G_ | 0; + return caml_trampoline_cps_call2(Stdlib[44], _H_, cont); + } + var g = caml_cps_closure(g$0, g$1); + return g; + } + function test5$0(param){var g$0 = g(); g$0(42); g$0(- 5); return 0;} + function test5$1(param, cont){ + var g$0 = g(); + return caml_exact_trampoline_cps_call + (g$0, + 42, + function(_E_){ + return caml_exact_trampoline_cps_call + (g$0, - 5, function(_F_){return cont(0);}); + }); + } var - test4 = caml_cps_closure(test4$0, test4$1), - Test = [0, test1, test2, test3, test4]; + test5 = caml_cps_closure(test5$0, test5$1), + Test = [0, test1, test2, test3, test4, test5]; runtime.caml_register_global(7, Test, "Test"); return; } From 13ede20b717c403e713f39bf0360eb8cbc6b6c48 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 4 Dec 2024 18:31:03 +0100 Subject: [PATCH 27/80] CR --- compiler/lib/effects.ml | 135 +++++++----------- compiler/lib/subst.ml | 3 +- .../double-translation/direct_calls.ml | 6 +- .../effects_continuations.ml | 20 +-- .../double-translation/effects_exceptions.ml | 34 ++--- 5 files changed, 81 insertions(+), 117 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 08b5d48044..9ecc2c60c9 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -818,24 +818,6 @@ let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc block = { 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 @@ -854,20 +836,21 @@ let subst_bound_in_blocks blocks s = res) blocks +let subst_add array v v' = + if 0 <= Var.idx v && Var.idx v < Array.length array then array.(Var.idx v) <- v' + let cps_transform ~live_vars ~flow_info ~cps_needed p = (* Define an identity function, needed for the boilerplate around "resume" *) let closure_info = Hashtbl.create 16 in let trampolined_calls = ref Var.Set.empty in let in_cps = ref Var.Set.empty in let cps_pc_of_direct = Hashtbl.create 512 in - let p, bound_subst, param_subst, new_blocks = + let cloned_vars = Array.init (Var.count ()) ~f:Var.of_idx in + let cloned_subst = Subst.from_array cloned_vars in + let p, new_blocks = Code.fold_closures_innermost_first p - (fun name_opt - params - (start, args) - (({ blocks; free_pc; _ } as p), bound_subst, param_subst, new_blocks) - -> + (fun name_opt params (start, args) (({ blocks; free_pc; _ } as p), 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 @@ -957,7 +940,7 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = start blocks ()); - let blocks, free_pc, bound_subst, param_subst, new_blocks = + let blocks, free_pc, 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, @@ -965,49 +948,41 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = 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 = + let 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 + List.iter2 params params' ~f:(fun x x' -> cloned_vars.(Var.idx x) <- x'); + let cps_args = List.map ~f:cloned_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 ~k ~orig_pc:pc block in - ( rewrite_direct_block - ~st - ~cps_needed - ~closure_info:st.closure_info - ~pc - block - , Some cps_block ) )) + fun pc block -> + let cps_block = cps_block ~st ~k ~orig_pc:pc block in + ( rewrite_direct_block + ~st + ~cps_needed + ~closure_info:st.closure_info + ~pc + block + , Some cps_block )) else if function_needs_cps && not (double_translate ()) then ( let k = Var.fresh_n "cont" in Hashtbl.add st.closure_info initial_start (params @ [ k ], (start, args)); - param_subst, fun pc block -> cps_block ~st ~k ~orig_pc:pc block, None) + fun pc block -> cps_block ~st ~k ~orig_pc:pc block, None) else - ( param_subst - , fun pc block -> - ( rewrite_direct_block - ~st - ~cps_needed - ~closure_info:st.closure_info - ~pc - block - , None ) ) + fun pc block -> + ( rewrite_direct_block + ~st + ~cps_needed + ~closure_info:st.closure_info + ~pc + block + , None ) in let blocks = Code.traverse @@ -1030,45 +1005,33 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = (* 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 () + if double_translate () + then + if function_needs_cps && 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 + Code.traverse + Code.{ fold = fold_children } + (fun pc () -> + let block = Addr.Map.find pc blocks in + Freevars.iter_block_bound_vars + (fun v -> subst_add cloned_vars v (Var.fork v)) + block) + start + st.blocks + (); 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 - { p with blocks; free_pc }, bound_subst, param_subst, new_blocks) - (p, Var.Map.empty, Var.Map.empty, Addr.Map.empty) + { p with blocks; free_pc }, new_blocks) + (p, 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; - 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; - in_cps := Var.Set.map param_subst !in_cps; + let new_blocks = subst_bound_in_blocks new_blocks cloned_subst in + (* Also apply that substitution to the sets of trampolined calls, and cps + call sites *) + trampolined_calls := Var.Set.map cloned_subst !trampolined_calls; + in_cps := Var.Set.map cloned_subst !in_cps; let p = { p with blocks = diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml index 30f06d38da..ca7fbbd267 100644 --- a/compiler/lib/subst.ml +++ b/compiler/lib/subst.ml @@ -97,7 +97,8 @@ end (****) -let from_array s x = s.(Var.idx x) +let from_array s x = + if 0 <= Var.idx x && Var.idx x < Array.length s then s.(Var.idx x) else x (****) diff --git a/compiler/tests-compiler/double-translation/direct_calls.ml b/compiler/tests-compiler/double-translation/direct_calls.ml index b21e3230e7..de6c6f24fb 100644 --- a/compiler/tests-compiler/double-translation/direct_calls.ml +++ b/compiler/tests-compiler/double-translation/direct_calls.ml @@ -155,9 +155,9 @@ let%expect_test "direct calls with --enable effects,doubletranslate" = } 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); + (function(e$0){ + var raise = caml_pop_trap(), e = caml_maybe_attach_backtrace(e$0, 0); + return raise(e); }); return caml_exact_trampoline_cps_call (g, x, function(_P_){caml_pop_trap(); return cont();}); diff --git a/compiler/tests-compiler/double-translation/effects_continuations.ml b/compiler/tests-compiler/double-translation/effects_continuations.ml index 3ff2035b45..6fcaa8eb25 100644 --- a/compiler/tests-compiler/double-translation/effects_continuations.ml +++ b/compiler/tests-compiler/double-translation/effects_continuations.ml @@ -132,25 +132,25 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = } //end function exceptions$1(s, cont){ - try{var _A_ = caml_int_of_string(s), n = _A_;} + try{var _z_ = caml_int_of_string(s), n = _z_;} catch(_E_){ - var _w_ = caml_wrap_exception(_E_); - if(_w_[1] !== Stdlib[7]){ + var _A_ = caml_wrap_exception(_E_); + if(_A_[1] !== Stdlib[7]){ var raise$1 = caml_pop_trap(); - return raise$1(caml_maybe_attach_backtrace(_w_, 0)); + return raise$1(caml_maybe_attach_backtrace(_A_, 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_; + var _x_ = 7, m = _x_; } catch(_D_){ - var _x_ = caml_wrap_exception(_D_); - if(_x_ !== Stdlib[8]){ + var _y_ = caml_wrap_exception(_D_); + if(_y_ !== Stdlib[8]){ var raise$0 = caml_pop_trap(); - return raise$0(caml_maybe_attach_backtrace(_x_, 0)); + return raise$0(caml_maybe_attach_backtrace(_y_, 0)); } var m = 0; } @@ -165,8 +165,8 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = (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)); + var _w_ = Stdlib[8], raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_w_, 1)); } //end var exceptions = caml_cps_closure(exceptions$0, exceptions$1); diff --git a/compiler/tests-compiler/double-translation/effects_exceptions.ml b/compiler/tests-compiler/double-translation/effects_exceptions.ml index 6870ed6094..9a920e14e2 100644 --- a/compiler/tests-compiler/double-translation/effects_exceptions.ml +++ b/compiler/tests-compiler/double-translation/effects_exceptions.ml @@ -87,25 +87,25 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = } //end function exceptions$1(s, cont){ - try{var _r_ = caml_int_of_string(s), n = _r_;} + try{var _q_ = caml_int_of_string(s), n = _q_;} catch(_v_){ - var _n_ = caml_wrap_exception(_v_); - if(_n_[1] !== Stdlib[7]){ + var _r_ = caml_wrap_exception(_v_); + if(_r_[1] !== Stdlib[7]){ var raise$1 = caml_pop_trap(); - return raise$1(caml_maybe_attach_backtrace(_n_, 0)); + return raise$1(caml_maybe_attach_backtrace(_r_, 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_; + var _o_ = 7, m = _o_; } catch(_u_){ - var _o_ = caml_wrap_exception(_u_); - if(_o_ !== Stdlib[8]){ + var _p_ = caml_wrap_exception(_u_); + if(_p_ !== Stdlib[8]){ var raise$0 = caml_pop_trap(); - return raise$0(caml_maybe_attach_backtrace(_o_, 0)); + return raise$0(caml_maybe_attach_backtrace(_p_, 0)); } var m = 0; } @@ -120,8 +120,8 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = (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)); + var _n_ = Stdlib[8], raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_n_, 1)); } //end var exceptions = caml_cps_closure(exceptions$0, exceptions$1); @@ -148,24 +148,24 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = //end function handler_is_loop$1(f, g, l, cont){ caml_push_trap - (function(_j_){ - function _k_(l){ + (function(_k_){ + function _j_(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); + return caml_exact_trampoline_call1(_j_, l); } var - exn = match[2], + exn$0 = match[2], raise = caml_pop_trap(), - exn$0 = caml_maybe_attach_backtrace(exn, 1); - return raise(exn$0); + exn = caml_maybe_attach_backtrace(exn$0, 1); + return raise(exn); }); } - return _k_(l); + return _j_(l); }); return caml_trampoline_cps_call2 (f, 0, function(_i_){caml_pop_trap(); return cont(_i_);}); From 68b1334f0eab3da72dc9ed9040edbbce41fdf6b7 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 4 Dec 2024 18:46:04 +0100 Subject: [PATCH 28/80] Revert addition of no longer necessary Freevars functions --- compiler/lib/freevars.ml | 15 +++------------ compiler/lib/freevars.mli | 11 +---------- 2 files changed, 4 insertions(+), 22 deletions(-) diff --git a/compiler/lib/freevars.ml b/compiler/lib/freevars.ml index 90340672b4..6fe65b106a 100644 --- a/compiler/lib/freevars.ml +++ b/compiler/lib/freevars.ml @@ -77,11 +77,8 @@ 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 ?(closure_params = false) f i = +let iter_instr_bound_vars 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 _ -> () @@ -90,17 +87,11 @@ let iter_last_bound_vars f l = | Return _ | Raise _ | Stop | Branch _ | Cond _ | Switch _ | Poptrap _ -> () | Pushtrap (_, x, _) -> f x -let iter_block_bound_vars ?(closure_params = false) f block = +let iter_block_bound_vars f block = List.iter ~f block.params; - List.iter block.body ~f:(fun i -> iter_instr_bound_vars ~closure_params f i); + List.iter block.body ~f:(fun i -> iter_instr_bound_vars 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 bc28735e67..ef07c7540e 100644 --- a/compiler/lib/freevars.mli +++ b/compiler/lib/freevars.mli @@ -21,16 +21,7 @@ open! Stdlib val iter_block_free_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_block_bound_vars : (Code.Var.t -> unit) -> Code.block -> unit val iter_instr_free_vars : (Code.Var.t -> unit) -> Code.instr -> unit From cf89d76f14db4bf40c66432b270b0c50957374ee Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 4 Dec 2024 21:53:40 +0100 Subject: [PATCH 29/80] Add wasm mode to double translation tests --- .../lib-effects/double-translation/dune | 32 +++++++++++++++++-- 1 file changed, 29 insertions(+), 3 deletions(-) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index bd4262aca0..b49739cd27 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -12,6 +12,32 @@ ;; because dune doesn't know that it should compile ;; multiple versions of the dependencies (compilation_mode whole_program))) + (wasm + (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))) + (wasm-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)) @@ -56,7 +82,7 @@ assume_no_perform assume_no_perform_unhandled assume_no_perform_nested_handler)) - (modes js)) + (modes js wasm)) (tests (build_if @@ -69,7 +95,7 @@ 2 (run node %{test})) (run cat))) - (modes js)) + (modes js wasm)) (tests (build_if @@ -84,4 +110,4 @@ (with-accepted-exit-codes 0 (run node %{test})))) - (modes js)) + (modes js wasm)) From d87412035adb8229520eafbe0a28725b28976b2a Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 4 Dec 2024 23:08:01 +0100 Subject: [PATCH 30/80] CR: Add missing Wasm stubs --- runtime/wasm/effect.wat | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index dbc41b3c76..6e69aa6296 100644 --- a/runtime/wasm/effect.wat +++ b/runtime/wasm/effect.wat @@ -36,6 +36,9 @@ (param $f funcref) (param $env eqref) (result anyref))) (import "bindings" "resume_fiber" (func $resume_fiber (param externref) (param (ref eq)))) + (import "obj" "caml_callback_1" + (func $caml_callback_1 + (param (ref eq)) (param (ref eq)) (result (ref eq)))) (type $block (array (mut (ref eq)))) (type $string (array (mut i8))) @@ -732,4 +735,7 @@ (func (export "caml_cps_initialize_effects") (global.set $caml_trampoline_ref (ref.func $caml_trampoline))) + + (func (export "caml_assume_no_perform") (param $f (ref eq)) (result (ref eq)) + (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))) ) From 259973a30b238b0c4684bcf2a64cd28072e76f07 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 5 Dec 2024 11:29:25 +0100 Subject: [PATCH 31/80] Revert "Add wasm mode to double translation tests" This reverts commit d3cc1b7c8437ffe1f1e2b9aa6fbe00e26469e80b. --- .../lib-effects/double-translation/dune | 32 ++----------------- 1 file changed, 3 insertions(+), 29 deletions(-) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index b49739cd27..bd4262aca0 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -12,32 +12,6 @@ ;; because dune doesn't know that it should compile ;; multiple versions of the dependencies (compilation_mode whole_program))) - (wasm - (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))) - (wasm-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)) @@ -82,7 +56,7 @@ assume_no_perform assume_no_perform_unhandled assume_no_perform_nested_handler)) - (modes js wasm)) + (modes js)) (tests (build_if @@ -95,7 +69,7 @@ 2 (run node %{test})) (run cat))) - (modes js wasm)) + (modes js)) (tests (build_if @@ -110,4 +84,4 @@ (with-accepted-exit-codes 0 (run node %{test})))) - (modes js wasm)) + (modes js)) From 64a6beb8a085271319083864e8fea7a2aa6fd2d8 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 5 Dec 2024 11:50:58 +0100 Subject: [PATCH 32/80] Update dune.inc --- compiler/tests-compiler/double-translation/dune.inc | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/compiler/tests-compiler/double-translation/dune.inc b/compiler/tests-compiler/double-translation/dune.inc index 1cecd7aa8b..aca4e07a45 100644 --- a/compiler/tests-compiler/double-translation/dune.inc +++ b/compiler/tests-compiler/double-translation/dune.inc @@ -2,7 +2,7 @@ (library ;; compiler/tests-compiler/double-translation/direct_calls.ml (name direct_calls_47) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules direct_calls) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -17,7 +17,7 @@ (library ;; compiler/tests-compiler/double-translation/effects_continuations.ml (name effects_continuations_47) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules effects_continuations) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -32,7 +32,7 @@ (library ;; compiler/tests-compiler/double-translation/effects_exceptions.ml (name effects_exceptions_47) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules effects_exceptions) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -47,7 +47,7 @@ (library ;; compiler/tests-compiler/double-translation/effects_toplevel.ml (name effects_toplevel_47) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules effects_toplevel) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests From 028027ab0fcbf3cabbf70f4f949211ea48b2cd69 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 5 Dec 2024 14:20:10 +0100 Subject: [PATCH 33/80] CR --- compiler/lib/effects.ml | 46 ++++++++++++++++------------------------- 1 file changed, 18 insertions(+), 28 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 9ecc2c60c9..09d12d96e5 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -559,23 +559,15 @@ let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last = let cps_instr ~st (instr : instr) : instr list = match instr with - | Let (x, Closure (_, (pc, _))) - when (not (double_translate ())) && Var.Set.mem x st.cps_needed -> + | Let (x, Closure (_, (pc, _))) when Var.Set.mem x st.cps_needed -> + (* Due to lambda lifiting, there are no closures in code that requires + transforming. *) + assert (not (double_translate ())); (* Add the continuation parameter, and change the initial block if needed *) 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 double_translate () && Var.Set.mem x st.cps_needed -> - 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 (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 "caml_alloc_dummy_function", [ size; arity ])) -> ( match arity with | Pc (Int a) -> @@ -640,7 +632,7 @@ let cps_block ~st ~k ~orig_pc block = | exception Not_found -> [] in - let rewrite_instr x e = + let rewrite_last_instr (x : Var.t) (e : expr) : (k:Var.t -> instr list * last) option = let perform_effect ~effect_ ~continuation = Some (fun ~k -> @@ -662,8 +654,8 @@ let cps_block ~st ~k ~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 -> + | Prim (Extern "caml_assume_no_perform", [ Pv f ]) when not (double_translate ()) -> + assert (Var.Set.mem x st.cps_needed); (* Translated like the [Apply] case, with a unit argument *) Some (fun ~k -> @@ -678,7 +670,7 @@ let cps_block ~st ~k ~orig_pc block = ~st ~instrs:[ Let (unit, Constant (Int Targetint.zero)) ] ~exact - ~in_cps:false + ~in_cps:true ~check:true ~f [ unit; k ]) @@ -704,13 +696,13 @@ let cps_block ~st ~k ~orig_pc block = let rewritten_block = match block_split_last block.body, block.branch with | Some (body_prefix, Let (x, e)), Return ret -> - Option.map (rewrite_instr x e) ~f:(fun f -> + Option.map (rewrite_last_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 -> - Option.map (rewrite_instr x e) ~f:(fun f -> + Option.map (rewrite_last_instr x e) ~f:(fun f -> let constr_cont, k' = allocate_continuation ~st @@ -747,7 +739,7 @@ let cps_block ~st ~k ~orig_pc block = ; branch = last } -let rewrite_direct_instr ~st instr = +let rewrite_direct_instr ~st instr : 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 @@ -836,11 +828,9 @@ let subst_bound_in_blocks blocks s = res) blocks -let subst_add array v v' = - if 0 <= Var.idx v && Var.idx v < Array.length array then array.(Var.idx v) <- v' +let subst_add_fresh array v = array.(Var.idx v) <- Var.fork v let cps_transform ~live_vars ~flow_info ~cps_needed p = - (* Define an identity function, needed for the boilerplate around "resume" *) let closure_info = Hashtbl.create 16 in let trampolined_calls = ref Var.Set.empty in let in_cps = ref Var.Set.empty in @@ -953,8 +943,8 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = 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 - List.iter2 params params' ~f:(fun x x' -> cloned_vars.(Var.idx x) <- x'); + List.iter ~f:(subst_add_fresh cloned_vars) params; + let params' = List.map ~f:cloned_subst params in let cps_args = List.map ~f:cloned_subst args in Hashtbl.add st.closure_info @@ -1012,12 +1002,12 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = Code.traverse Code.{ fold = fold_children } (fun pc () -> - let block = Addr.Map.find pc blocks in + let block = Addr.Map.find pc p.blocks in Freevars.iter_block_bound_vars - (fun v -> subst_add cloned_vars v (Var.fork v)) + (fun v -> subst_add_fresh cloned_vars v) block) - start - st.blocks + initial_start + p.blocks (); let blocks = Addr.Map.fold Addr.Map.add new_blocks_this_clos blocks in ( blocks From 17a051f3eed07632bc05fb38f0f823c0fca5fd88 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 5 Dec 2024 16:26:24 +0100 Subject: [PATCH 34/80] CR --- compiler/lib/effects.ml | 63 +++++++------------ compiler/lib/lambda_lifting_simple.ml | 34 +++++----- compiler/lib/lambda_lifting_simple.mli | 2 +- compiler/lib/subst.ml | 3 +- .../assume_no_perform_nested_handler.ml | 4 +- 5 files changed, 42 insertions(+), 64 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 09d12d96e5..1f37cd81df 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -583,7 +583,7 @@ let cps_instr ~st (instr : instr) : instr list = the right number of parameter *) assert ( (* If this function is unknown to the global flow analysis, then it was - introduced by the lambda lifting and does not require CPS *) + introduced by the lambda lifting and we don't have exactness info any more. *) 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 }) ] @@ -593,28 +593,15 @@ let cps_instr ~st (instr : instr) : instr list = 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 }) - ]) + (* The case when double translation is disabled should be taken care of by a prior + pass *) + assert (double_translate ()); + (* 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 ] }) + ] | Let (_, Prim (Extern "caml_assume_no_perform", args)) -> invalid_arg @@ Format.sprintf @@ -648,10 +635,8 @@ let cps_block ~st ~k ~orig_pc block = (fun ~k -> let exact = 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) + || 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 "caml_assume_no_perform", [ Pv f ]) when not (double_translate ()) -> @@ -660,10 +645,8 @@ let cps_block ~st ~k ~orig_pc block = 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 + 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 @@ -785,12 +768,12 @@ let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc block = ] | Let (x, Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg ])) -> [ Let (x, Prim (Extern "caml_resume", [ Pv f; Pv arg; Pv stack ])) ] - | Let (x, Prim (Extern "%perform", [ Pv effect ])) -> + | Let (x, Prim (Extern "%perform", [ Pv effect_ ])) -> (* In direct-style code, we just raise [Effect.Unhandled]. *) - [ Let (x, Prim (Extern "caml_raise_unhandled", [ Pv effect ])) ] - | Let (x, Prim (Extern "%reperform", [ Pv effect; Pv _continuation ])) -> + [ Let (x, Prim (Extern "caml_raise_unhandled", [ Pv effect_ ])) ] + | Let (x, Prim (Extern "%reperform", [ Pv effect_; Pv _continuation ])) -> (* Similar to previous case *) - [ Let (x, Prim (Extern "caml_raise_unhandled", [ Pv effect ])) ] + [ Let (x, Prim (Extern "caml_raise_unhandled", [ Pv effect_ ])) ] | 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 @@ -1246,10 +1229,10 @@ 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 = + let p, cps_needed = if double_translate () then ( - let p, lifter_functions, liftings = Lambda_lifting_simple.f ~to_lift:cps_needed p in + let p, 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) @@ -1257,8 +1240,6 @@ let f ~flow_info ~live_vars p = 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; @@ -1266,10 +1247,10 @@ let f ~flow_info ~live_vars p = debug_print "@[After lambda lifting...@,"; Code.Print.program (fun _ _ -> "") p; debug_print "@]"); - p, lifter_functions, cps_needed) + p, cps_needed) else let p, cps_needed = rewrite_toplevel ~cps_needed p in - p, Var.Set.empty, cps_needed + p, cps_needed 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 diff --git a/compiler/lib/lambda_lifting_simple.ml b/compiler/lib/lambda_lifting_simple.ml index 8f38fef662..ee52523011 100644 --- a/compiler/lib/lambda_lifting_simple.ml +++ b/compiler/lib/lambda_lifting_simple.ml @@ -85,7 +85,7 @@ let rec rewrite_blocks ~var_depth ~st:(program, (functions : instr list), lifters) ~pc - ~depth : _ * _ * (Var.Set.t * Var.t Var.Map.t) = + ~depth : _ * _ * Var.t Var.Map.t = assert (depth > 0); Code.preorder_traverse { fold = Code.fold_children } @@ -117,7 +117,7 @@ and rewrite_body ~var_depth ~current_contiguous ~acc_instr - ~(st : Code.program * instr list * (Var.Set.t * Var.t Var.Map.t)) + ~(st : Code.program * instr list * Var.t Var.Map.t) body = (* We lift possibly mutually recursive closures (that are created by contiguous statements) together. Isolated closures are lambda-lifted normally. *) @@ -166,7 +166,7 @@ and rewrite_body in (* Add to returned list of lifter functions definitions *) 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 lifters = Var.Map.add f f' lifters in rewrite_body ~to_lift ~inside_lifted @@ -277,13 +277,12 @@ and rewrite_body 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) ) + Var.Map.add_seq + (List.to_seq + @@ List.combine + (List.map current_contiguous ~f:(fun (f, _, _, _) -> f)) + f's) + lifters in let tuple = Var.fresh_n "tuple" in let rev_decl = @@ -316,18 +315,18 @@ and rewrite_body ~acc_instr:(i :: acc_instr) rem) -let lift ~to_lift ~pc program : program * Var.Set.t * Var.t Var.Map.t = +let lift ~to_lift ~pc program : program * Var.t Var.Map.t = let nv = Var.count () in let var_depth = Array.make nv (-1) in Code.preorder_traverse { fold = Code.fold_children } - (fun pc (program, lifter_names, lifter_map) -> + (fun pc (program, lifter_map) -> let block = Code.Addr.Map.find pc program.blocks in mark_bound_variables var_depth block 0; - let program, body, (lifter_names', lifter_map') = + let program, body, lifter_map' = List.fold_right block.body - ~init:(program, [], (Var.Set.empty, Var.Map.empty)) + ~init:(program, [], Var.Map.empty) ~f:(fun i (program, rem, lifters) -> match i with | Let (f, Closure (_, (pc', _))) as i -> @@ -344,11 +343,10 @@ let lift ~to_lift ~pc program : program * Var.Set.t * Var.t Var.Map.t = | i -> program, i :: rem, lifters) in ( { program with blocks = Addr.Map.add pc { block with body } program.blocks } - , Var.Set.union lifter_names lifter_names' , Var.Map.union (fun _ _ -> assert false) lifter_map lifter_map' )) pc program.blocks - (program, Var.Set.empty, Var.Map.empty) + (program, Var.Map.empty) let f ~to_lift program = if debug () @@ -357,6 +355,6 @@ let f ~to_lift program = Code.Print.program (fun _ _ -> "") program; Format.eprintf "@]"); let t = Timer.make () in - let program, lifters, liftings = lift ~to_lift ~pc:program.start program in + let program, liftings = lift ~to_lift ~pc:program.start program in if Debug.find "times" () then Format.eprintf " lambda lifting: %a@." Timer.print t; - program, lifters, liftings + program, liftings diff --git a/compiler/lib/lambda_lifting_simple.mli b/compiler/lib/lambda_lifting_simple.mli index c0f2eea66e..bb888d782e 100644 --- a/compiler/lib/lambda_lifting_simple.mli +++ b/compiler/lib/lambda_lifting_simple.mli @@ -18,7 +18,7 @@ open Code -val f : to_lift:Var.Set.t -> program -> program * Var.Set.t * Var.t Var.Map.t +val f : to_lift:Var.Set.t -> program -> program * 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 diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml index ca7fbbd267..6f82da73e4 100644 --- a/compiler/lib/subst.ml +++ b/compiler/lib/subst.ml @@ -97,8 +97,7 @@ end (****) -let from_array s x = - if 0 <= Var.idx x && Var.idx x < Array.length s then s.(Var.idx x) else x +let from_array s x = if Var.idx x < Array.length s then s.(Var.idx x) else x (****) diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml b/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml index 0d91ba09b2..7be1f1aacd 100644 --- a/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml +++ b/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml @@ -12,8 +12,8 @@ let () = (fun () -> ()) () { effc = (fun (type a) (_ : a Effect.t) -> None) }; - perform Dummy - ) + ); + perform Dummy ) () { effc = From 1ff3b10fc08e2090f5557822b18598bf503f224f Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 6 Dec 2024 12:44:11 +0100 Subject: [PATCH 35/80] Use copy_file rather than duplicate tests --- .../double-translation/assume_no_perform.ml | 164 ------------- .../assume_no_perform_nested_handler.ml | 25 -- .../double-translation/cmphash.expected | 2 - .../lib-effects/double-translation/cmphash.ml | 24 -- .../lib-effects/double-translation/dune | 50 ++++ .../double-translation/effects.expected | 18 -- .../lib-effects/double-translation/effects.ml | 226 ------------------ .../double-translation/evenodd.expected | 1 - .../lib-effects/double-translation/evenodd.ml | 22 -- .../double-translation/manylive.expected | 1 - .../double-translation/manylive.ml | 27 --- .../double-translation/marshal.expected | 1 - .../lib-effects/double-translation/marshal.ml | 21 -- .../double-translation/overflow.expected | 1 - .../double-translation/overflow.ml | 40 ---- .../double-translation/partial.expected | 1 - .../lib-effects/double-translation/partial.ml | 28 --- .../double-translation/reperform.expected | 22 -- .../double-translation/reperform.ml | 37 --- .../double-translation/sched.expected | 1 - .../lib-effects/double-translation/sched.ml | 65 ----- .../double-translation/shallow_state.expected | 3 - .../double-translation/shallow_state.ml | 48 ---- .../shallow_state_io.expected | 3 - .../double-translation/shallow_state_io.ml | 51 ---- .../double-translation/test1.expected | 1 - .../lib-effects/double-translation/test1.ml | 15 -- .../double-translation/test10.expected | 1 - .../lib-effects/double-translation/test10.ml | 34 --- .../double-translation/test11.expected | 2 - .../lib-effects/double-translation/test11.ml | 22 -- .../double-translation/test2.expected | 6 - .../lib-effects/double-translation/test2.ml | 30 --- .../double-translation/test3.expected | 2 - .../lib-effects/double-translation/test3.ml | 22 -- .../double-translation/test4.expected | 1 - .../lib-effects/double-translation/test4.ml | 21 -- .../double-translation/test5.expected | 1 - .../lib-effects/double-translation/test5.ml | 24 -- .../double-translation/test6.expected | 3 - .../lib-effects/double-translation/test6.ml | 30 --- .../double-translation/test_lazy.expected | 3 - .../double-translation/test_lazy.ml | 49 ---- .../unhandled_unlinked.expected | 1 - .../double-translation/unhandled_unlinked.ml | 7 - .../double-translation/used_cont.expected | 1 - .../double-translation/used_cont.ml | 21 -- 47 files changed, 50 insertions(+), 1129 deletions(-) delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_nested_handler.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/cmphash.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/cmphash.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/effects.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/effects.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/evenodd.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/evenodd.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/manylive.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/manylive.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/marshal.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/marshal.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/overflow.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/overflow.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/partial.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/partial.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/reperform.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/reperform.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/sched.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/sched.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/shallow_state.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/shallow_state.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test1.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test1.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test10.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test10.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test11.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test11.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test2.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test2.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test3.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test3.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test4.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test4.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test5.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test5.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test6.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test6.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test_lazy.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/test_lazy.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.ml delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/used_cont.expected delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/used_cont.ml 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 deleted file mode 100644 index 5818e8f9f1..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform.ml +++ /dev/null @@ -1,164 +0,0 @@ -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_nested_handler.ml b/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_nested_handler.ml deleted file mode 100644 index 7be1f1aacd..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_nested_handler.ml +++ /dev/null @@ -1,25 +0,0 @@ -open Printf -open Effect -open Effect.Deep - -type _ Effect.t += Dummy : unit t - -let () = - try_with - (fun () -> - Js_of_ocaml.Js.Effect.assume_no_perform (fun () -> - try_with - (fun () -> ()) - () - { effc = (fun (type a) (_ : a Effect.t) -> None) }; - ); - perform Dummy - ) - () - { effc = - (fun (type a) (e : a Effect.t) -> - match e with - | Dummy -> - Some (fun (k : (a, _) continuation) -> print_endline "ok"; continue k ()) - | _ -> None) - } diff --git a/compiler/tests-ocaml/lib-effects/double-translation/cmphash.expected b/compiler/tests-ocaml/lib-effects/double-translation/cmphash.expected deleted file mode 100644 index 79ebd0860f..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/cmphash.expected +++ /dev/null @@ -1,2 +0,0 @@ -ok -ok diff --git a/compiler/tests-ocaml/lib-effects/double-translation/cmphash.ml b/compiler/tests-ocaml/lib-effects/double-translation/cmphash.ml deleted file mode 100644 index 0bee4ec7b3..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/cmphash.ml +++ /dev/null @@ -1,24 +0,0 @@ -(* 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/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index bd4262aca0..4312dc4c3e 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -24,6 +24,56 @@ ;; multiple versions of the dependencies (compilation_mode whole_program)))) +(copy_files ../*.expected) + +(copy_files ../cmphash.ml) + +(copy_files ../marshal.ml) + +(copy_files ../effects.ml) + +(copy_files ../evenodd.ml) + +(copy_files ../manylive.ml) + +(copy_files ../overflow.ml) + +(copy_files ../partial.ml) + +(copy_files ../reperform.ml) + +(copy_files ../sched.ml) + +(copy_files ../shallow_state_io.ml) + +(copy_files ../shallow_state.ml) + +(copy_files ../test10.ml) + +(copy_files ../test11.ml) + +(copy_files ../test1.ml) + +(copy_files ../test2.ml) + +(copy_files ../test3.ml) + +(copy_files ../test4.ml) + +(copy_files ../test5.ml) + +(copy_files ../test6.ml) + +(copy_files ../test_lazy.ml) + +(copy_files ../used_cont.ml) + +(copy_files ../unhandled_unlinked.ml) + +(copy_files ../assume_no_perform.ml) + +(copy_files ../assume_no_perform_nested_handler.ml) + (tests (build_if (>= %{ocaml_version} 5)) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/effects.expected b/compiler/tests-ocaml/lib-effects/double-translation/effects.expected deleted file mode 100644 index fbb6e38647..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/effects.expected +++ /dev/null @@ -1,18 +0,0 @@ -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/effects.ml b/compiler/tests-ocaml/lib-effects/double-translation/effects.ml deleted file mode 100644 index f49a585732..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/effects.ml +++ /dev/null @@ -1,226 +0,0 @@ - -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/evenodd.expected b/compiler/tests-ocaml/lib-effects/double-translation/evenodd.expected deleted file mode 100644 index 8682371075..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/evenodd.expected +++ /dev/null @@ -1 +0,0 @@ -even 100000 is true diff --git a/compiler/tests-ocaml/lib-effects/double-translation/evenodd.ml b/compiler/tests-ocaml/lib-effects/double-translation/evenodd.ml deleted file mode 100644 index 035308b58f..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/evenodd.ml +++ /dev/null @@ -1,22 +0,0 @@ -(* 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/manylive.expected b/compiler/tests-ocaml/lib-effects/double-translation/manylive.expected deleted file mode 100644 index 9766475a41..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/manylive.expected +++ /dev/null @@ -1 +0,0 @@ -ok diff --git a/compiler/tests-ocaml/lib-effects/double-translation/manylive.ml b/compiler/tests-ocaml/lib-effects/double-translation/manylive.ml deleted file mode 100644 index 96e25e23d8..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/manylive.ml +++ /dev/null @@ -1,27 +0,0 @@ -(* 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/marshal.expected b/compiler/tests-ocaml/lib-effects/double-translation/marshal.expected deleted file mode 100644 index 9766475a41..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/marshal.expected +++ /dev/null @@ -1 +0,0 @@ -ok diff --git a/compiler/tests-ocaml/lib-effects/double-translation/marshal.ml b/compiler/tests-ocaml/lib-effects/double-translation/marshal.ml deleted file mode 100644 index 6c754073e2..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/marshal.ml +++ /dev/null @@ -1,21 +0,0 @@ -(* 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/overflow.expected b/compiler/tests-ocaml/lib-effects/double-translation/overflow.expected deleted file mode 100644 index dba40afcf7..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/overflow.expected +++ /dev/null @@ -1 +0,0 @@ -211 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/overflow.ml b/compiler/tests-ocaml/lib-effects/double-translation/overflow.ml deleted file mode 100644 index a187e9e10d..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/overflow.ml +++ /dev/null @@ -1,40 +0,0 @@ -(* 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/partial.expected b/compiler/tests-ocaml/lib-effects/double-translation/partial.expected deleted file mode 100644 index 9766475a41..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/partial.expected +++ /dev/null @@ -1 +0,0 @@ -ok diff --git a/compiler/tests-ocaml/lib-effects/double-translation/partial.ml b/compiler/tests-ocaml/lib-effects/double-translation/partial.ml deleted file mode 100644 index 50e4b53cfc..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/partial.ml +++ /dev/null @@ -1,28 +0,0 @@ -(* 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/reperform.expected b/compiler/tests-ocaml/lib-effects/double-translation/reperform.expected deleted file mode 100644 index 4028fa8350..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/reperform.expected +++ /dev/null @@ -1,22 +0,0 @@ -[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/reperform.ml b/compiler/tests-ocaml/lib-effects/double-translation/reperform.ml deleted file mode 100644 index 8aefdd0587..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/reperform.ml +++ /dev/null @@ -1,37 +0,0 @@ -(* 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/sched.expected b/compiler/tests-ocaml/lib-effects/double-translation/sched.expected deleted file mode 100644 index 47294f1ef7..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/sched.expected +++ /dev/null @@ -1 +0,0 @@ -A+,+B.C,D,[]!E. diff --git a/compiler/tests-ocaml/lib-effects/double-translation/sched.ml b/compiler/tests-ocaml/lib-effects/double-translation/sched.ml deleted file mode 100644 index 3dc14a2cfc..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/sched.ml +++ /dev/null @@ -1,65 +0,0 @@ -(* 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/shallow_state.expected b/compiler/tests-ocaml/lib-effects/double-translation/shallow_state.expected deleted file mode 100644 index 6cb73dd1e2..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/shallow_state.expected +++ /dev/null @@ -1,3 +0,0 @@ -Initial state: 0 -Updated state: 42 -Final state: 43 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/shallow_state.ml b/compiler/tests-ocaml/lib-effects/double-translation/shallow_state.ml deleted file mode 100644 index 56c61b0c3c..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/shallow_state.ml +++ /dev/null @@ -1,48 +0,0 @@ -(* 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_io.expected b/compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.expected deleted file mode 100644 index 6cb73dd1e2..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.expected +++ /dev/null @@ -1,3 +0,0 @@ -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 deleted file mode 100644 index 6b1fa649a7..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/shallow_state_io.ml +++ /dev/null @@ -1,51 +0,0 @@ -(* 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/test1.expected b/compiler/tests-ocaml/lib-effects/double-translation/test1.expected deleted file mode 100644 index f599e28b8a..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test1.expected +++ /dev/null @@ -1 +0,0 @@ -10 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test1.ml b/compiler/tests-ocaml/lib-effects/double-translation/test1.ml deleted file mode 100644 index 5d05359f8a..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test1.ml +++ /dev/null @@ -1,15 +0,0 @@ -(* 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/test10.expected b/compiler/tests-ocaml/lib-effects/double-translation/test10.expected deleted file mode 100644 index 9766475a41..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test10.expected +++ /dev/null @@ -1 +0,0 @@ -ok diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test10.ml b/compiler/tests-ocaml/lib-effects/double-translation/test10.ml deleted file mode 100644 index 29c5f47f25..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test10.ml +++ /dev/null @@ -1,34 +0,0 @@ -(* 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/test11.expected b/compiler/tests-ocaml/lib-effects/double-translation/test11.expected deleted file mode 100644 index 5c8f9eaff1..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test11.expected +++ /dev/null @@ -1,2 +0,0 @@ -10 -42 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test11.ml b/compiler/tests-ocaml/lib-effects/double-translation/test11.ml deleted file mode 100644 index 6714473e0e..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test11.ml +++ /dev/null @@ -1,22 +0,0 @@ -(* 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/test2.expected b/compiler/tests-ocaml/lib-effects/double-translation/test2.expected deleted file mode 100644 index 652e4a6429..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test2.expected +++ /dev/null @@ -1,6 +0,0 @@ -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/test2.ml b/compiler/tests-ocaml/lib-effects/double-translation/test2.ml deleted file mode 100644 index e9b8289bb2..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test2.ml +++ /dev/null @@ -1,30 +0,0 @@ -(* 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/test3.expected b/compiler/tests-ocaml/lib-effects/double-translation/test3.expected deleted file mode 100644 index 78ea20d6e8..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test3.expected +++ /dev/null @@ -1,2 +0,0 @@ -in handler. raising X -10 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test3.ml b/compiler/tests-ocaml/lib-effects/double-translation/test3.ml deleted file mode 100644 index d76130eaaa..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test3.ml +++ /dev/null @@ -1,22 +0,0 @@ -(* 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/test4.expected b/compiler/tests-ocaml/lib-effects/double-translation/test4.expected deleted file mode 100644 index b8626c4cff..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test4.expected +++ /dev/null @@ -1 +0,0 @@ -4 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test4.ml b/compiler/tests-ocaml/lib-effects/double-translation/test4.ml deleted file mode 100644 index f5cf78cbda..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test4.ml +++ /dev/null @@ -1,21 +0,0 @@ -(* 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/test5.expected b/compiler/tests-ocaml/lib-effects/double-translation/test5.expected deleted file mode 100644 index 45a4fb75db..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test5.expected +++ /dev/null @@ -1 +0,0 @@ -8 diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test5.ml b/compiler/tests-ocaml/lib-effects/double-translation/test5.ml deleted file mode 100644 index 33ed2c23ca..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test5.ml +++ /dev/null @@ -1,24 +0,0 @@ -(* 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/test6.expected b/compiler/tests-ocaml/lib-effects/double-translation/test6.expected deleted file mode 100644 index b979d62f4f..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test6.expected +++ /dev/null @@ -1,3 +0,0 @@ -true -true -true diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test6.ml b/compiler/tests-ocaml/lib-effects/double-translation/test6.ml deleted file mode 100644 index 40574561bf..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test6.ml +++ /dev/null @@ -1,30 +0,0 @@ -(* 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/test_lazy.expected b/compiler/tests-ocaml/lib-effects/double-translation/test_lazy.expected deleted file mode 100644 index 3e572fff4a..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test_lazy.expected +++ /dev/null @@ -1,3 +0,0 @@ -1000 -2000 -Undefined diff --git a/compiler/tests-ocaml/lib-effects/double-translation/test_lazy.ml b/compiler/tests-ocaml/lib-effects/double-translation/test_lazy.ml deleted file mode 100644 index 24f457f0af..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/test_lazy.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* 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/unhandled_unlinked.expected b/compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.expected deleted file mode 100644 index 73cee5f415..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.expected +++ /dev/null @@ -1 +0,0 @@ -Fatal error: exception Effect.Unhandled diff --git a/compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.ml b/compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.ml deleted file mode 100644 index bc2badb8e8..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/unhandled_unlinked.ml +++ /dev/null @@ -1,7 +0,0 @@ -(* TEST - exit_status= "2" -*) - -open Effect -type _ t += E : unit t -let _ = perform E diff --git a/compiler/tests-ocaml/lib-effects/double-translation/used_cont.expected b/compiler/tests-ocaml/lib-effects/double-translation/used_cont.expected deleted file mode 100644 index 9766475a41..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/used_cont.expected +++ /dev/null @@ -1 +0,0 @@ -ok diff --git a/compiler/tests-ocaml/lib-effects/double-translation/used_cont.ml b/compiler/tests-ocaml/lib-effects/double-translation/used_cont.ml deleted file mode 100644 index 71a33388ec..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/used_cont.ml +++ /dev/null @@ -1,21 +0,0 @@ -(* 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 } From f5ed63bac87dee17bd7cd9fabc2140dd3f65ea47 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 6 Dec 2024 13:03:34 +0100 Subject: [PATCH 36/80] Update comment --- compiler/lib/lambda_lifting_simple.mli | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/lib/lambda_lifting_simple.mli b/compiler/lib/lambda_lifting_simple.mli index bb888d782e..ca14ada3b3 100644 --- a/compiler/lib/lambda_lifting_simple.mli +++ b/compiler/lib/lambda_lifting_simple.mli @@ -21,9 +21,9 @@ open Code val f : to_lift:Var.Set.t -> program -> program * 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: + mutually recursive are lifted together. Also yields a map from the original + function names to the names of their lambda-lifted counterparts. E.g. + consider: let y = -3 in (* ... *) From 080750701441c7ef9bc6cf5e7acf89cf3bef82ff Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 6 Dec 2024 13:36:29 +0100 Subject: [PATCH 37/80] CR: Factorize some code --- compiler/lib/effects.ml | 71 +++++++++++++++++------------------------ 1 file changed, 30 insertions(+), 41 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 1f37cd81df..508f4c62ca 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -557,18 +557,20 @@ 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 list = - match instr with - | Let (x, Closure (_, (pc, _))) when Var.Set.mem x st.cps_needed -> - (* Due to lambda lifiting, there are no closures in code that requires - transforming. *) +let rewrite_instr ~target ~st (instr : instr) : instr list = + match target, instr with + | (`Cps | `Direct_style), Let (x, Closure (_, (pc, _))) when Var.Set.mem x st.cps_needed + -> + (* When CPS-transforming with double translation enabled, there are no closures in + code that requires transforming, due to lambda lifiting. *) assert (not (double_translate ())); (* Add the continuation parameter, and change the initial block if needed *) 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, Prim (Extern "caml_alloc_dummy_function", [ size; arity ])) -> ( + | ( (`Cps | `Direct_style) + , Let (x, Prim (Extern "caml_alloc_dummy_function", [ size; arity ])) ) -> ( match arity with | Pc (Int a) -> [ Let @@ -578,21 +580,26 @@ let cps_instr ~st (instr : instr) : instr list = , [ size; Pc (Int (Targetint.succ a)) ] ) ) ] | _ -> assert false) - | Let (x, Apply { f; args; _ }) when not (Var.Set.mem x st.cps_needed) -> + | (`Cps | `Direct_style), 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 ( (* If this function is unknown to the global flow analysis, then it was introduced by the lambda lifting and we don't have exactness info any more. *) - Var.idx f >= Var.Tbl.length st.flow_info.info_approximation - || Global_flow.exact_call st.flow_info f (List.length args)); + match target with + | `Cps -> + Var.idx f >= Var.Tbl.length st.flow_info.info_approximation + || Global_flow.exact_call st.flow_info f (List.length args) + | `Direct_style -> 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"), _))) -> + | `Cps, 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 ])) -> + | `Direct_style, Let (_, e) when effect_primitive_or_application e -> assert false + | `Cps, Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) -> (* The case when double translation is disabled should be taken care of by a prior pass *) assert (double_translate ()); @@ -602,13 +609,13 @@ let cps_instr ~st (instr : instr) : instr list = [ Let (unit, Constant (Int Targetint.zero)) ; Let (x, Apply { exact; f; args = [ unit ] }) ] - | Let (_, Prim (Extern "caml_assume_no_perform", args)) -> + | `Cps, 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 ] + | (`Cps | `Direct_style), _ -> [ instr ] let cps_block ~st ~k ~orig_pc block = debug_print "cps_block %d\n" orig_pc; @@ -706,14 +713,18 @@ let cps_block ~st ~k ~orig_pc block = match rewritten_block with | Some (body_prefix, last_instrs, last) -> let body_prefix = - List.map body_prefix ~f:(fun i -> cps_instr ~st i) |> List.concat + List.map body_prefix ~f:(fun i -> rewrite_instr ~target:`Cps ~st i) + |> List.concat in body_prefix @ last_instrs, last | None -> 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 + let body = + List.map block.body ~f:(fun i -> rewrite_instr ~target:`Cps ~st i) + |> List.concat + in body @ last_instrs, last in @@ -722,31 +733,6 @@ let cps_block ~st ~k ~orig_pc block = ; branch = last } -let rewrite_direct_instr ~st instr : 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 - st.in_cps := Var.Set.add x !(st.in_cps); - 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 (_, e) when effect_primitive_or_application e -> 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 @@ -791,7 +777,10 @@ let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc block = 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 } + else + { block with + body = List.concat_map ~f:(rewrite_instr ~target:`Direct_style ~st) block.body + } (* Apply a substitution in a set of blocks, including to bound variables *) let subst_bound_in_blocks blocks s = From 21e750aad034febfc4a5357bc399556fc0dca058 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 6 Dec 2024 15:11:26 +0100 Subject: [PATCH 38/80] CR --- compiler/lib/effects.ml | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 508f4c62ca..beb70a8c8c 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -587,18 +587,9 @@ let rewrite_instr ~target ~st (instr : instr) : instr list = assert ( (* If this function is unknown to the global flow analysis, then it was introduced by the lambda lifting and we don't have exactness info any more. *) - match target with - | `Cps -> - Var.idx f >= Var.Tbl.length st.flow_info.info_approximation - || Global_flow.exact_call st.flow_info f (List.length args) - | `Direct_style -> Global_flow.exact_call st.flow_info f (List.length args)); + 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 }) ] - | `Cps, 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 - | `Direct_style, Let (_, e) when effect_primitive_or_application e -> assert false | `Cps, Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) -> (* The case when double translation is disabled should be taken care of by a prior pass *) @@ -609,6 +600,11 @@ let rewrite_instr ~target ~st (instr : instr) : instr list = [ Let (unit, Constant (Int Targetint.zero)) ; Let (x, Apply { exact; f; args = [ unit ] }) ] + | (`Cps | `Direct_style), Let (_, e) when effect_primitive_or_application e -> + (* For the CPS target, 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. *) + assert false | `Cps, Let (_, Prim (Extern "caml_assume_no_perform", args)) -> invalid_arg @@ Format.sprintf From b734492663289e56ee79cb8aebf2b2a52f8e70e4 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 6 Dec 2024 15:59:24 +0100 Subject: [PATCH 39/80] CR: simplify --- compiler/lib/effects.ml | 46 ++++++++++++++++++----------------------- 1 file changed, 20 insertions(+), 26 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index beb70a8c8c..86a24105ba 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -557,10 +557,9 @@ 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 rewrite_instr ~target ~st (instr : instr) : instr list = - match target, instr with - | (`Cps | `Direct_style), Let (x, Closure (_, (pc, _))) when Var.Set.mem x st.cps_needed - -> +let rewrite_instr ~st (instr : instr) : instr list = + match instr with + | Let (x, Closure (_, (pc, _))) when Var.Set.mem x st.cps_needed -> (* When CPS-transforming with double translation enabled, there are no closures in code that requires transforming, due to lambda lifiting. *) assert (not (double_translate ())); @@ -569,8 +568,7 @@ let rewrite_instr ~target ~st (instr : instr) : instr list = 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)) ] - | ( (`Cps | `Direct_style) - , Let (x, Prim (Extern "caml_alloc_dummy_function", [ size; arity ])) ) -> ( + | Let (x, Prim (Extern "caml_alloc_dummy_function", [ size; arity ])) -> ( match arity with | Pc (Int a) -> [ Let @@ -580,8 +578,7 @@ let rewrite_instr ~target ~st (instr : instr) : instr list = , [ size; Pc (Int (Targetint.succ a)) ] ) ) ] | _ -> assert false) - | (`Cps | `Direct_style), Let (x, Apply { f; args; _ }) - when not (Var.Set.mem x st.cps_needed) -> + | 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 ( @@ -590,7 +587,16 @@ let rewrite_instr ~target ~st (instr : instr) : instr list = 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 }) ] - | `Cps, Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) -> + | Let (_, e) when effect_primitive_or_application e -> + (* For the CPS target, 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. *) + assert false + | _ -> [ instr ] + +let cps_instr ~st (instr : instr) : instr list = + match instr with + | Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) -> (* The case when double translation is disabled should be taken care of by a prior pass *) assert (double_translate ()); @@ -600,18 +606,13 @@ let rewrite_instr ~target ~st (instr : instr) : instr list = [ Let (unit, Constant (Int Targetint.zero)) ; Let (x, Apply { exact; f; args = [ unit ] }) ] - | (`Cps | `Direct_style), Let (_, e) when effect_primitive_or_application e -> - (* For the CPS target, 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. *) - assert false - | `Cps, Let (_, Prim (Extern "caml_assume_no_perform", args)) -> + | 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) - | (`Cps | `Direct_style), _ -> [ instr ] + | _ -> rewrite_instr ~st instr let cps_block ~st ~k ~orig_pc block = debug_print "cps_block %d\n" orig_pc; @@ -709,18 +710,14 @@ let cps_block ~st ~k ~orig_pc block = match rewritten_block with | Some (body_prefix, last_instrs, last) -> let body_prefix = - List.map body_prefix ~f:(fun i -> rewrite_instr ~target:`Cps ~st i) - |> List.concat + 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 orig_pc block.branch ~k in - let body = - List.map block.body ~f:(fun i -> rewrite_instr ~target:`Cps ~st i) - |> List.concat - in + let body = List.map block.body ~f:(fun i -> cps_instr ~st i) |> List.concat in body @ last_instrs, last in @@ -773,10 +770,7 @@ let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc block = in let body = List.concat_map block.body ~f:(fun i -> rewrite_instr i) in { block with body } - else - { block with - body = List.concat_map ~f:(rewrite_instr ~target:`Direct_style ~st) block.body - } + else { block with body = List.concat_map ~f:(rewrite_instr ~st) block.body } (* Apply a substitution in a set of blocks, including to bound variables *) let subst_bound_in_blocks blocks s = From 343f2705fadcc052aab6d58b7b7434a5d91a8365 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Mon, 9 Dec 2024 10:58:43 +0100 Subject: [PATCH 40/80] Simplify function rewrite_instr --- compiler/lib/effects.ml | 29 +++++++++++------------------ 1 file changed, 11 insertions(+), 18 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 86a24105ba..f7bd176c4f 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -557,7 +557,7 @@ 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 rewrite_instr ~st (instr : instr) : instr list = +let rewrite_instr ~st (instr : instr) : instr = match instr with | Let (x, Closure (_, (pc, _))) when Var.Set.mem x st.cps_needed -> (* When CPS-transforming with double translation enabled, there are no closures in @@ -567,16 +567,15 @@ let rewrite_instr ~st (instr : instr) : instr list = needed *) 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 (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)) ] ) ) - ] + 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 @@ -586,13 +585,13 @@ let rewrite_instr ~st (instr : instr) : instr list = introduced by the lambda lifting and we don't have exactness info any more. *) 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 (x, Apply { f; args; exact = true }) | Let (_, e) when effect_primitive_or_application e -> (* For the CPS target, 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. *) assert false - | _ -> [ instr ] + | _ -> instr let cps_instr ~st (instr : instr) : instr list = match instr with @@ -606,13 +605,7 @@ let cps_instr ~st (instr : instr) : instr list = [ Let (unit, Constant (Int Targetint.zero)) ; 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) - | _ -> rewrite_instr ~st instr + | _ -> [ rewrite_instr ~st instr ] let cps_block ~st ~k ~orig_pc block = debug_print "cps_block %d\n" orig_pc; @@ -770,7 +763,7 @@ let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc block = in let body = List.concat_map block.body ~f:(fun i -> rewrite_instr i) in { block with body } - else { block with body = List.concat_map ~f:(rewrite_instr ~st) block.body } + else { block with body = List.map ~f:(rewrite_instr ~st) block.body } (* Apply a substitution in a set of blocks, including to bound variables *) let subst_bound_in_blocks blocks s = From 28690a7b090c201db05a825af2eb4c1e03d15265 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Mon, 9 Dec 2024 11:02:15 +0100 Subject: [PATCH 41/80] Function assume_no_perform makes perform fail for all effect implementations --- compiler/lib/effects.ml | 35 ++------------ compiler/lib/partial_cps_analysis.ml | 13 ----- .../assume_no_perform_unhandled.ml | 11 ++--- .../assume_no_perform_unhandled.ml | 26 ---------- .../lib-effects/double-translation/dune | 48 +------------------ runtime/js/effect.js | 8 ++++ runtime/wasm/effect.wat | 26 +++++++++- 7 files changed, 42 insertions(+), 125 deletions(-) delete mode 100644 compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.ml diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index f7bd176c4f..c6adef9810 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -169,8 +169,7 @@ let empty_body b = (****) let effect_primitive_or_application = function - | Prim (Extern ("%resume" | "%perform" | "%reperform" | "caml_assume_no_perform"), _) - | Apply _ -> true + | Prim (Extern ("%resume" | "%perform" | "%reperform"), _) | Apply _ -> true | Block (_, _, _, _) | Field (_, _, _) | Closure (_, _) @@ -595,11 +594,9 @@ let rewrite_instr ~st (instr : instr) : instr = let cps_instr ~st (instr : instr) : instr list = match instr with - | Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) -> - (* The case when double translation is disabled should be taken care of by a prior - pass *) - assert (double_translate ()); - (* We just need to call [f] in direct style. *) + | Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) when double_translate () -> + (* When double translation is enabled, we just call [f] in direct style. + Otherwise, the runtime primitive is used. *) 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)) @@ -636,24 +633,6 @@ let cps_block ~st ~k ~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 ()) -> - assert (Var.Set.mem x st.cps_needed); - (* Translated like the [Apply] case, with a unit argument *) - Some - (fun ~k -> - let 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:true - ~check:true - ~f - [ unit; k ]) | Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg ]) -> Some (fun ~k -> @@ -752,12 +731,6 @@ let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc block = 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 diff --git a/compiler/lib/partial_cps_analysis.ml b/compiler/lib/partial_cps_analysis.ml index b0f68a0c36..f639e4b067 100644 --- a/compiler/lib/partial_cps_analysis.ml +++ b/compiler/lib/partial_cps_analysis.ml @@ -96,15 +96,6 @@ 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 _ -> ()) @@ -159,10 +150,6 @@ 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-ocaml/lib-effects/assume_no_perform_unhandled.ml b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml index a647cbe951..c81d984806 100644 --- a/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml +++ b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml @@ -4,10 +4,11 @@ open Effect.Deep type _ Effect.t += Dummy : unit t -let f () = +let must_raise () = try_with (fun () -> Js_of_ocaml.Js.Effect.assume_no_perform (fun () -> + (* Should raise [Effect.Unhandled] despite the installed handler *) perform Dummy ) ) @@ -21,9 +22,5 @@ let f () = let () = try - (* When double translation is not enabled, [f] should not raise *) - f (); print_endline "ok" - with Effect.Unhandled Dummy -> ( - print_endline "failed"; - exit 2 - ) + must_raise (); print_endline "failed"; exit 2 + with Effect.Unhandled Dummy -> print_endline "ok" diff --git a/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.ml b/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.ml deleted file mode 100644 index c81d984806..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.ml +++ /dev/null @@ -1,26 +0,0 @@ -open Printf -open Effect -open Effect.Deep - -type _ Effect.t += Dummy : unit t - -let must_raise () = - try_with - (fun () -> - Js_of_ocaml.Js.Effect.assume_no_perform (fun () -> - (* Should raise [Effect.Unhandled] despite the installed handler *) - perform Dummy - ) - ) - () - { effc = - (fun (type a) (e : a Effect.t) -> - match e with - | Dummy -> Some (fun (k : (a, _) continuation) -> continue k ()) - | _ -> None) - } - -let () = - try - must_raise (); print_endline "failed"; exit 2 - with Effect.Unhandled Dummy -> print_endline "ok" diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index 4312dc4c3e..dd2b2cd741 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -26,53 +26,7 @@ (copy_files ../*.expected) -(copy_files ../cmphash.ml) - -(copy_files ../marshal.ml) - -(copy_files ../effects.ml) - -(copy_files ../evenodd.ml) - -(copy_files ../manylive.ml) - -(copy_files ../overflow.ml) - -(copy_files ../partial.ml) - -(copy_files ../reperform.ml) - -(copy_files ../sched.ml) - -(copy_files ../shallow_state_io.ml) - -(copy_files ../shallow_state.ml) - -(copy_files ../test10.ml) - -(copy_files ../test11.ml) - -(copy_files ../test1.ml) - -(copy_files ../test2.ml) - -(copy_files ../test3.ml) - -(copy_files ../test4.ml) - -(copy_files ../test5.ml) - -(copy_files ../test6.ml) - -(copy_files ../test_lazy.ml) - -(copy_files ../used_cont.ml) - -(copy_files ../unhandled_unlinked.ml) - -(copy_files ../assume_no_perform.ml) - -(copy_files ../assume_no_perform_nested_handler.ml) +(copy_files# ../*.ml) (tests (build_if diff --git a/runtime/js/effect.js b/runtime/js/effect.js index 8156b4f4a9..e7c467df67 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -305,3 +305,11 @@ function caml_cps_closure(direct_f, cps_f) { direct_f.cps = cps_f; return direct_f; } + +//Provides: caml_assume_no_perform +//Requires: caml_callback +//If: effects +//If: !doubletranslate +function caml_assume_no_perform(f) { + return caml_callback(f, [0]); +} diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index 6e69aa6296..5bc8678f2a 100644 --- a/runtime/wasm/effect.wat +++ b/runtime/wasm/effect.wat @@ -306,7 +306,13 @@ (ref.func $do_perform) (struct.new $pair (local.get $eff) (local.get $cont)))) + (global $effect_allowed (mut i32) (i32.const 1)) + (func (export "%perform") (param $eff (ref eq)) (result (ref eq)) + (if (i32.eqz (global.get $effect_allowed)) + (then + (return_call $raise_unhandled + (local.get $eff) (ref.i31 (i32.const 0))))) (return_call $reperform (local.get $eff) (array.new_fixed $block 3 (ref.i31 (global.get $cont_tag)) (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0))))) @@ -737,5 +743,23 @@ (global.set $caml_trampoline_ref (ref.func $caml_trampoline))) (func (export "caml_assume_no_perform") (param $f (ref eq)) (result (ref eq)) - (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))) + (local $saved_effect_allowed i32) + (local $res (ref eq)) + (local $exn (ref eq)) + (local.set $saved_effect_allowed (global.get $effect_allowed)) + (global.set $effect_allowed (i32.const 0)) + (local.set $res + (try (result (ref eq)) + (do + (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))) + (catch $ocaml_exception + (local.set $exn (pop (ref eq))) + (global.set $effect_allowed (local.get $saved_effect_allowed)) + (throw $ocaml_exception (local.get $exn))) + (catch $javascript_exception + (local.set $exn (call $caml_wrap_exception (pop externref))) + (global.set $effect_allowed (local.get $saved_effect_allowed)) + (throw $ocaml_exception (local.get $exn))))) + (global.set $effect_allowed (local.get $saved_effect_allowed)) + (local.get $res)) ) From 43eb25ba563866c244154f13eba2b30cedd52e48 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 10 Dec 2024 17:07:10 +0100 Subject: [PATCH 42/80] CR: Add --effects option --- compiler/bin-js_of_ocaml/cmd_arg.ml | 23 +++++++- compiler/bin-js_of_ocaml/cmd_arg.mli | 1 + compiler/bin-js_of_ocaml/compile.ml | 7 +++ compiler/bin-wasm_of_ocaml/cmd_arg.ml | 19 ++++++- compiler/bin-wasm_of_ocaml/cmd_arg.mli | 1 + compiler/bin-wasm_of_ocaml/compile.ml | 7 +++ compiler/lib/build_info.ml | 22 +++++--- compiler/lib/config.ml | 12 ++++- compiler/lib/config.mli | 12 ++++- compiler/lib/driver.ml | 54 ++++++++++--------- compiler/lib/effects.ml | 6 ++- compiler/lib/effects.mli | 16 +++--- compiler/lib/generate.ml | 20 +++---- compiler/lib/generate_closure.ml | 2 +- compiler/lib/inline.ml | 2 +- compiler/lib/js_output.ml | 3 +- compiler/lib/linker.ml | 8 ++- compiler/lib/unit_info.ml | 2 +- .../double-translation/direct_calls.ml | 2 +- .../double-translation/dune.inc | 8 +-- compiler/tests-compiler/util/util.ml | 10 ++-- .../lib-effects/double-translation/dune | 6 +-- lib/js_of_ocaml/js.mli | 17 +++--- 23 files changed, 175 insertions(+), 85 deletions(-) diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml index c294be23a1..b91f077c4c 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.ml +++ b/compiler/bin-js_of_ocaml/cmd_arg.ml @@ -65,6 +65,7 @@ type t = ; fs_output : string option ; fs_external : bool ; keep_unit_names : bool + ; effects : Config.effects_backend option } let wrap_with_fun_conv = @@ -253,6 +254,20 @@ let options = & opt (some string) None & info [ "ofs" ] ~docs:filesystem_section ~docv:"FILE" ~doc) in + let effects = + let doc = + "Select an implementation of effect handlers. [$(docv)] should be one of $(b,cps) \ + or $(b,double-translation). Effects are not allowed by default." + in + Arg.( + value + & opt + (some + (enum + [ "cps", Config.Cps; "double-translation", Double_translation ])) + None + & info [ "effects" ] ~docv:"KIND" ~doc) + in let build_t common set_param @@ -279,7 +294,8 @@ let options = output_file input_file js_files - keep_unit_names = + keep_unit_names + effects = let inline_source_content = not sourcemap_don't_inline_content in let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in let runtime_files = js_files in @@ -341,6 +357,7 @@ let options = ; bytecode ; source_map ; keep_unit_names + ; effects } in let t = @@ -371,7 +388,8 @@ let options = $ output_file $ input_file $ js_files - $ keep_unit_names) + $ keep_unit_names + $ effects) in Term.ret t @@ -567,6 +585,7 @@ let options_runtime_only = ; bytecode = `None ; source_map ; keep_unit_names = false + ; effects = None } in let t = diff --git a/compiler/bin-js_of_ocaml/cmd_arg.mli b/compiler/bin-js_of_ocaml/cmd_arg.mli index ec756685b5..35006290bf 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.mli +++ b/compiler/bin-js_of_ocaml/cmd_arg.mli @@ -49,6 +49,7 @@ type t = ; fs_output : string option ; fs_external : bool ; keep_unit_names : bool + ; effects : Config.effects_backend option } val options : t Cmdliner.Term.t diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index b87036c1a6..f525ac2062 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -153,6 +153,7 @@ let run ; export_file ; keep_unit_names ; include_runtime + ; effects } = let source_map_base = Option.map ~f:snd source_map in let source_map = @@ -172,6 +173,12 @@ let run | `Name _, _ -> ()); List.iter params ~f:(fun (s, v) -> Config.Param.set s v); List.iter static_env ~f:(fun (s, v) -> Eval.set_static_env s v); + (* For backward compatibility, consider that [--enable effects] alone means + [--effects cps] *) + Config.set_effects_backend + (match effects with + | None -> if Config.Flag.effects () then Some Cps else None + | Some _ -> effects); let t = Timer.make () in let include_dirs = List.filter_map (include_dirs @ [ "+stdlib/" ]) ~f:(fun d -> Findlib.find [] d) diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.ml b/compiler/bin-wasm_of_ocaml/cmd_arg.ml index 5b6c86b399..4c04214db3 100644 --- a/compiler/bin-wasm_of_ocaml/cmd_arg.ml +++ b/compiler/bin-wasm_of_ocaml/cmd_arg.ml @@ -51,6 +51,7 @@ type t = ; sourcemap_don't_inline_content : bool ; params : (string * string) list ; include_dirs : string list + ; effects : Config.effects_backend option } let options = @@ -103,6 +104,16 @@ let options = let doc = "Add [$(docv)] to the list of include directories." in Arg.(value & opt_all string [] & info [ "I" ] ~docv:"DIR" ~doc) in + let effects = + let doc = + "Select an implementation of effect handlers. [$(docv)] should be one of $(b,jspi) \ + (the default) or $(b,cps)." + in + Arg.( + value + & opt (enum [ "jspi", None; "cps", Some Config.Cps ]) None + & info [ "effects" ] ~docv:"KIND" ~doc) + in let build_t common set_param @@ -115,7 +126,8 @@ let options = sourcemap_root output_file input_file - runtime_files = + runtime_files + effects = let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in let output_file = let ext = @@ -145,6 +157,7 @@ let options = ; enable_source_maps ; sourcemap_root ; sourcemap_don't_inline_content + ; effects } in let t = @@ -161,7 +174,8 @@ let options = $ sourcemap_root $ output_file $ input_file - $ runtime_files) + $ runtime_files + $ effects) in Term.ret t @@ -229,6 +243,7 @@ let options_runtime_only = ; enable_source_maps ; sourcemap_root ; sourcemap_don't_inline_content + ; effects = None } in let t = diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.mli b/compiler/bin-wasm_of_ocaml/cmd_arg.mli index 74d38c76fc..4fa4035113 100644 --- a/compiler/bin-wasm_of_ocaml/cmd_arg.mli +++ b/compiler/bin-wasm_of_ocaml/cmd_arg.mli @@ -31,6 +31,7 @@ type t = ; sourcemap_don't_inline_content : bool ; params : (string * string) list ; include_dirs : string list + ; effects : Config.effects_backend option } val options : t Cmdliner.Term.t diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index 9957756643..b857c8d5a4 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -269,8 +269,15 @@ let run ; include_dirs ; sourcemap_root ; sourcemap_don't_inline_content + ; effects } = Config.set_target `Wasm; + (* For backward compatibility, consider that [--enable effects] alone means [--effects cps] *) + Config.set_effects_backend + (match effects with + | None -> if Config.Flag.effects () then Some Cps else None + | Some Cps -> Some Cps + | Some _ -> failwith "Unexpected effects backend"); Jsoo_cmdline.Arg.eval common; Generate.init (); let output_file = fst output_file in diff --git a/compiler/lib/build_info.ml b/compiler/lib/build_info.ml index 8f6dd8e79e..23dbd8c62c 100644 --- a/compiler/lib/build_info.ml +++ b/compiler/lib/build_info.ml @@ -36,6 +36,17 @@ let string_of_kind = function | `Cma -> "cma" | `Unknown -> "unknown" +let string_of_effects_backend = function + | None -> "none" + | Some Config.Cps -> "cps" + | Some Config.Double_translation -> "double-translation" + +let effects_backend_of_string = function + | "none" -> None + | "cps" -> Some Config.Cps + | "double-translation" -> Some Double_translation + | _ -> invalid_arg "effects_backend_of_string" + let kind_of_string s = match List.find_opt all ~f:(fun k -> String.equal s (string_of_kind k)) with | None -> `Unknown @@ -55,8 +66,7 @@ let create kind = | v -> Printf.sprintf "%s+%s" Compiler_version.s v 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 ()) + ; "effects", string_of_effects_backend (Config.effects ()) ; "version", version ; "kind", string_of_kind kind ] @@ -127,9 +137,9 @@ 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" | "doubletranslate" | "use-js-string" | "version"), Some v1, Some v2 + | ("effects" | "use-js-string" | "version"), Some v1, Some v2 when String.equal v1 v2 -> Some v1 - | (("effects" | "doubletranslate" | "use-js-string" | "version") as key), v1, v2 + | (("effects" | "use-js-string" | "version") as key), v1, v2 -> raise (Incompatible_build_info { key; first = fname1, v1; second = fname2, v2 }) @@ -145,7 +155,7 @@ let configure t = StringMap.iter (fun k v -> match k with - | "use-js-string" | "effects" | "doubletranslate" -> - Config.Flag.set k (bool_of_string v) + | "use-js-string" -> Config.Flag.set k (bool_of_string v) + | "effects" -> Config.set_effects_backend (effects_backend_of_string v) | _ -> ()) t diff --git a/compiler/lib/config.ml b/compiler/lib/config.ml index a78fef98dc..6f25f2485a 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -70,8 +70,6 @@ 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 @@ -197,3 +195,13 @@ let set_target (t : [ `JavaScript | `Wasm ]) = | `JavaScript -> Targetint.set_num_bits 32 | `Wasm -> Targetint.set_num_bits 31); target_ := (t :> [ `JavaScript | `Wasm | `None ]) + +type effects_backend = + | Cps + | Double_translation + +let effects_ : effects_backend option ref = ref None + +let effects () = !effects_ + +let set_effects_backend backend = effects_ := backend diff --git a/compiler/lib/config.mli b/compiler/lib/config.mli index b08e4d6fe6..cf57230823 100644 --- a/compiler/lib/config.mli +++ b/compiler/lib/config.mli @@ -16,6 +16,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + module Flag : sig val available : unit -> string list @@ -39,10 +40,9 @@ module Flag : sig val staticeval : unit -> bool + (* Deprecated in favor of toplevel function [effects] below *) val effects : unit -> bool - val double_translation : unit -> bool - val genprim : unit -> bool val strictmode : unit -> bool @@ -117,3 +117,11 @@ end val target : unit -> [ `JavaScript | `Wasm ] val set_target : [ `JavaScript | `Wasm ] -> unit + +type effects_backend = + | Cps + | Double_translation + +val effects : unit -> effects_backend option + +val set_effects_backend : effects_backend option -> unit diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 7dfbe6cce1..4887ce3a6f 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -98,30 +98,34 @@ let ( +> ) f g x = g (f x) let map_fst f (x, y, z) = f x, y, z let effects ~deadcode_sentinal p = - if Config.Flag.effects () - then ( - if debug () then Format.eprintf "Effects...@."; - let p, live_vars = Deadcode.f p in - let p = Effects.remove_empty_blocks ~live_vars p in - let p, live_vars = Deadcode.f p in - let info = Global_flow.f ~fast:false p in - let p, live_vars = - if Config.Flag.globaldeadcode () - then - let p = Global_deadcode.f p ~deadcode_sentinal info in - Deadcode.f p - else p, live_vars - in - p - |> Effects.f ~flow_info:info ~live_vars - |> map_fst (if Config.Flag.double_translation () then Fun.id else Lambda_lifting.f)) - else - ( p - , (Code.Var.Set.empty : Effects.trampolined_calls) - , (Code.Var.Set.empty : Effects.in_cps) ) + match Config.effects () with + | Some _ -> + if debug () then Format.eprintf "Effects...@."; + let p, live_vars = Deadcode.f p in + let p = Effects.remove_empty_blocks ~live_vars p in + let p, live_vars = Deadcode.f p in + let info = Global_flow.f ~fast:false p in + let p, live_vars = + if Config.Flag.globaldeadcode () + then + let p = Global_deadcode.f p ~deadcode_sentinal info in + Deadcode.f p + else p, live_vars + in + p + |> Effects.f ~flow_info:info ~live_vars + |> map_fst + (match Config.effects () with + | Some Double_translation -> Fun.id + | Some Cps -> Lambda_lifting.f + | None -> assert false) + | None -> + ( p + , (Code.Var.Set.empty : Effects.trampolined_calls) + , (Code.Var.Set.empty : Effects.in_cps) ) let exact_calls profile ~deadcode_sentinal p = - if not (Config.Flag.effects ()) + if Option.is_none (Config.effects ()) then let fast = match profile with @@ -694,9 +698,9 @@ let optimize ~profile p = +> exact_calls ~deadcode_sentinal profile +> effects ~deadcode_sentinal +> map_fst - (match Config.target (), Config.Flag.effects () with - | `JavaScript, false -> Generate_closure.f - | `JavaScript, true | `Wasm, _ -> Fun.id) + (match Config.target (), Config.effects () with + | `JavaScript, None -> Generate_closure.f + | `JavaScript, Some _ | `Wasm, _ -> Fun.id) +> map_fst deadcode' in if times () then Format.eprintf "Start Optimizing...@."; diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index c6adef9810..21ddc97e23 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -38,7 +38,11 @@ open Code let debug = Debug.find "effects" -let double_translate = Config.Flag.double_translation +let double_translate () = + match Config.effects () with + | None -> assert false + | Some Cps -> false + | Some Double_translation -> true let debug_print fmt = if debug () then Format.(eprintf (fmt ^^ "%!")) else Format.(ifprintf err_formatter fmt) diff --git a/compiler/lib/effects.mli b/compiler/lib/effects.mli index b4e499cd99..2468f4cf84 100644 --- a/compiler/lib/effects.mli +++ b/compiler/lib/effects.mli @@ -30,11 +30,11 @@ val f : (** 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. *) + In addition, if double translation 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/generate.ml b/compiler/lib/generate.ml index ecc38babeb..935125ed75 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -925,11 +925,11 @@ let apply_fun_raw = 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) + match Config.effects () with + | Some Double_translation when cps -> + (* Effects enabled, CPS version, not single-version *) + J.EDot (f, J.ANormal, cps_field) + | _ -> f in (* We skip the arity check when we know that we have the right number of parameters, since this test is expensive. *) @@ -953,15 +953,15 @@ let apply_fun_raw = (* 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")) + (match Config.effects () with + | Some Double_translation when cps -> "caml_call_gen_cps" + | _ -> "caml_call_gen")) [ f; J.array params ] J.N ) in if trampolined then ( - assert (Config.Flag.effects ()); + assert (Option.is_some (Config.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. @@ -1408,7 +1408,7 @@ let rec translate_expr ctx loc x e level : (_ * J.statement_list) Expr_builder.t return e | Extern "caml_alloc_dummy_function", _ -> assert false | Extern ("%resume" | "%perform" | "%reperform"), _ -> - if Config.Flag.effects () then assert false; + assert (Option.is_none (Config.effects ())); if not !(ctx.effect_warning) then ( warn diff --git a/compiler/lib/generate_closure.ml b/compiler/lib/generate_closure.ml index a3b4c0eb72..a585ebcfa9 100644 --- a/compiler/lib/generate_closure.ml +++ b/compiler/lib/generate_closure.ml @@ -327,7 +327,7 @@ let f p : Code.program = p let f p = - assert (not (Config.Flag.effects ())); + assert (Option.is_none (Config.effects ())); let open Config.Param in match tailcall_optim () with | TcNone -> p diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index c3d0a642df..695f2d0953 100644 --- a/compiler/lib/inline.ml +++ b/compiler/lib/inline.ml @@ -331,7 +331,7 @@ let times = Debug.find "times" let f p live_vars = let first_class_primitives = match Config.target () with - | `JavaScript -> not (Config.Flag.effects ()) + | `JavaScript -> Option.is_none (Config.effects ()) | `Wasm -> false in Code.invariant p; diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml index d514e457cf..c6a879536a 100644 --- a/compiler/lib/js_output.ml +++ b/compiler/lib/js_output.ml @@ -2099,7 +2099,8 @@ let program ?(accept_unnamed_var = false) ?(source_map = false) f p = let accept_unnamed_var = accept_unnamed_var end) in PP.set_needed_space_function f need_space; - if Config.Flag.effects () then PP.set_adjust_indentation_function f (fun n -> n mod 40); + if Option.is_some (Config.effects ()) + then PP.set_adjust_indentation_function f (fun n -> n mod 40); PP.start_group f 0; O.program f p; PP.end_group f; diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml index 310b4ab61d..84a1fccbb7 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -185,8 +185,12 @@ module Fragment = struct ~f:(fun m (k, v) -> StringMap.add k v m) ~init:StringMap.empty [ "js-string", Config.Flag.use_js_string - ; "effects", Config.Flag.effects - ; "doubletranslate", Config.Flag.double_translation + ; ("effects", fun () -> Option.is_some (Config.effects ())) + ; ( "doubletranslate" + , fun () -> + match Config.effects () with + | Some Double_translation -> true + | _ -> false ) ; ( "wasm" , fun () -> match Config.target () with diff --git a/compiler/lib/unit_info.ml b/compiler/lib/unit_info.ml index a3d3112917..7c87ac4a88 100644 --- a/compiler/lib/unit_info.ml +++ b/compiler/lib/unit_info.ml @@ -53,7 +53,7 @@ let of_cmo (cmo : Cmo_format.compilation_unit) = let requires = StringSet.of_list (Cmo_format.requires cmo) in let requires = StringSet.diff requires provides in let effects_without_cps = - (not (Config.Flag.effects ())) + Option.is_none (Config.effects ()) && List.exists (Cmo_format.primitives cmo) ~f:(function | "%resume" | "%reperform" | "%perform" -> true | _ -> false) diff --git a/compiler/tests-compiler/double-translation/direct_calls.ml b/compiler/tests-compiler/double-translation/direct_calls.ml index de6c6f24fb..efb648a634 100644 --- a/compiler/tests-compiler/double-translation/direct_calls.ml +++ b/compiler/tests-compiler/double-translation/direct_calls.ml @@ -18,7 +18,7 @@ open Util -let%expect_test "direct calls with --enable effects,doubletranslate" = +let%expect_test "direct calls with --effects=double-translation" = let code = compile_and_parse ~effects:true diff --git a/compiler/tests-compiler/double-translation/dune.inc b/compiler/tests-compiler/double-translation/dune.inc index aca4e07a45..1cecd7aa8b 100644 --- a/compiler/tests-compiler/double-translation/dune.inc +++ b/compiler/tests-compiler/double-translation/dune.inc @@ -2,7 +2,7 @@ (library ;; compiler/tests-compiler/double-translation/direct_calls.ml (name direct_calls_47) - (enabled_if %{env:js-enabled=}) + (enabled_if true) (modules direct_calls) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -17,7 +17,7 @@ (library ;; compiler/tests-compiler/double-translation/effects_continuations.ml (name effects_continuations_47) - (enabled_if %{env:js-enabled=}) + (enabled_if true) (modules effects_continuations) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -32,7 +32,7 @@ (library ;; compiler/tests-compiler/double-translation/effects_exceptions.ml (name effects_exceptions_47) - (enabled_if %{env:js-enabled=}) + (enabled_if true) (modules effects_exceptions) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -47,7 +47,7 @@ (library ;; compiler/tests-compiler/double-translation/effects_toplevel.ml (name effects_toplevel_47) - (enabled_if %{env:js-enabled=}) + (enabled_if true) (modules effects_toplevel) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests diff --git a/compiler/tests-compiler/util/util.ml b/compiler/tests-compiler/util/util.ml index ff5c148c8b..e44908189d 100644 --- a/compiler/tests-compiler/util/util.ml +++ b/compiler/tests-compiler/util/util.ml @@ -295,15 +295,17 @@ let compile_to_javascript ~pretty ~sourcemap file = + assert (not doubletranslate || effects); let out_file = swap_extention file ~ext:"js" in let extra_args = List.flatten [ (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 effects && doubletranslate + then [ "--effects=double-translation" ] + else if effects + then [ "--effects=cps" ] + else []) ; (if use_js_string then [ "--enable=use-js-string" ] else [ "--disable=use-js-string" ]) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index dd2b2cd741..60439edead 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -4,9 +4,9 @@ (:standard -w -38)) (js_of_ocaml (flags - (:standard --enable effects,doubletranslate)) + (:standard --effects=double-translation)) (build_runtime_flags - (:standard --enable effects,doubletranslate)) + (:standard --effects=double-translation)) ;; 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 @@ -17,7 +17,7 @@ (:standard -w -38)) (js_of_ocaml (flags - (:standard --enable effects,doubletranslate)) + (:standard --effects=double-translation)) ;; separate compilation doesn't work when using ;; features such as 'effects' or 'use-js-string' ;; because dune doesn't know that it should compile diff --git a/lib/js_of_ocaml/js.mli b/lib/js_of_ocaml/js.mli index e24ebc2126..e54130ede0 100644 --- a/lib/js_of_ocaml/js.mli +++ b/lib/js_of_ocaml/js.mli @@ -892,15 +892,14 @@ 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 ()]. *) + when compiling with `--effects=double-translation`, 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. + + This behaviour is the same when double translation is disabled. *) end (** {2 Unsafe operations.} *) From 0835a698b59e973a953dffa9633eb4330ab9bd57 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 11 Dec 2024 18:14:38 +0100 Subject: [PATCH 43/80] Fix Dynlink and limit use of --enable=effects --- README.md | 3 ++- README_wasm_of_ocaml.md | 4 ++-- compiler/bin-js_of_ocaml/cmd_arg.ml | 22 ++++++++++++++++--- .../js_of_ocaml_compiler_dynlink.ml | 7 +++++- compiler/lib-runtime-files/gen/gen.ml | 14 ++++++++---- compiler/lib/generate.ml | 2 +- compiler/lib/link_js.ml | 2 +- compiler/tests-compiler/direct_calls.ml | 4 ++-- .../lib-effects/double-translation/dune | 7 ++++-- compiler/tests-ocaml/lib-effects/dune | 4 +++- lib/runtime/jsoo_runtime.ml | 11 +++++++++- manual/effects.wiki | 10 +++++---- manual/overview.wiki | 6 ++++- manual/tailcall.wiki | 2 +- runtime/js/jslib.js | 17 +++++++++++++- 15 files changed, 89 insertions(+), 26 deletions(-) diff --git a/README.md b/README.md index a52ac2582c..c51dc4ddd8 100644 --- a/README.md +++ b/README.md @@ -92,7 +92,8 @@ optimized: [More](http://ocsigen.org/js_of_ocaml/dev/manual/tailcall) about tail call optimization. -Effect handlers are supported with the `--enable=effects` flag. +Effect handlers are supported with the `--effects={cps,double-translation}` +flag. ## Data representation diff --git a/README_wasm_of_ocaml.md b/README_wasm_of_ocaml.md index 256ff4045b..b50568ed72 100644 --- a/README_wasm_of_ocaml.md +++ b/README_wasm_of_ocaml.md @@ -13,8 +13,8 @@ In particular, the output code requires the following [Wasm extensions](https:// OCaml 5.x code using effect handlers can be compiled in two different ways: One can enable the CPS transformation from `js_of_ocaml` by passing the -`--enable=effects` flag. Without the flag `wasm_of_ocaml` will instead emit code -utilizing +`--effects=cps` flag. Without the flag `wasm_of_ocaml` will instead default to +`--effects=jspi` and emit code utilizing - [the JavaScript-Promise Integration extension](https://github.com/WebAssembly/js-promise-integration/blob/main/proposals/js-promise-integration/Overview.md) diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml index b91f077c4c..24996598a3 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.ml +++ b/compiler/bin-js_of_ocaml/cmd_arg.ml @@ -514,6 +514,20 @@ let options_runtime_only = & opt (some string) None & info [ "ofs" ] ~docs:filesystem_section ~docv:"FILE" ~doc) in + let effects = + let doc = + "Select an implementation of effect handlers. [$(docv)] should be one of $(b,cps) \ + or $(b,double-translation). Effects are not allowed by default." + in + Arg.( + value + & opt + (some + (enum + [ "cps", Config.Cps; "double-translation", Double_translation ])) + None + & info [ "effects" ] ~docv:"KIND" ~doc) + in let build_t common toplevel @@ -533,7 +547,8 @@ let options_runtime_only = sourcemap_root target_env output_file - js_files = + js_files + effects = let inline_source_content = not sourcemap_don't_inline_content in let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in let runtime_files = js_files in @@ -585,7 +600,7 @@ let options_runtime_only = ; bytecode = `None ; source_map ; keep_unit_names = false - ; effects = None + ; effects } in let t = @@ -609,6 +624,7 @@ let options_runtime_only = $ sourcemap_root $ target_env $ output_file - $ js_files) + $ js_files + $ effects) in Term.ret t diff --git a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml index 1bc2bc2f5a..48c47ffbbb 100644 --- a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml +++ b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml @@ -39,7 +39,12 @@ let () = | Sys.(Native | Bytecode | Other _) -> failwith "Expected backend `js_of_ocaml`"); let global = J.pure_js_expr "globalThis" in Config.Flag.set "use-js-string" (Jsoo_runtime.Sys.Config.use_js_string ()); - Config.Flag.set "effects" (Jsoo_runtime.Sys.Config.effects ()); + Config.set_effects_backend + (match Jsoo_runtime.Sys.Config.effects () with + | None -> None + | Some Jsoo_runtime.Sys.Config.Cps -> Some Config.Cps + | Some Jsoo_runtime.Sys.Config.Double_translation -> Some Config.Double_translation + ); Linker.reset (); (* this needs to stay synchronized with toplevel.js *) let toplevel_compile (s : string) (debug : Instruct.debug_event list array) : diff --git a/compiler/lib-runtime-files/gen/gen.ml b/compiler/lib-runtime-files/gen/gen.ml index 06845810c7..4115b9edf4 100644 --- a/compiler/lib-runtime-files/gen/gen.ml +++ b/compiler/lib-runtime-files/gen/gen.ml @@ -48,7 +48,11 @@ let rec list_product l = let tail = list_product xs in List.concat_map values ~f:(fun v -> List.map tail ~f:(fun l -> (key, v) :: l)) -let bool = [ true; false ] +let bool = [ `Bool true; `Bool false ] + +let effects_backends = + let open Js_of_ocaml_compiler.Config in + [ `Effects None; `Effects (Some Cps); `Effects (Some Double_translation) ] let () = Js_of_ocaml_compiler.Config.set_target `JavaScript; @@ -60,11 +64,13 @@ let () = let fragments = List.map rest ~f:(fun f -> f, Js_of_ocaml_compiler.Linker.Fragment.parse_file f) in - let variants = list_product [ "use-js-string", bool; "effects", bool ] in + let variants = list_product [ "use-js-string", bool; "effects", effects_backends ] in (* load all files to make sure they are valid *) List.iter variants ~f:(fun setup -> - List.iter setup ~f:(fun (name, b) -> - Js_of_ocaml_compiler.Config.Flag.set name b); + List.iter setup ~f:(fun (name, v) -> + match v with + | `Bool b -> Js_of_ocaml_compiler.Config.Flag.set name b + | `Effects b -> Js_of_ocaml_compiler.Config.set_effects_backend b); List.iter Js_of_ocaml_compiler.Target_env.all ~f:(fun target_env -> Js_of_ocaml_compiler.Linker.reset (); List.iter fragments ~f:(fun (filename, frags) -> diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 935125ed75..3509c15e3d 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -1413,7 +1413,7 @@ let rec translate_expr ctx loc x e level : (_ * J.statement_list) Expr_builder.t then ( warn "Warning: your program contains effect handlers; you should probably run \ - js_of_ocaml with option '--enable=effects'@."; + js_of_ocaml with option '--effects=cps'@."; ctx.effect_warning := true); let name = "jsoo_effect_not_supported" in let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in diff --git a/compiler/lib/link_js.ml b/compiler/lib/link_js.ml index a3e1976dc1..1605dd8c02 100644 --- a/compiler/lib/link_js.ml +++ b/compiler/lib/link_js.ml @@ -343,7 +343,7 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source warn_effects := true; warn "Warning: your program contains effect handlers; you should \ - probably run js_of_ocaml with option '--enable=effects'@."); + probably run js_of_ocaml with option '--effects=cps'@."); (if mklib then let u = if linkall then { u with force_link = true } else u in diff --git a/compiler/tests-compiler/direct_calls.ml b/compiler/tests-compiler/direct_calls.ml index 2a81029d9c..d0e55b9da1 100644 --- a/compiler/tests-compiler/direct_calls.ml +++ b/compiler/tests-compiler/direct_calls.ml @@ -18,7 +18,7 @@ open Util -let%expect_test "direct calls without --enable effects" = +let%expect_test "direct calls without --effects=cps" = let code = compile_and_parse {| @@ -99,7 +99,7 @@ let%expect_test "direct calls without --enable effects" = } //end |}] -let%expect_test "direct calls with --enable effects" = +let%expect_test "direct calls with --effects=cps" = let code = compile_and_parse ~effects:true diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index 60439edead..341305c30c 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -1,5 +1,5 @@ (env - (using-effects + (with-effects (flags (:standard -w -38)) (js_of_ocaml @@ -10,7 +10,8 @@ ;; 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 + ;; multiple versions of the dependencies as is doesn't know about + ;; '--effects=double-translation'. (compilation_mode whole_program))) (_ (flags @@ -18,6 +19,8 @@ (js_of_ocaml (flags (:standard --effects=double-translation)) + (build_runtime_flags + (:standard --effects=double-translation)) ;; separate compilation doesn't work when using ;; features such as 'effects' or 'use-js-string' ;; because dune doesn't know that it should compile diff --git a/compiler/tests-ocaml/lib-effects/dune b/compiler/tests-ocaml/lib-effects/dune index e1258a9fbc..83eb174b38 100644 --- a/compiler/tests-ocaml/lib-effects/dune +++ b/compiler/tests-ocaml/lib-effects/dune @@ -4,7 +4,9 @@ (:standard -w -38)) (js_of_ocaml (flags - (:standard --enable effects))))) + (:standard --enable=effects)) + (build_runtime_flags + (:standard --enable=effects))))) (tests (build_if diff --git a/lib/runtime/jsoo_runtime.ml b/lib/runtime/jsoo_runtime.ml index 8127195231..fd7fd4a2b4 100644 --- a/lib/runtime/jsoo_runtime.ml +++ b/lib/runtime/jsoo_runtime.ml @@ -127,7 +127,16 @@ module Sys = struct module Config = struct external use_js_string : unit -> bool = "caml_jsoo_flags_use_js_string" - external effects : unit -> bool = "caml_jsoo_flags_effects" + type effects_backend = Cps | Double_translation + + external effects_ : unit -> string = "caml_jsoo_flags_effects" + + let effects () = + match effects_ () with + | "none" -> None + | "cps" -> Some Cps + | "double-translation" -> Some Double_translation + | _ -> assert false end let version = Runtime_version.s diff --git a/manual/effects.wiki b/manual/effects.wiki index 551afee24f..cffef5b334 100644 --- a/manual/effects.wiki +++ b/manual/effects.wiki @@ -1,7 +1,7 @@ == Effect handlers == -Js_of_ocaml supports effect handlers with the {{{--enable=effects}}} -flag. This is based on partially transforming the program to +Js_of_ocaml supports effect handlers with the {{{--effects={cps,double-translation}}}} +flag. The {{cps}} option is based on partially transforming the program to continuation-passing style. As a consequence, [[tailcall|tail calls]] are also fully optimized. This is not the default for now since the generated code can be slower, @@ -11,6 +11,8 @@ The analysis is especially effective on monomorphic code. It is not so effective We hope to improve on this by trying alternative compilation strategies. +The {{double-translation}} option does a similar CPS transform, but also keeps a direct-style version of the transformed functions. The choice of running the CPS version is delayed to run time. Since CPS code is usually slower, this can avoid degradations. In addition, one can ensure that some code is run in direct style by using {{Js_of_ocaml.Js.assume_no_perform}}. + === Dune integration === We're still working on dune support for compiling js_of_ocaml programs @@ -25,7 +27,7 @@ Put the following in a {{{dune}}} (or {{{dune-workspace}}}) file at the root of (env (_ (js_of_ocaml - (flags (:standard --enable effects)) + (flags (:standard --effects=cps)) (build_runtime_flags (:standard --enable effects))))) }}} @@ -50,7 +52,7 @@ Then pass the rights {{{js_of_ocaml}}} flags to the executable stanza {{{ (executable (name main) - (js_of_ocaml (flags (:standard --enable effects))) + (js_of_ocaml (flags (:standard --effects=cps))) ) }}} diff --git a/manual/overview.wiki b/manual/overview.wiki index 24c7b8f515..bfc8eee899 100644 --- a/manual/overview.wiki +++ b/manual/overview.wiki @@ -84,7 +84,11 @@ functions are optimized: * trampolines are used otherwise. <>. -Effect handlers are fully supported with the {{{--enable=effects}}} flag. This is not the default for now since effects are not widely used at the moment and the generated code can be slower, larger and less readable. +Effect handlers are fully supported with the +{{{--effects={cps,double-translation}}}} flag. Effect support is disabled by +default for now since effects are not widely used at the moment and the +generated code can be slower, larger and less readable. See the dedicated +manual section about effects for details. Data representation differs from the usual one. Most notably, integers are 32 bits (rather than 31 bits or 63 bits), which is their diff --git a/manual/tailcall.wiki b/manual/tailcall.wiki index 4ef3d687da..f8aefe94b2 100644 --- a/manual/tailcall.wiki +++ b/manual/tailcall.wiki @@ -3,7 +3,7 @@ JavaScript does not (yet) support tail call optimization. To circumvent this limitation, and mitigate stack overflows, the Js_of_ocaml compiler optimizes some common tail call patterns. Besides, all tail calls are optimized when you set the flag -{{{--enable=effects}}}, at the cost of some performance degradation. +{{{--effects=cps}}}, at the cost of some performance degradation. === Self tail recursive Self tail recursive function are compiled into a loop. diff --git a/runtime/js/jslib.js b/runtime/js/jslib.js index 2fef127f8d..99697013a5 100644 --- a/runtime/js/jslib.js +++ b/runtime/js/jslib.js @@ -139,8 +139,23 @@ function caml_jsoo_flags_use_js_string(unit) { } //Provides: caml_jsoo_flags_effects +//If: !effects +function caml_jsoo_flags_effects(unit) { + return "none"; +} + +//Provides: caml_jsoo_flags_effects +//If: effects +//If: !doubletranslate +function caml_jsoo_flags_effects(unit) { + return "cps"; +} + +//Provides: caml_jsoo_flags_effects +//If: effects +//If: doubletranslate function caml_jsoo_flags_effects(unit) { - return FLAG("effects"); + return "double-translation"; } //Provides: caml_wrap_exception const (mutable) From 29c6a82102ee1014d4bcb6408cd82d468d36bcf5 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 12 Dec 2024 11:23:14 +0100 Subject: [PATCH 44/80] Reformat --- compiler/bin-js_of_ocaml/cmd_arg.ml | 8 ++------ compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml | 3 +-- compiler/lib-runtime-files/gen/gen.ml | 4 +++- compiler/lib/build_info.ml | 3 +-- compiler/tests-compiler/util/util.ml | 2 +- compiler/tests-ocaml/lib-effects/dune | 2 +- lib/runtime/jsoo_runtime.ml | 4 +++- 7 files changed, 12 insertions(+), 14 deletions(-) diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml index 24996598a3..d209319291 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.ml +++ b/compiler/bin-js_of_ocaml/cmd_arg.ml @@ -262,9 +262,7 @@ let options = Arg.( value & opt - (some - (enum - [ "cps", Config.Cps; "double-translation", Double_translation ])) + (some (enum [ "cps", Config.Cps; "double-translation", Double_translation ])) None & info [ "effects" ] ~docv:"KIND" ~doc) in @@ -522,9 +520,7 @@ let options_runtime_only = Arg.( value & opt - (some - (enum - [ "cps", Config.Cps; "double-translation", Double_translation ])) + (some (enum [ "cps", Config.Cps; "double-translation", Double_translation ])) None & info [ "effects" ] ~docv:"KIND" ~doc) in diff --git a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml index 48c47ffbbb..fa8ba93360 100644 --- a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml +++ b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml @@ -43,8 +43,7 @@ let () = (match Jsoo_runtime.Sys.Config.effects () with | None -> None | Some Jsoo_runtime.Sys.Config.Cps -> Some Config.Cps - | Some Jsoo_runtime.Sys.Config.Double_translation -> Some Config.Double_translation - ); + | Some Jsoo_runtime.Sys.Config.Double_translation -> Some Config.Double_translation); Linker.reset (); (* this needs to stay synchronized with toplevel.js *) let toplevel_compile (s : string) (debug : Instruct.debug_event list array) : diff --git a/compiler/lib-runtime-files/gen/gen.ml b/compiler/lib-runtime-files/gen/gen.ml index 4115b9edf4..b21f4002c7 100644 --- a/compiler/lib-runtime-files/gen/gen.ml +++ b/compiler/lib-runtime-files/gen/gen.ml @@ -64,7 +64,9 @@ let () = let fragments = List.map rest ~f:(fun f -> f, Js_of_ocaml_compiler.Linker.Fragment.parse_file f) in - let variants = list_product [ "use-js-string", bool; "effects", effects_backends ] in + let variants = + list_product [ "use-js-string", bool; "effects", effects_backends ] + in (* load all files to make sure they are valid *) List.iter variants ~f:(fun setup -> List.iter setup ~f:(fun (name, v) -> diff --git a/compiler/lib/build_info.ml b/compiler/lib/build_info.ml index 23dbd8c62c..efd0425058 100644 --- a/compiler/lib/build_info.ml +++ b/compiler/lib/build_info.ml @@ -139,8 +139,7 @@ let merge fname1 info1 fname2 info2 = if Option.equal String.equal v1 v2 then v1 else Some (string_of_kind `Unknown) | ("effects" | "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" | "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 diff --git a/compiler/tests-compiler/util/util.ml b/compiler/tests-compiler/util/util.ml index e44908189d..f04be162ec 100644 --- a/compiler/tests-compiler/util/util.ml +++ b/compiler/tests-compiler/util/util.ml @@ -295,7 +295,7 @@ let compile_to_javascript ~pretty ~sourcemap file = - assert (not doubletranslate || effects); + assert ((not doubletranslate) || effects); let out_file = swap_extention file ~ext:"js" in let extra_args = List.flatten diff --git a/compiler/tests-ocaml/lib-effects/dune b/compiler/tests-ocaml/lib-effects/dune index 83eb174b38..9ac073c2b3 100644 --- a/compiler/tests-ocaml/lib-effects/dune +++ b/compiler/tests-ocaml/lib-effects/dune @@ -6,7 +6,7 @@ (flags (:standard --enable=effects)) (build_runtime_flags - (:standard --enable=effects))))) + (:standard --enable=effects))))) (tests (build_if diff --git a/lib/runtime/jsoo_runtime.ml b/lib/runtime/jsoo_runtime.ml index fd7fd4a2b4..e3fb6f186e 100644 --- a/lib/runtime/jsoo_runtime.ml +++ b/lib/runtime/jsoo_runtime.ml @@ -127,7 +127,9 @@ module Sys = struct module Config = struct external use_js_string : unit -> bool = "caml_jsoo_flags_use_js_string" - type effects_backend = Cps | Double_translation + type effects_backend = + | Cps + | Double_translation external effects_ : unit -> string = "caml_jsoo_flags_effects" From b8a379904c903237e0a7adf146eeadc97b094189 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 12 Dec 2024 12:07:10 +0100 Subject: [PATCH 45/80] CR --- compiler/lib/effects.ml | 57 +++++++++++++++-------------------------- compiler/lib/stdlib.ml | 15 ----------- 2 files changed, 20 insertions(+), 52 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 21ddc97e23..8120b525c9 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -769,10 +769,10 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = let cps_pc_of_direct = Hashtbl.create 512 in let cloned_vars = Array.init (Var.count ()) ~f:Var.of_idx in let cloned_subst = Subst.from_array cloned_vars in - let p, new_blocks = + let p = Code.fold_closures_innermost_first p - (fun name_opt params (start, args) (({ blocks; free_pc; _ } as p), new_blocks) -> + (fun name_opt params (start, args) ({ blocks; free_pc; _ } as p) -> 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 @@ -862,7 +862,7 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = start blocks ()); - let blocks, free_pc, new_blocks = + let blocks, free_pc = (* 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, @@ -927,45 +927,28 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = (* 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). *) - if double_translate () + if function_needs_cps && double_translate () then - if function_needs_cps && double_translate () - then - Code.traverse - Code.{ fold = fold_children } - (fun pc () -> - let block = Addr.Map.find pc p.blocks in - Freevars.iter_block_bound_vars - (fun v -> subst_add_fresh cloned_vars v) - block) - initial_start - p.blocks - (); - let blocks = Addr.Map.fold Addr.Map.add new_blocks_this_clos blocks in - ( blocks - , free_pc - , Addr.Map.union (fun _ _ -> assert false) new_blocks new_blocks_this_clos ) + Code.traverse + Code.{ fold = fold_children } + (fun pc () -> + let block = Addr.Map.find pc p.blocks in + Freevars.iter_block_bound_vars + (fun v -> subst_add_fresh cloned_vars v) + block) + initial_start + p.blocks + (); + let new_blocks = subst_bound_in_blocks new_blocks_this_clos cloned_subst in + let blocks = Addr.Map.fold Addr.Map.add new_blocks blocks in + blocks, free_pc in - { p with blocks; free_pc }, new_blocks) - (p, Addr.Map.empty) + { p with blocks; free_pc }) + p in - let new_blocks = subst_bound_in_blocks new_blocks cloned_subst in - (* Also apply that substitution to the sets of trampolined calls, and cps - call sites *) + (* Also apply our substitution to the sets of trampolined calls, and cps call sites *) trampolined_calls := Var.Set.map cloned_subst !trampolined_calls; in_cps := Var.Set.map cloned_subst !in_cps; - let p = - { 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 p diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index 075d8fbe0b..923e22a388 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -1179,21 +1179,6 @@ 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 From 733f4dc7aa48882b9c40b63586632b74d7ed1ed8 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 12 Dec 2024 12:18:40 +0100 Subject: [PATCH 46/80] CR --- compiler/lib/effects.ml | 36 ++++++++++++++++++++---------------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 8120b525c9..74b3f30edf 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -291,7 +291,8 @@ type trampolined_calls = Var.Set.t type in_cps = Var.Set.t type st = - { mutable new_blocks : Code.block Addr.Map.t * Code.Addr.t + { mutable new_blocks : Code.block Addr.Map.t + ; mutable free_pc : Code.Addr.t ; blocks : Code.block Addr.Map.t ; cfg : control_flow_graph ; idom : (int, int) Hashtbl.t @@ -313,8 +314,10 @@ type st = } let add_block st block = - let blocks, free_pc = st.new_blocks in - st.new_blocks <- Addr.Map.add free_pc block blocks, free_pc + 1; + let blocks = st.new_blocks in + let free_pc = st.free_pc in + st.new_blocks <- Addr.Map.add free_pc block blocks; + st.free_pc <- free_pc + 1; free_pc (* Provide the address of the CPS translation of a block *) @@ -323,8 +326,10 @@ let mk_cps_pc_of_direct ~st pc = then ( try Hashtbl.find st.cps_pc_of_direct pc with Not_found -> - let new_blocks, free_pc = st.new_blocks in - st.new_blocks <- new_blocks, free_pc + 1; + let new_blocks = st.new_blocks in + let free_pc = st.free_pc in + st.new_blocks <- new_blocks; + st.free_pc <- free_pc + 1; Hashtbl.add st.cps_pc_of_direct pc free_pc; free_pc) else pc @@ -772,7 +777,7 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = let p = Code.fold_closures_innermost_first p - (fun name_opt params (start, args) ({ blocks; free_pc; _ } as p) -> + (fun name_opt params (start, args) ({ Code.blocks; free_pc; _ } as p) -> 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 @@ -819,7 +824,8 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = else start, args, blocks, free_pc in let st = - { new_blocks = Addr.Map.empty, free_pc + { new_blocks = Addr.Map.empty + ; free_pc ; blocks ; cfg ; idom @@ -862,7 +868,7 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = start blocks ()); - let blocks, free_pc = + let 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, @@ -916,14 +922,13 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = | 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; + let new_blocks = st.new_blocks in + st.new_blocks <- Addr.Map.add cps_pc b new_blocks; 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). *) @@ -939,11 +944,10 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = initial_start p.blocks (); - let new_blocks = subst_bound_in_blocks new_blocks_this_clos cloned_subst in - let blocks = Addr.Map.fold Addr.Map.add new_blocks blocks in - blocks, free_pc + let new_blocks = subst_bound_in_blocks st.new_blocks cloned_subst in + Addr.Map.fold Addr.Map.add new_blocks blocks in - { p with blocks; free_pc }) + { p with blocks; free_pc = st.free_pc }) p in (* Also apply our substitution to the sets of trampolined calls, and cps call sites *) @@ -997,7 +1001,7 @@ let wrap_call ~cps_needed p x f args accu = ] :: accu ) -let wrap_primitive ~cps_needed p x e accu = +let wrap_primitive ~cps_needed (p : program) x e accu = let f = Var.fresh () in let closure_pc = p.free_pc in ( { p with From 618bc52323a02f4a918f2e362de70d6d829a12db Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 12 Dec 2024 12:52:12 +0100 Subject: [PATCH 47/80] CR: add missing bound check --- compiler/lib/effects.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 74b3f30edf..04806ff0f4 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -607,7 +607,10 @@ let cps_instr ~st (instr : instr) : instr list = (* When double translation is enabled, we just call [f] in direct style. Otherwise, the runtime primitive is used. *) let unit = Var.fresh_n "unit" in - let exact = Global_flow.exact_call st.flow_info f 1 in + let exact = + Var.idx f < Var.Tbl.length st.flow_info.info_approximation + && Global_flow.exact_call st.flow_info f 1 + in [ Let (unit, Constant (Int Targetint.zero)) ; Let (x, Apply { exact; f; args = [ unit ] }) ] From 244267e3d5cfb2e7b15a76830b311facee5c8e4e Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 12 Dec 2024 14:13:20 +0100 Subject: [PATCH 48/80] CR: Simplification in compiler/lib/effects.ml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Jérôme Vouillon --- compiler/lib/effects.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 04806ff0f4..92b0c366b0 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -326,9 +326,7 @@ let mk_cps_pc_of_direct ~st pc = then ( try Hashtbl.find st.cps_pc_of_direct pc with Not_found -> - let new_blocks = st.new_blocks in let free_pc = st.free_pc in - st.new_blocks <- new_blocks; st.free_pc <- free_pc + 1; Hashtbl.add st.cps_pc_of_direct pc free_pc; free_pc) From b705214aec09f17566f2dc265d63241f6ca47713 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 12 Dec 2024 14:37:03 +0100 Subject: [PATCH 49/80] CR: simplify closure allocation --- compiler/lib/effects.ml | 23 ++++++----------------- 1 file changed, 6 insertions(+), 17 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 92b0c366b0..82b068e967 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -113,12 +113,6 @@ let dominator_tree g = l); dom -(* pc dominates pc' *) -let rec dominates g idom pc pc' = - pc = pc' - || Hashtbl.find g.block_order pc < Hashtbl.find g.block_order pc' - && dominates g idom pc (Hashtbl.find idom pc') - (* pc has at least two forward edges moving into it *) let is_merge_node g pc = let s = try Hashtbl.find g.preds pc with Not_found -> assert false in @@ -295,7 +289,6 @@ type st = ; mutable free_pc : Code.Addr.t ; blocks : Code.block Addr.Map.t ; cfg : control_flow_graph - ; idom : (int, int) Hashtbl.t ; jc : jump_closures ; 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 *) @@ -452,15 +445,12 @@ let allocate_continuation ~st ~alloc_jump_closures ~split_closures src_pc x dire else if is_merge_node st.cfg direct_pc then [], alloc_jump_closures else - 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 + List.partition + ~f:(fun i -> + match i with + | Let (_, Closure (_, (pc'', []))) -> pc'' = mk_cps_pc_of_direct ~st direct_pc + | _ -> assert false) + alloc_jump_closures in let body, branch = allocate_closure ~st ~params:[ x ] ~body:(inner_closures @ body) ~branch @@ -829,7 +819,6 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = ; free_pc ; blocks ; cfg - ; idom ; jc = closure_jc ; closure_info ; cps_needed From f1441bcc1bb53a08a5c8ddb0843781a2c1ae6fe9 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 12 Dec 2024 15:47:21 +0100 Subject: [PATCH 50/80] Javascript runtime: stop using 'arguments' --- runtime/js/stdlib.js | 47 ++++++++++++++----------------------- runtime/js/stdlib_modern.js | 47 ++++++++++++++----------------------- 2 files changed, 34 insertions(+), 60 deletions(-) diff --git a/runtime/js/stdlib.js b/runtime/js/stdlib.js index 45c795a1d3..87e5f6d801 100644 --- a/runtime/js/stdlib.js +++ b/runtime/js/stdlib.js @@ -146,23 +146,16 @@ var caml_call_gen_tuple = (function () { ); } else { // FIXME: Restore the optimization of handling specially d = 1 or 2 + var args_ = args.slice(); + args_.length = argsLen; 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 (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_direct(f, args.concat(extra_args)); }, - 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); + function (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_cps(f, args_.concat(extra_args)); }, ); ret.l = d; @@ -188,25 +181,19 @@ var caml_call_gen_tuple = (function () { return f.cps.apply(null, args); } else { argsLen--; - var k = args[argsLen]; + var args_ = args.slice(); + args_.length = 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 (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_direct(f, args_.concat(extra_args)); }, - 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); + function (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_cps(f, args_.concat(extra_args)); }, ); + var k = args[argsLen]; cont.l = d; cont.cps.l = d + 1; return k(cont); diff --git a/runtime/js/stdlib_modern.js b/runtime/js/stdlib_modern.js index f921365218..ba47bdc341 100644 --- a/runtime/js/stdlib_modern.js +++ b/runtime/js/stdlib_modern.js @@ -134,23 +134,16 @@ var caml_call_gen_tuple = (function () { 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 args_ = args.slice(); + args_.length = argsLen; 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 (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_direct(f, args.concat(extra_args)); }, - 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); + function (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_cps(f, args_.concat(extra_args)); }, ); ret.l = d; @@ -176,25 +169,19 @@ var caml_call_gen_tuple = (function () { return f.cps(...args); } else { argsLen--; - var k = args[argsLen]; + var args_ = args.slice(); + args_.length = 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 (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_direct(f, args_.concat(extra_args)); }, - 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); + function (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_cps(f, args_.concat(extra_args)); }, ); + var k = args[argsLen]; cont.l = d; cont.cps.l = d + 1; return k(cont); From 4107e24a3f12408da60899443a24ed1efbc94d15 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 12 Dec 2024 16:53:21 +0100 Subject: [PATCH 51/80] Fix too early effects backend setting MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Jérôme Vouillon --- compiler/bin-wasm_of_ocaml/compile.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index b857c8d5a4..bfa5d98e73 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -273,12 +273,12 @@ let run } = Config.set_target `Wasm; (* For backward compatibility, consider that [--enable effects] alone means [--effects cps] *) + Jsoo_cmdline.Arg.eval common; Config.set_effects_backend (match effects with | None -> if Config.Flag.effects () then Some Cps else None | Some Cps -> Some Cps | Some _ -> failwith "Unexpected effects backend"); - Jsoo_cmdline.Arg.eval common; Generate.init (); let output_file = fst output_file in if debug_mem () then Debug.start_profiling output_file; From 9b8a90b0c7b7c6ea62fa4fc9e654628c471d01b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Thu, 12 Dec 2024 17:18:30 +0100 Subject: [PATCH 52/80] Fix uses of `--enable=effects` in lib-wasm/ --- compiler/lib-wasm/gc_target.ml | 2 +- compiler/lib-wasm/generate.ml | 14 ++++++-------- 2 files changed, 7 insertions(+), 9 deletions(-) diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index f2e6b7eccd..f7bdc62f61 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/compiler/lib-wasm/gc_target.ml @@ -1706,7 +1706,7 @@ let post_process_function_body = Initialize_locals.f let entry_point ~toplevel_fun = let code = let* () = - if Config.Flag.effects () + if Option.is_some (Config.effects ()) then let* f = register_import diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index d5e590dff2..078fcc442e 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -21,6 +21,8 @@ open Code module W = Wasm_ast open Code_generation +let effects () = Option.is_some (Config.effects ()) + module Generate (Target : Target_sig.S) = struct open Target @@ -237,9 +239,9 @@ module Generate (Target : Target_sig.S) = struct | Constant c -> Constant.translate c | Special (Alias_prim _) -> assert false | Prim (Extern "caml_alloc_dummy_function", [ _; Pc (Int arity) ]) -> - Closure.dummy ~cps:(Config.Flag.effects ()) ~arity:(Targetint.to_int_exn arity) + Closure.dummy ~cps:(effects ()) ~arity:(Targetint.to_int_exn arity) | Prim (Extern "caml_alloc_dummy_infix", _) -> - Closure.dummy ~cps:(Config.Flag.effects ()) ~arity:1 + Closure.dummy ~cps:(effects ()) ~arity:1 | Prim (Extern "caml_get_global", [ Pc (String name) ]) -> let* x = let* context = get_context in @@ -1176,11 +1178,7 @@ let init () = ] in Primitive.register "caml_array_of_uniform_array" `Mutable None None; - let l = - if Config.Flag.effects () - then ("caml_alloc_stack", "caml_cps_alloc_stack") :: l - else l - in + let l = if effects () then ("caml_alloc_stack", "caml_cps_alloc_stack") :: l else l in List.iter ~f:(fun (nm, nm') -> Primitive.alias nm nm') l (* Make sure we can use [br_table] for switches *) @@ -1222,7 +1220,7 @@ let fix_switch_branches p = let start () = make_context ~value_type:Gc_target.Value.value let f ~context ~unit_name p ~live_vars ~in_cps ~deadcode_sentinal ~debug = - let p = if Config.Flag.effects () then fix_switch_branches p else p in + let p = if effects () then fix_switch_branches p else p in let module G = Generate (Gc_target) in G.f ~context ~unit_name ~live_vars ~in_cps ~deadcode_sentinal ~debug p From cc385000eb4f8ad0998ef37a39356e4bf52dc225 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 12 Dec 2024 18:03:48 +0100 Subject: [PATCH 53/80] Move assume_no_perform to Jsoo_runtime --- .../tests-ocaml/lib-effects/assume_no_perform.ml | 2 +- .../assume_no_perform_nested_handler.ml | 2 +- .../lib-effects/assume_no_perform_unhandled.ml | 2 +- .../lib-effects/double-translation/dune | 2 +- compiler/tests-ocaml/lib-effects/dune | 2 +- lib/js_of_ocaml/js.ml | 6 ------ lib/js_of_ocaml/js.mli | 13 ------------- lib/runtime/jsoo_runtime.ml | 15 +++++++++++++++ manual/effects.wiki | 2 +- 9 files changed, 21 insertions(+), 25 deletions(-) diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform.ml b/compiler/tests-ocaml/lib-effects/assume_no_perform.ml index 5818e8f9f1..5808e584c5 100644 --- a/compiler/tests-ocaml/lib-effects/assume_no_perform.ml +++ b/compiler/tests-ocaml/lib-effects/assume_no_perform.ml @@ -136,7 +136,7 @@ let () = (* The code below should be called in direct style despite the installed effect handler *) - Js_of_ocaml.Js.Effect.assume_no_perform (fun () -> + Jsoo_runtime.Effect.assume_no_perform (fun () -> let m, sd = benchmark iter_fun 5 in let () = printf "Iter: mean = %f, sd = %f\n%!" m sd in diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml b/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml index 7be1f1aacd..25f152ee82 100644 --- a/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml +++ b/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml @@ -7,7 +7,7 @@ type _ Effect.t += Dummy : unit t let () = try_with (fun () -> - Js_of_ocaml.Js.Effect.assume_no_perform (fun () -> + Jsoo_runtime.Effect.assume_no_perform (fun () -> try_with (fun () -> ()) () diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml index c81d984806..a6ff920bdf 100644 --- a/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml +++ b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml @@ -7,7 +7,7 @@ type _ Effect.t += Dummy : unit t let must_raise () = try_with (fun () -> - Js_of_ocaml.Js.Effect.assume_no_perform (fun () -> + Jsoo_runtime.Effect.assume_no_perform (fun () -> (* Should raise [Effect.Unhandled] despite the installed handler *) perform Dummy ) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index 341305c30c..259b66c4d4 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -85,7 +85,7 @@ assume_no_perform assume_no_perform_unhandled assume_no_perform_nested_handler) - (libraries js_of_ocaml) + (libraries js_of_ocaml-compiler.runtime) (action (ignore-outputs (with-accepted-exit-codes diff --git a/compiler/tests-ocaml/lib-effects/dune b/compiler/tests-ocaml/lib-effects/dune index 9ac073c2b3..7eedfc0405 100644 --- a/compiler/tests-ocaml/lib-effects/dune +++ b/compiler/tests-ocaml/lib-effects/dune @@ -62,7 +62,7 @@ assume_no_perform assume_no_perform_unhandled assume_no_perform_nested_handler) - (libraries js_of_ocaml) + (libraries js_of_ocaml-compiler.runtime) (action (ignore-outputs (with-accepted-exit-codes diff --git a/lib/js_of_ocaml/js.ml b/lib/js_of_ocaml/js.ml index ce38502bfa..9caa734de4 100644 --- a/lib/js_of_ocaml/js.ml +++ b/lib/js_of_ocaml/js.ml @@ -843,12 +843,6 @@ 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 e54130ede0..cdaf7ad8f4 100644 --- a/lib/js_of_ocaml/js.mli +++ b/lib/js_of_ocaml/js.mli @@ -889,19 +889,6 @@ 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 `--effects=double-translation`, 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. - - This behaviour is the same when double translation is disabled. *) -end - (** {2 Unsafe operations.} *) (** Unsafe Javascript operations *) diff --git a/lib/runtime/jsoo_runtime.ml b/lib/runtime/jsoo_runtime.ml index e3fb6f186e..c95a8818e5 100644 --- a/lib/runtime/jsoo_runtime.ml +++ b/lib/runtime/jsoo_runtime.ml @@ -239,3 +239,18 @@ module Int64 = struct external create_int64_lo_mi_hi : int -> int -> int -> Int64.t = "caml_int64_create_lo_mi_hi" end + +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 `--effects=double-translation`, 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. + + This behaviour is the same when double translation is disabled. *) +end = struct + external assume_no_perform : (unit -> 'a) -> 'a = "caml_assume_no_perform" +end diff --git a/manual/effects.wiki b/manual/effects.wiki index cffef5b334..651838c7b5 100644 --- a/manual/effects.wiki +++ b/manual/effects.wiki @@ -11,7 +11,7 @@ The analysis is especially effective on monomorphic code. It is not so effective We hope to improve on this by trying alternative compilation strategies. -The {{double-translation}} option does a similar CPS transform, but also keeps a direct-style version of the transformed functions. The choice of running the CPS version is delayed to run time. Since CPS code is usually slower, this can avoid degradations. In addition, one can ensure that some code is run in direct style by using {{Js_of_ocaml.Js.assume_no_perform}}. +The {{double-translation}} option does a similar CPS transform, but also keeps a direct-style version of the transformed functions. The choice of running the CPS version is delayed to run time. Since CPS code is usually slower, this can avoid degradations. In addition, one can ensure that some code is run in direct style by using {{Jsoo_runtime.Effect.assume_no_perform}}. === Dune integration === From 31be126be36f88f306611360fa099010e6282a47 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 12 Dec 2024 18:16:33 +0100 Subject: [PATCH 54/80] Fix: move C primitive --- lib/js_of_ocaml/js_of_ocaml_stubs.c | 4 ---- lib/runtime/js_of_ocaml_runtime_stubs.c | 4 ++++ 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/js_of_ocaml/js_of_ocaml_stubs.c b/lib/js_of_ocaml/js_of_ocaml_stubs.c index 8481e80555..0ddf5aee81 100644 --- a/lib/js_of_ocaml/js_of_ocaml_stubs.c +++ b/lib/js_of_ocaml/js_of_ocaml_stubs.c @@ -1,9 +1,5 @@ #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!"); } diff --git a/lib/runtime/js_of_ocaml_runtime_stubs.c b/lib/runtime/js_of_ocaml_runtime_stubs.c index 69f6b31c94..559cc91fd1 100644 --- a/lib/runtime/js_of_ocaml_runtime_stubs.c +++ b/lib/runtime/js_of_ocaml_runtime_stubs.c @@ -16,6 +16,10 @@ void bigstring_to_typed_array () { caml_fatal_error("Unimplemented Javascript primitive bigstring_to_typed_array!"); } +void caml_assume_no_perform () { + caml_fatal_error("Unimplemented Javascript primitive caml_assume_no_perform!"); +} + void caml_ba_from_typed_array () { caml_fatal_error("Unimplemented Javascript primitive caml_ba_from_typed_array!"); } From 26a2b6d8c60b27bff85617327db5a31f3ad241af Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 13 Dec 2024 14:51:16 +0100 Subject: [PATCH 55/80] CR --- compiler/lib/effects.ml | 121 ++++++++++++++++++++-------------------- 1 file changed, 60 insertions(+), 61 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 82b068e967..c411d51441 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -307,9 +307,8 @@ type st = } let add_block st block = - let blocks = st.new_blocks in let free_pc = st.free_pc in - st.new_blocks <- Addr.Map.add free_pc block blocks; + st.new_blocks <- Addr.Map.add free_pc block st.new_blocks; st.free_pc <- free_pc + 1; free_pc @@ -379,36 +378,6 @@ let cps_jump_cont ~st ~src ((pc, _) as cont) = in call_block, [] -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 - 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 src_pc x direct_cont = debug_print "@[allocate_continuation ~src_pc:%d ~cont:(%d,@ _)@,@]" @@ -604,12 +573,46 @@ let cps_instr ~st (instr : instr) : instr list = ] | _ -> [ rewrite_instr ~st instr ] +let call_exact flow_info (f : Var.t) nargs : bool = + (* If [f] is unknown to the global flow analysis, then it was introduced by + the lambda lifting and we don't have exactness about it. *) + Var.idx f < Var.Tbl.length flow_info.Global_flow.info_approximation + && Global_flow.exact_call flow_info f nargs + let cps_block ~st ~k ~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 orig_pc st.jc.closures_of_alloc_site with - | to_allocate -> do_alloc_jump_closures ~st to_allocate + | 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 cps_jump_pc = mk_cps_pc_of_direct ~st jump_pc in + Let (cname, Closure (params, (cps_jump_pc, [])))) | exception Not_found -> [] in @@ -627,11 +630,7 @@ let cps_block ~st ~k ~orig_pc block = | Apply { f; args; exact } when Var.Set.mem x st.cps_needed -> Some (fun ~k -> - let exact = - exact - || Var.idx f < Var.Tbl.length st.flow_info.info_approximation - && Global_flow.exact_call st.flow_info f (List.length args) - in + let exact = exact || call_exact 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 ]) -> Some @@ -640,7 +639,7 @@ let cps_block ~st ~k ~orig_pc block = tail_call ~st ~instrs:[ Let (k', Prim (Extern "caml_resume_stack", [ Pv stack; Pv k ])) ] - ~exact:(Global_flow.exact_call st.flow_info f 1) + ~exact:(call_exact st.flow_info f 1) ~in_cps:true ~check:true ~f @@ -729,7 +728,7 @@ let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc block = (* 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 exact = call_exact st.flow_info f 1 in [ Let (unit, Constant unit_val); Let (x, Apply { exact; f; args = [ unit ] }) ] | (Let _ | Assign _ | Set_field _ | Offset_ref _ | Array_set _ | Event _) as instr -> [ instr ] @@ -902,28 +901,27 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = block , None ) in - 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 = st.new_blocks in - st.new_blocks <- Addr.Map.add cps_pc b new_blocks; - Addr.Map.add cps_pc b blocks) - start - st.blocks - st.blocks - in - (* If double-translating, all variables bound in the CPS version will have to be + 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 + st.new_blocks <- Addr.Map.add cps_pc b st.new_blocks; + Addr.Map.add cps_pc b blocks) + start + st.blocks + st.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 new_blocks = if function_needs_cps && double_translate () - then + then ( Code.traverse Code.{ fold = fold_children } (fun pc () -> @@ -934,9 +932,10 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = initial_start p.blocks (); - let new_blocks = subst_bound_in_blocks st.new_blocks cloned_subst in - Addr.Map.fold Addr.Map.add new_blocks blocks + subst_bound_in_blocks st.new_blocks cloned_subst) + else st.new_blocks in + let blocks = Addr.Map.fold Addr.Map.add new_blocks blocks in { p with blocks; free_pc = st.free_pc }) p in From f736e33362194ac59425f14542222be8e0d8d9c9 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 16 Dec 2024 11:43:25 +0100 Subject: [PATCH 56/80] CR: rephrase comment Co-authored-by: hhugo --- compiler/bin-js_of_ocaml/cmd_arg.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml index d209319291..9802e27624 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.ml +++ b/compiler/bin-js_of_ocaml/cmd_arg.ml @@ -257,7 +257,7 @@ let options = let effects = let doc = "Select an implementation of effect handlers. [$(docv)] should be one of $(b,cps) \ - or $(b,double-translation). Effects are not allowed by default." + or $(b,double-translation). Effects won't be supported if unspecified." in Arg.( value From 68d02dfe7f7066e2a807ce6889e6c4adeeaec9be Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 16 Dec 2024 14:38:59 +0100 Subject: [PATCH 57/80] CR: Move effects backend choice logic --- compiler/bin-js_of_ocaml/cmd_arg.ml | 18 ++++++++++++++ compiler/bin-js_of_ocaml/compile.ml | 6 ----- compiler/bin-wasm_of_ocaml/cmd_arg.ml | 34 +++++++++++++++++++++++++-- compiler/bin-wasm_of_ocaml/compile.ml | 6 ----- 4 files changed, 50 insertions(+), 14 deletions(-) diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml index 9802e27624..4d5914eb7a 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.ml +++ b/compiler/bin-js_of_ocaml/cmd_arg.ml @@ -332,6 +332,15 @@ let options = let params : (string * string) list = List.flatten set_param in let static_env : (string * string) list = List.flatten set_env in let include_dirs = normalize_include_dirs include_dirs in + (* For backward compatibility, consider that [--enable effects] alone means + [--effects cps] *) + Config.set_effects_backend + (match effects with + | None -> + if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable + then Some Cps + else None + | Some _ -> effects); `Ok { common ; params @@ -573,6 +582,15 @@ let options_runtime_only = let params : (string * string) list = List.flatten set_param in let static_env : (string * string) list = List.flatten set_env in let include_dirs = normalize_include_dirs include_dirs in + (* For backward compatibility, consider that [--enable effects] alone means + [--effects cps] *) + Config.set_effects_backend + (match effects with + | None -> + if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable + then Some Cps + else None + | Some _ -> effects); `Ok { common ; params diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index f525ac2062..7f68988092 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -173,12 +173,6 @@ let run | `Name _, _ -> ()); List.iter params ~f:(fun (s, v) -> Config.Param.set s v); List.iter static_env ~f:(fun (s, v) -> Eval.set_static_env s v); - (* For backward compatibility, consider that [--enable effects] alone means - [--effects cps] *) - Config.set_effects_backend - (match effects with - | None -> if Config.Flag.effects () then Some Cps else None - | Some _ -> effects); let t = Timer.make () in let include_dirs = List.filter_map (include_dirs @ [ "+stdlib/" ]) ~f:(fun d -> Findlib.find [] d) diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.ml b/compiler/bin-wasm_of_ocaml/cmd_arg.ml index 4c04214db3..da6e661bd8 100644 --- a/compiler/bin-wasm_of_ocaml/cmd_arg.ml +++ b/compiler/bin-wasm_of_ocaml/cmd_arg.ml @@ -145,6 +145,15 @@ let options = let params : (string * string) list = List.flatten set_param in let enable_source_maps = (not no_sourcemap) && sourcemap in let include_dirs = normalize_include_dirs include_dirs in + (* For backward compatibility, consider that [--enable effects] alone means [--effects cps] *) + Config.set_effects_backend + (match effects with + | None -> + if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable + then Some Config.Cps + else None + | Some Config.Cps -> Some Config.Cps + | Some _ -> failwith "Unexpected effects backend"); `Ok { common ; params @@ -218,6 +227,16 @@ let options_runtime_only = & opt_all (list (pair ~sep:'=' (enum all) string)) [] & info [ "set" ] ~docv:"PARAM=VALUE" ~doc) in + let effects = + let doc = + "Select an implementation of effect handlers. [$(docv)] should be one of $(b,jspi) \ + (the default) or $(b,cps)." + in + Arg.( + value + & opt (enum [ "jspi", None; "cps", Some Config.Cps ]) None + & info [ "effects" ] ~docv:"KIND" ~doc) + in let build_t common set_param @@ -227,10 +246,20 @@ let options_runtime_only = sourcemap_don't_inline_content sourcemap_root output_file - runtime_files = + runtime_files + effects = let params : (string * string) list = List.flatten set_param in let enable_source_maps = (not no_sourcemap) && sourcemap in let include_dirs = normalize_include_dirs include_dirs in + (* For backward compatibility, consider that [--enable effects] alone means [--effects cps] *) + Config.set_effects_backend + (match effects with + | None -> + if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable + then Some Config.Cps + else None + | Some Config.Cps -> Some Config.Cps + | Some _ -> failwith "Unexpected effects backend"); `Ok { common ; params @@ -257,6 +286,7 @@ let options_runtime_only = $ sourcemap_don't_inline_content $ sourcemap_root $ output_file - $ runtime_files) + $ runtime_files + $ effects) in Term.ret t diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index bfa5d98e73..96d66884e9 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -272,13 +272,7 @@ let run ; effects } = Config.set_target `Wasm; - (* For backward compatibility, consider that [--enable effects] alone means [--effects cps] *) Jsoo_cmdline.Arg.eval common; - Config.set_effects_backend - (match effects with - | None -> if Config.Flag.effects () then Some Cps else None - | Some Cps -> Some Cps - | Some _ -> failwith "Unexpected effects backend"); Generate.init (); let output_file = fst output_file in if debug_mem () then Debug.start_profiling output_file; From 35b27b00ef7e88600db72420ff9330386bb59d55 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 16 Dec 2024 14:40:07 +0100 Subject: [PATCH 58/80] CR: simplify --- compiler/lib/effects.ml | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index c411d51441..10d7dc2910 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -558,27 +558,23 @@ let rewrite_instr ~st (instr : instr) : instr = assert false | _ -> instr +let call_exact flow_info (f : Var.t) nargs : bool = + (* If [f] is unknown to the global flow analysis, then it was introduced by + the lambda lifting and we don't have exactness about it. *) + Var.idx f < Var.Tbl.length flow_info.Global_flow.info_approximation + && Global_flow.exact_call flow_info f nargs + let cps_instr ~st (instr : instr) : instr list = match instr with | Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) when double_translate () -> (* When double translation is enabled, we just call [f] in direct style. Otherwise, the runtime primitive is used. *) let unit = Var.fresh_n "unit" in - let exact = - Var.idx f < Var.Tbl.length st.flow_info.info_approximation - && Global_flow.exact_call st.flow_info f 1 - in [ Let (unit, Constant (Int Targetint.zero)) - ; Let (x, Apply { exact; f; args = [ unit ] }) + ; Let (x, Apply { exact = call_exact st.flow_info f 1; f; args = [ unit ] }) ] | _ -> [ rewrite_instr ~st instr ] -let call_exact flow_info (f : Var.t) nargs : bool = - (* If [f] is unknown to the global flow analysis, then it was introduced by - the lambda lifting and we don't have exactness about it. *) - Var.idx f < Var.Tbl.length flow_info.Global_flow.info_approximation - && Global_flow.exact_call flow_info f nargs - let cps_block ~st ~k ~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); From 12adc936c328f04cff8b4ed9612b1a57c8df9b06 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 16 Dec 2024 14:46:21 +0100 Subject: [PATCH 59/80] Docs: document double translation better Only document the use of `--enable effects` for now, as only this option is correctly handled by Dune, and document possible caching issues with `--effects=double-translation`. --- manual/effects.wiki | 6 +++--- manual/overview.wiki | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/manual/effects.wiki b/manual/effects.wiki index 651838c7b5..5317eaad24 100644 --- a/manual/effects.wiki +++ b/manual/effects.wiki @@ -1,7 +1,7 @@ == Effect handlers == -Js_of_ocaml supports effect handlers with the {{{--effects={cps,double-translation}}}} -flag. The {{cps}} option is based on partially transforming the program to +Js_of_ocaml supports effect handlers with the {{{--enable=effects}}} +flag. This is based on partially transforming the program to continuation-passing style. As a consequence, [[tailcall|tail calls]] are also fully optimized. This is not the default for now since the generated code can be slower, @@ -11,7 +11,7 @@ The analysis is especially effective on monomorphic code. It is not so effective We hope to improve on this by trying alternative compilation strategies. -The {{double-translation}} option does a similar CPS transform, but also keeps a direct-style version of the transformed functions. The choice of running the CPS version is delayed to run time. Since CPS code is usually slower, this can avoid degradations. In addition, one can ensure that some code is run in direct style by using {{Jsoo_runtime.Effect.assume_no_perform}}. +An alternative CPS transform is provided under the {{--effects=double-translation}} option. It keeps a direct-style version of the transformed functions in addition to the CPS version. The choice of running the CPS version is delayed to run time. Since CPS code is usually slower, this can avoid degradations. In addition, one can ensure that some code is run in direct style by using {{Jsoo_runtime.Effect.assume_no_perform}}. A caveat is that Dune does not know about {{--effects=double-translation}} yet and may try to link together files built with {{--enable=double-translation}} and files built with only {{--enable=effects}}, which gives an error. As long as this is not fixed, running {{dune clean}} should help. === Dune integration === diff --git a/manual/overview.wiki b/manual/overview.wiki index bfc8eee899..6dce5ca01f 100644 --- a/manual/overview.wiki +++ b/manual/overview.wiki @@ -85,7 +85,7 @@ functions are optimized: <>. Effect handlers are fully supported with the -{{{--effects={cps,double-translation}}}} flag. Effect support is disabled by +{{{--enable=effects}}} flag. Effect support is disabled by default for now since effects are not widely used at the moment and the generated code can be slower, larger and less readable. See the dedicated manual section about effects for details. From b778d4735bd95012afc1d518335230050d9cd614 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 16 Dec 2024 15:00:37 +0100 Subject: [PATCH 60/80] Fix warning --- compiler/bin-wasm_of_ocaml/compile.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index 96d66884e9..002a3d305d 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -269,7 +269,7 @@ let run ; include_dirs ; sourcemap_root ; sourcemap_don't_inline_content - ; effects + ; effects = _ } = Config.set_target `Wasm; Jsoo_cmdline.Arg.eval common; From 191086669c0276e4ca3c3d3d338e3f7c4a10d56d Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 16 Dec 2024 15:10:25 +0100 Subject: [PATCH 61/80] Fix another warning --- compiler/bin-js_of_ocaml/compile.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index 7f68988092..504e357f45 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -153,7 +153,7 @@ let run ; export_file ; keep_unit_names ; include_runtime - ; effects + ; effects = _ } = let source_map_base = Option.map ~f:snd source_map in let source_map = From 65365330d4d6fce6c5c56e9de6eb79305c2d4647 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 16 Dec 2024 18:11:08 +0100 Subject: [PATCH 62/80] Update manual/effects.wiki MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Jérôme Vouillon --- manual/effects.wiki | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/manual/effects.wiki b/manual/effects.wiki index 5317eaad24..f84b9e6c44 100644 --- a/manual/effects.wiki +++ b/manual/effects.wiki @@ -11,7 +11,7 @@ The analysis is especially effective on monomorphic code. It is not so effective We hope to improve on this by trying alternative compilation strategies. -An alternative CPS transform is provided under the {{--effects=double-translation}} option. It keeps a direct-style version of the transformed functions in addition to the CPS version. The choice of running the CPS version is delayed to run time. Since CPS code is usually slower, this can avoid degradations. In addition, one can ensure that some code is run in direct style by using {{Jsoo_runtime.Effect.assume_no_perform}}. A caveat is that Dune does not know about {{--effects=double-translation}} yet and may try to link together files built with {{--enable=double-translation}} and files built with only {{--enable=effects}}, which gives an error. As long as this is not fixed, running {{dune clean}} should help. +An alternative CPS transform is provided under the {{--effects=double-translation}} option. It keeps a direct-style version of the transformed functions in addition to the CPS version. The choice of running the CPS version is delayed to run time. Since CPS code is usually slower, this can avoid degradations. In addition, one can ensure that some code is run in direct style by using {{Jsoo_runtime.Effect.assume_no_perform}}. A caveat is that Dune does not know about {{--effects=double-translation}} yet and may try to link together files built with {{--enable=double-translation}} and files built with only {{--enable=effects}}, which gives an error. A work-around is to disable separate compilation by using the option {{(js_of_ocaml (compilation_mode whole_program))}}. === Dune integration === From cfdca94b71b2e6fd199da05efde3e4e391e2f578 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 16 Dec 2024 18:13:01 +0100 Subject: [PATCH 63/80] CR: revert some changes in docs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Jérôme Vouillon --- manual/effects.wiki | 4 ++-- manual/tailcall.wiki | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/manual/effects.wiki b/manual/effects.wiki index f84b9e6c44..cffe51c226 100644 --- a/manual/effects.wiki +++ b/manual/effects.wiki @@ -27,7 +27,7 @@ Put the following in a {{{dune}}} (or {{{dune-workspace}}}) file at the root of (env (_ (js_of_ocaml - (flags (:standard --effects=cps)) + (flags (:standard --enable effects)) (build_runtime_flags (:standard --enable effects))))) }}} @@ -52,7 +52,7 @@ Then pass the rights {{{js_of_ocaml}}} flags to the executable stanza {{{ (executable (name main) - (js_of_ocaml (flags (:standard --effects=cps))) + (js_of_ocaml (flags (:standard --enable effects))) ) }}} diff --git a/manual/tailcall.wiki b/manual/tailcall.wiki index f8aefe94b2..4ef3d687da 100644 --- a/manual/tailcall.wiki +++ b/manual/tailcall.wiki @@ -3,7 +3,7 @@ JavaScript does not (yet) support tail call optimization. To circumvent this limitation, and mitigate stack overflows, the Js_of_ocaml compiler optimizes some common tail call patterns. Besides, all tail calls are optimized when you set the flag -{{{--effects=cps}}}, at the cost of some performance degradation. +{{{--enable=effects}}}, at the cost of some performance degradation. === Self tail recursive Self tail recursive function are compiled into a loop. From f914e2225ba5335ea3b61624e6a7f0c6ae2ebb32 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Tue, 17 Dec 2024 11:52:40 +0100 Subject: [PATCH 64/80] Don't set effects_backend in _cmd_arg_ modules --- compiler/bin-js_of_ocaml/cmd_arg.ml | 30 ++++++++++-------------- compiler/bin-js_of_ocaml/compile.ml | 3 ++- compiler/bin-wasm_of_ocaml/cmd_arg.ml | 33 ++++++++++++--------------- compiler/bin-wasm_of_ocaml/compile.ml | 3 ++- 4 files changed, 30 insertions(+), 39 deletions(-) diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml index 4d5914eb7a..149c81f385 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.ml +++ b/compiler/bin-js_of_ocaml/cmd_arg.ml @@ -39,6 +39,16 @@ let trim_trailing_dir_sep s = let normalize_include_dirs dirs = List.map dirs ~f:trim_trailing_dir_sep +let normalize_effects effects common = + (* For backward compatibility, consider that [--enable effects] alone means + [--effects cps] *) + match effects with + | None -> + if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable + then Some Cps + else None + | Some _ -> effects + type t = { common : Jsoo_cmdline.Arg.t ; (* compile option *) @@ -332,15 +342,7 @@ let options = let params : (string * string) list = List.flatten set_param in let static_env : (string * string) list = List.flatten set_env in let include_dirs = normalize_include_dirs include_dirs in - (* For backward compatibility, consider that [--enable effects] alone means - [--effects cps] *) - Config.set_effects_backend - (match effects with - | None -> - if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable - then Some Cps - else None - | Some _ -> effects); + let effects = normalize_effects effects common in `Ok { common ; params @@ -582,15 +584,7 @@ let options_runtime_only = let params : (string * string) list = List.flatten set_param in let static_env : (string * string) list = List.flatten set_env in let include_dirs = normalize_include_dirs include_dirs in - (* For backward compatibility, consider that [--enable effects] alone means - [--effects cps] *) - Config.set_effects_backend - (match effects with - | None -> - if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable - then Some Cps - else None - | Some _ -> effects); + let effects = normalize_effects effects common in `Ok { common ; params diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index 504e357f45..5e96635cd2 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -153,7 +153,7 @@ let run ; export_file ; keep_unit_names ; include_runtime - ; effects = _ + ; effects } = let source_map_base = Option.map ~f:snd source_map in let source_map = @@ -166,6 +166,7 @@ let run let custom_header = common.Jsoo_cmdline.Arg.custom_header in Config.set_target `JavaScript; Jsoo_cmdline.Arg.eval common; + Config.set_effects_backend effects; Linker.reset (); (match output_file with | `Stdout, _ -> () diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.ml b/compiler/bin-wasm_of_ocaml/cmd_arg.ml index da6e661bd8..48a6c164a3 100644 --- a/compiler/bin-wasm_of_ocaml/cmd_arg.ml +++ b/compiler/bin-wasm_of_ocaml/cmd_arg.ml @@ -38,6 +38,17 @@ let trim_trailing_dir_sep s = let normalize_include_dirs dirs = List.map dirs ~f:trim_trailing_dir_sep +let normalize_effects effects common = + (* For backward compatibility, consider that [--enable effects] alone means [--effects cps] *) + Config.set_effects_backend + (match effects with + | None -> + if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable + then Some Config.Cps + else None + | Some Config.Cps -> Some Config.Cps + | Some _ -> failwith "Unexpected effects backend") + type t = { common : Jsoo_cmdline.Arg.t ; (* compile option *) @@ -145,15 +156,7 @@ let options = let params : (string * string) list = List.flatten set_param in let enable_source_maps = (not no_sourcemap) && sourcemap in let include_dirs = normalize_include_dirs include_dirs in - (* For backward compatibility, consider that [--enable effects] alone means [--effects cps] *) - Config.set_effects_backend - (match effects with - | None -> - if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable - then Some Config.Cps - else None - | Some Config.Cps -> Some Config.Cps - | Some _ -> failwith "Unexpected effects backend"); + let effects = normalize_effects effects common in `Ok { common ; params @@ -251,15 +254,7 @@ let options_runtime_only = let params : (string * string) list = List.flatten set_param in let enable_source_maps = (not no_sourcemap) && sourcemap in let include_dirs = normalize_include_dirs include_dirs in - (* For backward compatibility, consider that [--enable effects] alone means [--effects cps] *) - Config.set_effects_backend - (match effects with - | None -> - if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable - then Some Config.Cps - else None - | Some Config.Cps -> Some Config.Cps - | Some _ -> failwith "Unexpected effects backend"); + let effects = normalize_effects effects common in `Ok { common ; params @@ -272,7 +267,7 @@ let options_runtime_only = ; enable_source_maps ; sourcemap_root ; sourcemap_don't_inline_content - ; effects = None + ; effects } in let t = diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index 002a3d305d..c54ca4e1fb 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -269,10 +269,11 @@ let run ; include_dirs ; sourcemap_root ; sourcemap_don't_inline_content - ; effects = _ + ; effects } = Config.set_target `Wasm; Jsoo_cmdline.Arg.eval common; + Config.set_effects_backend effects; Generate.init (); let output_file = fst output_file in if debug_mem () then Debug.start_profiling output_file; From 865f90ed008610421d0c6838b24269ba95d25f94 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 17 Dec 2024 16:33:16 +0100 Subject: [PATCH 65/80] Fix compilation --- compiler/bin-js_of_ocaml/cmd_arg.ml | 2 +- compiler/bin-wasm_of_ocaml/cmd_arg.ml | 15 +++++++-------- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml index 149c81f385..2d75b44278 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.ml +++ b/compiler/bin-js_of_ocaml/cmd_arg.ml @@ -45,7 +45,7 @@ let normalize_effects effects common = match effects with | None -> if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable - then Some Cps + then Some Config.Cps else None | Some _ -> effects diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.ml b/compiler/bin-wasm_of_ocaml/cmd_arg.ml index 48a6c164a3..f2a6eee653 100644 --- a/compiler/bin-wasm_of_ocaml/cmd_arg.ml +++ b/compiler/bin-wasm_of_ocaml/cmd_arg.ml @@ -40,14 +40,13 @@ let normalize_include_dirs dirs = List.map dirs ~f:trim_trailing_dir_sep let normalize_effects effects common = (* For backward compatibility, consider that [--enable effects] alone means [--effects cps] *) - Config.set_effects_backend - (match effects with - | None -> - if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable - then Some Config.Cps - else None - | Some Config.Cps -> Some Config.Cps - | Some _ -> failwith "Unexpected effects backend") + match effects with + | None -> + if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable + then Some Config.Cps + else None + | Some Config.Cps -> Some Config.Cps + | Some _ -> failwith "Unexpected effects backend" type t = { common : Jsoo_cmdline.Arg.t From 9c28e19661cefa21838a0e2736d088d5ea6926bc Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 17 Dec 2024 17:53:15 +0100 Subject: [PATCH 66/80] CR --- CHANGES.md | 2 +- compiler/lib-wasm/generate.ml | 12 +++--- compiler/lib/config.mli | 1 - compiler/lib/driver.ml | 39 +++++++++---------- compiler/lib/inline.ml | 6 +-- compiler/lib/js_output.ml | 6 ++- compiler/lib/unit_info.ml | 4 +- compiler/tests-compiler/direct_calls.ml | 2 +- .../double-translation/direct_calls.ml | 3 +- .../effects_continuations.ml | 3 +- .../double-translation/effects_exceptions.ml | 3 +- .../double-translation/effects_toplevel.ml | 3 +- compiler/tests-compiler/effects.ml | 2 +- .../tests-compiler/effects_continuations.ml | 2 +- compiler/tests-compiler/effects_exceptions.ml | 2 +- compiler/tests-compiler/effects_toplevel.ml | 2 +- compiler/tests-compiler/es6.ml | 8 ++-- compiler/tests-compiler/lambda_lifting.ml | 6 ++- compiler/tests-compiler/util/util.ml | 33 ++++------------ compiler/tests-compiler/util/util.mli | 12 +++--- .../lib-effects/double-translation/dune | 15 +++---- 21 files changed, 73 insertions(+), 93 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 2f3fe8ba7d..d4d59a036f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -6,6 +6,7 @@ * Merged Wasm_of_ocaml (#1724) * Lib: removed no longer relevant Js.optdef type annotations (#1769) * Misc: drop support for IE +* 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 * Fix small bug in global data flow analysis (#1768) @@ -48,7 +49,6 @@ * Toplevel: no longer set globals for toplevel initialization * Runtime: precompute constants used in `caml_lxm_next` (#1730) * Runtime: cleanup runtime -* 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-wasm/generate.ml b/compiler/lib-wasm/generate.ml index 078fcc442e..b7b3613f72 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -21,7 +21,7 @@ open Code module W = Wasm_ast open Code_generation -let effects () = Option.is_some (Config.effects ()) +let effects_cps () = Option.is_some (Config.effects ()) module Generate (Target : Target_sig.S) = struct open Target @@ -239,9 +239,9 @@ module Generate (Target : Target_sig.S) = struct | Constant c -> Constant.translate c | Special (Alias_prim _) -> assert false | Prim (Extern "caml_alloc_dummy_function", [ _; Pc (Int arity) ]) -> - Closure.dummy ~cps:(effects ()) ~arity:(Targetint.to_int_exn arity) + Closure.dummy ~cps:(effects_cps ()) ~arity:(Targetint.to_int_exn arity) | Prim (Extern "caml_alloc_dummy_infix", _) -> - Closure.dummy ~cps:(effects ()) ~arity:1 + Closure.dummy ~cps:(effects_cps ()) ~arity:1 | Prim (Extern "caml_get_global", [ Pc (String name) ]) -> let* x = let* context = get_context in @@ -1178,7 +1178,9 @@ let init () = ] in Primitive.register "caml_array_of_uniform_array" `Mutable None None; - let l = if effects () then ("caml_alloc_stack", "caml_cps_alloc_stack") :: l else l in + let l = + if effects_cps () then ("caml_alloc_stack", "caml_cps_alloc_stack") :: l else l + in List.iter ~f:(fun (nm, nm') -> Primitive.alias nm nm') l (* Make sure we can use [br_table] for switches *) @@ -1220,7 +1222,7 @@ let fix_switch_branches p = let start () = make_context ~value_type:Gc_target.Value.value let f ~context ~unit_name p ~live_vars ~in_cps ~deadcode_sentinal ~debug = - let p = if effects () then fix_switch_branches p else p in + let p = if effects_cps () then fix_switch_branches p else p in let module G = Generate (Gc_target) in G.f ~context ~unit_name ~live_vars ~in_cps ~deadcode_sentinal ~debug p diff --git a/compiler/lib/config.mli b/compiler/lib/config.mli index cf57230823..81df2c6ebd 100644 --- a/compiler/lib/config.mli +++ b/compiler/lib/config.mli @@ -40,7 +40,6 @@ module Flag : sig val staticeval : unit -> bool - (* Deprecated in favor of toplevel function [effects] below *) val effects : unit -> bool val genprim : unit -> bool diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 4887ce3a6f..82a603eaa4 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -99,7 +99,7 @@ let map_fst f (x, y, z) = f x, y, z let effects ~deadcode_sentinal p = match Config.effects () with - | Some _ -> + | Some (_ as effects) -> if debug () then Format.eprintf "Effects...@."; let p, live_vars = Deadcode.f p in let p = Effects.remove_empty_blocks ~live_vars p in @@ -115,31 +115,30 @@ let effects ~deadcode_sentinal p = p |> Effects.f ~flow_info:info ~live_vars |> map_fst - (match Config.effects () with - | Some Double_translation -> Fun.id - | Some Cps -> Lambda_lifting.f - | None -> assert false) + (match effects with + | Double_translation -> Fun.id + | Cps -> Lambda_lifting.f) | None -> ( p , (Code.Var.Set.empty : Effects.trampolined_calls) , (Code.Var.Set.empty : Effects.in_cps) ) let exact_calls profile ~deadcode_sentinal p = - if Option.is_none (Config.effects ()) - then - let fast = - match profile with - | O3 -> false - | O1 | O2 -> true - in - let info = Global_flow.f ~fast p in - let p = - if Config.Flag.globaldeadcode () && Config.Flag.deadcode () - then Global_deadcode.f p ~deadcode_sentinal info - else p - in - Specialize.f ~function_arity:(fun f -> Global_flow.function_arity info f) p - else p + match Config.effects () with + | None -> + let fast = + match profile with + | O3 -> false + | O1 | O2 -> true + in + let info = Global_flow.f ~fast p in + let p = + if Config.Flag.globaldeadcode () && Config.Flag.deadcode () + then Global_deadcode.f p ~deadcode_sentinal info + else p + in + Specialize.f ~function_arity:(fun f -> Global_flow.function_arity info f) p + | Some _ -> p let print p = if debug () then Code.Print.program (fun _ _ -> "") p; diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index 695f2d0953..abe6154aea 100644 --- a/compiler/lib/inline.ml +++ b/compiler/lib/inline.ml @@ -330,9 +330,9 @@ let times = Debug.find "times" let f p live_vars = let first_class_primitives = - match Config.target () with - | `JavaScript -> Option.is_none (Config.effects ()) - | `Wasm -> false + match Config.target (), Config.effects () with + | `JavaScript, None -> true + | `JavaScript, Some _ | `Wasm, _ -> false in Code.invariant p; let t = Timer.make () in diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml index c6a879536a..bebd7493fc 100644 --- a/compiler/lib/js_output.ml +++ b/compiler/lib/js_output.ml @@ -2099,8 +2099,10 @@ let program ?(accept_unnamed_var = false) ?(source_map = false) f p = let accept_unnamed_var = accept_unnamed_var end) in PP.set_needed_space_function f need_space; - if Option.is_some (Config.effects ()) - then PP.set_adjust_indentation_function f (fun n -> n mod 40); + (match Config.effects () with + | Some Cps | Some Double_translation -> + PP.set_adjust_indentation_function f (fun n -> n mod 40) + | None -> ()); PP.start_group f 0; O.program f p; PP.end_group f; diff --git a/compiler/lib/unit_info.ml b/compiler/lib/unit_info.ml index 7c87ac4a88..69839b9d5e 100644 --- a/compiler/lib/unit_info.ml +++ b/compiler/lib/unit_info.ml @@ -53,7 +53,9 @@ let of_cmo (cmo : Cmo_format.compilation_unit) = let requires = StringSet.of_list (Cmo_format.requires cmo) in let requires = StringSet.diff requires provides in let effects_without_cps = - Option.is_none (Config.effects ()) + (match Config.effects () with + | None -> true + | Some (Cps | Double_translation) -> false) && List.exists (Cmo_format.primitives cmo) ~f:(function | "%resume" | "%reperform" | "%perform" -> true | _ -> false) diff --git a/compiler/tests-compiler/direct_calls.ml b/compiler/tests-compiler/direct_calls.ml index d0e55b9da1..8de15dd959 100644 --- a/compiler/tests-compiler/direct_calls.ml +++ b/compiler/tests-compiler/direct_calls.ml @@ -102,7 +102,7 @@ let%expect_test "direct calls without --effects=cps" = let%expect_test "direct calls with --effects=cps" = let code = compile_and_parse - ~effects:true + ~effects:Js_of_ocaml_compiler.Config.Cps {| (* Arity of the argument of a function / direct call *) let test1 () = diff --git a/compiler/tests-compiler/double-translation/direct_calls.ml b/compiler/tests-compiler/double-translation/direct_calls.ml index efb648a634..c1e03a8582 100644 --- a/compiler/tests-compiler/double-translation/direct_calls.ml +++ b/compiler/tests-compiler/double-translation/direct_calls.ml @@ -21,8 +21,7 @@ open Util let%expect_test "direct calls with --effects=double-translation" = let code = compile_and_parse - ~effects:true - ~doubletranslate:true + ~effects:Js_of_ocaml_compiler.Config.Double_translation {| (* Arity of the argument of a function / direct call *) let test1 () = diff --git a/compiler/tests-compiler/double-translation/effects_continuations.ml b/compiler/tests-compiler/double-translation/effects_continuations.ml index 6fcaa8eb25..8c0a12959d 100644 --- a/compiler/tests-compiler/double-translation/effects_continuations.ml +++ b/compiler/tests-compiler/double-translation/effects_continuations.ml @@ -22,8 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let code = compile_and_parse - ~effects:true - ~doubletranslate:true + ~effects:Js_of_ocaml_compiler.Config.Double_translation {| let list_rev = List.rev (* Avoid to expose the offset of stdlib modules *) diff --git a/compiler/tests-compiler/double-translation/effects_exceptions.ml b/compiler/tests-compiler/double-translation/effects_exceptions.ml index 9a920e14e2..cc2b1038be 100644 --- a/compiler/tests-compiler/double-translation/effects_exceptions.ml +++ b/compiler/tests-compiler/double-translation/effects_exceptions.ml @@ -22,8 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let code = compile_and_parse - ~effects:true - ~doubletranslate:true + ~effects:Js_of_ocaml_compiler.Config.Double_translation {| let exceptions s = (* Compiled using 'try ... catch', diff --git a/compiler/tests-compiler/double-translation/effects_toplevel.ml b/compiler/tests-compiler/double-translation/effects_toplevel.ml index 0eb8ef9f3e..6550860648 100644 --- a/compiler/tests-compiler/double-translation/effects_toplevel.ml +++ b/compiler/tests-compiler/double-translation/effects_toplevel.ml @@ -22,8 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let code = compile_and_parse - ~effects:true - ~doubletranslate:true + ~effects:Js_of_ocaml_compiler.Config.Double_translation {| (* Function calls at toplevel outside of loops do not use [caml_callback] when double translation is enabled. *) diff --git a/compiler/tests-compiler/effects.ml b/compiler/tests-compiler/effects.ml index dda41570cc..1afd07d5f1 100644 --- a/compiler/tests-compiler/effects.ml +++ b/compiler/tests-compiler/effects.ml @@ -22,7 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let program = compile_and_parse - ~effects:true + ~effects:Js_of_ocaml_compiler.Config.Cps {| open Effect diff --git a/compiler/tests-compiler/effects_continuations.ml b/compiler/tests-compiler/effects_continuations.ml index 8111c81fa9..cee457e23f 100644 --- a/compiler/tests-compiler/effects_continuations.ml +++ b/compiler/tests-compiler/effects_continuations.ml @@ -22,7 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let code = compile_and_parse - ~effects:true + ~effects:Js_of_ocaml_compiler.Config.Cps {| let list_rev = List.rev diff --git a/compiler/tests-compiler/effects_exceptions.ml b/compiler/tests-compiler/effects_exceptions.ml index 317384515d..5637ab11d1 100644 --- a/compiler/tests-compiler/effects_exceptions.ml +++ b/compiler/tests-compiler/effects_exceptions.ml @@ -22,7 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let code = compile_and_parse - ~effects:true + ~effects:Js_of_ocaml_compiler.Config.Cps {| let exceptions s = (* Compiled using 'try ... catch', diff --git a/compiler/tests-compiler/effects_toplevel.ml b/compiler/tests-compiler/effects_toplevel.ml index 255c7a40ad..4153f03b2f 100644 --- a/compiler/tests-compiler/effects_toplevel.ml +++ b/compiler/tests-compiler/effects_toplevel.ml @@ -22,7 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let code = compile_and_parse - ~effects:true + ~effects:Js_of_ocaml_compiler.Config.Cps {| (* Function calls at toplevel outside of loops use [caml_callback]. *) diff --git a/compiler/tests-compiler/es6.ml b/compiler/tests-compiler/es6.ml index 464a1d7d37..5f3f65dcef 100644 --- a/compiler/tests-compiler/es6.ml +++ b/compiler/tests-compiler/es6.ml @@ -10,7 +10,7 @@ let f x = |} in let flags = [ "--enable"; "es6" ] in - let program = Util.compile_and_parse ~effects:false ~pretty:true ~flags prog in + let program = Util.compile_and_parse ?effects:None ~pretty:true ~flags prog in Util.print_program program; [%expect {| @@ -24,7 +24,7 @@ let f x = return;}) (globalThis); //end |}]; - let program = Util.compile_and_parse ~effects:false ~pretty:false ~flags prog in + let program = Util.compile_and_parse ?effects:None ~pretty:false ~flags prog in Util.print_program program; [%expect {| @@ -46,7 +46,7 @@ let rec odd n' = function |} in let flags = [ "--enable"; "es6" ] in - let program = Util.compile_and_parse ~effects:false ~pretty:false ~flags prog in + let program = Util.compile_and_parse ?effects:None ~pretty:false ~flags prog in Util.print_program program; [%expect {| @@ -67,7 +67,7 @@ let rec odd n' = function return;}) (globalThis); //end |}]; - let program = Util.compile_and_parse ~effects:false ~pretty:false ~flags:[] prog in + let program = Util.compile_and_parse ?effects:None ~pretty:false ~flags:[] prog in Util.print_program program; [%expect {| diff --git a/compiler/tests-compiler/lambda_lifting.ml b/compiler/tests-compiler/lambda_lifting.ml index 801af1d553..1bd37835d1 100644 --- a/compiler/tests-compiler/lambda_lifting.ml +++ b/compiler/tests-compiler/lambda_lifting.ml @@ -14,9 +14,11 @@ Printf.printf "%d\n" (f 3) let flags = [ "--no-inline"; "--set=lifting-threshold=1"; "--set=lifting-baseline=0" ] in - Util.compile_and_run ~effects:true ~flags prog; + Util.compile_and_run ~effects:Js_of_ocaml_compiler.Config.Cps ~flags prog; [%expect {|15 |}]; - let program = Util.compile_and_parse ~effects:true ~flags prog in + let program = + Util.compile_and_parse ~effects:Js_of_ocaml_compiler.Config.Cps ~flags prog + in Util.print_program program; [%expect {| diff --git a/compiler/tests-compiler/util/util.ml b/compiler/tests-compiler/util/util.ml index f04be162ec..32dbb86383 100644 --- a/compiler/tests-compiler/util/util.ml +++ b/compiler/tests-compiler/util/util.ml @@ -290,22 +290,20 @@ let extract_sourcemap file = let compile_to_javascript ?(flags = []) ?(use_js_string = false) - ?(effects = false) - ?(doubletranslate = false) + ?effects ~pretty ~sourcemap file = - assert ((not doubletranslate) || effects); let out_file = swap_extention file ~ext:"js" in let extra_args = List.flatten [ (if pretty then [ "--pretty" ] else []) ; (if sourcemap then [ "--sourcemap" ] else []) - ; (if effects && doubletranslate - then [ "--effects=double-translation" ] - else if effects - then [ "--effects=cps" ] - else []) + ; (match effects with + | Some Js_of_ocaml_compiler.Config.Double_translation -> + [ "--effects=double-translation" ] + | Some Cps -> [ "--effects=cps" ] + | None -> []) ; (if use_js_string then [ "--enable=use-js-string" ] else [ "--disable=use-js-string" ]) @@ -358,7 +356,6 @@ let compile_bc_to_javascript let compile_cmo_to_javascript ?(flags = []) ?effects - ?doubletranslate ?use_js_string ?(pretty = true) ?(sourcemap = true) @@ -366,7 +363,6 @@ let compile_cmo_to_javascript Filetype.path_of_cmo_file file |> compile_to_javascript ?effects - ?doubletranslate ?use_js_string ~flags:([ "--disable"; "header" ] @ flags) ~pretty @@ -632,26 +628,13 @@ 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 - ?doubletranslate - ?use_js_string - s = +let compile_and_parse ?(debug = true) ?pretty ?flags ?effects ?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 - ?doubletranslate - ?use_js_string - ~sourcemap:debug + |> compile_cmo_to_javascript ?pretty ?flags ?effects ?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 bac2017770..b44b79e919 100644 --- a/compiler/tests-compiler/util/util.mli +++ b/compiler/tests-compiler/util/util.mli @@ -34,8 +34,7 @@ val compile_lib : Filetype.cmo_file list -> string -> Filetype.cmo_file val compile_cmo_to_javascript : ?flags:string list - -> ?effects:bool - -> ?doubletranslate:bool + -> ?effects:Config.effects_backend -> ?use_js_string:bool -> ?pretty:bool -> ?sourcemap:bool @@ -44,7 +43,7 @@ val compile_cmo_to_javascript : val compile_bc_to_javascript : ?flags:string list - -> ?effects:bool + -> ?effects:Config.effects_backend -> ?use_js_string:bool -> ?pretty:bool -> ?sourcemap:bool @@ -84,7 +83,7 @@ val compile_and_run : -> ?pretty:bool -> ?skip_modern:bool -> ?flags:string list - -> ?effects:bool + -> ?effects:Config.effects_backend -> ?use_js_string:bool -> ?unix:bool -> string @@ -96,8 +95,7 @@ val compile_and_parse : ?debug:bool -> ?pretty:bool -> ?flags:string list - -> ?effects:bool - -> ?doubletranslate:bool + -> ?effects:Config.effects_backend -> ?use_js_string:bool -> string -> Javascript.program @@ -106,7 +104,7 @@ val compile_and_parse_whole_program : ?debug:bool -> ?pretty:bool -> ?flags:string list - -> ?effects:bool + -> ?effects:Config.effects_backend -> ?use_js_string:bool -> ?unix:bool -> string diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index 259b66c4d4..bee2d8ac89 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -7,11 +7,9 @@ (:standard --effects=double-translation)) (build_runtime_flags (:standard --effects=double-translation)) - ;; 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 as is doesn't know about - ;; '--effects=double-translation'. + ;; separate compilation doesn't yet work when using + ;; '--effect=double-translation' since Dune doesn't know it should compile a + ;; different version of the dependencies. (compilation_mode whole_program))) (_ (flags @@ -21,10 +19,9 @@ (:standard --effects=double-translation)) (build_runtime_flags (:standard --effects=double-translation)) - ;; 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 + ;; separate compilation doesn't yet work when using + ;; '--effect=double-translation' since Dune doesn't know it should compile a + ;; different version of the dependencies. (compilation_mode whole_program)))) (copy_files ../*.expected) From b025490efdf5972c94307711b349fca8365d8f5a Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 17 Dec 2024 18:10:43 +0100 Subject: [PATCH 67/80] CR: add CONFIG macro --- compiler/lib/macro.ml | 15 +++++++++++++++ runtime/js/jslib.js | 17 +---------------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/compiler/lib/macro.ml b/compiler/lib/macro.ml index 69e36b6a83..4a2502d21c 100644 --- a/compiler/lib/macro.ml +++ b/compiler/lib/macro.ml @@ -23,6 +23,11 @@ type m = | Replace | Count of int ref +let string_of_effects_backend = function + | None -> "none" + | Some Config.Cps -> "cps" + | Some Config.Double_translation -> "double-translation" + class macro_mapper ~flags = object (m) inherit Js_traverse.map as super @@ -40,6 +45,16 @@ class macro_mapper ~flags = | Count count -> incr count; super#expression x) + | "CONFIG", [ J.Arg (J.EStr (Utf8 "effects")) ] -> ( + match flags with + | Replace -> + let s = string_of_effects_backend (Config.effects ()) in + J.EStr (Utf8_string.of_string_exn s) + | Count count -> + incr count; + super#expression x) + | "CONFIG", [ J.Arg (J.EStr (Utf8 s)) ] -> + failwith ("unsupported CONFIG parameter " ^ s) | "BLOCK", J.Arg (J.ENum tag) :: (_ :: _ as args) when List.for_all args ~f:(function | J.Arg _ -> true diff --git a/runtime/js/jslib.js b/runtime/js/jslib.js index 99697013a5..495bbf1566 100644 --- a/runtime/js/jslib.js +++ b/runtime/js/jslib.js @@ -139,23 +139,8 @@ function caml_jsoo_flags_use_js_string(unit) { } //Provides: caml_jsoo_flags_effects -//If: !effects -function caml_jsoo_flags_effects(unit) { - return "none"; -} - -//Provides: caml_jsoo_flags_effects -//If: effects -//If: !doubletranslate -function caml_jsoo_flags_effects(unit) { - return "cps"; -} - -//Provides: caml_jsoo_flags_effects -//If: effects -//If: doubletranslate function caml_jsoo_flags_effects(unit) { - return "double-translation"; + return CONFIG("effects"); } //Provides: caml_wrap_exception const (mutable) From 796e97346db482df41d784b3ffe1988c89738ef4 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 19 Dec 2024 17:46:00 +0100 Subject: [PATCH 68/80] Re-export Jsoo_runtime from the js_of_ocaml library --- compiler/tests-ocaml/lib-effects/double-translation/dune | 2 +- compiler/tests-ocaml/lib-effects/dune | 2 +- lib/js_of_ocaml/dune | 3 ++- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index bee2d8ac89..9dc258c2d8 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -82,7 +82,7 @@ assume_no_perform assume_no_perform_unhandled assume_no_perform_nested_handler) - (libraries js_of_ocaml-compiler.runtime) + (libraries js_of_ocaml) (action (ignore-outputs (with-accepted-exit-codes diff --git a/compiler/tests-ocaml/lib-effects/dune b/compiler/tests-ocaml/lib-effects/dune index 7eedfc0405..9ac073c2b3 100644 --- a/compiler/tests-ocaml/lib-effects/dune +++ b/compiler/tests-ocaml/lib-effects/dune @@ -62,7 +62,7 @@ assume_no_perform assume_no_perform_unhandled assume_no_perform_nested_handler) - (libraries js_of_ocaml-compiler.runtime) + (libraries js_of_ocaml) (action (ignore-outputs (with-accepted-exit-codes diff --git a/lib/js_of_ocaml/dune b/lib/js_of_ocaml/dune index df22bcb59a..9dc2c3cfe1 100644 --- a/lib/js_of_ocaml/dune +++ b/lib/js_of_ocaml/dune @@ -1,7 +1,8 @@ (library (name js_of_ocaml) (public_name js_of_ocaml) - (libraries js_of_ocaml-compiler.runtime) + (libraries + (re_export js_of_ocaml-compiler.runtime)) (foreign_stubs (language c) (names js_of_ocaml_stubs)) From dded0e8d5040e1eb7c287143ea033bb84c5a71e1 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 19 Dec 2024 17:50:03 +0100 Subject: [PATCH 69/80] Fix spurious free var warning over CONFIG macro --- compiler/lib/linker.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml index 84a1fccbb7..28523910fb 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -135,7 +135,11 @@ module Check = struct let freename = StringSet.diff freename Reserved.keyword in let freename = StringSet.diff freename Reserved.provided in let freename = StringSet.remove Global_constant.global_object freename in - let freename = if has_flags then StringSet.remove "FLAG" freename else freename in + let freename = + if has_flags + then StringSet.(diff freename (of_list [ "FLAG"; "CONFIG" ])) + else freename + in if StringSet.mem Global_constant.old_global_object freename then warn From c4e594fd5cb2b1e0f1edbacd542aa0b9d36aa2bd Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 19 Dec 2024 20:10:14 +0100 Subject: [PATCH 70/80] CR: Update compiler/lib/driver.ml Co-authored-by: hhugo --- compiler/lib/driver.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 82a603eaa4..84f2490678 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -99,7 +99,7 @@ let map_fst f (x, y, z) = f x, y, z let effects ~deadcode_sentinal p = match Config.effects () with - | Some (_ as effects) -> + | Some effects -> if debug () then Format.eprintf "Effects...@."; let p, live_vars = Deadcode.f p in let p = Effects.remove_empty_blocks ~live_vars p in From 6bb65e4f1007f02e686fec3212d16941d126133d Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 20 Dec 2024 15:29:53 +0100 Subject: [PATCH 71/80] Remove duplicate effects flag --- compiler/tests-ocaml/lib-effects/double-translation/dune | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index 9dc258c2d8..d4ffbb1882 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -5,11 +5,10 @@ (js_of_ocaml (flags (:standard --effects=double-translation)) - (build_runtime_flags - (:standard --effects=double-translation)) ;; separate compilation doesn't yet work when using ;; '--effect=double-translation' since Dune doesn't know it should compile a ;; different version of the dependencies. + ;; TODO: remove once support in ocaml/dune#11222 is released. (compilation_mode whole_program))) (_ (flags @@ -17,11 +16,10 @@ (js_of_ocaml (flags (:standard --effects=double-translation)) - (build_runtime_flags - (:standard --effects=double-translation)) ;; separate compilation doesn't yet work when using ;; '--effect=double-translation' since Dune doesn't know it should compile a ;; different version of the dependencies. + ;; TODO: remove once support in ocaml/dune#11222 is released. (compilation_mode whole_program)))) (copy_files ../*.expected) From 6391bd662448cfe16715abf9e6f2ca444d828f2b Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Sun, 22 Dec 2024 00:26:06 +0100 Subject: [PATCH 72/80] CR: more explicit type for effects backend --- compiler/bin-js_of_ocaml/cmd_arg.ml | 18 ++++++++--------- compiler/bin-js_of_ocaml/cmd_arg.mli | 2 +- compiler/bin-wasm_of_ocaml/cmd_arg.ml | 18 ++++++++--------- compiler/bin-wasm_of_ocaml/cmd_arg.mli | 2 +- .../js_of_ocaml_compiler_dynlink.ml | 6 +----- compiler/lib-runtime-files/gen/gen.ml | 4 +--- compiler/lib-wasm/gc_target.ml | 7 ++++--- compiler/lib-wasm/generate.ml | 6 +++++- compiler/lib/build_info.ml | 16 ++++++++------- compiler/lib/build_info.mli | 2 ++ compiler/lib/config.ml | 17 +++++++++++----- compiler/lib/config.mli | 11 ++++++---- compiler/lib/driver.ml | 17 ++++++++-------- compiler/lib/effects.ml | 6 +++--- compiler/lib/generate.ml | 20 +++++++++++++------ compiler/lib/generate_closure.ml | 2 +- compiler/lib/inline.ml | 5 +++-- compiler/lib/js_output.ml | 5 +++-- compiler/lib/linker.ml | 9 ++++++--- compiler/lib/macro.ml | 7 +------ compiler/lib/unit_info.ml | 4 ++-- lib/runtime/jsoo_runtime.ml | 10 ++++------ 22 files changed, 107 insertions(+), 87 deletions(-) diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml index 2d75b44278..a9669809ac 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.ml +++ b/compiler/bin-js_of_ocaml/cmd_arg.ml @@ -39,15 +39,15 @@ let trim_trailing_dir_sep s = let normalize_include_dirs dirs = List.map dirs ~f:trim_trailing_dir_sep -let normalize_effects effects common = - (* For backward compatibility, consider that [--enable effects] alone means - [--effects cps] *) +let normalize_effects (effects : [ `Cps | `Double_translation ] option) common : Config.effects_backend = match effects with | None -> + (* For backward compatibility, consider that [--enable effects] alone means + [--effects cps] *) if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable - then Some Config.Cps - else None - | Some _ -> effects + then `Cps + else `Disabled + | Some (`Cps | `Double_translation as e) -> (e :> Config.effects_backend) type t = { common : Jsoo_cmdline.Arg.t @@ -75,7 +75,7 @@ type t = ; fs_output : string option ; fs_external : bool ; keep_unit_names : bool - ; effects : Config.effects_backend option + ; effects : Config.effects_backend } let wrap_with_fun_conv = @@ -272,7 +272,7 @@ let options = Arg.( value & opt - (some (enum [ "cps", Config.Cps; "double-translation", Double_translation ])) + (some (enum [ "cps", `Cps; "double-translation", `Double_translation ])) None & info [ "effects" ] ~docv:"KIND" ~doc) in @@ -531,7 +531,7 @@ let options_runtime_only = Arg.( value & opt - (some (enum [ "cps", Config.Cps; "double-translation", Double_translation ])) + (some (enum [ "cps", `Cps; "double-translation", `Double_translation ])) None & info [ "effects" ] ~docv:"KIND" ~doc) in diff --git a/compiler/bin-js_of_ocaml/cmd_arg.mli b/compiler/bin-js_of_ocaml/cmd_arg.mli index 35006290bf..5ee27b7f91 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.mli +++ b/compiler/bin-js_of_ocaml/cmd_arg.mli @@ -49,7 +49,7 @@ type t = ; fs_output : string option ; fs_external : bool ; keep_unit_names : bool - ; effects : Config.effects_backend option + ; effects : Config.effects_backend } val options : t Cmdliner.Term.t diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.ml b/compiler/bin-wasm_of_ocaml/cmd_arg.ml index f2a6eee653..2c82bba69e 100644 --- a/compiler/bin-wasm_of_ocaml/cmd_arg.ml +++ b/compiler/bin-wasm_of_ocaml/cmd_arg.ml @@ -38,15 +38,15 @@ let trim_trailing_dir_sep s = let normalize_include_dirs dirs = List.map dirs ~f:trim_trailing_dir_sep -let normalize_effects effects common = - (* For backward compatibility, consider that [--enable effects] alone means [--effects cps] *) +let normalize_effects (effects : [ `Cps | `Jspi ] option) common : Config.effects_backend = match effects with | None -> + (* For backward compatibility, consider that [--enable effects] alone means + [--effects cps] *) if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable - then Some Config.Cps - else None - | Some Config.Cps -> Some Config.Cps - | Some _ -> failwith "Unexpected effects backend" + then `Cps + else `Jspi + | Some (`Cps | `Jspi as e) -> e type t = { common : Jsoo_cmdline.Arg.t @@ -61,7 +61,7 @@ type t = ; sourcemap_don't_inline_content : bool ; params : (string * string) list ; include_dirs : string list - ; effects : Config.effects_backend option + ; effects : Config.effects_backend } let options = @@ -121,7 +121,7 @@ let options = in Arg.( value - & opt (enum [ "jspi", None; "cps", Some Config.Cps ]) None + & opt (some (enum [ "jspi", `Jspi; "cps", `Cps ])) None & info [ "effects" ] ~docv:"KIND" ~doc) in let build_t @@ -236,7 +236,7 @@ let options_runtime_only = in Arg.( value - & opt (enum [ "jspi", None; "cps", Some Config.Cps ]) None + & opt (some (enum [ "jspi", `Jspi; "cps", `Cps ])) None & info [ "effects" ] ~docv:"KIND" ~doc) in let build_t diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.mli b/compiler/bin-wasm_of_ocaml/cmd_arg.mli index 4fa4035113..f009a5c9e9 100644 --- a/compiler/bin-wasm_of_ocaml/cmd_arg.mli +++ b/compiler/bin-wasm_of_ocaml/cmd_arg.mli @@ -31,7 +31,7 @@ type t = ; sourcemap_don't_inline_content : bool ; params : (string * string) list ; include_dirs : string list - ; effects : Config.effects_backend option + ; effects : Config.effects_backend } val options : t Cmdliner.Term.t diff --git a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml index fa8ba93360..140a53b1dc 100644 --- a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml +++ b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml @@ -39,11 +39,7 @@ let () = | Sys.(Native | Bytecode | Other _) -> failwith "Expected backend `js_of_ocaml`"); let global = J.pure_js_expr "globalThis" in Config.Flag.set "use-js-string" (Jsoo_runtime.Sys.Config.use_js_string ()); - Config.set_effects_backend - (match Jsoo_runtime.Sys.Config.effects () with - | None -> None - | Some Jsoo_runtime.Sys.Config.Cps -> Some Config.Cps - | Some Jsoo_runtime.Sys.Config.Double_translation -> Some Config.Double_translation); + Config.set_effects_backend (Jsoo_runtime.Sys.Config.effects ()); Linker.reset (); (* this needs to stay synchronized with toplevel.js *) let toplevel_compile (s : string) (debug : Instruct.debug_event list array) : diff --git a/compiler/lib-runtime-files/gen/gen.ml b/compiler/lib-runtime-files/gen/gen.ml index b21f4002c7..147f2453e6 100644 --- a/compiler/lib-runtime-files/gen/gen.ml +++ b/compiler/lib-runtime-files/gen/gen.ml @@ -50,9 +50,7 @@ let rec list_product l = let bool = [ `Bool true; `Bool false ] -let effects_backends = - let open Js_of_ocaml_compiler.Config in - [ `Effects None; `Effects (Some Cps); `Effects (Some Double_translation) ] +let effects_backends = [ `Effects `Disabled; `Effects `Cps; `Effects `Double_translation ] let () = Js_of_ocaml_compiler.Config.set_target `JavaScript; diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index f7bdc62f61..dade14a909 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/compiler/lib-wasm/gc_target.ml @@ -1706,15 +1706,16 @@ let post_process_function_body = Initialize_locals.f let entry_point ~toplevel_fun = let code = let* () = - if Option.is_some (Config.effects ()) - then + match Config.effects () with + | `Cps | `Double_translation -> let* f = register_import ~name:"caml_cps_initialize_effects" (Fun { W.params = []; result = [] }) in instr (W.CallInstr (f, [])) - else return () + | `Jspi -> return () + | `Disabled -> assert false in let* main = register_import diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index b7b3613f72..308f8d5602 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -21,7 +21,11 @@ open Code module W = Wasm_ast open Code_generation -let effects_cps () = Option.is_some (Config.effects ()) +let effects_cps () = + match Config.effects () with + | `Cps | `Double_translation -> true + | `Jspi -> false + | `Disabled -> assert false module Generate (Target : Target_sig.S) = struct open Target diff --git a/compiler/lib/build_info.ml b/compiler/lib/build_info.ml index efd0425058..4de9956edf 100644 --- a/compiler/lib/build_info.ml +++ b/compiler/lib/build_info.ml @@ -36,15 +36,17 @@ let string_of_kind = function | `Cma -> "cma" | `Unknown -> "unknown" -let string_of_effects_backend = function - | None -> "none" - | Some Config.Cps -> "cps" - | Some Config.Double_translation -> "double-translation" +let string_of_effects_backend : Config.effects_backend -> string = function + | `Disabled -> "disabled" + | `Cps -> "cps" + | `Double_translation -> "double-translation" + | `Jspi -> "jspi" let effects_backend_of_string = function - | "none" -> None - | "cps" -> Some Config.Cps - | "double-translation" -> Some Double_translation + | "disabled" -> `Disabled + | "cps" -> `Cps + | "double-translation" -> `Double_translation + | "jspi" -> `Jspi | _ -> invalid_arg "effects_backend_of_string" let kind_of_string s = diff --git a/compiler/lib/build_info.mli b/compiler/lib/build_info.mli index f80eee1646..2d669ba2d4 100644 --- a/compiler/lib/build_info.mli +++ b/compiler/lib/build_info.mli @@ -18,6 +18,8 @@ *) open! Stdlib +val string_of_effects_backend : Config.effects_backend -> string + type t type kind = diff --git a/compiler/lib/config.ml b/compiler/lib/config.ml index 6f25f2485a..4d04c5d884 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -197,11 +197,18 @@ let set_target (t : [ `JavaScript | `Wasm ]) = target_ := (t :> [ `JavaScript | `Wasm | `None ]) type effects_backend = - | Cps - | Double_translation + [ `Disabled + | `Cps + | `Double_translation + | `Jspi + ] -let effects_ : effects_backend option ref = ref None +let effects_ : [< `None | effects_backend ] ref = ref `None -let effects () = !effects_ +let effects () = + match !effects_ with + | `None -> failwith "effects was not set" + | `Jspi | `Cps | `Disabled | `Double_translation as b -> b -let set_effects_backend backend = effects_ := backend +let set_effects_backend (backend : effects_backend) = + effects_ := (backend :> [ `None | effects_backend ]) diff --git a/compiler/lib/config.mli b/compiler/lib/config.mli index 81df2c6ebd..71642430bf 100644 --- a/compiler/lib/config.mli +++ b/compiler/lib/config.mli @@ -118,9 +118,12 @@ val target : unit -> [ `JavaScript | `Wasm ] val set_target : [ `JavaScript | `Wasm ] -> unit type effects_backend = - | Cps - | Double_translation + [ `Disabled + | `Cps + | `Double_translation + | `Jspi + ] -val effects : unit -> effects_backend option +val effects : unit -> effects_backend -val set_effects_backend : effects_backend option -> unit +val set_effects_backend : effects_backend -> unit diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 84f2490678..ee24a5eb86 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -99,7 +99,7 @@ let map_fst f (x, y, z) = f x, y, z let effects ~deadcode_sentinal p = match Config.effects () with - | Some effects -> + | `Cps | `Double_translation as effects -> if debug () then Format.eprintf "Effects...@."; let p, live_vars = Deadcode.f p in let p = Effects.remove_empty_blocks ~live_vars p in @@ -116,16 +116,16 @@ let effects ~deadcode_sentinal p = |> Effects.f ~flow_info:info ~live_vars |> map_fst (match effects with - | Double_translation -> Fun.id - | Cps -> Lambda_lifting.f) - | None -> + | `Double_translation -> Fun.id + | `Cps -> Lambda_lifting.f) + | `Disabled | `Jspi -> ( p , (Code.Var.Set.empty : Effects.trampolined_calls) , (Code.Var.Set.empty : Effects.in_cps) ) let exact_calls profile ~deadcode_sentinal p = match Config.effects () with - | None -> + | `Disabled | `Jspi -> let fast = match profile with | O3 -> false @@ -138,7 +138,7 @@ let exact_calls profile ~deadcode_sentinal p = else p in Specialize.f ~function_arity:(fun f -> Global_flow.function_arity info f) p - | Some _ -> p + | `Cps | `Double_translation -> p let print p = if debug () then Code.Print.program (fun _ _ -> "") p; @@ -698,8 +698,9 @@ let optimize ~profile p = +> effects ~deadcode_sentinal +> map_fst (match Config.target (), Config.effects () with - | `JavaScript, None -> Generate_closure.f - | `JavaScript, Some _ | `Wasm, _ -> Fun.id) + | `JavaScript, `Disabled -> Generate_closure.f + | `JavaScript, (`Cps | `Double_translation) | `Wasm, (`Jspi | `Cps) -> Fun.id + | `JavaScript, `Jspi | `Wasm, (`Disabled | `Double_translation) -> assert false) +> map_fst deadcode' in if times () then Format.eprintf "Start Optimizing...@."; diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 10d7dc2910..6caf2ebb94 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -40,9 +40,9 @@ let debug = Debug.find "effects" let double_translate () = match Config.effects () with - | None -> assert false - | Some Cps -> false - | Some Double_translation -> true + | `Disabled | `Jspi -> assert false + | `Cps -> false + | `Double_translation -> true let debug_print fmt = if debug () then Format.(eprintf (fmt ^^ "%!")) else Format.(ifprintf err_formatter fmt) diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 3509c15e3d..2b82ac051c 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -24,6 +24,12 @@ let debug = Debug.find "gen" let times = Debug.find "times" +let cps_transform () = + match Config.effects () with + | `Cps | `Double_translation -> true + | `Disabled -> false + | `Jspi -> assert false + open Code module J = Javascript @@ -926,10 +932,11 @@ let apply_fun_raw = (* Adapt if [f] is a (direct-style, CPS) closure pair *) let real_closure = match Config.effects () with - | Some Double_translation when cps -> + | `Double_translation when cps -> (* Effects enabled, CPS version, not single-version *) J.EDot (f, J.ANormal, cps_field) - | _ -> f + | `Cps | `Double_translation | `Disabled -> f + | `Jspi -> assert false in (* We skip the arity check when we know that we have the right number of parameters, since this test is expensive. *) @@ -954,14 +961,15 @@ let apply_fun_raw = (runtime_fun ctx (match Config.effects () with - | Some Double_translation when cps -> "caml_call_gen_cps" - | _ -> "caml_call_gen")) + | `Double_translation when cps -> "caml_call_gen_cps" + | `Double_translation | `Cps | `Disabled -> "caml_call_gen" + | `Jspi -> assert false)) [ f; J.array params ] J.N ) in if trampolined then ( - assert (Option.is_some (Config.effects ())); + assert (cps_transform ()); (* 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. @@ -1408,7 +1416,7 @@ let rec translate_expr ctx loc x e level : (_ * J.statement_list) Expr_builder.t return e | Extern "caml_alloc_dummy_function", _ -> assert false | Extern ("%resume" | "%perform" | "%reperform"), _ -> - assert (Option.is_none (Config.effects ())); + assert (not (cps_transform ())); if not !(ctx.effect_warning) then ( warn diff --git a/compiler/lib/generate_closure.ml b/compiler/lib/generate_closure.ml index a585ebcfa9..a43876e8e1 100644 --- a/compiler/lib/generate_closure.ml +++ b/compiler/lib/generate_closure.ml @@ -327,7 +327,7 @@ let f p : Code.program = p let f p = - assert (Option.is_none (Config.effects ())); + assert (match Config.effects () with `Disabled | `Jspi -> true | `Cps | `Double_translation -> false); let open Config.Param in match tailcall_optim () with | TcNone -> p diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index abe6154aea..2637480062 100644 --- a/compiler/lib/inline.ml +++ b/compiler/lib/inline.ml @@ -331,8 +331,9 @@ let times = Debug.find "times" let f p live_vars = let first_class_primitives = match Config.target (), Config.effects () with - | `JavaScript, None -> true - | `JavaScript, Some _ | `Wasm, _ -> false + | `JavaScript, `Disabled -> true + | `JavaScript, (`Cps | `Double_translation) | `Wasm, _ -> false + | `JavaScript, `Jspi -> assert false in Code.invariant p; let t = Timer.make () in diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml index bebd7493fc..e6e03a4026 100644 --- a/compiler/lib/js_output.ml +++ b/compiler/lib/js_output.ml @@ -2100,9 +2100,10 @@ let program ?(accept_unnamed_var = false) ?(source_map = false) f p = end) in PP.set_needed_space_function f need_space; (match Config.effects () with - | Some Cps | Some Double_translation -> + | `Cps | `Double_translation -> PP.set_adjust_indentation_function f (fun n -> n mod 40) - | None -> ()); + | `Disabled -> () + | `Jspi -> assert false); PP.start_group f 0; O.program f p; PP.end_group f; diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml index 28523910fb..a5e0d05212 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -189,12 +189,15 @@ module Fragment = struct ~f:(fun m (k, v) -> StringMap.add k v m) ~init:StringMap.empty [ "js-string", Config.Flag.use_js_string - ; ("effects", fun () -> Option.is_some (Config.effects ())) + ; ("effects", fun () -> + match Config.effects () with + | `Disabled | `Jspi -> false + | `Cps | `Double_translation -> true) ; ( "doubletranslate" , fun () -> match Config.effects () with - | Some Double_translation -> true - | _ -> false ) + | `Double_translation -> true + | `Jspi | `Cps | `Disabled -> false ) ; ( "wasm" , fun () -> match Config.target () with diff --git a/compiler/lib/macro.ml b/compiler/lib/macro.ml index 4a2502d21c..958286a53f 100644 --- a/compiler/lib/macro.ml +++ b/compiler/lib/macro.ml @@ -23,11 +23,6 @@ type m = | Replace | Count of int ref -let string_of_effects_backend = function - | None -> "none" - | Some Config.Cps -> "cps" - | Some Config.Double_translation -> "double-translation" - class macro_mapper ~flags = object (m) inherit Js_traverse.map as super @@ -48,7 +43,7 @@ class macro_mapper ~flags = | "CONFIG", [ J.Arg (J.EStr (Utf8 "effects")) ] -> ( match flags with | Replace -> - let s = string_of_effects_backend (Config.effects ()) in + let s = Build_info.string_of_effects_backend (Config.effects ()) in J.EStr (Utf8_string.of_string_exn s) | Count count -> incr count; diff --git a/compiler/lib/unit_info.ml b/compiler/lib/unit_info.ml index 69839b9d5e..f1b97ae475 100644 --- a/compiler/lib/unit_info.ml +++ b/compiler/lib/unit_info.ml @@ -54,8 +54,8 @@ let of_cmo (cmo : Cmo_format.compilation_unit) = let requires = StringSet.diff requires provides in let effects_without_cps = (match Config.effects () with - | None -> true - | Some (Cps | Double_translation) -> false) + | `Disabled | `Jspi -> true + | `Cps | `Double_translation -> false) && List.exists (Cmo_format.primitives cmo) ~f:(function | "%resume" | "%reperform" | "%perform" -> true | _ -> false) diff --git a/lib/runtime/jsoo_runtime.ml b/lib/runtime/jsoo_runtime.ml index c95a8818e5..5a41a5f3b7 100644 --- a/lib/runtime/jsoo_runtime.ml +++ b/lib/runtime/jsoo_runtime.ml @@ -127,17 +127,15 @@ module Sys = struct module Config = struct external use_js_string : unit -> bool = "caml_jsoo_flags_use_js_string" - type effects_backend = - | Cps - | Double_translation + type effects_backend = [ `Disabled | `Cps | `Double_translation ] external effects_ : unit -> string = "caml_jsoo_flags_effects" let effects () = match effects_ () with - | "none" -> None - | "cps" -> Some Cps - | "double-translation" -> Some Double_translation + | "disabled" -> `Disabled + | "cps" -> `Cps + | "double-translation" -> `Double_translation | _ -> assert false end From 51b3d5096f48429242585c799ec94fea35825187 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Sun, 22 Dec 2024 18:11:54 +0100 Subject: [PATCH 73/80] CR: doc phrasing --- compiler/bin-js_of_ocaml/cmd_arg.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml index a9669809ac..61298fe463 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.ml +++ b/compiler/bin-js_of_ocaml/cmd_arg.ml @@ -526,7 +526,7 @@ let options_runtime_only = let effects = let doc = "Select an implementation of effect handlers. [$(docv)] should be one of $(b,cps) \ - or $(b,double-translation). Effects are not allowed by default." + or $(b,double-translation). Effects won't be supported if unspecified." in Arg.( value From 3109620155553688655bcb1369ac409a3a0b7151 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Sun, 22 Dec 2024 18:20:34 +0100 Subject: [PATCH 74/80] CR: revert obsolete change --- runtime/js/jslib.js | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/runtime/js/jslib.js b/runtime/js/jslib.js index 495bbf1566..79c5d9e868 100644 --- a/runtime/js/jslib.js +++ b/runtime/js/jslib.js @@ -67,8 +67,7 @@ function caml_trampoline_return(f, args, direct) { //Provides:caml_stack_depth //If: effects -var caml_stack_depth = 10; // Initialized to a non-zero value in case of -// unhandled effect +var caml_stack_depth = 0; //Provides:caml_stack_check_depth //If: effects From 821537d755414fe6e7119789c9416e4ae177698e Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Sun, 22 Dec 2024 23:09:29 +0100 Subject: [PATCH 75/80] Fix assertion --- compiler/lib/js_output.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml index e6e03a4026..ddddcd637a 100644 --- a/compiler/lib/js_output.ml +++ b/compiler/lib/js_output.ml @@ -2102,8 +2102,7 @@ let program ?(accept_unnamed_var = false) ?(source_map = false) f p = (match Config.effects () with | `Cps | `Double_translation -> PP.set_adjust_indentation_function f (fun n -> n mod 40) - | `Disabled -> () - | `Jspi -> assert false); + | `Disabled | `Jspi -> ()); PP.start_group f 0; O.program f p; PP.end_group f; From 3a527280d7d594e8aed305c835bca37c96cb857d Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Sun, 22 Dec 2024 23:16:20 +0100 Subject: [PATCH 76/80] CR: comment to justify constant --- runtime/js/effect.js | 2 ++ 1 file changed, 2 insertions(+) diff --git a/runtime/js/effect.js b/runtime/js/effect.js index e7c467df67..6432547c3c 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -273,6 +273,8 @@ function caml_resume(f, arg, stack) { /* Note: f is not an ordinary function but a (direct-style, CPS) closure pair */ var res = { joo_tramp: f, joo_args: [arg, k], joo_direct: 0 }; do { + /* Avoids trampolining too often while still avoiding stack overflow. See + [caml_callback]. */ caml_stack_depth = 40; try { res = res.joo_direct From 5541f1b300b6077c8480f42507af63708b6cc8ba Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Sun, 22 Dec 2024 23:16:36 +0100 Subject: [PATCH 77/80] reformat --- compiler/bin-js_of_ocaml/cmd_arg.ml | 13 +++++-------- compiler/bin-wasm_of_ocaml/cmd_arg.ml | 11 +++++------ compiler/lib-wasm/gc_target.ml | 12 ++++++------ compiler/lib/config.ml | 2 +- compiler/lib/driver.ml | 2 +- compiler/lib/generate_closure.ml | 5 ++++- compiler/lib/js_output.ml | 3 +-- compiler/lib/linker.ml | 9 +++++---- lib/runtime/jsoo_runtime.ml | 6 +++++- 9 files changed, 33 insertions(+), 30 deletions(-) diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml index 61298fe463..31be9f99e2 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.ml +++ b/compiler/bin-js_of_ocaml/cmd_arg.ml @@ -39,7 +39,8 @@ let trim_trailing_dir_sep s = let normalize_include_dirs dirs = List.map dirs ~f:trim_trailing_dir_sep -let normalize_effects (effects : [ `Cps | `Double_translation ] option) common : Config.effects_backend = +let normalize_effects (effects : [ `Cps | `Double_translation ] option) common : + Config.effects_backend = match effects with | None -> (* For backward compatibility, consider that [--enable effects] alone means @@ -47,7 +48,7 @@ let normalize_effects (effects : [ `Cps | `Double_translation ] option) common : if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable then `Cps else `Disabled - | Some (`Cps | `Double_translation as e) -> (e :> Config.effects_backend) + | Some ((`Cps | `Double_translation) as e) -> (e :> Config.effects_backend) type t = { common : Jsoo_cmdline.Arg.t @@ -271,9 +272,7 @@ let options = in Arg.( value - & opt - (some (enum [ "cps", `Cps; "double-translation", `Double_translation ])) - None + & opt (some (enum [ "cps", `Cps; "double-translation", `Double_translation ])) None & info [ "effects" ] ~docv:"KIND" ~doc) in let build_t @@ -530,9 +529,7 @@ let options_runtime_only = in Arg.( value - & opt - (some (enum [ "cps", `Cps; "double-translation", `Double_translation ])) - None + & opt (some (enum [ "cps", `Cps; "double-translation", `Double_translation ])) None & info [ "effects" ] ~docv:"KIND" ~doc) in let build_t diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.ml b/compiler/bin-wasm_of_ocaml/cmd_arg.ml index 2c82bba69e..a468332596 100644 --- a/compiler/bin-wasm_of_ocaml/cmd_arg.ml +++ b/compiler/bin-wasm_of_ocaml/cmd_arg.ml @@ -38,15 +38,14 @@ let trim_trailing_dir_sep s = let normalize_include_dirs dirs = List.map dirs ~f:trim_trailing_dir_sep -let normalize_effects (effects : [ `Cps | `Jspi ] option) common : Config.effects_backend = +let normalize_effects (effects : [ `Cps | `Jspi ] option) common : Config.effects_backend + = match effects with | None -> - (* For backward compatibility, consider that [--enable effects] alone means + (* For backward compatibility, consider that [--enable effects] alone means [--effects cps] *) - if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable - then `Cps - else `Jspi - | Some (`Cps | `Jspi as e) -> e + if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable then `Cps else `Jspi + | Some ((`Cps | `Jspi) as e) -> e type t = { common : Jsoo_cmdline.Arg.t diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index dade14a909..239bf1e248 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/compiler/lib-wasm/gc_target.ml @@ -1708,12 +1708,12 @@ let entry_point ~toplevel_fun = let* () = match Config.effects () with | `Cps | `Double_translation -> - let* f = - register_import - ~name:"caml_cps_initialize_effects" - (Fun { W.params = []; result = [] }) - in - instr (W.CallInstr (f, [])) + let* f = + register_import + ~name:"caml_cps_initialize_effects" + (Fun { W.params = []; result = [] }) + in + instr (W.CallInstr (f, [])) | `Jspi -> return () | `Disabled -> assert false in diff --git a/compiler/lib/config.ml b/compiler/lib/config.ml index 4d04c5d884..3e662dd517 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -208,7 +208,7 @@ let effects_ : [< `None | effects_backend ] ref = ref `None let effects () = match !effects_ with | `None -> failwith "effects was not set" - | `Jspi | `Cps | `Disabled | `Double_translation as b -> b + | (`Jspi | `Cps | `Disabled | `Double_translation) as b -> b let set_effects_backend (backend : effects_backend) = effects_ := (backend :> [ `None | effects_backend ]) diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index ee24a5eb86..6d3fee9708 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -99,7 +99,7 @@ let map_fst f (x, y, z) = f x, y, z let effects ~deadcode_sentinal p = match Config.effects () with - | `Cps | `Double_translation as effects -> + | (`Cps | `Double_translation) as effects -> if debug () then Format.eprintf "Effects...@."; let p, live_vars = Deadcode.f p in let p = Effects.remove_empty_blocks ~live_vars p in diff --git a/compiler/lib/generate_closure.ml b/compiler/lib/generate_closure.ml index a43876e8e1..3285e535b8 100644 --- a/compiler/lib/generate_closure.ml +++ b/compiler/lib/generate_closure.ml @@ -327,7 +327,10 @@ let f p : Code.program = p let f p = - assert (match Config.effects () with `Disabled | `Jspi -> true | `Cps | `Double_translation -> false); + assert ( + match Config.effects () with + | `Disabled | `Jspi -> true + | `Cps | `Double_translation -> false); let open Config.Param in match tailcall_optim () with | TcNone -> p diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml index ddddcd637a..19a55ffb60 100644 --- a/compiler/lib/js_output.ml +++ b/compiler/lib/js_output.ml @@ -2100,8 +2100,7 @@ let program ?(accept_unnamed_var = false) ?(source_map = false) f p = end) in PP.set_needed_space_function f need_space; (match Config.effects () with - | `Cps | `Double_translation -> - PP.set_adjust_indentation_function f (fun n -> n mod 40) + | `Cps | `Double_translation -> PP.set_adjust_indentation_function f (fun n -> n mod 40) | `Disabled | `Jspi -> ()); PP.start_group f 0; O.program f p; diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml index a5e0d05212..f3ce13b689 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -189,10 +189,11 @@ module Fragment = struct ~f:(fun m (k, v) -> StringMap.add k v m) ~init:StringMap.empty [ "js-string", Config.Flag.use_js_string - ; ("effects", fun () -> - match Config.effects () with - | `Disabled | `Jspi -> false - | `Cps | `Double_translation -> true) + ; ( "effects" + , fun () -> + match Config.effects () with + | `Disabled | `Jspi -> false + | `Cps | `Double_translation -> true ) ; ( "doubletranslate" , fun () -> match Config.effects () with diff --git a/lib/runtime/jsoo_runtime.ml b/lib/runtime/jsoo_runtime.ml index 5a41a5f3b7..af0457de38 100644 --- a/lib/runtime/jsoo_runtime.ml +++ b/lib/runtime/jsoo_runtime.ml @@ -127,7 +127,11 @@ module Sys = struct module Config = struct external use_js_string : unit -> bool = "caml_jsoo_flags_use_js_string" - type effects_backend = [ `Disabled | `Cps | `Double_translation ] + type effects_backend = + [ `Disabled + | `Cps + | `Double_translation + ] external effects_ : unit -> string = "caml_jsoo_flags_effects" From 01595fc8a61d03c4162bb05c58f5c04c53118ad0 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 23 Dec 2024 00:35:03 +0100 Subject: [PATCH 78/80] Fixes --- compiler/bin-js_of_ocaml/build_fs.ml | 1 + compiler/bin-js_of_ocaml/check_runtime.ml | 1 + compiler/tests-compiler/direct_calls.ml | 2 +- .../tests-compiler/double-translation/direct_calls.ml | 2 +- .../double-translation/effects_continuations.ml | 2 +- .../double-translation/effects_exceptions.ml | 2 +- .../double-translation/effects_toplevel.ml | 2 +- compiler/tests-compiler/effects.ml | 2 +- compiler/tests-compiler/effects_continuations.ml | 2 +- compiler/tests-compiler/effects_exceptions.ml | 2 +- compiler/tests-compiler/effects_toplevel.ml | 2 +- compiler/tests-compiler/lambda_lifting.ml | 4 ++-- compiler/tests-compiler/util/util.ml | 8 ++++---- compiler/tests-compiler/util/util.mli | 10 +++++----- 14 files changed, 22 insertions(+), 20 deletions(-) diff --git a/compiler/bin-js_of_ocaml/build_fs.ml b/compiler/bin-js_of_ocaml/build_fs.ml index 68821c83be..bdf436c333 100644 --- a/compiler/bin-js_of_ocaml/build_fs.ml +++ b/compiler/bin-js_of_ocaml/build_fs.ml @@ -62,6 +62,7 @@ function jsoo_create_file_extern(name,content){ |} in Config.set_target `JavaScript; + Config.set_effects_backend `Disabled; let fragments = Linker.Fragment.parse_string code in Linker.load_fragments ~target_env:Isomorphic ~filename:"" fragments; Linker.check_deps (); diff --git a/compiler/bin-js_of_ocaml/check_runtime.ml b/compiler/bin-js_of_ocaml/check_runtime.ml index 5868fdad53..e5d6fa4447 100644 --- a/compiler/bin-js_of_ocaml/check_runtime.ml +++ b/compiler/bin-js_of_ocaml/check_runtime.ml @@ -44,6 +44,7 @@ let print_groups output l = let f (runtime_files, bytecode, target_env) = Config.set_target `JavaScript; + Config.set_effects_backend `Disabled; Linker.reset (); let runtime_files, builtin = List.partition_map runtime_files ~f:(fun name -> diff --git a/compiler/tests-compiler/direct_calls.ml b/compiler/tests-compiler/direct_calls.ml index 8de15dd959..b2a700b490 100644 --- a/compiler/tests-compiler/direct_calls.ml +++ b/compiler/tests-compiler/direct_calls.ml @@ -102,7 +102,7 @@ let%expect_test "direct calls without --effects=cps" = let%expect_test "direct calls with --effects=cps" = let code = compile_and_parse - ~effects:Js_of_ocaml_compiler.Config.Cps + ~effects:`Cps {| (* Arity of the argument of a function / direct call *) let test1 () = diff --git a/compiler/tests-compiler/double-translation/direct_calls.ml b/compiler/tests-compiler/double-translation/direct_calls.ml index c1e03a8582..47995e53d1 100644 --- a/compiler/tests-compiler/double-translation/direct_calls.ml +++ b/compiler/tests-compiler/double-translation/direct_calls.ml @@ -21,7 +21,7 @@ open Util let%expect_test "direct calls with --effects=double-translation" = let code = compile_and_parse - ~effects:Js_of_ocaml_compiler.Config.Double_translation + ~effects:`Double_translation {| (* Arity of the argument of a function / direct call *) let test1 () = diff --git a/compiler/tests-compiler/double-translation/effects_continuations.ml b/compiler/tests-compiler/double-translation/effects_continuations.ml index 8c0a12959d..a85a5d3564 100644 --- a/compiler/tests-compiler/double-translation/effects_continuations.ml +++ b/compiler/tests-compiler/double-translation/effects_continuations.ml @@ -22,7 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let code = compile_and_parse - ~effects:Js_of_ocaml_compiler.Config.Double_translation + ~effects:`Double_translation {| let list_rev = List.rev (* Avoid to expose the offset of stdlib modules *) diff --git a/compiler/tests-compiler/double-translation/effects_exceptions.ml b/compiler/tests-compiler/double-translation/effects_exceptions.ml index cc2b1038be..0294c1036a 100644 --- a/compiler/tests-compiler/double-translation/effects_exceptions.ml +++ b/compiler/tests-compiler/double-translation/effects_exceptions.ml @@ -22,7 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let code = compile_and_parse - ~effects:Js_of_ocaml_compiler.Config.Double_translation + ~effects:`Double_translation {| let exceptions s = (* Compiled using 'try ... catch', diff --git a/compiler/tests-compiler/double-translation/effects_toplevel.ml b/compiler/tests-compiler/double-translation/effects_toplevel.ml index 6550860648..8a2e76af6a 100644 --- a/compiler/tests-compiler/double-translation/effects_toplevel.ml +++ b/compiler/tests-compiler/double-translation/effects_toplevel.ml @@ -22,7 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let code = compile_and_parse - ~effects:Js_of_ocaml_compiler.Config.Double_translation + ~effects:`Double_translation {| (* Function calls at toplevel outside of loops do not use [caml_callback] when double translation is enabled. *) diff --git a/compiler/tests-compiler/effects.ml b/compiler/tests-compiler/effects.ml index 1afd07d5f1..d4b1dca638 100644 --- a/compiler/tests-compiler/effects.ml +++ b/compiler/tests-compiler/effects.ml @@ -22,7 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let program = compile_and_parse - ~effects:Js_of_ocaml_compiler.Config.Cps + ~effects:`Cps {| open Effect diff --git a/compiler/tests-compiler/effects_continuations.ml b/compiler/tests-compiler/effects_continuations.ml index cee457e23f..92b303cbce 100644 --- a/compiler/tests-compiler/effects_continuations.ml +++ b/compiler/tests-compiler/effects_continuations.ml @@ -22,7 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let code = compile_and_parse - ~effects:Js_of_ocaml_compiler.Config.Cps + ~effects:`Cps {| let list_rev = List.rev diff --git a/compiler/tests-compiler/effects_exceptions.ml b/compiler/tests-compiler/effects_exceptions.ml index 5637ab11d1..a93058c40d 100644 --- a/compiler/tests-compiler/effects_exceptions.ml +++ b/compiler/tests-compiler/effects_exceptions.ml @@ -22,7 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let code = compile_and_parse - ~effects:Js_of_ocaml_compiler.Config.Cps + ~effects:`Cps {| let exceptions s = (* Compiled using 'try ... catch', diff --git a/compiler/tests-compiler/effects_toplevel.ml b/compiler/tests-compiler/effects_toplevel.ml index 4153f03b2f..6faf1ef7b0 100644 --- a/compiler/tests-compiler/effects_toplevel.ml +++ b/compiler/tests-compiler/effects_toplevel.ml @@ -22,7 +22,7 @@ open Util let%expect_test "test-compiler/lib-effects/test1.ml" = let code = compile_and_parse - ~effects:Js_of_ocaml_compiler.Config.Cps + ~effects:`Cps {| (* Function calls at toplevel outside of loops use [caml_callback]. *) diff --git a/compiler/tests-compiler/lambda_lifting.ml b/compiler/tests-compiler/lambda_lifting.ml index 1bd37835d1..25755fe92e 100644 --- a/compiler/tests-compiler/lambda_lifting.ml +++ b/compiler/tests-compiler/lambda_lifting.ml @@ -14,10 +14,10 @@ Printf.printf "%d\n" (f 3) let flags = [ "--no-inline"; "--set=lifting-threshold=1"; "--set=lifting-baseline=0" ] in - Util.compile_and_run ~effects:Js_of_ocaml_compiler.Config.Cps ~flags prog; + Util.compile_and_run ~effects:`Cps ~flags prog; [%expect {|15 |}]; let program = - Util.compile_and_parse ~effects:Js_of_ocaml_compiler.Config.Cps ~flags prog + Util.compile_and_parse ~effects:`Cps ~flags prog in Util.print_program program; [%expect diff --git a/compiler/tests-compiler/util/util.ml b/compiler/tests-compiler/util/util.ml index 32dbb86383..66a10b3fd1 100644 --- a/compiler/tests-compiler/util/util.ml +++ b/compiler/tests-compiler/util/util.ml @@ -290,7 +290,7 @@ let extract_sourcemap file = let compile_to_javascript ?(flags = []) ?(use_js_string = false) - ?effects + ?(effects = `Disabled) ~pretty ~sourcemap file = @@ -300,10 +300,10 @@ let compile_to_javascript [ (if pretty then [ "--pretty" ] else []) ; (if sourcemap then [ "--sourcemap" ] else []) ; (match effects with - | Some Js_of_ocaml_compiler.Config.Double_translation -> + | `Double_translation -> [ "--effects=double-translation" ] - | Some Cps -> [ "--effects=cps" ] - | None -> []) + | `Cps -> [ "--effects=cps" ] + | `Disabled -> []) ; (if use_js_string then [ "--enable=use-js-string" ] else [ "--disable=use-js-string" ]) diff --git a/compiler/tests-compiler/util/util.mli b/compiler/tests-compiler/util/util.mli index b44b79e919..511933b9b0 100644 --- a/compiler/tests-compiler/util/util.mli +++ b/compiler/tests-compiler/util/util.mli @@ -34,7 +34,7 @@ val compile_lib : Filetype.cmo_file list -> string -> Filetype.cmo_file val compile_cmo_to_javascript : ?flags:string list - -> ?effects:Config.effects_backend + -> ?effects:[ `Disabled | `Cps | `Double_translation ] -> ?use_js_string:bool -> ?pretty:bool -> ?sourcemap:bool @@ -43,7 +43,7 @@ val compile_cmo_to_javascript : val compile_bc_to_javascript : ?flags:string list - -> ?effects:Config.effects_backend + -> ?effects:[ `Disabled | `Cps | `Double_translation ] -> ?use_js_string:bool -> ?pretty:bool -> ?sourcemap:bool @@ -83,7 +83,7 @@ val compile_and_run : -> ?pretty:bool -> ?skip_modern:bool -> ?flags:string list - -> ?effects:Config.effects_backend + -> ?effects:[ `Disabled | `Cps | `Double_translation ] -> ?use_js_string:bool -> ?unix:bool -> string @@ -95,7 +95,7 @@ val compile_and_parse : ?debug:bool -> ?pretty:bool -> ?flags:string list - -> ?effects:Config.effects_backend + -> ?effects:[ `Disabled | `Cps | `Double_translation ] -> ?use_js_string:bool -> string -> Javascript.program @@ -104,7 +104,7 @@ val compile_and_parse_whole_program : ?debug:bool -> ?pretty:bool -> ?flags:string list - -> ?effects:Config.effects_backend + -> ?effects:[ `Disabled | `Cps | `Double_translation ] -> ?use_js_string:bool -> ?unix:bool -> string From 7066f6be92715f4ade05b2ef9166ee777a6f6aee Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 23 Dec 2024 10:56:10 +0100 Subject: [PATCH 79/80] Fix assert failure --- compiler/lib/js_output.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml index 19a55ffb60..b0eb604860 100644 --- a/compiler/lib/js_output.ml +++ b/compiler/lib/js_output.ml @@ -2101,7 +2101,7 @@ let program ?(accept_unnamed_var = false) ?(source_map = false) f p = PP.set_needed_space_function f need_space; (match Config.effects () with | `Cps | `Double_translation -> PP.set_adjust_indentation_function f (fun n -> n mod 40) - | `Disabled | `Jspi -> ()); + | `Disabled | `Jspi | exception Failure _ -> ()); PP.start_group f 0; O.program f p; PP.end_group f; From 0eeaafec1549f9ba7bbd8a3b5439ebbaeb97928d Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 23 Dec 2024 16:31:12 +0100 Subject: [PATCH 80/80] reformat --- compiler/lib/js_output.ml | 2 +- compiler/tests-compiler/lambda_lifting.ml | 4 +--- compiler/tests-compiler/util/util.ml | 3 +-- 3 files changed, 3 insertions(+), 6 deletions(-) diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml index b0eb604860..f2cf8c79ed 100644 --- a/compiler/lib/js_output.ml +++ b/compiler/lib/js_output.ml @@ -2101,7 +2101,7 @@ let program ?(accept_unnamed_var = false) ?(source_map = false) f p = PP.set_needed_space_function f need_space; (match Config.effects () with | `Cps | `Double_translation -> PP.set_adjust_indentation_function f (fun n -> n mod 40) - | `Disabled | `Jspi | exception Failure _ -> ()); + | `Disabled | `Jspi | (exception Failure _) -> ()); PP.start_group f 0; O.program f p; PP.end_group f; diff --git a/compiler/tests-compiler/lambda_lifting.ml b/compiler/tests-compiler/lambda_lifting.ml index 25755fe92e..11cc1467b0 100644 --- a/compiler/tests-compiler/lambda_lifting.ml +++ b/compiler/tests-compiler/lambda_lifting.ml @@ -16,9 +16,7 @@ Printf.printf "%d\n" (f 3) in Util.compile_and_run ~effects:`Cps ~flags prog; [%expect {|15 |}]; - let program = - Util.compile_and_parse ~effects:`Cps ~flags prog - in + let program = Util.compile_and_parse ~effects:`Cps ~flags prog in Util.print_program program; [%expect {| diff --git a/compiler/tests-compiler/util/util.ml b/compiler/tests-compiler/util/util.ml index 66a10b3fd1..74cf3cec92 100644 --- a/compiler/tests-compiler/util/util.ml +++ b/compiler/tests-compiler/util/util.ml @@ -300,8 +300,7 @@ let compile_to_javascript [ (if pretty then [ "--pretty" ] else []) ; (if sourcemap then [ "--sourcemap" ] else []) ; (match effects with - | `Double_translation -> - [ "--effects=double-translation" ] + | `Double_translation -> [ "--effects=double-translation" ] | `Cps -> [ "--effects=cps" ] | `Disabled -> []) ; (if use_js_string