diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 7c0ed54ff..a64e088e9 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -95,7 +95,10 @@ let effects p = then ( if debug () then Format.eprintf "Effects...@."; p |> Deadcode.f +> Effects.f +> map_fst Lambda_lifting.f) - else p, (Code.Var.Set.empty : Effects.cps_calls), (Code.Var.Set.empty : Effects.in_cps) + else + ( p + , (Code.Var.Set.empty : Effects.trampolined_calls) + , (Code.Var.Set.empty : Effects.in_cps) ) let exact_calls profile p = if not (Config.Flag.effects ()) @@ -179,14 +182,14 @@ let generate ~exported_runtime ~wrap_with_fun ~warn_on_unhandled_effect - ((p, live_vars), cps_calls, _) = + ((p, live_vars), trampolined_calls, _) = if times () then Format.eprintf "Start Generation...@."; let should_export = should_export wrap_with_fun in Generate.f p ~exported_runtime ~live_vars - ~cps_calls + ~trampolined_calls ~should_export ~warn_on_unhandled_effect d diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 1dd38eb10..c6b904ec2 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -247,7 +247,7 @@ let jump_closures blocks_to_transform idom : jump_closures = idom { closure_of_jump = Addr.Map.empty; closures_of_alloc_site = Addr.Map.empty } -type cps_calls = Var.Set.t +type trampolined_calls = Var.Set.t type in_cps = Var.Set.t @@ -265,7 +265,7 @@ type st = ; block_order : (Addr.t, int) Hashtbl.t ; live_vars : Deadcode.variable_uses ; flow_info : Global_flow.info - ; cps_calls : cps_calls ref + ; trampolined_calls : trampolined_calls ref ; in_cps : in_cps ref } @@ -286,7 +286,7 @@ let allocate_closure ~st ~params ~body ~branch loc = let tail_call ~st ?(instrs = []) ~exact ~in_cps ~check ~f args loc = assert (exact || check); let ret = Var.fresh () in - if check then st.cps_calls := Var.Set.add ret !(st.cps_calls); + if check then st.trampolined_calls := Var.Set.add ret !(st.trampolined_calls); if in_cps then st.in_cps := Var.Set.add ret !(st.in_cps); instrs @ [ Let (ret, Apply { f; args; exact }), loc ], (Return ret, loc) @@ -617,7 +617,7 @@ let cps_block ~st ~k pc block = let cps_transform ~live_vars ~flow_info ~cps_needed p = let closure_info = Hashtbl.create 16 in - let cps_calls = ref Var.Set.empty in + let trampolined_calls = ref Var.Set.empty in let in_cps = ref Var.Set.empty in let p = Code.fold_closures_innermost_first @@ -677,7 +677,7 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = ; block_order = cfg.block_order ; flow_info ; live_vars - ; cps_calls + ; trampolined_calls ; in_cps } in @@ -755,7 +755,7 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = in { start = new_start; blocks; free_pc = new_start + 1 } in - p, !cps_calls, !in_cps + p, !trampolined_calls, !in_cps (****) @@ -951,6 +951,6 @@ let f (p, live_vars) = 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, in_cps = cps_transform ~live_vars ~flow_info ~cps_needed p in + let p, trampolined_calls, in_cps = cps_transform ~live_vars ~flow_info ~cps_needed p in if Debug.find "times" () then Format.eprintf " effects: %a@." Timer.print t; - p, cps_calls, in_cps + p, trampolined_calls, in_cps diff --git a/compiler/lib/effects.mli b/compiler/lib/effects.mli index f1a4d7450..44bc06104 100644 --- a/compiler/lib/effects.mli +++ b/compiler/lib/effects.mli @@ -16,8 +16,8 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type cps_calls = Code.Var.Set.t +type trampolined_calls = Code.Var.Set.t type in_cps = Code.Var.Set.t -val f : Code.program * Deadcode.variable_uses -> Code.program * cps_calls * in_cps +val f : Code.program * Deadcode.variable_uses -> Code.program * trampolined_calls * in_cps diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index cafd0748a..3571dcb30 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -66,7 +66,7 @@ let list_group f g l = type application_description = { arity : int ; exact : bool - ; cps : bool + ; trampolined : bool } module Share = struct @@ -144,7 +144,7 @@ module Share = struct | _ -> t) let get - ~cps_calls + ~trampolined_calls ?alias_strings ?(alias_prims = false) ?(alias_apply = true) @@ -161,9 +161,9 @@ module Share = struct match i with | Let (_, Constant c) -> get_constant c share | Let (x, Apply { args; exact; _ }) -> - let cps = Var.Set.mem x cps_calls in - if (not exact) || cps - then add_apply { arity = List.length args; exact; cps } share + let trampolined = Var.Set.mem x trampolined_calls in + if (not exact) || trampolined + then add_apply { arity = List.length args; exact; trampolined } share else share | Let (_, Prim (Extern "%closure", [ Pc (String name) ])) -> let name = Primitive.resolve name in @@ -255,11 +255,11 @@ 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; trampolined } = desc in Var.fresh_n (Printf.sprintf "caml_%scall%d" - (match exact, cps with + (match exact, trampolined with | true, false -> assert false | true, true -> "cps_exact_" | false, false -> "" @@ -280,7 +280,7 @@ module Ctx = struct ; exported_runtime : (Code.Var.t * bool ref) option ; should_export : bool ; effect_warning : bool ref - ; cps_calls : Effects.cps_calls + ; trampolined_calls : Effects.trampolined_calls } let initial @@ -289,7 +289,7 @@ module Ctx = struct ~should_export blocks live - cps_calls + trampolined_calls share debug = { blocks @@ -299,7 +299,7 @@ module Ctx = struct ; exported_runtime ; should_export ; effect_warning = ref (not warn_on_unhandled_effect) - ; cps_calls + ; trampolined_calls } end @@ -951,7 +951,7 @@ let parallel_renaming params args continuation queue = (****) -let apply_fun_raw ctx f params exact cps = +let apply_fun_raw ctx f params exact trampolined = let n = List.length params in let apply_directly = (* Make sure we are performing a regular call, not a (slower) @@ -980,7 +980,7 @@ let apply_fun_raw ctx f params exact cps = , apply_directly , J.call (runtime_fun ctx "caml_call_gen") [ f; J.array params ] J.N ) in - if cps + if trampolined then ( assert (Config.Flag.effects ()); (* When supporting effect, we systematically perform tailcall @@ -993,7 +993,7 @@ let apply_fun_raw ctx f params exact cps = , J.call (runtime_fun ctx "caml_trampoline_return") [ f; J.array params ] J.N )) else apply -let generate_apply_fun ctx { arity; exact; cps } = +let generate_apply_fun ctx { arity; exact; trampolined } = let f' = Var.fresh_n "f" in let f = J.V f' in let params = @@ -1008,23 +1008,24 @@ 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 trampolined)), J.N + ] J.N ) -let apply_fun ctx f params exact cps loc = +let apply_fun ctx f params exact trampolined 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 the test, and we expect the performance impact to be low 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 + if Config.Flag.inline_callgen () || (exact && not trampolined) + then apply_fun_raw ctx f params exact trampolined else let y = Share.get_apply (generate_apply_fun ctx) - { arity = List.length params; exact; cps } + { arity = List.length params; exact; trampolined } ctx.Ctx.share in J.call y (f :: params) loc @@ -1209,7 +1210,7 @@ let throw_statement ctx cx k loc = 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 trampolined = Var.Set.mem x ctx.Ctx.trampolined_calls in let args, prop, queue = List.fold_right ~f:(fun x (args, prop, queue) -> @@ -1220,7 +1221,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 trampolined loc in (e, prop, queue), [] | Block (tag, a, array_or_not) -> let contents, prop, queue = @@ -2176,12 +2177,12 @@ let f (p : Code.program) ~exported_runtime ~live_vars - ~cps_calls + ~trampolined_calls ~should_export ~warn_on_unhandled_effect debug = let t' = Timer.make () in - let share = Share.get ~cps_calls ~alias_prims:exported_runtime p in + let share = Share.get ~trampolined_calls ~alias_prims:exported_runtime p in let exported_runtime = if exported_runtime then Some (Code.Var.fresh_n "runtime", ref false) else None in @@ -2192,7 +2193,7 @@ let f ~should_export p.blocks live_vars - cps_calls + trampolined_calls share debug in diff --git a/compiler/lib/generate.mli b/compiler/lib/generate.mli index 21bb63ff5..d8fe84647 100644 --- a/compiler/lib/generate.mli +++ b/compiler/lib/generate.mli @@ -22,7 +22,7 @@ val f : Code.program -> exported_runtime:bool -> live_vars:Deadcode.variable_uses - -> cps_calls:Effects.cps_calls + -> trampolined_calls:Effects.trampolined_calls -> should_export:bool -> warn_on_unhandled_effect:bool -> Parse_bytecode.Debug.t