diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index d7912d3685d..c79e0e34835 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -383,7 +383,7 @@ module Inlining = struct ~result_arity:(Code.result_arity code) ~make_inlined_body) end -let close_c_call acc env ~loc ~let_bound_var +let close_c_call acc env ~loc ~let_bound_ids_with_kinds ({ prim_name; prim_arity; prim_alloc; @@ -394,14 +394,48 @@ let close_c_call acc env ~loc ~let_bound_var prim_native_repr_args; prim_native_repr_res } : - Primitive.description) ~(args : Simple.t list) exn_continuation dbg - ~current_region (k : Acc.t -> Named.t option -> Expr_with_acc.t) : + Primitive.description) ~(args : Simple.t list list) exn_continuation dbg + ~current_region (k : Acc.t -> Named.t list -> Expr_with_acc.t) : Expr_with_acc.t = - (* We always replace the original let-binding with an Flambda expression, so - we call [k] with [None], to get just the closure-converted body of that - binding. *) + let args = + List.map + (function + | [arg] -> arg + | [] | _ :: _ :: _ -> + Misc.fatal_errorf + "close_c_call: expected only singleton arguments for primitive %s, \ + but got: [%a]" + prim_name + (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf args -> + Format.fprintf ppf "[%a]" + (Format.pp_print_list ~pp_sep:Format.pp_print_space + Simple.print) + args)) + args) + args + in + let env, let_bound_vars = + List.fold_left_map + (fun env (id, kind) -> Env.add_var_like env id Not_user_visible kind) + env let_bound_ids_with_kinds + in + let let_bound_var = + match let_bound_vars with + | [let_bound_var] -> let_bound_var + | [] | _ :: _ :: _ -> + Misc.fatal_errorf + "close_c_call: expected singleton return for primitive %s, but got: \ + [%a]" + prim_name + (Format.pp_print_list ~pp_sep:Format.pp_print_space Variable.print) + let_bound_vars + in let cost_metrics_of_body, free_names_of_body, acc, body = - Acc.measure_cost_metrics acc ~f:(fun acc -> k acc None) + Acc.measure_cost_metrics acc ~f:(fun acc -> + k acc + (List.map + (fun var -> Named.create_simple (Simple.var var)) + let_bound_vars)) in let box_return_value = match prim_native_repr_res with @@ -421,7 +455,7 @@ let close_c_call acc env ~loc ~let_bound_var | Apply_cont apply_cont when Simple.List.equal (Apply_cont_expr.args apply_cont) - [Simple.var let_bound_var] + (Simple.vars let_bound_vars) && Option.is_none (Apply_cont_expr.trap_action apply_cont) && Option.is_none box_return_value -> Apply_cont_expr.continuation apply_cont, false @@ -598,9 +632,35 @@ let close_exn_continuation acc env (exn_continuation : IR.exn_continuation) = Exn_continuation.create ~exn_handler:exn_continuation.exn_handler ~extra_args ) -let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args - loc (exn_continuation : IR.exn_continuation option) ~current_region - (k : Acc.t -> Named.t option -> Expr_with_acc.t) : Expr_with_acc.t = +let close_raise0 acc env ~raise_kind ~arg ~dbg exn_continuation = + let acc, exn_cont = close_exn_continuation acc env exn_continuation in + let exn_handler = Exn_continuation.exn_handler exn_cont in + let args = + (* CR mshinwell: Share with [Lambda_to_flambda_primitives_helpers] *) + let extra_args = + List.map + (fun (simple, _kind) -> simple) + (Exn_continuation.extra_args exn_cont) + in + arg :: extra_args + in + let raise_kind = Some (Trap_action.Raise_kind.from_lambda raise_kind) in + let trap_action = Trap_action.Pop { exn_handler; raise_kind } in + let acc, apply_cont = + Apply_cont_with_acc.create acc ~trap_action exn_handler ~args ~dbg + in + (* Since raising of an exception doesn't terminate, we don't call [k]. *) + Expr_with_acc.create_apply_cont acc apply_cont + +let close_raise acc env ~raise_kind ~arg ~dbg exn_continuation = + let acc, arg = find_simple acc env arg in + close_raise0 acc env ~raise_kind ~arg ~dbg exn_continuation + +let close_primitive acc env ~let_bound_ids_with_kinds named + (prim : Lambda.primitive) ~args loc + (exn_continuation : IR.exn_continuation option) ~current_region + (k : Acc.t -> Named.t list -> Expr_with_acc.t) : Expr_with_acc.t = + let orig_exn_continuation = exn_continuation in let acc, exn_continuation = match exn_continuation with | None -> acc, None @@ -608,7 +668,9 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args let acc, cont = close_exn_continuation acc env exn_continuation in acc, Some cont in - let acc, args = find_simples acc env args in + let acc, args = + List.fold_left_map (fun acc arg -> find_simples acc env arg) acc args + in let dbg = Debuginfo.from_location loc in match prim, args with | Pccall prim, args -> @@ -619,8 +681,8 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args IR.print_named named | Some exn_continuation -> exn_continuation in - close_c_call acc env ~loc ~let_bound_var prim ~args exn_continuation dbg - ~current_region k + close_c_call acc env ~loc ~let_bound_ids_with_kinds prim ~args + exn_continuation dbg ~current_region k | Pgetglobal cu, [] -> if Compilation_unit.equal cu (Env.current_unit env) then @@ -630,38 +692,22 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args Flambda2_import.Symbol.for_compilation_unit cu |> Symbol.create_wrapped in let named = Named.create_simple (Simple.symbol symbol) in - k acc (Some named) + k acc [named] | Pgetpredef id, [] -> let symbol = Flambda2_import.Symbol.for_predef_ident id |> Symbol.create_wrapped in let named = Named.create_simple (Simple.symbol symbol) in - k acc (Some named) - | Praise raise_kind, [_] -> + k acc [named] + | Praise raise_kind, [[arg]] -> let exn_continuation = - match exn_continuation with + match orig_exn_continuation with | None -> Misc.fatal_errorf "Praise is missing exception continuation: %a" IR.print_named named | Some exn_continuation -> exn_continuation in - let exn_handler = Exn_continuation.exn_handler exn_continuation in - let args = - (* CR mshinwell: Share with [Lambda_to_flambda_primitives_helpers] *) - let extra_args = - List.map - (fun (simple, _kind) -> simple) - (Exn_continuation.extra_args exn_continuation) - in - args @ extra_args - in - let raise_kind = Some (Trap_action.Raise_kind.from_lambda raise_kind) in - let trap_action = Trap_action.Pop { exn_handler; raise_kind } in - let acc, apply_cont = - Apply_cont_with_acc.create acc ~trap_action exn_handler ~args ~dbg - in - (* Since raising of an exception doesn't terminate, we don't call [k]. *) - Expr_with_acc.create_apply_cont acc apply_cont + close_raise0 acc env ~raise_kind ~arg ~dbg exn_continuation | (Pmakeblock _ | Pmakefloatblock _ | Pmakearray _), [] -> (* Special case for liftable empty block or array *) let acc, sym = @@ -708,7 +754,7 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args (* Inconsistent with outer match *) assert false in - k acc (Some (Named.create_simple (Simple.symbol sym))) + k acc [Named.create_simple (Simple.symbol sym)] | prim, args -> Lambda_to_flambda_primitives.convert_and_bind acc exn_continuation ~big_endian:(Env.big_endian env) ~register_const0 prim ~args dbg @@ -722,24 +768,24 @@ let close_trap_action_opt trap_action = | Pop { exn_handler } -> Pop { exn_handler; raise_kind = None }) trap_action -let close_named acc env ~let_bound_var (named : IR.named) - (k : Acc.t -> Named.t option -> Expr_with_acc.t) : Expr_with_acc.t = +let close_named acc env ~let_bound_ids_with_kinds (named : IR.named) + (k : Acc.t -> Named.t list -> Expr_with_acc.t) : Expr_with_acc.t = match named with | Simple (Var id) -> assert (not (Ident.is_global_or_predef id)); let acc, simple = find_simple acc env (Var id) in let named = Named.create_simple simple in - k acc (Some named) + k acc [named] | Simple (Const cst) -> let acc, named, _name = close_const acc cst in - k acc (Some named) + k acc [named] | Get_tag var -> let named = find_simple_from_id env var in let prim : Lambda_to_flambda_primitives_helpers.expr_primitive = Unary (Tag_immediate, Prim (Unary (Get_tag, Simple named))) in - Lambda_to_flambda_primitives_helpers.bind_rec acc None ~register_const0 prim - Debuginfo.none (fun acc named -> k acc (Some named)) + Lambda_to_flambda_primitives_helpers.bind_recs acc None ~register_const0 + [prim] Debuginfo.none k | Begin_region { try_region_parent } -> let prim : Lambda_to_flambda_primitives_helpers.expr_primitive = match try_region_parent with @@ -748,17 +794,18 @@ let close_named acc env ~let_bound_var (named : IR.named) let try_region_parent = find_simple_from_id env try_region_parent in Unary (Begin_try_region, Simple try_region_parent) in - Lambda_to_flambda_primitives_helpers.bind_rec acc None ~register_const0 prim - Debuginfo.none (fun acc named -> k acc (Some named)) + Lambda_to_flambda_primitives_helpers.bind_recs acc None ~register_const0 + [prim] Debuginfo.none k | End_region id -> let named = find_simple_from_id env id in let prim : Lambda_to_flambda_primitives_helpers.expr_primitive = Unary (End_region, Simple named) in - Lambda_to_flambda_primitives_helpers.bind_rec acc None ~register_const0 prim - Debuginfo.none (fun acc named -> k acc (Some named)) + Lambda_to_flambda_primitives_helpers.bind_recs acc None ~register_const0 + [prim] Debuginfo.none k | Prim { prim; args; loc; exn_continuation; region } -> - close_primitive acc env ~let_bound_var named prim ~args loc exn_continuation + close_primitive acc env ~let_bound_ids_with_kinds named prim ~args loc + exn_continuation ~current_region:(fst (Env.find_var env region)) k @@ -837,65 +884,125 @@ let classify_fields_of_block env fields alloc_mode = then Computed_static fields else Constant fields -let close_let acc env id user_visible kind defining_expr +let close_let acc env let_bound_ids_with_kinds user_visible defining_expr ~(body : Acc.t -> Env.t -> Expr_with_acc.t) : Expr_with_acc.t = - let body_env, var = Env.add_var_like env id user_visible kind in - let cont acc (defining_expr : Named.t option) = - match defining_expr with - | Some (Simple simple) -> - let body_env = Env.add_simple_to_substitute env id simple kind in - body acc body_env - | None -> body acc body_env - | Some (Prim ((Nullary Begin_region | Unary (End_region, _)), _)) - when not (Flambda_features.stack_allocation_enabled ()) -> - (* We use [body_env] to ensure the region variables are still in the - environment, to avoid lookup errors, even though the [Let] won't be - generated. *) - body acc body_env - | Some defining_expr -> ( - let bound_pattern = - Bound_pattern.singleton (VB.create var Name_mode.normal) - in - let bind acc env = - (* CR pchambart: Not tail ! The body function is the recursion *) - let acc, body = body acc env in - Let_with_acc.create acc bound_pattern defining_expr ~body - in + let rec cont ids_with_kinds env acc (defining_exprs : Named.t list) = + match ids_with_kinds, defining_exprs with + | [], [] -> body acc env + | (id, kind) :: ids_with_kinds, defining_expr :: defining_exprs -> ( + let body_env, var = Env.add_var_like env id user_visible kind in + let body acc env = cont ids_with_kinds env acc defining_exprs in match defining_expr with - | Prim - ( Variadic - (Make_block (Values (tag, _), Immutable, alloc_mode), fields), - _ ) -> ( - let approxs = - List.map (find_value_approximation body_env) fields |> Array.of_list + | Simple simple -> + let body_env = Env.add_simple_to_substitute env id simple kind in + body acc body_env + | Prim ((Nullary Begin_region | Unary (End_region, _)), _) + when not (Flambda_features.stack_allocation_enabled ()) -> + (* We use [body_env] to ensure the region variables are still in the + environment, to avoid lookup errors, even though the [Let] won't be + generated. *) + body acc body_env + | _ -> ( + let bound_pattern = + Bound_pattern.singleton (VB.create var Name_mode.normal) in - let fields_kind = classify_fields_of_block env fields alloc_mode in - match fields_kind with - | Constant static_fields -> - let acc, sym = - register_const0 acc - (Static_const.block tag Immutable static_fields) - (Ident.name id) - in - let body_env = - Env.add_simple_to_substitute body_env id (Simple.symbol sym) kind - in - let acc = - Acc.add_symbol_approximation acc sym - (Value_approximation.Block_approximation - (approxs, Alloc_mode.For_allocations.as_type alloc_mode)) + let bind acc env = + (* CR pchambart: Not tail ! The body function is the recursion *) + let acc, body = body acc env in + Let_with_acc.create acc bound_pattern defining_expr ~body + in + match defining_expr with + | Prim + ( Variadic + (Make_block (Values (tag, _), Immutable, alloc_mode), fields), + _ ) -> ( + let approxs = + List.map (find_value_approximation body_env) fields |> Array.of_list in - body acc body_env - | Computed_static static_fields -> - (* This is a inconstant statically-allocated value, so cannot go - through [register_const0]. The definition must be placed right - away. *) + let fields_kind = classify_fields_of_block env fields alloc_mode in + match fields_kind with + | Constant static_fields -> + let acc, sym = + register_const0 acc + (Static_const.block tag Immutable static_fields) + (Ident.name id) + in + let body_env = + Env.add_simple_to_substitute body_env id (Simple.symbol sym) kind + in + let acc = + Acc.add_symbol_approximation acc sym + (Value_approximation.Block_approximation + (approxs, Alloc_mode.For_allocations.as_type alloc_mode)) + in + body acc body_env + | Computed_static static_fields -> + (* This is a inconstant statically-allocated value, so cannot go + through [register_const0]. The definition must be placed right + away. *) + let symbol = + Symbol.create + (Compilation_unit.get_current_exn ()) + (Linkage_name.of_string (Variable.unique_name var)) + in + let static_const = Static_const.block tag Immutable static_fields in + let static_consts = + [Static_const_or_code.create_static_const static_const] + in + let defining_expr = + Static_const_group.create static_consts + |> Named.create_static_consts + in + let body_env = + Env.add_simple_to_substitute body_env id (Simple.symbol symbol) + kind + in + let approx = + Value_approximation.Block_approximation + (approxs, Alloc_mode.For_allocations.as_type alloc_mode) + in + let acc = Acc.add_symbol_approximation acc symbol approx in + let acc, body = body acc body_env in + Let_with_acc.create acc + (Bound_pattern.static + (Bound_static.create [Bound_static.Pattern.block_like symbol])) + defining_expr ~body + | Dynamic_block -> + let body_env = + Env.add_block_approximation body_env var approxs + (Alloc_mode.For_allocations.as_type alloc_mode) + in + bind acc body_env) + | Prim + ( Variadic + ( Make_block (Values (tag, _), Immutable_unique, _alloc_mode), + [exn_name; exn_id] ), + _ ) + when Tag.Scannable.equal tag Tag.Scannable.object_tag + && Env.at_toplevel env + && Flambda_features.classic_mode () -> + (* Special case to lift toplevel exception declarations *) let symbol = Symbol.create (Compilation_unit.get_current_exn ()) (Linkage_name.of_string (Variable.unique_name var)) in - let static_const = Static_const.block tag Immutable static_fields in + let transform_arg arg = + Simple.pattern_match' arg + ~var:(fun var ~coercion:_ -> + Field_of_static_block.Dynamically_computed (var, Debuginfo.none)) + ~symbol:(fun sym ~coercion:_ -> Field_of_static_block.Symbol sym) + ~const:(fun const -> + Misc.fatal_errorf "Constant %a not expected as argument in %a" + Reg_width_const.print const Named.print defining_expr) + in + (* This is an inconstant statically-allocated value, so cannot go + through [register_const0]. The definition must be placed right + away. *) + let static_const = + Static_const.block Tag.Scannable.object_tag Immutable_unique + [transform_arg exn_name; transform_arg exn_id] + in let static_consts = [Static_const_or_code.create_static_const static_const] in @@ -906,96 +1013,46 @@ let close_let acc env id user_visible kind defining_expr let body_env = Env.add_simple_to_substitute body_env id (Simple.symbol symbol) kind in - let approx = - Value_approximation.Block_approximation - (approxs, Alloc_mode.For_allocations.as_type alloc_mode) + let acc = + Acc.add_symbol_approximation acc symbol + Value_approximation.Value_unknown in - let acc = Acc.add_symbol_approximation acc symbol approx in let acc, body = body acc body_env in Let_with_acc.create acc (Bound_pattern.static (Bound_static.create [Bound_static.Pattern.block_like symbol])) defining_expr ~body - | Dynamic_block -> - let body_env = - Env.add_block_approximation body_env var approxs - (Alloc_mode.For_allocations.as_type alloc_mode) - in - bind acc body_env) - | Prim - ( Variadic - ( Make_block (Values (tag, _), Immutable_unique, _alloc_mode), - [exn_name; exn_id] ), - _ ) - when Tag.Scannable.equal tag Tag.Scannable.object_tag - && Env.at_toplevel env - && Flambda_features.classic_mode () -> - (* Special case to lift toplevel exception declarations *) - let symbol = - Symbol.create - (Compilation_unit.get_current_exn ()) - (Linkage_name.of_string (Variable.unique_name var)) - in - let transform_arg arg = - Simple.pattern_match' arg - ~var:(fun var ~coercion:_ -> - Field_of_static_block.Dynamically_computed (var, Debuginfo.none)) - ~symbol:(fun sym ~coercion:_ -> Field_of_static_block.Symbol sym) - ~const:(fun const -> - Misc.fatal_errorf "Constant %a not expected as argument in %a" - Reg_width_const.print const Named.print defining_expr) - in - (* This is an inconstant statically-allocated value, so cannot go - through [register_const0]. The definition must be placed right - away. *) - let static_const = - Static_const.block Tag.Scannable.object_tag Immutable_unique - [transform_arg exn_name; transform_arg exn_id] - in - let static_consts = - [Static_const_or_code.create_static_const static_const] - in - let defining_expr = - Static_const_group.create static_consts |> Named.create_static_consts - in - let body_env = - Env.add_simple_to_substitute body_env id (Simple.symbol symbol) kind - in - let acc = - Acc.add_symbol_approximation acc symbol - Value_approximation.Value_unknown - in - let acc, body = body acc body_env in - Let_with_acc.create acc - (Bound_pattern.static - (Bound_static.create [Bound_static.Pattern.block_like symbol])) - defining_expr ~body - | Prim (Binary (Block_load _, block, field), _) -> ( - match simplify_block_load acc body_env ~block ~field with - | Unknown -> bind acc body_env - | Not_a_block -> - if Flambda_features.check_invariants () - then - (* CR keryan: This is hidden behind invariants check because it can - appear on correct code using Lazy or GADT. It might warrant a - proper warning at some point. *) - Misc.fatal_errorf - "Unexpected approximation found when block approximation was \ - expected in [Closure_conversion]: %a" - Named.print defining_expr - else - ( acc, - Expr.create_invalid - (Defining_expr_of_let (bound_pattern, defining_expr)) ) - | Field_contents sim -> - let body_env = Env.add_simple_to_substitute env id sim kind in - body acc body_env - | Block_but_cannot_simplify approx -> - let body_env = Env.add_var_approximation body_env var approx in - bind acc body_env) - | _ -> bind acc body_env) - in - close_named acc env ~let_bound_var:var defining_expr cont + | Prim (Binary (Block_load _, block, field), _) -> ( + match simplify_block_load acc body_env ~block ~field with + | Unknown -> bind acc body_env + | Not_a_block -> + if Flambda_features.check_invariants () + then + (* CR keryan: This is hidden behind invariants check because it + can appear on correct code using Lazy or GADT. It might warrant + a proper warning at some point. *) + Misc.fatal_errorf + "Unexpected approximation found when block approximation was \ + expected in [Closure_conversion]: %a" + Named.print defining_expr + else + ( acc, + Expr.create_invalid + (Defining_expr_of_let (bound_pattern, defining_expr)) ) + | Field_contents sim -> + let body_env = Env.add_simple_to_substitute env id sim kind in + body acc body_env + | Block_but_cannot_simplify approx -> + let body_env = Env.add_var_approximation body_env var approx in + bind acc body_env) + | _ -> bind acc body_env)) + | _, _ -> + Misc.fatal_errorf + "CC.close_let: defining_exprs should have the same length as number of \ + variables" + in + close_named acc env ~let_bound_ids_with_kinds defining_expr + (cont let_bound_ids_with_kinds env) let close_let_cont acc env ~name ~is_exn_handler ~params ~(recursive : Asttypes.rec_flag) diff --git a/middle_end/flambda2/from_lambda/closure_conversion.mli b/middle_end/flambda2/from_lambda/closure_conversion.mli index d0a8937e8af..ccd2cbd5746 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion.mli @@ -25,9 +25,8 @@ module Expr_with_acc = Closure_conversion_aux.Expr_with_acc val close_let : Acc.t -> Env.t -> - Ident.t -> + (Ident.t * Flambda_kind.With_subkind.t) list -> IR.user_visible -> - Flambda_kind.With_subkind.t -> IR.named -> body:(Acc.t -> Env.t -> Expr_with_acc.t) -> Expr_with_acc.t @@ -70,6 +69,15 @@ val close_switch : IR.switch -> Expr_with_acc.t +val close_raise : + Acc.t -> + Env.t -> + raise_kind:Lambda.raise_kind -> + arg:IR.simple -> + dbg:Debuginfo.t -> + IR.exn_continuation -> + Expr_with_acc.t + type 'a close_program_metadata = | Normal : [`Normal] close_program_metadata | Classic : diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml index f83b17f87ae..78431d8bbb9 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml @@ -39,7 +39,7 @@ module IR = struct | End_region of Ident.t | Prim of { prim : Lambda.primitive; - args : simple list; + args : simple list list; loc : Lambda.scoped_location; exn_continuation : exn_continuation option; region : Ident.t @@ -92,7 +92,10 @@ module IR = struct | End_region id -> fprintf ppf "@[<2>(End_region@ %a)@]" Ident.print id | Prim { prim; args; _ } -> fprintf ppf "@[<2>(%a %a)@]" Printlambda.primitive prim - (Format.pp_print_list ~pp_sep:Format.pp_print_space print_simple) + (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf arg -> + fprintf ppf "@[<2>(%a)@]" + (Format.pp_print_list ~pp_sep:Format.pp_print_space print_simple) + arg)) args end diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli index 1d32232d514..5ec72e8e1a1 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli @@ -43,7 +43,7 @@ module IR : sig don't exist in Lambda *) | Prim of { prim : Lambda.primitive; - args : simple list; + args : simple list list; loc : Lambda.scoped_location; exn_continuation : exn_continuation option; region : Ident.t diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 9e6082ce03c..75b004844dd 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -562,9 +562,9 @@ let compile_staticfail acc env ccenv ~(continuation : Continuation.t) ~args : | Try_with _ -> body acc ccenv | Regular region_ident -> CC.close_let acc ccenv - (Ident.create_local "unit") - Not_user_visible Flambda_kind.With_subkind.tagged_immediate - (End_region region_ident) ~body + [ ( Ident.create_local "unit", + Flambda_kind.With_subkind.tagged_immediate ) ] + Not_user_visible (End_region region_ident) ~body in let no_end_region after_everything = after_everything in match @@ -699,7 +699,7 @@ 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).") | _, _ -> Primitive (prim, args, loc) @@ -816,9 +816,10 @@ let restore_continuation_context acc env ccenv cont ~close_early body = comment in [cps] on the [Lregion] case. *) if close_early then - CC.close_let acc ccenv (Ident.create_local "unit") - Not_user_visible Flambda_kind.With_subkind.tagged_immediate - (End_region region) ~body:(fun acc ccenv -> body acc ccenv cont) + CC.close_let acc ccenv + [Ident.create_local "unit", Flambda_kind.With_subkind.tagged_immediate] + Not_user_visible (End_region region) + ~body:(fun acc ccenv -> body acc ccenv cont) else let ({ continuation_closing_region; continuation_after_closing_region } : Env.region_closure_continuation) = @@ -985,94 +986,6 @@ let primitive_can_raise (prim : Lambda.primitive) = | Punbox_int _ | Pbox_int _ -> false -let primitive_result_kind (prim : Lambda.primitive) : - Flambda_kind.With_subkind.t = - match prim with - | Pccall { prim_native_repr_res = _, Untagged_int; _ } -> - Flambda_kind.With_subkind.tagged_immediate - | Pccall { prim_native_repr_res = _, Unboxed_float; _ } - | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ - | Pmulfloat _ | Pdivfloat _ | Pfloatfield _ - | Parrayrefs (Pfloatarray_ref _) - | Parrayrefu (Pfloatarray_ref _) - | Pbigarrayref (_, _, (Pbigarray_float32 | Pbigarray_float64), _) -> - Flambda_kind.With_subkind.boxed_float - | Pccall { prim_native_repr_res = _, Unboxed_integer Pnativeint; _ } - | Pbigarrayref (_, _, Pbigarray_native_int, _) -> - 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 - | 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 - | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint - | Plsrint | Pasrint | Pmodint _ | Pdivint _ | Pignore | Psequand | Psequor - | Pnot | Pbytesrefs | Pstringrefs | Pbytessets | Pstring_load_16 _ - | Pbytes_load_16 _ | Pbigstring_load_16 _ | Pbytes_set_16 _ | Pbytes_set_32 _ - | Pbytes_set_64 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ - | Pbigstring_set_64 _ | Pintcomp _ | Pcompare_ints | Pcompare_floats - | Pcompare_bints _ | Pintoffloat | Pfloatcomp _ | Parraysets _ - | Pbigarrayset _ | Psetfield _ | Psetfield_computed _ | Psetfloatfield _ - | Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu | Pbytessetu - | Parraylength _ | Parraysetu _ | Pisint _ | Pbintcomp _ | Pintofbint _ - | Pisout - | Parrayrefs Pintarray_ref - | Parrayrefu Pintarray_ref - | Pprobe_is_enabled _ | Pctconst _ | Pbswap16 - | Pbigarrayref - ( _, - _, - ( Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 - | Pbigarray_uint16 | Pbigarray_caml_int ), - _ ) -> - Flambda_kind.With_subkind.tagged_immediate - | Pdivbint { size = bi; _ } - | Pmodbint { size = bi; _ } - | Pandbint (bi, _) - | Porbint (bi, _) - | Pxorbint (bi, _) - | Plslbint (bi, _) - | Plsrbint (bi, _) - | Pasrbint (bi, _) - | Pnegbint (bi, _) - | Paddbint (bi, _) - | Psubbint (bi, _) - | Pmulbint (bi, _) - | 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) - | Popaque layout | Pobj_magic layout -> - 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 - | Pccall { prim_native_repr_res = _, Same_as_ocaml_repr; _ } - | Parrayrefs (Pgenarray_ref _ | Paddrarray_ref) - | Parrayrefu (Pgenarray_ref _ | Paddrarray_ref) - | Pbytes_to_string | Pbytes_of_string | Parray_of_iarray | Parray_to_iarray - | Pgetglobal _ | Psetglobal _ | Pgetpredef _ | Pmakeblock _ - | Pmakefloatblock _ | Pfield _ | Pfield_computed _ | Pduprecord _ - | Poffsetint _ | Poffsetref _ | Pmakearray _ | Pduparray _ | Pbigarraydim _ - | 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) - type cps_continuation = | Tail of Continuation.t | Non_tail of (Acc.t -> Env.t -> CCenv.t -> IR.simple -> Expr_with_acc.t) @@ -1100,8 +1013,9 @@ let name_if_not_var acc ccenv name simple kind body = | IR.Var id -> body id acc ccenv | IR.Const _ -> let id = Ident.create_local name in - CC.close_let acc ccenv id Not_user_visible kind (IR.Simple simple) - ~body:(body id) + CC.close_let acc ccenv + [id, kind] + Not_user_visible (IR.Simple simple) ~body:(body id) let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (k_exn : Continuation.t) : Expr_with_acc.t = @@ -1148,10 +1062,11 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) 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 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) - (Simple (Var temp_id)) ~body) + CC.close_let acc ccenv + [new_id, kind] + User_visible (Simple (Var temp_id)) ~body) | Llet ((Strict | Alias | StrictOpt), _, fun_id, Lfunction func, body) -> (* This case is here to get function names right. *) let bindings = cps_function_bindings env [fun_id, L.Lfunction func] in @@ -1167,9 +1082,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) | Llet ((Strict | Alias | StrictOpt), layout, id, Lconst const, body) -> (* This case avoids extraneous continuations. *) let body acc ccenv = cps acc env ccenv body k k_exn in - CC.close_let acc ccenv id User_visible - (Flambda_kind.With_subkind.from_lambda layout) - (Simple (Const const)) ~body + CC.close_let acc ccenv + [id, Flambda_kind.With_subkind.from_lambda layout] + User_visible (Simple (Const const)) ~body | Llet ( ((Strict | Alias | StrictOpt) as let_kind), layout, @@ -1190,10 +1105,12 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) in cps_non_tail_list acc env ccenv args (fun acc env ccenv args -> + let args = List.map (fun arg -> [arg]) args in 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 - (Flambda_kind.With_subkind.from_lambda layout) + CC.close_let acc ccenv + [id, Flambda_kind.With_subkind.from_lambda layout] + User_visible (Prim { prim; args; loc; exn_continuation; region }) ~body) k_exn @@ -1216,16 +1133,17 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) 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 - CC.close_let acc ccenv id Not_user_visible - Flambda_kind.With_subkind.tagged_immediate - (Simple (Const L.const_unit)) ~body + CC.close_let acc ccenv + [id, Flambda_kind.With_subkind.tagged_immediate] + Not_user_visible (Simple (Const L.const_unit)) ~body in 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) + let value_kind = Flambda_kind.With_subkind.from_lambda value_kind in + CC.close_let acc ccenv + [new_id, value_kind] + User_visible (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 @@ -1256,30 +1174,36 @@ 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 - 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) + match[@ocaml.warning "-fragile-match"] prim with + | Praise raise_kind -> ( + match args with + | [_] -> + cps_non_tail_list acc env ccenv args + (fun acc _env ccenv args -> + let exn_continuation : IR.exn_continuation = + { exn_handler = k_exn; + extra_args = extra_args_for_exn_continuation env k_exn + } + in + let dbg = Debuginfo.from_location loc in + CC.close_raise acc ccenv ~raise_kind ~arg:(List.hd args) ~dbg + exn_continuation) + k_exn + | [] | _ :: _ -> + Misc.fatal_errorf "Wrong number of arguments for Lraise: %a" + Printlambda.primitive prim) + | _ -> + let id = Ident.create_local "prim" in + let result_layout = L.primitive_result_layout prim in + (match result_layout with + | Pvalue _ | Punboxed_float | Punboxed_int _ -> () + | Ptop | Pbottom -> + Misc.fatal_errorf "Invalid result layout %a for primitive %a" + Printlambda.layout result_layout Printlambda.primitive prim); + (* CR mshinwell: find a way of making these lets non-user-visible *) + cps acc env ccenv + (L.Llet (Strict, result_layout, id, lam, L.Lvar id)) + k k_exn) | Lswitch (scrutinee, switch, loc, kind) -> maybe_insert_let_cont "switch_result" kind k acc env ccenv (fun acc env ccenv k -> @@ -1384,8 +1308,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) same toplevel context, here we need to assume that all of the body could be behind a branch. *) let ccenv = CCenv.set_not_at_toplevel ccenv in - CC.close_let acc ccenv region Not_user_visible - Flambda_kind.With_subkind.region + CC.close_let acc ccenv + [region, Flambda_kind.With_subkind.region] + Not_user_visible (Begin_region { try_region_parent = Some (Env.current_region env) }) ~body:(fun acc ccenv -> maybe_insert_let_cont "try_with_result" kind k acc env ccenv @@ -1415,9 +1340,11 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (Some (IR.Pop { exn_handler = handler_continuation })) [IR.Var body_result])) ~handler:(fun acc env ccenv -> - CC.close_let acc ccenv (Ident.create_local "unit") - Not_user_visible Flambda_kind.With_subkind.tagged_immediate - (End_region region) ~body:(fun acc ccenv -> + CC.close_let acc ccenv + [ ( Ident.create_local "unit", + Flambda_kind.With_subkind.tagged_immediate ) ] + Not_user_visible (End_region region) + ~body:(fun acc ccenv -> let env = Env.leaving_try_region env in cps_tail acc env ccenv handler k k_exn)))) | Lifthenelse (cond, ifso, ifnot, kind) -> @@ -1453,9 +1380,10 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) 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) + let value_kind = Flambda_kind.With_subkind.from_lambda value_kind in + CC.close_let acc ccenv + [new_id, value_kind] + User_visible (Simple new_value) ~body) k_exn | Levent (body, _event) -> cps acc env ccenv body k k_exn | Lifused _ -> @@ -1469,9 +1397,10 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) cps acc env ccenv body k k_exn | Lexclave body -> let region = Env.current_region env in - CC.close_let acc ccenv (Ident.create_local "unit") - Not_user_visible Flambda_kind.With_subkind.tagged_immediate - (End_region region) ~body:(fun acc ccenv -> + CC.close_let acc ccenv + [Ident.create_local "unit", Flambda_kind.With_subkind.tagged_immediate] + Not_user_visible (End_region region) + ~body:(fun acc ccenv -> let env = Env.leaving_region env in cps acc env ccenv body k k_exn) | Lregion (body, layout) -> @@ -1480,8 +1409,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) continuation for the code after the body. *) let region = Ident.create_local "region" in let dbg = Debuginfo.none in - CC.close_let acc ccenv region Not_user_visible - Flambda_kind.With_subkind.region + CC.close_let acc ccenv + [region, Flambda_kind.With_subkind.region] + Not_user_visible (Begin_region { try_region_parent = None }) ~body:(fun acc ccenv -> maybe_insert_let_cont "body_return" layout k acc env ccenv @@ -1517,9 +1447,11 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) in cps_tail acc env ccenv body k k_exn) ~handler:(fun acc env ccenv -> - CC.close_let acc ccenv (Ident.create_local "unit") - Not_user_visible Flambda_kind.With_subkind.tagged_immediate - (End_region region) ~body:(fun acc ccenv -> + CC.close_let acc ccenv + [ ( Ident.create_local "unit", + Flambda_kind.With_subkind.tagged_immediate ) ] + Not_user_visible (End_region region) + ~body:(fun acc ccenv -> (* Both body and handler will continue at [return_continuation] by default. [restore_region_context] will intercept the @@ -1811,8 +1743,9 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg let body acc ccenv = CC.close_switch acc ccenv ~condition_dbg scrutinee_tag block_switch in - CC.close_let acc ccenv scrutinee_tag Not_user_visible - Flambda_kind.With_subkind.naked_immediate (Get_tag scrutinee) ~body + CC.close_let acc ccenv + [scrutinee_tag, Flambda_kind.With_subkind.naked_immediate] + Not_user_visible (Get_tag scrutinee) ~body in if switch.sw_numblocks = 0 then const_switch, wrappers @@ -1834,11 +1767,12 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg isint_switch in let region = Env.current_region env in - CC.close_let acc ccenv is_scrutinee_int Not_user_visible - Flambda_kind.With_subkind.naked_immediate + CC.close_let acc ccenv + [is_scrutinee_int, Flambda_kind.With_subkind.naked_immediate] + Not_user_visible (Prim { prim = Pisint { variant_only = true }; - args = [Var scrutinee]; + args = [[Var scrutinee]]; loc = Loc_unknown; exn_continuation = None; region 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 0e139d359b7..00fc7108122 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -15,9 +15,9 @@ (**************************************************************************) module H = Lambda_to_flambda_primitives_helpers -module I = Flambda_kind.Standard_int -module I_or_f = Flambda_kind.Standard_int_or_float module K = Flambda_kind +module I = K.Standard_int +module I_or_f = K.Standard_int_or_float module L = Lambda module P = Flambda_primitive @@ -67,21 +67,20 @@ let convert_float_comparison (comp : L.float_comparison) : unit P.comparison = [Lambda_to_flambda]" let boxable_number_of_boxed_integer (bint : L.boxed_integer) : - Flambda_kind.Boxable_number.t = + K.Boxable_number.t = match bint with | Pnativeint -> Naked_nativeint | Pint32 -> Naked_int32 | Pint64 -> Naked_int64 -let standard_int_of_boxed_integer (bint : L.boxed_integer) : - Flambda_kind.Standard_int.t = +let standard_int_of_boxed_integer (bint : L.boxed_integer) : K.Standard_int.t = match bint with | Pnativeint -> Naked_nativeint | Pint32 -> Naked_int32 | Pint64 -> Naked_int64 let standard_int_or_float_of_boxed_integer (bint : L.boxed_integer) : - Flambda_kind.Standard_int_or_float.t = + K.Standard_int_or_float.t = match bint with | Pnativeint -> Naked_nativeint | Pint32 -> Naked_int32 @@ -198,12 +197,12 @@ let box_float (mode : L.alloc_mode) (arg : H.expr_primitive) ~current_region : H.expr_primitive = Unary ( Box_number - ( Flambda_kind.Boxable_number.Naked_float, + ( K.Boxable_number.Naked_float, Alloc_mode.For_allocations.from_lambda mode ~current_region ), Prim arg ) let unbox_float (arg : H.simple_or_prim) : H.simple_or_prim = - Prim (Unary (Unbox_number Flambda_kind.Boxable_number.Naked_float, arg)) + Prim (Unary (Unbox_number K.Boxable_number.Naked_float, arg)) let box_bint bi mode (arg : H.expr_primitive) ~current_region : H.expr_primitive = @@ -620,26 +619,32 @@ let bbswap bi si mode arg ~current_region : H.expr_primitive = Prim (Unary (Unbox_number bi, arg)) )) ) (* Primitive conversion *) -let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) - (dbg : Debuginfo.t) ~current_region : H.expr_primitive = - let args = List.map (fun arg : H.simple_or_prim -> Simple arg) args in +let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) + (dbg : Debuginfo.t) ~current_region : H.expr_primitive list = + let args = + List.map (List.map (fun arg : H.simple_or_prim -> Simple arg)) args + in let size_int = assert (Targetint.size mod 8 = 0); Targetint.size / 8 in match prim, args with | Pmakeblock (tag, mutability, shape, mode), _ -> + let args = List.flatten args in let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in let tag = Tag.Scannable.create_exn tag in let shape = convert_block_shape shape ~num_fields:(List.length args) in let mutability = Mutability.from_lambda mutability in - Variadic (Make_block (Values (tag, shape), mutability, mode), args) + [Variadic (Make_block (Values (tag, shape), mutability, mode), args)] | Pmakefloatblock (mutability, mode), _ -> + let args = List.flatten args in let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in let mutability = Mutability.from_lambda mutability in - Variadic - (Make_block (Naked_floats, mutability, mode), List.map unbox_float args) + [ Variadic + (Make_block (Naked_floats, mutability, mode), List.map unbox_float args) + ] | Pmakearray (array_kind, mutability, mode), _ -> ( + let args = List.flatten args in let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in let array_kind = convert_array_kind array_kind in let mutability = Mutability.from_lambda mutability in @@ -650,30 +655,31 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) | Immediates | Values -> args | Naked_floats -> List.map unbox_float args in - Variadic (Make_array (array_kind, mutability, mode), args) + [Variadic (Make_array (array_kind, mutability, mode), args)] | Float_array_opt_dynamic -> ( (* If this is an empty array we can just give it array kind [Values]. (Even empty flat float arrays have tag zero.) *) match args with | [] -> - Variadic - (Make_array (Values, Immutable, Alloc_mode.For_allocations.heap), []) + [ Variadic + (Make_array (Values, Immutable, Alloc_mode.For_allocations.heap), []) + ] | elt :: _ -> (* Test the first element to see if it's a boxed float: if it is, this array must be created as a flat float array. *) - If_then_else - ( Unary (Is_boxed_float, elt), - Variadic - ( Make_array (Naked_floats, mutability, mode), - List.map unbox_float args ), - Variadic (Make_array (Values, mutability, mode), args) ))) - | Popaque layout, [arg] -> + [ If_then_else + ( Unary (Is_boxed_float, elt), + Variadic + ( Make_array (Naked_floats, mutability, mode), + List.map unbox_float args ), + Variadic (Make_array (Values, mutability, mode), args) ) ])) + | Popaque layout, [[arg]] -> let kind = K.With_subkind.kind (K.With_subkind.from_lambda layout) in - Unary (Opaque_identity { middle_end_only = false; kind }, arg) - | Pobj_magic layout, [arg] -> + [Unary (Opaque_identity { middle_end_only = false; kind }, arg)] + | Pobj_magic layout, [[arg]] -> let kind = K.With_subkind.kind (K.With_subkind.from_lambda layout) in - Unary (Opaque_identity { middle_end_only = true; kind }, arg) - | Pduprecord (repr, num_fields), [arg] -> + [Unary (Opaque_identity { middle_end_only = true; kind }, arg)] + | Pduprecord (repr, num_fields), [[arg]] -> let kind : P.Duplicate_block_kind.t = match repr with | Record_boxed _ -> @@ -701,105 +707,108 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) Misc.fatal_errorf "Cannot handle record kind for Pduprecord: %a" Printlambda.primitive prim in - Unary (Duplicate_block { kind }, arg) - | Pnegint, [arg] -> Unary (Int_arith (I.Tagged_immediate, Neg), arg) - | Paddint, [arg1; arg2] -> - Binary (Int_arith (I.Tagged_immediate, Add), arg1, arg2) - | Psubint, [arg1; arg2] -> - Binary (Int_arith (I.Tagged_immediate, Sub), arg1, arg2) - | Pmulint, [arg1; arg2] -> - Binary (Int_arith (I.Tagged_immediate, Mul), arg1, arg2) - | Pandint, [arg1; arg2] -> - Binary (Int_arith (I.Tagged_immediate, And), arg1, arg2) - | Porint, [arg1; arg2] -> - Binary (Int_arith (I.Tagged_immediate, Or), arg1, arg2) - | Pxorint, [arg1; arg2] -> - Binary (Int_arith (I.Tagged_immediate, Xor), arg1, arg2) - | Plslint, [arg1; arg2] -> - Binary (Int_shift (I.Tagged_immediate, Lsl), arg1, untag_int arg2) - | Plsrint, [arg1; arg2] -> - Binary (Int_shift (I.Tagged_immediate, Lsr), arg1, untag_int arg2) - | Pasrint, [arg1; arg2] -> - Binary (Int_shift (I.Tagged_immediate, Asr), arg1, untag_int arg2) - | Pnot, [arg] -> Unary (Boolean_not, arg) - | Pintcomp comp, [arg1; arg2] -> - tag_int (Binary (convert_integer_comparison_prim comp, arg1, arg2)) - | Pbintcomp (kind, comp), [arg1; arg2] -> + [Unary (Duplicate_block { kind }, arg)] + | Pnegint, [[arg]] -> [Unary (Int_arith (I.Tagged_immediate, Neg), arg)] + | Paddint, [[arg1]; [arg2]] -> + [Binary (Int_arith (I.Tagged_immediate, Add), arg1, arg2)] + | Psubint, [[arg1]; [arg2]] -> + [Binary (Int_arith (I.Tagged_immediate, Sub), arg1, arg2)] + | Pmulint, [[arg1]; [arg2]] -> + [Binary (Int_arith (I.Tagged_immediate, Mul), arg1, arg2)] + | Pandint, [[arg1]; [arg2]] -> + [Binary (Int_arith (I.Tagged_immediate, And), arg1, arg2)] + | Porint, [[arg1]; [arg2]] -> + [Binary (Int_arith (I.Tagged_immediate, Or), arg1, arg2)] + | Pxorint, [[arg1]; [arg2]] -> + [Binary (Int_arith (I.Tagged_immediate, Xor), arg1, arg2)] + | Plslint, [[arg1]; [arg2]] -> + [Binary (Int_shift (I.Tagged_immediate, Lsl), arg1, untag_int arg2)] + | Plsrint, [[arg1]; [arg2]] -> + [Binary (Int_shift (I.Tagged_immediate, Lsr), arg1, untag_int arg2)] + | Pasrint, [[arg1]; [arg2]] -> + [Binary (Int_shift (I.Tagged_immediate, Asr), arg1, untag_int arg2)] + | Pnot, [[arg]] -> [Unary (Boolean_not, arg)] + | Pintcomp comp, [[arg1]; [arg2]] -> + [tag_int (Binary (convert_integer_comparison_prim comp, arg1, arg2))] + | Pbintcomp (kind, comp), [[arg1]; [arg2]] -> let arg1 = unbox_bint kind arg1 in let arg2 = unbox_bint kind arg2 in - tag_int - (Binary (convert_boxed_integer_comparison_prim kind comp, arg1, arg2)) - | Pintoffloat, [arg] -> + [ tag_int + (Binary (convert_boxed_integer_comparison_prim kind comp, arg1, arg2)) + ] + | Pintoffloat, [[arg]] -> let src = K.Standard_int_or_float.Naked_float in let dst = K.Standard_int_or_float.Tagged_immediate in - Unary (Num_conv { src; dst }, unbox_float arg) - | Pfloatofint mode, [arg] -> + [Unary (Num_conv { src; dst }, unbox_float arg)] + | Pfloatofint mode, [[arg]] -> let src = K.Standard_int_or_float.Tagged_immediate in let dst = K.Standard_int_or_float.Naked_float in - box_float mode (Unary (Num_conv { src; dst }, arg)) ~current_region - | Pnegfloat mode, [arg] -> - box_float mode (Unary (Float_arith Neg, unbox_float arg)) ~current_region - | Pabsfloat mode, [arg] -> - box_float mode (Unary (Float_arith Abs, unbox_float arg)) ~current_region - | Paddfloat mode, [arg1; arg2] -> - box_float mode - (Binary (Float_arith Add, unbox_float arg1, unbox_float arg2)) - ~current_region - | Psubfloat mode, [arg1; arg2] -> - box_float mode - (Binary (Float_arith Sub, unbox_float arg1, unbox_float arg2)) - ~current_region - | Pmulfloat mode, [arg1; arg2] -> - box_float mode - (Binary (Float_arith Mul, unbox_float arg1, unbox_float arg2)) - ~current_region - | Pdivfloat mode, [arg1; arg2] -> - box_float mode - (Binary (Float_arith Div, unbox_float arg1, unbox_float arg2)) - ~current_region - | Pfloatcomp comp, [arg1; arg2] -> - tag_int - (Binary - ( Float_comp (Yielding_bool (convert_float_comparison comp)), - unbox_float arg1, - unbox_float arg2 )) - | Punbox_float, [arg] -> Unary (Unbox_number Naked_float, arg) - | Pbox_float mode, [arg] -> - Unary - ( Box_number - ( Naked_float, - Alloc_mode.For_allocations.from_lambda mode ~current_region ), - arg ) - | Punbox_int bi, [arg] -> + [box_float mode (Unary (Num_conv { src; dst }, arg)) ~current_region] + | Pnegfloat mode, [[arg]] -> + [box_float mode (Unary (Float_arith Neg, unbox_float arg)) ~current_region] + | Pabsfloat mode, [[arg]] -> + [box_float mode (Unary (Float_arith Abs, unbox_float arg)) ~current_region] + | Paddfloat mode, [[arg1]; [arg2]] -> + [ box_float mode + (Binary (Float_arith Add, unbox_float arg1, unbox_float arg2)) + ~current_region ] + | Psubfloat mode, [[arg1]; [arg2]] -> + [ box_float mode + (Binary (Float_arith Sub, unbox_float arg1, unbox_float arg2)) + ~current_region ] + | Pmulfloat mode, [[arg1]; [arg2]] -> + [ box_float mode + (Binary (Float_arith Mul, unbox_float arg1, unbox_float arg2)) + ~current_region ] + | Pdivfloat mode, [[arg1]; [arg2]] -> + [ box_float mode + (Binary (Float_arith Div, unbox_float arg1, unbox_float arg2)) + ~current_region ] + | Pfloatcomp comp, [[arg1]; [arg2]] -> + [ tag_int + (Binary + ( Float_comp (Yielding_bool (convert_float_comparison comp)), + unbox_float arg1, + unbox_float arg2 )) ] + | Punbox_float, [[arg]] -> [Unary (Unbox_number Naked_float, arg)] + | Pbox_float mode, [[arg]] -> + [ Unary + ( Box_number + ( Naked_float, + Alloc_mode.For_allocations.from_lambda mode ~current_region ), + arg ) ] + | Punbox_int bi, [[arg]] -> let kind = boxable_number_of_boxed_integer bi in - Unary (Unbox_number kind, arg) - | Pbox_int (bi, mode), [arg] -> + [Unary (Unbox_number kind, arg)] + | Pbox_int (bi, mode), [[arg]] -> let kind = boxable_number_of_boxed_integer bi in - Unary - ( Box_number - (kind, Alloc_mode.For_allocations.from_lambda mode ~current_region), - arg ) - | Pfield_computed sem, [obj; field] -> + [ Unary + ( Box_number + (kind, Alloc_mode.For_allocations.from_lambda mode ~current_region), + arg ) ] + | Pfield_computed sem, [[obj]; [field]] -> let block_access : P.Block_access_kind.t = Values { tag = Unknown; size = Unknown; field_kind = Any_value } in - Binary - (Block_load (block_access, convert_field_read_semantics sem), obj, field) - | Psetfield_computed (imm_or_pointer, init_or_assign), [obj; field; value] -> + [ Binary + (Block_load (block_access, convert_field_read_semantics sem), obj, field) + ] + | ( Psetfield_computed (imm_or_pointer, init_or_assign), + [[obj]; [field]; [value]] ) -> let field_kind = convert_block_access_field_kind imm_or_pointer in let block_access : P.Block_access_kind.t = Values { tag = Unknown; size = Unknown; field_kind } in - Ternary - ( Block_set (block_access, convert_init_or_assign init_or_assign), - obj, - field, - value ) - | Parraylength _kind, [arg] -> + [ Ternary + ( Block_set (block_access, convert_init_or_assign init_or_assign), + obj, + field, + value ) ] + | Parraylength _kind, [[arg]] -> (* See check in flambda2.ml that ensures we don't need to propagate the array kind. *) - Unary (Array_length, arg) - | Pduparray (kind, mutability), [arg] -> ( + [Unary (Array_length, arg)] + | Pduparray (kind, mutability), [[arg]] -> ( let duplicate_array_kind = convert_array_kind_to_duplicate_array_kind kind in @@ -807,141 +816,143 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) let destination_mutability = Mutability.from_lambda mutability in match duplicate_array_kind with | Duplicate_array_kind duplicate_array_kind -> - Unary - ( Duplicate_array - { kind = duplicate_array_kind; - source_mutability; - destination_mutability - }, - arg ) + [ Unary + ( Duplicate_array + { kind = duplicate_array_kind; + source_mutability; + destination_mutability + }, + arg ) ] | Float_array_opt_dynamic -> - If_then_else - ( Unary (Is_flat_float_array, arg), - Unary - ( Duplicate_array - { kind = Naked_floats { length = None }; - source_mutability; - destination_mutability - }, - arg ), - Unary - ( Duplicate_array - { kind = Values; source_mutability; destination_mutability }, - arg ) )) - | Pstringlength, [arg] -> tag_int (Unary (String_length String, arg)) - | Pbyteslength, [arg] -> tag_int (Unary (String_length Bytes, arg)) - | Pstringrefu, [str; index] -> - string_like_load_unsafe ~access_size:Eight String None str index - ~current_region - | Pbytesrefu, [bytes; index] -> - string_like_load_unsafe ~access_size:Eight Bytes None bytes index - ~current_region - | Pstringrefs, [str; index] -> - string_like_load_safe ~dbg ~size_int ~access_size:Eight String None str - index ~current_region - | Pbytesrefs, [bytes; index] -> - string_like_load_safe ~dbg ~size_int ~access_size:Eight Bytes None bytes - index ~current_region - | Pstring_load_16 true (* unsafe *), [str; index] -> - string_like_load_unsafe ~access_size:Sixteen String None str index - ~current_region - | Pbytes_load_16 true (* unsafe *), [bytes; index] -> - string_like_load_unsafe ~access_size:Sixteen Bytes None bytes index - ~current_region - | Pstring_load_32 (true (* unsafe *), mode), [str; index] -> - string_like_load_unsafe ~access_size:Thirty_two String (Some mode) str index - ~current_region - | Pbytes_load_32 (true (* unsafe *), mode), [bytes; index] -> - string_like_load_unsafe ~access_size:Thirty_two Bytes (Some mode) bytes - index ~current_region - | Pstring_load_64 (true (* unsafe *), mode), [str; index] -> - string_like_load_unsafe ~access_size:Sixty_four String (Some mode) str index - ~current_region - | Pbytes_load_64 (true (* unsafe *), mode), [bytes; index] -> - string_like_load_unsafe ~access_size:Sixty_four Bytes (Some mode) bytes - index ~current_region - | Pstring_load_16 false (* safe *), [str; index] -> - string_like_load_safe ~dbg ~size_int ~access_size:Sixteen String None str - index ~current_region - | Pstring_load_32 (false (* safe *), mode), [str; index] -> - string_like_load_safe ~dbg ~size_int ~access_size:Thirty_two String - (Some mode) str index ~current_region - | Pstring_load_64 (false (* safe *), mode), [str; index] -> - string_like_load_safe ~dbg ~size_int ~access_size:Sixty_four String - (Some mode) str index ~current_region - | Pbytes_load_16 false (* safe *), [bytes; index] -> - string_like_load_safe ~dbg ~size_int ~access_size:Sixteen Bytes None bytes - index ~current_region - | Pbytes_load_32 (false (* safe *), mode), [bytes; index] -> - string_like_load_safe ~dbg ~size_int ~access_size:Thirty_two Bytes - (Some mode) bytes index ~current_region - | Pbytes_load_64 (false (* safe *), mode), [bytes; index] -> - string_like_load_safe ~dbg ~size_int ~access_size:Sixty_four Bytes - (Some mode) bytes index ~current_region - | Pbytes_set_16 true (* unsafe *), [bytes; index; new_value] -> - bytes_like_set_unsafe ~access_size:Sixteen Bytes bytes index new_value - | Pbytes_set_32 true (* unsafe *), [bytes; index; new_value] -> - bytes_like_set_unsafe ~access_size:Thirty_two Bytes bytes index new_value - | Pbytes_set_64 true (* unsafe *), [bytes; index; new_value] -> - bytes_like_set_unsafe ~access_size:Sixty_four Bytes bytes index new_value - | Pbytes_set_16 false (* safe *), [bytes; index; new_value] -> - bytes_like_set_safe ~dbg ~size_int ~access_size:Sixteen Bytes bytes index - new_value - | Pbytes_set_32 false (* safe *), [bytes; index; new_value] -> - bytes_like_set_safe ~dbg ~size_int ~access_size:Thirty_two Bytes bytes index - new_value - | Pbytes_set_64 false (* safe *), [bytes; index; new_value] -> - bytes_like_set_safe ~dbg ~size_int ~access_size:Sixty_four Bytes bytes index - new_value - | Pisint { variant_only }, [arg] -> - tag_int (Unary (Is_int { variant_only }, arg)) - | Pisout, [arg1; arg2] -> - tag_int - (Binary - (Int_comp (I.Tagged_immediate, Yielding_bool (Lt Unsigned)), arg1, arg2)) - | Pbintofint (bi, mode), [arg] -> + [ If_then_else + ( Unary (Is_flat_float_array, arg), + Unary + ( Duplicate_array + { kind = Naked_floats { length = None }; + source_mutability; + destination_mutability + }, + arg ), + Unary + ( Duplicate_array + { kind = Values; source_mutability; destination_mutability }, + arg ) ) ]) + | Pstringlength, [[arg]] -> [tag_int (Unary (String_length String, arg))] + | Pbyteslength, [[arg]] -> [tag_int (Unary (String_length Bytes, arg))] + | Pstringrefu, [[str]; [index]] -> + [ string_like_load_unsafe ~access_size:Eight String None str index + ~current_region ] + | Pbytesrefu, [[bytes]; [index]] -> + [ string_like_load_unsafe ~access_size:Eight Bytes None bytes index + ~current_region ] + | Pstringrefs, [[str]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Eight String None str + index ~current_region ] + | Pbytesrefs, [[bytes]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Eight Bytes None bytes + index ~current_region ] + | Pstring_load_16 true (* unsafe *), [[str]; [index]] -> + [ string_like_load_unsafe ~access_size:Sixteen String None str index + ~current_region ] + | Pbytes_load_16 true (* unsafe *), [[bytes]; [index]] -> + [ string_like_load_unsafe ~access_size:Sixteen Bytes None bytes index + ~current_region ] + | Pstring_load_32 (true (* unsafe *), mode), [[str]; [index]] -> + [ string_like_load_unsafe ~access_size:Thirty_two String (Some mode) str + index ~current_region ] + | Pbytes_load_32 (true (* unsafe *), mode), [[bytes]; [index]] -> + [ string_like_load_unsafe ~access_size:Thirty_two Bytes (Some mode) bytes + index ~current_region ] + | Pstring_load_64 (true (* unsafe *), mode), [[str]; [index]] -> + [ string_like_load_unsafe ~access_size:Sixty_four String (Some mode) str + index ~current_region ] + | Pbytes_load_64 (true (* unsafe *), mode), [[bytes]; [index]] -> + [ string_like_load_unsafe ~access_size:Sixty_four Bytes (Some mode) bytes + index ~current_region ] + | Pstring_load_16 false (* safe *), [[str]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Sixteen String None str + index ~current_region ] + | Pstring_load_32 (false (* safe *), mode), [[str]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Thirty_two String + (Some mode) str index ~current_region ] + | Pstring_load_64 (false (* safe *), mode), [[str]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Sixty_four String + (Some mode) str index ~current_region ] + | Pbytes_load_16 false (* safe *), [[bytes]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Sixteen Bytes None bytes + index ~current_region ] + | Pbytes_load_32 (false (* safe *), mode), [[bytes]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Thirty_two Bytes + (Some mode) bytes index ~current_region ] + | Pbytes_load_64 (false (* safe *), mode), [[bytes]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Sixty_four Bytes + (Some mode) bytes index ~current_region ] + | Pbytes_set_16 true (* unsafe *), [[bytes]; [index]; [new_value]] -> + [bytes_like_set_unsafe ~access_size:Sixteen Bytes bytes index new_value] + | Pbytes_set_32 true (* unsafe *), [[bytes]; [index]; [new_value]] -> + [bytes_like_set_unsafe ~access_size:Thirty_two Bytes bytes index new_value] + | Pbytes_set_64 true (* unsafe *), [[bytes]; [index]; [new_value]] -> + [bytes_like_set_unsafe ~access_size:Sixty_four Bytes bytes index new_value] + | Pbytes_set_16 false (* safe *), [[bytes]; [index]; [new_value]] -> + [ bytes_like_set_safe ~dbg ~size_int ~access_size:Sixteen Bytes bytes index + new_value ] + | Pbytes_set_32 false (* safe *), [[bytes]; [index]; [new_value]] -> + [ bytes_like_set_safe ~dbg ~size_int ~access_size:Thirty_two Bytes bytes + index new_value ] + | Pbytes_set_64 false (* safe *), [[bytes]; [index]; [new_value]] -> + [ bytes_like_set_safe ~dbg ~size_int ~access_size:Sixty_four Bytes bytes + index new_value ] + | Pisint { variant_only }, [[arg]] -> + [tag_int (Unary (Is_int { variant_only }, arg))] + | Pisout, [[arg1]; [arg2]] -> + [ tag_int + (Binary + ( Int_comp (I.Tagged_immediate, Yielding_bool (Lt Unsigned)), + arg1, + arg2 )) ] + | Pbintofint (bi, mode), [[arg]] -> let dst = standard_int_or_float_of_boxed_integer bi in - box_bint bi mode - (Unary (Num_conv { src = I_or_f.Tagged_immediate; dst }, arg)) - ~current_region - | Pintofbint bi, [arg] -> + [ box_bint bi mode + (Unary (Num_conv { src = I_or_f.Tagged_immediate; dst }, arg)) + ~current_region ] + | Pintofbint bi, [[arg]] -> let src = standard_int_or_float_of_boxed_integer bi in - Unary (Num_conv { src; dst = I_or_f.Tagged_immediate }, unbox_bint bi arg) - | Pcvtbint (source, destination, mode), [arg] -> - box_bint destination mode - (Unary - ( Num_conv - { src = standard_int_or_float_of_boxed_integer source; - dst = standard_int_or_float_of_boxed_integer destination - }, - unbox_bint source arg )) - ~current_region - | Pnegbint (bi, mode), [arg] -> - bint_unary_prim bi mode Neg arg ~current_region - | Paddbint (bi, mode), [arg1; arg2] -> - bint_binary_prim bi mode Add arg1 arg2 ~current_region - | Psubbint (bi, mode), [arg1; arg2] -> - bint_binary_prim bi mode Sub arg1 arg2 ~current_region - | Pmulbint (bi, mode), [arg1; arg2] -> - bint_binary_prim bi mode Mul arg1 arg2 ~current_region - | Pandbint (bi, mode), [arg1; arg2] -> - bint_binary_prim bi mode And arg1 arg2 ~current_region - | Porbint (bi, mode), [arg1; arg2] -> - bint_binary_prim bi mode Or arg1 arg2 ~current_region - | Pxorbint (bi, mode), [arg1; arg2] -> - bint_binary_prim bi mode Xor arg1 arg2 ~current_region - | Plslbint (bi, mode), [arg1; arg2] -> - bint_shift bi mode Lsl arg1 arg2 ~current_region - | Plsrbint (bi, mode), [arg1; arg2] -> - bint_shift bi mode Lsr arg1 arg2 ~current_region - | Pasrbint (bi, mode), [arg1; arg2] -> - bint_shift bi mode Asr arg1 arg2 ~current_region - | Poffsetint n, [arg] -> + [Unary (Num_conv { src; dst = I_or_f.Tagged_immediate }, unbox_bint bi arg)] + | Pcvtbint (source, destination, mode), [[arg]] -> + [ box_bint destination mode + (Unary + ( Num_conv + { src = standard_int_or_float_of_boxed_integer source; + dst = standard_int_or_float_of_boxed_integer destination + }, + unbox_bint source arg )) + ~current_region ] + | Pnegbint (bi, mode), [[arg]] -> + [bint_unary_prim bi mode Neg arg ~current_region] + | Paddbint (bi, mode), [[arg1]; [arg2]] -> + [bint_binary_prim bi mode Add arg1 arg2 ~current_region] + | Psubbint (bi, mode), [[arg1]; [arg2]] -> + [bint_binary_prim bi mode Sub arg1 arg2 ~current_region] + | Pmulbint (bi, mode), [[arg1]; [arg2]] -> + [bint_binary_prim bi mode Mul arg1 arg2 ~current_region] + | Pandbint (bi, mode), [[arg1]; [arg2]] -> + [bint_binary_prim bi mode And arg1 arg2 ~current_region] + | Porbint (bi, mode), [[arg1]; [arg2]] -> + [bint_binary_prim bi mode Or arg1 arg2 ~current_region] + | Pxorbint (bi, mode), [[arg1]; [arg2]] -> + [bint_binary_prim bi mode Xor arg1 arg2 ~current_region] + | Plslbint (bi, mode), [[arg1]; [arg2]] -> + [bint_shift bi mode Lsl arg1 arg2 ~current_region] + | Plsrbint (bi, mode), [[arg1]; [arg2]] -> + [bint_shift bi mode Lsr arg1 arg2 ~current_region] + | Pasrbint (bi, mode), [[arg1]; [arg2]] -> + [bint_shift bi mode Asr arg1 arg2 ~current_region] + | Poffsetint n, [[arg]] -> let const = Simple.const (Reg_width_const.tagged_immediate (Targetint_31_63.of_int n)) in - Binary (Int_arith (I.Tagged_immediate, Add), arg, Simple const) - | Pfield (index, sem), [arg] -> + [Binary (Int_arith (I.Tagged_immediate, Add), arg, Simple const)] + | Pfield (index, sem), [[arg]] -> let imm = Targetint_31_63.of_int index in check_non_negative_imm imm "Pfield"; let field = Simple.const (Reg_width_const.tagged_immediate imm) in @@ -949,8 +960,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) let block_access : P.Block_access_kind.t = Values { tag = Unknown; size = Unknown; field_kind = Any_value } in - Binary (Block_load (block_access, mutability), arg, Simple field) - | Pfloatfield (field, sem, mode), [arg] -> + [Binary (Block_load (block_access, mutability), arg, Simple field)] + | Pfloatfield (field, sem, mode), [[arg]] -> let imm = Targetint_31_63.of_int field in check_non_negative_imm imm "Pfloatfield"; let field = Simple.const (Reg_width_const.tagged_immediate imm) in @@ -958,11 +969,11 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) let block_access : P.Block_access_kind.t = Naked_floats { size = Unknown } in - box_float mode - (Binary (Block_load (block_access, mutability), arg, Simple field)) - ~current_region + [ box_float mode + (Binary (Block_load (block_access, mutability), arg, Simple field)) + ~current_region ] | ( Psetfield (index, immediate_or_pointer, initialization_or_assignment), - [block; value] ) -> + [[block]; [value]] ) -> let field_kind = convert_block_access_field_kind immediate_or_pointer in let imm = Targetint_31_63.of_int index in check_non_negative_imm imm "Psetfield"; @@ -971,9 +982,10 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) let block_access : P.Block_access_kind.t = Values { tag = Unknown; size = Unknown; field_kind } in - Ternary - (Block_set (block_access, init_or_assign), block, Simple field, value) - | Psetfloatfield (field, initialization_or_assignment), [block; value] -> + [ Ternary + (Block_set (block_access, init_or_assign), block, Simple field, value) + ] + | Psetfloatfield (field, initialization_or_assignment), [[block]; [value]] -> let imm = Targetint_31_63.of_int field in check_non_negative_imm imm "Psetfloatfield"; let field = Simple.const (Reg_width_const.tagged_immediate imm) in @@ -981,58 +993,58 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) Naked_floats { size = Unknown } in let init_or_assign = convert_init_or_assign initialization_or_assignment in - Ternary - ( Block_set (block_access, init_or_assign), - block, - Simple field, - unbox_float value ) - | Pdivint Unsafe, [arg1; arg2] -> - Binary (Int_arith (I.Tagged_immediate, Div), arg1, arg2) - | Pdivint Safe, [arg1; arg2] -> - checked_arith_op ~dbg None Div None arg1 arg2 ~current_region - | Pmodint Safe, [arg1; arg2] -> - checked_arith_op ~dbg None Mod None arg1 arg2 ~current_region - | Pdivbint { size = Pint32; is_safe = Safe; mode }, [arg1; arg2] -> - checked_arith_op ~dbg (Some Pint32) Div (Some mode) arg1 arg2 - ~current_region - | Pmodbint { size = Pint32; is_safe = Safe; mode }, [arg1; arg2] -> - checked_arith_op ~dbg (Some Pint32) Mod (Some mode) arg1 arg2 - ~current_region - | Pdivbint { size = Pint64; is_safe = Safe; mode }, [arg1; arg2] -> - checked_arith_op ~dbg (Some Pint64) Div (Some mode) arg1 arg2 - ~current_region - | Pmodbint { size = Pint64; is_safe = Safe; mode }, [arg1; arg2] -> - checked_arith_op ~dbg (Some Pint64) Mod (Some mode) arg1 arg2 - ~current_region - | Pdivbint { size = Pnativeint; is_safe = Safe; mode }, [arg1; arg2] -> - checked_arith_op ~dbg (Some Pnativeint) Div (Some mode) arg1 arg2 - ~current_region - | Pmodbint { size = Pnativeint; is_safe = Safe; mode }, [arg1; arg2] -> - checked_arith_op ~dbg (Some Pnativeint) Mod (Some mode) arg1 arg2 - ~current_region - | Parrayrefu array_ref_kind, [array; index] -> + [ Ternary + ( Block_set (block_access, init_or_assign), + block, + Simple field, + unbox_float value ) ] + | Pdivint Unsafe, [[arg1]; [arg2]] -> + [Binary (Int_arith (I.Tagged_immediate, Div), arg1, arg2)] + | Pdivint Safe, [[arg1]; [arg2]] -> + [checked_arith_op ~dbg None Div None arg1 arg2 ~current_region] + | Pmodint Safe, [[arg1]; [arg2]] -> + [checked_arith_op ~dbg None Mod None arg1 arg2 ~current_region] + | Pdivbint { size = Pint32; is_safe = Safe; mode }, [[arg1]; [arg2]] -> + [ checked_arith_op ~dbg (Some Pint32) Div (Some mode) arg1 arg2 + ~current_region ] + | Pmodbint { size = Pint32; is_safe = Safe; mode }, [[arg1]; [arg2]] -> + [ checked_arith_op ~dbg (Some Pint32) Mod (Some mode) arg1 arg2 + ~current_region ] + | Pdivbint { size = Pint64; is_safe = Safe; mode }, [[arg1]; [arg2]] -> + [ checked_arith_op ~dbg (Some Pint64) Div (Some mode) arg1 arg2 + ~current_region ] + | Pmodbint { size = Pint64; is_safe = Safe; mode }, [[arg1]; [arg2]] -> + [ checked_arith_op ~dbg (Some Pint64) Mod (Some mode) arg1 arg2 + ~current_region ] + | Pdivbint { size = Pnativeint; is_safe = Safe; mode }, [[arg1]; [arg2]] -> + [ checked_arith_op ~dbg (Some Pnativeint) Div (Some mode) arg1 arg2 + ~current_region ] + | Pmodbint { size = Pnativeint; is_safe = Safe; mode }, [[arg1]; [arg2]] -> + [ checked_arith_op ~dbg (Some Pnativeint) Mod (Some mode) arg1 arg2 + ~current_region ] + | Parrayrefu array_ref_kind, [[array]; [index]] -> (* For this and the following cases we will end up relying on the backend to CSE the two accesses to the array's header word in the [Pgenarray] case. *) - match_on_array_ref_kind ~array array_ref_kind - (array_load_unsafe ~array ~index ~current_region) - | Parrayrefs array_ref_kind, [array; index] -> - check_array_access ~dbg ~array ~index - (match_on_array_ref_kind ~array array_ref_kind - (array_load_unsafe ~array ~index ~current_region)) - | Parraysetu array_set_kind, [array; index; new_value] -> - match_on_array_set_kind ~array array_set_kind - (array_set_unsafe ~array ~index ~new_value) - | Parraysets array_set_kind, [array; index; new_value] -> - check_array_access ~dbg ~array ~index - (match_on_array_set_kind ~array array_set_kind - (array_set_unsafe ~array ~index ~new_value)) - | Pbytessetu (* unsafe *), [bytes; index; new_value] -> - bytes_like_set_unsafe ~access_size:Eight Bytes bytes index new_value - | Pbytessets, [bytes; index; new_value] -> - bytes_like_set_safe ~dbg ~size_int ~access_size:Eight Bytes bytes index - new_value - | Poffsetref n, [block] -> + [ match_on_array_ref_kind ~array array_ref_kind + (array_load_unsafe ~array ~index ~current_region) ] + | Parrayrefs array_ref_kind, [[array]; [index]] -> + [ check_array_access ~dbg ~array ~index + (match_on_array_ref_kind ~array array_ref_kind + (array_load_unsafe ~array ~index ~current_region)) ] + | Parraysetu array_set_kind, [[array]; [index]; [new_value]] -> + [ match_on_array_set_kind ~array array_set_kind + (array_set_unsafe ~array ~index ~new_value) ] + | Parraysets array_set_kind, [[array]; [index]; [new_value]] -> + [ check_array_access ~dbg ~array ~index + (match_on_array_set_kind ~array array_set_kind + (array_set_unsafe ~array ~index ~new_value)) ] + | Pbytessetu (* unsafe *), [[bytes]; [index]; [new_value]] -> + [bytes_like_set_unsafe ~access_size:Eight Bytes bytes index new_value] + | Pbytessets, [[bytes]; [index]; [new_value]] -> + [ bytes_like_set_safe ~dbg ~size_int ~access_size:Eight Bytes bytes index + new_value ] + | Poffsetref n, [[block]] -> let block_access : P.Block_access_kind.t = Values { tag = Known Tag.Scannable.zero; @@ -1052,40 +1064,52 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) Simple (Simple.const_int (Targetint_31_63.of_int n)), old_ref_value )) in - Ternary - ( Block_set - (block_access, Assignment (Alloc_mode.For_assignments.local ())), - block, - Simple Simple.const_zero, - new_ref_value ) + [ Ternary + ( Block_set + (block_access, Assignment (Alloc_mode.For_assignments.local ())), + block, + Simple Simple.const_zero, + new_ref_value ) ] | Pctconst const, _ -> ( match const with - | Big_endian -> Simple (Simple.const_bool big_endian) + | Big_endian -> [Simple (Simple.const_bool big_endian)] | Word_size -> - Simple (Simple.const_int (Targetint_31_63.of_int (8 * size_int))) + [Simple (Simple.const_int (Targetint_31_63.of_int (8 * size_int)))] | Int_size -> - Simple (Simple.const_int (Targetint_31_63.of_int ((8 * size_int) - 1))) + [Simple (Simple.const_int (Targetint_31_63.of_int ((8 * size_int) - 1)))] | Max_wosize -> - Simple - (Simple.const_int - (Targetint_31_63.of_int - ((1 lsl ((8 * size_int) - (10 + Config.profinfo_width))) - 1))) - | Ostype_unix -> Simple (Simple.const_bool (Sys.os_type = "Unix")) - | Ostype_win32 -> Simple (Simple.const_bool (Sys.os_type = "Win32")) - | Ostype_cygwin -> Simple (Simple.const_bool (Sys.os_type = "Cygwin")) + [ Simple + (Simple.const_int + (Targetint_31_63.of_int + ((1 lsl ((8 * size_int) - (10 + Config.profinfo_width))) - 1))) + ] + | Ostype_unix -> [Simple (Simple.const_bool (Sys.os_type = "Unix"))] + | Ostype_win32 -> [Simple (Simple.const_bool (Sys.os_type = "Win32"))] + | Ostype_cygwin -> [Simple (Simple.const_bool (Sys.os_type = "Cygwin"))] | Backend_type -> - Simple Simple.const_zero (* constructor 0 is the same as Native here *)) - | Pbswap16, [arg] -> - tag_int - (Unary (Int_arith (Naked_immediate, Swap_byte_endianness), untag_int arg)) - | Pbbswap (Pint32, mode), [arg] -> - bbswap Naked_int32 Naked_int32 mode arg ~current_region - | Pbbswap (Pint64, mode), [arg] -> - bbswap Naked_int64 Naked_int64 mode arg ~current_region - | Pbbswap (Pnativeint, mode), [arg] -> - bbswap Naked_nativeint Naked_nativeint mode arg ~current_region - | Pint_as_pointer, [arg] -> Unary (Int_as_pointer, arg) + [Simple Simple.const_zero] (* constructor 0 is the same as Native here *)) + | Pbswap16, [[arg]] -> + [ tag_int + (Unary (Int_arith (Naked_immediate, Swap_byte_endianness), untag_int arg)) + ] + | Pbbswap (Pint32, mode), [[arg]] -> + [bbswap Naked_int32 Naked_int32 mode arg ~current_region] + | Pbbswap (Pint64, mode), [[arg]] -> + [bbswap Naked_int64 Naked_int64 mode arg ~current_region] + | Pbbswap (Pnativeint, mode), [[arg]] -> + [bbswap Naked_nativeint Naked_nativeint mode arg ~current_region] + | Pint_as_pointer, [[arg]] -> [Unary (Int_as_pointer, arg)] | Pbigarrayref (unsafe, num_dimensions, kind, layout), args -> ( + let args = + List.map + (function + | [arg] -> arg + | [] | _ :: _ :: _ -> + Misc.fatal_errorf "Non-singleton arguments for Pbigarrayref: %a %a" + Printlambda.primitive prim H.print_list_of_lists_of_simple_or_prim + args) + args + in match P.Bigarray_kind.from_lambda kind, P.Bigarray_layout.from_lambda layout with @@ -1102,7 +1126,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) bigarray_box_or_tag_raw_value_to_read kind Alloc_mode.For_allocations.heap in - box (bigarray_load ~dbg ~unsafe kind layout b indexes) + [box (bigarray_load ~dbg ~unsafe kind layout b indexes)] | None, _ -> Misc.fatal_errorf "Lambda_to_flambda_primitives.convert_lprim: Pbigarrayref primitives \ @@ -1112,6 +1136,16 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) "Lambda_to_flambda_primitives.convert_lprim: Pbigarrayref primitives \ with an unknown layout should have been removed by Lambda_to_flambda.") | Pbigarrayset (unsafe, num_dimensions, kind, layout), args -> ( + let args = + List.map + (function + | [arg] -> arg + | [] | _ :: _ :: _ -> + Misc.fatal_errorf "Non-singleton arguments for Pbigarrayset: %a %a" + Printlambda.primitive prim H.print_list_of_lists_of_simple_or_prim + args) + args + in match P.Bigarray_kind.from_lambda kind, P.Bigarray_layout.from_lambda layout with @@ -1126,7 +1160,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) | [] -> Misc.fatal_errorf "Pbigarrayset is missing its arguments" in let unbox = bigarray_unbox_or_untag_value_to_store kind in - bigarray_set ~dbg ~unsafe kind layout b indexes (unbox value) + [bigarray_set ~dbg ~unsafe kind layout b indexes (unbox value)] | None, _ -> Misc.fatal_errorf "Lambda_to_flambda_primitives.convert_lprim: Pbigarrayref primitives \ @@ -1135,69 +1169,69 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) Misc.fatal_errorf "Lambda_to_flambda_primitives.convert_lprim: Pbigarrayref primitives \ with an unknown layout should have been removed by Lambda_to_flambda.") - | Pbigarraydim dimension, [arg] -> - tag_int (Unary (Bigarray_length { dimension }, arg)) - | Pbigstring_load_16 true (* unsafe *), [big_str; index] -> - string_like_load_unsafe ~access_size:Sixteen Bigstring None big_str index - ~current_region - | Pbigstring_load_32 (true (* unsafe *), mode), [big_str; index] -> - string_like_load_unsafe ~access_size:Thirty_two Bigstring (Some mode) - big_str index ~current_region - | Pbigstring_load_64 (true (* unsafe *), mode), [big_str; index] -> - string_like_load_unsafe ~access_size:Sixty_four Bigstring (Some mode) - big_str index ~current_region - | Pbigstring_load_16 false (* safe *), [big_str; index] -> - string_like_load_safe ~dbg ~size_int ~access_size:Sixteen Bigstring None - big_str index ~current_region - | Pbigstring_load_32 (false (* safe *), mode), [big_str; index] -> - string_like_load_safe ~dbg ~size_int ~access_size:Thirty_two Bigstring - (Some mode) big_str index ~current_region - | Pbigstring_load_64 (false (* safe *), mode), [big_str; index] -> - string_like_load_safe ~dbg ~size_int ~access_size:Sixty_four Bigstring - (Some mode) big_str index ~current_region - | Pbigstring_set_16 true (* unsafe *), [bigstring; index; new_value] -> - bytes_like_set_unsafe ~access_size:Sixteen Bigstring bigstring index - new_value - | Pbigstring_set_32 true (* unsafe *), [bigstring; index; new_value] -> - bytes_like_set_unsafe ~access_size:Thirty_two Bigstring bigstring index - new_value - | Pbigstring_set_64 true (* unsafe *), [bigstring; index; new_value] -> - bytes_like_set_unsafe ~access_size:Sixty_four Bigstring bigstring index - new_value - | Pbigstring_set_16 false (* safe *), [bigstring; index; new_value] -> - bytes_like_set_safe ~dbg ~size_int ~access_size:Sixteen Bigstring bigstring - index new_value - | Pbigstring_set_32 false (* safe *), [bigstring; index; new_value] -> - bytes_like_set_safe ~dbg ~size_int ~access_size:Thirty_two Bigstring - bigstring index new_value - | Pbigstring_set_64 false (* safe *), [bigstring; index; new_value] -> - bytes_like_set_safe ~dbg ~size_int ~access_size:Sixty_four Bigstring - bigstring index new_value - | Pcompare_ints, [i1; i2] -> - tag_int - (Binary - ( Int_comp - (Tagged_immediate, Yielding_int_like_compare_functions Signed), - i1, - i2 )) - | Pcompare_floats, [f1; f2] -> - tag_int - (Binary - ( Float_comp (Yielding_int_like_compare_functions ()), - Prim (Unary (Unbox_number Naked_float, f1)), - Prim (Unary (Unbox_number Naked_float, f2)) )) - | Pcompare_bints int_kind, [i1; i2] -> + | Pbigarraydim dimension, [[arg]] -> + [tag_int (Unary (Bigarray_length { dimension }, arg))] + | Pbigstring_load_16 true (* unsafe *), [[big_str]; [index]] -> + [ string_like_load_unsafe ~access_size:Sixteen Bigstring None big_str index + ~current_region ] + | Pbigstring_load_32 (true (* unsafe *), mode), [[big_str]; [index]] -> + [ string_like_load_unsafe ~access_size:Thirty_two Bigstring (Some mode) + big_str index ~current_region ] + | Pbigstring_load_64 (true (* unsafe *), mode), [[big_str]; [index]] -> + [ string_like_load_unsafe ~access_size:Sixty_four Bigstring (Some mode) + big_str index ~current_region ] + | Pbigstring_load_16 false (* safe *), [[big_str]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Sixteen Bigstring None + big_str index ~current_region ] + | Pbigstring_load_32 (false (* safe *), mode), [[big_str]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Thirty_two Bigstring + (Some mode) big_str index ~current_region ] + | Pbigstring_load_64 (false (* safe *), mode), [[big_str]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Sixty_four Bigstring + (Some mode) big_str index ~current_region ] + | Pbigstring_set_16 true (* unsafe *), [[bigstring]; [index]; [new_value]] -> + [ bytes_like_set_unsafe ~access_size:Sixteen Bigstring bigstring index + new_value ] + | Pbigstring_set_32 true (* unsafe *), [[bigstring]; [index]; [new_value]] -> + [ bytes_like_set_unsafe ~access_size:Thirty_two Bigstring bigstring index + new_value ] + | Pbigstring_set_64 true (* unsafe *), [[bigstring]; [index]; [new_value]] -> + [ bytes_like_set_unsafe ~access_size:Sixty_four Bigstring bigstring index + new_value ] + | Pbigstring_set_16 false (* safe *), [[bigstring]; [index]; [new_value]] -> + [ bytes_like_set_safe ~dbg ~size_int ~access_size:Sixteen Bigstring + bigstring index new_value ] + | Pbigstring_set_32 false (* safe *), [[bigstring]; [index]; [new_value]] -> + [ bytes_like_set_safe ~dbg ~size_int ~access_size:Thirty_two Bigstring + bigstring index new_value ] + | Pbigstring_set_64 false (* safe *), [[bigstring]; [index]; [new_value]] -> + [ bytes_like_set_safe ~dbg ~size_int ~access_size:Sixty_four Bigstring + bigstring index new_value ] + | Pcompare_ints, [[i1]; [i2]] -> + [ tag_int + (Binary + ( Int_comp + (Tagged_immediate, Yielding_int_like_compare_functions Signed), + i1, + i2 )) ] + | Pcompare_floats, [[f1]; [f2]] -> + [ tag_int + (Binary + ( Float_comp (Yielding_int_like_compare_functions ()), + Prim (Unary (Unbox_number Naked_float, f1)), + Prim (Unary (Unbox_number Naked_float, f2)) )) ] + | Pcompare_bints int_kind, [[i1]; [i2]] -> let unboxing_kind = boxable_number_of_boxed_integer int_kind in - tag_int - (Binary - ( Int_comp - ( standard_int_of_boxed_integer int_kind, - Yielding_int_like_compare_functions Signed ), - Prim (Unary (Unbox_number unboxing_kind, i1)), - Prim (Unary (Unbox_number unboxing_kind, i2)) )) + [ tag_int + (Binary + ( Int_comp + ( standard_int_of_boxed_integer int_kind, + Yielding_int_like_compare_functions Signed ), + Prim (Unary (Unbox_number unboxing_kind, i1)), + Prim (Unary (Unbox_number unboxing_kind, i2)) )) ] | Pprobe_is_enabled { name }, [] -> - tag_int (Nullary (Probe_is_enabled { name })) - | Pobj_dup, [v] -> Unary (Obj_dup, v) + [tag_int (Nullary (Probe_is_enabled { name }))] + | Pobj_dup, [[v]] -> [Unary (Obj_dup, v)] | ( ( Pmodint Unsafe | Pdivbint { is_safe = Unsafe; size = _; mode = _ } | Pmodbint { is_safe = Unsafe; size = _; mode = _ } @@ -1207,12 +1241,13 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) "Closure_conversion.convert_primitive: Primitive %a (%a) shouldn't be \ here, either a bug in [Closure_conversion] or the wrong number of \ arguments" - Printlambda.primitive prim H.print_list_of_simple_or_prim args + Printlambda.primitive prim H.print_list_of_lists_of_simple_or_prim args | Pprobe_is_enabled _, _ :: _ -> Misc.fatal_errorf "Closure_conversion.convert_primitive: Wrong arity for nullary primitive \ %a (%a)" - Printlambda.primitive prim H.print_list_of_simple_or_prim args + Printlambda.primitive prim H.print_list_of_simple_or_prim + (List.flatten args) | ( ( Pfield _ | Pnegint | Pnot | Poffsetint _ | Pintoffloat | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Pstringlength | Pbyteslength | Pbintofint _ | Pintofbint _ | Pnegbint _ | Popaque _ | Pduprecord _ | Parraylength _ @@ -1220,11 +1255,11 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) | Pbbswap _ | Pisint _ | Pint_as_pointer | Pbigarraydim _ | Pobj_dup | Pobj_magic _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ ), - ([] | _ :: _ :: _) ) -> + ([] | _ :: _ :: _ | [([] | _ :: _ :: _)]) ) -> Misc.fatal_errorf "Closure_conversion.convert_primitive: Wrong arity for unary primitive \ %a (%a)" - Printlambda.primitive prim H.print_list_of_simple_or_prim args + Printlambda.primitive prim H.print_list_of_lists_of_simple_or_prim args | ( ( Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pdivint _ | Pmodint _ | Psetfield _ | Pintcomp _ | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pfloatcomp _ @@ -1240,11 +1275,15 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) | Parrayrefs (Pgenarray_ref _ | Paddrarray_ref | Pintarray_ref | Pfloatarray_ref _) | Pcompare_ints | Pcompare_floats | Pcompare_bints _ ), - ([] | [_] | _ :: _ :: _ :: _) ) -> + ( [] + | [_] + | _ :: _ :: _ :: _ + | [_; ([] | _ :: _ :: _)] + | [([] | _ :: _ :: _); _] ) ) -> Misc.fatal_errorf "Closure_conversion.convert_primitive: Wrong arity for binary primitive \ %a (%a)" - Printlambda.primitive prim H.print_list_of_simple_or_prim args + Printlambda.primitive prim H.print_list_of_lists_of_simple_or_prim args | ( ( Psetfield_computed _ | Pbytessetu | Pbytessets | Parraysetu (Pgenarray_set _ | Paddrarray_set _ | Pintarray_set | Pfloatarray_set) @@ -1252,11 +1291,17 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) (Pgenarray_set _ | Paddrarray_set _ | Pintarray_set | Pfloatarray_set) | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _ ), - ([] | [_] | [_; _] | _ :: _ :: _ :: _ :: _) ) -> + ( [] + | [_] + | [_; _] + | _ :: _ :: _ :: _ :: _ + | [_; _; ([] | _ :: _ :: _)] + | [_; ([] | _ :: _ :: _); _] + | [([] | _ :: _ :: _); _; _] ) ) -> Misc.fatal_errorf "Closure_conversion.convert_primitive: Wrong arity for ternary primitive \ %a (%a)" - Printlambda.primitive prim H.print_list_of_simple_or_prim args + Printlambda.primitive prim H.print_list_of_lists_of_simple_or_prim args | ( ( Pignore | Psequand | Psequor | Pbytes_of_string | Pbytes_to_string | Parray_of_iarray | Parray_to_iarray ), _ ) -> @@ -1272,9 +1317,8 @@ module Acc = Closure_conversion_aux.Acc module Expr_with_acc = Closure_conversion_aux.Expr_with_acc let convert_and_bind acc ~big_endian exn_cont ~register_const0 - (prim : L.primitive) ~(args : Simple.t list) (dbg : Debuginfo.t) - ~current_region (cont : Acc.t -> Flambda.Named.t option -> Expr_with_acc.t) - : Expr_with_acc.t = - let expr = convert_lprim ~big_endian prim args dbg ~current_region in - H.bind_rec acc exn_cont ~register_const0 expr dbg (fun acc named -> - cont acc (Some named)) + (prim : L.primitive) ~(args : Simple.t list list) (dbg : Debuginfo.t) + ~current_region (cont : Acc.t -> Flambda.Named.t list -> Expr_with_acc.t) : + Expr_with_acc.t = + let exprs = convert_lprim ~big_endian prim args dbg ~current_region in + H.bind_recs acc exn_cont ~register_const0 exprs dbg cont diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli index 5bb20179a34..db9f4e4bc04 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli @@ -23,8 +23,8 @@ val convert_and_bind : Exn_continuation.t option -> register_const0:(Acc.t -> Static_const.t -> string -> Acc.t * Symbol.t) -> Lambda.primitive -> - args:Simple.t list -> + args:Simple.t list list -> Debuginfo.t -> current_region:Variable.t -> - (Acc.t -> Flambda.Named.t option -> Expr_with_acc.t) -> + (Acc.t -> Flambda.Named.t list -> Expr_with_acc.t) -> Expr_with_acc.t diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml index 1e9be4d4dda..b1782f280a7 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml @@ -71,6 +71,12 @@ let print_list_of_simple_or_prim ppf simple_or_prim_list = (Format.pp_print_list ~pp_sep:Format.pp_print_space print_simple_or_prim) simple_or_prim_list +let print_list_of_lists_of_simple_or_prim ppf simple_or_prim_list_list = + Format.fprintf ppf "@[(%a)@]" + (Format.pp_print_list ~pp_sep:Format.pp_print_space + print_list_of_simple_or_prim) + simple_or_prim_list_list + let raise_exn_for_failure acc ~dbg exn_cont exn_bucket = let exn_handler = Exn_continuation.exn_handler exn_cont in let trap_action = @@ -316,3 +322,13 @@ and bind_rec_primitive acc exn_cont ~register_const0 (prim : simple_or_prim) Let_with_acc.create acc (Bound_pattern.singleton var') named ~body in bind_rec acc exn_cont ~register_const0 p dbg cont + +let rec bind_recs acc exn_cont ~register_const0 (prims : expr_primitive list) + (dbg : Debuginfo.t) (cont : Acc.t -> Named.t list -> Expr_with_acc.t) : + Expr_with_acc.t = + match prims with + | [] -> cont acc [] + | prim :: prims -> + bind_rec acc exn_cont ~register_const0 prim dbg (fun acc named -> + bind_recs acc exn_cont ~register_const0 prims dbg (fun acc nameds -> + cont acc (named :: nameds))) diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.mli b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.mli index 63809376937..feda80526e7 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.mli @@ -52,13 +52,16 @@ val print_simple_or_prim : Format.formatter -> simple_or_prim -> unit val print_list_of_simple_or_prim : Format.formatter -> simple_or_prim list -> unit +val print_list_of_lists_of_simple_or_prim : + Format.formatter -> simple_or_prim list list -> unit + open Closure_conversion_aux -val bind_rec : +val bind_recs : Acc.t -> Exn_continuation.t option -> register_const0:(Acc.t -> Static_const.t -> string -> Acc.t * Symbol.t) -> - expr_primitive -> + expr_primitive list -> Debuginfo.t -> - (Acc.t -> Flambda.Named.t -> Expr_with_acc.t) -> + (Acc.t -> Flambda.Named.t list -> Expr_with_acc.t) -> Expr_with_acc.t diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index adc30eec738..7f3bca59f4a 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/lambda/lambda.ml @@ -1440,9 +1440,12 @@ let primitive_result_layout (p : primitive) = | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pbox_float _ -> layout_float | Punbox_float -> Punboxed_float - | Pccall _p -> - (* CR ncourant: use native_repr *) + | Pccall { prim_native_repr_res = _, Untagged_int; _} -> layout_int + | Pccall { prim_native_repr_res = _, Unboxed_float; _} -> layout_float + | Pccall { prim_native_repr_res = _, Same_as_ocaml_repr; _} -> layout_any_value + | Pccall { prim_native_repr_res = _, Unboxed_integer bi; _} -> + layout_boxedint bi | Praise _ -> layout_bottom | Psequor | Psequand | Pnot | Pnegint | Paddint | Psubint | Pmulint