From 68fbeb8ab3e592b290636eb2d377972ff902a2c6 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 9 Mar 2023 18:45:48 +0100 Subject: [PATCH] Effects: double translation of functions and ... dynamic switching between direct-style and CPS code. (#1461) --- CHANGES.md | 5 + 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 | 26 +- compiler/lib/effects.ml | 829 +++++++++++++++--- compiler/lib/effects.mli | 15 +- compiler/lib/flow.ml | 2 +- compiler/lib/freevars.ml | 15 +- compiler/lib/freevars.mli | 11 +- compiler/lib/generate.ml | 168 ++-- compiler/lib/generate.mli | 1 + compiler/lib/lambda_lifting.ml | 4 +- compiler/lib/lambda_lifting_simple.ml | 354 ++++++++ compiler/lib/lambda_lifting_simple.mli | 53 ++ compiler/lib/linker.ml | 18 + compiler/lib/phisimpl.ml | 2 +- compiler/lib/stdlib.ml | 15 + compiler/lib/subst.ml | 199 +++-- compiler/lib/subst.mli | 43 +- compiler/tests-compiler/direct_calls.ml | 20 +- .../double-translation/direct_calls.ml | 224 +++++ .../tests-compiler/double-translation/dune | 14 + .../double-translation/dune.inc | 60 ++ .../effects_continuations.ml | 301 +++++++ .../double-translation/effects_exceptions.ml | 195 ++++ .../double-translation/effects_toplevel.ml | 89 ++ compiler/tests-compiler/effects.ml | 9 +- .../tests-compiler/effects_continuations.ml | 74 +- compiler/tests-compiler/effects_exceptions.ml | 58 +- compiler/tests-compiler/effects_toplevel.ml | 18 +- 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/effect.js | 113 ++- runtime/jslib.js | 36 +- runtime/stdlib.js | 111 ++- runtime/stdlib_modern.js | 101 +++ 85 files changed, 4294 insertions(+), 392 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 56919dd197..7138f327be 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,8 @@ +# dev (2024-??) - ?? + +## Features/Changes +* Effects: add an optional feature of "dynamic switching" between CPS and direct style, resulting in better performance when no effect handler is installed + # 5.8.2 (2024-05-26) - Luc ## Bug fixes diff --git a/compiler/lib/build_info.ml b/compiler/lib/build_info.ml index 66b0e4b442..bdc0643021 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 ] @@ -122,9 +123,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 @@ -139,6 +141,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 0558eab6d7..2985093da6 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -106,6 +106,8 @@ module Var : sig val set : 'a t -> key -> 'a -> unit + val length : 'a t -> int + val make : size -> 'a -> 'a t val iter : (key -> 'a -> unit) -> 'a t -> unit @@ -212,6 +214,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 iter f t = diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index e11a3c8b0b..144830e52b 100644 --- a/compiler/lib/code.mli +++ b/compiler/lib/code.mli @@ -99,6 +99,8 @@ module Var : sig val set : 'a t -> key -> 'a -> unit + val length : 'a t -> int + val make : size -> 'a -> 'a t val iter : (key -> 'a -> unit) -> 'a t -> unit diff --git a/compiler/lib/config.ml b/compiler/lib/config.ml index 9385a063ba..154c8628a2 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 e4c86d37b0..c810a22107 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 86a329177a..e379cb8888 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -87,7 +87,7 @@ let phi p = let ( +> ) f g x = g (f x) -let map_fst f (x, y) = f x, y +let map_triple_fst f (x, y, z) = f x, y, z let effects ~deadcode_sentinal p = if Config.Flag.effects () @@ -104,9 +104,14 @@ let effects ~deadcode_sentinal p = Deadcode.f p else p, live_vars in - let p, cps = p |> Effects.f ~flow_info:info ~live_vars +> map_fst Lambda_lifting.f in - p, cps) - else p, (Code.Var.Set.empty : Effects.cps_calls) + p + |> Effects.f ~flow_info:info ~live_vars + +> map_triple_fst + (if Config.Flag.double_translation () then Fun.id else Lambda_lifting.f)) + else + ( p + , (Code.Var.Set.empty : Effects.cps_calls) + , (Code.Var.Set.empty : Effects.single_version_closures) ) let exact_calls profile ~deadcode_sentinal p = if not (Config.Flag.effects ()) @@ -193,7 +198,7 @@ let generate ~wrap_with_fun ~warn_on_unhandled_effect ~deadcode_sentinal - ((p, live_vars), cps_calls) = + ((p, live_vars), cps_calls, single_version_closures) = if times () then Format.eprintf "Start Generation...@."; let should_export = should_export wrap_with_fun in Generate.f @@ -201,6 +206,7 @@ let generate ~exported_runtime ~live_vars ~cps_calls + ~single_version_closures ~should_export ~warn_on_unhandled_effect ~deadcode_sentinal @@ -671,8 +677,14 @@ let full ~standalone ~wrap_with_fun ~profile ~link ~source_map formatter d p = | O3 -> o3) +> exact_calls ~deadcode_sentinal profile +> effects ~deadcode_sentinal - +> map_fst (if Config.Flag.effects () then fun x -> x else Generate_closure.f) - +> map_fst deadcode' + +> fun (p, cps_calls, single_version_closures) -> + let p, single_version_closures = + if Config.Flag.effects () + then p, single_version_closures + else Generate_closure.f p, single_version_closures + in + let p = deadcode' p in + p, cps_calls, single_version_closures in let emit = generate diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 97abfcf635..5343f86c32 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)) @@ -220,7 +225,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 @@ -249,13 +256,16 @@ let jump_closures blocks_to_transform idom : jump_closures = type cps_calls = Var.Set.t +type single_version_closures = Var.Set.t + type st = { mutable new_blocks : Code.block Addr.Map.t * 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 * 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 @@ -264,6 +274,12 @@ type st = ; live_vars : Deadcode.variable_uses ; flow_info : Global_flow.info ; cps_calls : cps_calls ref + ; cps_pc_of_direct : (int, int) Hashtbl.t + (* Mapping from direct-style to CPS addresses of functions (used when + double translation is enabled) *) + ; single_version_closures : single_version_closures ref + (* Functions that exist in only one version, even when double translation + is enabled *) } let add_block st block = @@ -271,15 +287,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 loc = + 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, []))), loc ], 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 ~check ~f args loc = assert (exact || check); let ret = Var.fresh () in @@ -288,7 +326,7 @@ let tail_call ~st ?(instrs = []) ~exact ~check ~f args loc = let cps_branch ~st ~src (pc, args) loc = match Addr.Set.mem pc st.blocks_to_transform with - | false -> [], (Branch (pc, args), loc) + | false -> [], (Branch (mk_cps_pc_of_direct ~st pc, args), loc) | true -> let args, instrs = if List.is_empty args && Hashtbl.mem st.is_continuation pc @@ -302,11 +340,13 @@ let cps_branch ~st ~src (pc, args) loc = (* We check the stack depth only for backward edges (so, at least once per loop iteration) *) let check = Hashtbl.find st.block_order src >= Hashtbl.find st.block_order pc in - tail_call ~st ~instrs ~exact:true ~check ~f:(closure_of_pc ~st pc) args loc + let f = closure_of_pc ~st pc in + mark_single_version ~st f; + tail_call ~st ~instrs ~exact:true ~check ~f args loc let cps_jump_cont ~st ~src ((pc, _) as cont) loc = 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 loc in @@ -314,7 +354,52 @@ let cps_jump_cont ~st ~src ((pc, _) as cont) loc = in call_block, [] -let allocate_continuation ~st ~alloc_jump_closures ~split_closures pc x cont loc = +let do_alloc_jump_closures ~st (to_allocate : (Var.t * Code.Addr.t) list) : + (instr * loc) 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, []))), noloc) + +let allocate_continuation + ~st + ~alloc_jump_closures + ~split_closures + ~direct_pc + src_pc + x + cont + loc = + 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 @@ -323,18 +408,18 @@ let allocate_continuation ~st ~alloc_jump_closures ~split_closures pc x cont loc 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 loc in + let body, branch = cps_branch ~st ~src:src_pc cont loc in let inner_closures, outer_closures = (* For [Pushtrap], we need to separate the closures corresponding to the exception handler body (that may make @@ -342,15 +427,18 @@ let allocate_continuation ~st ~alloc_jump_closures ~split_closures pc x cont loc 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 loc @@ -362,7 +450,7 @@ let cps_last ~st ~alloc_jump_closures pc ((last, last_loc) : last * loc) ~k : 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 ~check:false ~f:k [ x ] last_loc @@ -426,18 +514,26 @@ let cps_last ~st ~alloc_jump_closures pc ((last, last_loc) : last * loc) ~k : | 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, last_loc) + | 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, last_loc) | true -> let constr_cont, exn_handler = allocate_continuation ~st ~alloc_jump_closures ~split_closures:true + ~direct_pc:handler_pc pc exn handler_cont + (* We pass the direct pc, the mapping to CPS is made + by the called functions. *) last_loc in + mark_single_version ~st exn_handler; let push_trap = Let (Var.fresh (), Prim (Extern "caml_push_trap", [ Pv exn_handler ])), noloc in @@ -457,61 +553,185 @@ let cps_last ~st ~alloc_jump_closures pc ((last, last_loc) : last * loc) ~k : @ ((Let (exn_handler, Prim (Extern "caml_pop_trap", [])), noloc) :: 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, loc) -> + 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))), loc) :: body_acc) + | i -> return ((i, loc) :: 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), loc -> return (b, loc) + | Branch cont, loc -> + let* cont = update cont in + return (Branch cont, loc) + | Cond (x, c1, c2), loc -> + let* c1 = update c1 in + let* c2 = update c2 in + return (Cond (x, c1, c2), loc) + | Switch (x, conts), loc -> + let* conts = array_map conts ~f:update in + return (Switch (x, conts), loc) + | Pushtrap (c1, x, c2), loc -> + let* c1 = update c1 in + let* c2 = update c2 in + return (Pushtrap (c1, x, c2), loc) + | Poptrap cont, loc -> + let* cont = update cont in + return (Poptrap cont, loc) + 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 (x, Closure (params @ [ k ], cont)) + let cps_params, cps_cont = Hashtbl.find st.closure_info pc in + [ 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 + [ 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 (Int32.succ a)) ]) - ) + [ Let + ( x + , Prim + (Extern "caml_alloc_dummy_function", [ size; Pc (Int (Int32.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, []))), noloc) + 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 @@ -530,7 +750,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 ~check:true ~f (args @ [ k ]) loc) | Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg ]) -> @@ -555,22 +779,30 @@ let cps_block ~st ~k pc block = let rewritten_block = match List.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), loc)), (Return ret, _loc_ret) -> Option.map (rewrite_instr x e loc) ~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), loc)), (Branch cont, loc_ret) -> + | Some (body_prefix, (Let (x, e), loc)), (Branch ((direct_pc, _) as cont), loc_ret) -> Option.map (rewrite_instr x e loc) ~f:(fun f -> let constr_cont, k' = allocate_continuation ~st ~alloc_jump_closures ~split_closures:false - pc + ~direct_pc + orig_pc x cont + (* We pass the direct pc, the mapping to CPS is made by + the called functions. *) loc_ret in let instrs, branch = f ~k:k' in @@ -583,27 +815,192 @@ 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, loc) -> cps_instr ~st i, loc) @ last_instrs, last + let body_prefix = + (* For each instruction... *) + List.map body_prefix ~f:(fun (i, loc) -> + (* ... apply [cps_instr] ... *) + cps_instr ~st i + (* ... and decorate all resulting instructions with [loc] *) + |> List.map ~f:(fun i -> i, loc)) + |> 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 last_instrs, last = + cps_last ~st ~alloc_jump_closures orig_pc block.branch ~k + in let body = - List.map block.body ~f:(fun (i, loc) -> cps_instr ~st i, loc) @ last_instrs + (* For each instruction... *) + List.map block.body ~f:(fun (i, loc) -> + (* ... apply [cps_instr] ... *) + cps_instr ~st i + (* ... and decorate all resulting instructions with [loc] *) + |> List.map ~f:(fun i -> i, loc)) + |> List.concat in - body, last + 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, loc) = + 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)), loc + | 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 (Int32.succ a)) ]) + ) + , loc ) + | _ -> 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 }), loc + | Let (_, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> + assert false + | _ -> instr, loc + +(* 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 0l in + (* Dummy continuation *) + [ Let (x, Prim (Extern "caml_perform_effect", [ Pv effect; Pc (Int 0l); Pc k ])) + ] + | Let (x, Prim (Extern "%reperform", [ Pv effect; Pv continuation ])) -> + (* Similar to previous case *) + let k = Int 0l in + [ Let + ( x + , Prim (Extern "caml_perform_effect", [ Pv effect; Pv continuation; Pc k ]) + ) + ] + | (Let _ | Assign _ | Set_field _ | Offset_ref _ | Array_set _) as instr -> + [ instr ] + in + let body = + (* For each instruction... *) + List.concat_map block.body ~f:(fun (i, loc) -> + (* ... apply [rewrite_instr] ... *) + rewrite_instr i + (* ... and decorate all resulting instructions with [loc] *) + |> List.map ~f:(fun i -> i, loc)) + 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 cps_calls = 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 @@ -622,9 +1019,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 @@ -640,7 +1038,8 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = let closure_jc = jump_closures blocks_to_transform idom in let start, args, blocks, free_pc = (* Insert an initial block if needed. *) - if Addr.Map.mem start' closure_jc.closures_of_alloc_site + if should_compute_needed_transformations + && Addr.Map.mem start' closure_jc.closures_of_alloc_site then start', [], blocks', free_pc + 1 else start, args, blocks, free_pc in @@ -659,16 +1058,21 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = ; flow_info ; live_vars ; cps_calls + ; 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 ( @@ -685,57 +1089,188 @@ 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, loc) -> cps_instr ~st i, loc) - } + ( 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 CPS calls and lifter functions *) + cps_calls := Var.Set.map bound_subst !cps_calls; + single_version_closures := Var.Set.map bound_subst !single_version_closures; + (* 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 CPS calls and lifter functions *) + cps_calls := Var.Set.map param_subst !cps_calls; + single_version_closures := Var.Set.map param_subst !single_version_closures; 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, []))), noloc - ; Let (args, Prim (Extern "%js_array", [])), noloc - ; Let (res, Prim (Extern "caml_callback", [ Pv main; Pv args ])), noloc - ] - ; branch = Return res, noloc - } - 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, noloc } + p.blocks + in + let id_arg = Var.fresh_n "x" in + let dummy = Var.fresh_n "dummy" in + let new_start = id_pc + 1 in + let blocks = + Addr.Map.add + new_start + { params = [] + ; body = + [ Let (ident_fn, Closure ([ id_arg ], (id_pc, [ id_arg ]))), noloc + ; Let (dummy, Prim (Extern "caml_initialize_fiber_stack", [])), noloc + ] + ; branch = Branch (p.start, []), noloc + } + blocks + in + { start = new_start; blocks; free_pc = new_start + 1 } + else + 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)), noloc + ; Let (args, Prim (Extern "%js_array", [])), noloc + ; Let (res, Prim (Extern "caml_callback", [ Pv main; Pv args ])), noloc + ] + ; branch = Return res, noloc + } + p.blocks + in + { start = new_start; blocks; free_pc = new_start + 1 } in - p, !cps_calls + p, !cps_calls, !single_version_closures (****) @@ -820,13 +1355,13 @@ let rewrite_toplevel ~cps_needed p = (****) -let split_blocks ~cps_needed (p : Code.program) = +let split_blocks ~cps_needed ~lifter_functions (p : Code.program) = (* Ensure that function applications and effect primitives are in tail position *) let split_block pc block p = let is_split_point i r branch = match i with - | Let (x, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> + | Let (x, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> ( ((not (List.is_empty r)) || match fst branch with @@ -834,6 +1369,11 @@ let split_blocks ~cps_needed (p : Code.program) = | Return x' -> not (Var.equal x x') | _ -> true) && Var.Set.mem x cps_needed + && + match i with + | Let (_, Apply { f; args = _; exact = _ }) -> + not (Var.Set.mem f lifter_functions) + | _ -> true) | _ -> false in let rec split (p : Code.program) pc block accu l branch = @@ -925,9 +1465,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, cps_calls = 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, cps_calls, 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; - p, cps_calls + if debug () + then ( + debug_print "@[After CPS transform:@,"; + Code.Print.program (fun _ _ -> "") p; + debug_print "@]"); + p, cps_calls, single_version_closures diff --git a/compiler/lib/effects.mli b/compiler/lib/effects.mli index 29095a19db..1eabe9e638 100644 --- a/compiler/lib/effects.mli +++ b/compiler/lib/effects.mli @@ -20,8 +20,21 @@ type cps_calls = Code.Var.Set.t val remove_empty_blocks : live_vars:Deadcode.variable_uses -> Code.program -> Code.program +type single_version_closures = Code.Var.Set.t + val f : flow_info:Global_flow.info -> live_vars:Deadcode.variable_uses -> Code.program - -> Code.program * cps_calls + -> Code.program * cps_calls * single_version_closures +(** Perform a partial CPS transform to translate the result effect handlers. + + In addition, if the [doubletranslate] feature is enabled, functions are + created in two versions (direct-style and CPS) and the generated program + switches to CPS 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 + locations of CPS calls, and the set of closures that exist in a single + version (which can be in direct style or CPS). *) diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 412af3089a..a7fac3c257 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -454,7 +454,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 d65a54c64c..3d04173b34 100644 --- a/compiler/lib/freevars.ml +++ b/compiler/lib/freevars.ml @@ -76,8 +76,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 (fst 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 | Set_field _ | Offset_ref _ | Array_set _ | Assign _ -> () @@ -86,11 +89,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 (fst 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 f30723923f..18b84ee6a4 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 f_mutable : Code.program -> Code.Var.Set.t Code.Addr.Map.t diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 1e5ccc87dd..923717c3f2 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -56,6 +56,7 @@ type application_description = { arity : int ; exact : bool ; cps : bool + ; single_version : bool } module Share = struct @@ -134,6 +135,7 @@ module Share = struct let get ~cps_calls + ~single_version_closures ?alias_strings ?(alias_prims = false) ?(alias_apply = true) @@ -151,8 +153,15 @@ module Share = struct | Let (_, Constant c) -> get_constant c share | Let (x, Apply { args; exact; _ }) -> let cps = Var.Set.mem x cps_calls in + let single_version = + (not (Config.Flag.double_translation ())) + || Var.Set.mem x single_version_closures + in if (not exact) || cps - then add_apply { arity = List.length args; exact; cps } share + then + add_apply + { arity = List.length args; exact; cps; single_version } + share else share | Let (_, Special (Alias_prim name)) -> let name = Primitive.resolve name in @@ -244,15 +253,22 @@ module Share = struct try J.EVar (AppMap.find desc t.vars.applies) with Not_found -> let x = - let { arity; exact; cps } = desc in + let { arity; exact; cps; single_version } = desc in Var.fresh_n (Printf.sprintf "caml_%scall%d" - (match exact, cps with - | true, false -> assert false - | true, true -> "cps_exact_" - | false, false -> "" - | false, true -> "cps_") + (match exact, cps, single_version with + | true, true, false -> "cps_exact_double_" + | true, true, true -> "cps_exact_" + | false, false, false -> "double" + | false, false, true -> "" + | false, true, false -> "cps_" + | false, true, true -> + assert (not (Config.Flag.double_translation ())); + "cps_" + | true, false, _ -> + (* Should not happen: no intermediary function needed *) + assert false) arity) in let v = J.V x in @@ -273,6 +289,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 + ; single_version_closures : Effects.single_version_closures } let initial @@ -285,6 +302,7 @@ module Ctx = struct blocks live cps_calls + single_version_closures share debug = { blocks @@ -298,6 +316,7 @@ module Ctx = struct ; deadcode_sentinal ; mutated_vars ; freevars + ; single_version_closures } end @@ -773,49 +792,74 @@ let parallel_renaming back_edge params args continuation queue = (****) -let apply_fun_raw ctx f params exact cps = - 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) J.N - | _ -> J.call f params J.N - 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 cps single_version -> + 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) J.N + | _ -> J.call f params J.N + in + let apply cps single = + (* Adapt if [f] is a (direct-style, CPS) closure pair *) + let real_closure = + if (not (Config.Flag.effects ())) || (not cps) || single + 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.EqEq + , 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 cps + 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 single_version && Config.Flag.double_translation () + then J.(EObj [ Property (PNS (Utf8_string.of_string_exn "cps"), f) ]) + else f + in J.ECond - ( J.EBin - ( J.EqEq - , 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 ] J.N ) - in - if cps - 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") [] J.N - , apply - , J.call (runtime_fun ctx "caml_trampoline_return") [ f; J.array params ] J.N )) - else apply - -let generate_apply_fun ctx { arity; exact; cps } = + ( J.call (runtime_fun ctx "caml_stack_check_depth") [] J.N + , apply cps single_version + , J.call (runtime_fun ctx "caml_trampoline_return") [ f; J.array params ] J.N )) + else apply cps single_version + +let generate_apply_fun ctx { arity; exact; cps; single_version } = let f' = Var.fresh_n "f" in let f = J.V f' in let params = @@ -830,10 +874,13 @@ let generate_apply_fun ctx { arity; exact; cps } = ( None , J.fun_ (f :: params) - [ J.Return_statement (Some (apply_fun_raw ctx f' params' exact cps)), J.N ] + [ ( J.Return_statement + (Some (apply_fun_raw ctx f' params' exact cps single_version)) + , J.N ) + ] J.N ) -let apply_fun ctx f params exact cps loc = +let apply_fun ctx f params exact cps single_version 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 @@ -841,12 +888,12 @@ let apply_fun ctx f params exact cps loc = since the function should get inlined by the JavaScript engines. *) if Config.Flag.inline_callgen () || (exact && not cps) - then apply_fun_raw ctx f params exact cps + then apply_fun_raw ctx f params exact cps single_version else let y = Share.get_apply (generate_apply_fun ctx) - { arity = List.length params; exact; cps } + { arity = List.length params; exact; cps; single_version } ctx.Ctx.share in J.call y (f :: params) loc @@ -1030,6 +1077,10 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list = match e with | Apply { f; args; exact } -> let cps = Var.Set.mem x ctx.Ctx.cps_calls in + let single_version = + (not (Config.Flag.double_translation ())) + || Var.Set.mem f ctx.Ctx.single_version_closures + in let args, prop, queue = List.fold_right ~f:(fun x (args, prop, queue) -> @@ -1040,7 +1091,7 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list = in let (prop', f), queue = access_queue queue f in let prop = or_p prop prop' in - let e = apply_fun ctx f args exact cps loc in + let e = apply_fun ctx f args exact cps single_version loc in (e, prop, queue), [] | Block (tag, a, array_or_not, _mut) -> let contents, prop, queue = @@ -1446,7 +1497,8 @@ and translate_instrs_rev (ctx : Ctx.t) 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 @@ -1950,12 +2002,15 @@ let f ~exported_runtime ~live_vars ~cps_calls + ~single_version_closures ~should_export ~warn_on_unhandled_effect ~deadcode_sentinal debug = let t' = Timer.make () in - let share = Share.get ~cps_calls ~alias_prims:exported_runtime p in + let share = + Share.get ~cps_calls ~single_version_closures ~alias_prims:exported_runtime p + in let exported_runtime = if exported_runtime then Some (Code.Var.fresh_n "runtime", ref false) else None in @@ -1972,6 +2027,7 @@ let f p.blocks live_vars cps_calls + single_version_closures share debug in diff --git a/compiler/lib/generate.mli b/compiler/lib/generate.mli index eaf1ab8f5e..b39b9f465c 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 -> cps_calls:Effects.cps_calls + -> single_version_closures:Effects.single_version_closures -> 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 bb3f7dc540..47dda19995 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..5200ffb7e3 --- /dev/null +++ b/compiler/lib/lambda_lifting_simple.ml @@ -0,0 +1,354 @@ +(* 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 * loc) 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, loc) (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, loc) :: rem), lifters + | i -> program, (i, loc) :: 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 * loc) list * (Var.Set.t * Var.t Var.Map.t)) + l = + match l with + | (Let (f, (Closure (_, (pc', _)) as cl)), loc) :: 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), noloc ]; branch = Return f', noloc } + 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'', []))), noloc) :: 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 }), loc) + :: rem' + , st ) + | (Let (cname, Closure (params, (pc', args))), loc) :: rem -> + let st = traverse ~to_lift var_depth st pc' (depth + 1) in + rewrite_body ((cname, params, pc', args, loc) :: 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, loc) -> + Let (f', Closure (params, (pc, args))), loc) + @ [ ( Let + (tuple, Block (0, Array.of_list f's, NotArray, Immutable)) + , noloc ) + ] + ; branch = Return tuple, noloc + } + 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, []))), noloc) + :: 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 } ) + , noloc ) + :: List.mapi current_contiguous ~f:(fun i (f, _, _, _, loc) -> + Let (f, Field (tuple, i)), loc) + @ 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, loc) -> + Let (f, Closure (params, (pc, args))), loc) + @ 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 1629afc5a8..e3e2d57573 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -179,6 +179,7 @@ module Fragment = struct ; code : Javascript.program pack ; js_string : bool option ; effects : bool option + ; double_translate : bool option ; fragment_target : Target_env.t option ; aliases : StringSet.t } @@ -249,6 +250,7 @@ module Fragment = struct ; code = Ok code ; js_string = None ; effects = None + ; double_translate = None ; fragment_target = None ; aliases = StringSet.empty } @@ -299,6 +301,15 @@ module Fragment = struct if Option.is_some fragment.effects then Format.eprintf "Duplicated effects in %s\n" (loc pi); { fragment with effects = Some b } + | (`Ifnot "doubletranslate" | `If "doubletranslate") as i -> + let b = + match i with + | `If _ -> true + | `Ifnot _ -> false + in + if Option.is_some fragment.double_translate + then Format.eprintf "Duplicated doubletranslate in %s\n" (loc pi); + { fragment with double_translate = Some b } | `If name when Option.is_some (Target_env.of_string name) -> if Option.is_some fragment.fragment_target then Format.eprintf "Duplicated target_env in %s\n" (loc pi); @@ -453,6 +464,7 @@ let load_fragment ~target_env ~filename (f : Fragment.t) = ; code ; js_string ; effects + ; double_translate ; fragment_target ; aliases ; has_macro @@ -467,9 +479,15 @@ let load_fragment ~target_env ~filename (f : Fragment.t) = | Some true, false | Some false, true -> true | None, _ | Some true, true | Some false, false -> false in + let ignore_because_of_double_translate = + match double_translate, Config.Flag.double_translation () with + | Some true, false | Some false, true -> true + | None, _ | Some true, true | Some false, false -> false + in if (not version_constraint_ok) || ignore_because_of_js_string || ignore_because_of_effects + || ignore_because_of_double_translate then `Ignored else match provides with diff --git a/compiler/lib/phisimpl.ml b/compiler/lib/phisimpl.ml index bbb3537af9..7a27019278 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 e1a108e6a6..6db007b937 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -1141,6 +1141,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 4e735576c3..2572d29aa0 100644 --- a/compiler/lib/subst.ml +++ b/compiler/lib/subst.ml @@ -23,80 +23,82 @@ 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) -> Field (s x, n) - | 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, y) -> Set_field (s x, n, s y) - | Offset_ref (x, n) -> Offset_ref (s x, n) - | Array_set (x, y, z) -> Array_set (s x, s y, s z) - -let instrs s l = List.map l ~f:(fun (i, loc) -> instr s i, loc) - -let last s (l, loc) = - let 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) - in - l, loc - -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) +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) -> Field (s x, n) + | 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, y) -> Set_field (s x, n, s y) + | Offset_ref (x, n) -> Offset_ref (s x, n) + | Array_set (x, y, z) -> Array_set (s x, s y, s z) + + let instrs s l = List.map l ~f:(fun (i, loc) -> instr s i, loc) + + let last s (l, loc) = + let 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) in - Code.fold_children - blocks - pc - (fun pc (blocks, visited) -> cont' s pc blocks visited) - (blocks, visited) + l, loc + + let block s block = + { params = block.params; body = instrs s block.body; branch = last s block.branch } -let cont s addr p = - let blocks, _ = cont' s addr p.blocks Addr.Set.empty in - { p with blocks } + 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 (****) @@ -111,3 +113,56 @@ 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) -> Field (s x, n) + | 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, y) -> Set_field (s x, n, s y) + | Offset_ref (x, n) -> Offset_ref (s x, n) + | Array_set (x, y, z) -> Array_set (s x, s y, s z) + + let instrs s l = List.map l ~f:(fun (i, loc) -> instr s i, loc) + + let last s (l, loc) = + let 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) + in + l, loc + + 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 faa7ac6b27..80c6de91ed 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 * loc) list -> (instr * loc) list + val instrs : (Var.t -> Var.t) -> (instr * loc) list -> (instr * loc) list -val block : (Var.t -> Var.t) -> block -> block + val block : (Var.t -> Var.t) -> block -> block -val last : (Var.t -> Var.t) -> last * loc -> last * loc + val last : (Var.t -> Var.t) -> last * loc -> last * loc -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 * loc) list -> (instr * loc) 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 a0d8f7b58a..439792ce84 100644 --- a/compiler/tests-compiler/direct_calls.ml +++ b/compiler/tests-compiler/direct_calls.ml @@ -97,7 +97,8 @@ let%expect_test "direct calls without --enable effects" = M1[1].call(null, 1); return M2[1].call(null, 2); } - //end |}] + //end + |}] let%expect_test "direct calls with --enable effects" = let code = @@ -159,38 +160,39 @@ let%expect_test "direct calls with --enable effects" = return raise(e$0); }); return caml_cps_exact_call2 - (g, x, function(_f_){caml_pop_trap(); return cont(undef);}); + (g, x, function(_t_){caml_pop_trap(); return cont(undef);}); } return caml_cps_exact_call3 (f, function(x, cont){return cont(undef);}, 7, - function(_d_){ + function(_r_){ return caml_cps_exact_call3 (f, function(x, cont){ return caml_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(undef), M2 = F(undef), _c_ = M2[1].call(null, 2); - return cont([0, M1[1].call(null, 1), _c_]); + var M1 = F(undef), M2 = F(undef), _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_cps_call3(Stdlib_Printf[2], _o_, x, cont);} return [0, f]; } var M1 = F(undef), M2 = F(undef); return caml_cps_exact_call2 (M1[1], 1, - function(_b_){return caml_cps_exact_call2(M2[1], 2, cont);}); + function(_p_){return caml_cps_exact_call2(M2[1], 2, cont);}); } - //end |}] + //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..4684602099 --- /dev/null +++ b/compiler/tests-compiler/double-translation/direct_calls.ml @@ -0,0 +1,224 @@ +(* 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_doublecall1(f, a0){ + return (f.l >= 0 ? f.l : f.l = f.length) == 1 + ? f(a0) + : runtime.caml_call_gen(f, [a0]); + } + function caml_doublecall2(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_cps_exact_double_call2(f, a0, a1){ + return runtime.caml_stack_check_depth() + ? f.cps.call(null, a0, a1) + : runtime.caml_trampoline_return(f, [a0, a1]); + } + function caml_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_cps_exact_double_call3(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 + undef = undefined, + 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_doublecall1(g, undef); return;} + catch(e$0){ + var e = caml_wrap_exception(e$0); + throw caml_maybe_attach_backtrace(e, 0); + } + } + f(function(x){return;}, undef); + f(function(x){return;}, undef); + return 0; + } + function test1$1(param, cont){ + function f(g, x){ + try{caml_doublecall1(g, undef); return;} + catch(e$0){ + var e = caml_wrap_exception(e$0); + throw caml_maybe_attach_backtrace(e, 0); + } + } + f(function(x){return;}, undef); + f(function(x){return;}, undef); + return cont(0); + } + var test1 = caml_cps_closure(test1$0, test1$1); + function f$0(){ + function f$0(g, x){ + try{caml_doublecall1(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_cps_exact_double_call2 + (g, x, function(_y_){caml_pop_trap(); return cont(undef);}); + } + var f = caml_cps_closure(f$0, f$1); + return f; + } + function _h_(){ + return caml_cps_closure + (function(x){return;}, function(x, cont){return cont(undef);}); + } + function _j_(){ + return caml_cps_closure + (function(x){return caml_doublecall2(Stdlib[28], x, cst_a$0);}, + function(x, cont){ + return caml_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_cps_exact_double_call3 + (f, + _h_(), + 7, + function(_w_){ + return caml_cps_exact_double_call3 + (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(undef), M2 = F(undef), _v_ = caml_doublecall1(M2[1], 2); + return [0, caml_doublecall1(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(undef), M2 = F(undef), _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_doublecall2(Stdlib_Printf[2], _s_, x);} + function f$1(x, cont){ + return caml_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(undef), M2 = F(undef); + caml_doublecall1(M1[1], 1); + return caml_doublecall1(M2[1], 2); + } + function test4$1(x, cont){ + function F(symbol){var f$0 = f(); return [0, f$0];} + var M1 = F(undef), M2 = F(undef); + return caml_cps_exact_double_call2 + (M1[1], + 1, + function(_t_){ + return caml_cps_exact_double_call2(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..22454723c5 --- /dev/null +++ b/compiler/tests-compiler/double-translation/effects_continuations.ml @@ -0,0 +1,301 @@ +(* 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_doublecall1(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_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_doublecall1(Stdlib[79], cst_toto$0) + : caml_doublecall1(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_cps_call2(Stdlib[79], cst_toto$0, _v_) + : caml_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_doublecall1(Stdlib_Printf[3], _h_); + else + caml_doublecall1(Stdlib_Printf[3], _i_); + return 7; + } + //end + function cond2$1(b, cont){ + function _t_(_u_){return cont(7);} + return b + ? caml_cps_call2(Stdlib_Printf[3], _h_, _t_) + : caml_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_doublecall1(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_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_doublecall1(Stdlib[79], cst_static_examples_ml); + for(;;){ + var line = caml_doublecall1(Stdlib[83], ic); + if(b) caml_doublecall1(Stdlib[53], line); + } + } + //end + function loop1$1(b, cont){ + return caml_cps_call2 + (Stdlib[79], + cst_static_examples_ml, + function(ic){ + function _p_(_q_){ + return caml_cps_call2 + (Stdlib[83], + ic, + function(line){ + return b + ? caml_cps_call2(Stdlib[53], line, _p_) + : caml_cps_exact_call1(_p_, 0); + }); + } + return _p_(0); + }); + } + //end + var loop1 = caml_cps_closure(loop1$0, loop1$1); + //end + function loop2$0(param){ + var ic = caml_doublecall1(Stdlib[79], cst_static_examples_ml$0); + caml_doublecall1(Stdlib_Printf[3], _k_); + for(;;){ + var line = caml_doublecall1(Stdlib[83], ic); + caml_doublecall1(Stdlib[53], line); + } + } + //end + function loop2$1(param, cont){ + return caml_cps_call2 + (Stdlib[79], + cst_static_examples_ml$0, + function(ic){ + function _n_(_o_){ + return caml_cps_call2 + (Stdlib[83], + ic, + function(line){ + return caml_cps_call2(Stdlib[53], line, _n_); + }); + } + return caml_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_doublecall1(list_rev, _l_), x = l; + for(;;){if(! x) return l; var r = x[2]; x = r;} + } + //end + function loop3$1(param, cont){ + return caml_cps_call2 + (list_rev, + _l_, + function(l){ + function _m_(x){ + if(! x) return cont(l); + var r = x[2]; + return caml_cps_exact_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..92f318abe5 --- /dev/null +++ b/compiler/tests-compiler/double-translation/effects_exceptions.ml @@ -0,0 +1,195 @@ +(* 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_doublecall1(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_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_doublecall1(f, 0); return _l_;} + catch(_m_){ + var l$0 = l; + for(;;){ + var match = caml_doublecall1(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_cps_call2 + (g, + l, + function(match){ + if(72330306 <= match[1]){ + var l = match[2]; + return caml_cps_exact_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_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_doublecall1(g, 0), s = _g_;}catch(_h_){var s = cst$1;} + return caml_doublecall2(Stdlib[28], s, cst_aaa); + } + //end + function handler_is_merge_node$1(g, cont){ + function _d_(s){return caml_cps_call3(Stdlib[28], s, cst_aaa, cont);} + caml_push_trap(function(_f_){return _d_(cst$1);}); + return caml_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..2dda2642d9 --- /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_doublecall1(f, a0){ + return (f.l >= 0 ? f.l : f.l = f.length) == 1 + ? f(a0) + : runtime.caml_call_gen(f, [a0]); + } + function caml_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 + undef = undefined, + 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_doublecall1(Stdlib_Printf[2], _b_);} + function g$1(param, cont){ + return caml_cps_call2(Stdlib_Printf[2], _b_, cont); + } + var g = runtime.caml_cps_closure(g$0, g$1); + g(undef); + var i = 1; + for(;;){ + g(undef); + var _c_ = i + 1 | 0; + if(5 === i){ + g(undef); + 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..8fed80c3a4 100644 --- a/compiler/tests-compiler/effects.ml +++ b/compiler/tests-compiler/effects.ml @@ -53,11 +53,12 @@ let fff () = ? cont([0, function(k, cont){return cont(11);}]) : cont(0); }], - function(_b_){ + function(_f_){ return caml_cps_call2 (Stdlib_Printf[2], - _a_, - function(_c_){return caml_cps_call2(_c_, _b_, cont);}); + _e_, + function(_g_){return caml_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..1b65bb0836 100644 --- a/compiler/tests-compiler/effects_continuations.ml +++ b/compiler/tests-compiler/effects_continuations.ml @@ -101,63 +101,62 @@ 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 (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_cps_call2(Stdlib[79], cst_toto$0, _v_) + : caml_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_cps_call2(Stdlib_Printf[3], _h_, _t_) + : caml_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_cps_call2(Stdlib_Printf[3], _j_, _r_); } //end function loop1(b, cont){ @@ -165,17 +164,17 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = (Stdlib[79], cst_static_examples_ml, function(ic){ - function _i_(_j_){ + function _p_(_q_){ return caml_cps_call2 (Stdlib[83], ic, function(line){ return b - ? caml_cps_call2(Stdlib[53], line, _i_) - : caml_cps_exact_call1(_i_, 0); + ? caml_cps_call2(Stdlib[53], line, _p_) + : caml_cps_exact_call1(_p_, 0); }); } - return _i_(0); + return _p_(0); }); } //end @@ -184,29 +183,30 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = (Stdlib[79], cst_static_examples_ml$0, function(ic){ - function _g_(_h_){ + function _n_(_o_){ return caml_cps_call2 (Stdlib[83], ic, function(line){ - return caml_cps_call2(Stdlib[53], line, _g_); + return caml_cps_call2(Stdlib[53], line, _n_); }); } - return caml_cps_call2(Stdlib_Printf[3], _d_, _g_); + return caml_cps_call2(Stdlib_Printf[3], _k_, _n_); }); } //end function loop3(param, cont){ return caml_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_cps_exact_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..f0dee813d8 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 (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){ + (function(_h_){ + function _i_(l){ return caml_cps_call2 (g, l, function(match){ if(72330306 <= match[1]){ var l = match[2]; - return caml_cps_exact_call1(_f_, l); + return caml_cps_exact_call1(_i_, l); } var exn = match[2], @@ -116,18 +116,20 @@ 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_);}); + (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_cps_call3(Stdlib[28], s, cst_aaa, cont);} + caml_push_trap(function(_f_){return _d_(cst$1);}); + return caml_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 596b47f1b7..5176a97516 100644 --- a/compiler/tests-compiler/effects_toplevel.ml +++ b/compiler/tests-compiler/effects_toplevel.ml @@ -34,7 +34,6 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = print_program code; [%expect {| - (function(globalThis){ "use strict"; var @@ -68,30 +67,31 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = undef = undefined, 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_cps_call2(Stdlib_Printf[2], _b_, cont); } caml_callback(g, [undef]); - function _b_(i){ + function _c_(i){ return caml_cps_exact_call2 (g, undef, - 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_cps_exact_call1(_c_, _e_); caml_callback(g, [undef]); var Test = [0]; runtime.caml_register_global(2, Test, "Test"); return; }); } - return _b_(1); + return _c_(1); }, []); } (globalThis)); - //end |}] + //end + |}] 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 17044c33e8..663078fc18 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/effect.js b/runtime/effect.js index 886c1ed29c..329399a91b 100644 --- a/runtime/effect.js +++ b/runtime/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 @@ -65,6 +70,21 @@ 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 @@ -72,6 +92,14 @@ 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 @@ -101,8 +129,22 @@ function caml_pop_fiber() { return rem.k; } +//Provides: caml_prepare_tramp +//If: effects +//If: !doubletranslate +function caml_prepare_tramp(handler) { + return handler; +} + +//Provides: caml_prepare_tramp +//If: effects +//If: doubletranslate +function caml_prepare_tramp(handler) { + return {cps: handler}; +} + //Provides: caml_perform_effect -//Requires: caml_pop_fiber, caml_stack_check_depth, caml_trampoline_return, caml_exn_stack, caml_fiber_stack +//Requires: caml_pop_fiber, caml_stack_check_depth, caml_trampoline_return, caml_exn_stack, caml_fiber_stack, caml_prepare_tramp //If: effects function caml_perform_effect(eff, cont, k0) { // Allocate a continuation if we don't already have one @@ -116,17 +158,47 @@ function caml_perform_effect(eff, cont, k0) { // The handler is defined in Stdlib.Effect, so we know that the arity matches var k1 = caml_pop_fiber(); return caml_stack_check_depth()?handler(eff,cont,k1,k1) - :caml_trampoline_return(handler,[eff,cont,k1,k1]); + :caml_trampoline_return(caml_prepare_tramp(handler),[eff,cont,k1,k1]); +} + +//Provides: caml_call_fun +//Requires: caml_call_gen +//If: effects +//If: !doubletranslate +function caml_call_fun(f, args) { + return caml_call_gen(f, args); +} + +//Provides: caml_call_fun +//Requires: caml_call_gen_cps +//If: effects +//If: doubletranslate +function caml_call_fun(f, args) { + return caml_call_gen_cps(f, args); +} + +//Provides: caml_get_fun +//If: effects +//If: !doubletranslate +function caml_get_fun(f) { + return f; +} + +//Provides: caml_get_fun +//If: effects +//If: doubletranslate +function caml_get_fun(f) { + return f.cps; } //Provides: caml_alloc_stack -//Requires: caml_pop_fiber, caml_fiber_stack, caml_call_gen, caml_stack_check_depth, caml_trampoline_return +//Requires: caml_pop_fiber, caml_fiber_stack, caml_stack_check_depth, caml_trampoline_return, caml_call_fun, caml_get_fun //If: effects function caml_alloc_stack(hv, hx, hf) { function call(i, x) { var f=caml_fiber_stack.h[i]; var args = [x, caml_pop_fiber()]; - return caml_stack_check_depth()?caml_call_gen(f,args) + return caml_stack_check_depth()?caml_call_fun(f,args) :caml_trampoline_return(f,args); } function hval(x) { @@ -137,7 +209,7 @@ function caml_alloc_stack(hv, hx, hf) { // Call [hx] in the parent fiber return call(2, e); } - return [0, hval, [0, hexn, 0], [0, hv, hx, hf], 0]; + return [0, hval, [0, hexn, 0], [0, hv, hx, caml_get_fun(hf)], 0]; } //Provides: caml_alloc_stack @@ -190,3 +262,34 @@ 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/jslib.js b/runtime/jslib.js index 59d954d91f..a42c9a49c9 100644 --- a/runtime/jslib.js +++ b/runtime/jslib.js @@ -53,7 +53,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 @@ -69,6 +70,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) { @@ -112,6 +114,38 @@ 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/stdlib.js b/runtime/stdlib.js index 01285c96ec..38a9ef0e9d 100644 --- a/runtime/stdlib.js +++ b/runtime/stdlib.js @@ -68,23 +68,24 @@ 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); args[n - 1] = function (g) { - if (typeof g !== "function") return k(g); + if(typeof g !== "function") return k(g); var args = rest.slice(); 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]; @@ -125,6 +126,106 @@ 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/stdlib_modern.js b/runtime/stdlib_modern.js index 26c5ccd8d7..09f8599a26 100644 --- a/runtime/stdlib_modern.js +++ b/runtime/stdlib_modern.js @@ -66,6 +66,8 @@ function caml_call_gen(f, args) { //Provides: caml_call_gen (const, shallow) //If: effects +//If: !doubletranslate +//Weakdef function caml_call_gen(f, args) { var n = (f.l >= 0)?f.l:(f.l = f.length); var argsLen = args.length; @@ -121,3 +123,102 @@ 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];