diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index 8bf657cb832..4eeab6ea2af 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -1070,6 +1070,8 @@ module Extended_machtype = struct typ_any_int | Pvalue Pintval -> typ_tagged_int | Pvalue _ -> typ_val + | Punboxed_product _ -> + Misc.fatal_error "Punboxed_product not expected here" end let machtype_of_layout layout = @@ -4002,8 +4004,8 @@ let direct_call ~dbg ty pos f_code_sym args = Cop (Capply (ty, pos), f_code_sym :: args, dbg) let indirect_call ~dbg ty pos alloc_mode f args_type args = - match args with - | [arg] -> + match args_type with + | [_] -> (* Use a variable to avoid duplicating the cmm code of the closure [f]. *) let v = Backend_var.create_local "*closure*" in let v' = Backend_var.With_provenance.create v in @@ -4011,10 +4013,10 @@ let indirect_call ~dbg ty pos alloc_mode f args_type args = ~body: (Cop ( Capply (Extended_machtype.to_machtype ty, pos), - [load ~dbg Word_int Asttypes.Mutable ~addr:(Cvar v); arg; Cvar v], + (load ~dbg Word_int Asttypes.Mutable ~addr:(Cvar v) :: args) + @ [Cvar v], dbg )) - | args -> - call_caml_apply ty args_type Asttypes.Mutable f args pos alloc_mode dbg + | _ -> call_caml_apply ty args_type Asttypes.Mutable f args pos alloc_mode dbg let indirect_full_call ~dbg ty pos alloc_mode f args_type = function (* the single-argument case is already optimized by indirect_call *) @@ -4143,5 +4145,5 @@ let kind_of_layout (layout : Lambda.layout) = | Pvalue Pfloatval -> Boxed_float | Pvalue (Pboxedintval bi) -> Boxed_integer bi | Pvalue (Pgenval | Pintval | Pvariant _ | Parrayval _) - | Ptop | Pbottom | Punboxed_float | Punboxed_int _ -> + | Ptop | Pbottom | Punboxed_float | Punboxed_int _ | Punboxed_product _ -> Any diff --git a/backend/cmmgen.ml b/backend/cmmgen.ml index 5aab1b76165..6b5300dcef4 100644 --- a/backend/cmmgen.ml +++ b/backend/cmmgen.ml @@ -150,6 +150,7 @@ let get_field env layout ptr n dbg = | Pvalue Pintval | Punboxed_int _ -> Word_int | Pvalue _ -> Word_val | Punboxed_float -> Double + | Punboxed_product _ -> Misc.fatal_error "TBD" | Ptop -> Misc.fatal_errorf "get_field with Ptop: %a" Debuginfo.print_compact dbg | Pbottom -> @@ -1322,6 +1323,7 @@ and transl_let env str (layout : Lambda.layout) id exp transl_body = end | Pvalue kind -> transl_let_value env str kind id exp transl_body + | Punboxed_product _ -> Misc.fatal_error "TBD" and make_catch (kind : Cmm.kind_for_unboxing) ncatch body handler dbg = match body with diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml index 77e66745305..b0b731993c7 100644 --- a/middle_end/clambda_primitives.ml +++ b/middle_end/clambda_primitives.ml @@ -150,6 +150,7 @@ and layout = Lambda.layout = | Pvalue of value_kind | Punboxed_float | Punboxed_int of boxed_integer + | Punboxed_product of layout list | Pbottom and block_shape = Lambda.block_shape diff --git a/middle_end/clambda_primitives.mli b/middle_end/clambda_primitives.mli index e71b17c4c85..5e3ddfd0765 100644 --- a/middle_end/clambda_primitives.mli +++ b/middle_end/clambda_primitives.mli @@ -153,6 +153,7 @@ and layout = Lambda.layout = | Pvalue of value_kind | Punboxed_float | Punboxed_int of boxed_integer + | Punboxed_product of layout list | Pbottom and block_shape = Lambda.block_shape diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index 4c54c2392ef..aec38ce62c1 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -65,6 +65,7 @@ let is_gc_ignorable kind = | Punboxed_int _ -> true | Pvalue Pintval -> true | Pvalue (Pgenval | Pfloatval | Pboxedintval _ | Pvariant _ | Parrayval _) -> false + | Punboxed_product _ -> Misc.fatal_error "TBD" let split_closure_fv kinds fv = List.fold_right (fun id (not_scanned, scanned) -> diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml index 541af7ecf86..9180f67f359 100644 --- a/middle_end/convert_primitives.ml +++ b/middle_end/convert_primitives.ml @@ -38,6 +38,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Psetfloatfield (field, init_or_assign) -> Psetfloatfield (field, init_or_assign) | Pduprecord (repr, size) -> Pduprecord (repr, size) + | Pmake_unboxed_product _ + | Punboxed_product_field _ -> Misc.fatal_error "TODO" | Pccall prim -> Pccall prim | Praise kind -> Praise kind | Psequand -> Psequand diff --git a/middle_end/flambda/closure_offsets.ml b/middle_end/flambda/closure_offsets.ml index cfb1791786d..11f071656ec 100644 --- a/middle_end/flambda/closure_offsets.ml +++ b/middle_end/flambda/closure_offsets.ml @@ -80,7 +80,8 @@ let add_closure_offsets | Punboxed_float -> true | Punboxed_int _ -> true | Pvalue Pintval -> true - | Pvalue _ -> false) + | Pvalue _ -> false + | Punboxed_product _ -> Misc.fatal_error "TODO") free_vars in let free_variable_offsets, free_variable_pos = diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml index a5385c63042..87fe4aab8dd 100644 --- a/middle_end/flambda/flambda_to_clambda.ml +++ b/middle_end/flambda/flambda_to_clambda.ml @@ -713,7 +713,8 @@ and to_clambda_set_of_closures t env | Punboxed_float -> true | Punboxed_int _ -> true | Pvalue Pintval -> true - | Pvalue _ -> false) + | Pvalue _ -> false + | Punboxed_product _ -> Misc.fatal_error "TBD") free_vars in let to_closure_args free_vars = diff --git a/middle_end/flambda2/bound_identifiers/bound_parameters.ml b/middle_end/flambda2/bound_identifiers/bound_parameters.ml index 99498cc3d07..9cc4bb1d2ed 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameters.ml +++ b/middle_end/flambda2/bound_identifiers/bound_parameters.ml @@ -58,7 +58,11 @@ let var_set t = Variable.Set.of_list (vars t) let rename t = List.map (fun t -> BP.rename t) t -let arity t = List.map (fun t -> BP.kind t) t |> Flambda_arity.create +let arity t = + List.map + (fun t -> Flambda_arity.Component_for_creation.Singleton (BP.kind t)) + t + |> Flambda_arity.create let free_names t = List.fold_left diff --git a/middle_end/flambda2/bound_identifiers/bound_parameters.mli b/middle_end/flambda2/bound_identifiers/bound_parameters.mli index 82460e86e9a..418078cf20d 100644 --- a/middle_end/flambda2/bound_identifiers/bound_parameters.mli +++ b/middle_end/flambda2/bound_identifiers/bound_parameters.mli @@ -30,7 +30,7 @@ val is_empty : t -> bool val same_number : t -> t -> bool -val arity : t -> Flambda_arity.t +val arity : t -> [> `Unarized] Flambda_arity.t val check_no_duplicates : t -> unit diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index f7025c568bf..41301ad1bfd 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -238,7 +238,7 @@ module Inlining = struct | Some (Closure_approximation { code; _ }) -> let metadata = Code_or_metadata.code_metadata code in let fun_params_length = - Code_metadata.params_arity metadata |> Flambda_arity.cardinal + Code_metadata.params_arity metadata |> Flambda_arity.num_params in if (not (Code_or_metadata.code_present code)) || fun_params_length > List.length (Apply_expr.args apply) @@ -440,11 +440,11 @@ let close_c_call acc env ~loc ~let_bound_var let param_arity = List.map kind_of_primitive_native_repr prim_native_repr_args |> List.map K.With_subkind.anything - |> Flambda_arity.create + |> Flambda_arity.create_singletons in let return_kind = kind_of_primitive_native_repr prim_native_repr_res in let return_arity = - Flambda_arity.create [K.With_subkind.anything return_kind] + Flambda_arity.create_singletons [K.With_subkind.anything return_kind] in let call_kind = Call_kind.c_call ~alloc:prim_alloc ~is_c_builtin:prim_c_builtin @@ -704,7 +704,7 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args | Pbigstring_set_64 _ | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer | Popaque _ | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ - -> + | Pmake_unboxed_product _ | Punboxed_product_field _ -> (* Inconsistent with outer match *) assert false in @@ -1076,6 +1076,7 @@ let close_exact_or_unknown_apply acc env mode; region_close; region; + args_arity; return_arity } as ir_apply : IR.apply) callee_approx ~replace_region : Expr_with_acc.t = @@ -1119,7 +1120,7 @@ let close_exact_or_unknown_apply acc env close_exn_continuation acc env exn_continuation in let acc, args_with_arity = find_simples_and_arity acc env args in - let args, args_arity = List.split args_with_arity in + let args, _split_args_arity = List.split args_with_arity in let inlined_call = Inlined_attribute.from_lambda inlined in let probe_name = match probe with None -> None | Some { name } -> Some name @@ -1131,9 +1132,9 @@ let close_exact_or_unknown_apply acc env in let apply = Apply.create ~callee ~continuation:(Return continuation) - apply_exn_continuation ~args - ~args_arity:(Flambda_arity.create args_arity) - ~return_arity ~call_kind + apply_exn_continuation ~args ~args_arity + ~return_arity:(Flambda_arity.unarize_t return_arity) + ~call_kind (Debuginfo.from_location loc) ~inlined:inlined_call ~inlining_state:(Inlining_state.default ~round:0) @@ -1536,7 +1537,7 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl (Exn_continuation.exn_handler exn_continuation) in let closure_info, acc = Acc.pop_closure_info acc in - let params_arity = Bound_parameters.arity params in + let params_arity = Function_decl.params_arity decl in let is_tupled = match Function_decl.kind decl with Curried _ -> false | Tupled -> true in @@ -1665,7 +1666,8 @@ 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 (_, kind) -> kind) params + |> Flambda_arity.create_singletons in let result_arity = Function_decl.return decl in let poll_attribute = @@ -1992,8 +1994,18 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) (fun n kind_with_subkind -> ( Ident.create_local ("param" ^ string_of_int (num_provided + n)), kind_with_subkind )) - (Flambda_arity.to_list missing_arity) - in + (Flambda_arity.unarize missing_arity) + in + let params_arity = missing_arity in + (match Sys.getenv "DEBUG" with + | exception Not_found -> () + | _ -> + Format.eprintf + "partial application (in CC) of %a: old params arity is %a, new params \ + arity is %a\n\ + %!" + Ident.print apply.func Flambda_arity.print arity Flambda_arity.print + params_arity); let return_continuation = Continuation.create ~sort:Return () in let exn_continuation = IR.{ exn_handler = Continuation.create (); extra_args = [] } @@ -2009,6 +2021,7 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) { apply with kind = Function; args = all_args; + args_arity = arity; continuation = return_continuation; exn_continuation; inlined = Lambda.Default_inlined; @@ -2039,7 +2052,10 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) in let closure_alloc_mode, num_trailing_local_params = let num_leading_heap_params = - Flambda_arity.cardinal arity - num_trailing_local_params + (* This is a pre-unarization calculation so uses [num_params] not + [cardinal_unarized]. *) + (* CR mshinwell: check this is correct *) + Flambda_arity.num_params arity - num_trailing_local_params in if num_provided <= num_leading_heap_params then Lambda.alloc_heap, num_trailing_local_params @@ -2055,11 +2071,11 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) let function_declarations = [ Function_decl.create ~let_rec_ident:(Some wrapper_id) ~function_slot ~kind:(Lambda.Curried { nlocal = num_trailing_local_params }) - ~params ~return:apply.return_arity ~return_continuation - ~exn_continuation ~my_region:apply.region ~body:fbody ~attr - ~loc:apply.loc ~free_idents_of_body ~closure_alloc_mode - ~num_trailing_local_params ~contains_no_escaping_local_allocs - Recursive.Non_recursive ] + ~params ~params_arity ~removed_params:Ident.Set.empty + ~return:apply.return_arity ~return_continuation ~exn_continuation + ~my_region:apply.region ~body:fbody ~attr ~loc:apply.loc + ~free_idents_of_body ~closure_alloc_mode ~num_trailing_local_params + ~contains_no_escaping_local_allocs Recursive.Non_recursive ] in let body acc env = let arg = find_simple_from_id env wrapper_id in @@ -2075,6 +2091,13 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) let wrap_over_application acc env full_call (apply : IR.apply) ~remaining ~remaining_arity ~contains_no_escaping_local_allocs = + (* Format.eprintf "wrap_over_application of %a, args %a, args_arity(apply)=%a, + \ result_arity(apply)=%a@ remaining=(%a)@ remaining_arity=%a\n\ %!" + Ident.print apply.func (Format.pp_print_list ~pp_sep:Format.pp_print_space + IR.print_simple) apply.args (Misc.Stdlib.Option.print Flambda_arity.print) + apply.args_arity Flambda_arity.print apply.return_arity + (Format.pp_print_list ~pp_sep:Format.pp_print_space IR.print_simple) + remaining Flambda_arity.print remaining_arity; *) let wrapper_cont = Continuation.create () in let returned_func = Variable.create "func" in (* See comments in [Simplify_common.split_direct_over_application] about this @@ -2122,7 +2145,8 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining let over_application = Apply.create ~callee:(Simple.var returned_func) ~continuation apply_exn_continuation ~args:remaining ~args_arity:remaining_arity - ~return_arity:apply.return_arity ~call_kind apply_dbg ~inlined + ~return_arity:(Flambda_arity.unarize_t apply.return_arity) + ~call_kind apply_dbg ~inlined ~inlining_state:(Inlining_state.default ~round:0) ~probe_name ~position ~relative_history:(Env.relative_history_from_scoped ~loc:apply.loc env) @@ -2135,7 +2159,7 @@ let wrap_over_application acc env full_call (apply : IR.apply) ~remaining List.mapi (fun i kind -> BP.create (Variable.create ("result" ^ string_of_int i)) kind) - (Flambda_arity.to_list apply.return_arity) + (Flambda_arity.unarize apply.return_arity) in let handler acc = let acc, call_return_continuation = @@ -2178,12 +2202,13 @@ type call_args_split = | Exact of IR.simple list | Partial_app of { provided : IR.simple list; - missing_arity : Flambda_arity.t + missing_arity : [`Unarized | `Complex] Flambda_arity.t } | Over_app of { full : IR.simple list; + provided_arity : [`Unarized | `Complex] Flambda_arity.t; remaining : IR.simple list; - remaining_arity : Flambda_arity.t + remaining_arity : [`Unarized | `Complex] Flambda_arity.t } let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = @@ -2215,10 +2240,10 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = is_tupled, num_trailing_local_params, contains_no_escaping_local_allocs ) -> ( - let acc, args_with_arities = find_simples_and_arity acc env apply.args in - let args_arity = List.map snd args_with_arities in + let acc, _ = find_simples_and_arity acc env apply.args in let split_args = - let arity = Flambda_arity.to_list arity in + let non_unarized_arity = arity in + let arity = Flambda_arity.unarize arity in let split args arity = let rec cut n l = if n <= 0 @@ -2230,24 +2255,28 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = let before, after = cut (n - 1) t in h :: before, after in - let args_l = List.length args in - let arity_l = List.length arity in + let args_l = Flambda_arity.num_params apply.args_arity in + let arity_l = Flambda_arity.num_params non_unarized_arity in if args_l = arity_l then Exact args else if args_l < arity_l then - let _provided_arity, missing_arity = cut args_l arity in - Partial_app - { provided = args; - missing_arity = Flambda_arity.create missing_arity - } + let missing_arity = + Flambda_arity.partially_apply non_unarized_arity + ~num_non_unarized_params_provided:args_l + in + Partial_app { provided = args; missing_arity } else - let full, remaining = cut arity_l args in - let _, remaining_arity = cut arity_l args_arity in + let full, remaining = cut (List.length arity) args in + let remaining_arity = + Flambda_arity.partially_apply apply.args_arity + ~num_non_unarized_params_provided:arity_l + in Over_app { full; + provided_arity = non_unarized_arity; remaining; - remaining_arity = Flambda_arity.create remaining_arity + remaining_arity } in let arity = @@ -2268,7 +2297,7 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = wrap_partial_application acc env apply.continuation apply approx ~provided ~missing_arity ~arity ~num_trailing_local_params ~contains_no_escaping_local_allocs - | Over_app { full; remaining; remaining_arity } -> + | Over_app { full; provided_arity; remaining; remaining_arity } -> let full_args_call apply_continuation ~region acc = let mode = if contains_no_escaping_local_allocs @@ -2278,10 +2307,12 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = close_exact_or_unknown_apply acc env { apply with args = full; + args_arity = provided_arity; continuation = apply_continuation; mode; return_arity = - Flambda_arity.create [Flambda_kind.With_subkind.any_value] + Flambda_arity.create_singletons + [Flambda_kind.With_subkind.any_value] } (Some approx) ~replace_region:(Some region) in diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml index e5b1f38a197..496a6754a59 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml @@ -64,7 +64,8 @@ module IR = struct probe : Lambda.probe; mode : Lambda.alloc_mode; region : Ident.t; - return_arity : Flambda_arity.t + args_arity : [`Unarized | `Complex] Flambda_arity.t; + return_arity : [`Unarized | `Complex] Flambda_arity.t } type switch = @@ -663,7 +664,9 @@ module Function_decls = struct function_slot : Function_slot.t; kind : Lambda.function_kind; params : (Ident.t * Flambda_kind.With_subkind.t) list; - return : Flambda_arity.t; + removed_params : Ident.Set.t; + params_arity : [`Unarized | `Complex] Flambda_arity.t; + return : [`Unarized | `Complex] Flambda_arity.t; return_continuation : Continuation.t; exn_continuation : IR.exn_continuation; my_region : Ident.t; @@ -677,11 +680,11 @@ module Function_decls = struct contains_no_escaping_local_allocs : bool } - let create ~let_rec_ident ~function_slot ~kind ~params ~return - ~return_continuation ~exn_continuation ~my_region ~body - ~(attr : Lambda.function_attribute) ~loc ~free_idents_of_body recursive - ~closure_alloc_mode ~num_trailing_local_params - ~contains_no_escaping_local_allocs = + let create ~let_rec_ident ~function_slot ~kind ~params ~params_arity + ~removed_params ~return ~return_continuation ~exn_continuation + ~my_region ~body ~(attr : Lambda.function_attribute) ~loc + ~free_idents_of_body recursive ~closure_alloc_mode + ~num_trailing_local_params ~contains_no_escaping_local_allocs = let let_rec_ident = match let_rec_ident with | None -> Ident.create_local "unnamed_function" @@ -691,6 +694,8 @@ module Function_decls = struct function_slot; kind; params; + params_arity; + removed_params; return; return_continuation; exn_continuation; @@ -713,6 +718,8 @@ module Function_decls = struct let params t = t.params + let params_arity t = t.params_arity + let return t = t.return let return_continuation t = t.return_continuation @@ -723,7 +730,7 @@ module Function_decls = struct let body t = t.body - let free_idents t = t.free_idents_of_body + let free_idents t = Ident.Set.diff t.free_idents_of_body t.removed_params let inline t = t.attr.inline @@ -929,7 +936,7 @@ module Let_with_acc = struct ~find_code_characteristics:(fun code_id -> let code = Code_id.Map.find code_id code_mapping in { cost_metrics = Code.cost_metrics code; - params_arity = Flambda_arity.cardinal (Code.params_arity code) + params_arity = Flambda_arity.num_params (Code.params_arity code) }) set_of_closures | Rec_info _ -> Cost_metrics.zero diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli index bdba26b1859..5249d966223 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli @@ -68,7 +68,8 @@ module IR : sig probe : Lambda.probe; mode : Lambda.alloc_mode; region : Ident.t; - return_arity : Flambda_arity.t + args_arity : [`Unarized | `Complex] Flambda_arity.t; + return_arity : [`Unarized | `Complex] Flambda_arity.t } type switch = @@ -77,6 +78,8 @@ module IR : sig failaction : (Continuation.t * trap_action option * simple list) option } + val print_simple : Format.formatter -> simple -> unit + val print_named : Format.formatter -> named -> unit end @@ -296,7 +299,9 @@ module Function_decls : sig function_slot:Function_slot.t -> kind:Lambda.function_kind -> params:(Ident.t * Flambda_kind.With_subkind.t) list -> - return:Flambda_arity.t -> + params_arity:[`Unarized | `Complex] Flambda_arity.t -> + removed_params:Ident.Set.t -> + return:[`Unarized | `Complex] Flambda_arity.t -> return_continuation:Continuation.t -> exn_continuation:IR.exn_continuation -> my_region:Ident.t -> @@ -318,7 +323,9 @@ module Function_decls : sig val params : t -> (Ident.t * Flambda_kind.With_subkind.t) list - val return : t -> Flambda_arity.t + val params_arity : t -> [`Unarized | `Complex] Flambda_arity.t + + val return : t -> [`Unarized | `Complex] Flambda_arity.t val return_continuation : t -> Continuation.t diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 3a8b435907c..0b96cb133c1 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -17,6 +17,9 @@ (* "Use CPS". -- A. Kennedy, "Compiling with Continuations Continued", ICFP 2007. *) +let unboxed_product_debug () = + match Sys.getenv "DEBUG" with exception Not_found -> false | _ -> true + module L = Lambda module CC = Closure_conversion module P = Flambda_primitive @@ -40,14 +43,30 @@ module Env : sig val is_mutable : t -> Ident.t -> bool - val register_mutable_variable : t -> Ident.t -> Lambda.layout -> t * Ident.t + val register_mutable_variable : + t -> Ident.t -> Flambda_kind.With_subkind.t -> t * Ident.t val update_mutable_variable : t -> Ident.t -> t * Ident.t + val register_unboxed_product : + t -> + unboxed_product:Ident.t -> + before_unarization: + [`Unarized | `Complex] Flambda_arity.Component_for_creation.t -> + fields:(Ident.t * Flambda_kind.With_subkind.t) list -> + t + + val get_unboxed_product_fields : + t -> + Ident.t -> + ([`Unarized | `Complex] Flambda_arity.Component_for_creation.t + * Ident.t list) + option + type add_continuation_result = private { body_env : t; handler_env : t; - extra_params : (Ident.t * Lambda.layout) list + extra_params : (Ident.t * Flambda_kind.With_subkind.t) list } val add_continuation : @@ -73,11 +92,10 @@ module Env : sig val extra_args_for_continuation : t -> Continuation.t -> Ident.t list val extra_args_for_continuation_with_kinds : - t -> Continuation.t -> (Ident.t * Lambda.layout) list - - val get_mutable_variable : t -> Ident.t -> Ident.t + t -> Continuation.t -> (Ident.t * Flambda_kind.With_subkind.t) list - val get_mutable_variable_with_kind : t -> Ident.t -> Ident.t * Lambda.layout + val get_mutable_variable_with_kind : + t -> Ident.t -> Ident.t * Flambda_kind.With_subkind.t (** About local allocation regions: @@ -173,8 +191,14 @@ end = struct type t = { current_unit : Compilation_unit.t; current_values_of_mutables_in_scope : - (Ident.t * Lambda.layout) Ident.Map.t; + (Ident.t * Flambda_kind.With_subkind.t) Ident.Map.t; mutables_needed_by_continuations : Ident.Set.t Continuation.Map.t; + unboxed_product_components_in_scope : + ([`Unarized | `Complex] Flambda_arity.Component_for_creation.t + * (Ident.t * Flambda_kind.With_subkind.t) array) + Ident.Map.t; + unboxed_product_components_needed_by_continuations : + Ident.Set.t Continuation.Map.t; try_stack : Continuation.t list; try_stack_at_handler : Continuation.t list Continuation.Map.t; static_exn_continuation : Continuation.t Numeric_types.Int.Map.t; @@ -190,9 +214,15 @@ end = struct Continuation.Map.of_list [return_continuation, Ident.Set.empty; exn_continuation, Ident.Set.empty] in + let unboxed_product_components_needed_by_continuations = + Continuation.Map.of_list + [return_continuation, Ident.Set.empty; exn_continuation, Ident.Set.empty] + in { current_unit; current_values_of_mutables_in_scope = Ident.Map.empty; mutables_needed_by_continuations; + unboxed_product_components_in_scope = Ident.Map.empty; + unboxed_product_components_needed_by_continuations; try_stack = []; try_stack_at_handler = Continuation.Map.empty; static_exn_continuation = Numeric_types.Int.Map.empty; @@ -232,10 +262,30 @@ end = struct let mutables_in_scope t = Ident.Map.keys t.current_values_of_mutables_in_scope + let register_unboxed_product t ~unboxed_product ~before_unarization ~fields = + if unboxed_product_debug () + then + Format.eprintf "register_unboxed_product %a: fields: %a\n%!" Ident.print + unboxed_product + (Format.pp_print_list ~pp_sep:Format.pp_print_space + (fun ppf (id, kind) -> + Format.fprintf ppf "%a :: %a" Ident.print id + Flambda_kind.With_subkind.print kind)) + fields; + { t with + unboxed_product_components_in_scope = + Ident.Map.add unboxed_product + (before_unarization, Array.of_list fields) + t.unboxed_product_components_in_scope + } + + let unboxed_product_components_in_scope t = + Ident.Map.keys t.unboxed_product_components_in_scope + type add_continuation_result = { body_env : t; handler_env : t; - extra_params : (Ident.t * Lambda.layout) list + extra_params : (Ident.t * Flambda_kind.With_subkind.t) list } let add_continuation t cont ~push_to_try_stack (recursive : Asttypes.rec_flag) @@ -248,11 +298,17 @@ end = struct Continuation.Map.add cont (mutables_in_scope t) t.mutables_needed_by_continuations in + let unboxed_product_components_needed_by_continuations = + Continuation.Map.add cont + (unboxed_product_components_in_scope t) + t.unboxed_product_components_needed_by_continuations + in let try_stack = if push_to_try_stack then cont :: t.try_stack else t.try_stack in { t with mutables_needed_by_continuations; + unboxed_product_components_needed_by_continuations; try_stack; region_stack_in_cont_scope } @@ -262,6 +318,15 @@ end = struct (fun mut_var (_outer_value, kind) -> Ident.rename mut_var, kind) t.current_values_of_mutables_in_scope in + let unboxed_product_components_in_scope = + Ident.Map.map + (fun (before_unarization, fields) -> + let fields = + Array.map (fun (field, layout) -> Ident.rename field, layout) fields + in + before_unarization, fields) + t.unboxed_product_components_in_scope + in let handler_env = let handler_env = match recursive with @@ -273,12 +338,24 @@ end = struct in { handler_env with current_values_of_mutables_in_scope; + unboxed_product_components_in_scope; region_stack_in_cont_scope } in + let extra_params_for_unboxed_products = + Ident.Map.data handler_env.unboxed_product_components_in_scope + |> List.map snd |> List.map Array.to_list |> List.concat + in let extra_params = Ident.Map.data handler_env.current_values_of_mutables_in_scope + @ extra_params_for_unboxed_products in + if unboxed_product_debug () + then + Format.eprintf "Adding continuation %a with extra params: %a\n%!" + Continuation.print cont + (Format.pp_print_list ~pp_sep:Format.pp_print_space Ident.print) + (List.map fst extra_params); { body_env; handler_env; extra_params } let add_static_exn_continuation t static_exn cont = @@ -330,18 +407,48 @@ end = struct | stack -> stack let extra_args_for_continuation_with_kinds t cont = - match Continuation.Map.find cont t.mutables_needed_by_continuations with - | exception Not_found -> - Misc.fatal_errorf "Unbound continuation %a" Continuation.print cont - | mutables -> - let mutables = Ident.Set.elements mutables in - List.map - (fun mut -> - match Ident.Map.find mut t.current_values_of_mutables_in_scope with - | exception Not_found -> - Misc.fatal_errorf "No current value for %a" Ident.print mut - | current_value, kind -> current_value, kind) - mutables + let for_mutables = + match Continuation.Map.find cont t.mutables_needed_by_continuations with + | exception Not_found -> + Misc.fatal_errorf "Unbound continuation %a" Continuation.print cont + | mutables -> + let mutables = Ident.Set.elements mutables in + List.map + (fun mut -> + match Ident.Map.find mut t.current_values_of_mutables_in_scope with + | exception Not_found -> + Misc.fatal_errorf "No current value for %a" Ident.print mut + | current_value, kind -> current_value, kind) + mutables + in + let for_unboxed_products = + match + Continuation.Map.find cont + t.unboxed_product_components_needed_by_continuations + with + | exception Not_found -> + Misc.fatal_errorf "Unbound continuation %a" Continuation.print cont + | unboxed_products_to_fields -> + let unboxed_products = Ident.Set.elements unboxed_products_to_fields in + List.concat_map + (fun unboxed_product -> + match + Ident.Map.find unboxed_product + t.unboxed_product_components_in_scope + with + | exception Not_found -> + Misc.fatal_errorf + "No field list registered for unboxed product %a" Ident.print + unboxed_product + | _, fields -> Array.to_list fields) + unboxed_products + in + if unboxed_product_debug () + then + Format.eprintf "Extra args for %a are: %a\n%!" Continuation.print cont + (Format.pp_print_list ~pp_sep:Format.pp_print_space Ident.print) + (List.map fst (for_mutables @ for_unboxed_products)); + for_mutables @ for_unboxed_products let extra_args_for_continuation t cont = List.map fst (extra_args_for_continuation_with_kinds t cont) @@ -352,7 +459,11 @@ end = struct Misc.fatal_errorf "Mutable variable %a not bound in env" Ident.print id | id, kind -> id, kind - let get_mutable_variable t id = fst (get_mutable_variable_with_kind t id) + let get_unboxed_product_fields t id = + match Ident.Map.find id t.unboxed_product_components_in_scope with + | exception Not_found -> None + | before_unarization, fields -> + Some (before_unarization, List.map fst (Array.to_list fields)) let entering_region t id ~continuation_closing_region ~continuation_after_closing_region = @@ -436,6 +547,18 @@ module Acc = Closure_conversion_aux.Acc type primitive_transform_result = | Primitive of L.primitive * L.lambda list * L.scoped_location | Transformed of L.lambda + | Unboxed_binding of + (Ident.t * Flambda_kind.With_subkind.t) option list * Env.t + (** [Unboxed_binding] enables a subset of the unboxed values arriving from + the defining expression to be bound. *) + +let must_be_singleton_simple simples = + match simples with + | [simple] -> simple + | [] | _ :: _ -> + Misc.fatal_errorf "Expected singleton Simple but got: %a" + (Format.pp_print_list ~pp_sep:Format.pp_print_space IR.print_simple) + simples let print_compact_location ppf (loc : Location.t) = if loc.loc_start.pos_fname = "//toplevel//" @@ -454,13 +577,9 @@ let name_for_function (func : Lambda.lfunction) = Format.asprintf "anon-fn[%a]" print_compact_location loc let extra_args_for_exn_continuation env exn_handler = - let more_extra_args = - Env.extra_args_for_continuation_with_kinds env exn_handler - in List.map - (fun (arg, kind) : (IR.simple * _) -> - Var arg, Flambda_kind.With_subkind.from_lambda kind) - more_extra_args + (fun (ident, kind) -> IR.Var ident, kind) + (Env.extra_args_for_continuation_with_kinds env exn_handler) let _print_stack ppf stack = Format.fprintf ppf "%a" @@ -574,7 +693,7 @@ let switch_for_if_then_else ~cond ~ifso ~ifnot ~kind = in L.Lswitch (cond, switch, Loc_unknown, kind) -let transform_primitive env (prim : L.primitive) args loc = +let transform_primitive env id (prim : L.primitive) args loc = match prim, args with | Psequor, [arg1; arg2] -> let const_true = Ident.create_local "const_true" in @@ -674,9 +793,120 @@ let transform_primitive env (prim : L.primitive) args loc = Primitive (L.Pccall desc, args, loc) else Misc.fatal_errorf - "Lambda_to_flambda.transform_primimive: Pbigarrayset with unknown \ + "Lambda_to_flambda.transform_primitive: Pbigarrayset with unknown \ layout and elements should only have dimensions between 1 and 3 \ (see translprim).") + | Pmake_unboxed_product layouts, args -> + (* CR mshinwell: should there be a case here for when args is a + singleton? *) + if List.compare_lengths layouts args <> 0 + then + Misc.fatal_errorf + "Pmake_unboxed_product layouts (%a) don't match arguments (%a)" + (Format.pp_print_list ~pp_sep:Format.pp_print_space Printlambda.layout) + layouts + (Format.pp_print_list ~pp_sep:Format.pp_print_space Printlambda.lambda) + args; + let arity_component = + Flambda_arity.Component_for_creation.Unboxed_product + (List.map Flambda_arity.Component_for_creation.from_lambda layouts) + in + let arity = Flambda_arity.create [arity_component] in + let fields = Flambda_arity.fresh_idents_unarized ~id arity in + let env = + Env.register_unboxed_product env ~unboxed_product:id + ~before_unarization:arity_component ~fields + in + if unboxed_product_debug () + then + Format.eprintf "Making unboxed product, bound to %a: num fields = %d\n%!" + Ident.print id (List.length fields); + let fields = List.map (fun ident_and_kind -> Some ident_and_kind) fields in + Unboxed_binding (fields, env) + | Punboxed_product_field (n, layouts), [_arg] -> + let layouts_array = Array.of_list layouts in + if n < 0 || n >= Array.length layouts_array + then Misc.fatal_errorf "Invalid field index %d for Punboxed_product_field" n; + let arity_component = + Flambda_arity.Component_for_creation.Unboxed_product + (List.map Flambda_arity.Component_for_creation.from_lambda layouts) + in + let arity = Flambda_arity.create [arity_component] in + if unboxed_product_debug () + then + Format.eprintf + "Punboxed_product_field bound to %a, product %a, field %d, arity %a:\n\ + %!" + Ident.print id Printlambda.lambda _arg n Flambda_arity.print arity; + let field_arity_component = + (* N.B. The arity of the field being projected, bound to [id], may in + itself be an unboxed product. *) + layouts_array.(n) |> Flambda_arity.Component_for_creation.from_lambda + in + let field_arity = Flambda_arity.create [field_arity_component] in + let ids_all_fields_with_kinds = + Flambda_arity.fresh_idents_unarized arity ~id + in + let num_fields_prior_to_projected_fields = + Misc.Stdlib.List.split_at n layouts + |> fst + |> List.map Flambda_arity.Component_for_creation.from_lambda + |> Flambda_arity.create |> Flambda_arity.cardinal_unarized + in + if unboxed_product_debug () + then + Format.eprintf "num_fields_prior_to_projected_fields %d\n%!" + num_fields_prior_to_projected_fields; + let num_projected_fields = Flambda_arity.cardinal_unarized field_arity in + let ids_projected_fields = + Array.sub + (Array.of_list ids_all_fields_with_kinds) + num_fields_prior_to_projected_fields num_projected_fields + |> Array.to_list + (* CR mshinwell: try to keep this as an array? *) + in + let env = + if num_projected_fields <> 1 + then + (* If the field being projected is an unboxed product, we must ensure + any occurrences of [id] get expanded to the individual fields, just + like we do in the [Pmake_unboxed_product] case above. *) + Env.register_unboxed_product env ~unboxed_product:id + ~before_unarization:field_arity_component ~fields:ids_projected_fields + else env + in + if unboxed_product_debug () + then + Format.eprintf + "Unboxed projection: emitting binding of %d ids, num projected fields %d\n\ + %!" + (List.length ids_all_fields_with_kinds) + (List.length ids_projected_fields); + let field_mask = + List.mapi + (fun cur_field (field, kind) -> + if cur_field < num_fields_prior_to_projected_fields + || cur_field + >= num_fields_prior_to_projected_fields + num_projected_fields + then None + else + match ids_projected_fields with + | [(_, kind)] -> + (* If no splitting is occurring, we must cause [id] to be bound, + being the original bound variable from the enclosing [Llet]. *) + Some (id, kind) + | [] | _ :: _ -> + (* In all other cases we cause one of the variables representing + the individual fields of the unboxed product to be bound. *) + Some (field, kind)) + ids_all_fields_with_kinds + in + Unboxed_binding (field_mask, env) + | Punboxed_product_field _, (([] | _ :: _) as args) -> + Misc.fatal_errorf + "Punboxed_product_field only takes one argument, but found: %a" + (Format.pp_print_list ~pp_sep:Format.pp_print_space Printlambda.lambda) + args | _, _ -> Primitive (prim, args, loc) [@@ocaml.warning "-fragile-match"] @@ -765,17 +995,54 @@ let let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler let { Env.body_env; handler_env; extra_params } = Env.add_continuation env cont ~push_to_try_stack:is_exn_handler Nonrecursive in - let params = - List.map - (fun (id, visible, kind) -> - id, visible, Flambda_kind.With_subkind.from_lambda kind) - params + let orig_params = params in + let handler_env, params_rev = + List.fold_left + (fun (handler_env, params_rev) (id, visible, layout) -> + let arity_component = + Flambda_arity.Component_for_creation.from_lambda layout + in + match arity_component with + | Singleton kind -> + let param = id, visible, kind in + handler_env, param :: params_rev + | Unboxed_product _ -> + let arity = Flambda_arity.create [arity_component] in + let fields = + List.mapi + (fun n kind -> + let field = + Ident.create_local + (Printf.sprintf "%s_unboxed%d" (Ident.unique_name id) n) + in + field, kind) + (Flambda_arity.unarize arity) + in + let handler_env = + Env.register_unboxed_product handler_env ~unboxed_product:id + ~before_unarization:arity_component ~fields + in + let new_params_rev = + List.map (fun (id, kind) -> id, IR.Not_user_visible, kind) fields + |> List.rev + in + handler_env, new_params_rev @ params_rev) + (handler_env, []) params in + let params = List.rev params_rev in + if List.compare_lengths params orig_params <> 0 + then + if unboxed_product_debug () + then + Format.eprintf + "Continuation %a has unboxed arities: orig_params %a, params %a\n%!" + Continuation.print cont + (Format.pp_print_list ~pp_sep:Format.pp_print_space Ident.print) + (List.map (fun (id, _, _) -> id) orig_params) + (Format.pp_print_list ~pp_sep:Format.pp_print_space Ident.print) + (List.map (fun (id, _, _) -> id) params); let extra_params = - List.map - (fun (id, kind) -> - id, IR.User_visible, Flambda_kind.With_subkind.from_lambda kind) - extra_params + List.map (fun (id, kind) -> id, IR.User_visible, kind) extra_params in let handler acc ccenv = handler acc handler_env ccenv in let body acc ccenv = body acc body_env ccenv cont in @@ -847,9 +1114,16 @@ let wrap_return_continuation acc env ccenv (apply : IR.apply) = | [] -> CC.close_apply acc ccenv { apply with continuation; region } | _ :: _ -> let wrapper_cont = Continuation.create () in - let return_value = Ident.create_local "return_val" in + let return_kinds = Flambda_arity.unarize apply.return_arity in + let return_value_components = + List.mapi + (fun i _ -> Ident.create_local (Printf.sprintf "return_val%d" i)) + return_kinds + in let args = - List.map (fun var : IR.simple -> Var var) (return_value :: extra_args) + List.map + (fun var : IR.simple -> Var var) + (return_value_components @ extra_args) in let dbg = Debuginfo.none in let handler acc ccenv = @@ -859,20 +1133,14 @@ let wrap_return_continuation acc env ccenv (apply : IR.apply) = CC.close_apply acc ccenv { apply with continuation = wrapper_cont; region } in - let return_arity = - match Flambda_arity.to_list apply.return_arity with - | [return_kind] -> return_kind - | _ :: _ -> - Misc.fatal_errorf - "Multiple return values for application of %a not supported yet" - Ident.print apply.func - | [] -> - Misc.fatal_errorf "Nullary return arity for application of %a" - Ident.print apply.func + let params = + List.map2 + (fun return_value_component kind -> + return_value_component, IR.Not_user_visible, kind) + return_value_components return_kinds in CC.close_let_cont acc ccenv ~name:wrapper_cont ~is_exn_handler:false - ~params:[return_value, Not_user_visible, return_arity] - ~recursive:Nonrecursive ~body ~handler + ~params ~recursive:Nonrecursive ~body ~handler in restore_continuation_context acc env ccenv apply.continuation ~close_early body @@ -957,32 +1225,32 @@ let primitive_can_raise (prim : Lambda.primitive) = | Pbigstring_set_64 true | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer | Popaque _ | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ | Pbox_float _ | Punbox_float - | Punbox_int _ | Pbox_int _ -> + | Punbox_int _ | Pbox_int _ | Pmake_unboxed_product _ + | Punboxed_product_field _ -> false -let primitive_result_kind (prim : Lambda.primitive) : - Flambda_kind.With_subkind.t = +let primitive_result_kind (prim : Lambda.primitive) : _ Flambda_arity.t = match prim with | Pccall { prim_native_repr_res = _, Untagged_int; _ } -> - Flambda_kind.With_subkind.tagged_immediate + Flambda_arity.create_singletons [Flambda_kind.With_subkind.tagged_immediate] | Pccall { prim_native_repr_res = _, Unboxed_float; _ } | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pfloatfield _ | Parrayrefs Pfloatarray | Parrayrefu Pfloatarray | Pbigarrayref (_, _, (Pbigarray_float32 | Pbigarray_float64), _) -> - Flambda_kind.With_subkind.boxed_float + Flambda_arity.create_singletons [Flambda_kind.With_subkind.boxed_float] | Pccall { prim_native_repr_res = _, Unboxed_integer Pnativeint; _ } | Pbigarrayref (_, _, Pbigarray_native_int, _) -> - Flambda_kind.With_subkind.boxed_nativeint + Flambda_arity.create_singletons [Flambda_kind.With_subkind.boxed_nativeint] | Pccall { prim_native_repr_res = _, Unboxed_integer Pint32; _ } | Pstring_load_32 _ | Pbytes_load_32 _ | Pbigstring_load_32 _ | Pbigarrayref (_, _, Pbigarray_int32, _) -> - Flambda_kind.With_subkind.boxed_int32 + Flambda_arity.create_singletons [Flambda_kind.With_subkind.boxed_int32] | Pccall { prim_native_repr_res = _, Unboxed_integer Pint64; _ } | Pstring_load_64 _ | Pbytes_load_64 _ | Pbigstring_load_64 _ | Pbigarrayref (_, _, Pbigarray_int64, _) -> - Flambda_kind.With_subkind.boxed_int64 + Flambda_arity.create_singletons [Flambda_kind.With_subkind.boxed_int64] | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pmodint _ | Pdivint _ | Pignore | Psequand | Psequor | Pnot | Pbytesrefs | Pstringrefs | Pbytessets | Pstring_load_16 _ @@ -1003,7 +1271,7 @@ let primitive_result_kind (prim : Lambda.primitive) : ( Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16 | Pbigarray_caml_int ), _ ) -> - Flambda_kind.With_subkind.tagged_immediate + Flambda_arity.create_singletons [Flambda_kind.With_subkind.tagged_immediate] | Pdivbint { size = bi; _ } | Pmodbint { size = bi; _ } | Pandbint (bi, _) @@ -1019,16 +1287,18 @@ let primitive_result_kind (prim : Lambda.primitive) : | Pbintofint (bi, _) | Pcvtbint (_, bi, _) | Pbbswap (bi, _) - | Pbox_int (bi, _) -> ( - match bi with - | Pint32 -> Flambda_kind.With_subkind.boxed_int32 - | Pint64 -> Flambda_kind.With_subkind.boxed_int64 - | Pnativeint -> Flambda_kind.With_subkind.boxed_nativeint) + | Pbox_int (bi, _) -> + Flambda_arity.create_singletons + [ (match bi with + | Pint32 -> Flambda_kind.With_subkind.boxed_int32 + | Pint64 -> Flambda_kind.With_subkind.boxed_int64 + | Pnativeint -> Flambda_kind.With_subkind.boxed_nativeint) ] | Popaque layout | Pobj_magic layout -> - Flambda_kind.With_subkind.from_lambda layout + Flambda_arity.create_singletons + [Flambda_kind.With_subkind.from_lambda layout] | Praise _ -> (* CR ncourant: this should be bottom, but we don't have it *) - Flambda_kind.With_subkind.any_value + Flambda_arity.create_singletons [Flambda_kind.With_subkind.any_value] | Pccall { prim_native_repr_res = _, Same_as_ocaml_repr; _ } | Parrayrefs (Pgenarray | Paddrarray) | Parrayrefu (Pgenarray | Paddrarray) @@ -1039,36 +1309,75 @@ let primitive_result_kind (prim : Lambda.primitive) : | Pbigarrayref (_, _, (Pbigarray_complex32 | Pbigarray_complex64 | Pbigarray_unknown), _) | Pint_as_pointer | Pobj_dup -> - Flambda_kind.With_subkind.any_value - | Pbox_float _ -> Flambda_kind.With_subkind.boxed_float - | Punbox_float -> Flambda_kind.With_subkind.naked_float - | Punbox_int bi -> ( - match bi with - | Pint32 -> Flambda_kind.With_subkind.naked_int32 - | Pint64 -> Flambda_kind.With_subkind.naked_int64 - | Pnativeint -> Flambda_kind.With_subkind.naked_nativeint) + Flambda_arity.create_singletons [Flambda_kind.With_subkind.any_value] + | Pbox_float _ -> + Flambda_arity.create_singletons [Flambda_kind.With_subkind.boxed_float] + | Punbox_float -> + Flambda_arity.create_singletons [Flambda_kind.With_subkind.naked_float] + | Punbox_int bi -> + Flambda_arity.create_singletons + [ (match bi with + | Pint32 -> Flambda_kind.With_subkind.naked_int32 + | Pint64 -> Flambda_kind.With_subkind.naked_int64 + | Pnativeint -> Flambda_kind.With_subkind.naked_nativeint) ] + | Pmake_unboxed_product _ | Punboxed_product_field _ -> + Misc.fatal_errorf "Primitive not allowed here:@ %a" Printlambda.primitive + prim + +type non_tail_continuation = + Acc.t -> + Env.t -> + CCenv.t -> + IR.simple list -> + [`Unarized | `Complex] Flambda_arity.Component_for_creation.t -> + Expr_with_acc.t + +type non_tail_list_continuation = + Acc.t -> + Env.t -> + CCenv.t -> + IR.simple list -> + [`Unarized | `Complex] Flambda_arity.Component_for_creation.t list -> + Expr_with_acc.t type cps_continuation = | Tail of Continuation.t - | Non_tail of (Acc.t -> Env.t -> CCenv.t -> IR.simple -> Expr_with_acc.t) + | Non_tail of non_tail_continuation -let apply_cps_cont_simple k ?(dbg = Debuginfo.none) acc env ccenv simple = +let apply_cps_cont_simple k ?(dbg = Debuginfo.none) acc env ccenv simples + (arity_component : + [`Unarized | `Complex] Flambda_arity.Component_for_creation.t) = match k with - | Tail k -> apply_cont_with_extra_args acc env ccenv ~dbg k None [simple] - | Non_tail k -> k acc env ccenv simple + | Tail k -> apply_cont_with_extra_args acc env ccenv ~dbg k None simples + | Non_tail k -> k acc env ccenv simples arity_component -let apply_cps_cont k ?dbg acc env ccenv id = - apply_cps_cont_simple k ?dbg acc env ccenv (IR.Var id) +let apply_cps_cont k ?dbg acc env ccenv id + (arity_component : + [`Unarized | `Complex] Flambda_arity.Component_for_creation.t) = + apply_cps_cont_simple k ?dbg acc env ccenv [IR.Var id] arity_component -let maybe_insert_let_cont result_var_name kind k acc env ccenv body = +let maybe_insert_let_cont result_var_name layout k acc env ccenv body = match k with | Tail k -> body acc env ccenv k | Non_tail k -> - let result_var = Ident.create_local result_var_name in - let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false - ~params:[result_var, IR.Not_user_visible, kind] - ~handler:(fun acc env ccenv -> k acc env ccenv (IR.Var result_var)) - ~body + let arity_component = + Flambda_arity.Component_for_creation.from_lambda layout + in + let arity = Flambda_arity.create [arity_component] in + if Flambda_arity.cardinal_unarized arity < 1 + then + let_cont_nonrecursive_with_extra_params acc env ccenv + ~is_exn_handler:false ~params:[] + ~handler:(fun acc env ccenv -> k acc env ccenv [] arity_component) + ~body + else + let result_var = Ident.create_local result_var_name in + let_cont_nonrecursive_with_extra_params acc env ccenv + ~is_exn_handler:false + ~params:[result_var, IR.Not_user_visible, layout] + ~handler:(fun acc env ccenv -> + k acc env ccenv [IR.Var result_var] arity_component) + ~body let name_if_not_var acc ccenv name simple kind body = match simple with @@ -1081,13 +1390,42 @@ let name_if_not_var acc ccenv name simple kind body = let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (k_exn : Continuation.t) : Expr_with_acc.t = match lam with - | Lvar id -> + | Lvar id -> ( assert (not (Env.is_mutable env id)); - apply_cps_cont k acc env ccenv id + if unboxed_product_debug () + then + Format.eprintf "checking for unboxed product fields of %a\n%!" Ident.print + id; + match Env.get_unboxed_product_fields env id with + | None -> + if unboxed_product_debug () then Format.eprintf "...no unboxed fields\n%!"; + let kind = + match CCenv.find_simple_to_substitute_exn ccenv id with + | exception Not_found -> snd (CCenv.find_var ccenv id) + | _, kind -> kind + in + let arity_component = + Flambda_arity.Component_for_creation.Singleton kind + in + apply_cps_cont k acc env ccenv id arity_component + | Some (before_unarization, fields) -> + if unboxed_product_debug () + then + Format.eprintf "...got unboxed fields: (%a)\n%!" + (Format.pp_print_list ~pp_sep:Format.pp_print_space Ident.print) + fields; + let fields = List.map (fun id -> IR.Var id) fields in + apply_cps_cont_simple k acc env ccenv fields before_unarization) | Lmutvar id -> - let return_id = Env.get_mutable_variable env id in + (* CR mshinwell: note: mutable variables of non-singleton layouts are not + supported *) + let return_id, kind = Env.get_mutable_variable_with_kind env id in apply_cps_cont k acc env ccenv return_id - | Lconst const -> apply_cps_cont_simple k acc env ccenv (IR.Const const) + (Flambda_arity.Component_for_creation.Singleton kind) + | Lconst const -> + apply_cps_cont_simple k acc env ccenv [IR.Const const] + (* CR mshinwell: improve layout here *) + (Singleton Flambda_kind.With_subkind.any_value) | Lapply { ap_func; ap_args; @@ -1112,7 +1450,10 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let func = cps_function env ~fid:id ~recursive:(Non_recursive : Recursive.t) func in - let body acc ccenv = apply_cps_cont k ~dbg acc env ccenv id in + let body acc ccenv = + apply_cps_cont k ~dbg acc env ccenv id + (Singleton Flambda_kind.With_subkind.any_value) + in CC.close_let_rec acc ccenv ~function_declarations:[func] ~body ~current_region:(Env.current_region env) | Lmutlet (value_kind, id, defining_expr, body) -> @@ -1122,7 +1463,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ~body:(fun acc env ccenv after_defining_expr -> cps_tail acc env ccenv defining_expr after_defining_expr k_exn) ~handler:(fun acc env ccenv -> - let env, new_id = Env.register_mutable_variable env id value_kind in + let kind = Flambda_kind.With_subkind.from_lambda value_kind in + let env, new_id = Env.register_mutable_variable env id kind in let body acc ccenv = cps acc env ccenv body k k_exn in CC.close_let acc ccenv new_id User_visible (Flambda_kind.With_subkind.from_lambda value_kind) @@ -1151,7 +1493,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) id, Lprim (prim, args, loc), body ) -> ( - match transform_primitive env prim args loc with + if unboxed_product_debug () + then Format.eprintf "Handling let-binding: %a\n%!" Printlambda.lambda lam; + match transform_primitive env id prim args loc with | Primitive (prim, args, loc) -> (* This case avoids extraneous continuations. *) let exn_continuation : IR.exn_continuation option = @@ -1164,7 +1508,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) else None in cps_non_tail_list acc env ccenv args - (fun acc env ccenv args -> + (fun acc env ccenv args _arity -> let body acc ccenv = cps acc env ccenv body k k_exn in let region = Env.current_region env in CC.close_let acc ccenv id User_visible @@ -1172,6 +1516,45 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (Prim { prim; args; loc; exn_continuation; region }) ~body) k_exn + | Unboxed_binding (ids_with_kinds, env) -> + cps_non_tail_list acc env ccenv args + (fun acc env ccenv (args : IR.simple list) _arity -> + if unboxed_product_debug () + then + Format.eprintf "Unboxed_binding: ids_with_kinds=(%a) args=(%a)\n%!" + (Format.pp_print_list ~pp_sep:Format.pp_print_space + (Misc.Stdlib.Option.print (fun ppf (id, kind) -> + Format.fprintf ppf "%a :: %a" Ident.print id + Flambda_kind.With_subkind.print kind))) + ids_with_kinds + (Format.pp_print_list ~pp_sep:Format.pp_print_space + IR.print_simple) + args; + let body acc ccenv = cps acc env ccenv body k k_exn in + if List.compare_lengths ids_with_kinds args <> 0 + then + Misc.fatal_errorf + "ids_with_kinds (%a) doesn't match args (%a) for:@ %a" + (Format.pp_print_list ~pp_sep:Format.pp_print_space + (Misc.Stdlib.Option.print (fun ppf (id, kind) -> + Format.fprintf ppf "%a :: %a" Ident.print id + Flambda_kind.With_subkind.print kind))) + ids_with_kinds + (Format.pp_print_list ~pp_sep:Format.pp_print_space + IR.print_simple) + args Printlambda.lambda lam; + let builder = + List.fold_left2 + (fun body id_and_kind_opt arg acc ccenv -> + match id_and_kind_opt with + | None -> body acc ccenv + | Some (id, kind) -> + CC.close_let acc ccenv id Not_user_visible kind (Simple arg) + ~body) + body ids_with_kinds args + in + builder acc ccenv) + k_exn | Transformed lam -> cps acc env ccenv (L.Llet (let_kind, layout, id, lam, body)) k k_exn) | Llet @@ -1187,7 +1570,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) Misc.fatal_errorf "Lassign on non-mutable variable %a" Ident.print being_assigned; cps_non_tail_simple acc env ccenv new_value - (fun acc env ccenv new_value -> + (fun acc env ccenv new_value _arity -> + let new_value = must_be_singleton_simple new_value in let env, new_id = Env.update_mutable_variable env being_assigned in let body acc ccenv = let body acc ccenv = cps acc env ccenv body k k_exn in @@ -1198,9 +1582,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let value_kind = snd (Env.get_mutable_variable_with_kind env being_assigned) in - CC.close_let acc ccenv new_id User_visible - (Flambda_kind.With_subkind.from_lambda value_kind) - (Simple new_value) ~body) + CC.close_let acc ccenv new_id User_visible value_kind (Simple new_value) + ~body) k_exn | Llet ((Strict | Alias | StrictOpt), layout, id, defining_expr, body) -> let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false @@ -1225,30 +1608,116 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ~current_region:(Env.current_region env) | Dissected lam -> cps acc env ccenv lam k k_exn) | Lprim (prim, args, loc) -> ( - match transform_primitive env prim args loc with - | Primitive (prim, args, loc) -> - let name = Printlambda.name_of_primitive prim in - let result_var = Ident.create_local name in - let exn_continuation : IR.exn_continuation option = - if primitive_can_raise prim - then - Some - { exn_handler = k_exn; - extra_args = extra_args_for_exn_continuation env k_exn - } - else None + match prim with + | Pmake_unboxed_product _ | Punboxed_product_field _ -> + (* This transformation cannot be done for [Praise] (because of the bottom + layout in Lambda) and is probably less efficient than the normal code + path in the next clause. So for the moment we just do it for the + unboxed product cases, as it simplifies matters. *) + (* CR mshinwell: One note though is that [primitive_result_kind] could be + deleted if we could use a path like this all the time. *) + let id = Ident.create_local "prim" in + let result_layout = + match prim with + | Pmake_unboxed_product layouts -> L.Punboxed_product layouts + | Punboxed_product_field (field, layouts) -> + (Array.of_list layouts).(field) + | Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ + | Psetglobal _ | Pgetpredef _ | Pmakeblock _ | Pmakefloatblock _ + | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ + | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise _ + | Psequand | Psequor | Pnot | Pnegint | Paddint | Psubint | Pmulint + | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint + | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats + | Pcompare_bints _ | Poffsetint _ | Poffsetref _ | Pintoffloat + | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ + | Pmulfloat _ | Pdivfloat _ | Pfloatcomp _ | Pstringlength | Pstringrefu + | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs + | Pbytessets | Pmakearray _ | Pduparray _ | Parraylength _ + | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ | Pisint _ + | Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ + | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ + | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ + | Pasrbint _ | Pbintcomp _ | Pbigarrayref _ | Pbigarrayset _ + | Pbigarraydim _ | Pstring_load_16 _ | Pstring_load_32 _ + | Pstring_load_64 _ | Pbytes_load_16 _ | Pbytes_load_32 _ + | Pbytes_load_64 _ | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ + | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _ + | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _ + | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer | Popaque _ + | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ | Punbox_float + | Pbox_float _ | Punbox_int _ | Pbox_int _ | Parray_of_iarray + | Parray_to_iarray -> + assert false in - let current_region = Env.current_region env in - let dbg = Debuginfo.from_location loc in - cps_non_tail_list acc env ccenv args - (fun acc env ccenv args -> - let body acc ccenv = apply_cps_cont ~dbg k acc env ccenv result_var in - CC.close_let acc ccenv result_var Not_user_visible - (primitive_result_kind prim) - (Prim { prim; args; loc; exn_continuation; region = current_region }) - ~body) - k_exn - | Transformed lam -> cps acc env ccenv lam k k_exn) + cps acc env ccenv + (L.Llet (Strict, result_layout, id, lam, L.Lvar id)) + k k_exn + | Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ + | Psetglobal _ | Pgetpredef _ | Pmakeblock _ | Pmakefloatblock _ | Pfield _ + | Pfield_computed _ | Psetfield _ | Psetfield_computed _ | Pfloatfield _ + | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise _ | Psequand | Psequor + | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ + | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ + | Pcompare_ints | Pcompare_floats | Pcompare_bints _ | Poffsetint _ + | Poffsetref _ | Pintoffloat | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ + | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pfloatcomp _ + | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu + | Pbytessetu | Pbytesrefs | Pbytessets | Pmakearray _ | Pduparray _ + | Parraylength _ | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ + | Pisint _ | Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ + | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ + | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ + | Pbintcomp _ | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _ + | Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_64 _ + | Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_64 _ | Pbytes_set_16 _ + | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbigstring_load_16 _ + | Pbigstring_load_32 _ | Pbigstring_load_64 _ | Pbigstring_set_16 _ + | Pbigstring_set_32 _ | Pbigstring_set_64 _ | Pctconst _ | Pbswap16 + | Pbbswap _ | Pint_as_pointer | Popaque _ | Pprobe_is_enabled _ | Pobj_dup + | Pobj_magic _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ + | Parray_of_iarray | Parray_to_iarray -> ( + match + transform_primitive env (Ident.create_local "dummy") prim args loc + with + | Primitive (prim, args, loc) -> ( + let name = Printlambda.name_of_primitive prim in + let result_var = Ident.create_local name in + let exn_continuation : IR.exn_continuation option = + if primitive_can_raise prim + then + Some + { exn_handler = k_exn; + extra_args = extra_args_for_exn_continuation env k_exn + } + else None + in + let current_region = Env.current_region env in + let dbg = Debuginfo.from_location loc in + let arity = primitive_result_kind prim in + match Flambda_arity.must_be_one_param arity with + | None -> + Misc.fatal_errorf + "Expected the following Lprim to require exactly one\n\ + \ variable binding:@ %a" Printlambda.lambda lam + | Some kind -> + cps_non_tail_list acc env ccenv args + (fun acc env ccenv args _arity -> + let body acc ccenv = + apply_cps_cont ~dbg k acc env ccenv result_var (Singleton kind) + in + CC.close_let acc ccenv result_var Not_user_visible kind + (Prim + { prim; + args; + loc; + exn_continuation; + region = current_region + }) + ~body) + k_exn) + | Unboxed_binding _ -> assert false + | Transformed lam -> cps acc env ccenv lam k k_exn)) | Lswitch (scrutinee, switch, loc, kind) -> maybe_insert_let_cont "switch_result" kind k acc env ccenv (fun acc env ccenv k -> @@ -1262,7 +1731,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) | Lstaticraise (static_exn, args) -> let continuation = Env.get_static_exn_continuation env static_exn in cps_non_tail_list acc env ccenv args - (fun acc env ccenv args -> + (fun acc env ccenv args _arity -> let extra_args = List.map (fun var : IR.simple -> Var var) @@ -1283,10 +1752,18 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) else Nonrecursive in let params = - List.map - (fun (arg, kind) -> - arg, IR.User_visible, Flambda_kind.With_subkind.from_lambda kind) - (args @ extra_params) + let args = + List.map + (fun (arg, kind) -> + arg, IR.User_visible, Flambda_kind.With_subkind.from_lambda kind) + args + in + let extra_params = + List.map + (fun (extra_param, kind) -> extra_param, IR.User_visible, kind) + extra_params + in + args @ extra_params in let handler acc ccenv = let ccenv = CCenv.set_not_at_toplevel ccenv in @@ -1297,12 +1774,13 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ~params ~recursive ~body ~handler) | Lsend (meth_kind, meth, obj, args, pos, mode, loc, layout) -> cps_non_tail_simple acc env ccenv obj - (fun acc env ccenv obj -> + (fun acc env ccenv obj _obj_arity -> + let obj = must_be_singleton_simple obj in cps_non_tail_var "meth" acc env ccenv meth Flambda_kind.With_subkind.any_value - (fun acc env ccenv meth -> + (fun acc env ccenv meth _meth_arity -> cps_non_tail_list acc env ccenv args - (fun acc env ccenv args -> + (fun acc env ccenv args args_arity -> maybe_insert_let_cont "send_result" layout k acc env ccenv (fun acc env ccenv k -> let exn_continuation : IR.exn_continuation = @@ -1322,8 +1800,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) probe = None; mode; region = Env.current_region env; + args_arity = Flambda_arity.create args_arity; return_arity = - Flambda_arity.create + Flambda_arity.create_singletons [Flambda_kind.With_subkind.from_lambda layout] } in @@ -1393,7 +1872,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let lam = switch_for_if_then_else ~cond ~ifso ~ifnot ~kind in cps acc env ccenv lam k k_exn | Lsequence (lam1, lam2) -> - let k acc env ccenv _value = cps acc env ccenv lam2 k k_exn in + let k acc env ccenv _value _arity = cps acc env ccenv lam2 k k_exn in cps_non_tail_simple acc env ccenv lam1 k k_exn | Lwhile { wh_cond = cond; wh_body = body; wh_cond_region = _; wh_body_region = _ } @@ -1417,17 +1896,18 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) Misc.fatal_errorf "Lassign on non-mutable variable %a" Ident.print being_assigned; cps_non_tail_simple acc env ccenv new_value - (fun acc env ccenv new_value -> + (fun acc env ccenv new_value _arity -> + let new_value = must_be_singleton_simple new_value in let env, new_id = Env.update_mutable_variable env being_assigned in let body acc ccenv = - apply_cps_cont_simple k acc env ccenv (Const L.const_unit) + apply_cps_cont_simple k acc env ccenv [Const L.const_unit] + (Singleton Flambda_kind.With_subkind.tagged_immediate) in let _, value_kind = Env.get_mutable_variable_with_kind env being_assigned in - CC.close_let acc ccenv new_id User_visible - (Flambda_kind.With_subkind.from_lambda value_kind) - (Simple new_value) ~body) + CC.close_let acc ccenv new_id User_visible value_kind (Simple new_value) + ~body) k_exn | Levent (body, _event) -> cps acc env ccenv body k k_exn | Lifused _ -> @@ -1492,24 +1972,48 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) apply_cont_with_extra_args acc env ccenv ~dbg k None [IR.Var wrap_return])))) -and cps_non_tail_simple acc env ccenv lam k k_exn = +and cps_non_tail_simple : + Acc.t -> + Env.t -> + CCenv.t -> + Lambda.lambda -> + non_tail_continuation -> + Continuation.t -> + Expr_with_acc.t = + fun acc env ccenv lam (k : non_tail_continuation) k_exn -> cps acc env ccenv lam (Non_tail k) k_exn -and cps_non_tail_var name acc env ccenv lam kind k k_exn = +and cps_non_tail_var : + string -> + Acc.t -> + Env.t -> + CCenv.t -> + Lambda.lambda -> + Flambda_kind.With_subkind.t -> + (Acc.t -> + Env.t -> + CCenv.t -> + Ident.t -> + [`Unarized | `Complex] Flambda_arity.Component_for_creation.t -> + Expr_with_acc.t) -> + Continuation.t -> + Expr_with_acc.t = + fun name acc env ccenv lam kind k k_exn -> cps_non_tail_simple acc env ccenv lam - (fun acc env ccenv simple -> + (fun acc env ccenv simple arity -> + let simple = must_be_singleton_simple simple in name_if_not_var acc ccenv name simple kind (fun var acc ccenv -> - k acc env ccenv var)) + k acc env ccenv var arity)) k_exn and cps_tail_apply acc env ccenv ap_func ap_args ap_region_close ap_mode ap_loc ap_inlined ap_probe ap_return (k : Continuation.t) (k_exn : Continuation.t) : Expr_with_acc.t = cps_non_tail_list acc env ccenv ap_args - (fun acc env ccenv args -> + (fun acc env ccenv args args_arity -> cps_non_tail_var "func" acc env ccenv ap_func Flambda_kind.With_subkind.any_value - (fun acc env ccenv func -> + (fun acc env ccenv func _func_arity -> let exn_continuation : IR.exn_continuation = { exn_handler = k_exn; extra_args = extra_args_for_exn_continuation env k_exn @@ -1527,9 +2031,10 @@ and cps_tail_apply acc env ccenv ap_func ap_args ap_region_close ap_mode ap_loc probe = ap_probe; mode = ap_mode; region = Env.current_region env; + args_arity = Flambda_arity.create args_arity; return_arity = Flambda_arity.create - [Flambda_kind.With_subkind.from_lambda ap_return] + [Flambda_arity.Component_for_creation.from_lambda ap_return] } in wrap_return_continuation acc env ccenv apply) @@ -1540,23 +2045,34 @@ and cps_tail acc env ccenv (lam : L.lambda) (k : Continuation.t) (k_exn : Continuation.t) : Expr_with_acc.t = cps acc env ccenv lam (Tail k) k_exn -and cps_non_tail_list acc env ccenv lams k k_exn = +and cps_non_tail_list : + Acc.t -> + Env.t -> + CCenv.t -> + Lambda.lambda list -> + non_tail_list_continuation -> + Continuation.t -> + Expr_with_acc.t = + fun acc env ccenv lams (k : non_tail_list_continuation) k_exn -> let lams = List.rev lams in (* Always evaluate right-to-left. *) cps_non_tail_list_core acc env ccenv lams - (fun acc env ccenv ids -> k acc env ccenv (List.rev ids)) + (fun acc env ccenv ids + (arity : + [`Unarized | `Complex] Flambda_arity.Component_for_creation.t list) -> + k acc env ccenv (List.rev ids) (List.rev arity)) k_exn and cps_non_tail_list_core acc env ccenv (lams : L.lambda list) - (k : Acc.t -> Env.t -> CCenv.t -> IR.simple list -> Expr_with_acc.t) - (k_exn : Continuation.t) = + (k : non_tail_list_continuation) (k_exn : Continuation.t) = match lams with - | [] -> k acc env ccenv [] + | [] -> k acc env ccenv [] [] | lam :: lams -> cps_non_tail_simple acc env ccenv lam - (fun acc env ccenv simple -> + (fun acc env ccenv simples arity -> cps_non_tail_list_core acc env ccenv lams - (fun acc env ccenv simples -> k acc env ccenv (simple :: simples)) + (fun acc env ccenv simples' arity' -> + k acc env ccenv (List.rev simples @ simples') (arity :: arity')) k_exn) k_exn @@ -1655,23 +2171,79 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents (Compilation_unit.get_current_exn ()) ~name:(Ident.name fid) Flambda_kind.With_subkind.any_value in + let params_arity = Flambda_arity.from_lambda_list (List.map snd params) in + let unarized_per_param = Flambda_arity.unarize_per_parameter params_arity in + assert (List.compare_lengths params unarized_per_param = 0); + let unboxed_products = ref Ident.Map.empty in + let params = + List.concat_map + (fun ((param, layout), kinds) -> + match kinds with + | [] -> [] + | [kind] -> [param, kind] + | _ :: _ -> + if unboxed_product_debug () + then + Format.eprintf + "splitting unboxed product for function parameter %a\n%!" + Ident.print param; + let fields = + List.mapi + (fun n kind -> + let ident = + Ident.create_local + (Printf.sprintf "%s_unboxed%d" (Ident.unique_name param) n) + in + ident, kind) + kinds + in + let before_unarization = + Flambda_arity.Component_for_creation.from_lambda layout + in + unboxed_products + := Ident.Map.add param + (before_unarization, fields) + !unboxed_products; + fields) + (List.combine params unarized_per_param) + in + if unboxed_product_debug () + then + if List.compare_lengths params unarized_per_param <> 0 + then + Format.eprintf "flattened param list for %a:@ %a\n%!" Ident.print fid + (Format.pp_print_list (fun ppf (id, kind) -> + Format.fprintf ppf "%a :: %a" Ident.print id + Flambda_kind.With_subkind.print kind)) + params; + let unboxed_products = !unboxed_products in + let removed_params = Ident.Map.keys unboxed_products in + let return = + Flambda_arity.create + [Flambda_arity.Component_for_creation.from_lambda return] + in let body acc ccenv = let ccenv = CCenv.set_path_to_root ccenv loc in let ccenv = CCenv.set_not_at_toplevel ccenv in + let new_env = + Ident.Map.fold + (fun unboxed_product (before_unarization, fields) new_env -> + if unboxed_product_debug () + then + Format.eprintf + "registering unboxed product for function parameter %a\n%!" + Ident.print unboxed_product; + Env.register_unboxed_product new_env ~unboxed_product + ~before_unarization ~fields) + unboxed_products new_env + in cps_tail acc new_env ccenv body body_cont body_exn_cont in - let params = - List.map - (fun (param, kind) -> param, Flambda_kind.With_subkind.from_lambda kind) - params - in - let return = - Flambda_arity.create [Flambda_kind.With_subkind.from_lambda return] - in Function_decl.create ~let_rec_ident:(Some fid) ~function_slot ~kind ~params - ~return ~return_continuation:body_cont ~exn_continuation ~my_region ~body - ~attr ~loc ~free_idents_of_body recursive ~closure_alloc_mode:mode - ~num_trailing_local_params ~contains_no_escaping_local_allocs:region + ~params_arity ~removed_params ~return ~return_continuation:body_cont + ~exn_continuation ~my_region ~body ~attr ~loc ~free_idents_of_body recursive + ~closure_alloc_mode:mode ~num_trailing_local_params + ~contains_no_escaping_local_allocs:region and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg ~scrutinee (k : Continuation.t) (k_exn : Continuation.t) : Expr_with_acc.t = @@ -1743,7 +2315,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg in cps_non_tail_var "scrutinee" acc env ccenv scrutinee Flambda_kind.With_subkind.any_value - (fun acc env ccenv scrutinee -> + (fun acc env ccenv scrutinee _arity -> let ccenv = CCenv.set_not_at_toplevel ccenv in let consts_rev, wrappers = convert_arms_rev env switch.sw_consts [] in let blocks_rev, wrappers = diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml index 84ff7ff9942..7bcefc1e61b 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -1220,7 +1220,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) %a (%a)" Printlambda.primitive prim H.print_list_of_simple_or_prim args | ( ( Pignore | Psequand | Psequor | Pbytes_of_string | Pbytes_to_string - | Parray_of_iarray | Parray_to_iarray ), + | Parray_of_iarray | Parray_to_iarray | Pmake_unboxed_product _ + | Punboxed_product_field _ ), _ ) -> Misc.fatal_errorf "[%a] should have been removed by [Lambda_to_flambda.transform_primitive]" diff --git a/middle_end/flambda2/kinds/flambda_arity.ml b/middle_end/flambda2/kinds/flambda_arity.ml index 5ff02e47cd4..0b2c8c8a3d8 100644 --- a/middle_end/flambda2/kinds/flambda_arity.ml +++ b/middle_end/flambda2/kinds/flambda_arity.ml @@ -15,48 +15,134 @@ (**************************************************************************) module Component = struct - type t = Singleton of Flambda_kind.With_subkind.t + type _ t = + | Singleton : Flambda_kind.With_subkind.t -> [> `Unarized] t + | Unboxed_product : _ t list -> [> `Complex] t - let equal_ignoring_subkinds t1 t2 = + let rec equal_ignoring_subkinds : type uc1 uc2. uc1 t -> uc2 t -> bool = + fun t1 t2 -> match t1, t2 with | Singleton kind1, Singleton kind2 -> - Flambda_kind.With_subkind.equal_ignoring_subkind kind1 kind2 + Flambda_kind.With_subkind.equal + (Flambda_kind.With_subkind.erase_subkind kind1) + (Flambda_kind.With_subkind.erase_subkind kind2) + | Unboxed_product ts1, Unboxed_product ts2 -> + Misc.Stdlib.List.equal equal_ignoring_subkinds ts1 ts2 + | Singleton _, Unboxed_product _ | Unboxed_product _, Singleton _ -> false - let equal_exact t1 t2 = + let rec equal_exact : type uc1 uc2. uc1 t -> uc2 t -> bool = + fun t1 t2 -> match t1, t2 with | Singleton kind1, Singleton kind2 -> Flambda_kind.With_subkind.equal kind1 kind2 + | Unboxed_product ts1, Unboxed_product ts2 -> + Misc.Stdlib.List.equal equal_exact ts1 ts2 + | Singleton _, Unboxed_product _ | Unboxed_product _, Singleton _ -> false - let print ~product_above:_ ppf t = - match t with Singleton kind -> Flambda_kind.With_subkind.print ppf kind + let rec print : type uc. Format.formatter -> uc t -> unit = + fun ppf t -> + match t with + | Singleton kind -> Flambda_kind.With_subkind.print ppf kind + | Unboxed_product [] -> Format.pp_print_string ppf "void" + | Unboxed_product ts -> + Format.fprintf ppf "@[%t#%t(%a)@]" Flambda_colours.unboxed_product + Flambda_colours.pop + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf " @<1>\u{2a2f} ") + print) + ts + + let rec unarize : type uc. uc t -> Flambda_kind.With_subkind.t list = + fun t -> + match t with + | Singleton kind -> [kind] + | Unboxed_product [] -> [] + | Unboxed_product ts -> List.concat_map unarize ts end -type t = Component.t list +type 'uc t = 'uc Component.t list + +module Component_for_creation = struct + type 'uc t = 'uc Component.t = + | Singleton : Flambda_kind.With_subkind.t -> [> `Unarized] t + | Unboxed_product : _ t list -> [> `Complex] t + + let rec from_lambda (layout : Lambda.layout) = + match layout with + | Pvalue _ | Punboxed_float | Punboxed_int _ -> + Singleton (Flambda_kind.With_subkind.from_lambda layout) + | Punboxed_product layouts -> Unboxed_product (List.map from_lambda layouts) + | Ptop -> + Misc.fatal_error + "Cannot convert Ptop to Flambda_arity.Component_for_creation" + | Pbottom -> + Misc.fatal_error + "Cannot convert Pbottom to Flambda_arity.Component_for_creation" +end let nullary = [] -let create t = List.map (fun kind -> Component.Singleton kind) t +let create t = t -let to_list t = List.map (fun (Component.Singleton kind) -> kind) t +let create_singletons t = List.map (fun kind -> Component.Singleton kind) t let print ppf t = Format.fprintf ppf "@[%a@]" - (Format.pp_print_list (Component.print ~product_above:true) - ~pp_sep:(fun ppf () -> Format.fprintf ppf " @<1>\u{2a2f} ")) + (Format.pp_print_list Component.print ~pp_sep:(fun ppf () -> + Format.fprintf ppf " @<1>\u{2a2f} ")) t -let equal_ignoring_subkinds t1 t2 = - List.equal Component.equal_ignoring_subkinds t1 t2 +let equal_ignoring_subkinds : type uc1 uc2. uc1 t -> uc2 t -> bool = + fun t1 t2 -> Misc.Stdlib.List.equal Component.equal_ignoring_subkinds t1 t2 -let equal_exact t1 t2 = List.equal Component.equal_exact t1 t2 +let equal_exact : type uc1 uc2. uc1 t -> uc2 t -> bool = + fun t1 t2 -> Misc.Stdlib.List.equal Component.equal_exact t1 t2 -let is_singleton_value t = +let is_one_param_of_kind_value : type uc. uc t -> bool = + fun t -> match t with | [Component.Singleton kind] when Flambda_kind.equal (Flambda_kind.With_subkind.kind kind) Flambda_kind.value -> true - | [] | Component.Singleton _ :: _ -> false + | [] | Component.Singleton _ :: _ | Component.Unboxed_product _ :: _ -> false + +let unarize t = t |> List.map Component.unarize |> List.concat + +let unarize_per_parameter t = t |> List.map Component.unarize + +let unarize_t t = t |> unarize |> create_singletons + +let fresh_idents_unarized t ~id = + List.mapi + (fun n kind -> + let ident = + Ident.create_local + (Printf.sprintf "%s_unboxed%d" (Ident.unique_name id) n) + in + ident, kind) + (unarize t) + +let cardinal_unarized t = List.length (unarize t) + +let num_params t = List.length t + +let rec must_be_one_param : type uc. uc t -> Flambda_kind.With_subkind.t option + = + fun t -> + match t with + | [Component.Singleton kind] -> Some kind + | [Component.Unboxed_product component] -> must_be_one_param component + | [] | (Component.Singleton _ | Component.Unboxed_product _) :: _ -> None + +let from_lambda_list layouts = + layouts |> List.map Component_for_creation.from_lambda |> create -let cardinal t = List.length t +let partially_apply t ~num_non_unarized_params_provided = + if num_non_unarized_params_provided < 0 + || num_non_unarized_params_provided >= List.length t + then + Misc.fatal_errorf "Bad num_non_unarized_params_provided (%d): %a" + num_non_unarized_params_provided print t + else snd (Misc.Stdlib.List.split_at num_non_unarized_params_provided t) diff --git a/middle_end/flambda2/kinds/flambda_arity.mli b/middle_end/flambda2/kinds/flambda_arity.mli index a055dc49283..18d1ec381df 100644 --- a/middle_end/flambda2/kinds/flambda_arity.mli +++ b/middle_end/flambda2/kinds/flambda_arity.mli @@ -14,25 +14,80 @@ (* *) (**************************************************************************) -(** Arities are lists of kinds (with subkinds) used to describe things - such as the kinding of function and continuation parameter lists. *) +(** Arities are used to describe the layouts of things like function and + continuation parameter lists. -type t + In Flambda 2, variables are always assigned kinds, which are at most + register width (presently machine word width, but in the future of SIMD + widths too). Variables from Lambda which cannot be accommodated in one + register, for example if they are of an unboxed product layout, are split + by a process called unarization. -val nullary : t + Despite this, [`Complex] arities preserve the information about any unboxed + products, for later use (e.g. during Cmm translation to optimize + caml_apply). +*) -val create : Flambda_kind.With_subkind.t list -> t +type _ t -val to_list : t -> Flambda_kind.With_subkind.t list +module Component_for_creation : sig + type _ t = + | Singleton : Flambda_kind.With_subkind.t -> [> `Unarized] t + (* The nullary unboxed product is called "void". It is important to + propagate information about void layouts, even though the corresponding + variables have no runtime representation, as they interact with + currying. *) + | Unboxed_product : _ t list -> [> `Complex] t -val cardinal : t -> int + val from_lambda : Lambda.layout -> [`Unarized | `Complex] t +end -val is_singleton_value : t -> bool +(** One component per function or continuation parameter, for example. Each + component may in turn have an arity describing an unboxed product. *) +val create : 'uc Component_for_creation.t list -> 'uc t -val print : Format.formatter -> t -> unit +val create_singletons : Flambda_kind.With_subkind.t list -> [> `Unarized] t -val equal_ignoring_subkinds : t -> t -> bool +(** "No parameters". (Not e.g. "one parameter of type void".) *) +val nullary : [> `Unarized] t + +val num_params : _ t -> int + +val print : Format.formatter -> _ t -> unit + +val equal_ignoring_subkinds : _ t -> _ t -> bool (* It's usually a mistake to use this function, but it's needed for [Compare]. *) -val equal_exact : t -> t -> bool +val equal_exact : _ t -> _ t -> bool + +val is_one_param_of_kind_value : _ t -> bool + +val must_be_one_param : _ t -> Flambda_kind.With_subkind.t option + +(** Converts, in a left-to-right depth-first order, an arity into a flattened + list of kinds for all parameters. *) +val unarize : _ t -> Flambda_kind.With_subkind.t list + +(** Like [unarize] but returns one list per parameter. *) +val unarize_per_parameter : _ t -> Flambda_kind.With_subkind.t list list + +(** Like [unarize] but returns a value of type [t]. *) +val unarize_t : _ t -> [> `Unarized] t + +(** Given an arity and an identifier, produce a list of identifiers (with + corresponding kinds) whose length matches [unarize t], with names derived + from the given identifier. *) +val fresh_idents_unarized : + _ t -> id:Ident.t -> (Ident.t * Flambda_kind.With_subkind.t) list + +(** The length of the list returned by [unarize]. *) +val cardinal_unarized : _ t -> int + +(** Take a list of Lambda layouts, one per parameter, and form the + corresponding arity. *) +val from_lambda_list : Lambda.layout list -> [`Unarized | `Complex] t + +(** Remove the first portion of an arity to correspond to a partial + application. *) +val partially_apply : 'uc t -> num_non_unarized_params_provided:int -> 'uc t diff --git a/middle_end/flambda2/kinds/flambda_kind.ml b/middle_end/flambda2/kinds/flambda_kind.ml index d0558c33bb8..165b0976100 100644 --- a/middle_end/flambda2/kinds/flambda_kind.ml +++ b/middle_end/flambda2/kinds/flambda_kind.ml @@ -531,6 +531,8 @@ module With_subkind = struct | Punboxed_int Pint32 -> naked_int32 | Punboxed_int Pint64 -> naked_int64 | Punboxed_int Pnativeint -> naked_nativeint + | Punboxed_product _ -> + Misc.fatal_error "Punboxed_product disallowed here, use Flambda_arity" include Container_types.Make (struct type nonrec t = t diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index f00281a5f5e..3bc4e8b31bf 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -283,7 +283,8 @@ let value_kind_with_subkind_opt : | Some kind -> value_kind_with_subkind kind | None -> Flambda_kind.With_subkind.any_value -let arity a = Flambda_arity.create (List.map value_kind_with_subkind a) +let arity a = + Flambda_arity.create_singletons (List.map value_kind_with_subkind a) let const (c : Fexpr.const) : Reg_width_const.t = match c with @@ -800,11 +801,12 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = (fun ({ kind; _ } : Fexpr.kinded_parameter) -> value_kind_with_subkind_opt kind) params_and_body.params - |> Flambda_arity.create + |> Flambda_arity.create_singletons in let result_arity = match ret_arity with - | None -> Flambda_arity.create [Flambda_kind.With_subkind.any_value] + | None -> + Flambda_arity.create_singletons [Flambda_kind.With_subkind.any_value] | Some ar -> arity ar in let ( _params, @@ -836,7 +838,7 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let my_depth, env = fresh_var env depth_var in let return_continuation, env = fresh_cont env ret_cont ~sort:Return - ~arity:(Flambda_arity.cardinal result_arity) + ~arity:(Flambda_arity.cardinal_unarized result_arity) in let exn_continuation, env = fresh_exn_cont env exn_cont in assert ( @@ -920,12 +922,13 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let params_arity = (* CR mshinwell: This needs fixing to cope with the fact that the arities have moved onto [Apply_expr] *) - Flambda_arity.create + Flambda_arity.create_singletons (List.map (fun _ -> Flambda_kind.With_subkind.any_value) args) in let return_arity = match arities with - | None -> Flambda_arity.create [Flambda_kind.With_subkind.any_value] + | None -> + Flambda_arity.create_singletons [Flambda_kind.With_subkind.any_value] | Some { ret_arity; _ } -> arity ret_arity in let alloc = alloc_mode_for_types alloc in @@ -943,13 +946,13 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = let params_arity = (* CR mshinwell: This needs fixing to cope with the fact that the arities have moved onto [Apply_expr] *) - Flambda_arity.create + Flambda_arity.create_singletons (List.map (fun _ -> Flambda_kind.With_subkind.any_value) args) in let return_arity = (* CR mshinwell: This needs fixing to cope with the fact that the arities have moved onto [Apply_expr] *) - Flambda_arity.create [Flambda_kind.With_subkind.any_value] + Flambda_arity.create_singletons [Flambda_kind.With_subkind.any_value] in ( Call_kind.indirect_function_call_unknown_arity alloc, params_arity, diff --git a/middle_end/flambda2/parser/flambda_to_fexpr.ml b/middle_end/flambda2/parser/flambda_to_fexpr.ml index 6b332f55032..de6f7d0a5bf 100644 --- a/middle_end/flambda2/parser/flambda_to_fexpr.ml +++ b/middle_end/flambda2/parser/flambda_to_fexpr.ml @@ -452,15 +452,16 @@ let kind_with_subkind_opt (k : Flambda_kind.With_subkind.t) : Fexpr.kind_with_subkind option = if is_default_kind_with_subkind k then None else Some (k |> kind_with_subkind) -let is_default_arity (a : Flambda_arity.t) = - match Flambda_arity.to_list a with +let is_default_arity (a : _ Flambda_arity.t) = + match Flambda_arity.unarize a with | [k] -> is_default_kind_with_subkind k | _ -> false -let arity (a : Flambda_arity.t) : Fexpr.arity = - Flambda_arity.to_list a |> List.map kind_with_subkind +let arity (a : _ Flambda_arity.t) : Fexpr.arity = + (* CR mshinwell: add unboxed arities to Fexpr *) + Flambda_arity.unarize a |> List.map kind_with_subkind -let arity_opt (a : Flambda_arity.t) : Fexpr.arity option = +let arity_opt (a : _ Flambda_arity.t) : Fexpr.arity option = if is_default_arity a then None else Some (arity a) let kinded_parameter env (kp : Bound_parameter.t) : diff --git a/middle_end/flambda2/simplify/apply_cont_rewrite.ml b/middle_end/flambda2/simplify/apply_cont_rewrite.ml index 9d77810f3b0..49933b48cac 100644 --- a/middle_end/flambda2/simplify/apply_cont_rewrite.ml +++ b/middle_end/flambda2/simplify/apply_cont_rewrite.ml @@ -84,7 +84,7 @@ let create ~original_params ~extra_params_and_args ~decide_param_usage = extra_params } -let original_params_arity t = Bound_parameters.arity t.original_params +(* let original_params_arity t = Bound_parameters.arity t.original_params *) let rec partition_used l usage = match l, usage with @@ -234,16 +234,14 @@ let make_rewrite rewrite ~ctx id args = let rewrite_exn_continuation rewrite id exn_cont = let exn_cont_arity = Exn_continuation.arity exn_cont in - if not - (Flambda_arity.equal_ignoring_subkinds exn_cont_arity - (original_params_arity rewrite)) - then - Misc.fatal_errorf - "Arity of exception continuation %a does not match@ [original_params] \ - (%a)" - Exn_continuation.print exn_cont Bound_parameters.print - rewrite.original_params; - assert (Flambda_arity.cardinal exn_cont_arity >= 1); + (* XXX see comment elsewhere - propagating original arity is tedious + + if not (Flambda_arity.equal_ignoring_subkinds exn_cont_arity + (original_params_arity rewrite)) then Misc.fatal_errorf "Arity of exception + continuation %a does not match@ [original_params] \ (%a)" + Exn_continuation.print exn_cont Bound_parameters.print + rewrite.original_params; *) + assert (Flambda_arity.cardinal_unarized exn_cont_arity >= 1); if List.hd rewrite.original_params_usage <> Used then Misc.fatal_errorf diff --git a/middle_end/flambda2/simplify/apply_cont_rewrite.mli b/middle_end/flambda2/simplify/apply_cont_rewrite.mli index f188d475cdd..a29f0dd824a 100644 --- a/middle_end/flambda2/simplify/apply_cont_rewrite.mli +++ b/middle_end/flambda2/simplify/apply_cont_rewrite.mli @@ -42,7 +42,7 @@ val get_used_params : t -> Bound_parameters.t * Bound_parameters.t val get_unused_params : t -> Bound_parameters.t -val original_params_arity : t -> Flambda_arity.t +(* val original_params_arity : t -> Flambda_arity.t *) type rewrite_apply_cont_ctx = | Apply_cont diff --git a/middle_end/flambda2/simplify/continuation_in_env.ml b/middle_end/flambda2/simplify/continuation_in_env.ml index 664e1360cf7..dae49153e5a 100644 --- a/middle_end/flambda2/simplify/continuation_in_env.ml +++ b/middle_end/flambda2/simplify/continuation_in_env.ml @@ -22,10 +22,10 @@ type t = cost_metrics_of_handler : Cost_metrics.t } | Non_inlinable_zero_arity of { handler : Rebuilt_expr.t Or_unknown.t } - | Non_inlinable_non_zero_arity of { arity : Flambda_arity.t } + | Non_inlinable_non_zero_arity of { arity : [`Unarized] Flambda_arity.t } | Toplevel_or_function_return_or_exn_continuation of - { arity : Flambda_arity.t } - | Invalid of { arity : Flambda_arity.t } + { arity : [`Unarized] Flambda_arity.t } + | Invalid of { arity : [`Unarized] Flambda_arity.t } let [@ocamlformat "disable"] print are_rebuilding_terms ppf t = match t with diff --git a/middle_end/flambda2/simplify/continuation_in_env.mli b/middle_end/flambda2/simplify/continuation_in_env.mli index 5e1410886f9..31fe2fd64af 100644 --- a/middle_end/flambda2/simplify/continuation_in_env.mli +++ b/middle_end/flambda2/simplify/continuation_in_env.mli @@ -30,13 +30,13 @@ type t = (** The handler, if available, is stored for [Simplify_switch_expr]. *) } - | Non_inlinable_non_zero_arity of { arity : Flambda_arity.t } + | Non_inlinable_non_zero_arity of { arity : [`Unarized] Flambda_arity.t } | Toplevel_or_function_return_or_exn_continuation of - { arity : Flambda_arity.t } - | Invalid of { arity : Flambda_arity.t } + { arity : [`Unarized] Flambda_arity.t } + | Invalid of { arity : [`Unarized] Flambda_arity.t } (** [Invalid] means that the code of the continuation handler is invalid, not that the continuation has zero uses. *) val print : Are_rebuilding_terms.t -> Format.formatter -> t -> unit -val arity : t -> Flambda_arity.t +val arity : t -> [`Unarized] Flambda_arity.t diff --git a/middle_end/flambda2/simplify/env/continuation_uses.ml b/middle_end/flambda2/simplify/env/continuation_uses.ml index 751760edb8b..e6b6bb0ecd1 100644 --- a/middle_end/flambda2/simplify/env/continuation_uses.ml +++ b/middle_end/flambda2/simplify/env/continuation_uses.ml @@ -20,7 +20,7 @@ module U = One_continuation_use type t = { continuation : Continuation.t; - arity : Flambda_arity.t; + arity : [`Unarized] Flambda_arity.t; uses : U.t list } @@ -95,7 +95,7 @@ let add_uses_to_arg_maps arg_maps uses = let empty_arg_maps arity : arg_types_by_use_id = List.map (fun _ -> Apply_cont_rewrite_id.Map.empty) - (Flambda_arity.to_list arity) + (Flambda_arity.unarize arity) let get_arg_types_by_use_id t = add_uses_to_arg_maps (empty_arg_maps t.arity) t.uses @@ -107,10 +107,12 @@ let get_arg_types_by_use_id_for_invariant_params arity l = List.fold_left (fun arg_maps t -> if not - (Misc.Stdlib.List.is_prefix - ~equal:Flambda_kind.With_subkind.equal_ignoring_subkind - (Flambda_arity.to_list arity) - ~of_:(Flambda_arity.to_list t.arity)) + (Misc.Stdlib.List.is_prefix ~equal:Flambda_kind.equal + (Flambda_arity.unarize arity + |> List.map Flambda_kind.With_subkind.kind) + ~of_: + (Flambda_arity.unarize t.arity + |> List.map Flambda_kind.With_subkind.kind)) then Misc.fatal_errorf "Arity of invariant params@ (%a) is not a prefix of the arity of the \ diff --git a/middle_end/flambda2/simplify/env/continuation_uses.mli b/middle_end/flambda2/simplify/env/continuation_uses.mli index d92e7b3d028..7af4f7591b6 100644 --- a/middle_end/flambda2/simplify/env/continuation_uses.mli +++ b/middle_end/flambda2/simplify/env/continuation_uses.mli @@ -21,7 +21,7 @@ type t -val create : Continuation.t -> Flambda_arity.t -> t +val create : Continuation.t -> [`Unarized] Flambda_arity.t -> t val print : Format.formatter -> t -> unit @@ -50,13 +50,13 @@ val get_arg_types_by_use_id : t -> arg_types_by_use_id prefix of each of these argument lists, corresponding to the invariant params, and merges them. *) val get_arg_types_by_use_id_for_invariant_params : - Flambda_arity.t -> t list -> arg_types_by_use_id + [`Unarized] Flambda_arity.t -> t list -> arg_types_by_use_id val get_use_ids : t -> Apply_cont_rewrite_id.Set.t val number_of_uses : t -> int -val arity : t -> Flambda_arity.t +val arity : t -> [`Unarized] Flambda_arity.t val get_typing_env_no_more_than_one_use : t -> Flambda2_types.Typing_env.t option diff --git a/middle_end/flambda2/simplify/env/upwards_env.mli b/middle_end/flambda2/simplify/env/upwards_env.mli index c23158e38ef..be858282962 100644 --- a/middle_end/flambda2/simplify/env/upwards_env.mli +++ b/middle_end/flambda2/simplify/env/upwards_env.mli @@ -29,10 +29,15 @@ val add_non_inlinable_continuation : handler:Rebuilt_expr.t Or_unknown.t -> t -val add_invalid_continuation : t -> Continuation.t -> Flambda_arity.t -> t +val add_invalid_continuation : + t -> Continuation.t -> [`Unarized] Flambda_arity.t -> t val add_continuation_alias : - t -> Continuation.t -> Flambda_arity.t -> alias_for:Continuation.t -> t + t -> + Continuation.t -> + [`Unarized] Flambda_arity.t -> + alias_for:Continuation.t -> + t val add_linearly_used_inlinable_continuation : t -> @@ -44,7 +49,7 @@ val add_linearly_used_inlinable_continuation : t val add_function_return_or_exn_continuation : - t -> Continuation.t -> Flambda_arity.t -> t + t -> Continuation.t -> [`Unarized] Flambda_arity.t -> t val find_continuation : t -> Continuation.t -> Continuation_in_env.t diff --git a/middle_end/flambda2/simplify/expr_builder.ml b/middle_end/flambda2/simplify/expr_builder.ml index 601ed1a6369..95c81f18355 100644 --- a/middle_end/flambda2/simplify/expr_builder.ml +++ b/middle_end/flambda2/simplify/expr_builder.ml @@ -705,14 +705,15 @@ let rewrite_fixed_arity_continuation0 uacc cont_or_apply_cont ~use_id arity : match UE.find_apply_cont_rewrite uenv original_cont with | None -> This_continuation cont | Some rewrite when Apply_cont_rewrite.does_nothing rewrite -> - let arity_in_rewrite = Apply_cont_rewrite.original_params_arity rewrite in - if not (Flambda_arity.equal_ignoring_subkinds arity arity_in_rewrite) - then - Misc.fatal_errorf - "Arity %a provided to fixed-arity-wrapper addition function does not \ - match arity %a in rewrite:@ %a" - Flambda_arity.print arity Flambda_arity.print arity_in_rewrite - Apply_cont_rewrite.print rewrite; + (* XXX getting original_params_arity is tedious as it requires propagation + through Simplify_let_cont + + let arity_in_rewrite = Apply_cont_rewrite.original_params_arity rewrite + in if not (Flambda_arity.equal_ignoring_subkinds arity arity_in_rewrite) + then Misc.fatal_errorf "Arity %a provided to fixed-arity-wrapper addition + function does not \ match arity %a in rewrite:@ %a" Flambda_arity.print + arity Flambda_arity.print arity_in_rewrite Apply_cont_rewrite.print + rewrite; *) This_continuation cont | Some rewrite -> ( let new_wrapper params expr ~free_names @@ -740,9 +741,9 @@ let rewrite_fixed_arity_continuation0 uacc cont_or_apply_cont ~use_id arity : let params = List.map (fun _kind -> Variable.create "param") - (Flambda_arity.to_list arity) + (Flambda_arity.unarize arity) in - let params = List.map2 BP.create params (Flambda_arity.to_list arity) in + let params = List.map2 BP.create params (Flambda_arity.unarize arity) in let args = List.map BP.simple params in let params = Bound_parameters.create params in let apply_cont = Apply_cont.create cont ~args ~dbg:Debuginfo.none in diff --git a/middle_end/flambda2/simplify/expr_builder.mli b/middle_end/flambda2/simplify/expr_builder.mli index 09bbd6f28b9..d6cb2e13d0d 100644 --- a/middle_end/flambda2/simplify/expr_builder.mli +++ b/middle_end/flambda2/simplify/expr_builder.mli @@ -127,13 +127,13 @@ val rewrite_switch_arm : Upwards_acc.t -> Apply_cont.t -> use_id:Apply_cont_rewrite_id.t -> - Flambda_arity.t -> + [`Unarized] Flambda_arity.t -> rewrite_switch_arm_result val rewrite_fixed_arity_apply : Upwards_acc.t -> use_id:Apply_cont_rewrite_id.t -> - Flambda_arity.t -> + [`Unarized] Flambda_arity.t -> Apply.t -> Upwards_acc.t * Rebuilt_expr.t diff --git a/middle_end/flambda2/simplify/flow/flow.mli b/middle_end/flambda2/simplify/flow/flow.mli index 31c43462508..345bb0ce226 100644 --- a/middle_end/flambda2/simplify/flow/flow.mli +++ b/middle_end/flambda2/simplify/flow/flow.mli @@ -82,7 +82,7 @@ module Acc : sig val add_apply_conts : result_cont:(Apply_cont_rewrite_id.t * Continuation.t) option -> exn_cont:Apply_cont_rewrite_id.t * Exn_continuation.t -> - result_arity:Flambda_arity.t -> + result_arity:[`Unarized] Flambda_arity.t -> t -> t diff --git a/middle_end/flambda2/simplify/flow/flow_acc.ml b/middle_end/flambda2/simplify/flow/flow_acc.ml index b205dbc2799..9d09ad470c6 100644 --- a/middle_end/flambda2/simplify/flow/flow_acc.ml +++ b/middle_end/flambda2/simplify/flow/flow_acc.ml @@ -277,7 +277,7 @@ let add_apply_conts ~result_cont ~exn_cont ~result_arity t = | None -> apply_cont_args | Some (rewrite_id, result_cont) -> add_func_result result_cont rewrite_id - ~result_arity:(Flambda_arity.cardinal result_arity) + ~result_arity:(Flambda_arity.cardinal_unarized result_arity) ~extra_args:[] apply_cont_args in { elt with apply_cont_args }) diff --git a/middle_end/flambda2/simplify/flow/flow_acc.mli b/middle_end/flambda2/simplify/flow/flow_acc.mli index 53cec19ac56..ee0ce5ca39d 100644 --- a/middle_end/flambda2/simplify/flow/flow_acc.mli +++ b/middle_end/flambda2/simplify/flow/flow_acc.mli @@ -97,7 +97,7 @@ val add_used_in_current_handler : Name_occurrences.t -> t -> t val add_apply_conts : result_cont:(Apply_cont_rewrite_id.t * Continuation.t) option -> exn_cont:Apply_cont_rewrite_id.t * Exn_continuation.t -> - result_arity:Flambda_arity.t -> + result_arity:[`Unarized] Flambda_arity.t -> t -> t diff --git a/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.ml b/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.ml index 9cccb4e32a2..c84b6fc554a 100644 --- a/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.ml +++ b/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.ml @@ -106,14 +106,15 @@ let speculative_inlining dacc ~apply ~function_type ~simplify_expr ~return_arity UE.add_function_return_or_exn_continuation (UE.create (DA.are_rebuilding_terms dacc)) (Exn_continuation.exn_handler exn_continuation) - (Flambda_arity.create [Flambda_kind.With_subkind.any_value]) + (Flambda_arity.create_singletons + [Flambda_kind.With_subkind.any_value]) in let uenv = match Apply.continuation apply with | Never_returns -> uenv | Return return_continuation -> UE.add_function_return_or_exn_continuation uenv return_continuation - return_arity + (Flambda_arity.unarize_t return_arity) in let uacc = UA.create ~flow_result ~compute_slot_offsets:false uenv dacc diff --git a/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.mli b/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.mli index 1cbaba44152..138118521a9 100644 --- a/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.mli +++ b/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.mli @@ -21,7 +21,7 @@ val make_decision : simplify_expr:Expr.t Simplify_common.expr_simplifier -> function_type:Flambda2_types.Function_type.t -> apply:Apply.t -> - return_arity:Flambda_arity.t -> + return_arity:_ Flambda_arity.t -> Call_site_inlining_decision_type.t val get_rec_info : diff --git a/middle_end/flambda2/simplify/simplify.ml b/middle_end/flambda2/simplify/simplify.ml index 2240b07a91c..4b00e04c3e2 100644 --- a/middle_end/flambda2/simplify/simplify.ml +++ b/middle_end/flambda2/simplify/simplify.ml @@ -42,7 +42,7 @@ let run ~cmx_loader ~round unit = let dacc = DA.create denv Continuation_uses_env.empty in let body, uacc = Simplify_expr.simplify_toplevel dacc (FU.body unit) ~return_continuation - ~return_arity:(Flambda_arity.create [K.With_subkind.any_value]) + ~return_arity:(Flambda_arity.create_singletons [K.With_subkind.any_value]) ~exn_continuation in let body = Rebuilt_expr.to_expr body (UA.are_rebuilding_terms uacc) in diff --git a/middle_end/flambda2/simplify/simplify_apply_expr.ml b/middle_end/flambda2/simplify/simplify_apply_expr.ml index 2e63b24089d..168e9b4e59c 100644 --- a/middle_end/flambda2/simplify/simplify_apply_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_expr.ml @@ -96,7 +96,8 @@ let simplify_direct_tuple_application ~simplify_expr dacc apply ~down_to_up = let dbg = Apply.dbg apply in let n = - Flambda_arity.cardinal (Code_metadata.params_arity callee's_code_metadata) + Flambda_arity.cardinal_unarized + (Code_metadata.params_arity callee's_code_metadata) in (* Split the tuple argument from other potential over application arguments *) let tuple, over_application_args = @@ -105,7 +106,7 @@ let simplify_direct_tuple_application ~simplify_expr dacc apply | _ -> Misc.fatal_errorf "Empty argument list for direct application" in let over_application_arity = - List.tl (Flambda_arity.to_list (Apply.args_arity apply)) + List.tl (Flambda_arity.unarize (Apply.args_arity apply)) in (* Create the list of variables and projections *) let vars_and_fields = @@ -119,7 +120,7 @@ let simplify_direct_tuple_application ~simplify_expr dacc apply let args_arity = (* The components of the tuple must always be of kind [Value] (in Lambda, [layout_field]). *) - Flambda_arity.create + Flambda_arity.create_singletons (List.init n (fun _ -> K.With_subkind.any_value) @ over_application_arity) in @@ -177,7 +178,9 @@ let rebuild_non_inlined_direct_full_application apply ~use_id ~exn_cont_use_id in uacc, RE.create_apply (UA.are_rebuilding_terms uacc) apply | Some use_id -> - EB.rewrite_fixed_arity_apply uacc ~use_id result_arity apply + EB.rewrite_fixed_arity_apply uacc ~use_id + (Flambda_arity.unarize_t result_arity) + apply in after_rebuild expr uacc @@ -252,7 +255,7 @@ let simplify_direct_full_application ~simplify_expr dacc apply function_type | Return apply_return_continuation, Ok result_types -> Result_types.pattern_match result_types ~f:(fun ~params ~results env_extension -> - if Flambda_arity.cardinal params_arity + if Flambda_arity.cardinal_unarized params_arity <> Bound_parameters.cardinal params then Misc.fatal_errorf @@ -260,7 +263,7 @@ let simplify_direct_full_application ~simplify_expr dacc apply function_type types structure:@ %a@ for application:@ %a" Flambda_arity.print params_arity Result_types.print result_types Apply.print apply; - if Flambda_arity.cardinal result_arity + if Flambda_arity.cardinal_unarized result_arity <> Bound_parameters.cardinal results then Misc.fatal_errorf @@ -286,7 +289,7 @@ let simplify_direct_full_application ~simplify_expr dacc apply function_type arg)) denv params args in - let result_arity = Flambda_arity.to_list result_arity in + let result_arity = Flambda_arity.unarize result_arity in let denv = List.fold_left2 (fun denv kind result -> @@ -338,9 +341,10 @@ 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 ~args_arity ~result_arity ~recursive ~down_to_up + ~coming_from_indirect ~(closure_alloc_mode_from_type : Alloc_mode.For_types.t) ~current_region - ~num_trailing_local_params = + ~num_trailing_local_non_unarized_params = (* Partial-applications are converted in full applications. Let's assume that [foo] takes 6 arguments. Then [foo a b c] gets transformed into: @@ -378,14 +382,18 @@ let simplify_direct_partial_application ~simplify_expr dacc apply Inlining_helpers.( inlined_attribute_on_partial_application_msg Unrolled)) | Default_inlined | Hint_inlined -> ()); - let arity = Flambda_arity.cardinal param_arity in - let args_arity = List.length args in - assert (arity > args_arity); - let applied_args, remaining_param_arity = + let num_non_unarized_params = Flambda_arity.num_params param_arity in + let num_non_unarized_args = Flambda_arity.num_params args_arity in + assert (num_non_unarized_params > num_non_unarized_args); + let remaining_param_arity = + Flambda_arity.partially_apply param_arity + ~num_non_unarized_params_provided:(Flambda_arity.num_params args_arity) + in + let applied_unarized_args, _ = Misc.Stdlib.List.map2_prefix (fun arg kind -> arg, kind) args - (Flambda_arity.to_list param_arity) + (Flambda_arity.unarize param_arity) in let wrapper_var = Variable.create "partial_app" in let compilation_unit = Compilation_unit.get_current_exn () in @@ -397,13 +405,17 @@ let simplify_direct_partial_application ~simplify_expr dacc apply (* 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 num_leading_heap_params = arity - num_trailing_local_params in - if args_arity <= num_leading_heap_params - then Alloc_mode.For_allocations.heap, num_trailing_local_params + let num_leading_heap_non_unarized_params = + num_non_unarized_params - num_trailing_local_non_unarized_params + in + if num_non_unarized_args <= num_leading_heap_non_unarized_params + then Alloc_mode.For_allocations.heap, num_trailing_local_non_unarized_params else - let num_supplied_local_args = args_arity - num_leading_heap_params in + let num_supplied_local_args = + num_non_unarized_args - num_leading_heap_non_unarized_params + in ( Alloc_mode.For_allocations.local ~region:current_region, - num_trailing_local_params - num_supplied_local_args ) + num_trailing_local_non_unarized_params - num_supplied_local_args ) in (match closure_alloc_mode_from_type with | Heap_or_local -> () @@ -443,7 +455,7 @@ let simplify_direct_partial_application ~simplify_expr dacc apply (fun kind -> let param = Variable.create "param" in Bound_parameter.create param kind) - remaining_param_arity + (Flambda_arity.unarize remaining_param_arity) |> Bound_parameters.create in let call_kind = @@ -494,8 +506,8 @@ let simplify_direct_partial_application ~simplify_expr dacc apply let applied_callee = applied_value (Apply.callee apply, K.With_subkind.any_value) in - let applied_args = List.map applied_value applied_args in - let applied_values = applied_callee :: applied_args in + let applied_unarized_args = List.map applied_value applied_unarized_args in + let applied_values = applied_callee :: applied_unarized_args in let my_closure = Variable.create "my_closure" in let my_region = Variable.create "my_region" in let my_depth = Variable.create "my_depth" in @@ -512,7 +524,8 @@ let simplify_direct_partial_application ~simplify_expr dacc apply in let callee = arg applied_callee in let args = - List.map arg applied_args @ Bound_parameters.simples remaining_params + List.map arg applied_unarized_args + @ Bound_parameters.simples remaining_params in let full_application = Apply.create ~callee ~continuation:(Return return_continuation) @@ -586,10 +599,12 @@ 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) - ~num_trailing_local_params ~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 + ~num_trailing_local_params + ~result_arity:(Flambda_arity.unarize_t 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: @@ -740,9 +755,9 @@ let simplify_direct_function_call ~simplify_expr dacc apply ~apply_alloc_mode ~current_region ~callee's_code_id ~callee's_code_metadata ~down_to_up else - let args = Apply.args apply in - let provided_num_args = List.length args in - let num_params = Flambda_arity.cardinal params_arity in + let args_arity = Apply.args_arity apply in + let num_params = Flambda_arity.num_params params_arity in + let provided_num_args = Flambda_arity.num_params args_arity in let result_arity_of_application = Apply.return_arity apply in if provided_num_args = num_params then ( @@ -757,7 +772,8 @@ let simplify_direct_function_call ~simplify_expr dacc apply present on the application expression, so all we can do is check that the function being overapplied returns kind Value. *) if not - (Flambda_arity.equal_ignoring_subkinds result_arity + (Flambda_arity.equal_ignoring_subkinds + (Flambda_arity.unarize_t result_arity) result_arity_of_application) then Misc.fatal_errorf @@ -771,7 +787,7 @@ let simplify_direct_function_call ~simplify_expr dacc apply else if provided_num_args > num_params then ( (* See comment above. *) - if not (Flambda_arity.is_singleton_value result_arity) + if not (Flambda_arity.is_one_param_of_kind_value result_arity) then Misc.fatal_errorf "Non-singleton-value return arity for overapplied OCaml function:@ \ @@ -783,7 +799,9 @@ let simplify_direct_function_call ~simplify_expr dacc apply else if provided_num_args > 0 && provided_num_args < num_params then ( (* See comment above. *) - if not (Flambda_arity.is_singleton_value result_arity_of_application) + if not + (Flambda_arity.is_one_param_of_kind_value + result_arity_of_application) then Misc.fatal_errorf "Non-singleton-value return arity for partially-applied OCaml \ @@ -791,9 +809,11 @@ 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 - ~num_trailing_local_params: + ~param_arity:params_arity ~args_arity + ~result_arity:(Flambda_arity.unarize_t result_arity) + ~recursive ~down_to_up ~coming_from_indirect + ~closure_alloc_mode_from_type ~current_region + ~num_trailing_local_non_unarized_params: (Code_metadata.num_trailing_local_params callee's_code_metadata)) else Misc.fatal_errorf @@ -808,7 +828,9 @@ let rebuild_function_call_where_callee's_type_unavailable apply call_kind |> Simplify_common.update_exn_continuation_extra_args uacc ~exn_cont_use_id in let uacc, expr = - EB.rewrite_fixed_arity_apply uacc ~use_id (Apply.return_arity apply) apply + EB.rewrite_fixed_arity_apply uacc ~use_id + (Flambda_arity.unarize_t (Apply.return_arity apply)) + apply in after_rebuild expr uacc @@ -958,7 +980,7 @@ let simplify_apply_shared dacc apply = "Argument kind %a from arity does not match kind from type %a for \ application:@ %a" K.print kind T.print arg_type Apply.print apply) - (Flambda_arity.to_list (Apply.args_arity apply)) + (Flambda_arity.unarize (Apply.args_arity apply)) arg_types; let inlining_state = Inlining_state.meet @@ -989,7 +1011,9 @@ let rebuild_method_call apply ~use_id ~exn_cont_use_id uacc ~after_rebuild = apply in let uacc, expr = - EB.rewrite_fixed_arity_apply uacc ~use_id (Apply.return_arity apply) apply + EB.rewrite_fixed_arity_apply uacc ~use_id + (Flambda_arity.unarize_t (Apply.return_arity apply)) + apply in after_rebuild expr uacc @@ -1049,7 +1073,9 @@ let rebuild_c_call apply ~use_id ~exn_cont_use_id ~return_arity uacc let uacc, expr = match use_id with | Some use_id -> - EB.rewrite_fixed_arity_apply uacc ~use_id return_arity apply + EB.rewrite_fixed_arity_apply uacc ~use_id + (Flambda_arity.unarize_t return_arity) + apply | None -> let uacc = UA.add_free_names uacc (Apply.free_names apply) diff --git a/middle_end/flambda2/simplify/simplify_common.ml b/middle_end/flambda2/simplify/simplify_common.ml index 5dcdc229159..48b52896f27 100644 --- a/middle_end/flambda2/simplify/simplify_common.ml +++ b/middle_end/flambda2/simplify/simplify_common.ml @@ -33,7 +33,7 @@ type simplify_toplevel = Downwards_acc.t -> Expr.t -> return_continuation:Continuation.t -> - return_arity:Flambda_arity.t -> + return_arity:[`Unarized] Flambda_arity.t -> exn_continuation:Continuation.t -> Rebuilt_expr.t * Upwards_acc.t @@ -41,7 +41,7 @@ type simplify_function_body = Downwards_acc.t -> Expr.t -> return_continuation:Continuation.t -> - return_arity:Flambda_arity.t -> + return_arity:[`Unarized] Flambda_arity.t -> exn_continuation:Continuation.t -> loopify_state:Loopify_state.t -> params:Bound_parameters.t -> @@ -96,15 +96,26 @@ let split_direct_over_application apply let callee's_params_arity = Code_metadata.params_arity callee's_code_metadata in - let arity = Flambda_arity.cardinal callee's_params_arity in + let num_non_unarized_params = + Flambda_arity.num_params callee's_params_arity + in + let args_arity = Apply.args_arity apply in + let num_non_unarized_args = Flambda_arity.num_params args_arity in + assert (num_non_unarized_params < num_non_unarized_args); let args = Apply.args apply in - assert (arity < List.length args); - let first_args, remaining_args = Misc.Stdlib.List.split_at arity args in - let _, remaining_arity = - Misc.Stdlib.List.split_at arity - (Apply.args_arity apply |> Flambda_arity.to_list) + let first_args, remaining_args = + Misc.Stdlib.List.split_at + (Flambda_arity.cardinal_unarized callee's_params_arity) + args + in + let remaining_arity = + Flambda_arity.partially_apply args_arity + ~num_non_unarized_params_provided:num_non_unarized_params in - assert (List.compare_lengths remaining_args remaining_arity = 0); + assert ( + List.compare_length_with remaining_args + (Flambda_arity.cardinal_unarized remaining_arity) + = 0); let func_var = Variable.create "full_apply" in let contains_no_escaping_local_allocs = Code_metadata.contains_no_escaping_local_allocs callee's_code_metadata @@ -141,8 +152,7 @@ let split_direct_over_application apply in Apply.create ~callee:(Simple.var func_var) ~continuation (Apply.exn_continuation apply) - ~args:remaining_args - ~args_arity:(Flambda_arity.create remaining_arity) + ~args:remaining_args ~args_arity:remaining_arity ~return_arity:(Apply.return_arity apply) ~call_kind: (Call_kind.indirect_function_call_unknown_arity apply_alloc_mode) @@ -170,7 +180,7 @@ let split_direct_over_application apply List.mapi (fun i kind -> BP.create (Variable.create ("result" ^ string_of_int i)) kind) - (Flambda_arity.to_list (Apply.return_arity apply)) + (Flambda_arity.unarize (Apply.return_arity apply)) in let call_return_continuation, call_return_continuation_free_names = match Apply.continuation apply with @@ -231,7 +241,9 @@ let split_direct_over_application apply ~continuation:(Return after_full_application) (Apply.exn_continuation apply) ~args:first_args ~args_arity:callee's_params_arity - ~return_arity:(Code_metadata.result_arity callee's_code_metadata) + ~return_arity: + (Flambda_arity.unarize_t + (Code_metadata.result_arity callee's_code_metadata)) ~call_kind:(Call_kind.direct_function_call callee's_code_id alloc_mode) (Apply.dbg apply) ~inlined:(Apply.inlined apply) ~inlining_state:(Apply.inlining_state apply) diff --git a/middle_end/flambda2/simplify/simplify_common.mli b/middle_end/flambda2/simplify/simplify_common.mli index 0470bb1c6ec..a9ed859c235 100644 --- a/middle_end/flambda2/simplify/simplify_common.mli +++ b/middle_end/flambda2/simplify/simplify_common.mli @@ -76,7 +76,7 @@ type simplify_toplevel = Downwards_acc.t -> Expr.t -> return_continuation:Continuation.t -> - return_arity:Flambda_arity.t -> + return_arity:[`Unarized] Flambda_arity.t -> exn_continuation:Continuation.t -> Rebuilt_expr.t * Upwards_acc.t @@ -84,7 +84,7 @@ type simplify_function_body = Downwards_acc.t -> Expr.t -> return_continuation:Continuation.t -> - return_arity:Flambda_arity.t -> + return_arity:[`Unarized] Flambda_arity.t -> exn_continuation:Continuation.t -> loopify_state:Loopify_state.t -> params:Bound_parameters.t -> diff --git a/middle_end/flambda2/simplify/simplify_expr.ml b/middle_end/flambda2/simplify/simplify_expr.ml index b833a07ad78..e7b186df810 100644 --- a/middle_end/flambda2/simplify/simplify_expr.ml +++ b/middle_end/flambda2/simplify/simplify_expr.ml @@ -66,7 +66,7 @@ let simplify_toplevel_common dacc simplify ~params ~implicit_params in let uenv = UE.add_function_return_or_exn_continuation uenv exn_continuation - (Flambda_arity.create [K.With_subkind.any_value]) + (Flambda_arity.create_singletons [K.With_subkind.any_value]) in let uacc = UA.create ~flow_result ~compute_slot_offsets:true uenv dacc diff --git a/middle_end/flambda2/simplify/simplify_set_of_closures.ml b/middle_end/flambda2/simplify/simplify_set_of_closures.ml index 99ddb1ebe96..8697bf9405b 100644 --- a/middle_end/flambda2/simplify/simplify_set_of_closures.ml +++ b/middle_end/flambda2/simplify/simplify_set_of_closures.ml @@ -171,7 +171,8 @@ let simplify_function_body context ~outer_dacc function_slot_opt assert (not (DE.at_unit_toplevel (DA.denv dacc))); match C.simplify_function_body context dacc body ~return_continuation - ~exn_continuation ~return_arity:(Code.result_arity code) + ~exn_continuation + ~return_arity:(Code.result_arity code |> Flambda_arity.unarize_t) ~implicit_params: (Bound_parameters.create [ Bound_parameter.create my_closure @@ -342,7 +343,7 @@ let simplify_function0 context ~outer_dacc function_slot_opt code_id code BP.create (Variable.create ("result" ^ string_of_int i)) kind_with_subkind) - (Flambda_arity.to_list result_arity) + (Flambda_arity.unarize result_arity) |> Bound_parameters.create in let { params; @@ -721,7 +722,7 @@ let simplify_non_lifted_set_of_closures0 dacc bound_vars ~closure_bound_vars Cost_metrics. { cost_metrics = Code_metadata.cost_metrics code_metadata; params_arity = - Flambda_arity.cardinal (Code_metadata.params_arity code_metadata) + Flambda_arity.num_params (Code_metadata.params_arity code_metadata) } in Simplified_named.create_with_known_free_names ~find_code_characteristics diff --git a/middle_end/flambda2/simplify/simplify_switch_expr.ml b/middle_end/flambda2/simplify/simplify_switch_expr.ml index 0ef1827bd8d..6d19da1c464 100644 --- a/middle_end/flambda2/simplify/simplify_switch_expr.ml +++ b/middle_end/flambda2/simplify/simplify_switch_expr.ml @@ -104,9 +104,9 @@ let rebuild_arm uacc arm (action, use_id, arity, env_at_use) | Non_inlinable_zero_arity { handler = Known handler } -> check_handler ~handler ~action | Non_inlinable_zero_arity { handler = Unknown } -> Some action - | Invalid _ -> None - | Non_inlinable_non_zero_arity _ - | Toplevel_or_function_return_or_exn_continuation _ -> + | Invalid _ | Toplevel_or_function_return_or_exn_continuation _ -> + None + | Non_inlinable_non_zero_arity _ -> Misc.fatal_errorf "Inconsistency for %a between [Apply_cont.is_goto] and \ continuation environment in [UA]:@ %a" @@ -377,7 +377,7 @@ let simplify_arm ~typing_env_at_use ~scrutinee_ty arm action (arms, dacc) = let arity = arg_types |> List.map (fun ty -> K.With_subkind.anything (T.kind ty)) - |> Flambda_arity.create + |> Flambda_arity.create_singletons in let action = Apply_cont.update_args action ~args in let dacc = diff --git a/middle_end/flambda2/simplify_shared/inlining_helpers.ml b/middle_end/flambda2/simplify_shared/inlining_helpers.ml index a1369782303..0f31c9168c7 100644 --- a/middle_end/flambda2/simplify_shared/inlining_helpers.ml +++ b/middle_end/flambda2/simplify_shared/inlining_helpers.ml @@ -72,7 +72,7 @@ let wrap_inlined_body_for_exn_extra_args acc ~extra_args ~apply_exn_continuation let kinded_params = List.map (fun k -> Bound_parameter.create (Variable.create "wrapper_return") k) - (Flambda_arity.to_list result_arity) + (Flambda_arity.unarize result_arity) in let trap_action = Trap_action.Pop { exn_handler = wrapper; raise_kind = None } diff --git a/middle_end/flambda2/simplify_shared/inlining_helpers.mli b/middle_end/flambda2/simplify_shared/inlining_helpers.mli index c1540a75ed5..8f97825168b 100644 --- a/middle_end/flambda2/simplify_shared/inlining_helpers.mli +++ b/middle_end/flambda2/simplify_shared/inlining_helpers.mli @@ -46,7 +46,7 @@ val wrap_inlined_body_for_exn_extra_args : extra_args:(Simple.t * Flambda_kind.With_subkind.t) list -> apply_exn_continuation:Exn_continuation.t -> apply_return_continuation:Flambda.Apply.Result_continuation.t -> - result_arity:Flambda_arity.t -> + result_arity:[`Unarized | `Complex] Flambda_arity.t -> make_inlined_body: ('acc -> apply_exn_continuation:Continuation.t -> diff --git a/middle_end/flambda2/simplify_shared/slot_offsets.ml b/middle_end/flambda2/simplify_shared/slot_offsets.ml index f516398b4e3..6d87dd3d4b8 100644 --- a/middle_end/flambda2/simplify_shared/slot_offsets.ml +++ b/middle_end/flambda2/simplify_shared/slot_offsets.ml @@ -727,7 +727,7 @@ end = struct let module CM = Code_metadata in let is_tupled = CM.is_tupled code_metadata in let params_arity = CM.params_arity code_metadata in - let arity = Flambda_arity.cardinal params_arity in + let arity = Flambda_arity.num_params params_arity in if (arity = 0 || arity = 1) && not is_tupled then 2 else 3 in let s = create_slot ~size (Function_slot function_slot) Unassigned in diff --git a/middle_end/flambda2/terms/apply_expr.ml b/middle_end/flambda2/terms/apply_expr.ml index 8e655488b0e..09fd18e461f 100644 --- a/middle_end/flambda2/terms/apply_expr.ml +++ b/middle_end/flambda2/terms/apply_expr.ml @@ -73,8 +73,8 @@ type t = continuation : Result_continuation.t; exn_continuation : Exn_continuation.t; args : Simple.t list; - args_arity : Flambda_arity.t; - return_arity : Flambda_arity.t; + args_arity : [`Unarized | `Complex] Flambda_arity.t; + return_arity : [`Unarized] Flambda_arity.t; call_kind : Call_kind.t; dbg : Debuginfo.t; inlined : Inlined_attribute.t; @@ -162,12 +162,12 @@ let invariant "For [C_call] applications the callee must be directly specified as a \ [Symbol]:@ %a" print t; - match Flambda_arity.to_list return_arity with + match Flambda_arity.unarize return_arity with | [] | [_] -> () | _ :: _ :: _ -> Misc.fatal_errorf "Illegal return arity for C call:@ %a" Flambda_arity.print return_arity)); - if List.compare_lengths args (Flambda_arity.to_list args_arity) <> 0 + if List.compare_lengths args (Flambda_arity.unarize args_arity) <> 0 then Misc.fatal_errorf "Length of argument and arity lists disagree in [Apply]:@ %a" print t diff --git a/middle_end/flambda2/terms/apply_expr.mli b/middle_end/flambda2/terms/apply_expr.mli index fc9777c324b..c6469feecde 100644 --- a/middle_end/flambda2/terms/apply_expr.mli +++ b/middle_end/flambda2/terms/apply_expr.mli @@ -51,8 +51,8 @@ val create : continuation:Result_continuation.t -> Exn_continuation.t -> args:Simple.t list -> - args_arity:Flambda_arity.t -> - return_arity:Flambda_arity.t -> + args_arity:[`Unarized | `Complex] Flambda_arity.t -> + return_arity:[`Unarized] Flambda_arity.t -> call_kind:Call_kind.t -> Debuginfo.t -> inlined:Inlined_attribute.t -> @@ -77,10 +77,10 @@ val callee : t -> Simple.t val args : t -> Simple.t list (** The arity of the arguments being applied. *) -val args_arity : t -> Flambda_arity.t +val args_arity : t -> [`Unarized | `Complex] Flambda_arity.t (** The arity of the result(s) of the application. *) -val return_arity : t -> Flambda_arity.t +val return_arity : t -> [`Unarized] Flambda_arity.t (** Information about what kind of call is involved (direct function call, method call, etc). *) @@ -110,7 +110,8 @@ val with_continuations : t -> Result_continuation.t -> Exn_continuation.t -> t val with_exn_continuation : t -> Exn_continuation.t -> t (** Change the arguments of an application *) -val with_args : t -> Simple.t list -> args_arity:Flambda_arity.t -> t +val with_args : + t -> Simple.t list -> args_arity:[`Unarized | `Complex] Flambda_arity.t -> t (** Change the call kind of an application. *) val with_call_kind : t -> Call_kind.t -> t diff --git a/middle_end/flambda2/terms/code_metadata.ml b/middle_end/flambda2/terms/code_metadata.ml index 8a8dcab3f14..4a44b597e4e 100644 --- a/middle_end/flambda2/terms/code_metadata.ml +++ b/middle_end/flambda2/terms/code_metadata.ml @@ -17,9 +17,9 @@ type t = { code_id : Code_id.t; newer_version_of : Code_id.t option; - params_arity : Flambda_arity.t; + params_arity : [`Unarized | `Complex] Flambda_arity.t; num_trailing_local_params : int; - result_arity : Flambda_arity.t; + result_arity : [`Unarized | `Complex] Flambda_arity.t; result_types : Result_types.t Or_unknown_or_bottom.t; contains_no_escaping_local_allocs : bool; stub : bool; @@ -58,7 +58,7 @@ module Code_metadata_accessors (X : Metadata_view_type) = struct let num_leading_heap_params t = let { params_arity; num_trailing_local_params; _ } = metadata t in - let n = Flambda_arity.cardinal params_arity - num_trailing_local_params in + let n = Flambda_arity.num_params params_arity - num_trailing_local_params in assert (n >= 0); (* see [create] *) n @@ -124,9 +124,9 @@ include Code_metadata_accessors [@inlined hint] (Metadata_view) type 'a create_type = Code_id.t -> newer_version_of:Code_id.t option -> - params_arity:Flambda_arity.t -> + params_arity:[`Unarized | `Complex] Flambda_arity.t -> num_trailing_local_params:int -> - result_arity:Flambda_arity.t -> + result_arity:[`Unarized | `Complex] Flambda_arity.t -> result_types:Result_types.t Or_unknown_or_bottom.t -> contains_no_escaping_local_allocs:bool -> stub:bool -> @@ -161,7 +161,7 @@ let createk k code_id ~newer_version_of ~params_arity ~num_trailing_local_params | true, (Always_inline | Unroll _) -> Misc.fatal_error "Stubs may not be annotated as [Always_inline] or [Unroll]"); if num_trailing_local_params < 0 - || num_trailing_local_params > Flambda_arity.cardinal params_arity + || num_trailing_local_params > Flambda_arity.cardinal_unarized params_arity then Misc.fatal_errorf "Illegal num_trailing_local_params=%d for params arity: %a" @@ -270,22 +270,22 @@ let [@ocamlformat "disable"] print ppf (if not is_a_functor then Flambda_colours.elide else C.none) is_a_functor Flambda_colours.pop - (if Flambda_arity.is_singleton_value params_arity + (if Flambda_arity.is_one_param_of_kind_value params_arity then Flambda_colours.elide else Flambda_colours.none) Flambda_colours.pop Flambda_arity.print params_arity - (if Flambda_arity.is_singleton_value params_arity + (if Flambda_arity.is_one_param_of_kind_value params_arity then Flambda_colours.elide else Flambda_colours.none) Flambda_colours.pop num_trailing_local_params - (if Flambda_arity.is_singleton_value result_arity + (if Flambda_arity.is_one_param_of_kind_value result_arity then Flambda_colours.elide else Flambda_colours.none) Flambda_colours.pop Flambda_arity.print result_arity - (if Flambda_arity.is_singleton_value result_arity + (if Flambda_arity.is_one_param_of_kind_value result_arity then Flambda_colours.elide else Flambda_colours.none) Flambda_colours.pop diff --git a/middle_end/flambda2/terms/code_metadata.mli b/middle_end/flambda2/terms/code_metadata.mli index 916657b1ab3..d3f5aceb9be 100644 --- a/middle_end/flambda2/terms/code_metadata.mli +++ b/middle_end/flambda2/terms/code_metadata.mli @@ -31,13 +31,14 @@ module type Code_metadata_accessors_result_type = sig val newer_version_of : 'a t -> Code_id.t option - val params_arity : 'a t -> Flambda_arity.t + val params_arity : 'a t -> [`Unarized | `Complex] Flambda_arity.t val num_leading_heap_params : 'a t -> int + (* XXX rename to num_trailing_local_non_unarized_params *) val num_trailing_local_params : 'a t -> int - val result_arity : 'a t -> Flambda_arity.t + val result_arity : 'a t -> [`Unarized | `Complex] Flambda_arity.t val result_types : 'a t -> Result_types.t Or_unknown_or_bottom.t @@ -82,9 +83,9 @@ include Code_metadata_accessors_result_type with type 'a t := t type 'a create_type = Code_id.t -> newer_version_of:Code_id.t option -> - params_arity:Flambda_arity.t -> + params_arity:[`Unarized | `Complex] Flambda_arity.t -> num_trailing_local_params:int -> - result_arity:Flambda_arity.t -> + result_arity:[`Unarized | `Complex] Flambda_arity.t -> result_types:Result_types.t Or_unknown_or_bottom.t -> contains_no_escaping_local_allocs:bool -> stub:bool -> diff --git a/middle_end/flambda2/terms/exn_continuation.ml b/middle_end/flambda2/terms/exn_continuation.ml index 1283eb74b51..e41d927ec34 100644 --- a/middle_end/flambda2/terms/exn_continuation.ml +++ b/middle_end/flambda2/terms/exn_continuation.ml @@ -108,7 +108,7 @@ let arity t = let exn_bucket_kind = Flambda_kind.With_subkind.create Flambda_kind.value Anything in - Flambda_arity.create (exn_bucket_kind :: extra_args) + Flambda_arity.create_singletons (exn_bucket_kind :: extra_args) let with_exn_handler t exn_handler = { t with exn_handler } diff --git a/middle_end/flambda2/terms/exn_continuation.mli b/middle_end/flambda2/terms/exn_continuation.mli index 8de74d2bc6d..911a699dd18 100644 --- a/middle_end/flambda2/terms/exn_continuation.mli +++ b/middle_end/flambda2/terms/exn_continuation.mli @@ -46,7 +46,7 @@ val extra_args : t -> (Simple.t * Flambda_kind.With_subkind.t) list (** The arity of the given exception continuation, taking into account both the exception bucket argument and any [extra_args]. *) -val arity : t -> Flambda_arity.t +val arity : t -> [> `Unarized] Flambda_arity.t val with_exn_handler : t -> Continuation.t -> t diff --git a/middle_end/flambda2/to_cmm/to_cmm_env.ml b/middle_end/flambda2/to_cmm/to_cmm_env.ml index 467e18c9970..46b694da2e1 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_env.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_env.ml @@ -360,7 +360,7 @@ let add_exn_handler env k arity = let env = { env with exn_handlers = Continuation.Set.add k env.exn_handlers } in - match Flambda_arity.to_list arity with + match Flambda_arity.unarize arity with | [] -> Misc.fatal_error "Exception handlers must have at least one parameter" | [_] -> env, [] | _ :: extra_args -> diff --git a/middle_end/flambda2/to_cmm/to_cmm_env.mli b/middle_end/flambda2/to_cmm/to_cmm_env.mli index b84e60fafb0..34cce6d8c43 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_env.mli +++ b/middle_end/flambda2/to_cmm/to_cmm_env.mli @@ -325,7 +325,7 @@ val add_inline_cont : val add_exn_handler : t -> Continuation.t -> - Flambda_arity.t -> + [`Unarized] Flambda_arity.t -> t * (Backend_var.t * Flambda_kind.With_subkind.t) list (** Return whether the given continuation has been registered as an exception diff --git a/middle_end/flambda2/to_cmm/to_cmm_expr.ml b/middle_end/flambda2/to_cmm/to_cmm_expr.ml index 055762f9c55..db075f5f2c4 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_expr.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_expr.ml @@ -93,9 +93,15 @@ let translate_apply0 ~dbg_with_inlined:dbg env res apply = Lambda.Rc_normal | Nontail -> Lambda.Rc_nontail in - let args_arity = Apply.args_arity apply |> Flambda_arity.to_list in + let args_arity = + Apply.args_arity apply |> Flambda_arity.unarize_per_parameter + in let return_arity = Apply.return_arity apply in - let args_ty = List.map C.extended_machtype_of_kind args_arity in + let args_ty = + List.map + (fun kinds -> List.map C.extended_machtype_of_kind kinds |> Array.concat) + args_arity + in let return_ty = C.extended_machtype_of_return_arity return_arity in match Apply.call_kind apply with | Function { function_call = Direct code_id; alloc_mode = _ } -> ( @@ -164,7 +170,7 @@ let translate_apply0 ~dbg_with_inlined:dbg env res apply = in let returns = Apply.returns apply in let wrap = - match Flambda_arity.to_list return_arity with + match Flambda_arity.unarize return_arity with (* Returned int32 values need to be sign_extended because it's not clear whether C code that returns an int32 returns one that is sign extended or not. There is no need to wrap other return arities. Note that @@ -184,7 +190,7 @@ let translate_apply0 ~dbg_with_inlined:dbg env res apply = in let ty_args = List.map C.exttype_of_kind - (Flambda_arity.to_list (Apply.args_arity apply) + (Flambda_arity.unarize (Apply.args_arity apply) |> List.map K.With_subkind.kind) in ( wrap dbg diff --git a/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml b/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml index c5ebc146ca2..41f01c2e865 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml @@ -42,10 +42,14 @@ let get_func_decl_params_arity t code_id = cmm_helpers.ml. *) let params_ty = List.map - (fun k -> - C.extended_machtype_of_kind k - |> C.Extended_machtype.change_tagged_int_to_val) - (Flambda_arity.to_list (Code_metadata.params_arity info)) + (fun ks -> + List.map + (fun k -> + C.extended_machtype_of_kind k + |> C.Extended_machtype.change_tagged_int_to_val) + ks + |> Array.concat) + (Flambda_arity.unarize_per_parameter (Code_metadata.params_arity info)) in let result_machtype = C.extended_machtype_of_return_arity (Code_metadata.result_arity info) diff --git a/middle_end/flambda2/to_cmm/to_cmm_shared.ml b/middle_end/flambda2/to_cmm/to_cmm_shared.ml index 30714ed2f73..e20f8496a4d 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_shared.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_shared.ml @@ -250,10 +250,11 @@ let make_update env res dbg kind ~symbol var ~index ~prev_updates = in env, res, Some update -let check_arity arity args = Flambda_arity.cardinal arity = List.length args +let check_arity arity args = + Flambda_arity.cardinal_unarized arity = List.length args let extended_machtype_of_return_arity arity = - match Flambda_arity.to_list arity with + match Flambda_arity.unarize arity with | [] -> (* Functions that never return have arity 0. In that case, we use the most restrictive machtype to ensure that the return value of the function is diff --git a/middle_end/flambda2/to_cmm/to_cmm_shared.mli b/middle_end/flambda2/to_cmm/to_cmm_shared.mli index 431849c3367..6cce26b17f3 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_shared.mli +++ b/middle_end/flambda2/to_cmm/to_cmm_shared.mli @@ -101,7 +101,7 @@ val make_update : prev_updates:To_cmm_env.expr_with_info option -> To_cmm_env.t * To_cmm_result.t * To_cmm_env.expr_with_info option -val check_arity : Flambda_arity.t -> _ list -> bool +val check_arity : _ Flambda_arity.t -> _ list -> bool val extended_machtype_of_return_arity : - Flambda_arity.t -> Cmm_helpers.Extended_machtype.t + _ Flambda_arity.t -> Cmm_helpers.Extended_machtype.t diff --git a/middle_end/flambda2/types/flambda2_types.mli b/middle_end/flambda2/types/flambda2_types.mli index 783e4096d5a..19fcd258b5a 100644 --- a/middle_end/flambda2/types/flambda2_types.mli +++ b/middle_end/flambda2/types/flambda2_types.mli @@ -23,7 +23,7 @@ type flambda_type = t val print : Format.formatter -> t -> unit -val arity_of_list : t list -> Flambda_arity.t +val arity_of_list : t list -> [`Unarized] Flambda_arity.t val apply_renaming : t -> Renaming.t -> t @@ -515,10 +515,10 @@ val kind : t -> Flambda_kind.t val get_alias_exn : t -> Simple.t (** For each of the kinds in an arity, create an "unknown" type. *) -val unknown_types_from_arity : Flambda_arity.t -> t list +val unknown_types_from_arity : _ Flambda_arity.t -> t list (** For each of the kinds in an arity, create an "bottom" type. *) -val bottom_types_from_arity : Flambda_arity.t -> t list +val bottom_types_from_arity : _ Flambda_arity.t -> t list (** Whether the given type says that a term of that type can never be constructed (in other words, it is [Invalid]). *) diff --git a/middle_end/flambda2/types/grammar/more_type_creators.ml b/middle_end/flambda2/types/grammar/more_type_creators.ml index e5ba181c90d..664bd506f89 100644 --- a/middle_end/flambda2/types/grammar/more_type_creators.ml +++ b/middle_end/flambda2/types/grammar/more_type_creators.ml @@ -275,7 +275,7 @@ let check_equation name ty = Name.print name TG.print ty let arity_of_list ts = - Flambda_arity.create + Flambda_arity.create_singletons (List.map (fun ty -> Flambda_kind.With_subkind.anything (TG.kind ty)) ts) let rec unknown_with_subkind ?(alloc_mode = Alloc_mode.For_types.unknown ()) @@ -328,7 +328,7 @@ let rec unknown_with_subkind ?(alloc_mode = Alloc_mode.For_types.unknown ()) let bottom_with_subkind kind = bottom (Flambda_kind.With_subkind.kind kind) let unknown_types_from_arity arity = - List.map unknown_with_subkind (Flambda_arity.to_list arity) + List.map (unknown_with_subkind ?alloc_mode:None) (Flambda_arity.unarize arity) let bottom_types_from_arity arity = - List.map bottom_with_subkind (Flambda_arity.to_list arity) + List.map bottom_with_subkind (Flambda_arity.unarize arity) diff --git a/middle_end/flambda2/types/grammar/more_type_creators.mli b/middle_end/flambda2/types/grammar/more_type_creators.mli index 46e6df57046..fc05adaa47c 100644 --- a/middle_end/flambda2/types/grammar/more_type_creators.mli +++ b/middle_end/flambda2/types/grammar/more_type_creators.mli @@ -141,7 +141,7 @@ val is_alias_of_name : Type_grammar.t -> Name.t -> bool val check_equation : Name.t -> Type_grammar.t -> unit -val arity_of_list : Type_grammar.t list -> Flambda_arity.t +val arity_of_list : Type_grammar.t list -> [`Unarized] Flambda_arity.t val unknown_with_subkind : ?alloc_mode:Alloc_mode.For_types.t -> @@ -149,7 +149,7 @@ val unknown_with_subkind : Type_grammar.t (** For each of the kinds in an arity, create an "unknown" type. *) -val unknown_types_from_arity : Flambda_arity.t -> Type_grammar.t list +val unknown_types_from_arity : _ Flambda_arity.t -> Type_grammar.t list (** For each of the kinds in an arity, create an "bottom" type. *) -val bottom_types_from_arity : Flambda_arity.t -> Type_grammar.t list +val bottom_types_from_arity : _ Flambda_arity.t -> Type_grammar.t list diff --git a/middle_end/flambda2/ui/flambda_colours.ml b/middle_end/flambda2/ui/flambda_colours.ml index d4f206afac2..c40731f71ce 100644 --- a/middle_end/flambda2/ui/flambda_colours.ml +++ b/middle_end/flambda2/ui/flambda_colours.ml @@ -102,6 +102,8 @@ let prim_neither ppf = push ~fg:130 ppf let naked_number ppf = push ~fg:70 ppf +let unboxed_product ppf = push ~fg:198 ppf + let tagged_immediate ppf = push ~fg:70 ppf let constructor ppf = push ~fg:69 ppf diff --git a/middle_end/flambda2/ui/flambda_colours.mli b/middle_end/flambda2/ui/flambda_colours.mli index 200bb0eae61..367fcc4b321 100644 --- a/middle_end/flambda2/ui/flambda_colours.mli +++ b/middle_end/flambda2/ui/flambda_colours.mli @@ -92,4 +92,6 @@ val each_file : directive val lambda : directive +val unboxed_product : directive + val without_colours : f:(unit -> 'a) -> 'a diff --git a/middle_end/internal_variable_names.ml b/middle_end/internal_variable_names.ml index 4fb6290a49b..536c9a627ed 100644 --- a/middle_end/internal_variable_names.ml +++ b/middle_end/internal_variable_names.ml @@ -314,6 +314,10 @@ let punbox_int = "Punbox_int" let pbox_int = "Pbox_int" let punbox_int_arg = "Punbox_int_arg" let pbox_int_arg = "Pbox_int_arg" +let pmake_unboxed_product = "Pmake_unboxed_product" +let punboxed_product_field = "Punboxed_product_field" +let pmake_unboxed_product_arg = "Pmake_unboxed_product_arg" +let punboxed_product_field_arg = "Punboxed_product_field_arg" let anon_fn_with_loc (sloc: Lambda.scoped_location) = let loc = Debuginfo.Scoped_location.to_location sloc in @@ -439,6 +443,8 @@ let of_primitive : Lambda.primitive -> string = function | Pbox_int _ -> pbox_int | Parray_of_iarray -> parray_of_iarray | Parray_to_iarray -> parray_to_iarray + | Pmake_unboxed_product _ -> pmake_unboxed_product + | Punboxed_product_field _ -> punboxed_product_field let of_primitive_arg : Lambda.primitive -> string = function | Pbytes_of_string -> pbytes_of_string_arg @@ -553,3 +559,5 @@ let of_primitive_arg : Lambda.primitive -> string = function | Pbox_int _ -> pbox_int_arg | Parray_of_iarray -> parray_of_iarray_arg | Parray_to_iarray -> parray_to_iarray_arg + | Pmake_unboxed_product _ -> pmake_unboxed_product_arg + | Punboxed_product_field _ -> punboxed_product_field_arg diff --git a/middle_end/printclambda.ml b/middle_end/printclambda.ml index 5978905e8dd..6017d6a981c 100644 --- a/middle_end/printclambda.ml +++ b/middle_end/printclambda.ml @@ -60,6 +60,7 @@ let layout (layout : Lambda.layout) = | Punboxed_int Pint32 -> ":unboxed_int32" | Punboxed_int Pint64 -> ":unboxed_int64" | Punboxed_int Pnativeint -> ":unboxed_nativeint" + | Punboxed_product _ -> Misc.fatal_error "TODO" let rec structured_constant ppf = function | Uconst_float x -> fprintf ppf "%F" x diff --git a/ocaml/asmcomp/cmm_helpers.ml b/ocaml/asmcomp/cmm_helpers.ml index 9e04285a702..3ce8e6cdb22 100644 --- a/ocaml/asmcomp/cmm_helpers.ml +++ b/ocaml/asmcomp/cmm_helpers.ml @@ -3280,6 +3280,6 @@ let kind_of_layout (layout : Lambda.layout) = | Pvalue Pfloatval -> Boxed_float | Pvalue (Pboxedintval bi) -> Boxed_integer bi | Pvalue (Pgenval | Pintval | Pvariant _ | Parrayval _) - | Ptop | Pbottom | Punboxed_float | Punboxed_int _ -> Any + | Ptop | Pbottom | Punboxed_float | Punboxed_int _ | Punboxed_product _ -> Any let make_tuple l = match l with [e] -> e | _ -> Ctuple l diff --git a/ocaml/asmcomp/cmmgen.ml b/ocaml/asmcomp/cmmgen.ml index 084c37111a7..d14c44fefdb 100644 --- a/ocaml/asmcomp/cmmgen.ml +++ b/ocaml/asmcomp/cmmgen.ml @@ -124,6 +124,7 @@ let get_field env layout ptr n dbg = | Pvalue Pintval | Punboxed_int _ -> Word_int | Pvalue _ -> Word_val | Punboxed_float -> Double + | Punboxed_product _ -> Misc.fatal_error "TBD" | Ptop -> Misc.fatal_errorf "get_field with Ptop: %a" Debuginfo.print_compact dbg | Pbottom -> @@ -1291,6 +1292,7 @@ and transl_let env str (layout : Lambda.layout) id exp transl_body = end | Pvalue kind -> transl_let_value env str kind id exp transl_body + | Punboxed_product _ -> Misc.fatal_error "TBD" and make_catch (kind : Cmm.kind_for_unboxing) ncatch body handler dbg = match body with | Cexit (nexit,[]) when nexit=ncatch -> handler diff --git a/ocaml/bytecomp/bytegen.ml b/ocaml/bytecomp/bytegen.ml index d36b24b4ac2..1685e4b2bb1 100644 --- a/ocaml/bytecomp/bytegen.ml +++ b/ocaml/bytecomp/bytegen.ml @@ -119,6 +119,7 @@ let preserve_tailcall_for_prim = function | Pmakeblock _ | Pmakefloatblock _ | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ + | Pmake_unboxed_product _ | Punboxed_product_field _ | Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat @@ -536,6 +537,7 @@ let comp_primitive p args = | Pmakefloatblock _ | Pprobe_is_enabled _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ + | Pmake_unboxed_product _ | Punboxed_product_field _ -> fatal_error "Bytegen.comp_primitive" diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index 87aefc0a7ab..0f38cb44e5b 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/lambda/lambda.ml @@ -147,6 +147,9 @@ type primitive = | Pfloatfield of int * field_read_semantics * alloc_mode | Psetfloatfield of int * initialization_or_assignment | Pduprecord of Types.record_representation * int + (* Unboxed products *) + | Pmake_unboxed_product of layout list + | Punboxed_product_field of int * layout list (* Force lazy values *) (* External call *) | Pccall of Primitive.description @@ -266,6 +269,7 @@ and layout = | Pvalue of value_kind | Punboxed_float | Punboxed_int of boxed_integer + | Punboxed_product of layout list | Pbottom and block_shape = @@ -334,7 +338,7 @@ let equal_layout x y = | Pbottom, Pbottom -> true | _, _ -> false -let compatible_layout x y = +let rec compatible_layout x y = match x, y with | Pbottom, _ | _, Pbottom -> true @@ -342,9 +346,13 @@ let compatible_layout x y = | Punboxed_float, Punboxed_float -> true | Punboxed_int bi1, Punboxed_int bi2 -> equal_boxed_integer bi1 bi2 + | Punboxed_product layouts1, Punboxed_product layouts2 -> + List.compare_lengths layouts1 layouts2 = 0 + && List.for_all2 compatible_layout layouts1 layouts2 | Ptop, Ptop -> true | Ptop, _ | _, Ptop -> false - | (Pvalue _ | Punboxed_float | Punboxed_int _), _ -> false + | (Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_product _), _ -> + false let must_be_value layout = match layout with @@ -633,6 +641,7 @@ let layout_lazy = Pvalue Pgenval let layout_lazy_contents = Pvalue Pgenval let layout_any_value = Pvalue Pgenval let layout_letrec = layout_any_value +let layout_unboxed_product layouts = Punboxed_product layouts (* CR ncourant: use [Ptop] or remove this as soon as possible. *) let layout_top = layout_any_value @@ -1319,6 +1328,7 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Pfloatfield (_, _, m) -> Some m | Psetfloatfield _ -> None | Pduprecord _ -> Some alloc_heap + | Pmake_unboxed_product _ | Punboxed_product_field _ -> None | Pccall p -> if not p.prim_alloc then None else begin match p.prim_native_repr_res with @@ -1418,6 +1428,8 @@ let primitive_result_layout (p : primitive) = | Pmakeblock _ | Pmakefloatblock _ | Pmakearray _ | Pduprecord _ | Pduparray _ | Pbigarraydim _ | Pobj_dup -> layout_block | Pfield _ | Pfield_computed _ -> layout_field + | Punboxed_product_field _ -> Misc.fatal_error "Not supported" + | Pmake_unboxed_product layouts -> layout_unboxed_product layouts | Pfloatfield _ | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pbox_float _ -> layout_float diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli index 0b9cb1b0f2b..918c70112f5 100644 --- a/ocaml/lambda/lambda.mli +++ b/ocaml/lambda/lambda.mli @@ -95,6 +95,9 @@ type primitive = | Pfloatfield of int * field_read_semantics * alloc_mode | Psetfloatfield of int * initialization_or_assignment | Pduprecord of Types.record_representation * int + (* Unboxed products *) + | Pmake_unboxed_product of layout list + | Punboxed_product_field of int * (layout list) (* External call *) | Pccall of Primitive.description (* Exceptions *) @@ -225,6 +228,7 @@ and layout = | Pvalue of value_kind | Punboxed_float | Punboxed_int of boxed_integer + | Punboxed_product of layout list | Pbottom and block_shape = @@ -524,6 +528,8 @@ val layout_any_value : layout (* A layout that is Pgenval because it is bound by a letrec *) val layout_letrec : layout +val layout_unboxed_product : layout list -> layout + val layout_top : layout val layout_bottom : layout diff --git a/ocaml/lambda/printlambda.ml b/ocaml/lambda/printlambda.ml index 022c98e8068..adcf647e953 100644 --- a/ocaml/lambda/printlambda.ml +++ b/ocaml/lambda/printlambda.ml @@ -77,6 +77,9 @@ let variant_kind print_contents ppf ~consts ~non_consts = )) non_consts +let unboxed_product_debug () = + match Sys.getenv "DEBUG" with exception Not_found -> false | _ -> true + let rec value_kind ppf = function | Pgenval -> () | Pintval -> fprintf ppf "[int]" @@ -86,8 +89,10 @@ let rec value_kind ppf = function | Pvariant { consts; non_consts; } -> variant_kind value_kind' ppf ~consts ~non_consts +(* CR mshinwell: we need to work out how to fix these printers properly *) + and value_kind' ppf = function - | Pgenval -> fprintf ppf "*" + | Pgenval -> fprintf ppf (if unboxed_product_debug () then "[val]" else "*") | Pintval -> fprintf ppf "[int]" | Pfloatval -> fprintf ppf "[float]" | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind) @@ -95,13 +100,18 @@ and value_kind' ppf = function | Pvariant { consts; non_consts; } -> variant_kind value_kind' ppf ~consts ~non_consts -let layout ppf layout = - match layout with - | Pvalue k -> value_kind ppf k +let rec layout ppf layout_ = + match layout_ with + | Pvalue k -> + (if unboxed_product_debug () then value_kind' else value_kind) ppf k | Ptop -> fprintf ppf "[top]" | Pbottom -> fprintf ppf "[bottom]" | Punboxed_float -> fprintf ppf "[unboxed_float]" | Punboxed_int bi -> fprintf ppf "[unboxed_%s]" (boxed_integer_name bi) + | Punboxed_product layouts -> + fprintf ppf "[%a]" + (pp_print_list ~pp_sep:(fun ppf () -> pp_print_string ppf " * ") layout) + layouts let return_kind ppf (mode, kind) = let smode = alloc_mode mode in @@ -117,6 +127,7 @@ let return_kind ppf (mode, kind) = variant_kind value_kind' ppf ~consts ~non_consts | Punboxed_float -> fprintf ppf ": unboxed_float@ " | Punboxed_int bi -> fprintf ppf ": unboxed_%s@ " (boxed_integer_name bi) + | Punboxed_product _ -> fprintf ppf ": %a" layout kind | Ptop -> fprintf ppf ": top@ " | Pbottom -> fprintf ppf ": bottom@ " @@ -295,6 +306,12 @@ let primitive ppf = function in fprintf ppf "setfloatfield%s %i" init n | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size + | Pmake_unboxed_product layouts -> + fprintf ppf "make_unboxed_product [%a]" + (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf " * ") layout) layouts + | Punboxed_product_field (n, layouts) -> + fprintf ppf "unboxed_product_field %d [%a]" n + (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf " * ") layout) layouts | Pccall p -> fprintf ppf "%s" p.prim_name | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) | Psequand -> fprintf ppf "&&" @@ -476,6 +493,8 @@ let name_of_primitive = function | Pfloatfield _ -> "Pfloatfield" | Psetfloatfield _ -> "Psetfloatfield" | Pduprecord _ -> "Pduprecord" + | Pmake_unboxed_product _ -> "Pmake_unboxed_product" + | Punboxed_product_field _ -> "Punboxed_product_field" | Pccall _ -> "Pccall" | Praise _ -> "Praise" | Psequand -> "Psequand" diff --git a/ocaml/lambda/tmc.ml b/ocaml/lambda/tmc.ml index 5eaeb3d3c99..87151706cc9 100644 --- a/ocaml/lambda/tmc.ml +++ b/ocaml/lambda/tmc.ml @@ -893,6 +893,9 @@ let rec choice ctx t = (* we don't handle all-float records *) | Pmakefloatblock _ + (* nor unboxed products *) + | Pmake_unboxed_product _ | Punboxed_product_field _ + | Pobj_dup | Pobj_magic _ | Pprobe_is_enabled _ diff --git a/ocaml/lambda/translprim.ml b/ocaml/lambda/translprim.ml index 9e8c649cd95..46f89d2803e 100644 --- a/ocaml/lambda/translprim.ml +++ b/ocaml/lambda/translprim.ml @@ -93,6 +93,7 @@ type prim = | Identity | Apply of Lambda.region_close * Lambda.layout | Revapply of Lambda.region_close * Lambda.layout + | Void let units_with_used_primitives = Hashtbl.create 7 let add_used_primitive loc env path = @@ -133,6 +134,14 @@ let to_modify_mode ~poly = function | None -> assert false | Some mode -> transl_modify_mode mode +let layout_unboxed_pair_of_values = + Punboxed_product [Pvalue Pgenval; Pvalue Pgenval] + +let two_unboxed_pairs_of_values = + [ layout_unboxed_pair_of_values; + layout_unboxed_pair_of_values; + ] + let lookup_primitive loc poly pos p = let mode = to_alloc_mode ~poly p.prim_native_repr_res in let arg_modes = List.map (to_modify_mode ~poly) p.prim_native_repr_args in @@ -401,6 +410,40 @@ let lookup_primitive loc poly pos p = | "%obj_magic" -> Primitive(Pobj_magic Lambda.layout_any_value, 1) | "%array_to_iarray" -> Primitive (Parray_to_iarray, 1) | "%array_of_iarray" -> Primitive (Parray_of_iarray, 1) + (* unboxed pairs of void *) + | "%make_unboxed_pair_o_o" -> + Primitive(Pmake_unboxed_product [Punboxed_product []; Punboxed_product []], 2) + | "%unboxed_pair_field_0_o_o" -> + Primitive(Punboxed_product_field (0, [Punboxed_product []; Punboxed_product []]), 1) + | "%unboxed_pair_field_1_o_o" -> + Primitive(Punboxed_product_field (1, [Punboxed_product []; Punboxed_product []]), 1) + (* unboxed pairs of values *) + | "%make_unboxed_pair_v_v" -> + Primitive(Pmake_unboxed_product [Pvalue Pgenval; Pvalue Pgenval], 2) + | "%unboxed_pair_field_0_v_v" -> + Primitive(Punboxed_product_field (0, [Pvalue Pgenval; Pvalue Pgenval]), 1) + | "%unboxed_pair_field_1_v_v" -> + Primitive(Punboxed_product_field (1, [Pvalue Pgenval; Pvalue Pgenval]), 1) + (* unboxed pairs of immediates *) + | "%make_unboxed_pair_i_i" -> + Primitive(Pmake_unboxed_product [Pvalue Pintval; Pvalue Pintval], 2) + | "%unboxed_pair_field_0_i_i" -> + Primitive(Punboxed_product_field (0, [Pvalue Pintval; Pvalue Pintval]), 1) + | "%unboxed_pair_field_1_i_i" -> + Primitive(Punboxed_product_field (1, [Pvalue Pintval; Pvalue Pintval]), 1) + (* unboxed pairs of (unboxed pairs of values) *) + | "%make_unboxed_pair_vup_vup" -> + Primitive(Pmake_unboxed_product [layout_unboxed_pair_of_values; layout_unboxed_pair_of_values], 2) + | "%unboxed_pair_field_0_vup_vup" -> + Primitive(Punboxed_product_field (0, two_unboxed_pairs_of_values), 1) + | "%unboxed_pair_field_1_vup_vup" -> + Primitive(Punboxed_product_field (1, two_unboxed_pairs_of_values), 1) + (* unboxed triples (void, int, void) *) + | "%make_unboxed_triple_o_i_o" -> + Primitive(Pmake_unboxed_product [Punboxed_product []; Pvalue Pintval; Punboxed_product []], 3) + (* void is special as the external is declared to have one parameter + but the primitive takes zero arguments *) + | "%void" -> Void | s when String.length s > 0 && s.[0] = '%' -> raise(Error(loc, Unknown_builtin_primitive s)) | _ -> External p @@ -762,6 +805,7 @@ let lambda_of_prim prim_name prim loc args arg_exps = ap_region_close = pos; ap_mode = alloc_heap; } + | Void, _ -> Lprim (Pmake_unboxed_product [], [], loc) | (Raise _ | Raise_with_backtrace | Lazy_force _ | Loc _ | Primitive _ | Sys_argv | Comparison _ | Send _ | Send_self _ | Send_cache _ | Frame_pointers | Identity @@ -790,6 +834,7 @@ let check_primitive_arity loc p = | Frame_pointers -> p.prim_arity = 0 | Identity -> p.prim_arity = 1 | Apply _ | Revapply _ -> p.prim_arity = 2 + | Void -> true in if not ok then raise(Error(loc, Wrong_arity_builtin_primitive p.prim_name)) @@ -877,6 +922,7 @@ let lambda_primitive_needs_event_after = function | Parray_to_iarray | Parray_of_iarray | Pignore | Psetglobal _ | Pgetglobal _ | Pgetpredef _ | Pmakeblock _ | Pmakefloatblock _ + | Pmake_unboxed_product _ | Punboxed_product_field _ | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Praise _ | Psequor | Psequand | Pnot | Pnegint | Paddint | Psubint | Pmulint @@ -898,7 +944,7 @@ let primitive_needs_event_after = function lambda_primitive_needs_event_after (comparison_primitive comp knd) | Lazy_force _ | Send _ | Send_self _ | Send_cache _ | Apply _ | Revapply _ -> true - | Raise _ | Raise_with_backtrace | Loc _ | Frame_pointers | Identity -> false + | Raise _ | Raise_with_backtrace | Loc _ | Frame_pointers | Identity | Void -> false let transl_primitive_application loc p env ty mode path exp args arg_exps pos = let prim = diff --git a/ocaml/middle_end/clambda_primitives.ml b/ocaml/middle_end/clambda_primitives.ml index 77e66745305..b0b731993c7 100644 --- a/ocaml/middle_end/clambda_primitives.ml +++ b/ocaml/middle_end/clambda_primitives.ml @@ -150,6 +150,7 @@ and layout = Lambda.layout = | Pvalue of value_kind | Punboxed_float | Punboxed_int of boxed_integer + | Punboxed_product of layout list | Pbottom and block_shape = Lambda.block_shape diff --git a/ocaml/middle_end/clambda_primitives.mli b/ocaml/middle_end/clambda_primitives.mli index e71b17c4c85..5e3ddfd0765 100644 --- a/ocaml/middle_end/clambda_primitives.mli +++ b/ocaml/middle_end/clambda_primitives.mli @@ -153,6 +153,7 @@ and layout = Lambda.layout = | Pvalue of value_kind | Punboxed_float | Punboxed_int of boxed_integer + | Punboxed_product of layout list | Pbottom and block_shape = Lambda.block_shape diff --git a/ocaml/middle_end/closure/closure.ml b/ocaml/middle_end/closure/closure.ml index 258eff83262..06910476e33 100644 --- a/ocaml/middle_end/closure/closure.ml +++ b/ocaml/middle_end/closure/closure.ml @@ -65,6 +65,7 @@ let is_gc_ignorable kind = | Punboxed_int _ -> true | Pvalue Pintval -> true | Pvalue (Pgenval | Pfloatval | Pboxedintval _ | Pvariant _ | Parrayval _) -> false + | Punboxed_product _ -> Misc.fatal_error "TBD" let split_closure_fv kinds fv = List.fold_right (fun id (not_scanned, scanned) -> diff --git a/ocaml/middle_end/convert_primitives.ml b/ocaml/middle_end/convert_primitives.ml index 541af7ecf86..9180f67f359 100644 --- a/ocaml/middle_end/convert_primitives.ml +++ b/ocaml/middle_end/convert_primitives.ml @@ -38,6 +38,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Psetfloatfield (field, init_or_assign) -> Psetfloatfield (field, init_or_assign) | Pduprecord (repr, size) -> Pduprecord (repr, size) + | Pmake_unboxed_product _ + | Punboxed_product_field _ -> Misc.fatal_error "TODO" | Pccall prim -> Pccall prim | Praise kind -> Praise kind | Psequand -> Psequand diff --git a/ocaml/middle_end/flambda/closure_offsets.ml b/ocaml/middle_end/flambda/closure_offsets.ml index cfb1791786d..11f071656ec 100644 --- a/ocaml/middle_end/flambda/closure_offsets.ml +++ b/ocaml/middle_end/flambda/closure_offsets.ml @@ -80,7 +80,8 @@ let add_closure_offsets | Punboxed_float -> true | Punboxed_int _ -> true | Pvalue Pintval -> true - | Pvalue _ -> false) + | Pvalue _ -> false + | Punboxed_product _ -> Misc.fatal_error "TODO") free_vars in let free_variable_offsets, free_variable_pos = diff --git a/ocaml/middle_end/flambda/flambda_to_clambda.ml b/ocaml/middle_end/flambda/flambda_to_clambda.ml index 4d5d6fc7d1b..a9ea72caa97 100644 --- a/ocaml/middle_end/flambda/flambda_to_clambda.ml +++ b/ocaml/middle_end/flambda/flambda_to_clambda.ml @@ -711,7 +711,8 @@ and to_clambda_set_of_closures t env | Punboxed_float -> true | Punboxed_int _ -> true | Pvalue Pintval -> true - | Pvalue _ -> false) + | Pvalue _ -> false + | Punboxed_product _ -> Misc.fatal_error "TBD") free_vars in let to_closure_args free_vars = diff --git a/ocaml/middle_end/internal_variable_names.ml b/ocaml/middle_end/internal_variable_names.ml index 4fb6290a49b..536c9a627ed 100644 --- a/ocaml/middle_end/internal_variable_names.ml +++ b/ocaml/middle_end/internal_variable_names.ml @@ -314,6 +314,10 @@ let punbox_int = "Punbox_int" let pbox_int = "Pbox_int" let punbox_int_arg = "Punbox_int_arg" let pbox_int_arg = "Pbox_int_arg" +let pmake_unboxed_product = "Pmake_unboxed_product" +let punboxed_product_field = "Punboxed_product_field" +let pmake_unboxed_product_arg = "Pmake_unboxed_product_arg" +let punboxed_product_field_arg = "Punboxed_product_field_arg" let anon_fn_with_loc (sloc: Lambda.scoped_location) = let loc = Debuginfo.Scoped_location.to_location sloc in @@ -439,6 +443,8 @@ let of_primitive : Lambda.primitive -> string = function | Pbox_int _ -> pbox_int | Parray_of_iarray -> parray_of_iarray | Parray_to_iarray -> parray_to_iarray + | Pmake_unboxed_product _ -> pmake_unboxed_product + | Punboxed_product_field _ -> punboxed_product_field let of_primitive_arg : Lambda.primitive -> string = function | Pbytes_of_string -> pbytes_of_string_arg @@ -553,3 +559,5 @@ let of_primitive_arg : Lambda.primitive -> string = function | Pbox_int _ -> pbox_int_arg | Parray_of_iarray -> parray_of_iarray_arg | Parray_to_iarray -> parray_to_iarray_arg + | Pmake_unboxed_product _ -> pmake_unboxed_product_arg + | Punboxed_product_field _ -> punboxed_product_field_arg diff --git a/ocaml/middle_end/printclambda.ml b/ocaml/middle_end/printclambda.ml index 45ced29e973..22f75e37040 100644 --- a/ocaml/middle_end/printclambda.ml +++ b/ocaml/middle_end/printclambda.ml @@ -60,6 +60,7 @@ let layout (layout : Lambda.layout) = | Punboxed_int Pint32 -> ":unboxed_int32" | Punboxed_int Pint64 -> ":unboxed_int64" | Punboxed_int Pnativeint -> ":unboxed_nativeint" + | Punboxed_product _ -> Misc.fatal_error "TODO" let rec structured_constant ppf = function | Uconst_float x -> fprintf ppf "%F" x diff --git a/ocaml/typing/predef.ml b/ocaml/typing/predef.ml index 8cd677899a3..c74949750b3 100644 --- a/ocaml/typing/predef.ml +++ b/ocaml/typing/predef.ml @@ -46,6 +46,9 @@ and ident_lazy_t = ident_create "lazy_t" and ident_string = ident_create "string" and ident_extension_constructor = ident_create "extension_constructor" and ident_floatarray = ident_create "floatarray" +and ident_unboxed_pair = ident_create "unboxed_pair" +and ident_unboxed_triple = ident_create "unboxed_triple" +and ident_real_void = ident_create "void" let path_int = Pident ident_int and path_char = Pident ident_char @@ -65,6 +68,9 @@ and path_lazy_t = Pident ident_lazy_t and path_string = Pident ident_string and path_extension_constructor = Pident ident_extension_constructor and path_floatarray = Pident ident_floatarray +and path_unboxed_pair = Pident ident_unboxed_pair +and path_unboxed_triple = Pident ident_unboxed_triple +and path_void = Pident ident_real_void let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) and type_char = newgenty (Tconstr(path_char, [], ref Mnil)) @@ -181,6 +187,49 @@ let common_initial_env add_type add_extension empty_env = } in add_type type_ident decl env + and add_type2 ?(kind=fun _ -> Types.kind_abstract) type_ident + ~variance ~separability env = + let param0 = newgenvar () in + let param1 = newgenvar () in + let decl = + {type_params = [param0; param1]; + type_arity = 2; + type_kind = kind param0; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = None; + type_variance = [variance; variance]; + type_separability = [separability; separability]; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_unboxed_default = false; + type_uid = Uid.of_predef_id type_ident; + } + in + add_type type_ident decl env + and add_type3 ?(kind=fun _ -> Types.kind_abstract) type_ident + ~variance ~separability env = + let param0 = newgenvar () in + let param1 = newgenvar () in + let param2 = newgenvar () in + let decl = + {type_params = [param0; param1; param2]; + type_arity = 3; + type_kind = kind param0; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = None; + type_variance = [variance; variance; variance]; + type_separability = [separability; separability; separability]; + type_is_newtype = false; + type_expansion_scope = lowest_level; + type_attributes = []; + type_unboxed_default = false; + type_uid = Uid.of_predef_id type_ident; + } + in + add_type type_ident decl env in let add_extension id l = add_extension id @@ -233,6 +282,13 @@ let common_initial_env add_type add_extension empty_env = |> add_type ident_string |> add_type ident_unit ~kind:(variant [cstr ident_void []]) + |> add_type2 ident_unboxed_pair + ~variance:Variance.covariant + ~separability:Separability.Ind + |> add_type3 ident_unboxed_triple + ~variance:Variance.covariant + ~separability:Separability.Ind + |> add_type ident_real_void (* Predefined exceptions - alphabetical order *) |> add_extension ident_assert_failure [newgenty (Ttuple[type_string; type_int; type_int])] diff --git a/ocaml/typing/predef.mli b/ocaml/typing/predef.mli index bb779b310af..8c451ea945d 100644 --- a/ocaml/typing/predef.mli +++ b/ocaml/typing/predef.mli @@ -54,6 +54,9 @@ val path_int64: Path.t val path_lazy_t: Path.t val path_extension_constructor: Path.t val path_floatarray: Path.t +val path_unboxed_pair: Path.t +val path_unboxed_triple: Path.t +val path_void: Path.t val path_match_failure: Path.t val path_invalid_argument: Path.t diff --git a/ocaml/typing/typeopt.ml b/ocaml/typing/typeopt.ml index 44495eb3034..c1b8484d9d5 100644 --- a/ocaml/typing/typeopt.ml +++ b/ocaml/typing/typeopt.ml @@ -179,9 +179,9 @@ let bigarray_type_kind_and_layout env typ = | _ -> (Pbigarray_unknown, Pbigarray_unknown_layout) -let value_kind env ty = +let rec layout env ty = let rec loop env ~visited ~depth ~num_nodes_visited ty - : int * Lambda.value_kind = + : int * Lambda.layout = let[@inline] cannot_proceed () = Numbers.Int.Set.mem (get_id ty) visited || depth >= 2 @@ -189,32 +189,41 @@ let value_kind env ty = in let scty = scrape_ty env ty in match get_desc scty with + (* | _ when is_immediate (Ctype.immediacy env scty) -> *) | _ when is_always_gc_ignorable env scty -> - num_nodes_visited, Pintval + num_nodes_visited, Pvalue Pintval | Tconstr(p, _, _) when Path.same p Predef.path_int -> - num_nodes_visited, Pintval + num_nodes_visited, Pvalue Pintval | Tconstr(p, _, _) when Path.same p Predef.path_char -> - num_nodes_visited, Pintval + num_nodes_visited, Pvalue Pintval | Tconstr(p, _, _) when Path.same p Predef.path_float -> - num_nodes_visited, Pfloatval + num_nodes_visited, Pvalue Pfloatval | Tconstr(p, _, _) when Path.same p Predef.path_int32 -> - num_nodes_visited, Pboxedintval Pint32 + num_nodes_visited, Pvalue (Pboxedintval Pint32) | Tconstr(p, _, _) when Path.same p Predef.path_int64 -> - num_nodes_visited, Pboxedintval Pint64 + num_nodes_visited, Pvalue (Pboxedintval Pint64) | Tconstr(p, _, _) when Path.same p Predef.path_nativeint -> - num_nodes_visited, Pboxedintval Pnativeint + num_nodes_visited, Pvalue (Pboxedintval Pnativeint) + | Tconstr(p, args, _) when Path.same p Predef.path_unboxed_pair -> + let layouts = List.map (layout env) args in + num_nodes_visited, Punboxed_product layouts + | Tconstr(p, args, _) when Path.same p Predef.path_unboxed_triple -> + let layouts = List.map (layout env) args in + num_nodes_visited, Punboxed_product layouts + | Tconstr(p, _, _) when Path.same p Predef.path_void -> + num_nodes_visited, Punboxed_product [] | Tconstr(p, _, _) when (Path.same p Predef.path_array || Path.same p Predef.path_floatarray) -> - num_nodes_visited, Parrayval (array_type_kind env ty) + num_nodes_visited, Pvalue (Parrayval (array_type_kind env ty)) | Tconstr(p, _, _) -> if cannot_proceed () then - num_nodes_visited, Pgenval + num_nodes_visited, Pvalue Pgenval else begin let visited = Numbers.Int.Set.add (get_id ty) visited in match (Env.find_type p env).type_kind with | exception Not_found -> - num_nodes_visited, Pgenval + num_nodes_visited, Pvalue Pgenval | Type_variant (constructors, _rep) -> let is_constant (constructor : Types.constructor_declaration) = match constructor.cd_args with @@ -222,7 +231,7 @@ let value_kind env ty = | _ -> false in if List.for_all is_constant constructors then - num_nodes_visited, Pintval + num_nodes_visited, Pvalue Pintval else let depth = depth + 1 in let for_one_constructor @@ -278,12 +287,18 @@ let value_kind env ty = constructors in begin match result with - | None -> num_nodes_visited, Pgenval + | None -> num_nodes_visited, Pvalue Pgenval | Some (num_nodes_visited, _, consts, _, non_consts) -> match non_consts with | [] -> assert false (* See [List.for_all is_constant], above *) | _::_ -> - num_nodes_visited, Pvariant { consts; non_consts } + let non_consts = + List.map (fun (l, layouts) -> + let value_kinds = + List.map (function (Pvalue vk) -> vk | _ -> assert false) layouts + in l, value_kinds) non_consts + in + num_nodes_visited, Pvalue (Pvariant { consts; non_consts }) end | Type_record (labels, record_representation) -> let depth = depth + 1 in @@ -304,22 +319,28 @@ let value_kind env ty = (false, num_nodes_visited) labels in if is_mutable then - num_nodes_visited, Pgenval + num_nodes_visited, Pvalue Pgenval else begin match record_representation with | Record_regular -> + let fields = + List.map (function (Pvalue vk) -> vk | _ -> assert false) fields + in num_nodes_visited, - Pvariant { consts = []; non_consts = [0, fields] } + Pvalue (Pvariant { consts = []; non_consts = [0, fields] }) | Record_float -> num_nodes_visited, - Pvariant { + Pvalue (Pvariant { consts = []; non_consts = [ Obj.double_array_tag, List.map (fun _ -> Pfloatval) fields - ] } + ] }) | Record_inlined tag -> + let fields = + List.map (function (Pvalue vk) -> vk | _ -> assert false) fields + in num_nodes_visited, - Pvariant { consts = []; non_consts = [tag, fields] } + Pvalue (Pvariant { consts = []; non_consts = [tag, fields] }) | Record_unboxed _ -> begin match fields with | [field] -> num_nodes_visited, field @@ -328,13 +349,13 @@ let value_kind env ty = have exactly one field" end | Record_extension _ -> - num_nodes_visited, Pgenval + num_nodes_visited, Pvalue Pgenval end - | Type_abstract _ | Type_open -> num_nodes_visited, Pgenval + | Type_abstract _ | Type_open -> num_nodes_visited, Pvalue Pgenval end | Ttuple fields -> if cannot_proceed () then - num_nodes_visited, Pgenval + num_nodes_visited, Pvalue Pgenval else begin let visited = Numbers.Int.Set.add (get_id ty) visited in let depth = depth + 1 in @@ -345,11 +366,14 @@ let value_kind env ty = num_nodes_visited fields in + let fields = + List.map (function (Pvalue vk) -> vk | _ -> assert false) fields + in num_nodes_visited, - Pvariant { consts = []; non_consts = [0, fields] } + Pvalue (Pvariant { consts = []; non_consts = [0, fields] }) end | _ -> - num_nodes_visited, Pgenval + num_nodes_visited, Pvalue Pgenval in let _num_nodes_visited, value_kind = loop env ~visited:Numbers.Int.Set.empty ~depth:0 @@ -357,8 +381,6 @@ let value_kind env ty = in value_kind -let layout env ty = Lambda.Pvalue (value_kind env ty) - let function_return_layout env ty = match is_function_type env ty with | Some (_lhs, rhs) -> layout env rhs @@ -408,7 +430,7 @@ let value_kind_union (k1 : Lambda.value_kind) (k2 : Lambda.value_kind) = if Lambda.equal_value_kind k1 k2 then k1 else Pgenval -let layout_union l1 l2 = +let rec layout_union l1 l2 = match l1, l2 with | Pbottom, l | l, Pbottom -> l @@ -417,5 +439,9 @@ let layout_union l1 l2 = | Punboxed_float, Punboxed_float -> Punboxed_float | Punboxed_int bi1, Punboxed_int bi2 -> if equal_boxed_integer bi1 bi2 then l1 else Ptop - | (Ptop | Pvalue _ | Punboxed_float | Punboxed_int _), _ -> + | Punboxed_product layouts1, Punboxed_product layouts2 -> + if List.compare_lengths layouts1 layouts2 <> 0 then Ptop + else Punboxed_product (List.map2 layout_union layouts1 layouts2) + | (Ptop | Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_product _), + _ -> Ptop diff --git a/ocaml/utils/misc.mli b/ocaml/utils/misc.mli index 53003147414..ab81108ddfb 100644 --- a/ocaml/utils/misc.mli +++ b/ocaml/utils/misc.mli @@ -97,7 +97,7 @@ module Stdlib : sig (** The lexicographic order supported by the provided order. There is no constraint on the relative lengths of the lists. *) - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val equal : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** Returns [true] if and only if the given lists have the same length and content with respect to the given equality function. *) diff --git a/up.ml b/up.ml new file mode 100644 index 00000000000..b5753472e86 --- /dev/null +++ b/up.ml @@ -0,0 +1,291 @@ +external make_unboxed_pair_v_v : 'a -> 'b -> ('a, 'b) unboxed_pair = "%make_unboxed_pair_v_v" +external unboxed_pair_field_0_v_v : ('a, 'b) unboxed_pair -> 'a = "%unboxed_pair_field_0_v_v" +external unboxed_pair_field_1_v_v : ('a, 'b) unboxed_pair -> 'b = "%unboxed_pair_field_1_v_v" + +let f i x y = + let p = make_unboxed_pair_v_v x y in + if i < 0 then unboxed_pair_field_0_v_v p + else unboxed_pair_field_1_v_v p + +external make_unboxed_pair_vup_vup : + ('a, 'b) unboxed_pair -> ('c, 'd) unboxed_pair + -> (('a, 'b) unboxed_pair, ('c, 'd) unboxed_pair) unboxed_pair + = "%make_unboxed_pair_vup_vup" + +external unboxed_pair_field_0_vup_vup : + (('a, 'b) unboxed_pair, _) unboxed_pair + -> ('a, 'b) unboxed_pair = "%unboxed_pair_field_0_vup_vup" + +let g i x y = + let p = make_unboxed_pair_v_v x y in + let q = make_unboxed_pair_vup_vup p p in + let p_again = unboxed_pair_field_0_vup_vup q in + if i < 0 then unboxed_pair_field_0_v_v p_again + else unboxed_pair_field_1_v_v p_again + +external unboxed_pair_field_1_vup_vup : + (_, ('a, 'b) unboxed_pair) unboxed_pair + -> ('a, 'b) unboxed_pair = "%unboxed_pair_field_1_vup_vup" + +let h i x y = + let p = make_unboxed_pair_v_v x y in + let p' = make_unboxed_pair_v_v y x in + let q = make_unboxed_pair_vup_vup p p' in + let r = + if i < 0 then unboxed_pair_field_0_vup_vup q + else unboxed_pair_field_1_vup_vup q + in + if i < 0 then unboxed_pair_field_0_v_v r + else unboxed_pair_field_1_v_v r + +external make_unboxed_pair_i_i : 'a -> 'b -> ('a, 'b) unboxed_pair = "%make_unboxed_pair_i_i" +external unboxed_pair_field_0_i_i : ('a, 'b) unboxed_pair -> 'a = "%unboxed_pair_field_0_i_i" +external unboxed_pair_field_1_i_i : ('a, 'b) unboxed_pair -> 'b = "%unboxed_pair_field_1_i_i" + +let[@inline never] takes_unboxed_pair (p : (int, int) unboxed_pair) = + let p0 = unboxed_pair_field_0_i_i p in + let p1 = unboxed_pair_field_1_i_i p in + p0 + p1 + +let caller x y = + let p = make_unboxed_pair_i_i x y in + takes_unboxed_pair p + +let[@inline never] takes_two_unboxed_pairs + (p : (int, int) unboxed_pair) + (q : (int, int) unboxed_pair) = + let p0 = unboxed_pair_field_0_i_i p in + let p1 = unboxed_pair_field_1_i_i p in + let q0 = unboxed_pair_field_0_i_i q in + let q1 = unboxed_pair_field_1_i_i q in + p0 + 10*p1 + 100*q0 + 1000*q1 + +let caller2 x y = + let p = make_unboxed_pair_i_i x y in + let q = make_unboxed_pair_i_i y x in + takes_two_unboxed_pairs p q + +let make_partial x y = + let p = make_unboxed_pair_i_i x y in + let partial = takes_two_unboxed_pairs p in + let q = make_unboxed_pair_i_i y x in + (Sys.opaque_identity partial) q + +let () = + Printf.printf "%d\n%!" (make_partial 1 2) + +let[@inline never] takes_three_unboxed_pairs + (p : (int, int) unboxed_pair) + (q : (int, int) unboxed_pair) + (r : (int, int) unboxed_pair) = + let p0 = unboxed_pair_field_0_i_i p in + let p1 = unboxed_pair_field_1_i_i p in + let q0 = unboxed_pair_field_0_i_i q in + let q1 = unboxed_pair_field_1_i_i q in + let r0 = unboxed_pair_field_0_i_i r in + let r1 = unboxed_pair_field_1_i_i r in + p0 + 10*p1 + 100*q0 + 1000*q1 + 10000*r0 + 100000*r1 + +let make_partial3 a b c d e f = + let p = make_unboxed_pair_i_i a b in + let q = make_unboxed_pair_i_i c d in + let r = make_unboxed_pair_i_i e f in + let partial1 = takes_three_unboxed_pairs p in + let partial2 = (Sys.opaque_identity partial1) q in + (Sys.opaque_identity partial2) r + +let () = + Printf.printf "%d\n%!" (make_partial3 1 2 3 4 5 6) + +let[@inline never] returns_unboxed_pair_not_inlined x = + if x < 0 then make_unboxed_pair_i_i x x + else make_unboxed_pair_i_i (x + 1) (x + 2) + +let[@inline] returns_unboxed_pair_inlined x = + if x < 0 then make_unboxed_pair_i_i x x + else make_unboxed_pair_i_i (x + 1) (x + 2) + +let call_function_returning_unboxed_pair x = + let p1 = returns_unboxed_pair_not_inlined x in + let p2 = returns_unboxed_pair_inlined x in + let p1_0 = unboxed_pair_field_0_i_i p1 in + let p1_1 = unboxed_pair_field_1_i_i p1 in + let p2_0 = unboxed_pair_field_0_i_i p2 in + let p2_1 = unboxed_pair_field_1_i_i p2 in + p1_0 + p1_1 + p2_0 + p2_1 + +let () = + Printf.printf "%d\n%!" (call_function_returning_unboxed_pair 42) + +external void : unit -> void = "%void" + +let void_const (v : void) = 42 + +let void0 (v : void) x = x + +let void1a (v : void) x y = x +let void1b (v : void) x y = y + +let void2a x (v : void) y = x +let void2b x (v : void) y = y + +let void3a x y (v : void) = x +let void3b x y (v : void) = y + +let apply_void1a_no_wrapper x y = + let p = (Sys.opaque_identity void1a) (void ()) in + p x y + +let () = + Printf.printf "%d (expected 1)\n%!" (apply_void1a_no_wrapper 1 2) + +let[@inline never] two_voids_const (v : void) (v : void) = 42 +let[@inline never] two_voids_const_side1 (v : void) = + Printf.printf "foo\n%!"; fun (v : void) -> 42 + +let[@inline never] two_voids_const_side2 (v : void) (v : void) = + Printf.printf "bar\n%!"; + 42 + +(* With partial applications concealed from flambda *) +let () = + let p = (Sys.opaque_identity two_voids_const) (void ()) in + Printf.printf "%d (expected 42)\n%!" (p (void ())); + let p = (Sys.opaque_identity two_voids_const_side1) (void ()) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void ())); + let p = (Sys.opaque_identity two_voids_const_side2) (void ()) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void ())) + +(* With partial applications visible to flambda (From_lambda) *) +let () = + let p = Sys.opaque_identity (two_voids_const (void ())) in + Printf.printf "%d (expected 42)\n%!" (p (void ())); + let p = Sys.opaque_identity (two_voids_const_side1 (void ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void ())); + let p = Sys.opaque_identity (two_voids_const_side2 (void ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void ())) + +(* With partial applications visible to flambda (Simplify) *) +let[@inline] to_inline two_voids_const two_voids_const_side1 + two_voids_const_side2 = + let p = Sys.opaque_identity (two_voids_const (void ())) in + Printf.printf "%d (expected 42)\n%!" (p (void ())); + let p = Sys.opaque_identity (two_voids_const_side1 (void ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void ())); + let p = Sys.opaque_identity (two_voids_const_side2 (void ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void ())) + +let () = + to_inline two_voids_const two_voids_const_side1 two_voids_const_side2 + +(* Overapplications concealed from flambda *) +let () = + Printf.printf "OVERAPP1\n%!"; + let x = (Sys.opaque_identity two_voids_const) (void ()) (void ()) in + Printf.printf "%d (expected 42)\n%!" x; + let x = (Sys.opaque_identity two_voids_const_side1) (void ()) (void ()) in + Printf.printf "%d (expected 42)\n%!" x; + let x = (Sys.opaque_identity two_voids_const_side2) (void ()) (void ()) in + Printf.printf "%d (expected 42)\n%!" x + +(* Overapplications visible to flambda *) +let () = + Printf.printf "OVERAPP2\n%!"; + let x = two_voids_const (void ()) (void ()) in + Printf.printf "%d (expected 42)\n%!" x; + let x = two_voids_const_side1 (void ()) (void ()) in + Printf.printf "%d (expected 42)\n%!" x; + let x = two_voids_const_side2 (void ()) (void ()) in + Printf.printf "%d (expected 42)\n%!" x + +(* Overapplications visible to simplify only *) +let[@inline always] g (f : void -> void -> int) : int = f (void ()) (void ()) +let () = + Printf.printf "OVERAPP3\n%!"; + let x = g two_voids_const in + Printf.printf "%d (expected 42)\n%!" x; + let x = g two_voids_const_side1 in + Printf.printf "%d (expected 42)\n%!" x; + let x = g two_voids_const_side2 in + Printf.printf "%d (expected 42)\n%!" x + +(* From above: with partial applications visible to flambda (From_lambda), + but using void arguments extracted from unboxed products *) +external make_unboxed_pair_o_o : void -> void -> (void, void) unboxed_pair = + "%make_unboxed_pair_o_o" +external unboxed_pair_field_0_o_o : (void, void) unboxed_pair -> void = + "%unboxed_pair_field_0_o_o" +external unboxed_pair_field_1_o_o : (void, void) unboxed_pair -> void = + "%unboxed_pair_field_1_o_o" + +let[@inline never] void_from_product () = + let p = make_unboxed_pair_o_o (void ()) (void ()) in + unboxed_pair_field_0_o_o p + +let[@inline] void_from_product_inlined () = + let p = make_unboxed_pair_o_o (void ()) (void ()) in + unboxed_pair_field_0_o_o p + +let () = + let p = Sys.opaque_identity (two_voids_const (void_from_product ())) in + Printf.printf "%d (expected 42)\n%!" (p (void_from_product ())); + let p = Sys.opaque_identity (two_voids_const_side1 (void_from_product ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void_from_product ())); + let p = Sys.opaque_identity (two_voids_const_side2 (void_from_product ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void_from_product ())) + +let () = + let p = Sys.opaque_identity (two_voids_const (void_from_product_inlined ())) in + Printf.printf "%d (expected 42)\n%!" (p (void_from_product_inlined ())); + let p = Sys.opaque_identity (two_voids_const_side1 (void_from_product_inlined ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void_from_product_inlined ())); + let p = Sys.opaque_identity (two_voids_const_side2 (void_from_product_inlined ())) in + Printf.printf "after definition\n%!"; + Printf.printf "%d (expected 42)\n%!" (p (void_from_product_inlined ())) + +(* version without printing to declutter Cmm *) +let[@inline never] returns_unboxed_pair_of_voids_not_inlined0 x = + make_unboxed_pair_o_o (void ()) (void ()) + +let[@inline never] returns_unboxed_pair_of_voids_not_inlined x = + if x < 0 then make_unboxed_pair_o_o (void ()) (void ()) + else ( + Printf.printf "foo\n%!"; + make_unboxed_pair_o_o (void ()) (void ()) + ) + +let[@inline] returns_unboxed_pair_of_voids_inlined x = + if x < 0 then make_unboxed_pair_o_o (void ()) (void ()) + else ( + Printf.printf "foo2\n%!"; + make_unboxed_pair_o_o (void ()) (void ()) + ) + +let print_foo (_ : void) = Printf.printf "FOO\n%!" + +let[@inline never] call_functions_returning_unboxed_pair_of_voids x = + let p1 = returns_unboxed_pair_of_voids_not_inlined x in + let p2 = returns_unboxed_pair_of_voids_inlined x in + print_foo (unboxed_pair_field_0_o_o p1); + print_foo (unboxed_pair_field_1_o_o p1); + print_foo (unboxed_pair_field_0_o_o p2); + print_foo (unboxed_pair_field_1_o_o p2) + +let () = call_functions_returning_unboxed_pair_of_voids 100 +let () = call_functions_returning_unboxed_pair_of_voids (-100) + +external make_unboxed_triple_o_i_o + : void -> int -> void -> (void, int, void) unboxed_triple = + "%make_unboxed_triple_o_i_o" + +let[@inline never] returns_unboxed_triple_of_void_int_void_not_inlined x = + make_unboxed_triple_o_i_o (void ()) x (void ())