From fc7f54b09df517e24bfea0acc7d25c61e77a562f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Fri, 24 Mar 2023 16:20:42 +0100 Subject: [PATCH 1/7] Add modes on parameters and a framework for attributes on them --- middle_end/closure/closure.ml | 49 +++++++-------- middle_end/flambda/closure_conversion.ml | 4 ++ .../from_lambda/closure_conversion.ml | 60 +++++++++++++------ .../from_lambda/closure_conversion_aux.ml | 11 +++- .../from_lambda/closure_conversion_aux.mli | 11 +++- .../flambda2/from_lambda/lambda_to_flambda.ml | 7 ++- .../flambda2/parser/fexpr_to_flambda.ml | 7 ++- .../flambda2/simplify/simplify_apply_expr.ml | 21 ++++--- .../simplify/simplify_set_of_closures.ml | 13 +--- middle_end/flambda2/term_basics/alloc_mode.ml | 2 + .../flambda2/term_basics/alloc_mode.mli | 2 + middle_end/flambda2/terms/code_metadata.ml | 53 +++++++++++++--- middle_end/flambda2/terms/code_metadata.mli | 3 + ocaml/bytecomp/bytegen.ml | 4 +- ocaml/lambda/lambda.ml | 23 ++++++- ocaml/lambda/lambda.mli | 13 +++- ocaml/lambda/printlambda.ml | 19 +++--- ocaml/lambda/simplif.ml | 38 ++++++++---- ocaml/lambda/simplif.mli | 2 +- ocaml/lambda/tmc.ml | 4 +- ocaml/lambda/transl_list_comprehension.ml | 12 +++- ocaml/lambda/translclass.ml | 41 +++++++------ ocaml/lambda/translcore.ml | 49 ++++++++------- ocaml/lambda/translmod.ml | 6 +- ocaml/lambda/translprim.ml | 16 +++-- ocaml/middle_end/closure/closure.ml | 4 +- 26 files changed, 321 insertions(+), 153 deletions(-) diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index df139603f61..78b7239ce99 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -868,7 +868,7 @@ let warning_if_forced_inlined ~loc ~attribute warning = Location.prerr_warning (Debuginfo.Scoped_location.to_location loc) (Warnings.Inlining_impossible warning) -let fail_if_probe ~probe msg = +let fail_if_probe ~(probe : Lambda.probe) msg = match probe with | None -> () | Some {name} -> @@ -1080,8 +1080,22 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) List.fold_left (fun kinds (arg, _, kind) -> V.Map.add arg kind kinds) kinds first_args in + let new_clos_mode, kind = + (* If the closure has a local suffix, and we've supplied + enough args to hit it, then the closure must be local + (because the args or closure might be). *) + let nparams = List.length params_layout in + assert (nparams >= nlocal); + let heap_params = nparams - nlocal in + if nargs <= heap_params then + alloc_heap, Curried {nlocal} + else + let supplied_local_args = nargs - heap_params in + alloc_local, Curried {nlocal = nlocal - supplied_local_args} + in + if is_local_mode clos_mode then assert (is_local_mode new_clos_mode); let final_args = - List.map (fun kind -> V.create_local "arg", kind) rem_layouts + List.map (fun kind -> { name = V.create_local "arg"; layout = kind; attributes = Lambda.default_param_attribute; mode = new_clos_mode}) rem_layouts in let rec iter args body = match args with @@ -1092,25 +1106,11 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) in let internal_args = (List.map (fun (arg1, _arg2, _) -> Lvar arg1) first_args) - @ (List.map (fun (arg, _) -> Lvar arg ) final_args) + @ (List.map (fun p -> Lvar p.name ) final_args) in let funct_var = V.create_local "funct" in let fenv = V.Map.add funct_var fapprox fenv in let kinds = V.Map.add funct_var Lambda.layout_function kinds in - let new_clos_mode, kind = - (* If the closure has a local suffix, and we've supplied - enough args to hit it, then the closure must be local - (because the args or closure might be). *) - let nparams = List.length params_layout in - assert (nparams >= nlocal); - let heap_params = nparams - nlocal in - if nargs <= heap_params then - alloc_heap, Curried {nlocal} - else - let supplied_local_args = nargs - heap_params in - alloc_local, Curried {nlocal = nlocal - supplied_local_args} - in - if is_local_mode clos_mode then assert (is_local_mode new_clos_mode); let ret_mode = if fundesc.fun_region then alloc_heap else alloc_local in let (new_fun, approx) = close { backend; fenv; cenv; mutable_vars; kinds; catch_env } @@ -1525,7 +1525,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ {fun_label = label; fun_arity = { function_kind = kind ; - params_layout = List.map snd params ; + params_layout = List.map (fun p -> p.layout) params ; return_layout = return }; fun_closed = initially_closed; @@ -1534,7 +1534,8 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ fun_poll = attr.poll; fun_region = region} in let dbg = Debuginfo.from_location loc in - (id, params, return, body, mode, attrib, fundesc, dbg) + (id, List.map (fun (p : Lambda.lparam) -> let No_attributes = p.attributes in (p.name, p.layout, p.mode)) params, + return, body, mode, attrib, fundesc, dbg) | (_, _) -> fatal_error "Closure.close_functions") fun_defs in (* Build an approximate fenv for compiling the functions *) @@ -1584,7 +1585,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ in let kinds_body = List.fold_right - (fun (id, kind) kinds -> V.Map.add id kind kinds) + (fun (id, kind, _) kinds -> V.Map.add id kind kinds) params (V.Map.add env_param Lambda.layout_function kinds_rec) in let (ubody, approx) = @@ -1602,13 +1603,13 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ let fun_params = if !useless_env then params - else params @ [env_param, Lambda.layout_function] + else params @ [env_param, Lambda.layout_function, alloc_heap] in let f = { label = fundesc.fun_label; arity = fundesc.fun_arity; - params = List.map (fun (var, _) -> VP.create var) fun_params; + params = List.map (fun (var, _, _) -> VP.create var) fun_params; body = ubody; dbg; env = Some env_param; @@ -1621,7 +1622,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ their wrapper functions) to be inlined *) let n = List.fold_left - (fun n (id, _) -> n + if V.name id = "*opt*" then 8 else 1) + (fun n (id, _, _) -> n + if V.name id = "*opt*" then 8 else 1) 0 fun_params in @@ -1637,7 +1638,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ | Never_inline -> min_int | Unroll _ -> assert false in - let fun_params = List.map (fun (var, _) -> VP.create var) fun_params in + let fun_params = List.map (fun (var, _, _) -> VP.create var) fun_params in if lambda_smaller ubody threshold then fundesc.fun_inline <- Some(fun_params, ubody); diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml index 6ffe0de0d8e..ac8ab07d431 100644 --- a/middle_end/flambda/closure_conversion.ml +++ b/middle_end/flambda/closure_conversion.ml @@ -226,6 +226,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = (* CR-soon mshinwell: some of this is now very similar to the let rec case below *) let set_of_closures_var = Variable.create Names.set_of_closures in + let params = List.map (fun (p : Lambda.lparam) -> let No_attributes = p.attributes in (p.name, p.layout)) params in let set_of_closures = let decl = Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind ~mode @@ -279,6 +280,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = let debug_info = Debuginfo.from_location loc in Variable.create_with_same_name_as_ident ~debug_info let_rec_ident in + let params = List.map (fun (p : Lambda.lparam) -> let No_attributes = p.attributes in (p.name, p.layout)) params in let function_declaration = Function_decl.create ~let_rec_ident:(Some let_rec_ident) ~closure_bound_var ~kind ~mode ~region @@ -623,6 +625,7 @@ and close_functions t external_env function_declarations : Flambda.named = Misc.fatal_error "Closure_conversion: Tupled Alloc_local function found" in let params = List.mapi (fun i (v, kind) -> + (* CR ncourant: actually now we have the alloc_mode in lambda, propagate it *) let alloc_mode = if i < nheap then Lambda.alloc_heap else Lambda.alloc_local in @@ -699,6 +702,7 @@ and close_let_bound_expression t ?let_rec_ident let_bound_var env let debug_info = Debuginfo.from_location loc in Variable.rename ~debug_info let_bound_var in + let params = List.map (fun (p : Lambda.lparam) -> let No_attributes = p.attributes in (p.name, p.layout)) params in let decl = Function_decl.create ~let_rec_ident ~closure_bound_var ~kind ~mode ~region ~params ~body ~attr ~loc ~return_layout:return diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 4679ad99f78..25f5f4007ef 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -1337,6 +1337,11 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl let loc = Function_decl.loc decl in let dbg = Debuginfo.from_location loc in let params = Function_decl.params decl in + let param_modes = + List.map + (fun (p : Function_decl.param) -> Alloc_mode.For_types.from_lambda p.mode) + params + in let return = Function_decl.return decl in let return_continuation = Function_decl.return_continuation decl in let acc, exn_continuation = @@ -1456,8 +1461,8 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl in let closure_env = List.fold_right - (fun (id, kind) env -> - let env, _var = Env.add_var_like env id User_visible kind in + (fun (p : Function_decl.param) env -> + let env, _var = Env.add_var_like env p.name User_visible p.kind in env) params closure_env in @@ -1482,11 +1487,12 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl (* CR-someday pchambart: eta-expansion wrappers for primitives are not marked as stubs but certainly should be. *) let stub = Function_decl.stub decl in - let param_vars = - List.map (fun (id, kind) -> fst (Env.find_var closure_env id), kind) params - in let params = - List.map (fun (var, kind) -> BP.create var kind) param_vars + List.map + (fun (p : Function_decl.param) -> + let var = fst (Env.find_var closure_env p.name) in + BP.create var p.kind) + params |> Bound_parameters.create in let acc = Acc.with_seen_a_function acc false in @@ -1606,6 +1612,7 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl let code = Code.create code_id ~params_and_body ~free_names_of_params_and_body:(Acc.free_names acc) ~params_arity + ~param_modes ~first_complex_local_param:(Function_decl.first_complex_local_param decl) ~result_arity:return ~result_types:Unknown ~contains_no_escaping_local_allocs: @@ -1706,7 +1713,7 @@ let close_functions acc external_env ~current_region function_declarations = List.fold_left (fun approx_map decl -> (* The only fields of metadata which are used for this pass are - params_arity, is_tupled, first_complex_local_param, + params_arity, param_modes, is_tupled, first_complex_local_param, contains_no_escaping_local_allocs, and result_arity. We try to populate the different fields as much as possible, but put dummy values when they are not yet computed or simply too expensive to @@ -1715,7 +1722,14 @@ let close_functions acc external_env ~current_region function_declarations = let code_id = Function_slot.Map.find function_slot function_code_ids in let params = Function_decl.params decl in let params_arity = - List.map (fun (_, kind) -> kind) params |> Flambda_arity.create + List.map (fun (p : Function_decl.param) -> p.kind) params + |> Flambda_arity.create + in + let param_modes = + List.map + (fun (p : Function_decl.param) -> + Alloc_mode.For_types.from_lambda p.mode) + params in let result_arity = Function_decl.return decl in let poll_attribute = @@ -1735,7 +1749,7 @@ let close_functions acc external_env ~current_region function_declarations = Code_metadata.create code_id ~params_arity ~first_complex_local_param: (Function_decl.first_complex_local_param decl) - ~result_arity ~result_types:Unknown + ~param_modes ~result_arity ~result_types:Unknown ~contains_no_escaping_local_allocs: (Function_decl.contains_no_escaping_local_allocs decl) ~stub:(Function_decl.stub decl) ~inline:Never_inline ~check @@ -2017,8 +2031,8 @@ let close_let_rec acc env ~function_declarations named ~body let wrap_partial_application acc env apply_continuation (apply : IR.apply) - approx ~provided ~missing_arity ~result_arity ~first_complex_local_param - ~contains_no_escaping_local_allocs = + approx ~provided ~missing_arity ~missing_param_modes ~result_arity + ~first_complex_local_param ~contains_no_escaping_local_allocs = (* In case of partial application, creates a wrapping function from scratch to allow inlining and lifting *) let wrapper_id = Ident.create_local ("partial_" ^ Ident.name apply.func) in @@ -2030,16 +2044,21 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) let num_provided = List.length provided in let params = List.mapi - (fun n kind_with_subkind -> - ( Ident.create_local ("param" ^ string_of_int (num_provided + n)), - kind_with_subkind )) - (Flambda_arity.to_list missing_arity) + (fun n (kind, mode) : Function_decl.param -> + { name = Ident.create_local ("param" ^ string_of_int (num_provided + n)); + kind; + attributes = Lambda.default_param_attribute; + mode = Alloc_mode.For_types.to_lambda mode + }) + (List.combine (Flambda_arity.to_list missing_arity) missing_param_modes) in let return_continuation = Continuation.create ~sort:Return () in let exn_continuation = IR.{ exn_handler = Continuation.create (); extra_args = [] } in - let all_args = provided @ List.map (fun (a, _) -> IR.Var a) params in + let all_args = + provided @ List.map (fun (p : Function_decl.param) -> IR.Var p.name) params + in let result_mode = if contains_no_escaping_local_allocs then Lambda.alloc_heap @@ -2218,6 +2237,7 @@ type call_args_split = | Partial_app of { provided : IR.simple list; missing_arity : Flambda_arity.t; + missing_param_modes : Alloc_mode.For_types.t list; result_arity : Flambda_arity.t } | Over_app of @@ -2237,6 +2257,7 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = ( Code_metadata.params_arity metadata, Code_metadata.result_arity metadata, Code_metadata.is_tupled metadata, + Code_metadata.param_modes metadata, Code_metadata.first_complex_local_param metadata, Code_metadata.contains_no_escaping_local_allocs metadata ) | Value_unknown -> None @@ -2255,6 +2276,7 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = ( params_arity, result_arity, is_tupled, + param_modes, first_complex_local_param, contains_no_escaping_local_allocs ) -> ( let acc, args_with_arities = find_simples_and_arity acc env apply.args in @@ -2279,9 +2301,11 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = else if args_l < arity_l then let _provided_arity, missing_arity = cut args_l arity in + let _provided_modes, missing_param_modes = cut args_l param_modes in Partial_app { provided = args; missing_arity = Flambda_arity.create missing_arity; + missing_param_modes; result_arity } else @@ -2305,7 +2329,7 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = close_exact_or_unknown_apply acc env { apply with args; continuation = apply.continuation } (Some approx) ~replace_region:None - | Partial_app { provided; missing_arity; result_arity } -> + | Partial_app { provided; missing_arity; missing_param_modes; result_arity } -> (match apply.inlined with | Always_inlined | Unroll _ -> Location.prerr_warning @@ -2315,7 +2339,7 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = inlined_attribute_on_partial_application_msg Inlined)) | Never_inlined | Hint_inlined | Default_inlined -> ()); wrap_partial_application acc env apply.continuation apply approx ~provided - ~missing_arity ~result_arity ~first_complex_local_param + ~missing_arity ~missing_param_modes ~result_arity ~first_complex_local_param ~contains_no_escaping_local_allocs | Over_app { full; remaining; remaining_arity } -> let full_args_call apply_continuation ~region acc = diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml index 11821118b77..a032c3a71da 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml @@ -672,11 +672,18 @@ end module Function_decls = struct module Function_decl = struct + type param = + { name : Ident.t; + kind : Flambda_kind.With_subkind.t; + attributes : Lambda.parameter_attribute; + mode : Lambda.alloc_mode + } + type t = { let_rec_ident : Ident.t; function_slot : Function_slot.t; kind : Lambda.function_kind; - params : (Ident.t * Flambda_kind.With_subkind.t) list; + params : param list; return : Flambda_arity.t; return_continuation : Continuation.t; exn_continuation : IR.exn_continuation; @@ -807,7 +814,7 @@ module Function_decls = struct set_diff (set_diff (all_free_idents function_decls) - (List.map fst (all_params function_decls))) + (List.map (fun p -> p.Function_decl.name) (all_params function_decls))) (let_rec_idents function_decls) let create function_decls alloc_mode = diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli index b460e0f612c..500b5e392d7 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli @@ -293,11 +293,18 @@ module Function_decls : sig module Function_decl : sig type t + type param = + { name : Ident.t; + kind : Flambda_kind.With_subkind.t; + attributes : Lambda.parameter_attribute; + mode : Lambda.alloc_mode + } + val create : let_rec_ident:Ident.t option -> function_slot:Function_slot.t -> kind:Lambda.function_kind -> - params:(Ident.t * Flambda_kind.With_subkind.t) list -> + params:param list -> return:Flambda_arity.t -> return_continuation:Continuation.t -> exn_continuation:IR.exn_continuation -> @@ -318,7 +325,7 @@ module Function_decls : sig val kind : t -> Lambda.function_kind - val params : t -> (Ident.t * Flambda_kind.With_subkind.t) list + val params : t -> param list val return : t -> Flambda_arity.t diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 004cb76f423..72b2680d2f9 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -1631,7 +1631,12 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents in let params = List.map - (fun (param, kind) -> param, Flambda_kind.With_subkind.from_lambda kind) + (fun (p : Lambda.lparam) : Function_decl.param -> + { name = p.name; + kind = Flambda_kind.With_subkind.from_lambda p.layout; + attributes = p.attributes; + mode = p.mode + }) params in let return = diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index 7d13c088030..44ea7d76e59 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -885,10 +885,15 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let cost_metrics = Cost_metrics.from_size (Code_size.of_int code_size) in + let param_modes = + List.map + (fun _ -> Alloc_mode.For_types.heap) + (Flambda_arity.to_list params_arity) + in let code = (* CR mshinwell: [inlining_decision] should maybe be set properly *) Code.create code_id ~params_and_body ~free_names_of_params_and_body - ~newer_version_of ~params_arity + ~newer_version_of ~params_arity ~param_modes ~first_complex_local_param:(Flambda_arity.cardinal params_arity) ~result_arity ~result_types:Unknown ~contains_no_escaping_local_allocs:false ~stub:false ~inline diff --git a/middle_end/flambda2/simplify/simplify_apply_expr.ml b/middle_end/flambda2/simplify/simplify_apply_expr.ml index 8c4fd6bdc5a..f54ec9a2b3c 100644 --- a/middle_end/flambda2/simplify/simplify_apply_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_expr.ml @@ -322,7 +322,8 @@ let simplify_direct_full_application ~simplify_expr dacc apply function_type let simplify_direct_partial_application ~simplify_expr dacc apply ~callee's_code_id ~callee's_code_metadata ~callee's_function_slot - ~param_arity ~result_arity ~recursive ~down_to_up ~coming_from_indirect + ~param_arity ~param_modes ~result_arity ~recursive ~down_to_up + ~coming_from_indirect ~(closure_alloc_mode_from_type : Alloc_mode.For_types.t) ~current_region ~first_complex_local_param = (* Partial-applications are converted in full applications. Let's assume that @@ -426,6 +427,9 @@ let simplify_direct_partial_application ~simplify_expr dacc apply remaining_param_arity |> Bound_parameters.create in + let _, remaining_params_alloc_modes = + Misc.Stdlib.List.split_at (List.length args) param_modes + in let call_kind = Call_kind.direct_function_call callee's_code_id apply_alloc_mode in @@ -566,10 +570,11 @@ let simplify_direct_partial_application ~simplify_expr dacc apply Code.create code_id ~params_and_body ~free_names_of_params_and_body:free_names ~newer_version_of:None ~params_arity:(Bound_parameters.arity remaining_params) - ~first_complex_local_param ~result_arity ~result_types:Unknown - ~contains_no_escaping_local_allocs ~stub:true ~inline:Default_inline - ~poll_attribute:Default ~check:Check_attribute.Default_check - ~is_a_functor:false ~recursive ~cost_metrics:cost_metrics_of_body + ~param_modes:remaining_params_alloc_modes ~first_complex_local_param + ~result_arity ~result_types:Unknown ~contains_no_escaping_local_allocs + ~stub:true ~inline:Default_inline ~poll_attribute:Default + ~check:Check_attribute.Default_check ~is_a_functor:false ~recursive + ~cost_metrics:cost_metrics_of_body ~inlining_arguments:(DE.inlining_arguments (DA.denv dacc)) ~dbg ~is_tupled:false ~is_my_closure_used: @@ -771,8 +776,10 @@ let simplify_direct_function_call ~simplify_expr dacc apply Apply.print apply; simplify_direct_partial_application ~simplify_expr dacc apply ~callee's_code_id ~callee's_code_metadata ~callee's_function_slot - ~param_arity:params_arity ~result_arity ~recursive ~down_to_up - ~coming_from_indirect ~closure_alloc_mode_from_type ~current_region + ~param_arity:params_arity + ~param_modes:(Code_metadata.param_modes callee's_code_metadata) + ~result_arity ~recursive ~down_to_up ~coming_from_indirect + ~closure_alloc_mode_from_type ~current_region ~first_complex_local_param: (Code_metadata.first_complex_local_param callee's_code_metadata)) else diff --git a/middle_end/flambda2/simplify/simplify_set_of_closures.ml b/middle_end/flambda2/simplify/simplify_set_of_closures.ml index cb1baf1e9b1..c6ac7431834 100644 --- a/middle_end/flambda2/simplify/simplify_set_of_closures.ml +++ b/middle_end/flambda2/simplify/simplify_set_of_closures.ml @@ -31,17 +31,7 @@ let dacc_inside_function context ~outer_dacc ~params ~my_closure ~my_region ~inlining_arguments ~absolute_history code_id ~return_continuation ~exn_continuation ~loopify_state code_metadata = let dacc = C.dacc_inside_functions context in - let first_complex_local_param = - Code_metadata.first_complex_local_param code_metadata - in - let alloc_modes = - List.mapi - (fun index _ : Alloc_mode.For_types.t -> - if index < first_complex_local_param - then Alloc_mode.For_types.heap - else Alloc_mode.For_types.unknown ()) - (Bound_parameters.to_list params) - in + let alloc_modes = Code_metadata.param_modes code_metadata in let denv = DE.add_parameters_with_unknown_types ~alloc_modes (DA.denv dacc) params |> DE.set_inlining_arguments inlining_arguments @@ -434,6 +424,7 @@ let simplify_function0 context ~outer_dacc function_slot_opt code_id code (DA.are_rebuilding_terms dacc_after_body) code_id ~params_and_body ~free_names_of_params_and_body:free_names_of_code ~newer_version_of ~params_arity:(Code.params_arity code) + ~param_modes:(Code.param_modes code) ~first_complex_local_param:(Code.first_complex_local_param code) ~result_arity ~result_types ~contains_no_escaping_local_allocs: diff --git a/middle_end/flambda2/term_basics/alloc_mode.ml b/middle_end/flambda2/term_basics/alloc_mode.ml index be14b92598e..cc8eebe565c 100644 --- a/middle_end/flambda2/term_basics/alloc_mode.ml +++ b/middle_end/flambda2/term_basics/alloc_mode.ml @@ -32,6 +32,8 @@ module For_types = struct | Local, Heap_or_local -> -1 | Heap_or_local, Local -> 1 + let equal t1 t2 = compare t1 t2 = 0 + let heap = Heap let local () = diff --git a/middle_end/flambda2/term_basics/alloc_mode.mli b/middle_end/flambda2/term_basics/alloc_mode.mli index a84836a3fc4..a65c1de1421 100644 --- a/middle_end/flambda2/term_basics/alloc_mode.mli +++ b/middle_end/flambda2/term_basics/alloc_mode.mli @@ -23,6 +23,8 @@ module For_types : sig val compare : t -> t -> int + val equal : t -> t -> bool + val heap : t (** Returns [Heap] if stack allocation is disabled! *) diff --git a/middle_end/flambda2/terms/code_metadata.ml b/middle_end/flambda2/terms/code_metadata.ml index 1270d42067a..5bb9158b2bf 100644 --- a/middle_end/flambda2/terms/code_metadata.ml +++ b/middle_end/flambda2/terms/code_metadata.ml @@ -18,7 +18,11 @@ type t = { code_id : Code_id.t; newer_version_of : Code_id.t option; params_arity : Flambda_arity.t; + param_modes : Alloc_mode.For_types.t list; first_complex_local_param : int; + (* Note: first_complex_local_param cannot be computed from param_modes, + because it might be 0 if the closure itself has to be allocated locally, + for instance as a result of a partial application. *) result_arity : Flambda_arity.t; result_types : Result_types.t Or_unknown_or_bottom.t; contains_no_escaping_local_allocs : bool; @@ -56,6 +60,8 @@ module Code_metadata_accessors (X : Metadata_view_type) = struct let params_arity t = (metadata t).params_arity + let param_modes t = (metadata t).param_modes + let first_complex_local_param t = (metadata t).first_complex_local_param let result_arity t = (metadata t).result_arity @@ -118,6 +124,7 @@ type 'a create_type = Code_id.t -> newer_version_of:Code_id.t option -> params_arity:Flambda_arity.t -> + param_modes:Alloc_mode.For_types.t list -> first_complex_local_param:int -> result_arity:Flambda_arity.t -> result_types:Result_types.t Or_unknown_or_bottom.t -> @@ -139,12 +146,12 @@ type 'a create_type = loopify:Loopify_attribute.t -> 'a -let createk k code_id ~newer_version_of ~params_arity ~first_complex_local_param - ~result_arity ~result_types ~contains_no_escaping_local_allocs ~stub - ~(inline : Inline_attribute.t) ~check ~poll_attribute ~is_a_functor - ~recursive ~cost_metrics ~inlining_arguments ~dbg ~is_tupled - ~is_my_closure_used ~inlining_decision ~absolute_history ~relative_history - ~loopify = +let createk k code_id ~newer_version_of ~params_arity ~param_modes + ~first_complex_local_param ~result_arity ~result_types + ~contains_no_escaping_local_allocs ~stub ~(inline : Inline_attribute.t) + ~check ~poll_attribute ~is_a_functor ~recursive ~cost_metrics + ~inlining_arguments ~dbg ~is_tupled ~is_my_closure_used ~inlining_decision + ~absolute_history ~relative_history ~loopify = (match stub, inline with | true, (Available_inline | Never_inline | Default_inline) | ( false, @@ -159,10 +166,19 @@ let createk k code_id ~newer_version_of ~params_arity ~first_complex_local_param Misc.fatal_errorf "Illegal first_complex_local_param=%d for params arity: %a" first_complex_local_param Flambda_arity.print params_arity; + if List.compare_length_with param_modes (Flambda_arity.cardinal params_arity) + <> 0 + then + Misc.fatal_errorf "Parameter modes do not match arity: %a and (%a)" + Flambda_arity.print params_arity + (Format.pp_print_list ~pp_sep:Format.pp_print_space + Alloc_mode.For_types.print) + param_modes; k { code_id; newer_version_of; params_arity; + param_modes; first_complex_local_param; result_arity; result_types; @@ -212,7 +228,8 @@ let [@ocamlformat "disable"] print_inlining_paths ppf let [@ocamlformat "disable"] print ppf { code_id = _; newer_version_of; stub; inline; check; poll_attribute; - is_a_functor; params_arity; first_complex_local_param; result_arity; + is_a_functor; params_arity; param_modes; + first_complex_local_param; result_arity; result_types; contains_no_escaping_local_allocs; recursive; cost_metrics; inlining_arguments; dbg; is_tupled; is_my_closure_used; inlining_decision; @@ -226,6 +243,7 @@ let [@ocamlformat "disable"] print ppf @[%t(poll_attribute@ %a)%t@]@ \ @[%t(is_a_functor@ %b)%t@]@ \ @[%t(params_arity@ %t%a%t)%t@]@ \ + @[%t(param_modes@ %t(%a)%t)%t@]@ \ @[(first_complex_local_param@ %d)@]@ \ @[%t(result_arity@ %t%a%t)%t@]@ \ @[(result_types@ @[(%a)@])@]@ \ @@ -272,6 +290,21 @@ let [@ocamlformat "disable"] print ppf then Flambda_colours.elide else Flambda_colours.none) Flambda_colours.pop + (if List.for_all + (fun mode -> Alloc_mode.For_types.equal mode Alloc_mode.For_types.heap) + param_modes + then Flambda_colours.elide + else Flambda_colours.none) + Flambda_colours.pop + (Format.pp_print_list ~pp_sep:Format.pp_print_space + Alloc_mode.For_types.print) + param_modes + (if List.for_all + (fun mode -> Alloc_mode.For_types.equal mode Alloc_mode.For_types.heap) + param_modes + then Flambda_colours.elide + else Flambda_colours.none) + Flambda_colours.pop first_complex_local_param (if Flambda_arity.is_singleton_value result_arity then Flambda_colours.elide @@ -308,6 +341,7 @@ let free_names { code_id = _; newer_version_of; params_arity = _; + param_modes = _; first_complex_local_param = _; result_arity = _; result_types; @@ -348,6 +382,7 @@ let apply_renaming ({ code_id; newer_version_of; params_arity = _; + param_modes = _; first_complex_local_param = _; result_arity = _; result_types; @@ -399,6 +434,7 @@ let ids_for_export { code_id; newer_version_of; params_arity = _; + param_modes = _; first_complex_local_param = _; result_arity = _; result_types; @@ -436,6 +472,7 @@ let approx_equal { code_id = code_id1; newer_version_of = newer_version_of1; params_arity = params_arity1; + param_modes = param_modes1; first_complex_local_param = first_complex_local_param1; result_arity = result_arity1; result_types = _; @@ -459,6 +496,7 @@ let approx_equal { code_id = code_id2; newer_version_of = newer_version_of2; params_arity = params_arity2; + param_modes = param_modes2; first_complex_local_param = first_complex_local_param2; result_arity = result_arity2; result_types = _; @@ -482,6 +520,7 @@ let approx_equal Code_id.equal code_id1 code_id2 && (Option.equal Code_id.equal) newer_version_of1 newer_version_of2 && Flambda_arity.equal_ignoring_subkinds params_arity1 params_arity2 + && List.equal Alloc_mode.For_types.equal param_modes1 param_modes2 && Int.equal first_complex_local_param1 first_complex_local_param2 && Flambda_arity.equal_ignoring_subkinds result_arity1 result_arity2 && Bool.equal contains_no_escaping_local_allocs1 diff --git a/middle_end/flambda2/terms/code_metadata.mli b/middle_end/flambda2/terms/code_metadata.mli index c4a576ffff0..47f6c75ec8b 100644 --- a/middle_end/flambda2/terms/code_metadata.mli +++ b/middle_end/flambda2/terms/code_metadata.mli @@ -33,6 +33,8 @@ module type Code_metadata_accessors_result_type = sig val params_arity : 'a t -> Flambda_arity.t + val param_modes : 'a t -> Alloc_mode.For_types.t list + (* Zero-indexed position of the first local param, to be able to determine the allocation modes of partial applications. If there is no local parameter, equal to the number of (complex) parameters. *) @@ -84,6 +86,7 @@ type 'a create_type = Code_id.t -> newer_version_of:Code_id.t option -> params_arity:Flambda_arity.t -> + param_modes:Alloc_mode.For_types.t list -> first_complex_local_param:int -> result_arity:Flambda_arity.t -> result_types:Result_types.t Or_unknown_or_bottom.t -> diff --git a/ocaml/bytecomp/bytegen.ml b/ocaml/bytecomp/bytegen.ml index f3db45b26a3..fd569d3e2c5 100644 --- a/ocaml/bytecomp/bytegen.ml +++ b/ocaml/bytecomp/bytegen.ml @@ -632,7 +632,7 @@ let rec comp_expr env exp sz cont = let lbl = new_label() in let fv = Ident.Set.elements(free_variables exp) in let to_compile = - { params = List.map fst params; body = body; label = lbl; + { params = List.map (fun p -> p.name) params; body = body; label = lbl; free_vars = fv; num_defs = 1; rec_vars = []; rec_pos = 0 } in Stack.push to_compile functions_to_compile; comp_args env (List.map (fun n -> Lvar n) fv) sz @@ -655,7 +655,7 @@ let rec comp_expr env exp sz cont = | (_id, Lfunction{params; body}) :: rem -> let lbl = new_label() in let to_compile = - { params = List.map fst params; body = body; label = lbl; + { params = List.map (fun p -> p.name) params; body = body; label = lbl; free_vars = fv; num_defs = ndecl; rec_vars = rec_idents; rec_pos = pos} in Stack.push to_compile functions_to_compile; diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index 6a7932f739a..a5d0e09878e 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/lambda/lambda.ml @@ -507,6 +507,15 @@ type function_attribute = { type scoped_location = Debuginfo.Scoped_location.t +type parameter_attribute = No_attributes + +type lparam = { + name : Ident.t; + layout : layout; + attributes : parameter_attribute; + mode : alloc_mode +} + type lambda = Lvar of Ident.t | Lmutvar of Ident.t @@ -538,7 +547,7 @@ type lambda = and lfunction = { kind: function_kind; - params: (Ident.t * layout) list; + params: lparam list; return: layout; body: lambda; attr: function_attribute; (* specified with [@inline] attribute *) @@ -677,6 +686,8 @@ let default_function_attribute = { let default_stub_attribute = { default_function_attribute with stub = true; check = Ignore_assert_all Zero_alloc } +let default_param_attribute = No_attributes + (* Build sharing keys *) (* Those keys are later compared with Stdlib.compare. @@ -863,7 +874,7 @@ let rec free_variables = function free_variables_list (free_variables fn) args | Lfunction{body; params} -> Ident.Set.diff (free_variables body) - (Ident.Set.of_list (List.map fst params)) + (Ident.Set.of_list (List.map (fun p -> p.name) params)) | Llet(_, _k, id, arg, body) | Lmutlet(_k, id, arg, body) -> Ident.Set.union @@ -1035,6 +1046,12 @@ let subst update_env ?(freshen_bound_variables = false) s input_lam = ((id', rhs) :: ids' , l) ) ids ([], l) in + let bind_params params l = + List.fold_right (fun p (params', l) -> + let name', l = bind p.name l in + ({ p with name = name' } :: params' , l) + ) params ([], l) + in let rec subst s l lam = match lam with | Lvar id as lam -> @@ -1059,7 +1076,7 @@ let subst update_env ?(freshen_bound_variables = false) s input_lam = Lapply{ap with ap_func = subst s l ap.ap_func; ap_args = subst_list s l ap.ap_args} | Lfunction lf -> - let params, l' = bind_many lf.params l in + let params, l' = bind_params lf.params l in Lfunction {lf with params; body = subst s l' lf.body} | Llet(str, k, id, arg, body) -> let id, l' = bind id l in diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli index b6236bfb775..71099ed200a 100644 --- a/ocaml/lambda/lambda.mli +++ b/ocaml/lambda/lambda.mli @@ -403,6 +403,14 @@ type function_attribute = { tmc_candidate: bool; } +type parameter_attribute = No_attributes + +type lparam = { + name : Ident.t; + layout : layout; + attributes : parameter_attribute; + mode : alloc_mode +} type scoped_location = Debuginfo.Scoped_location.t @@ -440,7 +448,7 @@ type lambda = and lfunction = private { kind: function_kind; - params: (Ident.t * layout) list; + params: lparam list; return: layout; body: lambda; attr: function_attribute; (* specified with [@inline] attribute *) @@ -555,7 +563,7 @@ val name_lambda_list: (lambda * layout) list -> (lambda list -> lambda) -> lambd val lfunction : kind:function_kind -> - params:(Ident.t * layout) list -> + params:lparam list -> return:layout -> body:lambda -> attr:function_attribute -> (* specified with [@inline] attribute *) @@ -640,6 +648,7 @@ val swap_float_comparison : float_comparison -> float_comparison val default_function_attribute : function_attribute val default_stub_attribute : function_attribute +val default_param_attribute : parameter_attribute val find_exact_application : function_kind -> arity:int -> lambda list -> lambda list option diff --git a/ocaml/lambda/printlambda.ml b/ocaml/lambda/printlambda.ml index 427120e9415..13a78eb1b59 100644 --- a/ocaml/lambda/printlambda.ml +++ b/ocaml/lambda/printlambda.ml @@ -670,7 +670,7 @@ let apply_specialised_attribute ppf = function | Always_specialise -> fprintf ppf " always_specialise" | Never_specialise -> fprintf ppf " never_specialise" -let apply_probe ppf = function +let apply_probe ppf : probe -> unit = function | None -> () | Some {name} -> fprintf ppf " (probe %s)" name @@ -705,16 +705,21 @@ let rec lam ppf = function match kind with | Curried {nlocal} -> fprintf ppf "@ {nlocal = %d}" nlocal; - List.iter (fun (param, k) -> - fprintf ppf "@ %a%a" Ident.print param layout k) params + List.iter (fun (p : Lambda.lparam) -> + (* Make sure we change this once there are attributes *) + let No_attributes = p.attributes in + fprintf ppf "@ %a%s%a" Ident.print p.name (alloc_kind p.mode) layout p.layout) params | Tupled -> fprintf ppf " ("; let first = ref true in List.iter - (fun (param, k) -> - if !first then first := false else fprintf ppf ",@ "; - Ident.print ppf param; - layout ppf k) + (fun (p : Lambda.lparam) -> + (* Make sure we change this once there are attributes *) + let No_attributes = p.attributes in + if !first then first := false else fprintf ppf ",@ "; + Ident.print ppf p.name; + Format.fprintf ppf "%s" (alloc_kind p.mode); + layout ppf p.layout) params; fprintf ppf ")" in let rmode = if region then alloc_heap else alloc_local in diff --git a/ocaml/lambda/simplif.ml b/ocaml/lambda/simplif.ml index e0969aee260..fa72a40273c 100644 --- a/ocaml/lambda/simplif.ml +++ b/ocaml/lambda/simplif.ml @@ -373,8 +373,9 @@ let exact_application {kind; params; _} args = Lambda.find_exact_application kind ~arity args let beta_reduce params body args = - List.fold_left2 (fun l (param, kind) arg -> Llet(Strict, kind, param, arg, l)) - body params args + List.fold_left2 + (fun l param arg -> Llet(Strict, param.layout, param.name, arg, l)) + body params args (* Simplification of lets *) @@ -778,7 +779,8 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body | Llet(Strict, k, id, (Lifthenelse(Lprim (Pisint _, [Lvar optparam], _), _, _, _) as def), rest) when - Ident.name optparam = "*opt*" && List.mem_assoc optparam params + Ident.name optparam = "*opt*" && + List.exists (fun p -> Ident.same p.name optparam) params && not (List.mem_assoc optparam map) -> let wrapper_body, inner = aux ((optparam, id) :: map) add_region rest in @@ -793,14 +795,20 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body List.iter (fun (id, _) -> if Ident.Set.mem id fv then raise Exit) map; let inner_id = Ident.create_local (Ident.name fun_id ^ "_inner") in - let map_param p layout = + let map_param p = try (* If the param is optional, then it must be a value *) - List.assoc p map, Lambda.layout_field + (* CR ncourant: is the mode necessarily heap? *) + { + name = List.assoc p.name map; + layout = Lambda.layout_field; + attributes = Lambda.default_param_attribute; + mode = alloc_heap + } with - Not_found -> p, layout + Not_found -> p in - let args = List.map (fun (p, layout) -> Lvar (fst (map_param p layout))) params in + let args = List.map (fun p -> Lvar (map_param p).name) params in let wrapper_body = Lapply { ap_func = Lvar inner_id; @@ -815,11 +823,13 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ap_probe=None; } in - let inner_params = List.map (fun (param, layout) -> map_param param layout) params in - let new_ids = List.map (fun (param, layout) -> (Ident.rename param, layout)) inner_params in + let inner_params = List.map map_param params in + let new_ids = + List.map (fun p -> { p with name = Ident.rename p.name }) inner_params + in let subst = - List.fold_left2 (fun s (id, _) (new_id, _) -> - Ident.Map.add id new_id s + List.fold_left2 (fun s p new_p -> + Ident.Map.add p.name new_p.name s ) Ident.Map.empty inner_params new_ids in let body = Lambda.rename subst body in @@ -1005,9 +1015,13 @@ let simplify_local_functions lam = | lam -> Lambda.shallow_map ~tail:rewrite ~non_tail:rewrite lam in + let new_params lf = + List.map + (fun p -> (p.name, p.layout)) lf.params + in List.fold_right (fun (st, lf) lam -> - Lstaticcatch (lam, (st, lf.params), rewrite lf.body, lf.return) + Lstaticcatch (lam, (st, new_params lf), rewrite lf.body, lf.return) ) (LamTbl.find_all static lam0) lam diff --git a/ocaml/lambda/simplif.mli b/ocaml/lambda/simplif.mli index 50eb33e9348..2bcacfed5dd 100644 --- a/ocaml/lambda/simplif.mli +++ b/ocaml/lambda/simplif.mli @@ -32,7 +32,7 @@ val simplify_lambda: lambda -> lambda val split_default_wrapper : id:Ident.t -> kind:function_kind - -> params:(Ident.t * Lambda.layout) list + -> params:Lambda.lparam list -> return:Lambda.layout -> body:lambda -> attr:function_attribute diff --git a/ocaml/lambda/tmc.ml b/ocaml/lambda/tmc.ml index 3d549135740..3d489c2e2c5 100644 --- a/ocaml/lambda/tmc.ml +++ b/ocaml/lambda/tmc.ml @@ -62,7 +62,9 @@ and offset = Offset of lambda let offset_code (Offset t) = t let add_dst_params ({var; offset} : Ident.t destination) params = - (var, Lambda.layout_block) :: (offset, Lambda.layout_int) :: params + { name = var ; layout = Lambda.layout_block ; attributes = Lambda.default_param_attribute; mode = alloc_heap } :: + { name = offset ; layout = Lambda.layout_int ; attributes = Lambda.default_param_attribute; mode = alloc_heap } :: + params let add_dst_args ({var; offset} : offset destination) args = Lvar var :: offset_code offset :: args diff --git a/ocaml/lambda/transl_list_comprehension.ml b/ocaml/lambda/transl_list_comprehension.ml index eb705471204..3528636dd6d 100644 --- a/ocaml/lambda/transl_list_comprehension.ml +++ b/ocaml/lambda/transl_list_comprehension.ml @@ -245,7 +245,17 @@ let rec translate_bindings ~kind:(Curried { nlocal = 2 }) (* Only the accumulator is local, but since the function itself is local, [nlocal] has to be equal to the number of parameters *) - ~params:[element, element_kind; inner_acc, Pvalue Pgenval] + ~params:[ + {name = element; + layout = element_kind; + attributes = Lambda.default_param_attribute; + (* CR ncourant: check *) + mode = alloc_heap}; + {name = inner_acc; + layout = Pvalue Pgenval; + attributes = Lambda.default_param_attribute; + mode = alloc_local} + ] ~return:(Pvalue Pgenval) ~attr:default_function_attribute ~loc diff --git a/ocaml/lambda/translclass.ml b/ocaml/lambda/translclass.ml index a24eeae0b4e..4fc314f77b0 100644 --- a/ocaml/lambda/translclass.ml +++ b/ocaml/lambda/translclass.ml @@ -67,6 +67,9 @@ let lapply ap = | _ -> Lapply ap +let lparam name layout : Lambda.lparam = + { name; layout; attributes = Lambda.default_param_attribute; mode = alloc_heap } + let mkappl (func, args, layout) = Lprim (Popaque layout, @@ -217,7 +220,7 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl = in Lambda.lfunction ~kind:(Curried {nlocal=0}) - ~params:((param, arg_layout)::params) + ~params:(lparam param arg_layout::params) ~return:layout_obj ~attr:default_function_attribute ~loc:(of_location ~scopes pat.pat_loc) @@ -261,9 +264,9 @@ let rec build_object_init_0 let ((_,inh_init), obj_init) = build_object_init ~scopes cl_table obj params (envs,[]) copy_env cl in let obj_init = - if ids = [] then obj_init else lfunction layout_obj [self, layout_obj] obj_init in + if ids = [] then obj_init else lfunction layout_obj [lparam self layout_obj] obj_init in (inh_init, lfunction (if ids = [] then layout_obj else layout_function) - [env, layout_block] (subst_env env inh_init obj_init)) + [lparam env layout_block] (subst_env env inh_init obj_init)) let bind_method tbl lab id cl_init = @@ -505,7 +508,7 @@ let rec transl_class_rebind ~scopes obj_init cl vf = in Lambda.lfunction ~kind:(Curried {nlocal=0}) - ~params:((param, arg_layout)::params) + ~params:(lparam param arg_layout :: params) ~return:return_layout ~attr:default_function_attribute ~loc:(of_location ~scopes pat.pat_loc) @@ -555,7 +558,7 @@ let rec transl_class_rebind_0 ~scopes (self:Ident.t) obj_init cl vf = | _ -> let path, path_lam, obj_init = transl_class_rebind ~scopes obj_init cl vf in - (path, path_lam, lfunction layout_obj [self, layout_obj] obj_init) + (path, path_lam, lfunction layout_obj [lparam self layout_obj] obj_init) let transl_class_rebind ~scopes cl vf = try @@ -577,7 +580,7 @@ let transl_class_rebind ~scopes cl vf = in let _, path_lam, obj_init' = transl_class_rebind_0 ~scopes self obj_init0 cl vf in - let id = (obj_init' = lfunction layout_obj [self, layout_obj] obj_init0) in + let id = (obj_init' = lfunction layout_obj [lparam self layout_obj] obj_init0) in if id then path_lam else let cla = Ident.create_local "class" @@ -586,15 +589,15 @@ let transl_class_rebind ~scopes cl vf = and table = Ident.create_local "table" and envs = Ident.create_local "envs" in Llet( - Strict, layout_function, new_init, lfunction layout_function [obj_init, layout_function] obj_init', + Strict, layout_function, new_init, lfunction layout_function [lparam obj_init layout_function] obj_init', Llet( Alias, layout_block, cla, path_lam, Lprim(Pmakeblock(0, Immutable, None, alloc_heap), [mkappl(Lvar new_init, [lfield cla 0], layout_function); - lfunction layout_function [table, layout_table] + lfunction layout_function [lparam table layout_table] (Llet(Strict, layout_function, env_init, mkappl(lfield cla 1, [Lvar table], layout_function), - lfunction layout_function [envs, layout_block] + lfunction layout_function [lparam envs layout_block] (mkappl(Lvar new_init, [mkappl(Lvar env_init, [Lvar envs], layout_obj)], layout_function)))); lfield cla 2; @@ -648,7 +651,7 @@ let rec builtin_meths self env env2 body = | Lsend(Cached, met, arg, [_;_], _, _, _, _) -> let s, args = conv arg in ("send_"^s, met :: args) - | Lfunction {kind = Curried _; params = [x, _]; body} -> + | Lfunction {kind = Curried _; params = [{name = x; _}]; body} -> let rec enter self = function | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _) when Ident.same x x' && List.mem s self -> @@ -731,7 +734,7 @@ let free_methods l = fv := Ident.Set.add meth !fv | Lsend _ -> () | Lfunction{params} -> - List.iter (fun (param, _) -> fv := Ident.Set.remove param !fv) params + List.iter (fun p -> fv := Ident.Set.remove p.name !fv) params | Llet(_, _k, id, _arg, _body) | Lmutlet(_k, id, _arg, _body) -> fv := Ident.Set.remove id !fv @@ -790,7 +793,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = let no_env_update _ _ env = env in let msubst arr = function Lfunction {kind = Curried _ as kind; region; - params = (self, layout) :: args; return; body} -> + params = self :: args; return; body} -> let env = Ident.create_local "env" in let body' = if new_ids = [] then body else @@ -799,13 +802,13 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = (* Doesn't seem to improve size for bytecode *) (* if not !Clflags.native_code then raise Not_found; *) if not arr || !Clflags.debug then raise Not_found; - builtin_meths [self] env env2 (lfunction return args body') + builtin_meths [self.name] env env2 (lfunction return args body') with Not_found -> - [lfunction ~kind ~region return ((self, layout) :: args) + [lfunction ~kind ~region return (self :: args) (if not (Ident.Set.mem env (free_variables body')) then body' else Llet(Alias, layout_block, env, Lprim(Pfield_computed Reads_vary, - [Lvar self; Lvar env2], + [Lvar self.name; Lvar env2], Loc_unknown), body'))] end @@ -873,7 +876,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~return:layout_function ~mode:alloc_heap ~region:true - ~params:[cla, layout_table] ~body:cl_init) in + ~params:[lparam cla layout_table] ~body:cl_init) in Llet(Strict, layout_function, class_init, cl_init, lam (free_variables cl_init)) and lbody fv = if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then @@ -898,7 +901,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~return:layout_function ~mode:alloc_heap ~region:true - ~params:[cla, layout_table] ~body:cl_init; + ~params:[lparam cla layout_table] ~body:cl_init; lambda_unit; lenvs], Loc_unknown) in @@ -952,7 +955,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = let lclass lam = Llet(Strict, layout_function, class_init, Lambda.lfunction - ~kind:(Curried {nlocal=0}) ~params:[cla, layout_table] + ~kind:(Curried {nlocal=0}) ~params:[lparam cla layout_table] ~return:layout_function ~attr:default_function_attribute ~loc:Loc_unknown @@ -984,7 +987,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~mode:alloc_heap ~region:true ~return:layout_function - ~params:[cla, layout_table] + ~params:[lparam cla layout_table] ~body:(def_ids cla cl_init)) in let lupdate_cache = diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 44cc9bc2fe0..661a4dfe5c0 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -819,7 +819,10 @@ and transl_exp0 ~in_new_scope ~scopes sort e = typechecker enforces that e has layout value. *) let scopes = enter_lazy ~scopes in let fn = lfunction ~kind:(Curried {nlocal=0}) - ~params:[Ident.create_local "param", Lambda.layout_unit] + ~params:[{ name = Ident.create_local "param"; + layout = Lambda.layout_unit; + attributes = Lambda.default_param_attribute; + mode = alloc_heap}] ~return:Lambda.layout_lazy_contents ~attr:default_function_attribute ~loc:(of_location ~scopes e.exp_loc) @@ -940,7 +943,8 @@ and transl_exp0 ~in_new_scope ~scopes sort e = ~kind:(Curried {nlocal=0}) (* CR layouts: Adjust param layouts when we allow other things in probes. *) - ~params:(List.map (fun v -> v, layout_probe_arg) param_idents) + (* CR ncourant: can we assume the mode is always heap? *) + ~params:(List.map (fun name -> { name; layout = layout_probe_arg; attributes = Lambda.default_param_attribute; mode = alloc_heap }) param_idents) ~return:return_layout ~body ~loc:(of_location ~scopes exp.exp_loc) @@ -1140,7 +1144,7 @@ and transl_apply ~scopes | Alloc_heap -> true in let layout_arg = layout_of_sort (to_location loc) sort_arg in - lfunction ~kind:(Curried {nlocal}) ~params:[id_arg, layout_arg] + lfunction ~kind:(Curried {nlocal}) ~params:[{ name = id_arg; layout = layout_arg; attributes = Lambda.default_param_attribute; mode = arg_mode}] ~return:result_layout ~body ~mode ~region ~attr:default_stub_attribute ~loc in @@ -1162,11 +1166,11 @@ and transl_apply ~scopes build_apply lam [] loc position mode args and transl_curried_function - ~scopes ~arg_sort ~arg_layout ~return_sort ~return_layout loc repr ~region + ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort ~return_layout loc repr ~region ~curry partial warnings (param:Ident.t) cases = let max_arity = Lambda.max_arity () in let rec loop ~scopes ~arg_sort ~arg_layout ~return_sort ~return_layout loc - ~arity ~region ~curry partial warnings (param:Ident.t) cases = + ~arity ~region ~curry ~arg_mode partial warnings (param:Ident.t) cases = match curry, cases with More_args {partial_mode}, [{c_lhs=pat; c_guard=None; @@ -1175,7 +1179,7 @@ and transl_curried_function { arg_label = _; param = param'; cases = cases'; partial = partial'; region = region'; curry = curry'; - warnings = warnings'; arg_sort; ret_sort }; + warnings = warnings'; arg_mode = arg_mode'; arg_sort; ret_sort }; exp_env; exp_type; exp_loc }}] when arity < max_arity -> (* Lfunctions must have local returns after the first local arg/ret *) @@ -1189,7 +1193,7 @@ and transl_curried_function let arg_layout = function_arg_layout exp_env exp_loc arg_sort exp_type in - loop ~scopes ~arg_sort ~arg_layout ~return_sort:ret_sort + loop ~scopes ~arg_sort ~arg_layout ~arg_mode:arg_mode' ~return_sort:ret_sort ~return_layout exp_loc ~arity:(arity + 1) ~region:region' ~curry:curry' partial' warnings' param' cases' in @@ -1204,7 +1208,8 @@ and transl_curried_function assert (nlocal = List.length params); Curried {nlocal = nlocal + 1} in - ((fnkind, (param, arg_layout) :: params, return_layout, region), + let arg_mode = transl_alloc_mode arg_mode in + ((fnkind, { name = param; layout = arg_layout; attributes = Lambda.default_param_attribute; mode = arg_mode } :: params, return_layout, region), Matching.for_function ~scopes ~arg_sort ~arg_layout ~return_layout loc None (Lvar param) [pat, body] partial) else begin @@ -1217,19 +1222,19 @@ and transl_curried_function Warnings.restore prev | Partial -> () end; - transl_tupled_function ~scopes ~arg_sort ~arg_layout + transl_tupled_function ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort:ret_sort ~return_layout ~arity ~region ~curry loc repr partial param cases end | curry, cases -> - transl_tupled_function ~scopes ~arg_sort ~arg_layout ~return_sort + transl_tupled_function ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort ~return_layout ~arity ~region ~curry loc repr partial param cases in - loop ~scopes ~arg_sort ~arg_layout ~return_sort ~return_layout loc ~arity:1 + loop ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort ~return_layout loc ~arity:1 ~region ~curry partial warnings param cases and transl_tupled_function - ~scopes ~arg_layout ~arg_sort ~return_sort ~return_layout ~arity ~region + ~scopes ~arg_layout ~arg_sort ~arg_mode ~return_sort ~return_layout ~arity ~region ~curry loc repr partial (param:Ident.t) cases = let partial_mode = match curry with @@ -1260,9 +1265,9 @@ and transl_tupled_function Argument should be a tuple, but couldn't get the kinds" in let tparams = - List.map (fun kind -> Ident.create_local "param", kind) kinds + List.map (fun kind -> { name = Ident.create_local "param"; layout = kind; attributes = Lambda.default_param_attribute; mode = alloc_heap }) kinds in - let params = List.map fst tparams in + let params = List.map (fun p -> p.name) tparams in let body = Matching.for_tupled_function ~scopes ~return_layout loc params (transl_tupled_cases ~scopes return_sort pats_expr_list) partial @@ -1270,14 +1275,14 @@ and transl_tupled_function let region = region || not (may_allocate_in_region body) in ((Tupled, tparams, return_layout, region), body) with Matching.Cannot_flatten -> - transl_function0 ~scopes ~arg_sort ~arg_layout ~return_sort ~return_layout + transl_function0 ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort ~return_layout loc ~region ~partial_mode repr partial param cases end - | _ -> transl_function0 ~scopes ~arg_sort ~arg_layout ~return_sort + | _ -> transl_function0 ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort ~return_layout loc ~region ~partial_mode repr partial param cases and transl_function0 - ~scopes ~arg_sort ~arg_layout ~return_sort ~return_layout loc ~region + ~scopes ~arg_sort ~arg_layout ~arg_mode ~return_sort ~return_layout loc ~region ~partial_mode repr partial (param:Ident.t) cases = let body = Matching.for_function ~scopes ~arg_sort ~arg_layout ~return_layout loc @@ -1290,7 +1295,8 @@ and transl_function0 | Alloc_local -> 1 | Alloc_heap -> 0 in - ((Curried {nlocal}, [param, arg_layout], return_layout, region), body) + let arg_mode = transl_alloc_mode arg_mode in + ((Curried {nlocal}, [{ name = param; layout = arg_layout; attributes = Lambda.default_param_attribute; mode = arg_mode}], return_layout, region), body) and transl_function ~scopes e alloc_mode param arg_mode arg_sort return_sort cases partial warnings region curry = @@ -1307,7 +1313,7 @@ and transl_function ~scopes e alloc_mode param arg_mode arg_sort return_sort let return_layout = function_return_layout e.exp_env e.exp_loc return_sort e.exp_type in - transl_curried_function ~arg_sort ~arg_layout ~return_sort + transl_curried_function ~arg_sort ~arg_layout ~arg_mode ~return_sort ~return_layout ~scopes e.exp_loc repr ~region ~curry partial warnings param pl) in @@ -1717,8 +1723,9 @@ and transl_letop ~scopes loc env let_ ands param param_sort case case_sort event_function ~scopes case.c_rhs (function repr -> transl_curried_function ~scopes ~arg_sort:param_sort ~arg_layout - ~return_sort:case_sort ~return_layout case.c_rhs.exp_loc repr - ~region:true ~curry partial warnings param [case]) + ~arg_mode:(Amode Global) ~return_sort:case_sort + ~return_layout case.c_rhs.exp_loc repr ~region:true ~curry partial + warnings param [case]) in let attr = default_function_attribute in let loc = of_location ~scopes case.c_rhs.exp_loc in diff --git a/ocaml/lambda/translmod.ml b/ocaml/lambda/translmod.ml index c63d5595181..f7514bbbe29 100644 --- a/ocaml/lambda/translmod.ml +++ b/ocaml/lambda/translmod.ml @@ -131,7 +131,7 @@ let rec apply_coercion loc strict restr arg = | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create_local "funarg" in let carg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict arg [param, Lambda.layout_module] [carg] cc_res + apply_coercion_result loc strict arg [{name = param; layout = Lambda.layout_module; attributes = Lambda.default_param_attribute; mode = alloc_heap}] [carg] cc_res | Tcoerce_primitive { pc_desc; pc_env; pc_type; pc_poly_mode } -> Translprim.transl_primitive loc pc_desc pc_env pc_type ~poly_mode:pc_poly_mode None | Tcoerce_alias (env, path, cc) -> @@ -148,7 +148,7 @@ and apply_coercion_result loc strict funct params args cc_res = let param = Ident.create_local "funarg" in let arg = apply_coercion loc Alias cc_arg (Lvar param) in apply_coercion_result loc strict funct - ((param, Lambda.layout_module) :: params) (arg :: args) cc_res + ({ name = param; layout = Lambda.layout_module; attributes = Lambda.default_param_attribute; mode = alloc_heap} :: params) (arg :: args) cc_res | _ -> name_lambda strict funct Lambda.layout_functor (fun id -> @@ -559,7 +559,7 @@ let rec compile_functor ~scopes mexp coercion root_path loc = List.fold_left (fun (params, body) (param, loc, arg_coercion) -> let param' = Ident.rename param in let arg = apply_coercion loc Alias arg_coercion (Lvar param') in - let params = (param', Lambda.layout_module) :: params in + let params = {name = param'; layout = Lambda.layout_module; attributes = Lambda.default_param_attribute; mode = alloc_heap} :: params in let body = Llet (Alias, Lambda.layout_module, param, arg, body) in params, body) ([], transl_module ~scopes res_coercion body_path body) diff --git a/ocaml/lambda/translprim.ml b/ocaml/lambda/translprim.ml index b3dd12b3c92..d138199d4be 100644 --- a/ocaml/lambda/translprim.ml +++ b/ocaml/lambda/translprim.ml @@ -887,12 +887,13 @@ let transl_primitive loc p env ty ~poly_mode path = | None -> prim | Some prim -> prim in + let to_alloc_mode = to_alloc_mode ~poly:poly_mode in let rec make_params ty repr_args repr_res = match repr_args, repr_res with | [], (_, res_repr) -> let res_sort = sort_of_native_repr res_repr in [], Typeopt.layout env (to_location loc) (Sort.of_const res_sort) ty - | ((_, arg_repr) :: repr_args), _ -> + | (((_, arg_repr) as arg) :: repr_args), _ -> match Typeopt.is_function_type env ty with | None -> Misc.fatal_errorf "Primitive %s type does not correspond to arity" @@ -902,13 +903,18 @@ let transl_primitive loc p env ty ~poly_mode path = let arg_layout = Typeopt.layout env (to_location loc) (Sort.of_const arg_sort) arg_ty in + let arg_mode = to_alloc_mode arg in let params, return = make_params ret_ty repr_args repr_res in - (Ident.create_local "prim", arg_layout) :: params, return + { name = Ident.create_local "prim"; + layout = arg_layout; + attributes = Lambda.default_param_attribute; + mode = arg_mode } + :: params, return in let params, return = make_params ty p.prim_native_repr_args p.prim_native_repr_res in - let args = List.map (fun (id, _) -> Lvar id) params in + let args = List.map (fun p -> Lvar p.name) params in match params with | [] -> lambda_of_prim p.prim_name prim loc args None | _ -> @@ -918,8 +924,6 @@ let transl_primitive loc p env ty ~poly_mode path = loc in let body = lambda_of_prim p.prim_name prim loc args None in - let to_alloc_mode m = to_alloc_mode ~poly:poly_mode m in - let arg_modes = List.map to_alloc_mode p.prim_native_repr_args in let region = match to_alloc_mode p.prim_native_repr_res with | Alloc_heap -> true @@ -931,7 +935,7 @@ let transl_primitive loc p env ty ~poly_mode path = | Alloc_heap :: args -> count_nlocal args | (Alloc_local :: _) as args -> List.length args in - let nlocal = count_nlocal arg_modes in + let nlocal = count_nlocal (List.map to_alloc_mode p.prim_native_repr_args) in lfunction ~kind:(Curried {nlocal}) ~params diff --git a/ocaml/middle_end/closure/closure.ml b/ocaml/middle_end/closure/closure.ml index 7d009724b70..a44d3c53227 100644 --- a/ocaml/middle_end/closure/closure.ml +++ b/ocaml/middle_end/closure/closure.ml @@ -1611,7 +1611,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ their wrapper functions) to be inlined *) let n = List.fold_left - (fun n (id, _) -> n + if V.name id = "*opt*" then 8 else 1) + (fun n (id, _, _) -> n + if V.name id = "*opt*" then 8 else 1) 0 fun_params in @@ -1627,7 +1627,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ | Never_inline -> min_int | Unroll _ -> assert false in - let fun_params = List.map (fun (var, _) -> VP.create var) fun_params in + let fun_params = List.map (fun (var, _, _) -> VP.create var) fun_params in if lambda_smaller ubody threshold then fundesc.fun_inline <- Some(fun_params, ubody); From 71a78819b8e326dd195c1afa47893fbca5717178 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Tue, 4 Jul 2023 10:22:04 +0200 Subject: [PATCH 2/7] fix long lines --- ocaml/lambda/printlambda.ml | 3 ++- ocaml/lambda/tmc.ml | 7 +++++-- ocaml/lambda/translclass.ml | 5 ++++- ocaml/lambda/translcore.ml | 31 +++++++++++++++++++++++++++---- ocaml/lambda/translmod.ml | 18 +++++++++++++++--- 5 files changed, 53 insertions(+), 11 deletions(-) diff --git a/ocaml/lambda/printlambda.ml b/ocaml/lambda/printlambda.ml index 13a78eb1b59..e0e8fb85226 100644 --- a/ocaml/lambda/printlambda.ml +++ b/ocaml/lambda/printlambda.ml @@ -708,7 +708,8 @@ let rec lam ppf = function List.iter (fun (p : Lambda.lparam) -> (* Make sure we change this once there are attributes *) let No_attributes = p.attributes in - fprintf ppf "@ %a%s%a" Ident.print p.name (alloc_kind p.mode) layout p.layout) params + fprintf ppf "@ %a%s%a" + Ident.print p.name (alloc_kind p.mode) layout p.layout) params | Tupled -> fprintf ppf " ("; let first = ref true in diff --git a/ocaml/lambda/tmc.ml b/ocaml/lambda/tmc.ml index 3d489c2e2c5..4c7aa9c9dea 100644 --- a/ocaml/lambda/tmc.ml +++ b/ocaml/lambda/tmc.ml @@ -62,8 +62,11 @@ and offset = Offset of lambda let offset_code (Offset t) = t let add_dst_params ({var; offset} : Ident.t destination) params = - { name = var ; layout = Lambda.layout_block ; attributes = Lambda.default_param_attribute; mode = alloc_heap } :: - { name = offset ; layout = Lambda.layout_int ; attributes = Lambda.default_param_attribute; mode = alloc_heap } :: + (* CR ncourant: are these modes necessarily heap? *) + { name = var ; layout = Lambda.layout_block ; + attributes = Lambda.default_param_attribute ; mode = alloc_heap } :: + { name = offset ; layout = Lambda.layout_int ; + attributes = Lambda.default_param_attribute ; mode = alloc_heap } :: params let add_dst_args ({var; offset} : offset destination) args = diff --git a/ocaml/lambda/translclass.ml b/ocaml/lambda/translclass.ml index 4fc314f77b0..32e60a90fe4 100644 --- a/ocaml/lambda/translclass.ml +++ b/ocaml/lambda/translclass.ml @@ -68,7 +68,10 @@ let lapply ap = Lapply ap let lparam name layout : Lambda.lparam = - { name; layout; attributes = Lambda.default_param_attribute; mode = alloc_heap } + (* CR ncourant: we assume all parameters defined with this function + are alloc_heap. Are we sure this is true? *) + { name; layout; + attributes = Lambda.default_param_attribute; mode = alloc_heap } let mkappl (func, args, layout) = Lprim diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 661a4dfe5c0..dd2098cc585 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -1144,7 +1144,13 @@ and transl_apply ~scopes | Alloc_heap -> true in let layout_arg = layout_of_sort (to_location loc) sort_arg in - lfunction ~kind:(Curried {nlocal}) ~params:[{ name = id_arg; layout = layout_arg; attributes = Lambda.default_param_attribute; mode = arg_mode}] + let params = [{ + name = id_arg; + layout = layout_arg; + attributes = Lambda.default_param_attribute; + mode = arg_mode + }] in + lfunction ~kind:(Curried {nlocal}) ~params ~return:result_layout ~body ~mode ~region ~attr:default_stub_attribute ~loc in @@ -1209,7 +1215,14 @@ and transl_curried_function Curried {nlocal = nlocal + 1} in let arg_mode = transl_alloc_mode arg_mode in - ((fnkind, { name = param; layout = arg_layout; attributes = Lambda.default_param_attribute; mode = arg_mode } :: params, return_layout, region), + let params = { + name = param ; + layout = arg_layout ; + attributes = Lambda.default_param_attribute ; + mode = arg_mode + } :: params + in + ((fnkind, params, return_layout, region), Matching.for_function ~scopes ~arg_sort ~arg_layout ~return_layout loc None (Lvar param) [pat, body] partial) else begin @@ -1265,7 +1278,12 @@ and transl_tupled_function Argument should be a tuple, but couldn't get the kinds" in let tparams = - List.map (fun kind -> { name = Ident.create_local "param"; layout = kind; attributes = Lambda.default_param_attribute; mode = alloc_heap }) kinds + List.map (fun kind -> { + name = Ident.create_local "param"; + layout = kind; + attributes = Lambda.default_param_attribute; + mode = alloc_heap + }) kinds in let params = List.map (fun p -> p.name) tparams in let body = @@ -1296,7 +1314,12 @@ and transl_function0 | Alloc_heap -> 0 in let arg_mode = transl_alloc_mode arg_mode in - ((Curried {nlocal}, [{ name = param; layout = arg_layout; attributes = Lambda.default_param_attribute; mode = arg_mode}], return_layout, region), body) + ((Curried {nlocal}, + [{ name = param; + layout = arg_layout; + attributes = Lambda.default_param_attribute; + mode = arg_mode}], + return_layout, region), body) and transl_function ~scopes e alloc_mode param arg_mode arg_sort return_sort cases partial warnings region curry = diff --git a/ocaml/lambda/translmod.ml b/ocaml/lambda/translmod.ml index f7514bbbe29..5bafd4617b2 100644 --- a/ocaml/lambda/translmod.ml +++ b/ocaml/lambda/translmod.ml @@ -131,7 +131,10 @@ let rec apply_coercion loc strict restr arg = | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create_local "funarg" in let carg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict arg [{name = param; layout = Lambda.layout_module; attributes = Lambda.default_param_attribute; mode = alloc_heap}] [carg] cc_res + apply_coercion_result loc strict arg + [{name = param; layout = Lambda.layout_module; + attributes = Lambda.default_param_attribute; mode = alloc_heap}] + [carg] cc_res | Tcoerce_primitive { pc_desc; pc_env; pc_type; pc_poly_mode } -> Translprim.transl_primitive loc pc_desc pc_env pc_type ~poly_mode:pc_poly_mode None | Tcoerce_alias (env, path, cc) -> @@ -148,7 +151,11 @@ and apply_coercion_result loc strict funct params args cc_res = let param = Ident.create_local "funarg" in let arg = apply_coercion loc Alias cc_arg (Lvar param) in apply_coercion_result loc strict funct - ({ name = param; layout = Lambda.layout_module; attributes = Lambda.default_param_attribute; mode = alloc_heap} :: params) (arg :: args) cc_res + ({ name = param; + layout = Lambda.layout_module; + attributes = Lambda.default_param_attribute; + mode = alloc_heap } :: params) + (arg :: args) cc_res | _ -> name_lambda strict funct Lambda.layout_functor (fun id -> @@ -559,7 +566,12 @@ let rec compile_functor ~scopes mexp coercion root_path loc = List.fold_left (fun (params, body) (param, loc, arg_coercion) -> let param' = Ident.rename param in let arg = apply_coercion loc Alias arg_coercion (Lvar param') in - let params = {name = param'; layout = Lambda.layout_module; attributes = Lambda.default_param_attribute; mode = alloc_heap} :: params in + let params = { + name = param'; + layout = Lambda.layout_module; + attributes = Lambda.default_param_attribute; + mode = alloc_heap + } :: params in let body = Llet (Alias, Lambda.layout_module, param, arg, body) in params, body) ([], transl_module ~scopes res_coercion body_path body) From ce121c3b945aa8c6cd0dc5fdcd3a0b3c0e4d34f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Tue, 4 Jul 2023 10:28:20 +0200 Subject: [PATCH 3/7] backport to ocaml/ --- ocaml/middle_end/closure/closure.ml | 46 +++++++++---------- .../middle_end/flambda/closure_conversion.ml | 4 ++ 2 files changed, 27 insertions(+), 23 deletions(-) diff --git a/ocaml/middle_end/closure/closure.ml b/ocaml/middle_end/closure/closure.ml index a44d3c53227..d00c42530d9 100644 --- a/ocaml/middle_end/closure/closure.ml +++ b/ocaml/middle_end/closure/closure.ml @@ -868,7 +868,7 @@ let warning_if_forced_inlined ~loc ~attribute warning = Location.prerr_warning (Debuginfo.Scoped_location.to_location loc) (Warnings.Inlining_impossible warning) -let fail_if_probe ~probe msg = +let fail_if_probe ~(probe : Lambda.probe) msg = match probe with | None -> () | Some {name} -> @@ -1082,8 +1082,22 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) List.fold_left (fun kinds (arg, _, kind) -> V.Map.add arg kind kinds) kinds first_args in + let new_clos_mode, kind = + (* If the closure has a local suffix, and we've supplied + enough args to hit it, then the closure must be local + (because the args or closure might be). *) + let nparams = List.length params_layout in + assert (nparams >= nlocal); + let heap_params = nparams - nlocal in + if nargs <= heap_params then + alloc_heap, Curried {nlocal} + else + let supplied_local_args = nargs - heap_params in + alloc_local, Curried {nlocal = nlocal - supplied_local_args} + in + if is_local_mode clos_mode then assert (is_local_mode new_clos_mode); let final_args = - List.map (fun kind -> V.create_local "arg", kind) rem_layouts + List.map (fun kind -> { name = V.create_local "arg"; layout = kind; attributes = Lambda.default_param_attribute; mode = new_clos_mode}) rem_layouts in let rec iter args body = match args with @@ -1094,26 +1108,11 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) in let internal_args = (List.map (fun (arg1, _arg2, _) -> Lvar arg1) first_args) - @ (List.map (fun (arg, _) -> Lvar arg ) final_args) + @ (List.map (fun p -> Lvar p.name ) final_args) in let funct_var = V.create_local "funct" in let fenv = V.Map.add funct_var fapprox fenv in let kinds = V.Map.add funct_var Lambda.layout_function kinds in - let new_clos_mode, kind = - (* If the closure has a local suffix, and we've supplied - enough args to hit it, then the closure must be local - (because the args or closure might be). *) - let nparams = List.length params_layout in - assert (nparams >= nlocal); - let heap_params = nparams - nlocal in - if nargs <= heap_params then - alloc_heap, Curried {nlocal} - else - let supplied_local_args = nargs - heap_params in - alloc_local, Curried {nlocal = nlocal - supplied_local_args} - in - if Lambda.is_local_mode clos_mode then - assert (Lambda.is_local_mode new_clos_mode); let ret_mode = if fundesc.fun_region then alloc_heap else alloc_local in @@ -1516,7 +1515,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ {fun_label = label; fun_arity = { function_kind = kind ; - params_layout = List.map snd params ; + params_layout = List.map (fun p -> p.layout) params ; return_layout = return }; fun_closed = initially_closed; @@ -1525,7 +1524,8 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ fun_region = region; fun_poll = attr.poll } in let dbg = Debuginfo.from_location loc in - (id, params, return, body, mode, fundesc, dbg) + (id, List.map (fun (p : Lambda.lparam) -> let No_attributes = p.attributes in (p.name, p.layout, p.mode)) params, + return, body, mode, attrib, fundesc, dbg) | (_, _) -> fatal_error "Closure.close_functions") fun_defs in (* Build an approximate fenv for compiling the functions *) @@ -1575,7 +1575,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ in let kinds_body = List.fold_right - (fun (id, kind) kinds -> V.Map.add id kind kinds) + (fun (id, kind, _) kinds -> V.Map.add id kind kinds) params (V.Map.add env_param Lambda.layout_function kinds_rec) in let (ubody, approx) = @@ -1593,13 +1593,13 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ let fun_params = if !useless_env then params - else params @ [env_param, Lambda.layout_function] + else params @ [env_param, Lambda.layout_function, alloc_heap] in let f = { label = fundesc.fun_label; arity = fundesc.fun_arity; - params = List.map (fun (var, _) -> VP.create var) fun_params; + params = List.map (fun (var, _, _) -> VP.create var) fun_params; body = ubody; dbg; env = Some env_param; diff --git a/ocaml/middle_end/flambda/closure_conversion.ml b/ocaml/middle_end/flambda/closure_conversion.ml index 61e854d2a8e..f850b9cb39e 100644 --- a/ocaml/middle_end/flambda/closure_conversion.ml +++ b/ocaml/middle_end/flambda/closure_conversion.ml @@ -222,6 +222,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = (* CR-soon mshinwell: some of this is now very similar to the let rec case below *) let set_of_closures_var = Variable.create Names.set_of_closures in + let params = List.map (fun (p : Lambda.lparam) -> let No_attributes = p.attributes in (p.name, p.layout)) params in let set_of_closures = let decl = Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind ~mode @@ -274,6 +275,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = let closure_bound_var = Variable.create_with_same_name_as_ident let_rec_ident in + let params = List.map (fun (p : Lambda.lparam) -> let No_attributes = p.attributes in (p.name, p.layout)) params in let function_declaration = Function_decl.create ~let_rec_ident:(Some let_rec_ident) ~closure_bound_var ~kind ~mode ~region @@ -620,6 +622,7 @@ and close_functions t external_env function_declarations : Flambda.named = Misc.fatal_error "Closure_conversion: Tupled Alloc_local function found" in let params = List.mapi (fun i (v, kind) -> + (* CR ncourant: actually now we have the alloc_mode in lambda, propagate it *) let alloc_mode = if i < nheap then Lambda.alloc_heap else Lambda.alloc_local in Parameter.wrap v alloc_mode kind) param_vars @@ -691,6 +694,7 @@ and close_let_bound_expression t ?let_rec_ident let_bound_var env (* Ensure that [let] and [let rec]-bound functions have appropriate names. *) let closure_bound_var = Variable.rename let_bound_var in + let params = List.map (fun (p : Lambda.lparam) -> let No_attributes = p.attributes in (p.name, p.layout)) params in let decl = Function_decl.create ~let_rec_ident ~closure_bound_var ~kind ~mode ~region ~params ~body ~attr ~loc ~return_layout:return From 18d3f27f7a08bf7c3b3bdcc2b4433df720d127ed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Tue, 4 Jul 2023 12:45:02 +0200 Subject: [PATCH 4/7] fix backport --- ocaml/middle_end/closure/closure.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/middle_end/closure/closure.ml b/ocaml/middle_end/closure/closure.ml index d00c42530d9..33bfe6b59a2 100644 --- a/ocaml/middle_end/closure/closure.ml +++ b/ocaml/middle_end/closure/closure.ml @@ -1525,7 +1525,7 @@ and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_ fun_poll = attr.poll } in let dbg = Debuginfo.from_location loc in (id, List.map (fun (p : Lambda.lparam) -> let No_attributes = p.attributes in (p.name, p.layout, p.mode)) params, - return, body, mode, attrib, fundesc, dbg) + return, body, mode, fundesc, dbg) | (_, _) -> fatal_error "Closure.close_functions") fun_defs in (* Build an approximate fenv for compiling the functions *) From 879635df8d05dfe096c68388af03dc7b3c20d867 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Tue, 4 Jul 2023 15:55:35 +0200 Subject: [PATCH 5/7] review --- middle_end/closure/closure.ml | 9 ++++++++- middle_end/flambda2/parser/fexpr_to_flambda.ml | 1 + ocaml/lambda/translclass.ml | 2 -- ocaml/middle_end/closure/closure.ml | 9 ++++++++- 4 files changed, 17 insertions(+), 4 deletions(-) diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index 78b7239ce99..6ded86e026e 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -1094,8 +1094,15 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) alloc_local, Curried {nlocal = nlocal - supplied_local_args} in if is_local_mode clos_mode then assert (is_local_mode new_clos_mode); + (* CR ncourant: mode = new_clos_mode is incorrect; but the modes will + not be used for anything, so it is fine here. *) let final_args = - List.map (fun kind -> { name = V.create_local "arg"; layout = kind; attributes = Lambda.default_param_attribute; mode = new_clos_mode}) rem_layouts + List.map (fun kind -> { + name = V.create_local "arg"; + layout = kind; + attributes = Lambda.default_param_attribute; + mode = new_clos_mode + }) rem_layouts in let rec iter args body = match args with diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index 44ea7d76e59..f77492948c4 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -885,6 +885,7 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let cost_metrics = Cost_metrics.from_size (Code_size.of_int code_size) in + (* CR ncourant: allow fexpr to specify param modes? *) let param_modes = List.map (fun _ -> Alloc_mode.For_types.heap) diff --git a/ocaml/lambda/translclass.ml b/ocaml/lambda/translclass.ml index 32e60a90fe4..ee9db420ab8 100644 --- a/ocaml/lambda/translclass.ml +++ b/ocaml/lambda/translclass.ml @@ -68,8 +68,6 @@ let lapply ap = Lapply ap let lparam name layout : Lambda.lparam = - (* CR ncourant: we assume all parameters defined with this function - are alloc_heap. Are we sure this is true? *) { name; layout; attributes = Lambda.default_param_attribute; mode = alloc_heap } diff --git a/ocaml/middle_end/closure/closure.ml b/ocaml/middle_end/closure/closure.ml index 33bfe6b59a2..08902ba947a 100644 --- a/ocaml/middle_end/closure/closure.ml +++ b/ocaml/middle_end/closure/closure.ml @@ -1096,8 +1096,15 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) alloc_local, Curried {nlocal = nlocal - supplied_local_args} in if is_local_mode clos_mode then assert (is_local_mode new_clos_mode); + (* CR ncourant: mode = new_clos_mode is incorrect; but the modes will + not be used for anything, so it is fine here. *) let final_args = - List.map (fun kind -> { name = V.create_local "arg"; layout = kind; attributes = Lambda.default_param_attribute; mode = new_clos_mode}) rem_layouts + List.map (fun kind -> { + name = V.create_local "arg"; + layout = kind; + attributes = Lambda.default_param_attribute; + mode = new_clos_mode + }) rem_layouts in let rec iter args body = match args with From 0783d025851465dd809473367fad5e6edd9e748b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Wed, 5 Jul 2023 17:02:46 +0200 Subject: [PATCH 6/7] review --- ocaml/lambda/simplif.ml | 5 ++--- ocaml/lambda/tmc.ml | 1 - ocaml/lambda/translcore.ml | 1 - 3 files changed, 2 insertions(+), 5 deletions(-) diff --git a/ocaml/lambda/simplif.ml b/ocaml/lambda/simplif.ml index fa72a40273c..01fb24c7d1e 100644 --- a/ocaml/lambda/simplif.ml +++ b/ocaml/lambda/simplif.ml @@ -795,15 +795,14 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body List.iter (fun (id, _) -> if Ident.Set.mem id fv then raise Exit) map; let inner_id = Ident.create_local (Ident.name fun_id ^ "_inner") in - let map_param p = + let map_param (p : Lambda.lparam) = try (* If the param is optional, then it must be a value *) - (* CR ncourant: is the mode necessarily heap? *) { name = List.assoc p.name map; layout = Lambda.layout_field; attributes = Lambda.default_param_attribute; - mode = alloc_heap + mode = p.mode } with Not_found -> p diff --git a/ocaml/lambda/tmc.ml b/ocaml/lambda/tmc.ml index 4c7aa9c9dea..9728a2eefc8 100644 --- a/ocaml/lambda/tmc.ml +++ b/ocaml/lambda/tmc.ml @@ -62,7 +62,6 @@ and offset = Offset of lambda let offset_code (Offset t) = t let add_dst_params ({var; offset} : Ident.t destination) params = - (* CR ncourant: are these modes necessarily heap? *) { name = var ; layout = Lambda.layout_block ; attributes = Lambda.default_param_attribute ; mode = alloc_heap } :: { name = offset ; layout = Lambda.layout_int ; diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index dd2098cc585..555af1343ea 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -943,7 +943,6 @@ and transl_exp0 ~in_new_scope ~scopes sort e = ~kind:(Curried {nlocal=0}) (* CR layouts: Adjust param layouts when we allow other things in probes. *) - (* CR ncourant: can we assume the mode is always heap? *) ~params:(List.map (fun name -> { name; layout = layout_probe_arg; attributes = Lambda.default_param_attribute; mode = alloc_heap }) param_idents) ~return:return_layout ~body From 06de445325fd617e7e7119647781170acb2cc43d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Mon, 17 Jul 2023 13:16:18 +0200 Subject: [PATCH 7/7] make fmt --- middle_end/flambda2/from_lambda/closure_conversion.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 25f5f4007ef..19d18eac651 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -2329,7 +2329,8 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = close_exact_or_unknown_apply acc env { apply with args; continuation = apply.continuation } (Some approx) ~replace_region:None - | Partial_app { provided; missing_arity; missing_param_modes; result_arity } -> + | Partial_app { provided; missing_arity; missing_param_modes; result_arity } + -> (match apply.inlined with | Always_inlined | Unroll _ -> Location.prerr_warning @@ -2339,8 +2340,8 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = inlined_attribute_on_partial_application_msg Inlined)) | Never_inlined | Hint_inlined | Default_inlined -> ()); wrap_partial_application acc env apply.continuation apply approx ~provided - ~missing_arity ~missing_param_modes ~result_arity ~first_complex_local_param - ~contains_no_escaping_local_allocs + ~missing_arity ~missing_param_modes ~result_arity + ~first_complex_local_param ~contains_no_escaping_local_allocs | Over_app { full; remaining; remaining_arity } -> let full_args_call apply_continuation ~region acc = let mode =