diff --git a/middle_end/flambda2/classic_mode_types/value_approximation.ml b/middle_end/flambda2/classic_mode_types/value_approximation.ml index 898cb7667b0..15db0edb778 100644 --- a/middle_end/flambda2/classic_mode_types/value_approximation.ml +++ b/middle_end/flambda2/classic_mode_types/value_approximation.ml @@ -28,7 +28,8 @@ type 'code t = code : 'code; symbol : Symbol.t option } - | Block_approximation of Tag.t * 'code t array * Alloc_mode.For_types.t + | Block_approximation of + Tag.Scannable.t * 'code t array * Alloc_mode.For_types.t let rec print fmt = function | Value_unknown -> Format.fprintf fmt "?" @@ -41,7 +42,8 @@ let rec print fmt = function if len < 1 then Format.fprintf fmt "{}" else ( - Format.fprintf fmt "@[{%a:%a" Tag.print tag print fields.(0); + Format.fprintf fmt "@[{%a:%a" Tag.Scannable.print tag print + fields.(0); for i = 1 to len - 1 do Format.fprintf fmt "@ %a" print fields.(i) done; diff --git a/middle_end/flambda2/classic_mode_types/value_approximation.mli b/middle_end/flambda2/classic_mode_types/value_approximation.mli index 1b792af523b..3553870c567 100644 --- a/middle_end/flambda2/classic_mode_types/value_approximation.mli +++ b/middle_end/flambda2/classic_mode_types/value_approximation.mli @@ -28,7 +28,8 @@ type 'code t = code : 'code; symbol : Symbol.t option } - | Block_approximation of Tag.t * 'code t array * Alloc_mode.For_types.t + | Block_approximation of + Tag.Scannable.t * 'code t array * Alloc_mode.For_types.t val print : Format.formatter -> 'a t -> unit diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 715644f7316..50f424337ce 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -1053,7 +1053,6 @@ let close_let acc env let_bound_ids_with_kinds user_visible defining_expr ( Variadic (Make_block (Values (tag, _), Immutable, alloc_mode), fields), _ ) -> ( - let tag' = Tag.Scannable.to_tag tag in let approxs = List.map (find_value_approximation body_env) fields |> Array.of_list in @@ -1071,7 +1070,7 @@ let close_let acc env let_bound_ids_with_kinds user_visible defining_expr let acc = Acc.add_symbol_approximation acc sym (Value_approximation.Block_approximation - (tag', approxs, Alloc_mode.For_allocations.as_type alloc_mode)) + (tag, approxs, Alloc_mode.For_allocations.as_type alloc_mode)) in body acc body_env | Computed_static static_fields -> @@ -1095,7 +1094,7 @@ let close_let acc env let_bound_ids_with_kinds user_visible defining_expr in let approx = Value_approximation.Block_approximation - (tag', approxs, Alloc_mode.For_allocations.as_type alloc_mode) + (tag, 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 @@ -1105,7 +1104,7 @@ let close_let acc env let_bound_ids_with_kinds user_visible defining_expr defining_expr ~body | Dynamic_block -> let body_env = - Env.add_block_approximation body_env var tag' approxs + Env.add_block_approximation body_env var tag approxs (Alloc_mode.For_allocations.as_type alloc_mode) in bind acc body_env) diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml index 6e04ec39533..8645224804a 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml @@ -494,7 +494,6 @@ module Acc = struct | Tagged_immediate i -> Value_int i | Dynamically_computed _ -> Value_unknown in - let tag = Tag.Scannable.to_tag tag in let fields = List.map approx_of_field fields |> Array.of_list in Block_approximation (tag, fields, Alloc_mode.For_types.unknown ()) else Value_unknown diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli index 29647fe909e..69d1139c06c 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli @@ -169,7 +169,7 @@ module Env : sig val add_block_approximation : t -> Variable.t -> - Tag.t -> + Tag.Scannable.t -> value_approximation array -> Alloc_mode.For_types.t -> t 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 49a152c5220..6d7c6a1e831 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -999,8 +999,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in let mutability = Mutability.from_lambda mutability in let tag = Tag.Scannable.create_exn tag in - let shape = P.Mixed_block_kind.from_lambda shape in - [Variadic (Make_mixed_block (tag, shape, mutability, mode), args)] + let shape = K.Mixed_block_shape.from_lambda shape in + [Variadic (Make_block (Mixed (tag, shape), mutability, mode), args)] | Pmakearray (lambda_array_kind, mutability, mode), _ -> ( let args = List.flatten args in let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in @@ -1447,7 +1447,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) Naked_floats { size = Unknown } in [Binary (Block_load (block_access, mutability), arg, Simple field)] - | Pmixedfield (field, read, sem), [[arg]] -> ( + | Pmixedfield (field, read, shape, sem), [[arg]] -> ( let imm = Targetint_31_63.of_int field in check_non_negative_imm imm "Pmixedfield"; let field = Simple.const (Reg_width_const.tagged_immediate imm) in @@ -1460,11 +1460,11 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Mread_flat_suffix read -> Flat_suffix (match read with - | Flat_read flat_element -> - P.Mixed_block_flat_element.from_lambda flat_element - | Flat_read_float_boxed _ -> Float_boxed) + | Flat_read flat_element -> K.from_lambda_flat_element flat_element + | Flat_read_float_boxed _ -> K.naked_float) in - Mixed { tag = Unknown; field_kind; size = Unknown } + let shape = K.Mixed_block_shape.from_lambda shape in + Mixed { tag = Unknown; field_kind; shape; size = Unknown } in let block_access : H.expr_primitive = Binary (Block_load (block_access, mutability), arg, Simple field) @@ -1510,7 +1510,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) [ Ternary (Block_set (block_access, init_or_assign), block, Simple field, value) ] - | ( Psetmixedfield (field, write, initialization_or_assignment), + | ( Psetmixedfield (field, write, shape, initialization_or_assignment), [[block]; [value]] ) -> let imm = Targetint_31_63.of_int field in check_non_negative_imm imm "Psetmixedfield"; @@ -1523,9 +1523,10 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) Value_prefix (convert_block_access_field_kind immediate_or_pointer) | Mwrite_flat_suffix flat -> - Flat_suffix (P.Mixed_block_flat_element.from_lambda flat)); - size = Unknown; - tag = Unknown + Flat_suffix (K.from_lambda_flat_element flat)); + shape = K.Mixed_block_shape.from_lambda shape; + tag = Unknown; + size = Unknown } in let init_or_assign = convert_init_or_assign initialization_or_assignment in diff --git a/middle_end/flambda2/identifiers/reg_width_const.ml b/middle_end/flambda2/identifiers/reg_width_const.ml index 543198db83f..8d0de4af283 100644 --- a/middle_end/flambda2/identifiers/reg_width_const.ml +++ b/middle_end/flambda2/identifiers/reg_width_const.ml @@ -40,3 +40,20 @@ let is_tagged_immediate t = | Naked_immediate _ | Naked_float _ | Naked_float32 _ | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _ | Naked_vec128 _ -> None + +let of_int_of_kind (kind : Flambda_kind.t) i = + match kind with + | Value -> tagged_immediate (Targetint_31_63.of_int i) + | Naked_number Naked_float -> + naked_float (Numeric_types.Float_by_bit_pattern.create (float_of_int i)) + | Naked_number Naked_float32 -> + naked_float32 (Numeric_types.Float32_by_bit_pattern.create (float_of_int i)) + | Naked_number Naked_immediate -> naked_immediate (Targetint_31_63.of_int i) + | Naked_number Naked_int32 -> naked_int32 (Int32.of_int i) + | Naked_number Naked_int64 -> naked_int64 (Int64.of_int i) + | Naked_number Naked_nativeint -> naked_nativeint (Targetint_32_64.of_int i) + | Naked_number Naked_vec128 -> + let i = Int64.of_int i in + naked_vec128 (Vector_types.Vec128.Bit_pattern.of_bits { high = i; low = i }) + | Region | Rec_info -> + Misc.fatal_errorf "Invalid kind %a" Flambda_kind.print kind diff --git a/middle_end/flambda2/identifiers/reg_width_const.mli b/middle_end/flambda2/identifiers/reg_width_const.mli index 25d85ca31bc..c52fea0154c 100644 --- a/middle_end/flambda2/identifiers/reg_width_const.mli +++ b/middle_end/flambda2/identifiers/reg_width_const.mli @@ -25,3 +25,7 @@ val of_descr : Descr.t -> t val is_naked_immediate : t -> Targetint_31_63.t option val is_tagged_immediate : t -> Targetint_31_63.t option + +(** Create a numeric constant of the given kind ([Region] and [Rec_info] are + forbidden). *) +val of_int_of_kind : Flambda_kind.t -> int -> t diff --git a/middle_end/flambda2/kinds/flambda_kind.ml b/middle_end/flambda2/kinds/flambda_kind.ml index efa8ac4c9c9..047ad308d49 100644 --- a/middle_end/flambda2/kinds/flambda_kind.ml +++ b/middle_end/flambda2/kinds/flambda_kind.ml @@ -79,6 +79,16 @@ let region = Region let rec_info = Rec_info +let from_lambda_flat_element (elt : Lambda.flat_element) = + match elt with + | Imm -> Value + | Float_boxed -> Naked_number Naked_float + | Float64 -> Naked_number Naked_float + | Float32 -> Naked_number Naked_float32 + | Bits32 -> Naked_number Naked_int32 + | Bits64 -> Naked_number Naked_int64 + | Word -> Naked_number Naked_nativeint + let to_lambda (t : t) : Lambda.layout = match t with | Value -> Pvalue Pgenval @@ -163,6 +173,110 @@ let is_naked_float t = | Region | Rec_info -> false +module Mixed_block_shape = struct + type kind = t + + type t = + { fields : kind array; + (* For compiling to Cmm, we need the lambda shape. We also use it to know + the value prefix length. *) + lambda_shape : Lambda.mixed_block_shape + } + + let field_kinds { fields; lambda_shape = _ } = fields + + let value_prefix_size { fields = _; lambda_shape } = + lambda_shape.value_prefix_len + + (* This function has two meanings. The first is to say whether two shapes are + equivalent (which is why the lambda shape is not compared directly). The + second is to tell whether two shapes are compatible. Currently this matches + with equivalence, but if we introduce subkinds this will have to be split + into two functions. *) + let equal t1 t2 = + Int.equal t1.lambda_shape.value_prefix_len t2.lambda_shape.value_prefix_len + && Int.equal (Array.length t1.fields) (Array.length t2.fields) + && Array.for_all2 equal t1.fields t2.fields + + let compare t1 t2 = + let c = + Int.compare t1.lambda_shape.value_prefix_len + t2.lambda_shape.value_prefix_len + in + if c <> 0 + then c + else + let length1 = Array.length t1.fields in + let length2 = Array.length t2.fields in + let c = Int.compare length1 length2 in + if c <> 0 + then c + else + let exception Result of int in + try + for i = 0 to length1 - 1 do + let c = compare t1.fields.(i) t2.fields.(i) in + if c <> 0 then raise_notrace (Result c) + done; + 0 + with Result c -> c + + let from_lambda (shape : Lambda.mixed_block_shape) = + let value_prefix_shape = + List.init shape.value_prefix_len (fun _ -> Value) + in + let flat_suffix_shape = + List.map from_lambda_flat_element (Array.to_list shape.flat_suffix) + in + { fields = Array.of_list (value_prefix_shape @ flat_suffix_shape); + lambda_shape = shape + } + + let to_lambda { fields = _; lambda_shape } = lambda_shape +end + +module Block_shape = struct + type t = + | Value_only + | Float_record + | Mixed_record of Mixed_block_shape.t + + (* Some users rely on shapes not being compatible if they're not equal. *) + let equal shape1 shape2 = + match shape1, shape2 with + | Value_only, Value_only -> true + | Float_record, Float_record -> true + | Mixed_record shape1, Mixed_record shape2 -> + Mixed_block_shape.equal shape1 shape2 + | (Value_only | Float_record | Mixed_record _), _ -> false + + let compare shape1 shape2 = + match shape1, shape2 with + | Value_only, Value_only -> 0 + | Value_only, _ -> -1 + | _, Value_only -> 1 + | Float_record, Float_record -> 0 + | Float_record, _ -> -1 + | _, Float_record -> 1 + | Mixed_record kinds1, Mixed_record kinds2 -> + Mixed_block_shape.compare kinds1 kinds2 + + let print ppf shape = + match shape with + | Value_only -> Format.fprintf ppf "Values" + | Float_record -> Format.fprintf ppf "Floats" + | Mixed_record { fields; lambda_shape = _ } -> + Format.fprintf ppf "Mixed@ (@["; + Array.iter (fun k -> Format.fprintf ppf "%a@ " print k) fields; + Format.fprintf ppf "@])" + + let element_kind shape index = + match shape with + | Value_only -> Value + | Float_record -> Naked_number Naked_float + | Mixed_record shape -> (Mixed_block_shape.field_kinds shape).(index) +end + module Standard_int = struct type t = | Tagged_immediate @@ -333,7 +447,8 @@ module With_subkind = struct | Tagged_immediate | Variant of { consts : Targetint_31_63.Set.t; - non_consts : kind_and_subkind list Tag.Scannable.Map.t + non_consts : + (Block_shape.t * kind_and_subkind list) Tag.Scannable.Map.t } | Float_block of { num_fields : int } | Float_array @@ -383,8 +498,10 @@ module With_subkind = struct let field_lists2 = Tag.Scannable.Map.data non_consts2 in assert (List.compare_lengths field_lists1 field_lists2 = 0); List.for_all2 - (fun fields1 fields2 -> - if List.compare_lengths fields1 fields2 <> 0 + (fun (shape1, fields1) (shape2, fields2) -> + if not (Block_shape.equal shape1 shape2) + then false + else if List.compare_lengths fields1 fields2 <> 0 then false else List.for_all2 @@ -450,7 +567,7 @@ module With_subkind = struct let print_field ppf { kind = _; subkind } = print ppf subkind in Format.fprintf ppf "%t=Variant((consts (%a))@ (non_consts (%a)))%t" colour Targetint_31_63.Set.print consts - (Tag.Scannable.Map.print (fun ppf fields -> + (Tag.Scannable.Map.print (fun ppf (_shape, fields) -> Format.fprintf ppf "[%a]" (Format.pp_print_list ~pp_sep:Format.pp_print_space print_field) @@ -578,7 +695,8 @@ module With_subkind = struct create value (Variant { consts = Targetint_31_63.Set.empty; - non_consts = Tag.Scannable.Map.singleton tag fields + non_consts = + Tag.Scannable.Map.singleton tag (Block_shape.Value_only, fields) }) | None -> Misc.fatal_errorf "Tag %a is not scannable" Tag.print tag @@ -623,45 +741,68 @@ module With_subkind = struct | Pboxedvectorval (Pvec128 _) -> boxed_vec128 | Pintval -> tagged_immediate | Pvariant { consts; non_consts } -> ( - let all_uniform_non_consts = - List.map - (fun (tag, (shape : Lambda.constructor_shape)) -> - match shape with - | Constructor_uniform shape -> Some (tag, shape) - | Constructor_mixed _ -> None) - non_consts - |> Misc.Stdlib.List.some_if_all_elements_are_some - in - match all_uniform_non_consts with - | None -> - (* CR mixed blocks v2: have a better representation of mixed blocks in - the flambda2 middle end so that they can be optimized more. *) - any_value - | Some non_consts -> ( - match consts, non_consts with - | [], [] -> Misc.fatal_error "[Pvariant] with no constructors at all" - | [], [(tag, fields)] when tag = Obj.double_array_tag -> - (* If we have [Obj.double_array_tag] here, this is always an all-float - block, not an array. *) - float_block ~num_fields:(List.length fields) - | [], _ :: _ | _ :: _, [] | _ :: _, _ :: _ -> - let consts = - Targetint_31_63.Set.of_list - (List.map (fun const -> Targetint_31_63.of_int const) consts) - in - let non_consts = - List.fold_left - (fun non_consts (tag, fields) -> - match Tag.Scannable.create tag with - | Some tag -> - Tag.Scannable.Map.add tag - (List.map from_lambda_value_kind fields) - non_consts - | None -> - Misc.fatal_errorf "Non-scannable tag %d in [Pvariant]" tag) - Tag.Scannable.Map.empty non_consts - in - create value (Variant { consts; non_consts }))) + match consts, non_consts with + | [], [] -> Misc.fatal_error "[Pvariant] with no constructors at all" + | [], [(tag, shape)] when tag = Obj.double_array_tag -> + (* If we have [Obj.double_array_tag] here, this is always an all-float + block, not an array. *) + (* CR vlaviron: change the Lambda type *) + let num_fields = + match shape with + | Constructor_uniform fields -> List.length fields + | Constructor_mixed _ -> assert false + in + float_block ~num_fields + | [], _ :: _ | _ :: _, [] | _ :: _, _ :: _ -> + let consts = + Targetint_31_63.Set.of_list + (List.map (fun const -> Targetint_31_63.of_int const) consts) + in + let non_consts = + List.fold_left + (fun non_consts (tag, shape) -> + match Tag.Scannable.create tag with + | Some tag -> + let shape_and_fields = + match (shape : Lambda.constructor_shape) with + | Constructor_uniform fields -> + ( Block_shape.Value_only, + List.map from_lambda_value_kind fields ) + | Constructor_mixed { value_prefix; flat_suffix } -> + let lambda_shape : Lambda.mixed_block_shape = + { value_prefix_len = List.length value_prefix; + flat_suffix = Array.of_list flat_suffix + } + in + let fields = + let flat_element_kind (elt : Lambda.flat_element) = + match elt with + | Imm -> tagged_immediate + | Float_boxed -> naked_float + | Float64 -> naked_float + | Float32 -> naked_float32 + | Bits32 -> naked_int32 + | Bits64 -> naked_int64 + | Word -> naked_nativeint + in + let prefix = + List.map from_lambda_value_kind value_prefix + in + let suffix = List.map flat_element_kind flat_suffix in + prefix @ suffix + in + let shape = + Block_shape.Mixed_record + (Mixed_block_shape.from_lambda lambda_shape) + in + shape, fields + in + Tag.Scannable.Map.add tag shape_and_fields non_consts + | None -> + Misc.fatal_errorf "Non-scannable tag %d in [Pvariant]" tag) + Tag.Scannable.Map.empty non_consts + in + create value (Variant { consts; non_consts })) | Parrayval Pfloatarray -> float_array | Parrayval Pintarray -> immediate_array | Parrayval Paddrarray -> value_array diff --git a/middle_end/flambda2/kinds/flambda_kind.mli b/middle_end/flambda2/kinds/flambda_kind.mli index 0097a1fd6e4..35b32098e6b 100644 --- a/middle_end/flambda2/kinds/flambda_kind.mli +++ b/middle_end/flambda2/kinds/flambda_kind.mli @@ -72,10 +72,46 @@ val is_value : t -> bool val is_naked_float : t -> bool +val from_lambda_flat_element : Lambda.flat_element -> t + val to_lambda : t -> Lambda.layout include Container_types.S with type t := t +module Mixed_block_shape : sig + type t + + val from_lambda : Lambda.mixed_block_shape -> t + + val field_kinds : t -> kind array + + val value_prefix_size : t -> int + + val to_lambda : t -> Lambda.mixed_block_shape + + val equal : t -> t -> bool + + val compare : t -> t -> int +end + +module Block_shape : sig + type t = + | Value_only + | Float_record + | Mixed_record of Mixed_block_shape.t + + (** For now if two block shapes do not compare as equal they will be + incompatible. If that changes, a [compatible] function will be + introduced. *) + val equal : t -> t -> bool + + val compare : t -> t -> int + + val print : Format.formatter -> t -> unit + + val element_kind : t -> int -> kind +end + module Standard_int : sig (** "Standard" because these correspond to the usual representations of tagged immediates, 32-bit, 64-bit and native integers as expected by the @@ -150,7 +186,7 @@ module With_subkind : sig | Tagged_immediate | Variant of { consts : Targetint_31_63.Set.t; - non_consts : with_subkind list Tag.Scannable.Map.t + non_consts : (Block_shape.t * with_subkind list) Tag.Scannable.Map.t } | Float_block of { num_fields : int } | Float_array diff --git a/middle_end/flambda2/lattices/or_unknown.ml b/middle_end/flambda2/lattices/or_unknown.ml index 004aeaf2421..49ed8f5fe72 100644 --- a/middle_end/flambda2/lattices/or_unknown.ml +++ b/middle_end/flambda2/lattices/or_unknown.ml @@ -18,6 +18,8 @@ type 'a t = | Known of 'a | Unknown +let known x = Known x + let print f ppf t = let colour = Flambda_colours.top_or_bottom_type in match t with diff --git a/middle_end/flambda2/lattices/or_unknown.mli b/middle_end/flambda2/lattices/or_unknown.mli index a2abde630e4..81bd96a166a 100644 --- a/middle_end/flambda2/lattices/or_unknown.mli +++ b/middle_end/flambda2/lattices/or_unknown.mli @@ -18,6 +18,8 @@ type 'a t = | Known of 'a | Unknown +val known : 'a -> 'a t + val print : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int diff --git a/middle_end/flambda2/parser/fexpr.ml b/middle_end/flambda2/parser/fexpr.ml index 53961dab701..10bb5bc1469 100644 --- a/middle_end/flambda2/parser/fexpr.ml +++ b/middle_end/flambda2/parser/fexpr.ml @@ -210,11 +210,6 @@ type block_access_kind = field_kind : block_access_field_kind } | Naked_floats of { size : targetint option } - | Mixed of - { tag : tag_scannable option; - size : targetint option; - field_kind : Flambda_primitive.Mixed_block_access_field_kind.t - } type standard_int = Flambda_kind.Standard_int.t = | Tagged_immediate diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index 67e588ea60d..bd11fb36473 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -273,7 +273,9 @@ let rec subkind : Fexpr.subkind -> Flambda_kind.With_subkind.Subkind.t = let non_consts = non_consts |> List.map (fun (tag, sk) -> - tag_scannable tag, List.map value_kind_with_subkind sk) + ( tag_scannable tag, + ( Flambda_kind.Block_shape.Value_only, + List.map value_kind_with_subkind sk ) )) |> Tag.Scannable.Map.of_list in Variant { consts; non_consts } @@ -439,14 +441,6 @@ let block_access_kind (ak : Fexpr.block_access_kind) : | Naked_floats { size = s } -> let size = size s in Naked_floats { size } - | Mixed { tag; size = s; field_kind } -> - let tag : Tag.Scannable.t Or_unknown.t = - match tag with - | Some tag -> Known (tag |> tag_scannable) - | None -> Unknown - in - let s = size s in - Mixed { tag; size = s; field_kind } let binop (binop : Fexpr.binop) : Flambda_primitive.binary_primitive = match binop with diff --git a/middle_end/flambda2/parser/flambda_to_fexpr.ml b/middle_end/flambda2/parser/flambda_to_fexpr.ml index d505786a111..aa345ebcc6d 100644 --- a/middle_end/flambda2/parser/flambda_to_fexpr.ml +++ b/middle_end/flambda2/parser/flambda_to_fexpr.ml @@ -449,7 +449,7 @@ and variant_subkind consts non_consts : Fexpr.subkind = in let non_consts = non_consts |> Tag.Scannable.Map.bindings - |> List.map (fun (tag, sk) -> + |> List.map (fun (tag, (_shape, sk)) -> Tag.Scannable.to_int tag, List.map kind_with_subkind sk) in Variant { consts; non_consts } @@ -571,14 +571,7 @@ let block_access_kind (bk : Flambda_primitive.Block_access_kind.t) : | Naked_floats { size = s } -> let size = s |> size in Naked_floats { size } - | Mixed { tag; size = s; field_kind } -> - let size = s |> size in - let tag = - match tag with - | Unknown -> None - | Known tag -> Some (tag |> Tag.Scannable.to_int) - in - Mixed { tag; size; field_kind } + | Mixed _ -> Misc.fatal_error "Mixed blocks not supported in fexpr" let binop (op : Flambda_primitive.binary_primitive) : Fexpr.binop = match op with @@ -623,7 +616,7 @@ let varop env (op : Flambda_primitive.variadic_primitive) : Fexpr.varop = let tag = tag |> Tag.Scannable.to_int in let alloc = alloc_mode_for_allocations env alloc in Make_block (tag, mutability, alloc) - | Make_block (Naked_floats, _, _) | Make_array _ | Make_mixed_block _ -> + | Make_block ((Naked_floats | Mixed _), _, _) | Make_array _ -> Misc.fatal_errorf "TODO: Variadic primitive: %a" Flambda_primitive.Without_args.print (Flambda_primitive.Without_args.Variadic op) diff --git a/middle_end/flambda2/parser/print_fexpr.ml b/middle_end/flambda2/parser/print_fexpr.ml index 02f2714eab5..b93e97f16ca 100644 --- a/middle_end/flambda2/parser/print_fexpr.ml +++ b/middle_end/flambda2/parser/print_fexpr.ml @@ -476,25 +476,12 @@ let block_access_kind ppf (access_kind : block_access_kind) = | Any_value -> () | Immediate -> Format.fprintf ppf "@ imm" in - let pp_mixed_field_kind ppf - (field_kind : Flambda_primitive.Mixed_block_access_field_kind.t) = - match field_kind with - | Value_prefix Any_value -> () - | Value_prefix Immediate -> Format.fprintf ppf "@ imm" - | Flat_suffix flat -> - Format.fprintf ppf "@ %s" - (Flambda_primitive.Mixed_block_flat_element.to_string flat) - in match access_kind with | Values { field_kind; tag; size } -> Format.fprintf ppf "%a%a%a" pp_field_kind field_kind (pp_option ~space:Before (pp_like "tag(%a)" Format.pp_print_int)) tag pp_size size | Naked_floats { size } -> Format.fprintf ppf "@ float%a" pp_size size - | Mixed { tag; field_kind; size } -> - Format.fprintf ppf "%a%a%a" pp_mixed_field_kind field_kind - (pp_option ~space:Before (pp_like "tag(%a)" Format.pp_print_int)) - tag pp_size size let string_accessor_width ppf saw = Format.fprintf ppf "%s" diff --git a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml index 39de6869032..8183e52412f 100644 --- a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml +++ b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml @@ -239,6 +239,13 @@ let blocks_to_unbox ~escaping ~source_info ~required_names = (fun _ -> Flambda_kind.With_subkind.naked_float) fields } + | Mixed (tag, shape) -> + let fields_kinds = + List.map Flambda_kind.With_subkind.anything + (Array.to_list + (Flambda_kind.Mixed_block_shape.field_kinds shape)) + in + { tag = Tag.Scannable.to_tag tag; mut; fields_kinds } in Variable.Map.add var block_to_unbox map) map elt.mutable_let_prims_rev) diff --git a/middle_end/flambda2/simplify/simplify_binary_primitive.ml b/middle_end/flambda2/simplify/simplify_binary_primitive.ml index 3799cc832eb..a3b642ddc06 100644 --- a/middle_end/flambda2/simplify/simplify_binary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_binary_primitive.ml @@ -898,18 +898,11 @@ let[@inline always] simplify_immutable_block_load0 let result_var' = Bound_var.var result_var in let typing_env = DA.typing_env dacc in match[@warning "-fragile-match"] - T.meet_equals_single_tagged_immediate typing_env index_ty, access_kind + T.meet_equals_single_tagged_immediate typing_env index_ty with - | _, Mixed _ -> - SPR.create_unknown dacc ~result_var result_kind ~original_term - (* CR mixed blocks: An flambda2 person will see how to do better here for - mixed blocks. Simply extending the existing code would require extending - [Block_kind] with [Mixed], but various parts of the code seem to assume - blocks have uniform element kinds. *) - | Invalid, _ -> SPR.create_invalid dacc - | Need_meet, _ -> - SPR.create_unknown dacc ~result_var result_kind ~original_term - | Known_result index, _ -> ( + | Invalid -> SPR.create_invalid dacc + | Need_meet -> SPR.create_unknown dacc ~result_var result_kind ~original_term + | Known_result index -> ( match T.meet_block_field_simple typing_env ~min_name_mode ~field_kind:result_kind block_ty index @@ -924,28 +917,33 @@ let[@inline always] simplify_immutable_block_load0 let n = Targetint_31_63.add index Targetint_31_63.one in (* CR-someday mshinwell: We should be able to use the size in the [access_kind] to constrain the type of the block *) - let tag : _ Or_unknown.t = + let tag, shape = match access_kind with - | Values { tag; _ } -> Or_unknown.map tag ~f:Tag.Scannable.to_tag - | Naked_floats { size } -> ( - match size with - | Known size -> - (* We don't expect blocks of naked floats of size zero (it doesn't - seem that the frontend currently emits code to create such - blocks) and so it isn't clear whether such blocks should have tag - zero (like zero-sized naked float arrays) or another tag. *) - if Targetint_31_63.equal size Targetint_31_63.zero - then Unknown - else Known Tag.double_array_tag - | Unknown -> Unknown) - | Mixed _ -> assert false + | Values { tag; _ } -> + Or_unknown.map tag ~f:Tag.Scannable.to_tag, K.Block_shape.Value_only + | Naked_floats { size } -> + ( (match size with + | Known size -> + (* We don't expect blocks of naked floats of size zero (it doesn't + seem that the frontend currently emits code to create such + blocks) and so it isn't clear whether such blocks should have + tag zero (like zero-sized naked float arrays) or another + tag. *) + if Targetint_31_63.equal size Targetint_31_63.zero + then Or_unknown.Unknown + else Or_unknown.Known Tag.double_array_tag + | Unknown -> Or_unknown.Unknown), + K.Block_shape.Float_record ) + | Mixed { tag; size = _; field_kind = _; shape } -> + ( Or_unknown.map tag ~f:Tag.Scannable.to_tag, + K.Block_shape.Mixed_record shape ) in let result = Simplify_common.simplify_projection dacc ~original_term ~deconstructing:block_ty ~shape: - (T.immutable_block_with_size_at_least ~tag ~n - ~field_kind:result_kind ~field_n_minus_one:result_var') + (T.immutable_block_with_size_at_least ~tag ~n ~shape + ~field_n_minus_one:result_var') ~result_var ~result_kind in match result.simplified_named with @@ -961,8 +959,8 @@ let[@inline always] simplify_immutable_block_load0 (DA.typing_env dacc) block_ty with | Unknown -> result - | Proved (tag_and_size, field_simples) -> ( - match Tag_and_size.tag tag_and_size |> Tag.Scannable.of_tag with + | Proved (tag, shape_from_type, _size, field_simples) -> ( + match Tag.Scannable.of_tag tag with | None -> result | Some tag -> ( let block_kind : P.Block_kind.t = @@ -973,7 +971,15 @@ let[@inline always] simplify_immutable_block_load0 in Values (tag, arity) | Naked_floats _ -> Naked_floats - | Mixed _ -> assert false + | Mixed { shape; _ } -> + (match shape_from_type with + | Mixed_record shape_from_type + when K.Mixed_block_shape.equal shape shape_from_type -> + () + | Value_only | Float_record | Mixed_record _ -> + Misc.fatal_error + "Block access kind disagrees with block shape from type"); + Mixed (tag, shape) in let prim = P.Eligible_for_cse.create diff --git a/middle_end/flambda2/simplify/simplify_primitive.ml b/middle_end/flambda2/simplify/simplify_primitive.ml index 15668a1e9f5..eb897deb0e8 100644 --- a/middle_end/flambda2/simplify/simplify_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_primitive.ml @@ -168,7 +168,9 @@ let simplify_primitive dacc (prim : P.t) dbg ~result_var = let arg_tys = List.map snd args_with_tys in let arg_tys_and_expected_kinds = match P.args_kind_of_variadic_primitive variadic_prim with - | Variadic arg_kinds -> List.combine arg_tys arg_kinds + | Variadic_mixed arg_kinds -> + List.combine arg_tys + (Array.to_list (K.Mixed_block_shape.field_kinds arg_kinds)) | Variadic_all_of_kind kind -> List.map (fun arg_ty -> arg_ty, kind) arg_tys in diff --git a/middle_end/flambda2/simplify/simplify_static_const.ml b/middle_end/flambda2/simplify/simplify_static_const.ml index ae42bdffec2..274d0295243 100644 --- a/middle_end/flambda2/simplify/simplify_static_const.ml +++ b/middle_end/flambda2/simplify/simplify_static_const.ml @@ -84,11 +84,11 @@ let simplify_static_const_of_kind_value dacc (static_const : Static_const.t) let fields = field_tys in match is_mutable with | Immutable -> - T.immutable_block ~is_unique:false tag ~field_kind:K.value ~fields - Alloc_mode.For_types.heap + T.immutable_block ~is_unique:false tag ~shape:K.Block_shape.Value_only + ~fields Alloc_mode.For_types.heap | Immutable_unique -> - T.immutable_block ~is_unique:true tag ~field_kind:K.value ~fields - Alloc_mode.For_types.heap + T.immutable_block ~is_unique:true tag ~shape:K.Block_shape.Value_only + ~fields Alloc_mode.For_types.heap | Mutable -> T.any_value in let dacc = bind_result_sym ty in diff --git a/middle_end/flambda2/simplify/simplify_switch_expr.ml b/middle_end/flambda2/simplify/simplify_switch_expr.ml index 4093bcf44d0..2edf6d1f074 100644 --- a/middle_end/flambda2/simplify/simplify_switch_expr.ml +++ b/middle_end/flambda2/simplify/simplify_switch_expr.ml @@ -288,7 +288,7 @@ let rebuild_switch_with_single_arg_to_same_destination uacc ~dacc_before_switch let uacc = let fields = List.map Field_of_static_block.tagged_immediate consts in let block_type = - T.immutable_block ~is_unique:false Tag.zero ~field_kind:K.value + T.immutable_block ~is_unique:false Tag.zero ~shape:Value_only Alloc_mode.For_types.heap ~fields: (List.map diff --git a/middle_end/flambda2/simplify/simplify_variadic_primitive.ml b/middle_end/flambda2/simplify/simplify_variadic_primitive.ml index e34e9b174ec..02e7fb7ab65 100644 --- a/middle_end/flambda2/simplify/simplify_variadic_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_variadic_primitive.ml @@ -16,68 +16,31 @@ open! Simplify_import -(* Allow [simplify_make_block] to fold over the fields, whether they are backed - by a list (for non-mixed blocks) or an array (for mixed blocks). *) -module Block_shape = struct - type t = - | Not_mixed of - { field_kind : K.t; - shape : K.With_subkind.t list - } - | Mixed of P.Mixed_block_kind.t - - type possibly_refined_kind = - | Just_kind of K.t - | With_subkind of K.With_subkind.t - - let length = function - | Not_mixed { shape; _ } -> List.length shape - | Mixed shape -> P.Mixed_block_kind.length shape - - let fold_left_fields f init t = - match t with - | Not_mixed { shape; _ } -> - List.fold_left (fun acc x -> f acc (With_subkind x)) init shape - | Mixed mixed -> - P.Mixed_block_kind.fold_left (fun acc x -> f acc (Just_kind x)) init mixed -end - -let simplify_make_block ~original_prim tag ~(block_shape : Block_shape.t) +let simplify_make_block ~original_prim ~(block_kind : P.Block_kind.t) ~(mutable_or_immutable : Mutability.t) alloc_mode dacc ~original_term _dbg ~args_with_tys ~result_var = - let args, _arg_tys = List.split args_with_tys in - if List.compare_length_with args (Block_shape.length block_shape) <> 0 - then - Misc.fatal_errorf - "Shape in [Make_block] of different length from argument list:@ %a" - Named.print original_term; - let remaining_args, result = - let typing_env = DA.typing_env dacc in - Block_shape.fold_left_fields - (fun (args, env_extension) arg_kind : (_ * _ Or_bottom.t) -> - let arg, args = - match args with - | arg :: args -> arg, args - | [] -> - Misc.fatal_error - "We already checked that [args] and [block_shape] have the same \ - length" - in - let result = + let env_extension : _ Or_bottom.t = + match block_kind with + | Naked_floats | Mixed _ -> + (* No useful subkind information *) + Ok TEE.empty + | Values (_tag, field_kinds) -> + if List.compare_lengths args_with_tys field_kinds <> 0 + then + Misc.fatal_errorf + "Shape in [Make_block] of different length from argument list:@ %a" + Named.print original_term; + let typing_env = DA.typing_env dacc in + List.fold_left2 + (fun env_extension arg_kind (arg, _arg_ty) : _ Or_bottom.t -> let open Or_bottom.Let_syntax in let<* env_extension = env_extension in Simple.pattern_match' arg ~var:(fun _ ~coercion:_ : _ Or_bottom.t -> let<* _ty, env_extension' = - match arg_kind with - | Just_kind arg_kind -> - T.meet typing_env - (T.alias_type_of arg_kind arg) - (T.unknown arg_kind) - | With_subkind arg_kind -> - T.meet typing_env - (T.alias_type_of (K.With_subkind.kind arg_kind) arg) - (T.unknown_with_subkind arg_kind) + T.meet typing_env + (T.alias_type_of (K.With_subkind.kind arg_kind) arg) + (T.unknown_with_subkind arg_kind) in let<+ env_extension = T.Typing_env_extension.meet typing_env env_extension @@ -85,20 +48,10 @@ let simplify_make_block ~original_prim tag ~(block_shape : Block_shape.t) in env_extension) ~const:(fun _ : _ Or_bottom.t -> Ok env_extension) - ~symbol:(fun _ ~coercion:_ : _ Or_bottom.t -> Ok env_extension) - in - args, result) - (args, Or_bottom.Ok TEE.empty) - block_shape + ~symbol:(fun _ ~coercion:_ : _ Or_bottom.t -> Ok env_extension)) + (Or_bottom.Ok TEE.empty) field_kinds args_with_tys in - let () = - match remaining_args with - | [] -> () - | _ :: _ -> - Misc.fatal_error - "We already checked that [args] and [block_shape] have the same length" - in - match result with + match env_extension with | Bottom -> SPR.create_invalid dacc | Ok env_extension -> let dacc = @@ -107,22 +60,15 @@ let simplify_make_block ~original_prim tag ~(block_shape : Block_shape.t) TE.add_env_extension typing_env env_extension)) in let ty = - match block_shape with - | Mixed _ -> T.any_value - | Not_mixed { shape; field_kind } -> ( - let fields = - List.map2 - (fun arg kind_with_subkind -> - T.alias_type_of (K.With_subkind.kind kind_with_subkind) arg) - args shape - in - let alloc_mode = Alloc_mode.For_allocations.as_type alloc_mode in - match mutable_or_immutable with - | Immutable -> - T.immutable_block ~is_unique:false tag ~field_kind alloc_mode ~fields - | Immutable_unique -> - T.immutable_block ~is_unique:true tag ~field_kind alloc_mode ~fields - | Mutable -> T.mutable_block alloc_mode) + let fields = List.map snd args_with_tys in + let alloc_mode = Alloc_mode.For_allocations.as_type alloc_mode in + let tag, shape = P.Block_kind.to_shape block_kind in + match mutable_or_immutable with + | Immutable -> + T.immutable_block ~is_unique:false tag ~shape alloc_mode ~fields + | Immutable_unique -> + T.immutable_block ~is_unique:true tag ~shape alloc_mode ~fields + | Mutable -> T.mutable_block alloc_mode in let dacc = DA.add_variable dacc result_var ty in let dacc = @@ -138,14 +84,6 @@ let simplify_make_block ~original_prim tag ~(block_shape : Block_shape.t) in SPR.create original_term ~try_reify:true dacc -let simplify_make_block_of_floats ~original_prim ~mutable_or_immutable - alloc_mode dacc ~original_term dbg ~args_with_tys ~result_var = - let shape = List.map (fun _ -> K.With_subkind.naked_float) args_with_tys in - simplify_make_block ~original_prim - ~block_shape:(Not_mixed { field_kind = K.naked_float; shape }) - Tag.double_array_tag ~mutable_or_immutable alloc_mode dacc ~original_term - dbg ~args_with_tys ~result_var - let simplify_make_array (array_kind : P.Array_kind.t) ~(mutable_or_immutable : Mutability.t) alloc_mode dacc ~original_term dbg ~args_with_tys ~result_var = @@ -201,31 +139,15 @@ let simplify_make_array (array_kind : P.Array_kind.t) in SPR.create named ~try_reify:true dacc -let simplify_make_mixed_block ~original_prim ~kind - ~(mutable_or_immutable : Mutability.t) tag alloc_mode dacc ~original_term - dbg ~args_with_tys ~result_var = - simplify_make_block ~original_prim ~mutable_or_immutable - ~block_shape:(Mixed kind) tag alloc_mode dacc ~original_term dbg - ~args_with_tys ~result_var - let simplify_variadic_primitive dacc original_prim (prim : P.variadic_primitive) ~args_with_tys dbg ~result_var = let original_term = Named.create_prim original_prim dbg in let simplifier = match prim with - | Make_block (Values (tag, shape), mutable_or_immutable, alloc_mode) -> - let tag = Tag.Scannable.to_tag tag in - simplify_make_block ~original_prim tag - ~block_shape:(Not_mixed { field_kind = K.value; shape }) - ~mutable_or_immutable alloc_mode - | Make_block (Naked_floats, mutable_or_immutable, alloc_mode) -> - simplify_make_block_of_floats ~original_prim ~mutable_or_immutable + | Make_block (block_kind, mutable_or_immutable, alloc_mode) -> + simplify_make_block ~original_prim ~block_kind ~mutable_or_immutable alloc_mode | Make_array (array_kind, mutable_or_immutable, alloc_mode) -> simplify_make_array array_kind ~mutable_or_immutable alloc_mode - | Make_mixed_block (tag, kind, mutable_or_immutable, alloc_mode) -> - let tag = Tag.Scannable.to_tag tag in - simplify_make_mixed_block ~original_prim tag ~kind ~mutable_or_immutable - alloc_mode in simplifier dacc ~original_term dbg ~args_with_tys ~result_var diff --git a/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml b/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml index fa5d66a24b3..c9dd10d0f78 100644 --- a/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml +++ b/middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml @@ -35,23 +35,22 @@ let denv_of_number_decision naked_kind shape param_var naked_var denv : DE.t = let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = match decision with | Do_not_unbox _ -> denv - | Unbox (Unique_tag_and_size { tag; fields }) -> - let field_kind = - if Tag.equal tag Tag.double_array_tag then K.naked_float else K.value - in + | Unbox (Unique_tag_and_size { tag; shape; fields }) -> let denv = - List.fold_left - (fun denv ({ epa = { param = var; _ }; _ } : U.field_decision) -> + Misc.Stdlib.List.fold_lefti + (fun index denv ({ epa = { param = var; _ }; _ } : U.field_decision) -> let v = VB.create var Name_mode.normal in - DE.define_variable denv v field_kind) + DE.define_variable denv v (K.Block_shape.element_kind shape index)) denv fields in - let type_of_var (field : U.field_decision) = - T.alias_type_of field_kind (Simple.var field.epa.param) + let type_of_var index (field : U.field_decision) = + T.alias_type_of + (K.Block_shape.element_kind shape index) + (Simple.var field.epa.param) in - let field_types = List.map type_of_var fields in + let field_types = List.mapi type_of_var fields in let shape = - T.immutable_block ~is_unique:false tag ~field_kind ~fields:field_types + T.immutable_block ~is_unique:false tag ~shape ~fields:field_types (Alloc_mode.For_types.unknown ()) in let denv = add_equation_on_var denv param_var shape in @@ -142,21 +141,22 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = in let denv = Tag.Scannable.Map.fold - (fun _ block_fields denv -> - List.fold_left - (fun denv ({ epa = { param = var; _ }; _ } : U.field_decision) -> + (fun _ (shape, block_fields) denv -> + Misc.Stdlib.List.fold_lefti + (fun index denv ({ epa = { param = var; _ }; _ } : U.field_decision) -> let v = VB.create var Name_mode.normal in - DE.define_variable denv v K.value) + DE.define_variable denv v (K.Block_shape.element_kind shape index)) denv block_fields) fields_by_tag denv in let non_const_ctors = Tag.Scannable.Map.map - (fun block_fields -> - List.map - (fun (field : U.field_decision) -> - T.alias_type_of K.value (Simple.var field.epa.param)) - block_fields) + (fun (shape, block_fields) -> + ( shape, + List.map + (fun (field : U.field_decision) -> + T.alias_type_of K.value (Simple.var field.epa.param)) + block_fields )) fields_by_tag in let shape = @@ -165,7 +165,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t = let denv = add_equation_on_var denv param_var shape in (* Recurse on the fields *) Tag.Scannable.Map.fold - (fun _ block_fields denv -> + (fun _ (_shape, block_fields) denv -> List.fold_left (fun denv (field : U.field_decision) -> denv_of_decision denv ~param_var:field.epa.param field.decision) diff --git a/middle_end/flambda2/simplify/unboxing/is_unboxing_beneficial.ml b/middle_end/flambda2/simplify/unboxing/is_unboxing_beneficial.ml index 4cc7fcc40eb..e56fd302365 100644 --- a/middle_end/flambda2/simplify/unboxing/is_unboxing_beneficial.ml +++ b/middle_end/flambda2/simplify/unboxing/is_unboxing_beneficial.ml @@ -29,7 +29,7 @@ let is_unboxing_beneficial_for_epa (epa : Extra_param_and_args.t) = let rec filter_non_beneficial_decisions decision : U.decision = match (decision : U.decision) with | Do_not_unbox _ -> decision - | Unbox (Unique_tag_and_size { tag; fields }) -> + | Unbox (Unique_tag_and_size { tag; shape; fields }) -> let is_unboxing_beneficial, fields = List.fold_left_map (fun is_unboxing_beneficial ({ epa; decision; kind } : U.field_decision) @@ -42,7 +42,7 @@ let rec filter_non_beneficial_decisions decision : U.decision = false fields in if is_unboxing_beneficial - then Unbox (Unique_tag_and_size { tag; fields }) + then Unbox (Unique_tag_and_size { tag; shape; fields }) else Do_not_unbox Not_beneficial | Unbox (Closure_single_entry { function_slot; vars_within_closure }) -> let is_unboxing_beneficial = ref false in @@ -62,13 +62,17 @@ let rec filter_non_beneficial_decisions decision : U.decision = let is_unboxing_beneficial = ref false in let fields_by_tag = Tag.Scannable.Map.map - (List.map - (fun ({ epa; decision; kind } : U.field_decision) : U.field_decision - -> - is_unboxing_beneficial - := !is_unboxing_beneficial || is_unboxing_beneficial_for_epa epa; - let decision = filter_non_beneficial_decisions decision in - { epa; decision; kind })) + (fun (shape, fields) -> + ( shape, + List.map + (fun ({ epa; decision; kind } : U.field_decision) : + U.field_decision -> + is_unboxing_beneficial + := !is_unboxing_beneficial + || is_unboxing_beneficial_for_epa epa; + let decision = filter_non_beneficial_decisions decision in + { epa; decision; kind }) + fields )) fields_by_tag in if !is_unboxing_beneficial diff --git a/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml b/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml index cab4fe61eb1..47604117656 100644 --- a/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml +++ b/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml @@ -87,13 +87,13 @@ let rec make_optimistic_decision ~depth ~recursive tenv ~param_type : U.decision then Do_not_unbox Max_depth_exceeded else match T.prove_unique_tag_and_size tenv param_type with - | Proved (tag, size) when unbox_blocks -> ( + | Proved (tag, shape, size) when unbox_blocks -> ( let fields = make_optimistic_fields ~add_tag_to_name:false ~depth ~recursive tenv - param_type tag size + param_type tag shape size in match fields with - | Some fields -> Unbox (Unique_tag_and_size { tag; fields }) + | Some fields -> Unbox (Unique_tag_and_size { tag; shape; fields }) | None -> Do_not_unbox All_fields_invalid) | Proved _ | Unknown -> ( match T.prove_variant_like tenv param_type with @@ -107,10 +107,14 @@ let rec make_optimistic_decision ~depth ~recursive tenv ~param_type : U.decision in let fields_by_tag = Tag.Scannable.Map.filter_map - (fun scannable_tag size -> + (fun scannable_tag (size, shape) -> let tag = Tag.Scannable.to_tag scannable_tag in - make_optimistic_fields ~add_tag_to_name:true ~depth ~recursive - tenv param_type tag size) + match + make_optimistic_fields ~add_tag_to_name:true ~depth + ~recursive tenv param_type tag shape size + with + | None -> None + | Some decision -> Some (shape, decision)) non_const_ctors_with_sizes in if Tag.Scannable.Map.is_empty fields_by_tag @@ -119,9 +123,9 @@ let rec make_optimistic_decision ~depth ~recursive tenv ~param_type : U.decision match const_ctors, Tag.Scannable.Map.get_singleton fields_by_tag with - | Zero, Some (scannable_tag, fields) -> + | Zero, Some (scannable_tag, (shape, fields)) -> let tag = Tag.Scannable.to_tag scannable_tag in - Unbox (Unique_tag_and_size { tag; fields }) + Unbox (Unique_tag_and_size { tag; shape; fields }) | (Zero | At_least_one _), _ -> Unbox (Variant { tag; const_ctors; fields_by_tag })) | Proved _ | Unknown -> ( @@ -137,14 +141,12 @@ let rec make_optimistic_decision ~depth ~recursive tenv ~param_type : U.decision | Proved _ | Unknown -> Do_not_unbox Incomplete_parameter_type))) and make_optimistic_fields ~add_tag_to_name ~depth ~recursive tenv param_type - (tag : Tag.t) size = - let field_kind, field_base_name = - if Tag.equal tag Tag.double_array_tag - then K.naked_float, "unboxed_float_field" - else K.value, "unboxed_field" - in - let field_kind_with_subkind = - K.With_subkind.create field_kind K.With_subkind.Subkind.Anything + (tag : Tag.t) (shape : K.Block_shape.t) size = + let field_base_name = + match shape with + | Value_only -> "unboxed_field" + | Float_record -> "unboxed_float_field" + | Mixed_record _ -> "unboxed_mixed_field" in let field_name n = Format.asprintf "%s%a_%d" field_base_name (pp_tag add_tag_to_name) tag n @@ -153,19 +155,21 @@ and make_optimistic_fields ~add_tag_to_name ~depth ~recursive tenv param_type List.init (Targetint_31_63.to_int size) (fun i -> Extra_param_and_args.create ~name:(field_name i)) in - let type_of_var (epa : Extra_param_and_args.t) = - T.alias_type_of field_kind (Simple.var epa.param) + let type_of_var index (epa : Extra_param_and_args.t) = + T.alias_type_of + (K.Block_shape.element_kind shape index) + (Simple.var epa.param) in - let field_types = List.map type_of_var field_vars in + let field_types = List.mapi type_of_var field_vars in let tenv = - List.fold_left - (fun acc { Extra_param_and_args.param = var; args = _ } -> + Misc.Stdlib.List.fold_lefti + (fun index acc { Extra_param_and_args.param = var; args = _ } -> let name = Bound_name.create (Name.var var) Name_mode.normal in - TE.add_definition acc name field_kind) + TE.add_definition acc name (K.Block_shape.element_kind shape index)) tenv field_vars in let shape = - T.immutable_block ~is_unique:false tag ~field_kind ~fields:field_types + T.immutable_block ~is_unique:false tag ~shape ~fields:field_types (Alloc_mode.For_types.unknown ()) in match T.meet tenv param_type shape with @@ -184,7 +188,7 @@ and make_optimistic_fields ~add_tag_to_name ~depth ~recursive tenv param_type make_optimistic_decision ~depth:(depth + 1) ~recursive tenv ~param_type:var_type in - { epa; decision; kind = field_kind_with_subkind }) + { epa; decision; kind = K.With_subkind.anything (T.kind var_type) }) field_vars field_types in Some fields diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml index 19a5898816a..d094d82e0b0 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml +++ b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml @@ -171,6 +171,39 @@ let compute_extra_arg_for_number kind unboxer epa rewrite_id ~typing_env_at_use let epa = Extra_param_and_args.update_param_args epa rewrite_id extra_arg in Unbox (Number (kind, epa)) +(* Helpers for the block case *) +(* ************************** *) + +let access_kind_and_dummy_const tag shape fields index : + P.Block_access_kind.t * _ = + let size = Or_unknown.Known (Targetint_31_63.of_int (List.length fields)) in + match (shape : K.Block_shape.t) with + | Value_only -> + ( Values + { size; + tag = Known (Option.get (Tag.Scannable.of_tag tag)); + field_kind = Any_value + }, + Const.const_zero ) + | Float_record -> + ( Naked_floats { size }, + Const.naked_float Numeric_types.Float_by_bit_pattern.zero ) + | Mixed_record shape -> + let field_kind, const = + let field_kind = (K.Mixed_block_shape.field_kinds shape).(index) in + if index < K.Mixed_block_shape.value_prefix_size shape + then + (* CR vlaviron: we're not trying to infer if this can only be an + immediate. In most cases it should be fine, as the primitive will get + simplified away. *) + P.Mixed_block_access_field_kind.Value_prefix Any_value, Const.const_zero + else + ( P.Mixed_block_access_field_kind.Flat_suffix field_kind, + Const.of_int_of_kind field_kind 0 ) + in + let tag = Or_unknown.Known (Option.get (Tag.Scannable.of_tag tag)) in + Mixed { tag; size; shape; field_kind }, const + (* Recursive descent on decisions *) (* ****************************** *) @@ -189,9 +222,9 @@ and compute_extra_args_for_one_decision_and_use_aux ~(pass : U.pass) rewrite_id ~typing_env_at_use arg_being_unboxed (decision : U.decision) : U.decision = match decision with | Do_not_unbox _ -> decision - | Unbox (Unique_tag_and_size { tag; fields }) -> + | Unbox (Unique_tag_and_size { tag; shape; fields }) -> compute_extra_args_for_block ~pass rewrite_id ~typing_env_at_use - arg_being_unboxed tag fields + arg_being_unboxed tag shape fields | Unbox (Closure_single_entry { function_slot; vars_within_closure }) -> compute_extra_args_for_closure ~pass rewrite_id ~typing_env_at_use arg_being_unboxed function_slot vars_within_closure @@ -243,25 +276,15 @@ and compute_extra_args_for_one_decision_and_use_aux ~(pass : U.pass) rewrite_id rewrite_id ~typing_env_at_use arg_being_unboxed and compute_extra_args_for_block ~pass rewrite_id ~typing_env_at_use - arg_being_unboxed tag fields : U.decision = - let size = Or_unknown.Known (Targetint_31_63.of_int (List.length fields)) in - let bak, invalid_const = - if Tag.equal tag Tag.double_array_tag - then - ( P.Block_access_kind.Naked_floats { size }, - Const.naked_float Numeric_types.Float_by_bit_pattern.zero ) - else - ( P.Block_access_kind.Values - { size; - tag = Known (Option.get (Tag.Scannable.of_tag tag)); - field_kind = Any_value - }, - Const.const_zero ) - in + arg_being_unboxed tag (shape : K.Block_shape.t) fields : U.decision = let _, fields = List.fold_left_map (fun field_nth ({ epa; decision; kind } : U.field_decision) : (_ * U.field_decision) -> + let bak, invalid_const = + access_kind_and_dummy_const tag shape fields + (Targetint_31_63.to_int field_nth) + in let unboxer = Unboxers.Field.unboxer ~invalid_const bak ~index:field_nth in @@ -278,7 +301,7 @@ and compute_extra_args_for_block ~pass rewrite_id ~typing_env_at_use Targetint_31_63.(add one field_nth), { epa; decision; kind }) Targetint_31_63.zero fields in - Unbox (Unique_tag_and_size { tag; fields }) + Unbox (Unique_tag_and_size { tag; shape; fields }) and compute_extra_args_for_closure ~pass rewrite_id ~typing_env_at_use arg_being_unboxed function_slot vars_within_closure : U.decision = @@ -351,21 +374,19 @@ and compute_extra_args_for_variant ~pass rewrite_id ~typing_env_at_use in let fields_by_tag = Tag.Scannable.Map.mapi - (fun tag_decision block_fields -> - let size = List.length block_fields in + (fun tag_decision (shape, block_fields) -> (* See doc/unboxing.md about invalid constants, poison and aliases. *) let invalid_const = Const.const_int (Targetint_31_63.of_int 0xbaba) in - let bak : Flambda_primitive.Block_access_kind.t = - Values - { size = Known (Targetint_31_63.of_int size); - tag = Known tag_decision; - field_kind = Any_value - } - in let new_fields_decisions, _ = List.fold_left (fun (new_decisions, field_nth) ({ epa; decision; kind } : U.field_decision) -> + let bak, _const = + access_kind_and_dummy_const + (Tag.Scannable.to_tag tag_decision) + shape block_fields + (Targetint_31_63.to_int field_nth) + in let new_extra_arg, new_arg_being_unboxed = if are_there_non_const_ctors_at_use && Tag.Scannable.equal tag_at_use_site tag_decision @@ -391,7 +412,7 @@ and compute_extra_args_for_variant ~pass rewrite_id ~typing_env_at_use new_decisions, Targetint_31_63.(add one field_nth)) ([], Targetint_31_63.zero) block_fields in - List.rev new_fields_decisions) + shape, List.rev new_fields_decisions) fields_by_tag_from_decision in Unbox (Variant { tag; const_ctors; fields_by_tag }) @@ -400,7 +421,7 @@ let add_extra_params_and_args extra_params_and_args decision = let rec aux extra_params_and_args (decision : U.decision) = match decision with | Do_not_unbox _ -> extra_params_and_args - | Unbox (Unique_tag_and_size { tag = _; fields }) -> + | Unbox (Unique_tag_and_size { tag = _; shape = _; fields }) -> List.fold_left (fun extra_params_and_args ({ epa; decision; kind } : U.field_decision) -> let extra_param = BP.create epa.param kind in @@ -422,7 +443,7 @@ let add_extra_params_and_args extra_params_and_args decision = | Unbox (Variant { tag; const_ctors; fields_by_tag }) -> let extra_params_and_args = Tag.Scannable.Map.fold - (fun _ block_fields extra_params_and_args -> + (fun _ (_shape, block_fields) extra_params_and_args -> List.fold_left (fun extra_params_and_args ({ epa; decision; kind } : U.field_decision) -> diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_types.ml b/middle_end/flambda2/simplify/unboxing/unboxing_types.ml index b329f44eb82..550fc3cd6c9 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_types.ml +++ b/middle_end/flambda2/simplify/unboxing/unboxing_types.ml @@ -54,12 +54,14 @@ end type unboxing_decision = | Unique_tag_and_size of { tag : Tag.t; + shape : K.Block_shape.t; fields : field_decision list } | Variant of { tag : Extra_param_and_args.t; const_ctors : const_ctors_decision; - fields_by_tag : field_decision list Tag.Scannable.Map.t + fields_by_tag : + (K.Block_shape.t * field_decision list) Tag.Scannable.Map.t } | Closure_single_entry of { function_slot : Function_slot.t; @@ -110,17 +112,18 @@ let rec print_decision ppf = function | Do_not_unbox reason -> Format.fprintf ppf "@[(do_not_unbox@ %a)@]" print_do_not_unbox_reason reason - | Unbox (Unique_tag_and_size { tag; fields }) -> + | Unbox (Unique_tag_and_size { tag; shape; fields }) -> Format.fprintf ppf - "@[(unique_tag_and_size@ @[(static_tag %a)@]@ @[(fields@ \ - %a)@])@]" - Tag.print tag print_fields_decisions fields + "@[(unique_tag_and_size@ @[(static_tag %a)@]@ @[(shape %a)@]@ \ + @[(fields@ %a)@])@]" + Tag.print tag K.Block_shape.print shape print_fields_decisions fields | Unbox (Variant { tag; const_ctors; fields_by_tag }) -> Format.fprintf ppf "@[(variant@ @[(tag %a)@]@ @[(const_ctors@ %a)@]@ @[(fields_by_tag@ %a)@])@]" Extra_param_and_args.print tag print_const_ctor_num const_ctors - (Tag.Scannable.Map.print print_fields_decisions) + (Tag.Scannable.Map.print (fun ppf (_shape, fields) -> + print_fields_decisions ppf fields)) fields_by_tag | Unbox (Closure_single_entry { function_slot; vars_within_closure }) -> Format.fprintf ppf diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_types.mli b/middle_end/flambda2/simplify/unboxing/unboxing_types.mli index 391b7afc289..f06e919792b 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_types.mli +++ b/middle_end/flambda2/simplify/unboxing/unboxing_types.mli @@ -42,12 +42,14 @@ end type unboxing_decision = | Unique_tag_and_size of { tag : Tag.t; + shape : Flambda_kind.Block_shape.t; fields : field_decision list } | Variant of { tag : Extra_param_and_args.t; const_ctors : const_ctors_decision; - fields_by_tag : field_decision list Tag.Scannable.Map.t + fields_by_tag : + (Flambda_kind.Block_shape.t * field_decision list) Tag.Scannable.Map.t } | Closure_single_entry of { function_slot : Function_slot.t; diff --git a/middle_end/flambda2/terms/code_size.ml b/middle_end/flambda2/terms/code_size.ml index ec537cef6f0..0bdf41c499c 100644 --- a/middle_end/flambda2/terms/code_size.ml +++ b/middle_end/flambda2/terms/code_size.ml @@ -159,14 +159,7 @@ let block_set (kind : Flambda_primitive.Block_access_kind.t) does_not_need_caml_c_call_extcall_size (* caml_modify *) | Values _, (Assignment Local | Initialization) -> 1 (* cadda + store *) | Naked_floats _, (Assignment _ | Initialization) -> 1 - | ( Mixed - { field_kind = - ( Value_prefix _ - | Flat_suffix - (Imm | Float_boxed | Float64 | Float32 | Bits32 | Bits64 | Word) - ); - _ - }, + | ( Mixed { field_kind = Value_prefix _ | Flat_suffix _; _ }, (Assignment _ | Initialization) ) -> 1 @@ -420,8 +413,7 @@ let variadic_prim_size prim args = | Make_block (_, _mut, _alloc_mode) (* CR mshinwell: I think Make_array for a generic array ("Anything") is more expensive than the other cases *) - | Make_array (_, _mut, _alloc_mode) - | Make_mixed_block (_, _, _mut, _alloc_mode) -> + | Make_array (_, _mut, _alloc_mode) -> alloc_size + List.length args let prim (prim : Flambda_primitive.t) = diff --git a/middle_end/flambda2/terms/flambda_primitive.ml b/middle_end/flambda2/terms/flambda_primitive.ml index e9bdb4f3217..dbca2acfe35 100644 --- a/middle_end/flambda2/terms/flambda_primitive.ml +++ b/middle_end/flambda2/terms/flambda_primitive.ml @@ -29,6 +29,13 @@ module Block_kind = struct type t = | Values of Tag.Scannable.t * K.With_subkind.t list | Naked_floats + | Mixed of Tag.Scannable.t * Flambda_kind.Mixed_block_shape.t + + let to_shape t : _ * K.Block_shape.t = + match t with + | Values (tag, _) -> Tag.Scannable.to_tag tag, Value_only + | Naked_floats -> Tag.double_array_tag, Float_record + | Mixed (tag, fields) -> Tag.Scannable.to_tag tag, Mixed_record fields let [@ocamlformat "disable"] print ppf t = match t with @@ -42,6 +49,14 @@ module Block_kind = struct K.With_subkind.print) shape | Naked_floats -> Format.pp_print_string ppf "Naked_floats" + | Mixed (tag, shape) -> + Format.fprintf ppf + "@[(Mixed@ \ + @[(tag %a)@]@ \ + @[(shape@ @[(%a)@])@])@]" + Tag.Scannable.print tag + (Format.pp_print_list ~pp_sep:Format.pp_print_space + K.print) (Array.to_list (K.Mixed_block_shape.field_kinds shape)) let compare t1 t2 = match t1, t2 with @@ -51,137 +66,13 @@ module Block_kind = struct then c else Misc.Stdlib.List.compare K.With_subkind.compare shape1 shape2 | Naked_floats, Naked_floats -> 0 + | Mixed (tag1, shape1), Mixed (tag2, shape2) -> + let c = Tag.Scannable.compare tag1 tag2 in + if c <> 0 then c else K.Mixed_block_shape.compare shape1 shape2 | Values _, _ -> -1 | _, Values _ -> 1 - - let element_kind t = - match t with Values _ -> K.value | Naked_floats -> K.naked_float -end - -module Mixed_block_flat_element = struct - type t = - | Imm - | Float_boxed - | Float64 - | Float32 - | Bits32 - | Bits64 - | Word - - let from_lambda : Lambda.flat_element -> t = function - | Imm -> Imm - | Float_boxed -> Float_boxed - | Float64 -> Float64 - | Float32 -> Float32 - | Bits32 -> Bits32 - | Bits64 -> Bits64 - | Word -> Word - - let to_lambda : t -> Lambda.flat_element = function - | Imm -> Imm - | Float_boxed -> Float_boxed - | Float64 -> Float64 - | Float32 -> Float32 - | Bits32 -> Bits32 - | Bits64 -> Bits64 - | Word -> Word - - let to_string = function - | Imm -> "Imm" - | Float_boxed -> "Float_boxed" - | Float64 -> "Float64" - | Float32 -> "Float32" - | Bits32 -> "Bits32" - | Bits64 -> "Bits64" - | Word -> "Word" - - let compare t1 t2 = - match t1, t2 with - | Imm, Imm - | Float_boxed, Float_boxed - | Float64, Float64 - | Float32, Float32 - | Word, Word - | Bits32, Bits32 - | Bits64, Bits64 -> - 0 - | Imm, _ -> -1 - | _, Imm -> 1 - | Float_boxed, _ -> -1 - | _, Float_boxed -> 1 - | Float64, _ -> -1 - | _, Float64 -> 1 - | Float32, _ -> -1 - | _, Float32 -> 1 - | Word, _ -> -1 - | _, Word -> 1 - | Bits32, _ -> -1 - | _, Bits32 -> 1 - - let print ppf t = Format.fprintf ppf "%s" (to_string t) - - let element_kind = function - | Imm -> K.value - | Float_boxed | Float64 -> K.naked_float - | Float32 -> K.naked_float32 - | Bits32 -> K.naked_int32 - | Bits64 -> K.naked_int64 - | Word -> K.naked_nativeint -end - -module Mixed_block_kind = struct - type t = - { value_prefix_len : int; - (* We use an array just so we can index into the middle. *) - flat_suffix : Mixed_block_flat_element.t array - } - - let from_lambda { Lambda.value_prefix_len; flat_suffix } = - { value_prefix_len; - flat_suffix = Array.map Mixed_block_flat_element.from_lambda flat_suffix - } - - let to_lambda { value_prefix_len; flat_suffix } : Lambda.mixed_block_shape = - { value_prefix_len; - flat_suffix = Array.map Mixed_block_flat_element.to_lambda flat_suffix - } - - let print ppf ({ value_prefix_len; flat_suffix } : t) = - Format.fprintf ppf "[|@ "; - Format.fprintf ppf "Value (x%d);@ " value_prefix_len; - Array.iter - (fun elem -> - Format.fprintf ppf "%a;@ " Mixed_block_flat_element.print elem) - flat_suffix; - Format.fprintf ppf "|]" - - let compare (t1 : t) (t2 : t) = - let components (t : t) = - let (({ value_prefix_len; flat_suffix } [@warning "+9"]) : t) = t in - value_prefix_len, flat_suffix - in - let v1, a1 = components t1 in - let v2, a2 = components t2 in - match Int.compare v1 v2 with - | 0 -> Misc.Stdlib.Array.compare Mixed_block_flat_element.compare a1 a2 - | cmp -> cmp - - let length ({ value_prefix_len; flat_suffix } : t) = - value_prefix_len + Array.length flat_suffix - - let element_kind i { value_prefix_len; flat_suffix } = - if i < 0 then Misc.fatal_errorf "Negative index: %d" i; - if i < value_prefix_len - then K.value - else - Mixed_block_flat_element.element_kind flat_suffix.(i - value_prefix_len) - - let fold_left f init t = - let result = ref init in - for i = 0 to length t - 1 do - result := f !result (element_kind i t) - done; - !result + | Naked_floats, _ -> -1 + | _, Naked_floats -> 1 end module Init_or_assign = struct @@ -468,7 +359,7 @@ end module Mixed_block_access_field_kind = struct type t = | Value_prefix of Block_access_field_kind.t - | Flat_suffix of Mixed_block_flat_element.t + | Flat_suffix of K.t let [@ocamlformat "disable"] print ppf t = match t with @@ -483,20 +374,20 @@ module Mixed_block_access_field_kind = struct "@[(Flat_suffix \ @[(flat_element@ %a)@]\ )@]" - Mixed_block_flat_element.print flat_element + K.print flat_element let compare t1 t2 = match t1, t2 with | Value_prefix field_kind1, Value_prefix field_kind2 -> Block_access_field_kind.compare field_kind1 field_kind2 | Flat_suffix element_kind1, Flat_suffix element_kind2 -> - Mixed_block_flat_element.compare element_kind1 element_kind2 + K.compare element_kind1 element_kind2 | Value_prefix _, Flat_suffix _ -> -1 | Flat_suffix _, Value_prefix _ -> 1 let to_element_kind = function | Value_prefix _ -> K.value - | Flat_suffix flat -> Mixed_block_flat_element.element_kind flat + | Flat_suffix kind -> kind end module Block_access_kind = struct @@ -510,7 +401,8 @@ module Block_access_kind = struct | Mixed of { tag : Tag.Scannable.t Or_unknown.t; size : Targetint_31_63.t Or_unknown.t; - field_kind : Mixed_block_access_field_kind.t + field_kind : Mixed_block_access_field_kind.t; + shape : Flambda_kind.Mixed_block_shape.t } let [@ocamlformat "disable"] print ppf t = @@ -531,7 +423,7 @@ module Block_access_kind = struct @[(size@ %a)@]\ )@]" (Or_unknown.print Targetint_31_63.print) size - | Mixed { tag; size; field_kind } -> + | Mixed { tag; size; field_kind; shape = _ } -> Format.fprintf ppf "@[(Mixed@ \ @[(tag@ %a)@]@ \ @@ -558,14 +450,14 @@ module Block_access_kind = struct | Mixed { field_kind = Value_prefix Immediate; _ } -> K.With_subkind.tagged_immediate | Naked_floats _ -> K.With_subkind.naked_float - | Mixed { field_kind = Flat_suffix field_kind; _ } -> ( - match field_kind with - | Imm -> K.With_subkind.tagged_immediate - | Float_boxed | Float64 -> K.With_subkind.naked_float - | Float32 -> K.With_subkind.naked_float32 - | Bits32 -> K.With_subkind.naked_int32 - | Bits64 -> K.With_subkind.naked_int64 - | Word -> K.With_subkind.naked_nativeint) + | Mixed { field_kind = Flat_suffix field_kind; _ } -> + K.With_subkind.anything field_kind + + let to_block_shape t : K.Block_shape.t = + match t with + | Values _ -> Value_only + | Naked_floats _ -> Float_record + | Mixed { shape; _ } -> Mixed_record shape let element_kind_for_set = element_kind_for_load @@ -583,8 +475,11 @@ module Block_access_kind = struct else Block_access_field_kind.compare field_kind1 field_kind2 | Naked_floats { size = size1 }, Naked_floats { size = size2 } -> Or_unknown.compare Targetint_31_63.compare size1 size2 - | ( Mixed { tag = tag1; size = size1; field_kind = field_kind1 }, - Mixed { tag = tag2; size = size2; field_kind = field_kind2 } ) -> + | ( Mixed + { tag = tag1; size = size1; field_kind = field_kind1; shape = shape1 }, + Mixed + { tag = tag2; size = size2; field_kind = field_kind2; shape = shape2 } + ) -> let c = Or_unknown.compare Tag.Scannable.compare tag1 tag2 in if c <> 0 then c @@ -592,7 +487,13 @@ module Block_access_kind = struct let c = Or_unknown.compare Targetint_31_63.compare size1 size2 in if c <> 0 then c - else Mixed_block_access_field_kind.compare field_kind1 field_kind2 + else + let c = + Mixed_block_access_field_kind.compare field_kind1 field_kind2 + in + if c <> 0 + then c + else Flambda_kind.Mixed_block_shape.compare shape1 shape2 | Naked_floats _, Mixed _ -> -1 | Mixed _, Naked_floats _ -> 1 | Values _, _ -> -1 @@ -923,7 +824,7 @@ let print_unary_float_arith_op ppf width op = | Float32, Neg -> fprintf ppf "Float32.~-" type arg_kinds = - | Variadic of K.t list + | Variadic_mixed of K.Mixed_block_shape.t | Variadic_all_of_kind of K.t type result_kind = @@ -1931,32 +1832,17 @@ let ids_for_export_ternary_primitive p = type variadic_primitive = | Make_block of Block_kind.t * Mutability.t * Alloc_mode.For_allocations.t | Make_array of Array_kind.t * Mutability.t * Alloc_mode.For_allocations.t - | Make_mixed_block of - Tag.Scannable.t - * Mixed_block_kind.t - * Mutability.t - * Alloc_mode.For_allocations.t let variadic_primitive_eligible_for_cse p ~args = match p with - | Make_block (_, _, Local _) - | Make_array (_, Immutable, Local _) - | Make_mixed_block (_, _, _, Local _) -> + | Make_block (_, _, Local _) | Make_array (_, _, Local _) -> false + | Make_block (_, Mutable, _) | Make_array (_, Mutable, _) -> false + | Make_block (_, Immutable_unique, _) | Make_array (_, Immutable_unique, _) -> false - | Make_block (_, Immutable, Heap) - | Make_array (_, Immutable, _) - | Make_mixed_block (_, _, Immutable, Heap) -> + | Make_block (_, Immutable, Heap) | Make_array (_, Immutable, Heap) -> (* See comment in [unary_primitive_eligible_for_cse], above, on [Box_number] case. *) List.exists (fun arg -> Simple.is_var arg) args - | Make_block (_, Immutable_unique, _) - | Make_array (_, Immutable_unique, _) - | Make_mixed_block (_, _, Immutable_unique, _) -> - false - | Make_block (_, Mutable, _) - | Make_array (_, Mutable, _) - | Make_mixed_block (_, _, Mutable, _) -> - false let compare_variadic_primitive p1 p2 = match p1, p2 with @@ -1980,22 +1866,6 @@ let compare_variadic_primitive p1 p2 = if c <> 0 then c else Alloc_mode.For_allocations.compare alloc_mode1 alloc_mode2 - | ( Make_mixed_block (tag1, kind1, mut1, alloc_mode1), - Make_mixed_block (tag2, kind2, mut2, alloc_mode2) ) -> - let c = Tag.Scannable.compare tag1 tag2 in - if c <> 0 - then c - else - let c = Mixed_block_kind.compare kind1 kind2 in - if c <> 0 - then c - else - let c = Stdlib.compare mut1 mut2 in - if c <> 0 - then c - else Alloc_mode.For_allocations.compare alloc_mode1 alloc_mode2 - | Make_array _, Make_mixed_block _ -> -1 - | Make_mixed_block _, Make_array _ -> 1 | Make_block _, _ -> -1 | _, Make_block _ -> 1 @@ -2010,31 +1880,21 @@ let print_variadic_primitive ppf p = | Make_array (kind, mut, alloc_mode) -> fprintf ppf "@[(Make_array@ %a@ %a@ %a)@]" Array_kind.print kind Mutability.print mut Alloc_mode.For_allocations.print alloc_mode - | Make_mixed_block (tag, kind, mut, alloc_mode) -> - fprintf ppf "@[(Make_mixed_block %a@ %a@ %a@ %a)@]" - Tag.Scannable.print tag Mixed_block_kind.print kind Mutability.print mut - Alloc_mode.For_allocations.print alloc_mode let args_kind_of_variadic_primitive p : arg_kinds = match p with - | Make_block (kind, _, _) -> - Variadic_all_of_kind (Block_kind.element_kind kind) + | Make_block (Values _, _, _) -> Variadic_all_of_kind K.value + | Make_block (Naked_floats, _, _) -> Variadic_all_of_kind K.naked_float + | Make_block (Mixed (_tag, shape), _, _) -> Variadic_mixed shape | Make_array (kind, _, _) -> Variadic_all_of_kind (Array_kind.element_kind_for_primitive kind) - | Make_mixed_block (_, kind, _, _) -> - Variadic - (List.init (Mixed_block_kind.length kind) (fun i -> - Mixed_block_kind.element_kind i kind)) let result_kind_of_variadic_primitive p : result_kind = - match p with - | Make_block _ | Make_array _ | Make_mixed_block _ -> Singleton K.value + match p with Make_block _ | Make_array _ -> Singleton K.value let effects_and_coeffects_of_variadic_primitive p = match p with - | Make_block (_, mut, alloc_mode) - | Make_array (_, mut, alloc_mode) - | Make_mixed_block (_, _, mut, alloc_mode) -> + | Make_block (_, mut, alloc_mode) | Make_array (_, mut, alloc_mode) -> let coeffects : Coeffects.t = match alloc_mode with | Heap -> Coeffects.No_coeffects @@ -2043,8 +1903,7 @@ let effects_and_coeffects_of_variadic_primitive p = Effects.Only_generative_effects mut, coeffects, Placement.Strict let variadic_classify_for_printing p = - match p with - | Make_block _ | Make_array _ | Make_mixed_block _ -> Constructive + match p with Make_block _ | Make_array _ -> Constructive let free_names_variadic_primitive p = match p with @@ -2052,8 +1911,6 @@ let free_names_variadic_primitive p = Alloc_mode.For_allocations.free_names alloc_mode | Make_array (_kind, _mut, alloc_mode) -> Alloc_mode.For_allocations.free_names alloc_mode - | Make_mixed_block (_tag, _kind, _mut, alloc_mode) -> - Alloc_mode.For_allocations.free_names alloc_mode let apply_renaming_variadic_primitive p renaming = match p with @@ -2067,13 +1924,6 @@ let apply_renaming_variadic_primitive p renaming = Alloc_mode.For_allocations.apply_renaming alloc_mode renaming in if alloc_mode == alloc_mode' then p else Make_array (kind, mut, alloc_mode') - | Make_mixed_block (tag, kind, mut, alloc_mode) -> - let alloc_mode' = - Alloc_mode.For_allocations.apply_renaming alloc_mode renaming - in - if alloc_mode == alloc_mode' - then p - else Make_mixed_block (tag, kind, mut, alloc_mode') let ids_for_export_variadic_primitive p = match p with @@ -2081,8 +1931,6 @@ let ids_for_export_variadic_primitive p = Alloc_mode.For_allocations.ids_for_export alloc_mode | Make_array (_kind, _mut, alloc_mode) -> Alloc_mode.For_allocations.ids_for_export alloc_mode - | Make_mixed_block (_tag, _kind, _mut, alloc_mode) -> - Alloc_mode.For_allocations.ids_for_export alloc_mode type t = | Nullary of nullary_primitive @@ -2391,9 +2239,7 @@ module Eligible_for_cse = struct | Make_block (Values (tag, kinds), mutability, alloc_mode) -> let kinds = List.map K.With_subkind.erase_subkind kinds in Make_block (Values (tag, kinds), mutability, alloc_mode) - | Make_block (Naked_floats, _, _) - | Make_array _ | Make_mixed_block _ -> - prim + | Make_block ((Naked_floats | Mixed _), _, _) | Make_array _ -> prim in Variadic (prim, args) in diff --git a/middle_end/flambda2/terms/flambda_primitive.mli b/middle_end/flambda2/terms/flambda_primitive.mli index 3119c772163..58b4af6a287 100644 --- a/middle_end/flambda2/terms/flambda_primitive.mli +++ b/middle_end/flambda2/terms/flambda_primitive.mli @@ -28,6 +28,9 @@ module Block_kind : sig type t = | Values of Tag.Scannable.t * Flambda_kind.With_subkind.t list | Naked_floats + | Mixed of Tag.Scannable.t * Flambda_kind.Mixed_block_shape.t + + val to_shape : t -> Tag.t * Flambda_kind.Block_shape.t val print : Format.formatter -> t -> unit @@ -63,47 +66,6 @@ module Array_kind_for_length : sig | Float_array_opt_dynamic end -module Mixed_block_flat_element : sig - type t = - | Imm - | Float_boxed - | Float64 - | Float32 - | Bits32 - | Bits64 - | Word - - val from_lambda : Lambda.flat_element -> t - - val to_string : t -> string - - val print : Format.formatter -> t -> unit - - val compare : t -> t -> int -end - -module Mixed_block_kind : sig - type t = - { value_prefix_len : int; - (* We use an array just so we can index into the middle. *) - flat_suffix : Mixed_block_flat_element.t array - } - - val from_lambda : Lambda.mixed_block_shape -> t - - val to_lambda : t -> Lambda.mixed_block_shape - - val print : Format.formatter -> t -> unit - - val compare : t -> t -> int - - val fold_left : ('a -> Flambda_kind.t -> 'a) -> 'a -> t -> 'a - - val element_kind : int -> t -> Flambda_kind.t - - val length : t -> int -end - module Init_or_assign : sig type t = | Initialization @@ -184,7 +146,7 @@ end module Mixed_block_access_field_kind : sig type t = | Value_prefix of Block_access_field_kind.t - | Flat_suffix of Mixed_block_flat_element.t + | Flat_suffix of Flambda_kind.t val print : Format.formatter -> t -> unit @@ -202,7 +164,8 @@ module Block_access_kind : sig | Mixed of { tag : Tag.Scannable.t Or_unknown.t; size : Targetint_31_63.t Or_unknown.t; - field_kind : Mixed_block_access_field_kind.t + field_kind : Mixed_block_access_field_kind.t; + shape : Flambda_kind.Mixed_block_shape.t } val print : Format.formatter -> t -> unit @@ -212,6 +175,8 @@ module Block_access_kind : sig val element_kind_for_load : t -> Flambda_kind.t val element_subkind_for_load : t -> Flambda_kind.With_subkind.t + + val to_block_shape : t -> Flambda_kind.Block_shape.t end (* CR-someday mshinwell: We should have unboxed arrays of int32, int64 and @@ -487,11 +452,6 @@ type ternary_primitive = type variadic_primitive = | Make_block of Block_kind.t * Mutability.t * Alloc_mode.For_allocations.t | Make_array of Array_kind.t * Mutability.t * Alloc_mode.For_allocations.t - | Make_mixed_block of - Tag.Scannable.t - * Mixed_block_kind.t - * Mutability.t - * Alloc_mode.For_allocations.t (* CR mshinwell: Invariant checks -- e.g. that the number of arguments matches [num_dimensions] *) @@ -539,7 +499,7 @@ val args_kind_of_ternary_primitive : ternary_primitive -> Flambda_kind.t * Flambda_kind.t * Flambda_kind.t type arg_kinds = - | Variadic of Flambda_kind.t list + | Variadic_mixed of Flambda_kind.Mixed_block_shape.t | Variadic_all_of_kind of Flambda_kind.t val args_kind_of_variadic_primitive : variadic_primitive -> arg_kinds diff --git a/middle_end/flambda2/terms/removed_operations.ml b/middle_end/flambda2/terms/removed_operations.ml index ae5080567ad..d18319969d0 100644 --- a/middle_end/flambda2/terms/removed_operations.ml +++ b/middle_end/flambda2/terms/removed_operations.ml @@ -56,7 +56,7 @@ let prim (prim : Flambda_primitive.t) = | Nullary _ -> zero | Binary (_, _, _) | Ternary (_, _, _, _) -> { zero with prim = 1 } | Variadic (prim, _) -> ( - match prim with Make_block _ | Make_array _ | Make_mixed_block _ -> alloc) + match prim with Make_block _ | Make_array _ -> alloc) [@@ocaml.warning "-fragile-match"] let branch = { zero with branch = 1 } diff --git a/middle_end/flambda2/tests/api_tests/extension_meet.ml b/middle_end/flambda2/tests/api_tests/extension_meet.ml index 81a219f0222..26942c35679 100644 --- a/middle_end/flambda2/tests/api_tests/extension_meet.ml +++ b/middle_end/flambda2/tests/api_tests/extension_meet.ml @@ -32,20 +32,22 @@ let _test_recursive_meet () = let env = TE.add_definition env nb_v Flambda_kind.value in let alias name = T.alias_type_of Flambda_kind.value (Simple.name name) in let mk_block_type name = - T.immutable_block ~is_unique:false Tag.zero ~field_kind:Flambda_kind.value - Alloc_mode.For_types.heap + T.immutable_block ~is_unique:false Tag.zero + ~shape:Flambda_kind.Block_shape.Value_only Alloc_mode.For_types.heap ~fields:[alias name] in let env = TE.add_equation env n_x (mk_block_type n_y) in let env = TE.add_equation env n_y (mk_block_type n_z) in let env = TE.add_equation env n_z (mk_block_type n_x) in let ty1 = - T.immutable_block ~is_unique:false Tag.zero ~field_kind:Flambda_kind.value + T.immutable_block ~is_unique:false Tag.zero + ~shape:Flambda_kind.Block_shape.Value_only ~fields:[alias n_v; alias n_v] Alloc_mode.For_types.heap in let ty2 = - T.immutable_block ~is_unique:false Tag.zero ~field_kind:Flambda_kind.value + T.immutable_block ~is_unique:false Tag.zero + ~shape:Flambda_kind.Block_shape.Value_only ~fields:[alias n_x; alias n_y] Alloc_mode.For_types.heap in @@ -71,12 +73,14 @@ let _test_bottom_detection () = (Simple.const (Reg_width_const.const_int (Targetint_31_63.of_int n))) in let ty1 = - T.immutable_block ~is_unique:false Tag.zero ~field_kind:Flambda_kind.value + T.immutable_block ~is_unique:false Tag.zero + ~shape:Flambda_kind.Block_shape.Value_only ~fields:[alias n_x; alias n_x] Alloc_mode.For_types.heap in let ty2 = - T.immutable_block ~is_unique:false Tag.zero ~field_kind:Flambda_kind.value + T.immutable_block ~is_unique:false Tag.zero + ~shape:Flambda_kind.Block_shape.Value_only ~fields:[const 0; const 1] Alloc_mode.For_types.heap in @@ -102,18 +106,21 @@ let _test_bottom_recursive () = (Simple.const (Reg_width_const.const_int (Targetint_31_63.of_int n))) in let ty_x = - T.immutable_block ~is_unique:false Tag.zero ~field_kind:Flambda_kind.value + T.immutable_block ~is_unique:false Tag.zero + ~shape:Flambda_kind.Block_shape.Value_only ~fields:[T.unknown Flambda_kind.value; alias n_x] Alloc_mode.For_types.heap in let env = TE.add_equation env n_x ty_x in let ty_cell2 = - T.immutable_block ~is_unique:false Tag.zero ~field_kind:Flambda_kind.value + T.immutable_block ~is_unique:false Tag.zero + ~shape:Flambda_kind.Block_shape.Value_only ~fields:[const 1; T.unknown Flambda_kind.value] Alloc_mode.For_types.heap in let ty_cell1 = - T.immutable_block ~is_unique:false Tag.zero ~field_kind:Flambda_kind.value + T.immutable_block ~is_unique:false Tag.zero + ~shape:Flambda_kind.Block_shape.Value_only ~fields:[const 0; ty_cell2] Alloc_mode.For_types.heap in @@ -146,17 +153,20 @@ let test_double_recursion () = let env = TE.add_definition env nb_z Flambda_kind.value in let alias name = T.alias_type_of Flambda_kind.value (Simple.name name) in let ty_x = - T.immutable_block ~is_unique:false Tag.zero ~field_kind:Flambda_kind.value + T.immutable_block ~is_unique:false Tag.zero + ~shape:Flambda_kind.Block_shape.Value_only ~fields:[alias n_x; alias n_y; alias n_z] Alloc_mode.For_types.heap in let ty_y = - T.immutable_block ~is_unique:false Tag.zero ~field_kind:Flambda_kind.value + T.immutable_block ~is_unique:false Tag.zero + ~shape:Flambda_kind.Block_shape.Value_only ~fields:[alias n_y; alias n_z; alias n_x] Alloc_mode.For_types.heap in let ty_z = - T.immutable_block ~is_unique:false Tag.zero ~field_kind:Flambda_kind.value + T.immutable_block ~is_unique:false Tag.zero + ~shape:Flambda_kind.Block_shape.Value_only ~fields:[alias n_z; alias n_x; alias n_y] Alloc_mode.For_types.heap in diff --git a/middle_end/flambda2/tests/meet_test.ml b/middle_end/flambda2/tests/meet_test.ml index be768c2c1d9..6cefc957478 100644 --- a/middle_end/flambda2/tests/meet_test.ml +++ b/middle_end/flambda2/tests/meet_test.ml @@ -21,8 +21,9 @@ let test_meet_chains_two_vars () = let env = TE.add_definition env (Bound_name.create_var var1') K.value in let env = TE.add_equation env (Name.var var1) - (T.immutable_block ~is_unique:false Tag.zero ~field_kind:K.value - Alloc_mode.For_types.heap ~fields:[T.any_tagged_immediate]) + (T.immutable_block ~is_unique:false Tag.zero + ~shape:K.Block_shape.Value_only Alloc_mode.For_types.heap + ~fields:[T.any_tagged_immediate]) in let var2 = Variable.create "var2" in let var2' = Bound_var.create var2 Name_mode.normal in @@ -54,8 +55,9 @@ let test_meet_chains_three_vars () = let env = TE.add_definition env (Bound_name.create_var var1') K.value in let env = TE.add_equation env (Name.var var1) - (T.immutable_block ~is_unique:false Tag.zero ~field_kind:K.value - Alloc_mode.For_types.heap ~fields:[T.any_tagged_immediate]) + (T.immutable_block ~is_unique:false Tag.zero + ~shape:K.Block_shape.Value_only Alloc_mode.For_types.heap + ~fields:[T.any_tagged_immediate]) in let var2 = Variable.create "var2" in let var2' = Bound_var.create var2 Name_mode.normal in @@ -102,18 +104,24 @@ let meet_variants_don't_lose_aliases () = let ty1 = let non_const_ctors = Tag.Scannable.Map.of_list - [ Tag.Scannable.create_exn 0, [T.alias_type_of K.value (Simple.var vx)]; - Tag.Scannable.create_exn 1, [T.alias_type_of K.value (Simple.var vy)] - ] + [ ( Tag.Scannable.create_exn 0, + (K.Block_shape.Value_only, [T.alias_type_of K.value (Simple.var vx)]) + ); + ( Tag.Scannable.create_exn 1, + (K.Block_shape.Value_only, [T.alias_type_of K.value (Simple.var vy)]) + ) ] in T.variant ~const_ctors ~non_const_ctors Alloc_mode.For_types.heap in let ty2 = let non_const_ctors = Tag.Scannable.Map.of_list - [ Tag.Scannable.create_exn 0, [T.alias_type_of K.value (Simple.var va)]; - Tag.Scannable.create_exn 1, [T.alias_type_of K.value (Simple.var vb)] - ] + [ ( Tag.Scannable.create_exn 0, + (K.Block_shape.Value_only, [T.alias_type_of K.value (Simple.var va)]) + ); + ( Tag.Scannable.create_exn 1, + (K.Block_shape.Value_only, [T.alias_type_of K.value (Simple.var vb)]) + ) ] in T.variant ~const_ctors ~non_const_ctors Alloc_mode.For_types.heap in @@ -148,14 +156,14 @@ let test_meet_two_blocks () = let env = defines env [block1; block2; field1; field2] in let env = TE.add_equation env (Name.var block1) - (T.immutable_block ~is_unique:false Tag.zero ~field_kind:K.value - Alloc_mode.For_types.heap + (T.immutable_block ~is_unique:false Tag.zero + ~shape:K.Block_shape.Value_only Alloc_mode.For_types.heap ~fields:[T.alias_type_of K.value (Simple.var field1)]) in let env = TE.add_equation env (Name.var block2) - (T.immutable_block ~is_unique:false Tag.zero ~field_kind:K.value - Alloc_mode.For_types.heap + (T.immutable_block ~is_unique:false Tag.zero + ~shape:K.Block_shape.Value_only Alloc_mode.For_types.heap ~fields:[T.alias_type_of K.value (Simple.var field2)]) in (* let test b1 b2 env = diff --git a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml index 07662e5d99f..bdd893e48a7 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml @@ -92,6 +92,10 @@ let make_block ~dbg kind alloc_mode args = | Values (tag, _) -> C.make_alloc ~mode dbg (Tag.Scannable.to_int tag) args | Naked_floats -> C.make_float_alloc ~mode dbg (Tag.to_int Tag.double_array_tag) args + | Mixed (tag, shape) -> + C.make_mixed_alloc ~mode dbg (Tag.Scannable.to_int tag) + (K.Mixed_block_shape.to_lambda shape) + args let block_load ~dbg (kind : P.Block_access_kind.t) (mutability : Mutability.t) ~block ~index = @@ -106,15 +110,25 @@ let block_load ~dbg (kind : P.Block_access_kind.t) (mutability : Mutability.t) | Naked_floats _ -> C.unboxed_float_array_ref block index dbg | Mixed { field_kind = Flat_suffix field_kind; _ } -> ( match field_kind with - | Imm -> C.get_field_computed Immediate mutability ~block ~index dbg - | Float_boxed | Float64 -> + | Value -> + (* The flat suffix cannot store scannable values, so this must be an + immediate *) + C.get_field_computed Immediate mutability ~block ~index dbg + | Naked_number Naked_float -> (* CR layouts v5.1: We should use the mutability here to generate better code if the load is immutable. *) C.unboxed_float_array_ref block index dbg - | Float32 -> C.get_field_unboxed_float32 mutability ~block ~index dbg - | Bits32 -> C.get_field_unboxed_int32 mutability ~block ~index dbg - | Bits64 | Word -> - C.get_field_unboxed_int64_or_nativeint mutability ~block ~index dbg) + | Naked_number Naked_float32 -> + C.get_field_unboxed_float32 mutability ~block ~index dbg + | Naked_number Naked_int32 -> + C.get_field_unboxed_int32 mutability ~block ~index dbg + | Naked_number (Naked_int64 | Naked_nativeint) -> + C.get_field_unboxed_int64_or_nativeint mutability ~block ~index dbg + | Naked_number Naked_vec128 -> + Misc.fatal_error "Naked_vec128 not supported in mixed blocks" + | Naked_number Naked_immediate | Region | Rec_info -> + Misc.fatal_errorf "Unexpected kind in mixed block field: %a" K.print + field_kind) let block_set ~dbg (kind : P.Block_access_kind.t) (init : P.Init_or_assign.t) ~block ~index ~new_value = @@ -130,13 +144,21 @@ let block_set ~dbg (kind : P.Block_access_kind.t) (init : P.Init_or_assign.t) | Naked_floats _ -> C.float_array_set block index new_value dbg | Mixed { field_kind = Flat_suffix field_kind; _ } -> ( match field_kind with - | Imm -> + | Value -> + (* See comment in [block_load] about assuming [Immediate] *) C.setfield_computed Immediate init_or_assign block index new_value dbg - | Float_boxed | Float64 -> C.float_array_set block index new_value dbg - | Float32 -> C.setfield_unboxed_float32 block index new_value dbg - | Bits32 -> C.setfield_unboxed_int32 block index new_value dbg - | Bits64 | Word -> - C.setfield_unboxed_int64_or_nativeint block index new_value dbg) + | Naked_number Naked_float -> C.float_array_set block index new_value dbg + | Naked_number Naked_float32 -> + C.setfield_unboxed_float32 block index new_value dbg + | Naked_number Naked_int32 -> + C.setfield_unboxed_int32 block index new_value dbg + | Naked_number (Naked_int64 | Naked_nativeint) -> + C.setfield_unboxed_int64_or_nativeint block index new_value dbg + | Naked_number Naked_vec128 -> + Misc.fatal_error "Naked_vec128 not supported in mixed blocks" + | Naked_number Naked_immediate | Region | Rec_info -> + Misc.fatal_errorf "Unexpected kind in mixed block field: %a" K.print + field_kind) in C.return_unit dbg expr @@ -156,13 +178,6 @@ let make_array ~dbg kind alloc_mode args = | Naked_nativeints -> C.allocate_unboxed_nativeint_array ~elements:args mode dbg -let make_mixed_block ~dbg tag shape alloc_mode args = - check_alloc_fields args; - let mode = Alloc_mode.For_allocations.to_lambda alloc_mode in - let tag = Tag.Scannable.to_int tag in - let shape = P.Mixed_block_kind.to_lambda shape in - C.make_mixed_alloc ~mode dbg tag shape args - let array_length ~dbg arr (kind : P.Array_kind.t) = match kind with | Immediates | Values | Naked_floats -> @@ -819,8 +834,6 @@ let variadic_primitive _env dbg f args = match (f : P.variadic_primitive) with | Make_block (kind, _mut, alloc_mode) -> make_block ~dbg kind alloc_mode args | Make_array (kind, _mut, alloc_mode) -> make_array ~dbg kind alloc_mode args - | Make_mixed_block (tag, shape, _mut, alloc_mode) -> - make_mixed_block ~dbg tag shape alloc_mode args let arg ?consider_inlining_effectful_expressions ~dbg env res simple = C.simple ?consider_inlining_effectful_expressions ~dbg env res simple @@ -887,8 +900,7 @@ let consider_inlining_effectful_expressions p = that the Cmm translation for such primitive both respects right-to-left evaluation order and does not duplicate any arguments. *) match[@ocaml.warning "-4"] (p : P.t) with - | Variadic ((Make_block _ | Make_array _ | Make_mixed_block _), _) -> - Some true + | Variadic ((Make_block _ | Make_array _), _) -> Some true | Nullary _ | Unary _ | Binary _ | Ternary _ -> None let prim_simple env res dbg p = @@ -939,8 +951,7 @@ let prim_simple env res dbg p = let effs = Ece.join (Ece.join x.effs y.effs) z.effs in let expr = ternary_primitive env dbg ternary x.cmm y.cmm z.cmm in Env.simple expr free_vars, None, env, res, effs - | Variadic - (((Make_block _ | Make_array _ | Make_mixed_block _) as variadic), l) -> + | Variadic (((Make_block _ | Make_array _) as variadic), l) -> let args, free_vars, env, res, effs = arg_list ?consider_inlining_effectful_expressions ~dbg env res l in @@ -975,8 +986,7 @@ let prim_complex env res dbg p = let To_cmm_env.{ env; res; expr = z } = arg env res z in let effs = Ece.join (Ece.join x.effs y.effs) z.effs in prim', [x; y; z], effs, env, res - | Variadic - (((Make_block _ | Make_array _ | Make_mixed_block _) as variadic), l) -> + | Variadic (((Make_block _ | Make_array _) as variadic), l) -> let prim' = P.Without_args.Variadic variadic in let args, env, res, effs = arg_list' ?consider_inlining_effectful_expressions ~dbg env res l diff --git a/middle_end/flambda2/types/env/typing_env.ml b/middle_end/flambda2/types/env/typing_env.ml index 0dbc700c09b..58202e763e9 100644 --- a/middle_end/flambda2/types/env/typing_env.ml +++ b/middle_end/flambda2/types/env/typing_env.ml @@ -1250,7 +1250,8 @@ end = struct TG.alias_type_of Flambda_kind.value (Simple.symbol symbol) | Block_approximation (tag, fields, alloc_mode) -> let fields = List.map type_from_approx (Array.to_list fields) in - MTC.immutable_block ~is_unique:false tag ~field_kind:Flambda_kind.value + let shape : Flambda_kind.Block_shape.t = Value_only in + MTC.immutable_block ~is_unique:false (Tag.Scannable.to_tag tag) ~shape ~fields alloc_mode | Closure_approximation { code_id; @@ -1415,12 +1416,17 @@ end = struct then match TG.Row_like_for_blocks.get_singleton blocks with | None -> Value_unknown - | Some ((tag, _size), fields, alloc_mode) -> + | Some (tag, Value_only, _size, fields, alloc_mode) -> let fields = List.map type_to_approx (TG.Product.Int_indexed.components fields) in - Block_approximation (tag, Array.of_list fields, alloc_mode) + Block_approximation + ( Option.get (Tag.Scannable.of_tag tag), + Array.of_list fields, + alloc_mode ) + | Some (_, (Float_record | Mixed_record _), _, _, _) -> + Value_unknown else Value_unknown)) | Naked_immediate _ | Naked_float _ | Naked_float32 _ | Naked_int32 _ | Naked_int64 _ | Naked_vec128 _ | Naked_nativeint _ | Rec_info _ diff --git a/middle_end/flambda2/types/flambda2_types.mli b/middle_end/flambda2/types/flambda2_types.mli index 2a0d4d12527..a4aa7003f51 100644 --- a/middle_end/flambda2/types/flambda2_types.mli +++ b/middle_end/flambda2/types/flambda2_types.mli @@ -461,7 +461,7 @@ val any_block : t val immutable_block : is_unique:bool -> Tag.t -> - field_kind:Flambda_kind.t -> + shape:Flambda_kind.Block_shape.t -> Alloc_mode.For_types.t -> fields:t list -> t @@ -472,7 +472,7 @@ val immutable_block : val immutable_block_with_size_at_least : tag:Tag.t Or_unknown.t -> n:Targetint_31_63.t -> - field_kind:Flambda_kind.t -> + shape:Flambda_kind.Block_shape.t -> field_n_minus_one:Variable.t -> t @@ -480,7 +480,7 @@ val mutable_block : Alloc_mode.For_types.t -> t val variant : const_ctors:t -> - non_const_ctors:t list Tag.Scannable.Map.t -> + non_const_ctors:(Flambda_kind.Block_shape.t * t list) Tag.Scannable.Map.t -> Alloc_mode.For_types.t -> t @@ -593,7 +593,8 @@ val meet_naked_nativeints : type variant_like_proof = private { const_ctors : Targetint_31_63.Set.t Or_unknown.t; - non_const_ctors_with_sizes : Targetint_31_63.t Tag.Scannable.Map.t + non_const_ctors_with_sizes : + (Targetint_31_63.t * Flambda_kind.Block_shape.t) Tag.Scannable.Map.t } val meet_variant_like : Typing_env.t -> t -> variant_like_proof meet_shortcut @@ -634,10 +635,15 @@ val prove_is_or_is_not_a_boxed_float : Typing_env.t -> t -> bool proof_of_property val prove_unique_tag_and_size : - Typing_env.t -> t -> (Tag.t * Targetint_31_63.t) proof_of_property + Typing_env.t -> + t -> + (Tag.t * Flambda_kind.Block_shape.t * Targetint_31_63.t) proof_of_property val prove_unique_fully_constructed_immutable_heap_block : - Typing_env.t -> t -> (Tag_and_size.t * Simple.t list) proof_of_property + Typing_env.t -> + t -> + (Tag.t * Flambda_kind.Block_shape.t * Targetint_31_63.t * Simple.t list) + proof_of_property val prove_is_int : Typing_env.t -> t -> bool proof_of_property diff --git a/middle_end/flambda2/types/grammar/more_type_creators.ml b/middle_end/flambda2/types/grammar/more_type_creators.ml index 64989cd7644..20489ac035a 100644 --- a/middle_end/flambda2/types/grammar/more_type_creators.ml +++ b/middle_end/flambda2/types/grammar/more_type_creators.ml @@ -33,6 +33,9 @@ let unknown (kind : K.t) = let unknown_like t = unknown (TG.kind t) +let unknown_from_shape (shape : K.Block_shape.t) index = + unknown (K.Block_shape.element_kind shape index) + let bottom (kind : K.t) = match kind with | Value -> TG.bottom_value @@ -142,15 +145,15 @@ let blocks_with_these_tags tags alloc_mode : _ Or_unknown.t = if not (Tag.Set.for_all Tag.is_structured_block tags) then Unknown else + let tags = Tag.Map.of_set (fun _ -> Or_unknown.Unknown) tags in let blocks = - TG.Row_like_for_blocks.create_blocks_with_these_tags ~field_kind:K.value - tags alloc_mode + TG.Row_like_for_blocks.create_blocks_with_these_tags tags alloc_mode in Known (TG.create_variant ~is_unique:false ~immediates:(Known TG.bottom_naked_immediate) ~blocks:(Known blocks)) -let immutable_block ~is_unique tag ~field_kind alloc_mode ~fields = +let immutable_block ~is_unique tag ~shape alloc_mode ~fields = match Targetint_31_63.of_int_option (List.length fields) with | None -> (* CR-someday mshinwell: This should be a special kind of error. *) @@ -159,13 +162,14 @@ let immutable_block ~is_unique tag ~field_kind alloc_mode ~fields = TG.create_variant ~is_unique ~immediates:(Known TG.bottom_naked_immediate) ~blocks: (Known - (TG.Row_like_for_blocks.create ~field_kind ~field_tys:fields - (Closed tag) alloc_mode)) + (TG.Row_like_for_blocks.create ~shape ~field_tys:fields (Closed tag) + alloc_mode)) -let immutable_block_with_size_at_least ~tag ~n ~field_kind ~field_n_minus_one = +let immutable_block_with_size_at_least ~tag ~n ~shape ~field_n_minus_one = let n = Targetint_31_63.to_int n in let field_tys = List.init n (fun index -> + let field_kind = K.Block_shape.element_kind shape index in if index < n - 1 then unknown field_kind else TG.alias_type_of field_kind (Simple.var field_n_minus_one)) @@ -174,18 +178,19 @@ let immutable_block_with_size_at_least ~tag ~n ~field_kind ~field_n_minus_one = ~immediates:(Known (bottom K.naked_immediate)) ~blocks: (Known - (TG.Row_like_for_blocks.create ~field_kind ~field_tys (Open tag) + (TG.Row_like_for_blocks.create ~shape ~field_tys (Open tag) (Alloc_mode.For_types.unknown ()))) let variant ~const_ctors ~non_const_ctors alloc_mode = let blocks = - let field_tys_by_tag = + let shape_and_field_tys_by_tag = Tag.Scannable.Map.fold (fun tag ty non_const_ctors -> Tag.Map.add (Tag.Scannable.to_tag tag) ty non_const_ctors) non_const_ctors Tag.Map.empty in - TG.Row_like_for_blocks.create_exactly_multiple ~field_tys_by_tag alloc_mode + TG.Row_like_for_blocks.create_exactly_multiple ~shape_and_field_tys_by_tag + alloc_mode in TG.create_variant ~is_unique:false ~immediates:(Known const_ctors) ~blocks:(Known blocks) @@ -330,14 +335,14 @@ let rec unknown_with_subkind ?(alloc_mode = Alloc_mode.For_types.unknown ()) let const_ctors = these_naked_immediates consts in let non_const_ctors = Tag.Scannable.Map.map - (fun fields -> - List.map (fun subkind -> unknown_with_subkind subkind) fields) + (fun (shape, fields) -> + shape, List.map (fun subkind -> unknown_with_subkind subkind) fields) non_consts in variant ~const_ctors ~non_const_ctors alloc_mode | Float_block { num_fields } -> immutable_block ~is_unique:false Tag.double_array_tag - ~field_kind:Flambda_kind.naked_float + ~shape:Flambda_kind.Block_shape.Float_record ~fields:(List.init num_fields (fun _ -> TG.any_naked_float)) alloc_mode | Float_array -> diff --git a/middle_end/flambda2/types/grammar/more_type_creators.mli b/middle_end/flambda2/types/grammar/more_type_creators.mli index 17f6dd09426..da9d9faa774 100644 --- a/middle_end/flambda2/types/grammar/more_type_creators.mli +++ b/middle_end/flambda2/types/grammar/more_type_creators.mli @@ -21,6 +21,8 @@ val unknown : Flambda_kind.t -> Type_grammar.t val unknown_like : Type_grammar.t -> Type_grammar.t +val unknown_from_shape : Flambda_kind.Block_shape.t -> int -> Type_grammar.t + val bottom : Flambda_kind.t -> Type_grammar.t val bottom_like : Type_grammar.t -> Type_grammar.t @@ -107,7 +109,7 @@ val blocks_with_these_tags : val immutable_block : is_unique:bool -> Tag.t -> - field_kind:Flambda_kind.t -> + shape:Flambda_kind.Block_shape.t -> Alloc_mode.For_types.t -> fields:Type_grammar.t list -> Type_grammar.t @@ -115,13 +117,14 @@ val immutable_block : val immutable_block_with_size_at_least : tag:Tag.t Or_unknown.t -> n:Targetint_31_63.t -> - field_kind:Flambda_kind.t -> + shape:Flambda_kind.Block_shape.t -> field_n_minus_one:Variable.t -> Type_grammar.t val variant : const_ctors:Type_grammar.t -> - non_const_ctors:Type_grammar.t list Tag.Scannable.Map.t -> + non_const_ctors: + (Flambda_kind.Block_shape.t * Type_grammar.t list) Tag.Scannable.Map.t -> Alloc_mode.For_types.t -> Type_grammar.t diff --git a/middle_end/flambda2/types/grammar/type_grammar.ml b/middle_end/flambda2/types/grammar/type_grammar.ml index 4193aaa844e..85ae325117e 100644 --- a/middle_end/flambda2/types/grammar/type_grammar.ml +++ b/middle_end/flambda2/types/grammar/type_grammar.ml @@ -130,33 +130,38 @@ and head_of_kind_region = unit * type 'index row_like_index = { at_least : 'index; at_most : 'index } * representing { x | at_least \subset x /\ x \subset at_most } *) -and 'index row_like_index = - | Known of 'index (** [Known x] represents the singleton set: { x } *) - | At_least of 'index +and 'lattice row_like_index_domain = + | Known of 'lattice (** [Known x] represents the singleton set: { x } *) + | At_least of 'lattice (** [At_least x] represents the set { y | x \subset y } *) -and ('index, 'maps_to) row_like_case = +and ('lattice, 'shape) row_like_index = + { domain : 'lattice row_like_index_domain; + shape : 'shape + } + +and ('lattice, 'shape, 'maps_to) row_like_case = { maps_to : 'maps_to; - (** Kinds different from [Value] are only allowed in cases with known - tags. Currently cases with tag 254 must have fields of kind - [Naked_float] and all other must have fields of kind [Value]. *) - index : 'index row_like_index; + index : ('lattice, 'shape) row_like_index; env_extension : env_extension } +and row_like_block_case = (Block_size.t, K.Block_shape.t, t array) row_like_case + and row_like_for_blocks = - { known_tags : (Block_size.t, int_indexed_product) row_like_case Tag.Map.t; - other_tags : (Block_size.t, int_indexed_product) row_like_case Or_bottom.t; + { known_tags : row_like_block_case Or_unknown.t Tag.Map.t; + other_tags : row_like_block_case Or_bottom.t; alloc_mode : Alloc_mode.For_types.t } and row_like_for_closures = { known_closures : - (Set_of_closures_contents.t, closures_entry) row_like_case + (Set_of_closures_contents.t, unit, closures_entry) row_like_case Function_slot.Map.t; (* CR pchambart: this field is always Bottom, we should remove it *) other_closures : - (Set_of_closures_contents.t, closures_entry) row_like_case Or_bottom.t + (Set_of_closures_contents.t, unit, closures_entry) row_like_case + Or_bottom.t } and closures_entry = @@ -178,11 +183,6 @@ and function_slot_indexed_product = and value_slot_indexed_product = { value_slot_components_by_index : t Value_slot.Map.t } -and int_indexed_product = - { fields : t array; - kind : Flambda_kind.t - } - and function_type = { code_id : Code_id.t; rec_info : t @@ -301,23 +301,26 @@ and free_names_head_of_kind_rec_info head = and free_names_head_of_kind_region () = Name_occurrences.empty and free_names_row_like : - 'row_tag 'index 'maps_to 'known. - free_names_index:('index -> Name_occurrences.t) -> + 'row_tag 'lattice 'shape 'maps_to 'known. + free_names_lattice:('lattice -> Name_occurrences.t) -> free_names_maps_to: (follow_value_slots:bool -> 'maps_to -> Name_occurrences.t) -> follow_value_slots:bool -> known:'known -> - other:('index, 'maps_to) row_like_case Or_bottom.t -> + other:('lattice, 'shape, 'maps_to) row_like_case Or_bottom.t -> fold_known: - (('row_tag -> ('index, 'maps_to) row_like_case -> 'acc -> 'acc) -> + (('row_tag -> + ('lattice, 'shape, 'maps_to) row_like_case -> + 'acc -> + 'acc) -> 'known -> 'acc -> 'acc) -> Name_occurrences.t = - fun ~free_names_index ~free_names_maps_to ~follow_value_slots ~known ~other + fun ~free_names_lattice ~free_names_maps_to ~follow_value_slots ~known ~other ~fold_known -> - let[@inline always] free_names_index index = - match index with Known index | At_least index -> free_names_index index + let[@inline always] free_names_index { domain; shape = _ } = + match domain with Known index | At_least index -> free_names_lattice index in let from_known = fold_known @@ -340,14 +343,22 @@ and free_names_row_like : and free_names_row_like_for_blocks ~follow_value_slots { known_tags; other_tags; alloc_mode = _ } = + let fold_known f map acc = + Tag.Map.fold + (fun tag case acc -> + match (case : _ Or_unknown.t) with + | Unknown -> acc + | Known case -> f tag case acc) + map acc + in free_names_row_like - ~free_names_index:(fun _block_size -> Name_occurrences.empty) + ~free_names_lattice:(fun _block_size -> Name_occurrences.empty) ~free_names_maps_to:free_names_int_indexed_product ~follow_value_slots - ~known:known_tags ~other:other_tags ~fold_known:Tag.Map.fold + ~known:known_tags ~other:other_tags ~fold_known and free_names_row_like_for_closures ~follow_value_slots { known_closures; other_closures } = - free_names_row_like ~free_names_index:Set_of_closures_contents.free_names + free_names_row_like ~free_names_lattice:Set_of_closures_contents.free_names ~free_names_maps_to:free_names_closures_entry ~follow_value_slots ~known:known_closures ~other:other_closures ~fold_known:Function_slot.Map.fold @@ -394,7 +405,7 @@ and free_names_value_slot_indexed_product ~follow_value_slots value_slot) value_slot_components_by_index Name_occurrences.empty -and free_names_int_indexed_product ~follow_value_slots { fields; kind = _ } = +and free_names_int_indexed_product ~follow_value_slots fields = Array.fold_left (fun free_names_acc t -> Name_occurrences.union (free_names0 ~follow_value_slots t) free_names_acc) @@ -608,22 +619,27 @@ and apply_renaming_head_of_kind_rec_info head renaming = and apply_renaming_head_of_kind_region () _renaming = () and apply_renaming_row_like : - 'index 'maps_to 'known. - apply_renaming_index:('index -> Renaming.t -> 'index) -> + 'lattice 'shape 'maps_to 'known. + apply_renaming_lattice:('lattice -> Renaming.t -> 'lattice) -> apply_renaming_maps_to:('maps_to -> Renaming.t -> 'maps_to) -> known:'known -> - other:('index, 'maps_to) row_like_case Or_bottom.t -> + other:('lattice, 'shape, 'maps_to) row_like_case Or_bottom.t -> map_known: - ((('index, 'maps_to) row_like_case -> ('index, 'maps_to) row_like_case) -> + ((('lattice, 'shape, 'maps_to) row_like_case -> + ('lattice, 'shape, 'maps_to) row_like_case) -> 'known -> 'known) -> Renaming.t -> - ('known * ('index, 'maps_to) row_like_case Or_bottom.t) option = - fun ~apply_renaming_index ~apply_renaming_maps_to ~known ~other ~map_known + ('known * ('lattice, 'shape, 'maps_to) row_like_case Or_bottom.t) option = + fun ~apply_renaming_lattice ~apply_renaming_maps_to ~known ~other ~map_known renaming -> - let rename_index = function - | Known index -> Known (apply_renaming_index index renaming) - | At_least index -> At_least (apply_renaming_index index renaming) + let rename_index { domain; shape } = + let domain = + match domain with + | Known index -> Known (apply_renaming_lattice index renaming) + | At_least index -> At_least (apply_renaming_lattice index renaming) + in + { domain; shape } in let known' = map_known @@ -648,12 +664,14 @@ and apply_renaming_row_like : and apply_renaming_row_like_for_blocks ({ known_tags; other_tags; alloc_mode } as row_like_for_tags) renaming = + let map_known map_case = + Tag.Map.map_sharing (Or_unknown.map_sharing ~f:map_case) + in match apply_renaming_row_like - ~apply_renaming_index:(fun block_size _ -> block_size) + ~apply_renaming_lattice:(fun block_size _ -> block_size) ~apply_renaming_maps_to:apply_renaming_int_indexed_product - ~known:known_tags ~other:other_tags ~map_known:Tag.Map.map_sharing - renaming + ~known:known_tags ~other:other_tags ~map_known renaming with | None -> row_like_for_tags | Some (known_tags, other_tags) -> { known_tags; other_tags; alloc_mode } @@ -662,7 +680,7 @@ and apply_renaming_row_like_for_closures ({ known_closures; other_closures } as row_like_for_closures) renaming = match apply_renaming_row_like - ~apply_renaming_index:Set_of_closures_contents.apply_renaming + ~apply_renaming_lattice:Set_of_closures_contents.apply_renaming ~apply_renaming_maps_to:apply_renaming_closures_entry ~known:known_closures ~other:other_closures ~map_known:Function_slot.Map.map_sharing renaming @@ -706,12 +724,12 @@ and apply_renaming_value_slot_indexed_product { value_slot_components_by_index } in { value_slot_components_by_index } -and apply_renaming_int_indexed_product { fields; kind } renaming = +and apply_renaming_int_indexed_product fields renaming = let fields = Array.copy fields in for i = 0 to Array.length fields - 1 do fields.(i) <- apply_renaming fields.(i) renaming done; - { fields; kind } + fields and apply_renaming_function_type ({ code_id; rec_info } as function_type) renaming = @@ -870,27 +888,25 @@ and print_head_of_kind_rec_info ppf head = Rec_info_expr.print ppf head and print_head_of_kind_region ppf () = Format.pp_print_string ppf "Region" and print_row_like : - 'index 'maps_to 'known. - print_index:(Format.formatter -> 'index -> unit) -> + 'lattice 'shape 'maps_to 'known. + print_index: + (Format.formatter -> ('lattice, 'shape) row_like_index -> unit) -> print_maps_to:(Format.formatter -> 'maps_to -> unit) -> print_known_map: - ((Format.formatter -> ('index, 'maps_to) row_like_case -> unit) -> + ((Format.formatter -> + ('lattice, 'shape, 'maps_to) row_like_case -> + unit) -> Format.formatter -> 'known -> unit) -> is_empty_map_known:('known -> bool) -> known:'known -> - other:('index, 'maps_to) row_like_case Or_bottom.t -> + other:('lattice, 'shape, 'maps_to) row_like_case Or_bottom.t -> Alloc_mode.For_types.t -> Format.formatter -> unit = fun ~print_index ~print_maps_to ~print_known_map ~is_empty_map_known ~known ~other alloc_mode ppf -> - let print_index ppf = function - | Known index -> Format.fprintf ppf "(Known @[<2>%a@])" print_index index - | At_least min_index -> - Format.fprintf ppf "(At_least @[<2>%a@])" print_index min_index - in if row_like_is_bottom ~known ~other ~is_empty_map_known then let colour = Flambda_colours.top_or_bottom_type in @@ -913,15 +929,39 @@ and print_row_like : (Or_bottom.print print) other and print_row_like_for_blocks ppf { known_tags; other_tags; alloc_mode } = - print_row_like ~print_index:Block_size.print - ~print_maps_to:print_int_indexed_product ~print_known_map:Tag.Map.print - ~is_empty_map_known:Tag.Map.is_empty ~known:known_tags ~other:other_tags - alloc_mode ppf + let print_index ppf { domain; shape = _ } = + (* TODO: print shape *) + match domain with + | Known index -> + Format.fprintf ppf "(Known @[<2>%a@])" Block_size.print index + | At_least min_index -> + Format.fprintf ppf "(At_least @[<2>%a@])" Block_size.print min_index + in + let print_known_map print_case ppf cases = + Tag.Map.print + (fun ppf case -> + match (case : _ Or_unknown.t) with + | Unknown -> Format.fprintf ppf "Unknown_shape" + | Known case -> print_case ppf case) + ppf cases + in + print_row_like ~print_index ~print_maps_to:print_int_indexed_product + ~print_known_map ~is_empty_map_known:Tag.Map.is_empty ~known:known_tags + ~other:other_tags alloc_mode ppf and print_row_like_for_closures alloc_mode ppf { known_closures; other_closures } = - print_row_like ~print_index:Set_of_closures_contents.print - ~print_maps_to:print_closures_entry ~print_known_map:Function_slot.Map.print + let print_index ppf { domain; shape = _ } = + match domain with + | Known index -> + Format.fprintf ppf "(Known @[<2>%a@])" Set_of_closures_contents.print + index + | At_least min_index -> + Format.fprintf ppf "(At_least @[<2>%a@])" Set_of_closures_contents.print + min_index + in + print_row_like ~print_index ~print_maps_to:print_closures_entry + ~print_known_map:Function_slot.Map.print ~is_empty_map_known:Function_slot.Map.is_empty ~known:known_closures ~other:other_closures alloc_mode ppf @@ -947,8 +987,8 @@ and print_value_slot_indexed_product ppf { value_slot_components_by_index } = (Value_slot.Map.print print) value_slot_components_by_index -and print_int_indexed_product ppf { fields; kind } = - Format.fprintf ppf "@[((kind %a)@ %a)@]" K.print kind +and print_int_indexed_product ppf fields = + Format.fprintf ppf "@[(%a)@]" (Format.pp_print_list ~pp_sep:Format.pp_print_space print) (Array.to_list fields) @@ -1061,12 +1101,15 @@ and ids_for_export_head_of_kind_rec_info head = and ids_for_export_head_of_kind_region () = Ids_for_export.empty and ids_for_export_row_like : - 'row_tag 'index 'maps_to 'known. + 'row_tag 'lattice 'shape 'maps_to 'known. ids_for_export_maps_to:('maps_to -> Ids_for_export.t) -> known:'known -> - other:('index, 'maps_to) row_like_case Or_bottom.t -> + other:('lattice, 'shape, 'maps_to) row_like_case Or_bottom.t -> fold_known: - (('row_tag -> ('index, 'maps_to) row_like_case -> 'acc -> 'acc) -> + (('row_tag -> + ('lattice, 'shape, 'maps_to) row_like_case -> + 'acc -> + 'acc) -> 'known -> 'acc -> 'acc) -> @@ -1091,9 +1134,17 @@ and ids_for_export_row_like : and ids_for_export_row_like_for_blocks { known_tags; other_tags; alloc_mode = _ } = + let fold_known f map acc = + Tag.Map.fold + (fun tag case acc -> + match (case : _ Or_unknown.t) with + | Unknown -> acc + | Known case -> f tag case acc) + map acc + in ids_for_export_row_like ~ids_for_export_maps_to:ids_for_export_int_indexed_product ~known:known_tags - ~other:other_tags ~fold_known:Tag.Map.fold + ~other:other_tags ~fold_known and ids_for_export_row_like_for_closures { known_closures; other_closures } = ids_for_export_row_like ~ids_for_export_maps_to:ids_for_export_closures_entry @@ -1128,7 +1179,7 @@ and ids_for_export_value_slot_indexed_product { value_slot_components_by_index } (fun _ t ids -> Ids_for_export.union ids (ids_for_export t)) value_slot_components_by_index Ids_for_export.empty -and ids_for_export_int_indexed_product { fields; kind = _ } = +and ids_for_export_int_indexed_product fields = Array.fold_left (fun ids field -> Ids_for_export.union ids (ids_for_export field)) Ids_for_export.empty fields @@ -1303,20 +1354,21 @@ and apply_coercion_head_of_kind_rec_info head coercion : _ Or_bottom.t = and apply_coercion_head_of_kind_region () _coercion : _ Or_bottom.t = Ok () and apply_coercion_row_like : - 'index 'maps_to 'row_tag 'known. + 'lattice 'shape 'maps_to 'row_tag 'known. apply_coercion_maps_to: ('row_tag option -> 'maps_to -> Coercion.t -> 'maps_to Or_bottom.t) -> known:'known -> - other:('index, 'maps_to) row_like_case Or_bottom.t -> + other:('lattice, 'shape, 'maps_to) row_like_case Or_bottom.t -> is_empty_map_known:('known -> bool) -> filter_map_known: (('row_tag -> - ('index, 'maps_to) row_like_case -> - ('index, 'maps_to) row_like_case option) -> + ('lattice, 'shape, 'maps_to) row_like_case -> + ('lattice, 'shape, 'maps_to) row_like_case option) -> 'known -> 'known) -> Coercion.t -> - ('known * ('index, 'maps_to) row_like_case Or_bottom.t) Or_bottom.t = + ('known * ('lattice, 'shape, 'maps_to) row_like_case Or_bottom.t) + Or_bottom.t = fun ~apply_coercion_maps_to ~known ~other ~is_empty_map_known ~filter_map_known coercion -> let known = @@ -1733,39 +1785,44 @@ and remove_unused_value_slots_and_shortcut_aliases_head_of_kind_region () () and remove_unused_value_slots_and_shortcut_aliases_row_like : - 'index 'maps_to 'known. - remove_unused_value_slots_and_shortcut_aliases_index: - ('index -> + 'lattice 'shape 'maps_to 'known. + remove_unused_value_slots_and_shortcut_aliases_lattice: + ('lattice -> used_value_slots:Value_slot.Set.t -> canonicalise:(Simple.t -> Simple.t) -> - 'index) -> + 'lattice) -> remove_unused_value_slots_and_shortcut_aliases_maps_to: ('maps_to -> used_value_slots:Value_slot.Set.t -> canonicalise:(Simple.t -> Simple.t) -> 'maps_to) -> known:'known -> - other:('index, 'maps_to) row_like_case Or_bottom.t -> + other:('lattice, 'shape, 'maps_to) row_like_case Or_bottom.t -> map_known: - ((('index, 'maps_to) row_like_case -> ('index, 'maps_to) row_like_case) -> + ((('lattice, 'shape, 'maps_to) row_like_case -> + ('lattice, 'shape, 'maps_to) row_like_case) -> 'known -> 'known) -> used_value_slots:Value_slot.Set.t -> canonicalise:(Simple.t -> Simple.t) -> - ('known * ('index, 'maps_to) row_like_case Or_bottom.t) option = - fun ~remove_unused_value_slots_and_shortcut_aliases_index + ('known * ('lattice, 'shape, 'maps_to) row_like_case Or_bottom.t) option = + fun ~remove_unused_value_slots_and_shortcut_aliases_lattice ~remove_unused_value_slots_and_shortcut_aliases_maps_to ~known ~other ~map_known ~used_value_slots ~canonicalise -> - let[@inline always] remove_unused_value_slots_and_shortcut_aliases_index = - function - | Known index -> - Known - (remove_unused_value_slots_and_shortcut_aliases_index index - ~used_value_slots ~canonicalise) - | At_least index -> - At_least - (remove_unused_value_slots_and_shortcut_aliases_index index - ~used_value_slots ~canonicalise) + let[@inline always] remove_unused_value_slots_and_shortcut_aliases_index + { domain; shape } = + let domain = + match domain with + | Known index -> + Known + (remove_unused_value_slots_and_shortcut_aliases_lattice index + ~used_value_slots ~canonicalise) + | At_least index -> + At_least + (remove_unused_value_slots_and_shortcut_aliases_lattice index + ~used_value_slots ~canonicalise) + in + { domain; shape } in let known' = map_known @@ -1800,14 +1857,17 @@ and remove_unused_value_slots_and_shortcut_aliases_row_like : and remove_unused_value_slots_and_shortcut_aliases_row_like_for_blocks ({ known_tags; other_tags; alloc_mode } as row_like_for_tags) ~used_value_slots ~canonicalise = + let map_known map_case = + Tag.Map.map_sharing (Or_unknown.map_sharing ~f:map_case) + in match remove_unused_value_slots_and_shortcut_aliases_row_like - ~remove_unused_value_slots_and_shortcut_aliases_index: + ~remove_unused_value_slots_and_shortcut_aliases_lattice: (fun block_size ~used_value_slots:_ ~canonicalise:_ -> block_size) ~remove_unused_value_slots_and_shortcut_aliases_maps_to: remove_unused_value_slots_and_shortcut_aliases_int_indexed_product - ~known:known_tags ~other:other_tags ~map_known:Tag.Map.map_sharing - ~used_value_slots ~canonicalise + ~known:known_tags ~other:other_tags ~map_known ~used_value_slots + ~canonicalise with | None -> row_like_for_tags | Some (known_tags, other_tags) -> { known_tags; other_tags; alloc_mode } @@ -1817,7 +1877,7 @@ and remove_unused_value_slots_and_shortcut_aliases_row_like_for_closures ~used_value_slots ~canonicalise = match remove_unused_value_slots_and_shortcut_aliases_row_like - ~remove_unused_value_slots_and_shortcut_aliases_index: + ~remove_unused_value_slots_and_shortcut_aliases_lattice: (fun index ~used_value_slots ~canonicalise:_ -> Set_of_closures_contents.remove_unused_value_slots index ~used_value_slots) @@ -1877,15 +1937,15 @@ and remove_unused_value_slots_and_shortcut_aliases_value_slot_indexed_product in { value_slot_components_by_index } -and remove_unused_value_slots_and_shortcut_aliases_int_indexed_product - { fields; kind } ~used_value_slots ~canonicalise = +and remove_unused_value_slots_and_shortcut_aliases_int_indexed_product fields + ~used_value_slots ~canonicalise = let fields = Array.copy fields in for i = 0 to Array.length fields - 1 do fields.(i) <- remove_unused_value_slots_and_shortcut_aliases fields.(i) ~used_value_slots ~canonicalise done; - { fields; kind } + fields and remove_unused_value_slots_and_shortcut_aliases_function_type ({ code_id; rec_info } as function_type) ~used_value_slots ~canonicalise = @@ -2213,16 +2273,17 @@ and project_row_like_for_blocks ~to_project ~expand ({ known_tags; other_tags; alloc_mode } as blocks) = let known_tags' = Tag.Map.map_sharing - (fun ({ index; maps_to; env_extension } as case) -> - let env_extension' = - project_env_extension ~to_project ~expand env_extension - in - let maps_to' = - project_int_indexed_product ~to_project ~expand maps_to - in - if env_extension == env_extension' && maps_to == maps_to' - then case - else { index; env_extension = env_extension'; maps_to = maps_to' }) + (Or_unknown.map_sharing + ~f:(fun ({ index; maps_to; env_extension } as case) -> + let env_extension' = + project_env_extension ~to_project ~expand env_extension + in + let maps_to' = + project_int_indexed_product ~to_project ~expand maps_to + in + if env_extension == env_extension' && maps_to == maps_to' + then case + else { index; env_extension = env_extension'; maps_to = maps_to' })) known_tags in let other_tags' : _ Or_bottom.t = @@ -2319,8 +2380,7 @@ and project_value_slot_indexed_product ~to_project ~expand then product else { value_slot_components_by_index = value_slot_components_by_index' } -and project_int_indexed_product ~to_project ~expand - ({ fields; kind } as product) = +and project_int_indexed_product ~to_project ~expand fields = let changed = ref false in let fields' = Array.copy fields in for i = 0 to Array.length fields - 1 do @@ -2331,7 +2391,7 @@ and project_int_indexed_product ~to_project ~expand changed := true; fields'.(i) <- field') done; - if !changed then { fields = fields'; kind } else product + if !changed then fields' else fields and project_function_type ~to_project ~expand ({ code_id; rec_info } as function_type) = @@ -2458,24 +2518,28 @@ module Product = struct end module Int_indexed = struct - type t = int_indexed_product + type t = flambda_type array - let field_kind t = t.kind + let create_from_list tys = Array.of_list tys - let create_from_list kind tys = { kind; fields = Array.of_list tys } + let create_from_array fields = fields - let create_from_array kind fields = { kind; fields } + let create_top () = [||] - let create_top kind = { kind; fields = [||] } + let width t = Targetint_31_63.of_int (Array.length t) - let width t = Targetint_31_63.of_int (Array.length t.fields) - - let components t = Array.to_list t.fields + let components t = Array.to_list t end end module Row_like_index = struct - type 'index t = 'index row_like_index + type ('lattice, 'shape) t = ('lattice, 'shape) row_like_index + + let create ~domain ~shape = { domain; shape } +end + +module Row_like_index_domain = struct + type 'lattice t = 'lattice row_like_index_domain let known index = Known index @@ -2483,7 +2547,8 @@ module Row_like_index = struct end module Row_like_case = struct - type ('index, 'maps_to) t = ('index, 'maps_to) row_like_case + type ('lattice, 'shape, 'maps_to) t = + ('lattice, 'shape, 'maps_to) row_like_case let create ~maps_to ~index ~env_extension = { maps_to; index; env_extension } end @@ -2511,59 +2576,63 @@ module Row_like_for_blocks = struct | Ok _ -> Unknown | Bottom -> Known (Tag.Map.keys known_tags) - let create_exactly tag index maps_to alloc_mode = + let create_exactly tag index shape maps_to alloc_mode = { known_tags = Tag.Map.singleton tag - { maps_to; - index = Known index; - env_extension = { equations = Name.Map.empty } - }; + (Or_unknown.Known + { maps_to; + index = { domain = Known index; shape }; + env_extension = { equations = Name.Map.empty } + }); other_tags = Bottom; alloc_mode } - let create_at_least tag index maps_to alloc_mode = + let create_at_least tag index shape maps_to alloc_mode = { known_tags = Tag.Map.singleton tag - { maps_to; - index = At_least index; - env_extension = { equations = Name.Map.empty } - }; + (Or_unknown.Known + { maps_to; + index = { domain = At_least index; shape }; + env_extension = { equations = Name.Map.empty } + }); other_tags = Bottom; alloc_mode } - let create_at_least_unknown_tag index maps_to alloc_mode = + let create_at_least_unknown_tag index shape maps_to alloc_mode = { known_tags = Tag.Map.empty; other_tags = Ok { maps_to; - index = At_least index; + index = { domain = At_least index; shape }; env_extension = { equations = Name.Map.empty } }; alloc_mode } - let check_field_tys ~field_kind ~field_tys = - let field_kind' = - List.map kind field_tys |> Flambda_kind.Set.of_list - |> Flambda_kind.Set.get_singleton - in + let check_field_tys ~shape ~field_tys = if Flambda_features.check_invariants () then - match field_kind' with - | None -> - if List.length field_tys <> 0 - then Misc.fatal_error "[field_tys] must all be of the same kind" - | Some field_kind' -> - if not (Flambda_kind.equal field_kind field_kind') - then - Misc.fatal_errorf "Declared field kind %a doesn't match [field_tys]" - Flambda_kind.print field_kind + List.iteri + (fun i ty -> + let field_kind = kind ty in + let shape_kind = + match (shape : K.Block_shape.t) with + | Value_only -> K.value + | Float_record -> K.naked_float + | Mixed_record kinds -> (K.Mixed_block_shape.field_kinds kinds).(i) + in + if not (Flambda_kind.equal field_kind shape_kind) + then + Misc.fatal_errorf + "Kind mismatch for field %d: %a doesn't match its shape (%a)" i + Flambda_kind.print field_kind Flambda_kind.print shape_kind) + field_tys - let create ~(field_kind : Flambda_kind.t) ~field_tys + let create ~(shape : K.Block_shape.t) ~field_tys (open_or_closed : open_or_closed) alloc_mode = - check_field_tys ~field_kind ~field_tys; + check_field_tys ~shape ~field_tys; let tag : _ Or_unknown.t = let tag : _ Or_unknown.t = match open_or_closed with @@ -2573,87 +2642,64 @@ module Row_like_for_blocks = struct in match tag with | Unknown -> ( - match field_kind with - | Value -> Unknown - | Naked_number Naked_float -> Known Tag.double_array_tag - | Naked_number Naked_float32 - | Naked_number Naked_immediate - | Naked_number Naked_int32 - | Naked_number Naked_int64 - | Naked_number Naked_nativeint - | Naked_number Naked_vec128 - | Region | Rec_info -> - Misc.fatal_errorf "Bad kind %a for fields" Flambda_kind.print - field_kind) + match shape with + | Value_only | Mixed_record _ -> Unknown + | Float_record -> Known Tag.double_array_tag) | Known tag -> ( - match field_kind with - | Value -> ( + match shape with + | Value_only | Mixed_record _ -> ( match Tag.Scannable.of_tag tag with | Some _ -> Known tag | None -> Misc.fatal_error - "Blocks full of [Value]s must have a tag less than [No_scan_tag]") - | Naked_number Naked_float -> + "Blocks must have a tag less than [No_scan_tag] (except for \ + float records)") + | Float_record -> if not (Tag.equal tag Tag.double_array_tag) then Misc.fatal_error "Blocks full of naked floats must have tag [Tag.double_array_tag]"; - Known tag - | Naked_number Naked_float32 - | Naked_number Naked_immediate - | Naked_number Naked_int32 - | Naked_number Naked_int64 - | Naked_number Naked_nativeint - | Naked_number Naked_vec128 - | Region | Rec_info -> - Misc.fatal_errorf "Bad kind %a for fields" Flambda_kind.print - field_kind) - in - let product = { kind = field_kind; fields = Array.of_list field_tys } in + Known tag) + in + let product = Array.of_list field_tys in let size = Targetint_31_63.of_int (List.length field_tys) in match open_or_closed with | Open _ -> ( match tag with - | Known tag -> create_at_least tag size product alloc_mode - | Unknown -> create_at_least_unknown_tag size product alloc_mode) + | Known tag -> create_at_least tag size shape product alloc_mode + | Unknown -> create_at_least_unknown_tag size shape product alloc_mode) | Closed _ -> ( match tag with - | Known tag -> create_exactly tag size product alloc_mode + | Known tag -> create_exactly tag size shape product alloc_mode | Unknown -> assert false) (* see above *) - let create_blocks_with_these_tags ~field_kind tags alloc_mode = - let maps_to = Product.Int_indexed.create_top field_kind in - let case = - { maps_to; - index = At_least Targetint_31_63.zero; - env_extension = { equations = Name.Map.empty } - } + let create_blocks_with_these_tags tags alloc_mode = + let maps_to = Product.Int_indexed.create_top () in + let case shape = + Or_unknown.map + ~f:(fun shape -> + { maps_to; + index = { domain = At_least Targetint_31_63.zero; shape }; + env_extension = { equations = Name.Map.empty } + }) + shape in - { known_tags = Tag.Map.of_set (fun _ -> case) tags; - other_tags = Bottom; - alloc_mode - } + { known_tags = Tag.Map.map case tags; other_tags = Bottom; alloc_mode } - let create_exactly_multiple ~field_tys_by_tag alloc_mode = + let create_exactly_multiple ~shape_and_field_tys_by_tag alloc_mode = let known_tags = Tag.Map.map - (fun field_tys -> - let field_kind = - match field_tys with - | [] -> Flambda_kind.value - | field_ty :: _ -> kind field_ty - in - check_field_tys ~field_kind ~field_tys; - let maps_to = - { kind = field_kind; fields = Array.of_list field_tys } - in + (fun (shape, field_tys) -> + check_field_tys ~shape ~field_tys; + let maps_to = Array.of_list field_tys in let size = Targetint_31_63.of_int (List.length field_tys) in - { maps_to; - index = Known size; - env_extension = { equations = Name.Map.empty } - }) - field_tys_by_tag + Or_unknown.Known + { maps_to; + index = { domain = Known size; shape }; + env_extension = { equations = Name.Map.empty } + }) + shape_and_field_tys_by_tag in { known_tags; other_tags = Bottom; alloc_mode } @@ -2661,26 +2707,27 @@ module Row_like_for_blocks = struct (* CR-someday mshinwell: add invariant check? *) { known_tags; other_tags; alloc_mode } - let all_tags_and_indexes { known_tags; other_tags; alloc_mode = _ } : - _ Or_unknown.t = - match other_tags with + let all_tags_and_sizes t : + (Targetint_31_63.t * K.Block_shape.t) Tag.Map.t Or_unknown.t = + match t.other_tags with | Ok _ -> Unknown - | Bottom -> Known (Tag.Map.map (fun case -> case.index) known_tags) - - let all_tags_and_sizes t : Targetint_31_63.t Tag.Map.t Or_unknown.t = - match all_tags_and_indexes t with - | Unknown -> Unknown - | Known tags_and_indexes -> + | Bottom -> let any_unknown = ref false in let by_tag = Tag.Map.map - (fun index -> - match index with - | Known index -> index - | At_least index -> + (fun case -> + match (case : _ Or_unknown.t) with + | Unknown -> any_unknown := true; - index) - tags_and_indexes + (* result doesn't matter as it is unused *) + Targetint_31_63.zero, K.Block_shape.Value_only + | Known { index = { domain; shape }; _ } -> ( + match domain with + | Known size -> size, shape + | At_least size -> + any_unknown := true; + size, shape)) + t.known_tags in if !any_unknown then Unknown else Known by_tag @@ -2690,20 +2737,28 @@ module Row_like_for_blocks = struct | Bottom -> ( match Tag.Map.get_singleton known_tags with | None -> None - | Some (tag, { maps_to; index; env_extension = _ }) -> ( + | Some (_tag, Unknown) -> None + (* CR pchambart: We lose the tag information when we don't know the shape. + Example where this could matter: in Provers.prove_physical_equality + this could miss some physical inequality *) + | Some (tag, Known { maps_to; index; env_extension = _ }) -> ( (* If this is a singleton all the information from the env_extension is already part of the environment *) - match index with + match index.domain with | At_least _ -> None - | Known index -> Some ((tag, index), maps_to, alloc_mode))) + | Known size -> Some (tag, index.shape, size, maps_to, alloc_mode))) - let project_int_indexed_product { fields; kind = _ } index : _ Or_unknown.t = + let project_int_indexed_product fields index : _ Or_unknown.t = if Array.length fields <= index then Unknown else Known fields.(index) let get_field t index : _ Or_unknown_or_bottom.t = match get_singleton t with + (* CR pchambart vlaviron: This is missing the 'Other' case. It would be easy + to be efficient to get the the field when there is only the 'Other' case. + Also we could be slightly better when there are multiple tags with + exactly the same type: we could do a trivial join *) | None -> Unknown - | Some ((_tag, size), maps_to, _alloc_mode) -> ( + | Some (_tag, _shape, size, maps_to, _alloc_mode) -> ( if Targetint_31_63.( <= ) size index then Bottom else @@ -2722,7 +2777,7 @@ module Row_like_for_closures = struct = let known_closures = Function_slot.Map.singleton function_slot - { index = Known contents; + { index = { domain = Known contents; shape = () }; maps_to = closures_entry; env_extension = { equations = Name.Map.empty } } @@ -2734,7 +2789,7 @@ module Row_like_for_closures = struct = let known_closures = Function_slot.Map.singleton function_slot - { index = At_least contents; + { index = { domain = At_least contents; shape = () }; maps_to = closures_entry; env_extension = { equations = Name.Map.empty } } @@ -2754,7 +2809,7 @@ module Row_like_for_closures = struct | Some (tag, { maps_to; index; env_extension = _ }) -> ( (* If this is a singleton all the information from the env_extension is already part of the environment *) - match index with + match index.domain with | At_least _ -> None | Known index -> Some ((tag, index), maps_to))) diff --git a/middle_end/flambda2/types/grammar/type_grammar.mli b/middle_end/flambda2/types/grammar/type_grammar.mli index 3e4564b4871..67b5a3b02e3 100644 --- a/middle_end/flambda2/types/grammar/type_grammar.mli +++ b/middle_end/flambda2/types/grammar/type_grammar.mli @@ -93,28 +93,37 @@ and head_of_kind_rec_info = Rec_info_expr.t and head_of_kind_region = unit -and 'index row_like_index = private - | Known of 'index - | At_least of 'index +and 'lattice row_like_index_domain = private + | Known of 'lattice + | At_least of 'lattice -and ('index, 'maps_to) row_like_case = private +and ('lattice, 'shape) row_like_index = private + { domain : 'lattice row_like_index_domain; + shape : 'shape + } + +and ('lattice, 'shape, 'maps_to) row_like_case = private { maps_to : 'maps_to; - index : 'index row_like_index; + index : ('lattice, 'shape) row_like_index; env_extension : env_extension } +and row_like_block_case = + (Block_size.t, Flambda_kind.Block_shape.t, t array) row_like_case + and row_like_for_blocks = private - { known_tags : (Block_size.t, int_indexed_product) row_like_case Tag.Map.t; - other_tags : (Block_size.t, int_indexed_product) row_like_case Or_bottom.t; + { known_tags : row_like_block_case Or_unknown.t Tag.Map.t; + other_tags : row_like_block_case Or_bottom.t; alloc_mode : Alloc_mode.For_types.t } and row_like_for_closures = private { known_closures : - (Set_of_closures_contents.t, closures_entry) row_like_case + (Set_of_closures_contents.t, unit, closures_entry) row_like_case Function_slot.Map.t; other_closures : - (Set_of_closures_contents.t, closures_entry) row_like_case Or_bottom.t + (Set_of_closures_contents.t, unit, closures_entry) row_like_case + Or_bottom.t } and closures_entry = private @@ -129,11 +138,6 @@ and function_slot_indexed_product = private and value_slot_indexed_product = private { value_slot_components_by_index : t Value_slot.Map.t } -and int_indexed_product = private - { fields : t array; - kind : Flambda_kind.t - } - and function_type = private { code_id : Code_id.t; rec_info : t @@ -342,15 +346,13 @@ module Product : sig end module Int_indexed : sig - type t = int_indexed_product - - val create_top : Flambda_kind.t -> t + type t = flambda_type array - val create_from_list : Flambda_kind.t -> flambda_type list -> t + val create_top : unit -> t - val create_from_array : Flambda_kind.t -> flambda_type array -> t + val create_from_list : flambda_type list -> t - val field_kind : t -> Flambda_kind.t + val create_from_array : flambda_type array -> t val width : t -> Targetint_31_63.t @@ -384,21 +386,31 @@ module Closures_entry : sig end module Row_like_index : sig - type 'index t = 'index row_like_index + type ('lattice, 'shape) t = ('lattice, 'shape) row_like_index + + val create : + domain:'lattice row_like_index_domain -> + shape:'shape -> + ('lattice, 'shape) t +end - val known : 'index -> 'index t +module Row_like_index_domain : sig + type 'lattice t = 'lattice row_like_index_domain - val at_least : 'index -> 'index t + val known : 'lattice -> 'lattice t + + val at_least : 'lattice -> 'lattice t end module Row_like_case : sig - type ('index, 'maps_to) t = ('index, 'maps_to) row_like_case + type ('lattice, 'shape, 'maps_to) t = + ('lattice, 'shape, 'maps_to) row_like_case val create : maps_to:'maps_to -> - index:'index row_like_index -> + index:('lattice, 'shape) row_like_index -> env_extension:env_extension -> - ('index, 'maps_to) row_like_case + ('lattice, 'shape, 'maps_to) row_like_case end module Row_like_for_blocks : sig @@ -411,31 +423,42 @@ module Row_like_for_blocks : sig | Closed of Tag.t val create : - field_kind:Flambda_kind.t -> + shape:Flambda_kind.Block_shape.t -> field_tys:flambda_type list -> open_or_closed -> Alloc_mode.For_types.t -> t val create_blocks_with_these_tags : - field_kind:Flambda_kind.t -> Tag.Set.t -> Alloc_mode.For_types.t -> t + Flambda_kind.Block_shape.t Or_unknown.t Tag.Map.t -> + Alloc_mode.For_types.t -> + t val create_exactly_multiple : - field_tys_by_tag:flambda_type list Tag.Map.t -> Alloc_mode.For_types.t -> t + shape_and_field_tys_by_tag: + (Flambda_kind.Block_shape.t * flambda_type list) Tag.Map.t -> + Alloc_mode.For_types.t -> + t val create_raw : - known_tags:(Block_size.t, int_indexed_product) row_like_case Tag.Map.t -> - other_tags:(Block_size.t, int_indexed_product) row_like_case Or_bottom.t -> + known_tags:row_like_block_case Or_unknown.t Tag.Map.t -> + other_tags:row_like_block_case Or_bottom.t -> alloc_mode:Alloc_mode.For_types.t -> t val all_tags : t -> Tag.Set.t Or_unknown.t - val all_tags_and_sizes : t -> Targetint_31_63.t Tag.Map.t Or_unknown.t + val all_tags_and_sizes : + t -> (Targetint_31_63.t * Flambda_kind.Block_shape.t) Tag.Map.t Or_unknown.t val get_singleton : t -> - (Tag_and_size.t * Product.Int_indexed.t * Alloc_mode.For_types.t) option + (Tag.t + * Flambda_kind.Block_shape.t + * Targetint_31_63.t + * Product.Int_indexed.t + * Alloc_mode.For_types.t) + option (** Get the nth field of the block if it is unambiguous. @@ -486,10 +509,11 @@ module Row_like_for_closures : sig val create_raw : known_closures: - (Set_of_closures_contents.t, closures_entry) row_like_case + (Set_of_closures_contents.t, unit, closures_entry) row_like_case Function_slot.Map.t -> other_closures: - (Set_of_closures_contents.t, closures_entry) row_like_case Or_bottom.t -> + (Set_of_closures_contents.t, unit, closures_entry) row_like_case + Or_bottom.t -> t val get_singleton : diff --git a/middle_end/flambda2/types/meet_and_join_new.ml b/middle_end/flambda2/types/meet_and_join_new.ml index e8b94e589c1..d76f137d210 100644 --- a/middle_end/flambda2/types/meet_and_join_new.ml +++ b/middle_end/flambda2/types/meet_and_join_new.ml @@ -371,9 +371,7 @@ let[@inline always] meet_unknown meet_contents ~contents_is_bottom env | _, Unknown -> Ok (Left_input, env) | Unknown, _ -> Ok (Right_input, env) | Known contents1, Known contents2 -> - map_result - ~f:(fun contents -> Or_unknown.Known contents) - (meet_contents env contents1 contents2) + map_result ~f:Or_unknown.known (meet_contents env contents1 contents2) let[@inline always] join_unknown join_contents (env : Join_env.t) (or_unknown1 : _ Or_unknown.t) (or_unknown2 : _ Or_unknown.t) : @@ -921,31 +919,34 @@ and meet_head_of_kind_rec_info env _t1 _t2 = and meet_head_of_kind_region env () () : _ meet_result = Ok (Both_inputs, env) and meet_row_like : - 'index 'maps_to 'row_tag 'known. + 'lattice 'shape 'maps_to 'row_tag 'known. meet_maps_to:(TE.t -> 'maps_to -> 'maps_to -> 'maps_to meet_result) -> - equal_index:('index -> 'index -> bool) -> - subset_index:('index -> 'index -> bool) -> - union_index:('index -> 'index -> 'index) -> + equal_index:('lattice -> 'lattice -> bool) -> + subset_index:('lattice -> 'lattice -> bool) -> + union_index:('lattice -> 'lattice -> 'lattice) -> + meet_shape:('shape -> 'shape -> 'shape Or_bottom.t) -> is_empty_map_known:('known -> bool) -> get_singleton_map_known: - ('known -> ('row_tag * ('index, 'maps_to) TG.Row_like_case.t) option) -> + ('known -> + ('row_tag * ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) option) -> merge_map_known: (('row_tag -> - ('index, 'maps_to) TG.Row_like_case.t option -> - ('index, 'maps_to) TG.Row_like_case.t option -> - ('index, 'maps_to) TG.Row_like_case.t option) -> + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option -> + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option -> + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) -> 'known -> 'known -> 'known) -> TE.t -> known1:'known -> known2:'known -> - other1:('index, 'maps_to) TG.Row_like_case.t Or_bottom.t -> - other2:('index, 'maps_to) TG.Row_like_case.t Or_bottom.t -> - ('known * ('index, 'maps_to) TG.Row_like_case.t Or_bottom.t) meet_result = - fun ~meet_maps_to ~equal_index ~subset_index ~union_index ~is_empty_map_known - ~get_singleton_map_known ~merge_map_known initial_env ~known1 ~known2 - ~other1 ~other2 -> + other1:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t -> + other2:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t -> + ('known * ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t) + meet_result = + fun ~meet_maps_to ~equal_index ~subset_index ~union_index ~meet_shape + ~is_empty_map_known ~get_singleton_map_known ~merge_map_known initial_env + ~known1 ~known2 ~other1 ~other2 -> let common_scope = TE.current_scope initial_env in let base_env = TE.increment_scope initial_env in let extract_extension scoped_env = @@ -1004,39 +1005,46 @@ and meet_row_like : in result_env := new_result_env in - let meet_index env (i1 : 'index TG.row_like_index) - (i2 : 'index TG.row_like_index) : 'index TG.row_like_index meet_result = - match i1, i2 with - | Known i1', Known i2' -> - if equal_index i1' i2' then Ok (Both_inputs, env) else Bottom - | Known known, At_least at_least -> - if subset_index at_least known - then - (* [at_least] is included in [known] hence [Known known] is included in - [At_least at_least], hence [Known known] \inter [At_least at_least] = - [Known known] *) - Ok (Left_input, env) - else Bottom - | At_least at_least, Known known -> - if subset_index at_least known then Ok (Right_input, env) else Bottom - | At_least i1', At_least i2' -> - if subset_index i1' i2' - then - if subset_index i2' i1' - then Ok (Both_inputs, env) - else Ok (Right_input, env) - else if subset_index i2' i1' - then Ok (Left_input, env) - else - Ok (New_result (TG.Row_like_index.at_least (union_index i1' i2')), env) + let meet_index env (i1 : ('lattice, 'shape) TG.row_like_index) + (i2 : ('lattice, 'shape) TG.row_like_index) : + ('lattice, 'shape) TG.row_like_index meet_result = + match meet_shape i1.shape i2.shape with + | Bottom -> Bottom + | Ok shape -> ( + match i1.domain, i2.domain with + | Known i1', Known i2' -> + if equal_index i1' i2' then Ok (Both_inputs, env) else Bottom + | Known known, At_least at_least -> + if subset_index at_least known + then + (* [at_least] is included in [known] hence [Known known] is included + in [At_least at_least], hence [Known known] \inter [At_least + at_least] = [Known known] *) + Ok (Left_input, env) + else Bottom + | At_least at_least, Known known -> + if subset_index at_least known then Ok (Right_input, env) else Bottom + | At_least i1', At_least i2' -> + if subset_index i1' i2' + then + if subset_index i2' i1' + then Ok (Both_inputs, env) + else Ok (Right_input, env) + else if subset_index i2' i1' + then Ok (Left_input, env) + else + let domain = + TG.Row_like_index_domain.at_least (union_index i1' i2') + in + Ok (New_result (TG.Row_like_index.create ~domain ~shape), env)) in let bottom_case () = result_is_t1 := false; result_is_t2 := false; None in - let meet_case env (case1 : ('index, 'maps_to) TG.Row_like_case.t) - (case2 : ('index, 'maps_to) TG.Row_like_case.t) = + let meet_case env (case1 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) + (case2 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) = match meet_index env case1.index case2.index with | Bottom -> bottom_case () | Ok (index_result, env) -> ( @@ -1079,9 +1087,16 @@ and meet_row_like : else ( result_is_t1 := false; result_is_t2 := false); - Some (TG.Row_like_case.create ~maps_to ~index ~env_extension))) + Some + (Or_unknown.Known + (TG.Row_like_case.create ~maps_to ~index ~env_extension)))) in - let meet_knowns case1 case2 : ('index, 'maps_to) TG.Row_like_case.t option = + let meet_knowns + (case1 : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) + (case2 : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option = match case1, case2 with | None, None -> None | Some case1, None -> ( @@ -1089,21 +1104,72 @@ and meet_row_like : | Bottom -> result_is_t1 := false; None - | Ok other_case -> meet_case base_env case1 other_case) + | Ok other_case -> ( + match case1 with + | Unknown -> ( + match + TE.add_env_extension_strict base_env other_case.env_extension + ~meet_type:(New meet_type) + with + | Bottom -> None + | Ok env -> + join_result_env env; + result_is_t1 := false; + result_is_t2 := false; + Some (Known other_case)) + | Known case1 -> meet_case base_env case1 other_case)) | None, Some case2 -> ( match other1 with | Bottom -> result_is_t2 := false; None - | Ok other_case -> meet_case base_env other_case case2) - | Some case1, Some case2 -> meet_case base_env case1 case2 + | Ok other_case -> ( + match case2 with + | Unknown -> ( + match + TE.add_env_extension_strict base_env other_case.env_extension + ~meet_type:(New meet_type) + with + | Bottom -> None + | Ok env -> + join_result_env env; + result_is_t1 := false; + result_is_t2 := false; + Some (Known other_case)) + | Known case2 -> meet_case base_env other_case case2)) + | Some case1, Some case2 -> ( + match case1, case2 with + | Unknown, Unknown -> + join_result_env base_env; + Some Unknown + | Known case, Unknown -> ( + match + TE.add_env_extension_strict base_env case.env_extension + ~meet_type:(New meet_type) + with + | Bottom -> None + | Ok env -> + join_result_env env; + result_is_t2 := false; + Some (Known case)) + | Unknown, Known case -> ( + match + TE.add_env_extension_strict base_env case.env_extension + ~meet_type:(New meet_type) + with + | Bottom -> None + | Ok env -> + join_result_env env; + result_is_t1 := false; + Some (Known case)) + | Known case1, Known case2 -> meet_case base_env case1 case2) in let known = merge_map_known (fun _tag case1 case2 -> meet_knowns case1 case2) known1 known2 in - let other : ('index, 'maps_to) TG.Row_like_case.t Or_bottom.t = + let other : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t = match other1, other2 with | Bottom, Bottom -> Bottom | Bottom, _ -> @@ -1115,7 +1181,8 @@ and meet_row_like : | Ok other1, Ok other2 -> ( match meet_case base_env other1 other2 with | None -> Bottom - | Some r -> Ok r) + | Some Unknown -> Misc.fatal_error "meet_case should not produce Unknown" + | Some (Known r) -> Ok r) in if is_empty_map_known known && match other with Bottom -> true | Ok _ -> false @@ -1139,14 +1206,22 @@ and meet_row_like_for_blocks env TG.Row_like_for_blocks.t) ({ known_tags = known2; other_tags = other2; alloc_mode = alloc_mode2 } : TG.Row_like_for_blocks.t) : TG.Row_like_for_blocks.t meet_result = + let meet_shape shape1 shape2 : _ Or_bottom.t = + if K.Block_shape.equal shape1 shape2 then Ok shape1 else Bottom + in + let get_singleton_map_known known = + match (Tag.Map.get_singleton known : (_ * _ Or_unknown.t) option) with + | Some (tag, Known case) -> Some (tag, case) + | Some (_, Unknown) | None -> None + in combine_results2 env ~rebuild:(fun (known_tags, other_tags) alloc_mode -> TG.Row_like_for_blocks.create_raw ~known_tags ~other_tags ~alloc_mode) ~meet_a:(fun env (known1, other1) (known2, other2) -> meet_row_like ~meet_maps_to:meet_int_indexed_product ~equal_index:TG.Block_size.equal ~subset_index:TG.Block_size.subset - ~union_index:TG.Block_size.union ~is_empty_map_known:Tag.Map.is_empty - ~get_singleton_map_known:Tag.Map.get_singleton + ~union_index:TG.Block_size.union ~meet_shape + ~is_empty_map_known:Tag.Map.is_empty ~get_singleton_map_known ~merge_map_known:Tag.Map.merge env ~known1 ~known2 ~other1 ~other2) ~meet_b:meet_alloc_mode ~left_a:(known1, other1) ~right_a:(known2, other2) ~left_b:alloc_mode1 ~right_b:alloc_mode2 @@ -1156,17 +1231,29 @@ and meet_row_like_for_closures env TG.Row_like_for_closures.t) ({ known_closures = known2; other_closures = other2 } : TG.Row_like_for_closures.t) : TG.Row_like_for_closures.t meet_result = + let meet_shape () () : _ Or_bottom.t = Ok () in + let merge_map_known merge_case known1 known2 = + Function_slot.Map.merge + (fun fslot case1 case2 -> + let case1 = Option.map Or_unknown.known case1 in + let case2 = Option.map Or_unknown.known case2 in + match merge_case fslot case1 case2 with + | None -> None + | Some (Or_unknown.Known case) -> Some case + | Some Or_unknown.Unknown -> + Misc.fatal_error "Unknown case in closure meet") + known1 known2 + in map_result ~f:(fun (known_closures, other_closures) -> TG.Row_like_for_closures.create_raw ~known_closures ~other_closures) (meet_row_like ~meet_maps_to:meet_closures_entry ~equal_index:Set_of_closures_contents.equal ~subset_index:Set_of_closures_contents.subset - ~union_index:Set_of_closures_contents.union + ~union_index:Set_of_closures_contents.union ~meet_shape ~is_empty_map_known:Function_slot.Map.is_empty - ~get_singleton_map_known:Function_slot.Map.get_singleton - ~merge_map_known:Function_slot.Map.merge env ~known1 ~known2 ~other1 - ~other2) + ~get_singleton_map_known:Function_slot.Map.get_singleton ~merge_map_known + env ~known1 ~known2 ~other1 ~other2) and meet_closures_entry (env : TE.t) ({ function_types = function_types1; @@ -1209,17 +1296,11 @@ and meet_product_value_slot_indexed env (Value_slot_map_meet.meet ~meet_data:meet env components_by_index1 components_by_index2) -and meet_int_indexed_product env (prod1 : TG.Product.Int_indexed.t) - (prod2 : TG.Product.Int_indexed.t) : _ meet_result = - if not (K.equal prod1.kind prod2.kind) - then Bottom - else - let fields1 = prod1.fields in - let fields2 = prod2.fields in - let length = max (Array.length fields1) (Array.length fields2) in - map_result - ~f:(TG.Product.Int_indexed.create_from_array prod1.kind) - (meet_array_of_types env fields1 fields2 ~length) +and meet_int_indexed_product env (fields1 : TG.Product.Int_indexed.t) + (fields2 : TG.Product.Int_indexed.t) : _ meet_result = + let length = max (Array.length fields1) (Array.length fields2) in + map_result ~f:TG.Product.Int_indexed.create_from_array + (meet_array_of_types env fields1 fields2 ~length) and meet_array_of_types env fields1 fields2 ~length = let fold2 f left right init = @@ -1529,10 +1610,7 @@ and join_variant env ~(blocks1 : TG.Row_like_for_blocks.t Or_unknown.t) ~(blocks2 : TG.Row_like_for_blocks.t Or_unknown.t) ~(imms2 : TG.t Or_unknown.t) : (TG.Row_like_for_blocks.t Or_unknown.t * TG.t Or_unknown.t) Or_unknown.t = - let blocks_join env b1 b2 : _ Or_unknown.t = - Known (join_row_like_for_blocks env b1 b2) - in - let blocks = join_unknown blocks_join env blocks1 blocks2 in + let blocks = join_unknown join_row_like_for_blocks env blocks1 blocks2 in let imms = join_unknown (join ?bound_name:None) env imms1 imms2 in match blocks, imms with | Unknown, Unknown -> Unknown @@ -1615,71 +1693,80 @@ and join_head_of_kind_region _env () () : _ Or_unknown.t = Known () results from generic [join]s without needing to propagate them. *) and join_row_like : - 'index 'maps_to 'row_tag 'known. - join_maps_to:(Join_env.t -> 'maps_to -> 'maps_to -> 'maps_to) -> - maps_to_field_kind:('maps_to -> K.t) option -> - equal_index:('index -> 'index -> bool) -> - inter_index:('index -> 'index -> 'index) -> + 'lattice 'shape 'maps_to 'row_tag 'known. + join_maps_to:(Join_env.t -> 'shape -> 'maps_to -> 'maps_to -> 'maps_to) -> + equal_index:('lattice -> 'lattice -> bool) -> + inter_index:('lattice -> 'lattice -> 'lattice) -> + join_shape:('shape -> 'shape -> 'shape Or_unknown.t) -> merge_map_known: (('row_tag -> - ('index, 'maps_to) TG.Row_like_case.t option -> - ('index, 'maps_to) TG.Row_like_case.t option -> - ('index, 'maps_to) TG.Row_like_case.t option) -> + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option -> + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option -> + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) -> 'known -> 'known -> 'known) -> Join_env.t -> known1:'known -> known2:'known -> - other1:('index, 'maps_to) TG.Row_like_case.t Or_bottom.t -> - other2:('index, 'maps_to) TG.Row_like_case.t Or_bottom.t -> - 'known * ('index, 'maps_to) TG.Row_like_case.t Or_bottom.t = - fun ~join_maps_to ~maps_to_field_kind ~equal_index ~inter_index - ~merge_map_known join_env ~known1 ~known2 ~other1 ~other2 -> - let join_index (i1 : 'index TG.row_like_index) (i2 : 'index TG.row_like_index) - : 'index TG.row_like_index = - match i1, i2 with - | Known i1', Known i2' -> - if equal_index i1' i2' - then i1 - else - (* We can't represent exactly the union, This is the best - approximation *) - TG.Row_like_index.at_least (inter_index i1' i2') - | Known i1', At_least i2' - | At_least i1', Known i2' - | At_least i1', At_least i2' -> - TG.Row_like_index.at_least (inter_index i1' i2') - in - let matching_kinds (case1 : ('index, 'maps_to) TG.Row_like_case.t) - (case2 : ('index, 'maps_to) TG.Row_like_case.t) = - match maps_to_field_kind with - | None -> true - | Some maps_to_field_kind -> - K.equal - (maps_to_field_kind case1.maps_to) - (maps_to_field_kind case2.maps_to) + other1:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t -> + other2:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t -> + ('known * ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t) + Or_unknown.t = + fun ~join_maps_to ~equal_index ~inter_index ~join_shape ~merge_map_known + join_env ~known1 ~known2 ~other1 ~other2 -> + let join_index (i1 : ('lattice, 'shape) TG.row_like_index) + (i2 : ('lattice, 'shape) TG.row_like_index) : + ('lattice, 'shape) TG.row_like_index Or_unknown.t = + match join_shape i1.shape i2.shape with + | Unknown -> Unknown + | Known shape -> ( + let return_index domain = + Or_unknown.Known (TG.Row_like_index.create ~domain ~shape) + in + match i1.domain, i2.domain with + | Known i1', Known i2' -> + if equal_index i1' i2' + then return_index i1.domain + else + (* We can't represent exactly the union, This is the best + approximation *) + return_index (TG.Row_like_index_domain.at_least (inter_index i1' i2')) + | Known i1', At_least i2' + | At_least i1', Known i2' + | At_least i1', At_least i2' -> + return_index (TG.Row_like_index_domain.at_least (inter_index i1' i2'))) in - let join_case join_env (case1 : ('index, 'maps_to) TG.Row_like_case.t) - (case2 : ('index, 'maps_to) TG.Row_like_case.t) = + let join_case join_env + (case1 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) + (case2 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) : _ Or_unknown.t + = let index = join_index case1.index case2.index in - let maps_to = join_maps_to join_env case1.maps_to case2.maps_to in - let env_extension = - join_env_extension join_env case1.env_extension case2.env_extension - in - TG.Row_like_case.create ~maps_to ~index ~env_extension + Or_unknown.map index + ~f:(fun (index : ('lattice, 'shape) TG.Row_like_index.t) -> + let maps_to = + join_maps_to join_env index.shape case1.maps_to case2.maps_to + in + let env_extension = + join_env_extension join_env case1.env_extension case2.env_extension + in + TG.Row_like_case.create ~maps_to ~index ~env_extension) in - let join_knowns case1 case2 : ('index, 'maps_to) TG.Row_like_case.t option = - (* We assume that if tags are equals, the products will contains values of - the same kinds. *) + let join_knowns + (case1 : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) + (case2 : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option = match case1, case2 with | None, None -> None - | Some case1, None -> ( + | Some Unknown, _ | _, Some Unknown -> Some Unknown + | Some (Known case1), None -> ( let only_case1 () = (* cf. Type_descr.join_head_or_unknown_or_bottom, we need to join these to ensure that free variables not present in the target env are cleaned out of the types. Same below *) - (* CR pchambart: This seams terribly inefficient. *) + (* CR pchambart: This seems terribly inefficient. *) let join_env = Join_env.create (Join_env.target_join_env join_env) @@ -1691,12 +1778,8 @@ and join_row_like : in match other2 with | Bottom -> only_case1 () - | Ok other_case -> - if matching_kinds case1 other_case - then Some (join_case join_env case1 other_case) - else (* If kinds don't match, the tags can't match *) - only_case1 ()) - | None, Some case2 -> ( + | Ok other_case -> Some (join_case join_env case1 other_case)) + | None, Some (Known case2) -> ( let only_case2 () = (* See at the other bottom case *) let join_env = @@ -1710,20 +1793,19 @@ and join_row_like : in match other1 with | Bottom -> only_case2 () - | Ok other_case -> - if matching_kinds other_case case2 - then Some (join_case join_env other_case case2) - else only_case2 ()) - | Some case1, Some case2 -> Some (join_case join_env case1 case2) + | Ok other_case -> Some (join_case join_env other_case case2)) + | Some (Known case1), Some (Known case2) -> + Some (join_case join_env case1 case2) in let known = merge_map_known (fun _tag case1 case2 -> join_knowns case1 case2) known1 known2 in - let other : ('index, 'maps_to) TG.Row_like_case.t Or_bottom.t = + let other : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t Or_unknown.t = match other1, other2 with - | Bottom, Bottom -> Bottom + | Bottom, Bottom -> Known Bottom | Ok other1, Bottom -> (* See the previous cases *) let env = @@ -1733,7 +1815,7 @@ and join_row_like : ~right_env:(Join_env.left_join_env join_env) in let other1 = join_case env other1 other1 in - Ok other1 + Or_unknown.map other1 ~f:(fun other1 -> Or_bottom.Ok other1) | Bottom, Ok other2 -> (* See the previous cases *) let env = @@ -1743,38 +1825,58 @@ and join_row_like : ~right_env:(Join_env.right_join_env join_env) in let other2 = join_case env other2 other2 in - Ok other2 - | Ok other1, Ok other2 -> Ok (join_case join_env other1 other2) + Or_unknown.map other2 ~f:(fun other2 -> Or_bottom.Ok other2) + | Ok other1, Ok other2 -> + Or_unknown.map (join_case join_env other1 other2) ~f:(fun case -> + Or_bottom.Ok case) in - known, other + Or_unknown.map other ~f:(fun other -> known, other) and join_row_like_for_blocks env ({ known_tags = known1; other_tags = other1; alloc_mode = alloc_mode1 } : TG.Row_like_for_blocks.t) ({ known_tags = known2; other_tags = other2; alloc_mode = alloc_mode2 } : TG.Row_like_for_blocks.t) = - let known_tags, other_tags = - join_row_like ~join_maps_to:join_int_indexed_product - ~maps_to_field_kind:(Some TG.Product.Int_indexed.field_kind) - ~equal_index:TG.Block_size.equal ~inter_index:TG.Block_size.inter - ~merge_map_known:Tag.Map.merge env ~known1 ~known2 ~other1 ~other2 + let join_shape shape1 shape2 : _ Or_unknown.t = + if K.Block_shape.equal shape1 shape2 then Known shape1 else Unknown in - let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in - TG.Row_like_for_blocks.create_raw ~known_tags ~other_tags ~alloc_mode + Or_unknown.map + (join_row_like ~join_maps_to:join_int_indexed_product + ~equal_index:TG.Block_size.equal ~inter_index:TG.Block_size.inter + ~join_shape ~merge_map_known:Tag.Map.merge env ~known1 ~known2 ~other1 + ~other2) ~f:(fun (known_tags, other_tags) -> + let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in + TG.Row_like_for_blocks.create_raw ~known_tags ~other_tags ~alloc_mode) and join_row_like_for_closures env ({ known_closures = known1; other_closures = other1 } : TG.Row_like_for_closures.t) ({ known_closures = known2; other_closures = other2 } : TG.Row_like_for_closures.t) : TG.Row_like_for_closures.t = - let known_closures, other_closures = - join_row_like ~join_maps_to:join_closures_entry ~maps_to_field_kind:None + let merge_map_known join_case known1 known2 = + Function_slot.Map.merge + (fun function_slot case1 case2 -> + let case1 = Option.map Or_unknown.known case1 in + let case2 = Option.map Or_unknown.known case2 in + match (join_case function_slot case1 case2 : _ Or_unknown.t option) with + | None -> None + | Some (Known case) -> Some case + | Some Unknown -> + Misc.fatal_error "Join row_like case for closures returned Unknown") + known1 known2 + in + match + join_row_like + ~join_maps_to:(fun env () x y -> join_closures_entry env x y) ~equal_index:Set_of_closures_contents.equal ~inter_index:Set_of_closures_contents.inter - ~merge_map_known:Function_slot.Map.merge env ~known1 ~known2 ~other1 - ~other2 - in - TG.Row_like_for_closures.create_raw ~known_closures ~other_closures + ~join_shape:(fun () () -> Or_unknown.Known ()) + ~merge_map_known env ~known1 ~known2 ~other1 ~other2 + with + | Known (known_closures, other_closures) -> + TG.Row_like_for_closures.create_raw ~known_closures ~other_closures + | Unknown -> + Misc.fatal_error "Join row_like case for closures returned Unknown" and join_closures_entry env ({ function_types = function_types1; @@ -1846,15 +1948,8 @@ and join_value_slot_indexed_product env in TG.Product.Value_slot_indexed.create value_slot_components_by_index -and join_int_indexed_product env - ({ fields = fields1; kind = kind1 } : TG.Product.Int_indexed.t) - ({ fields = fields2; kind = kind2 } : TG.Product.Int_indexed.t) : - TG.Product.Int_indexed.t = - if not (K.equal kind1 kind2) - then - Misc.fatal_errorf - "join_int_indexed_product between mismatching kinds %a and %a@." K.print - kind1 K.print kind2; +and join_int_indexed_product env shape (fields1 : TG.Product.Int_indexed.t) + (fields2 : TG.Product.Int_indexed.t) : TG.Product.Int_indexed.t = let length1 = Array.length fields1 in let length2 = Array.length fields2 in let length = min length1 length2 in @@ -1881,10 +1976,10 @@ and join_int_indexed_product env then fields1.(index) else match join env fields1.(index) fields2.(index) with - | Unknown -> MTC.unknown kind1 + | Unknown -> MTC.unknown_from_shape shape index | Known ty -> ty) in - TG.Product.Int_indexed.create_from_array kind1 fields + TG.Product.Int_indexed.create_from_array fields and join_function_type (env : Join_env.t) (func_type1 : TG.Function_type.t Or_unknown_or_bottom.t) diff --git a/middle_end/flambda2/types/meet_and_join_old.ml b/middle_end/flambda2/types/meet_and_join_old.ml index 643d32c494c..5daac701b1c 100644 --- a/middle_end/flambda2/types/meet_and_join_old.ml +++ b/middle_end/flambda2/types/meet_and_join_old.ml @@ -614,33 +614,37 @@ and meet_head_of_kind_rec_info _env t1 _t2 : _ Or_bottom.t = and meet_head_of_kind_region _env () () : _ Or_bottom.t = Ok ((), TEE.empty) and meet_row_like : - 'index 'maps_to 'row_tag 'known. + 'lattice 'shape 'maps_to 'row_tag 'known. meet_maps_to: (Meet_env.t -> 'maps_to -> 'maps_to -> ('maps_to * TEE.t) Or_bottom.t) -> - equal_index:('index -> 'index -> bool) -> - subset_index:('index -> 'index -> bool) -> - union_index:('index -> 'index -> 'index) -> + equal_index:('lattice -> 'lattice -> bool) -> + subset_index:('lattice -> 'lattice -> bool) -> + union_index:('lattice -> 'lattice -> 'lattice) -> + meet_shape:('shape -> 'shape -> 'shape Or_bottom.t) -> is_empty_map_known:('known -> bool) -> get_singleton_map_known: - ('known -> ('row_tag * ('index, 'maps_to) TG.Row_like_case.t) option) -> + ('known -> + ('row_tag * ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) option) -> merge_map_known: (('row_tag -> - ('index, 'maps_to) TG.Row_like_case.t option -> - ('index, 'maps_to) TG.Row_like_case.t option -> - ('index, 'maps_to) TG.Row_like_case.t option) -> + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option -> + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option -> + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) -> 'known -> 'known -> 'known) -> Meet_env.t -> known1:'known -> known2:'known -> - other1:('index, 'maps_to) TG.Row_like_case.t Or_bottom.t -> - other2:('index, 'maps_to) TG.Row_like_case.t Or_bottom.t -> - ('known * ('index, 'maps_to) TG.Row_like_case.t Or_bottom.t * TEE.t) + other1:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t -> + other2:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t -> + ('known + * ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t + * TEE.t) Or_bottom.t = - fun ~meet_maps_to ~equal_index ~subset_index ~union_index ~is_empty_map_known - ~get_singleton_map_known ~merge_map_known meet_env ~known1 ~known2 ~other1 - ~other2 -> + fun ~meet_maps_to ~equal_index ~subset_index ~union_index ~meet_shape + ~is_empty_map_known ~get_singleton_map_known ~merge_map_known meet_env + ~known1 ~known2 ~other1 ~other2 -> let env_extension = ref None in let need_join = (* The returned env_extension is the join of the env_extension produced by @@ -681,23 +685,36 @@ and meet_row_like : assert need_join; env_extension := Some (join_env_extension join_env ext2 ext) in - let meet_index (i1 : 'index TG.row_like_index) (i2 : 'index TG.row_like_index) - : 'index TG.row_like_index Or_bottom.t = - match i1, i2 with - | Known i1', Known i2' -> if equal_index i1' i2' then Ok i1 else Bottom - | Known known, At_least at_least | At_least at_least, Known known -> - if subset_index at_least known - then - (* [at_least] is included in [known] hence [Known known] is included in - [At_least at_least], hence [Known known] \inter [At_least at_least] = - [Known known] *) - Ok (TG.Row_like_index.known known) - else Bottom - | At_least i1', At_least i2' -> - Ok (TG.Row_like_index.at_least (union_index i1' i2')) + let meet_index (i1 : ('lattice, 'shape) TG.row_like_index) + (i2 : ('lattice, 'shape) TG.row_like_index) : + ('lattice, 'shape) TG.row_like_index Or_bottom.t = + match meet_shape i1.shape i2.shape with + | Bottom -> Bottom + | Ok shape -> ( + match i1.domain, i2.domain with + | Known i1', Known i2' -> + if equal_index i1' i2' + then Ok (TG.Row_like_index.create ~domain:i1.domain ~shape) + else Bottom + | Known known, At_least at_least | At_least at_least, Known known -> + if subset_index at_least known + then + (* [at_least] is included in [known] hence [Known known] is included + in [At_least at_least], hence [Known known] \inter [At_least + at_least] = [Known known] *) + Ok + (TG.Row_like_index.create + ~domain:(TG.Row_like_index_domain.known known) + ~shape) + else Bottom + | At_least i1', At_least i2' -> + Ok + (TG.Row_like_index.create + ~domain:(TG.Row_like_index_domain.at_least (union_index i1' i2')) + ~shape)) in - let meet_case (case1 : ('index, 'maps_to) TG.Row_like_case.t) - (case2 : ('index, 'maps_to) TG.Row_like_case.t) = + let meet_case (case1 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) + (case2 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) = match meet_index case1.index case2.index with | Bottom -> None | Ok index -> ( @@ -716,31 +733,59 @@ and meet_row_like : let env_extension = if need_join then env_extension else TEE.empty in - Some (TG.Row_like_case.create ~maps_to ~index ~env_extension)))) + Some + (Or_unknown.Known + (TG.Row_like_case.create ~maps_to ~index ~env_extension))))) in - let meet_knowns case1 case2 : ('index, 'maps_to) TG.Row_like_case.t option = + let meet_knowns + (case1 : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) + (case2 : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option = match case1, case2 with | None, None -> None | Some case1, None -> ( match other2 with | Bottom -> None - | Ok other_case -> meet_case case1 other_case) + | Ok other_case -> ( + match case1 with + | Unknown -> + join_env_extension other_case.env_extension; + Some (Known other_case) + | Known case1 -> meet_case case1 other_case)) | None, Some case2 -> ( match other1 with | Bottom -> None - | Ok other_case -> meet_case other_case case2) - | Some case1, Some case2 -> meet_case case1 case2 + | Ok other_case -> ( + match case2 with + | Unknown -> + join_env_extension other_case.env_extension; + Some (Known other_case) + | Known case2 -> meet_case other_case case2)) + | Some case1, Some case2 -> ( + match case1, case2 with + | Unknown, Unknown -> + join_env_extension TEE.empty; + Some Unknown + | Known case, Unknown | Unknown, Known case -> + join_env_extension case.env_extension; + Some (Known case) + | Known case1, Known case2 -> meet_case case1 case2) in let known = merge_map_known (fun _tag case1 case2 -> meet_knowns case1 case2) known1 known2 in - let other : ('index, 'maps_to) TG.Row_like_case.t Or_bottom.t = + let other : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t = match other1, other2 with | Bottom, _ | _, Bottom -> Bottom | Ok other1, Ok other2 -> ( - match meet_case other1 other2 with None -> Bottom | Some r -> Ok r) + match meet_case other1 other2 with + | None -> Bottom + | Some Unknown -> Misc.fatal_error "meet_case should not produce Unknown" + | Some (Known r) -> Ok r) in if is_empty_map_known known && match other with Bottom -> true | Ok _ -> false @@ -759,11 +804,19 @@ and meet_row_like_for_blocks env ({ known_tags = known2; other_tags = other2; alloc_mode = alloc_mode2 } : TG.Row_like_for_blocks.t) : (TG.Row_like_for_blocks.t * TEE.t) Or_bottom.t = + let meet_shape shape1 shape2 : _ Or_bottom.t = + if K.Block_shape.equal shape1 shape2 then Ok shape1 else Bottom + in + let get_singleton_map_known known = + match (Tag.Map.get_singleton known : (_ * _ Or_unknown.t) option) with + | Some (tag, Known case) -> Some (tag, case) + | Some (_, Unknown) | None -> None + in let<* known_tags, other_tags, env_extension = meet_row_like ~meet_maps_to:meet_int_indexed_product ~equal_index:TG.Block_size.equal ~subset_index:TG.Block_size.subset - ~union_index:TG.Block_size.union ~is_empty_map_known:Tag.Map.is_empty - ~get_singleton_map_known:Tag.Map.get_singleton + ~union_index:TG.Block_size.union ~meet_shape + ~is_empty_map_known:Tag.Map.is_empty ~get_singleton_map_known ~merge_map_known:Tag.Map.merge env ~known1 ~known2 ~other1 ~other2 in let<+ alloc_mode = meet_alloc_mode alloc_mode1 alloc_mode2 in @@ -776,15 +829,27 @@ and meet_row_like_for_closures env ({ known_closures = known2; other_closures = other2 } : TG.Row_like_for_closures.t) : (TG.Row_like_for_closures.t * TEE.t) Or_bottom.t = + let meet_shape () () = Or_bottom.Ok () in + let merge_map_known merge_case known1 known2 = + Function_slot.Map.merge + (fun fslot case1 case2 -> + let case1 = Option.map Or_unknown.known case1 in + let case2 = Option.map Or_unknown.known case2 in + match merge_case fslot case1 case2 with + | None -> None + | Some (Or_unknown.Known case) -> Some case + | Some Or_unknown.Unknown -> + Misc.fatal_error "Unknown case in closure meet") + known1 known2 + in let<+ known_closures, other_closures, env_extension = meet_row_like ~meet_maps_to:meet_closures_entry ~equal_index:Set_of_closures_contents.equal ~subset_index:Set_of_closures_contents.subset - ~union_index:Set_of_closures_contents.union + ~union_index:Set_of_closures_contents.union ~meet_shape ~is_empty_map_known:Function_slot.Map.is_empty - ~get_singleton_map_known:Function_slot.Map.get_singleton - ~merge_map_known:Function_slot.Map.merge env ~known1 ~known2 ~other1 - ~other2 + ~get_singleton_map_known:Function_slot.Map.get_singleton ~merge_map_known + env ~known1 ~known2 ~other1 ~other2 in ( TG.Row_like_for_closures.create_raw ~known_closures ~other_closures, env_extension ) @@ -895,44 +960,36 @@ and meet_product_value_slot_indexed env in TG.Product.Value_slot_indexed.create components_by_index, env_extension -and meet_int_indexed_product env (prod1 : TG.Product.Int_indexed.t) - (prod2 : TG.Product.Int_indexed.t) : _ Or_bottom.t = - if not (K.equal prod1.kind prod2.kind) - then Bottom - else - let fields1 = prod1.fields in - let fields2 = prod2.fields in - let any_bottom = ref false in - let env_extension = ref TEE.empty in - let length = max (Array.length fields1) (Array.length fields2) in - let fields = - Array.init length (fun index -> - let get_opt fields = - if index >= Array.length fields then None else Some fields.(index) - in - match get_opt fields1, get_opt fields2 with - | None, None -> assert false - | Some t, None | None, Some t -> t - | Some ty1, Some ty2 -> ( - match meet env ty1 ty2 with - | Ok (ty, env_extension') -> ( - match meet_env_extension env !env_extension env_extension' with - | Bottom -> - any_bottom := true; - MTC.bottom_like ty1 - | Ok extension -> - env_extension := extension; - ty) +and meet_int_indexed_product env (fields1 : TG.Product.Int_indexed.t) + (fields2 : TG.Product.Int_indexed.t) : _ Or_bottom.t = + let any_bottom = ref false in + let env_extension = ref TEE.empty in + let length = max (Array.length fields1) (Array.length fields2) in + let fields = + Array.init length (fun index -> + let get_opt fields = + if index >= Array.length fields then None else Some fields.(index) + in + match get_opt fields1, get_opt fields2 with + | None, None -> assert false + | Some t, None | None, Some t -> t + | Some ty1, Some ty2 -> ( + match meet env ty1 ty2 with + | Ok (ty, env_extension') -> ( + match meet_env_extension env !env_extension env_extension' with | Bottom -> any_bottom := true; - MTC.bottom_like ty1)) - in - if !any_bottom - then Bottom - else - Ok - ( TG.Product.Int_indexed.create_from_array prod1.kind fields, - !env_extension ) + MTC.bottom_like ty1 + | Ok extension -> + env_extension := extension; + ty) + | Bottom -> + any_bottom := true; + MTC.bottom_like ty1)) + in + if !any_bottom + then Bottom + else Ok (TG.Product.Int_indexed.create_from_array fields, !env_extension) and meet_function_type (env : Meet_env.t) (func_type1 : TG.Function_type.t Or_unknown_or_bottom.t) @@ -1291,7 +1348,7 @@ and join_variant env ~(blocks1 : TG.Row_like_for_blocks.t Or_unknown.t) ~(imms2 : TG.t Or_unknown.t) : (TG.Row_like_for_blocks.t Or_unknown.t * TG.t Or_unknown.t) Or_unknown.t = let blocks_join env b1 b2 : _ Or_unknown.t = - Known (join_row_like_for_blocks env b1 b2) + join_row_like_for_blocks env b1 b2 in let blocks = join_unknown blocks_join env blocks1 blocks2 in let imms = join_unknown (join ?bound_name:None) env imms1 imms2 in @@ -1376,71 +1433,80 @@ and join_head_of_kind_region _env () () : _ Or_unknown.t = Known () results from generic [join]s without needing to propagate them. *) and join_row_like : - 'index 'maps_to 'row_tag 'known. - join_maps_to:(Join_env.t -> 'maps_to -> 'maps_to -> 'maps_to) -> - maps_to_field_kind:('maps_to -> K.t) option -> - equal_index:('index -> 'index -> bool) -> - inter_index:('index -> 'index -> 'index) -> + 'lattice 'shape 'maps_to 'row_tag 'known. + join_maps_to:(Join_env.t -> 'shape -> 'maps_to -> 'maps_to -> 'maps_to) -> + equal_index:('lattice -> 'lattice -> bool) -> + inter_index:('lattice -> 'lattice -> 'lattice) -> + join_shape:('shape -> 'shape -> 'shape Or_unknown.t) -> merge_map_known: (('row_tag -> - ('index, 'maps_to) TG.Row_like_case.t option -> - ('index, 'maps_to) TG.Row_like_case.t option -> - ('index, 'maps_to) TG.Row_like_case.t option) -> + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option -> + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option -> + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) -> 'known -> 'known -> 'known) -> Join_env.t -> known1:'known -> known2:'known -> - other1:('index, 'maps_to) TG.Row_like_case.t Or_bottom.t -> - other2:('index, 'maps_to) TG.Row_like_case.t Or_bottom.t -> - 'known * ('index, 'maps_to) TG.Row_like_case.t Or_bottom.t = - fun ~join_maps_to ~maps_to_field_kind ~equal_index ~inter_index - ~merge_map_known join_env ~known1 ~known2 ~other1 ~other2 -> - let join_index (i1 : 'index TG.row_like_index) (i2 : 'index TG.row_like_index) - : 'index TG.row_like_index = - match i1, i2 with - | Known i1', Known i2' -> - if equal_index i1' i2' - then i1 - else - (* We can't represent exactly the union, This is the best - approximation *) - TG.Row_like_index.at_least (inter_index i1' i2') - | Known i1', At_least i2' - | At_least i1', Known i2' - | At_least i1', At_least i2' -> - TG.Row_like_index.at_least (inter_index i1' i2') - in - let matching_kinds (case1 : ('index, 'maps_to) TG.Row_like_case.t) - (case2 : ('index, 'maps_to) TG.Row_like_case.t) = - match maps_to_field_kind with - | None -> true - | Some maps_to_field_kind -> - K.equal - (maps_to_field_kind case1.maps_to) - (maps_to_field_kind case2.maps_to) + other1:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t -> + other2:('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t -> + ('known * ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t) + Or_unknown.t = + fun ~join_maps_to ~equal_index ~inter_index ~join_shape ~merge_map_known + join_env ~known1 ~known2 ~other1 ~other2 -> + let join_index (i1 : ('lattice, 'shape) TG.row_like_index) + (i2 : ('lattice, 'shape) TG.row_like_index) : + ('lattice, 'shape) TG.row_like_index Or_unknown.t = + match join_shape i1.shape i2.shape with + | Unknown -> Unknown + | Known shape -> ( + let return_index domain = + Or_unknown.Known (TG.Row_like_index.create ~domain ~shape) + in + match i1.domain, i2.domain with + | Known i1', Known i2' -> + if equal_index i1' i2' + then return_index i1.domain + else + (* We can't represent exactly the union, This is the best + approximation *) + return_index (TG.Row_like_index_domain.at_least (inter_index i1' i2')) + | Known i1', At_least i2' + | At_least i1', Known i2' + | At_least i1', At_least i2' -> + return_index (TG.Row_like_index_domain.at_least (inter_index i1' i2'))) in - let join_case join_env (case1 : ('index, 'maps_to) TG.Row_like_case.t) - (case2 : ('index, 'maps_to) TG.Row_like_case.t) = + let join_case join_env + (case1 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) + (case2 : ('lattice, 'shape, 'maps_to) TG.Row_like_case.t) : _ Or_unknown.t + = let index = join_index case1.index case2.index in - let maps_to = join_maps_to join_env case1.maps_to case2.maps_to in - let env_extension = - join_env_extension join_env case1.env_extension case2.env_extension - in - TG.Row_like_case.create ~maps_to ~index ~env_extension + Or_unknown.map index + ~f:(fun (index : ('lattice, 'shape) TG.Row_like_index.t) -> + let maps_to = + join_maps_to join_env index.shape case1.maps_to case2.maps_to + in + let env_extension = + join_env_extension join_env case1.env_extension case2.env_extension + in + TG.Row_like_case.create ~maps_to ~index ~env_extension) in - let join_knowns case1 case2 : ('index, 'maps_to) TG.Row_like_case.t option = - (* We assume that if tags are equals, the products will contains values of - the same kinds. *) + let join_knowns + (case1 : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) + (case2 : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option) : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_unknown.t option = match case1, case2 with | None, None -> None - | Some case1, None -> ( + | Some Unknown, _ | _, Some Unknown -> Some Unknown + | Some (Known case1), None -> ( let only_case1 () = (* cf. Type_descr.join_head_or_unknown_or_bottom, we need to join these to ensure that free variables not present in the target env are cleaned out of the types. Same below *) - (* CR pchambart: This seams terribly inefficient. *) + (* CR pchambart: This seems terribly inefficient. *) let join_env = Join_env.create (Join_env.target_join_env join_env) @@ -1452,12 +1518,8 @@ and join_row_like : in match other2 with | Bottom -> only_case1 () - | Ok other_case -> - if matching_kinds case1 other_case - then Some (join_case join_env case1 other_case) - else (* If kinds don't match, the tags can't match *) - only_case1 ()) - | None, Some case2 -> ( + | Ok other_case -> Some (join_case join_env case1 other_case)) + | None, Some (Known case2) -> ( let only_case2 () = (* See at the other bottom case *) let join_env = @@ -1471,20 +1533,19 @@ and join_row_like : in match other1 with | Bottom -> only_case2 () - | Ok other_case -> - if matching_kinds other_case case2 - then Some (join_case join_env other_case case2) - else only_case2 ()) - | Some case1, Some case2 -> Some (join_case join_env case1 case2) + | Ok other_case -> Some (join_case join_env other_case case2)) + | Some (Known case1), Some (Known case2) -> + Some (join_case join_env case1 case2) in let known = merge_map_known (fun _tag case1 case2 -> join_knowns case1 case2) known1 known2 in - let other : ('index, 'maps_to) TG.Row_like_case.t Or_bottom.t = + let other : + ('lattice, 'shape, 'maps_to) TG.Row_like_case.t Or_bottom.t Or_unknown.t = match other1, other2 with - | Bottom, Bottom -> Bottom + | Bottom, Bottom -> Known Bottom | Ok other1, Bottom -> (* See the previous cases *) let env = @@ -1494,7 +1555,7 @@ and join_row_like : ~right_env:(Join_env.left_join_env join_env) in let other1 = join_case env other1 other1 in - Ok other1 + Or_unknown.map other1 ~f:(fun other1 -> Or_bottom.Ok other1) | Bottom, Ok other2 -> (* See the previous cases *) let env = @@ -1504,38 +1565,58 @@ and join_row_like : ~right_env:(Join_env.right_join_env join_env) in let other2 = join_case env other2 other2 in - Ok other2 - | Ok other1, Ok other2 -> Ok (join_case join_env other1 other2) + Or_unknown.map other2 ~f:(fun other2 -> Or_bottom.Ok other2) + | Ok other1, Ok other2 -> + Or_unknown.map (join_case join_env other1 other2) ~f:(fun case -> + Or_bottom.Ok case) in - known, other + Or_unknown.map other ~f:(fun other -> known, other) and join_row_like_for_blocks env ({ known_tags = known1; other_tags = other1; alloc_mode = alloc_mode1 } : TG.Row_like_for_blocks.t) ({ known_tags = known2; other_tags = other2; alloc_mode = alloc_mode2 } : TG.Row_like_for_blocks.t) = - let known_tags, other_tags = - join_row_like ~join_maps_to:join_int_indexed_product - ~maps_to_field_kind:(Some TG.Product.Int_indexed.field_kind) - ~equal_index:TG.Block_size.equal ~inter_index:TG.Block_size.inter - ~merge_map_known:Tag.Map.merge env ~known1 ~known2 ~other1 ~other2 + let join_shape shape1 shape2 : _ Or_unknown.t = + if K.Block_shape.equal shape1 shape2 then Known shape1 else Unknown in - let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in - TG.Row_like_for_blocks.create_raw ~known_tags ~other_tags ~alloc_mode + Or_unknown.map + (join_row_like ~join_maps_to:join_int_indexed_product + ~equal_index:TG.Block_size.equal ~inter_index:TG.Block_size.inter + ~join_shape ~merge_map_known:Tag.Map.merge env ~known1 ~known2 ~other1 + ~other2) ~f:(fun (known_tags, other_tags) -> + let alloc_mode = join_alloc_mode alloc_mode1 alloc_mode2 in + TG.Row_like_for_blocks.create_raw ~known_tags ~other_tags ~alloc_mode) and join_row_like_for_closures env ({ known_closures = known1; other_closures = other1 } : TG.Row_like_for_closures.t) ({ known_closures = known2; other_closures = other2 } : TG.Row_like_for_closures.t) : TG.Row_like_for_closures.t = - let known_closures, other_closures = - join_row_like ~join_maps_to:join_closures_entry ~maps_to_field_kind:None + let merge_map_known join_case known1 known2 = + Function_slot.Map.merge + (fun function_slot case1 case2 -> + let case1 = Option.map Or_unknown.known case1 in + let case2 = Option.map Or_unknown.known case2 in + match (join_case function_slot case1 case2 : _ Or_unknown.t option) with + | None -> None + | Some (Known case) -> Some case + | Some Unknown -> + Misc.fatal_error "Join row_like case for closures returned Unknown") + known1 known2 + in + match + join_row_like + ~join_maps_to:(fun env () x y -> join_closures_entry env x y) ~equal_index:Set_of_closures_contents.equal ~inter_index:Set_of_closures_contents.inter - ~merge_map_known:Function_slot.Map.merge env ~known1 ~known2 ~other1 - ~other2 - in - TG.Row_like_for_closures.create_raw ~known_closures ~other_closures + ~join_shape:(fun () () -> Or_unknown.Known ()) + ~merge_map_known env ~known1 ~known2 ~other1 ~other2 + with + | Known (known_closures, other_closures) -> + TG.Row_like_for_closures.create_raw ~known_closures ~other_closures + | Unknown -> + Misc.fatal_error "Join row_like case for closures returned Unknown" and join_closures_entry env ({ function_types = function_types1; @@ -1607,15 +1688,8 @@ and join_value_slot_indexed_product env in TG.Product.Value_slot_indexed.create value_slot_components_by_index -and join_int_indexed_product env - ({ fields = fields1; kind = kind1 } : TG.Product.Int_indexed.t) - ({ fields = fields2; kind = kind2 } : TG.Product.Int_indexed.t) : - TG.Product.Int_indexed.t = - if not (K.equal kind1 kind2) - then - Misc.fatal_errorf - "join_int_indexed_product between mismatching kinds %a and %a@." K.print - kind1 K.print kind2; +and join_int_indexed_product env shape (fields1 : TG.Product.Int_indexed.t) + (fields2 : TG.Product.Int_indexed.t) : TG.Product.Int_indexed.t = let length1 = Array.length fields1 in let length2 = Array.length fields2 in let length = min length1 length2 in @@ -1642,10 +1716,10 @@ and join_int_indexed_product env then fields1.(index) else match join env fields1.(index) fields2.(index) with - | Unknown -> MTC.unknown kind1 + | Unknown -> MTC.unknown_from_shape shape index | Known ty -> ty) in - TG.Product.Int_indexed.create_from_array kind1 fields + TG.Product.Int_indexed.create_from_array fields and join_function_type (env : Join_env.t) (func_type1 : TG.Function_type.t Or_unknown_or_bottom.t) diff --git a/middle_end/flambda2/types/provers.ml b/middle_end/flambda2/types/provers.ml index 090aa3bff7c..51d884ef471 100644 --- a/middle_end/flambda2/types/provers.ml +++ b/middle_end/flambda2/types/provers.ml @@ -333,7 +333,8 @@ let meet_naked_vec128s = meet_naked_number Vec128 type variant_like_proof = { const_ctors : Targetint_31_63.Set.t Or_unknown.t; - non_const_ctors_with_sizes : Targetint_31_63.t Tag.Scannable.Map.t + non_const_ctors_with_sizes : + (Targetint_31_63.t * K.Block_shape.t) Tag.Scannable.Map.t } let prove_variant_like_generic env t : variant_like_proof generic_proof = @@ -506,7 +507,11 @@ let prove_is_a_boxed_vec128 env t : _ proof_of_property = wrong_kind "Value" t let prove_unique_tag_and_size0 env t : - (Tag_and_size.t * TG.Product.Int_indexed.t * Alloc_mode.For_types.t) + (Tag.t + * K.Block_shape.t + * Targetint_31_63.t + * TG.Product.Int_indexed.t + * Alloc_mode.For_types.t) proof_of_property = match expand_head env t with | Value (Ok (Variant blocks_imms)) -> ( @@ -520,8 +525,8 @@ let prove_unique_tag_and_size0 env t : | Known blocks -> ( match TG.Row_like_for_blocks.get_singleton blocks with | None -> Unknown - | Some (tag_and_size, product, alloc_mode) -> - Proved (tag_and_size, product, alloc_mode)) + | Some (tag, shape, size, product, alloc_mode) -> + Proved (tag, shape, size, product, alloc_mode)) else Unknown) | Value (Ok (Mutable_block _)) | Value (Ok _) | Value Unknown | Value Bottom -> @@ -532,16 +537,16 @@ let prove_unique_tag_and_size0 env t : wrong_kind "Value" t let prove_unique_tag_and_size env t : - (Tag.t * Targetint_31_63.t) proof_of_property = + (Tag.t * K.Block_shape.t * Targetint_31_63.t) proof_of_property = match prove_unique_tag_and_size0 env t with - | Proved (tag_and_size, _, _) -> Proved tag_and_size + | Proved (tag, shape, size, _, _) -> Proved (tag, shape, size) | Unknown -> Unknown let prove_unique_fully_constructed_immutable_heap_block env t : _ proof_of_property = match prove_unique_tag_and_size0 env t with - | Unknown | Proved (_, _, (Heap_or_local | Local)) -> Unknown - | Proved (tag_and_size, product, Heap) -> ( + | Unknown | Proved (_, _, _, _, (Heap_or_local | Local)) -> Unknown + | Proved (tag, shape, size, product, Heap) -> ( let result = List.fold_left (fun (result : _ proof_of_property) field_ty : _ proof_of_property -> @@ -556,7 +561,7 @@ let prove_unique_fully_constructed_immutable_heap_block env t : in match result with | Unknown -> Unknown - | Proved simples -> Proved (tag_and_size, List.rev simples)) + | Proved simples -> Proved (tag, shape, size, List.rev simples)) let meet_is_naked_number_array env t naked_number_kind : bool meet_shortcut = match expand_head env t with @@ -1105,17 +1110,19 @@ let prove_physical_equality env t1 t2 = TG.Row_like_for_blocks.get_singleton blocks2 ) with | None, _ | _, None -> Unknown - | ( Some ((tag1, size1), _fields1, _alloc_mode1), - Some ((tag2, size2), _fields2, _alloc_mode2) ) -> - if Tag.equal tag1 tag2 && Targetint_31_63.equal size1 size2 + | ( Some (tag1, shape1, size1, _fields1, _alloc_mode1), + Some (tag2, shape2, size2, _fields2, _alloc_mode2) ) -> + if Tag.equal tag1 tag2 + && Targetint_31_63.equal size1 size2 + && K.Block_shape.equal shape1 shape2 then (* CR vlaviron and chambart: We could add a special case for extension constructors, to try to remove dead branches in try...with handlers *) Unknown else - (* Different tags or sizes: the blocks can't be physically - equal. *) + (* Different tags, shapes or sizes: the blocks can't be + physically equal. *) Proved false in (* Note: the [Proved true, Proved true] case cannot be converted to diff --git a/middle_end/flambda2/types/provers.mli b/middle_end/flambda2/types/provers.mli index d10c26cc054..3ac4b1f5878 100644 --- a/middle_end/flambda2/types/provers.mli +++ b/middle_end/flambda2/types/provers.mli @@ -74,7 +74,8 @@ val meet_naked_vec128s : type variant_like_proof = private { const_ctors : Targetint_31_63.Set.t Or_unknown.t; - non_const_ctors_with_sizes : Targetint_31_63.t Tag.Scannable.Map.t + non_const_ctors_with_sizes : + (Targetint_31_63.t * Flambda_kind.Block_shape.t) Tag.Scannable.Map.t } val meet_variant_like : @@ -118,7 +119,7 @@ val prove_is_or_is_not_a_boxed_float : val prove_unique_tag_and_size : Typing_env.t -> Type_grammar.t -> - (Tag.t * Targetint_31_63.t) proof_of_property + (Tag.t * Flambda_kind.Block_shape.t * Targetint_31_63.t) proof_of_property val prove_is_int : Typing_env.t -> Type_grammar.t -> bool proof_of_property @@ -131,7 +132,8 @@ val prove_get_tag : val prove_unique_fully_constructed_immutable_heap_block : Typing_env.t -> Type_grammar.t -> - (Tag_and_size.t * Simple.t list) proof_of_property + (Tag.t * Flambda_kind.Block_shape.t * Targetint_31_63.t * Simple.t list) + proof_of_property val meet_is_naked_number_array : Typing_env.t -> diff --git a/middle_end/flambda2/types/reify.ml b/middle_end/flambda2/types/reify.ml index 3fd818cf2e1..146c5655dd6 100644 --- a/middle_end/flambda2/types/reify.ml +++ b/middle_end/flambda2/types/reify.ml @@ -208,15 +208,21 @@ let reify ~allowed_if_free_vars_defined_in ~var_is_defined_at_toplevel then match TG.Row_like_for_blocks.get_singleton blocks with | None -> try_canonical_simple () - | Some ((tag, size), field_types, alloc_mode) -> ( + | Some (tag, shape, size, field_types, alloc_mode) -> ( assert ( Targetint_31_63.equal size (TG.Product.Int_indexed.width field_types)); (* CR mshinwell: Could recognise other things, e.g. tagged immediates and float arrays, supported by [Static_part]. *) - match Tag.Scannable.of_tag tag with - | None -> try_canonical_simple () - | Some tag -> ( + match shape with + | Float_record | Mixed_record _ -> try_canonical_simple () + | Value_only -> ( + let tag = + match Tag.Scannable.of_tag tag with + | Some tag -> tag + | None -> + Misc.fatal_errorf "Value-only block has tag %a" Tag.print tag + in let field_types = TG.Product.Int_indexed.components field_types in match try_to_reify_fields env ~var_allowed alloc_mode ~field_types diff --git a/ocaml/bytecomp/bytegen.ml b/ocaml/bytecomp/bytegen.ml index d700b4573d9..7b110aa7f1b 100644 --- a/ocaml/bytecomp/bytegen.ml +++ b/ocaml/bytecomp/bytegen.ml @@ -383,7 +383,7 @@ let comp_primitive stack_info p sz args = instructions for the ufloat primitives. *) | Pufloatfield (n, _sem) -> Kgetfloatfield n | Psetufloatfield (n, _init) -> Ksetfloatfield n - | Pmixedfield (n, _, _sem) -> + | Pmixedfield (n, _, _, _sem) -> (* CR layouts: This will need reworking if we ever want bytecode to unbox fields that are written with unboxed types in the source language. *) @@ -391,7 +391,7 @@ let comp_primitive stack_info p sz args = aren't stored flat like they are in native code. *) Kgetfield n - | Psetmixedfield (n, _shape, _init) -> + | Psetmixedfield (n, _, _shape, _init) -> (* See the comment in the [Pmixedfield] case. *) Ksetfield n | Pduprecord _ -> Kccall("caml_obj_dup", 1) diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index 688c83ca0af..089e8b90409 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/lambda/lambda.ml @@ -152,10 +152,12 @@ type primitive = | Psetfield_computed of immediate_or_pointer * initialization_or_assignment | Pfloatfield of int * field_read_semantics * alloc_mode | Pufloatfield of int * field_read_semantics - | Pmixedfield of int * mixed_block_read * field_read_semantics + | Pmixedfield of + int * mixed_block_read * mixed_block_shape * field_read_semantics | Psetfloatfield of int * initialization_or_assignment | Psetufloatfield of int * initialization_or_assignment - | Psetmixedfield of int * mixed_block_write * initialization_or_assignment + | Psetmixedfield of + int * mixed_block_write * mixed_block_shape * initialization_or_assignment | Pduprecord of Types.record_representation * int (* Unboxed products *) | Pmake_unboxed_product of layout list @@ -1678,7 +1680,7 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ -> None | Pfloatfield (_, _, m) -> Some m | Pufloatfield _ -> None - | Pmixedfield (_, read, _) -> begin + | Pmixedfield (_, read, _, _) -> begin match read with | Mread_value_prefix _ -> None | Mread_flat_suffix (Flat_read_float_boxed m) -> Some m @@ -1872,7 +1874,7 @@ let primitive_result_layout (p : primitive) = | Pbox_float (f, _) -> layout_boxed_float f | Pufloatfield _ -> Punboxed_float Pfloat64 | Punbox_float float_kind -> Punboxed_float float_kind - | Pmixedfield (_, kind, _) -> layout_of_mixed_field kind + | Pmixedfield (_, kind, _, _) -> layout_of_mixed_field kind | Pccall { prim_native_repr_res = _, repr_res } -> layout_of_extern_repr repr_res | Praise _ -> layout_bottom | Psequor | Psequand | Pnot diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli index 87f253387b1..fe954b85971 100644 --- a/ocaml/lambda/lambda.mli +++ b/ocaml/lambda/lambda.mli @@ -109,13 +109,15 @@ type primitive = | Psetfield_computed of immediate_or_pointer * initialization_or_assignment | Pfloatfield of int * field_read_semantics * alloc_mode | Pufloatfield of int * field_read_semantics - | Pmixedfield of int * mixed_block_read * field_read_semantics + | Pmixedfield of + int * mixed_block_read * mixed_block_shape * field_read_semantics (* [Pmixedfield] is an access to either the flat suffix or value prefix of a mixed record. *) | Psetfloatfield of int * initialization_or_assignment | Psetufloatfield of int * initialization_or_assignment - | Psetmixedfield of int * mixed_block_write * initialization_or_assignment + | Psetmixedfield of + int * mixed_block_write * mixed_block_shape * initialization_or_assignment | Pduprecord of Types.record_representation * int (* Unboxed products *) | Pmake_unboxed_product of layout list diff --git a/ocaml/lambda/matching.ml b/ocaml/lambda/matching.ml index 084037bbfdc..0ba2935daaf 100644 --- a/ocaml/lambda/matching.ml +++ b/ocaml/lambda/matching.ml @@ -1819,7 +1819,8 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem = in Mread_flat_suffix flat_read in - Pmixedfield (pos, read, Reads_agree) + let shape = Lambda.transl_mixed_product_shape shape in + Pmixedfield (pos, read, shape, Reads_agree) in let jkind = cstr.cstr_arg_jkinds.(field) in let sort = Jkind.sort_of_jkind jkind in @@ -2191,7 +2192,10 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem = in Mread_flat_suffix read in - Lprim (Pmixedfield (lbl.lbl_pos, read, sem), [ arg ], loc), + let shape : Lambda.mixed_block_shape = + { value_prefix_len; flat_suffix } + in + Lprim (Pmixedfield (lbl.lbl_pos, read, shape, sem), [ arg ], loc), lbl_sort, lbl_layout in let str = if Types.is_mutable lbl.lbl_mut then StrictOpt else Alias in diff --git a/ocaml/lambda/printlambda.ml b/ocaml/lambda/printlambda.ml index 00130ef31f8..bc43aca7e7a 100644 --- a/ocaml/lambda/printlambda.ml +++ b/ocaml/lambda/printlambda.ml @@ -467,7 +467,7 @@ let primitive ppf = function | Pufloatfield (n, sem) -> fprintf ppf "ufloatfield%a %i" field_read_semantics sem n - | Pmixedfield (n, read, sem) -> + | Pmixedfield (n, read, _shape, sem) -> fprintf ppf "mixedfield%a %i %a" field_read_semantics sem n mixed_block_read read | Psetfloatfield (n, init) -> @@ -488,7 +488,7 @@ let primitive ppf = function | Assignment Modify_maybe_stack -> "(maybe-stack)" in fprintf ppf "setufloatfield%s %i" init n - | Psetmixedfield (n, write, init) -> + | Psetmixedfield (n, write, _shape, init) -> let init = match init with | Heap_initialization -> "(heap-init)" diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index a0462221b46..ec8ace9e41c 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -623,7 +623,10 @@ and transl_exp0 ~in_new_scope ~scopes sort e = in Mread_flat_suffix flat_read in - Lprim (Pmixedfield (lbl.lbl_pos, read, sem), [targ], + let shape : Lambda.mixed_block_shape = + { value_prefix_len; flat_suffix } + in + Lprim (Pmixedfield (lbl.lbl_pos, read, shape, sem), [targ], of_location ~scopes e.exp_loc) end | Texp_setfield(arg, arg_mode, id, lbl, newval) -> @@ -655,7 +658,10 @@ and transl_exp0 ~in_new_scope ~scopes sort e = let flat_element = flat_suffix.(lbl.lbl_num - value_prefix_len) in Mwrite_flat_suffix flat_element in - Psetmixedfield(lbl.lbl_pos, write, mode) + let shape : Lambda.mixed_block_shape = + { value_prefix_len; flat_suffix } + in + Psetmixedfield(lbl.lbl_pos, write, shape, mode) end in Lprim(access, [transl_exp ~scopes Jkind.Sort.for_record arg; @@ -1743,7 +1749,10 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = in Mread_flat_suffix read in - Pmixedfield (i, read, sem) + let shape : Lambda.mixed_block_shape = + { value_prefix_len; flat_suffix } + in + Pmixedfield (i, read, shape, sem) in Lprim(access, [Lvar init_id], of_location ~scopes loc), @@ -1848,8 +1857,11 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = in Mwrite_flat_suffix flat_element in + let shape : Lambda.mixed_block_shape = + { value_prefix_len; flat_suffix } + in Psetmixedfield - (lbl.lbl_pos, write, Assignment modify_heap) + (lbl.lbl_pos, write, shape, Assignment modify_heap) end in Lsequence(Lprim(upd, [Lvar copy_id; diff --git a/ocaml/testsuite/tests/flambda/flambda2_row_like_join.ml b/ocaml/testsuite/tests/flambda/flambda2_row_like_join.ml new file mode 100644 index 00000000000..f7fc1867080 --- /dev/null +++ b/ocaml/testsuite/tests/flambda/flambda2_row_like_join.ml @@ -0,0 +1,46 @@ +(* TEST *) + +(* Tests a corner case of the Flambda2 join algorithm. + This checks that joining a row-like type where the tags are known, + with a row-like type where the tag is not known, correctly + takes both sides into account. *) + +(* GADTs allow us to hide kind information *) +type _ t = A : (int * int) t | B : (int * int) t + +let[@inline never] f (type a) (x : a) (cond : a t) = + let result : a = + match cond with + | A -> (0, 1) (* Known tag *) + | B -> begin + let r = fst x in (* Creates an equation on [x] with unknown tag *) + ignore (Sys.opaque_identity r); + x + end + in + (* At this point, [result] has been joined with no kind information. + If everything went well, we should know that: + - It can have tag 0 (as branch A has this tag) + - It can have any tag (as branch B doesn't restrict the tag) + The point of this test is to check that the approximation for + [result] doesn't assume that if it has tag 0, it must have come + from branch A. *) + (* We now need to cast it back to a tuple: *) + let result : int * int = match cond with A -> result | B -> result in + (* Then we need to actually introduce the constraint on the tag. + This is done by storing it into a block with a known shape: *) + let ignored : (unit * (int * int)) = (), result in + (* Now, if we wrongly assumed that only branch A has tag 0, + we would be able to propagate that information here and replace + [a + b] by the constant 1.*) + let a, b = result in + (* [ignored] is returned to make sure we don't remove the block + creation primitive that adds the tag constraint *) + a + b, ignored + +let test () = + let r, _ = f (2, 3) B in + assert (r == 5); + () + +let () = test () diff --git a/ocaml/utils/misc.ml b/ocaml/utils/misc.ml index 25a69fcd6a3..2a22f773424 100644 --- a/ocaml/utils/misc.ml +++ b/ocaml/utils/misc.ml @@ -168,6 +168,14 @@ module Stdlib = struct if a' == a && l' == l then l0 else a' :: l' | [] -> [] + let fold_lefti f accu l = + let rec aux f i accu l = + match l with + | [] -> accu + | a::l -> aux f (succ i) (f i accu a) l + in + aux f 0 accu l + let chunks_of n l = if n <= 0 then raise (Invalid_argument "chunks_of"); (* Invariant: List.length l = remaining *) diff --git a/ocaml/utils/misc.mli b/ocaml/utils/misc.mli index 71500eadb05..d9f5ff559f3 100644 --- a/ocaml/utils/misc.mli +++ b/ocaml/utils/misc.mli @@ -143,6 +143,10 @@ module Stdlib : sig (** [map_sharing f l] is [map f l]. If for all elements of the list [f e == e] then [map_sharing f l == l] *) + val fold_lefti : (int -> 'a -> 'b -> 'a) -> 'a -> 'b list -> 'a + (** [fold_lefti f init l] is like [fold_left] but also takes as parameter + the zero-based index of the element *) + val chunks_of : int -> 'a t -> 'a t t (** [chunks_of n t] returns a list of nonempty lists whose concatenation is equal to the original list. Every list has [n]