From 6b05a5c7c609a9f8310b41b1466de8aca2fcae85 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Mon, 18 Nov 2024 15:29:46 +0100 Subject: [PATCH 1/2] No lambda-lifting when producing Wasm --- compiler/lib/driver.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 6d3fee9708..8af7ce4865 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -115,9 +115,9 @@ let effects ~deadcode_sentinal p = p |> Effects.f ~flow_info:info ~live_vars |> map_fst - (match effects with - | `Double_translation -> Fun.id - | `Cps -> Lambda_lifting.f) + (match Config.target (), effects with + | `Wasm, _ | _, `Double_translation -> Fun.id + | `JavaScript, `Cps -> Lambda_lifting.f) | `Disabled | `Jspi -> ( p , (Code.Var.Set.empty : Effects.trampolined_calls) From 5b61065fad59c703e6ac8a0e80d5a0c6853dcb8f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 15 Nov 2024 13:47:42 +0100 Subject: [PATCH 2/2] Optimize calling a known function --- compiler/lib-wasm/generate.ml | 17 +++++-- compiler/lib/code.ml | 17 +++++-- compiler/lib/code.mli | 7 ++- compiler/lib/effects.ml | 68 ++++++++++++++++----------- compiler/lib/generate.ml | 14 +++++- compiler/lib/generate_closure.ml | 14 +++--- compiler/lib/global_flow.ml | 39 ++++++++++----- compiler/lib/global_flow.mli | 4 +- compiler/lib/inline.ml | 5 +- compiler/lib/lambda_lifting.ml | 2 +- compiler/lib/lambda_lifting_simple.ml | 4 +- compiler/lib/parse_bytecode.ml | 18 +++---- compiler/lib/pure_fun.ml | 4 +- compiler/lib/specialize.ml | 34 ++++++++------ compiler/lib/specialize.mli | 7 ++- compiler/lib/subst.ml | 8 ++-- 16 files changed, 165 insertions(+), 97 deletions(-) diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index 308f8d5602..e97c88734c 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -184,10 +184,16 @@ module Generate (Target : Target_sig.S) = struct let zero_divide_pc = -2 + let exact_call kind = + match kind with + | Generic -> false + | Exact | Known _ -> true + let rec translate_expr ctx context x e = match e with - | Apply { f; args; exact } - when exact || List.length args = if Var.Set.mem x ctx.in_cps then 2 else 1 -> + | Apply { f; args; kind } + when exact_call kind || List.length args = if Var.Set.mem x ctx.in_cps then 2 else 1 + -> let rec loop acc l = match l with | [] -> ( @@ -204,13 +210,14 @@ module Generate (Target : Target_sig.S) = struct if b then return (W.Call (f, List.rev (closure :: acc))) else - match funct with - | W.RefFunc g -> + match funct, kind with + | W.RefFunc g, _ -> (* Functions with constant closures ignore their environment. In case of partial application, we still need the closure. *) - let* cl = if exact then Value.unit else return closure in + let* cl = if exact_call kind then Value.unit else return closure in return (W.Call (g, List.rev (cl :: acc))) + | _, Known g -> return (W.Call (g, List.rev (closure :: acc))) | _ -> return (W.Call_ref (ty, funct, List.rev (closure :: acc)))) | x :: r -> let* x = load x in diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index 05249533e8..dd257149bc 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -412,11 +412,16 @@ type field_type = | Non_float | Float +type apply_kind = + | Generic + | Exact + | Known of Var.t + type expr = | Apply of { f : Var.t ; args : Var.t list - ; exact : bool + ; kind : apply_kind } | Block of int * Var.t array * array_or_not * mutability | Field of Var.t * int * field_type @@ -556,10 +561,12 @@ module Print = struct let expr f e = match e with - | Apply { f = g; args; exact } -> - if exact - then Format.fprintf f "%a!(%a)" Var.print g var_list args - else Format.fprintf f "%a(%a)" Var.print g var_list args + | Apply { f = g; args; kind } -> ( + match kind with + | Generic -> Format.fprintf f "%a(%a)" Var.print g var_list args + | Exact -> Format.fprintf f "%a!(%a)" Var.print g var_list args + | Known h -> Format.fprintf f "%a{=%a}(%a)" Var.print g Var.print h var_list args + ) | Block (t, a, _, mut) -> Format.fprintf f diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index e39038a8bc..95ac437450 100644 --- a/compiler/lib/code.mli +++ b/compiler/lib/code.mli @@ -208,11 +208,16 @@ type field_type = | Non_float | Float +type apply_kind = + | Generic + | Exact (* # of arguments = # of parameters *) + | Known of Var.t (* Exact and we know which function is called *) + type expr = | Apply of { f : Var.t ; args : Var.t list - ; exact : bool (* if true, then # of arguments = # of parameters *) + ; kind : apply_kind } | Block of int * Var.t array * array_or_not * mutability | Field of Var.t * int * field_type diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 3d1debdeb3..08027ec714 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -336,12 +336,15 @@ let allocate_closure ~st ~params ~body ~branch = let name = Var.fresh () in [ Let (name, Closure (params, (pc, []))) ], name -let tail_call ~st ?(instrs = []) ~exact ~in_cps ~check ~f args = - assert (exact || check); +let tail_call ~st ?(instrs = []) ~kind ~in_cps ~check ~f args = + assert ( + match kind with + | Generic -> check + | Exact | Known _ -> true); let ret = Var.fresh () in 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 }) ], Return ret + instrs @ [ Let (ret, Apply { f; args; kind }) ], Return ret let cps_branch ~st ~src (pc, args) = match Addr.Set.mem pc st.blocks_to_transform with @@ -359,14 +362,8 @@ let cps_branch ~st ~src (pc, args) = (* 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 - ~in_cps:false - ~check - ~f:(closure_of_pc ~st pc) - args + let f = closure_of_pc ~st pc in + tail_call ~st ~instrs ~kind:(Known f) ~in_cps:false ~check ~f args let cps_jump_cont ~st ~src ((pc, _) as cont) = match Addr.Set.mem pc st.blocks_to_transform with @@ -433,7 +430,7 @@ let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last = (* If the number of successive 'returns' is unbounded in CPS, it means that we have an unbounded of calls in direct style (even with tail call optimization) *) - tail_call ~st ~exact:true ~in_cps:false ~check:false ~f:k [ x ] + tail_call ~st ~kind:Exact ~in_cps:false ~check:false ~f:k [ x ] | Raise (x, rmode) -> ( assert (List.is_empty alloc_jump_closures); match Hashtbl.find_opt st.matching_exn_handler pc with @@ -468,7 +465,7 @@ let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last = tail_call ~st ~instrs:(Let (exn_handler, Prim (Extern "caml_pop_trap", [])) :: instrs) - ~exact:true + ~kind:Exact ~in_cps:false ~check:false ~f:exn_handler @@ -522,6 +519,14 @@ let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last = @ (Let (exn_handler, Prim (Extern "caml_pop_trap", [])) :: body) , branch )) +let refine_kind k k' = + match k, k' with + | Known _, _ -> k + | _, Known _ -> k' + | Exact, _ -> k + | _, Exact -> k' + | Generic, Generic -> k + let rewrite_instr ~st (instr : instr) : instr = match instr with | Let (x, Closure (_, (pc, _))) when Var.Set.mem x st.cps_needed -> @@ -542,15 +547,21 @@ let rewrite_instr ~st (instr : instr) : instr = (Extern "caml_alloc_dummy_function", [ size; Pc (Int (Targetint.succ a)) ]) ) | _ -> assert false) - | Let (x, Apply { f; args; _ }) when not (Var.Set.mem x st.cps_needed) -> + | Let (x, Apply { f; args; kind }) 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 ( + let kind' = (* If this function is unknown to the global flow analysis, then it was introduced by the lambda lifting and we don't have exactness info any more. *) - Var.idx f >= Var.Tbl.length st.flow_info.info_approximation - || Global_flow.exact_call st.flow_info f (List.length args)); - Let (x, Apply { f; args; exact = true }) + if Var.idx f >= Var.Tbl.length st.flow_info.info_approximation + then Exact + else Global_flow.apply_kind st.flow_info f (List.length args) + in + assert ( + match kind' with + | Generic -> false + | Exact | Known _ -> true); + Let (x, Apply { f; args; kind = refine_kind kind kind' }) | Let (_, e) when effect_primitive_or_application e -> (* For the CPS target, applications of CPS functions and effect primitives require more work (allocating a continuation and/or modifying end-of-block branches) and @@ -558,11 +569,12 @@ let rewrite_instr ~st (instr : instr) : instr = assert false | _ -> instr -let call_exact flow_info (f : Var.t) nargs : bool = +let call_kind flow_info (f : Var.t) nargs = (* If [f] is unknown to the global flow analysis, then it was introduced by the lambda lifting and we don't have exactness about it. *) - Var.idx f < Var.Tbl.length flow_info.Global_flow.info_approximation - && Global_flow.exact_call flow_info f nargs + if Var.idx f >= Var.Tbl.length flow_info.Global_flow.info_approximation + then Generic + else Global_flow.apply_kind flow_info f nargs let cps_instr ~st (instr : instr) : instr list = match instr with @@ -571,7 +583,7 @@ let cps_instr ~st (instr : instr) : instr list = Otherwise, the runtime primitive is used. *) let unit = Var.fresh_n "unit" in [ Let (unit, Constant (Int Targetint.zero)) - ; Let (x, Apply { exact = call_exact st.flow_info f 1; f; args = [ unit ] }) + ; Let (x, Apply { kind = call_kind st.flow_info f 1; f; args = [ unit ] }) ] | _ -> [ rewrite_instr ~st instr ] @@ -646,11 +658,11 @@ let cps_block ~st ~k ~orig_pc block = [ Let (x, e) ], Return x) in match e with - | Apply { f; args; exact } when Var.Set.mem x st.cps_needed -> + | Apply { f; args; kind } when Var.Set.mem x st.cps_needed -> Some (fun ~k -> - let exact = exact || call_exact st.flow_info f (List.length args) in - tail_call ~st ~exact ~in_cps:true ~check:true ~f (args @ [ k ])) + let kind = refine_kind kind (call_kind st.flow_info f (List.length args)) in + tail_call ~st ~kind ~in_cps:true ~check:true ~f (args @ [ k ])) | Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg; tail ]) -> Some (fun ~k -> @@ -659,7 +671,7 @@ let cps_block ~st ~k ~orig_pc block = ~st ~instrs: [ Let (k', Prim (Extern "caml_resume_stack", [ Pv stack; tail; Pv k ])) ] - ~exact:(call_exact st.flow_info f 1) + ~kind:(call_kind st.flow_info f 1) ~in_cps:true ~check:true ~f @@ -747,8 +759,8 @@ let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc block = (* We just need to call [f] in direct style. *) let unit = Var.fresh_n "unit" in let unit_val = Int Targetint.zero in - let exact = call_exact st.flow_info f 1 in - [ Let (unit, Constant unit_val); Let (x, Apply { exact; f; args = [ unit ] }) ] + let kind = call_kind st.flow_info f 1 in + [ Let (unit, Constant unit_val); Let (x, Apply { kind; f; args = [ unit ] }) ] | (Let _ | Assign _ | Set_field _ | Offset_ref _ | Array_set _ | Event _) as instr -> [ instr ] in diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 2b82ac051c..b872d58071 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -157,9 +157,14 @@ module Share = struct List.fold_left block.body ~init:share ~f:(fun share i -> match i with | Let (_, Constant c) -> get_constant c share - | Let (x, Apply { args; exact; _ }) -> + | Let (x, Apply { args; kind; _ }) -> let trampolined = Var.Set.mem x trampolined_calls in let in_cps = Var.Set.mem x in_cps in + let exact = + match kind with + | Generic -> false + | Exact | Known _ -> true + in if (not exact) || trampolined then add_apply @@ -1230,7 +1235,12 @@ let remove_unused_tail_args ctx exact trampolined args = let rec translate_expr ctx loc x e level : (_ * J.statement_list) Expr_builder.t = let open Expr_builder in match e with - | Apply { f; args; exact } -> + | Apply { f; args; kind } -> + let exact = + match kind with + | Generic -> false + | Exact | Known _ -> true + in let trampolined = Var.Set.mem x ctx.Ctx.trampolined_calls in let args = remove_unused_tail_args ctx exact trampolined args in let* () = info ~need_loc:true mutator_p in diff --git a/compiler/lib/generate_closure.ml b/compiler/lib/generate_closure.ml index 3285e535b8..5937b7320d 100644 --- a/compiler/lib/generate_closure.ml +++ b/compiler/lib/generate_closure.ml @@ -46,8 +46,8 @@ let rec collect_apply pc blocks visited tc = match block.branch with | Return x -> ( match List.last block.body with - | Some (Let (y, Apply { f; exact = true; _ })) when Code.Var.compare x y = 0 -> - Some (add_multi f pc tc) + | Some (Let (y, Apply { f; kind = Exact | Known _; _ })) + when Code.Var.compare x y = 0 -> Some (add_multi f pc tc) | None -> None | Some _ -> None) | _ -> None @@ -100,7 +100,7 @@ module Trampoline = struct match counter with | None -> { params = [] - ; body = [ Let (return, Apply { f; args; exact = true }) ] + ; body = [ Let (return, Apply { f; args; kind = Known f }) ] ; branch = Return return } | Some counter -> @@ -110,7 +110,7 @@ module Trampoline = struct [ Let ( counter_plus_1 , Prim (Extern "%int_add", [ Pv counter; Pc (Int Targetint.one) ]) ) - ; Let (return, Apply { f; args = counter_plus_1 :: args; exact = true }) + ; Let (return, Apply { f; args = counter_plus_1 :: args; kind = Known f }) ] ; branch = Return return } @@ -139,14 +139,14 @@ module Trampoline = struct (match counter with | None -> [ Event loc - ; Let (result1, Apply { f; args; exact = true }) + ; Let (result1, Apply { f; args; kind = Known f }) ; Event Parse_info.zero ; Let (result2, Prim (Extern "caml_trampoline", [ Pv result1 ])) ] | Some counter -> [ Event loc ; Let (counter, Constant (Int Targetint.zero)) - ; Let (result1, Apply { f; args = counter :: args; exact = true }) + ; Let (result1, Apply { f; args = counter :: args; kind = Known f }) ; Event Parse_info.zero ; Let (result2, Prim (Extern "caml_trampoline", [ Pv result1 ])) ]) @@ -222,7 +222,7 @@ module Trampoline = struct let bounce_call_pc = free_pc + 1 in let free_pc = free_pc + 2 in match List.rev block.body with - | Let (x, Apply { f; args; exact = true }) :: rem_rev -> + | Let (x, Apply { f; args; kind = Exact | Known _ }) :: rem_rev -> assert (Var.equal f ci.f_name); let blocks = Addr.Map.add diff --git a/compiler/lib/global_flow.ml b/compiler/lib/global_flow.ml index 551761a70c..f1ddb44199 100644 --- a/compiler/lib/global_flow.ml +++ b/compiler/lib/global_flow.ml @@ -704,17 +704,29 @@ let f ~fast p = ; info_return_vals = rets } -let exact_call info f n = +let apply_kind info f n = match Var.Tbl.get info.info_approximation f with - | Top | Values { others = true; _ } -> false - | Values { known; others = false } -> - Var.Set.for_all - (fun g -> - match info.info_defs.(Var.idx g) with - | Expr (Closure (params, _)) -> List.length params = n - | Expr (Block _) -> true - | Expr _ | Phi _ -> assert false) - known + | Top | Values { others = true; _ } -> Generic + | Values { known; others = false } -> ( + match + Var.Set.fold + (fun g acc -> + match info.info_defs.(Var.idx g) with + | Expr (Closure (params, _)) -> + if List.length params = n + then + match acc with + | None -> Some (Known g) + | Some (Known _) -> Some Exact + | Some (Exact | Generic) -> acc + else Some Generic + | Expr (Block _) -> acc + | Expr _ | Phi _ -> assert false) + known + None + with + | None -> Exact + | Some kind -> kind) let function_arity info f = match Var.Tbl.get info.info_approximation f with @@ -727,9 +739,10 @@ let function_arity info f = | Expr (Closure (params, _)) -> ( let n = List.length params in match acc with - | None -> Some (Some n) - | Some (Some n') when n <> n' -> Some None - | Some _ -> acc) + | None -> Some (Some (n, Known g)) + | Some (Some (n', _)) when n <> n' -> Some None + | Some (Some (_, Known _)) -> Some (Some (n, Exact)) + | Some (None | Some (_, (Exact | Generic))) -> acc) | Expr (Block _) -> acc | Expr _ | Phi _ -> assert false) known diff --git a/compiler/lib/global_flow.mli b/compiler/lib/global_flow.mli index 61f5dbfb6a..d312bb893e 100644 --- a/compiler/lib/global_flow.mli +++ b/compiler/lib/global_flow.mli @@ -46,6 +46,6 @@ type info = val f : fast:bool -> Code.program -> info -val exact_call : info -> Var.t -> int -> bool +val apply_kind : info -> Var.t -> int -> Code.apply_kind -val function_arity : info -> Var.t -> int option +val function_arity : info -> Var.t -> (int * Code.apply_kind) option diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index 2637480062..0828032a1c 100644 --- a/compiler/lib/inline.ml +++ b/compiler/lib/inline.ml @@ -179,7 +179,8 @@ let inline ~first_class_primitives live_vars closures name pc (outer, p) = ~init:([], (outer, block.branch, p)) ~f:(fun i (rem, state) -> match i with - | Let (x, Apply { f; args; exact = true; _ }) when Var.Map.mem f closures -> ( + | Let (x, Apply { f; args; kind = Exact | Known _; _ }) + when Var.Map.mem f closures -> ( let outer, branch, p = state in let { cl_params = params ; cl_cont = clos_cont @@ -268,7 +269,7 @@ let inline ~first_class_primitives live_vars closures name pc (outer, p) = if recursive then ( Let (f, Closure (params, clos_cont)) - :: Let (x, Apply { f; args; exact = true }) + :: Let (x, Apply { f; args; kind = Known f }) :: rem , (outer, branch, p) ) else diff --git a/compiler/lib/lambda_lifting.ml b/compiler/lib/lambda_lifting.ml index e37843c4bd..a49249cf46 100644 --- a/compiler/lib/lambda_lifting.ml +++ b/compiler/lib/lambda_lifting.ml @@ -200,7 +200,7 @@ let rec traverse var_depth (program, functions) pc depth limit = Let (f'', Closure (List.map s ~f:snd, (pc'', []))) :: functions in let rem', st = rewrite_body false (program, functions) rem in - ( Let (f, Apply { f = f''; args = List.map ~f:fst s; exact = true }) + ( Let (f, Apply { f = f''; args = List.map ~f:fst s; kind = Known f'' }) :: rem' , st )) else diff --git a/compiler/lib/lambda_lifting_simple.ml b/compiler/lib/lambda_lifting_simple.ml index ee52523011..c71ff45359 100644 --- a/compiler/lib/lambda_lifting_simple.ml +++ b/compiler/lib/lambda_lifting_simple.ml @@ -175,7 +175,7 @@ and rewrite_body ~var_depth ~acc_instr: (* Replace closure with application of the lifter function *) - (Let (f, Apply { f = f''; args = List.map ~f:fst s; exact = true }) :: acc_instr) + (Let (f, Apply { f = f''; args = List.map ~f:fst s; kind = Exact }) :: acc_instr) ~depth rem | Let (cname, Closure (params, (pc', args))) :: rem -> @@ -291,7 +291,7 @@ and rewrite_body in ( (program, functions, lifters) , rev_decl - @ Let (tuple, Apply { f = f_tuple; args = List.map ~f:fst s; exact = true }) + @ Let (tuple, Apply { f = f_tuple; args = List.map ~f:fst s; kind = Exact }) :: acc_instr ) | _ :: _ -> (* No need to lift the accumulated closures: just keep their definitions diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 33ce57f9d2..145c725255 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -1062,7 +1062,7 @@ and compile infos pc state (instrs : instr list) = infos (pc + 2) (State.pop 3 state) - (Let (x, Apply { f; args; exact = false }) :: instrs) + (Let (x, Apply { f; args; kind = Generic }) :: instrs) | APPLY1 -> let f = State.accu state in let x, state = State.fresh_var state in @@ -1074,7 +1074,7 @@ and compile infos pc state (instrs : instr list) = infos (pc + 1) (State.pop 1 state) - (Let (x, Apply { f; args = [ y ]; exact = false }) :: instrs) + (Let (x, Apply { f; args = [ y ]; kind = Generic }) :: instrs) | APPLY2 -> let f = State.accu state in let x, state = State.fresh_var state in @@ -1097,7 +1097,7 @@ and compile infos pc state (instrs : instr list) = infos (pc + 1) (State.pop 2 state) - (Let (x, Apply { f; args = [ y; z ]; exact = false }) :: instrs) + (Let (x, Apply { f; args = [ y; z ]; kind = Generic }) :: instrs) | APPLY3 -> let f = State.accu state in let x, state = State.fresh_var state in @@ -1123,7 +1123,7 @@ and compile infos pc state (instrs : instr list) = infos (pc + 1) (State.pop 3 state) - (Let (x, Apply { f; args = [ y; z; t ]; exact = false }) :: instrs) + (Let (x, Apply { f; args = [ y; z; t ]; kind = Generic }) :: instrs) | APPTERM -> let n = getu code (pc + 1) in let f = State.accu state in @@ -1138,13 +1138,13 @@ and compile infos pc state (instrs : instr list) = done; Format.printf ")@."); let x, state = State.fresh_var state in - Let (x, Apply { f; args = l; exact = false }) :: instrs, Return x, state + Let (x, Apply { f; args = l; kind = Generic }) :: instrs, Return x, state | APPTERM1 -> let f = State.accu state in let x = State.peek 0 state in if debug_parser () then Format.printf "return %a(%a)@." Var.print f Var.print x; let y, state = State.fresh_var state in - Let (y, Apply { f; args = [ x ]; exact = false }) :: instrs, Return y, state + Let (y, Apply { f; args = [ x ]; kind = Generic }) :: instrs, Return y, state | APPTERM2 -> let f = State.accu state in let x = State.peek 0 state in @@ -1152,7 +1152,7 @@ and compile infos pc state (instrs : instr list) = if debug_parser () then Format.printf "return %a(%a, %a)@." Var.print f Var.print x Var.print y; let z, state = State.fresh_var state in - Let (z, Apply { f; args = [ x; y ]; exact = false }) :: instrs, Return z, state + Let (z, Apply { f; args = [ x; y ]; kind = Generic }) :: instrs, Return z, state | APPTERM3 -> let f = State.accu state in let x = State.peek 0 state in @@ -1171,7 +1171,9 @@ and compile infos pc state (instrs : instr list) = Var.print z; let t, state = State.fresh_var state in - Let (t, Apply { f; args = [ x; y; z ]; exact = false }) :: instrs, Return t, state + ( Let (t, Apply { f; args = [ x; y; z ]; kind = Generic }) :: instrs + , Return t + , state ) | RETURN -> let x = State.accu state in diff --git a/compiler/lib/pure_fun.ml b/compiler/lib/pure_fun.ml index d90818cd1e..103d0947e4 100644 --- a/compiler/lib/pure_fun.ml +++ b/compiler/lib/pure_fun.ml @@ -26,7 +26,9 @@ let pure_expr pure_funs e = match e with | Block _ | Field _ | Closure _ | Constant _ -> true | Special (Alias_prim _) -> true - | Apply { f; exact; _ } -> exact && Var.Set.mem f pure_funs + | Apply { kind = Known g; _ } -> Var.Set.mem g pure_funs + | Apply { f; kind = Exact; _ } -> Var.Set.mem f pure_funs + | Apply { kind = Generic; _ } -> false | Prim (p, _l) -> ( match p with | Extern f -> Primitive.is_pure f diff --git a/compiler/lib/specialize.ml b/compiler/lib/specialize.ml index 0b6028b011..576a3943e6 100644 --- a/compiler/lib/specialize.ml +++ b/compiler/lib/specialize.ml @@ -21,29 +21,35 @@ open! Stdlib open Code open Flow +let merge_kinds k k' = + match k, k' with + | Generic, _ | _, Generic -> Generic + | Exact, _ | _, Exact -> Exact + | Known f, Known f' -> if Code.Var.equal f f' then k else Exact + let function_arity info x = let rec arity info x acc = get_approx info (fun x -> match Flow.Info.def info x with - | Some (Closure (l, _)) -> Some (List.length l) + | Some (Closure (l, _)) -> Some (List.length l, Known x) | Some (Special (Alias_prim prim)) -> ( - try Some (Primitive.arity prim) with Not_found -> None) + try Some (Primitive.arity prim, Exact) with Not_found -> None) | Some (Apply { f; args; _ }) -> ( if List.mem f ~set:acc then None else match arity info f (f :: acc) with - | Some n -> + | Some (n, _) -> let diff = n - List.length args in - if diff > 0 then Some diff else None + if diff > 0 then Some (diff, Exact) else None | None -> None) | _ -> None) None (fun u v -> match u, v with - | Some n, Some m when n = m -> u + | Some (n, kind), Some (n', kind') when n = n' -> Some (n, merge_kinds kind kind') | _ -> None) x in @@ -56,21 +62,21 @@ let add_event loc instrs = let specialize_instr function_arity ((acc, free_pc, extra), loc) i = match i with - | Let (x, Apply { f; args; exact = false }) when Config.Flag.optcall () -> ( + | Let (x, Apply { f; args; _ }) when Config.Flag.optcall () -> ( let n' = List.length args in match function_arity f with | None -> i :: acc, free_pc, extra - | Some n when n = n' -> - Let (x, Apply { f; args; exact = true }) :: acc, free_pc, extra - | Some n when n < n' -> + | Some (n, kind) when n = n' -> + Let (x, Apply { f; args; kind }) :: acc, free_pc, extra + | Some (n, kind) when n < n' -> let v = Code.Var.fresh () in let args, rest = List.take n args in ( (* Reversed *) - Let (x, Apply { f = v; args = rest; exact = false }) - :: add_event loc (Let (v, Apply { f; args; exact = true }) :: acc) + Let (x, Apply { f = v; args = rest; kind = Generic }) + :: add_event loc (Let (v, Apply { f; args; kind }) :: acc) , free_pc , extra ) - | Some n when n > n' -> + | Some (n, kind) when n > n' -> let missing = Array.init (n - n') ~f:(fun _ -> Code.Var.fresh ()) in let missing = Array.to_list missing in let block = @@ -79,9 +85,7 @@ let specialize_instr function_arity ((acc, free_pc, extra), loc) i = let return' = Code.Var.fresh () in { params = params' ; body = - add_event - loc - [ Let (return', Apply { f; args = args @ params'; exact = true }) ] + add_event loc [ Let (return', Apply { f; args = args @ params'; kind }) ] ; branch = Return return' } in diff --git a/compiler/lib/specialize.mli b/compiler/lib/specialize.mli index 39f0f7fed8..3d30956581 100644 --- a/compiler/lib/specialize.mli +++ b/compiler/lib/specialize.mli @@ -18,6 +18,9 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val function_arity : Flow.Info.t -> Code.Var.t -> int option +val function_arity : Flow.Info.t -> Code.Var.t -> (int * Code.apply_kind) option -val f : function_arity:(Code.Var.t -> int option) -> Code.program -> Code.program +val f : + function_arity:(Code.Var.t -> (int * Code.apply_kind) option) + -> Code.program + -> Code.program diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml index 6f82da73e4..4b2e7f585a 100644 --- a/compiler/lib/subst.ml +++ b/compiler/lib/subst.ml @@ -27,8 +27,7 @@ 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 } + | Apply { f; args; kind } -> Apply { f = s f; args = List.map args ~f:s; kind } | Block (n, a, k, mut) -> Block (n, Array.map a ~f:(fun x -> s x), k, mut) | Field (x, n, typ) -> Field (s x, n, typ) | Closure (l, pc) -> Closure (l, subst_cont s pc) @@ -115,7 +114,10 @@ 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:s; exact } + | Apply { f; args; kind = Known g } -> + Apply { f = s f; args = List.map args ~f:s; kind = Known (s g) } + | Apply { f; args; kind = (Generic | Exact) as kind } -> + Apply { f = s f; args = List.map args ~f:s; kind } | Block (n, a, k, mut) -> Block (n, Array.map a ~f:s, k, mut) | Field (x, n, typ) -> Field (s x, n, typ) | Closure (l, pc) -> Closure (List.map l ~f:s, subst_cont s pc)