From 19da487db6eaba3c868d60f19da3e093c8753d91 Mon Sep 17 00:00:00 2001 From: Pierre Chambart Date: Mon, 29 Mar 2021 19:21:50 +0200 Subject: [PATCH 1/6] Introduce poison constants --- middle_end/flambda/basic/reg_width_const.ml | 18 +- .../compilenv_deps/reg_width_things.ml | 169 +++++++++++++----- .../compilenv_deps/reg_width_things.mli | 23 ++- middle_end/flambda/parser/flambda_to_fexpr.ml | 19 +- middle_end/flambda/simplify/simplify_named.ml | 2 +- .../flambda/simplify/simplify_static_const.ml | 5 +- .../flambda/simplify/simplify_switch_expr.ml | 2 +- middle_end/flambda/to_cmm/un_cps.ml | 12 +- middle_end/flambda/to_cmm/un_cps_static.ml | 12 +- .../types/template/flambda_type.templ.ml | 22 ++- middle_end/flambda/types/type_descr.rec.ml | 12 +- middle_end/flambda/types/type_grammar.rec.ml | 12 +- 12 files changed, 212 insertions(+), 96 deletions(-) diff --git a/middle_end/flambda/basic/reg_width_const.ml b/middle_end/flambda/basic/reg_width_const.ml index 024aff05f087..3238ef7715bf 100644 --- a/middle_end/flambda/basic/reg_width_const.ml +++ b/middle_end/flambda/basic/reg_width_const.ml @@ -30,9 +30,15 @@ let kind t = let of_descr (descr : Descr.t) = match descr with - | Naked_immediate i -> naked_immediate i - | Tagged_immediate i -> tagged_immediate i - | Naked_float f -> naked_float f - | Naked_int32 i -> naked_int32 i - | Naked_int64 i -> naked_int64 i - | Naked_nativeint i -> naked_nativeint i + | Naked_immediate (Value, i) -> naked_immediate i + | Tagged_immediate (Value, i) -> tagged_immediate i + | Naked_float (Value, f) -> naked_float f + | Naked_int32 (Value, i) -> naked_int32 i + | Naked_int64 (Value, i) -> naked_int64 i + | Naked_nativeint (Value, i) -> naked_nativeint i + | Naked_immediate (Poison, _) -> naked_immediate_poison + | Tagged_immediate (Poison, _) -> tagged_immediate_poison + | Naked_float (Poison, _) -> naked_float_poison + | Naked_int32 (Poison, _) -> naked_int32_poison + | Naked_int64 (Poison, _) -> naked_int64_poison + | Naked_nativeint (Poison, _) -> naked_nativeint_poison diff --git a/middle_end/flambda/compilenv_deps/reg_width_things.ml b/middle_end/flambda/compilenv_deps/reg_width_things.ml index fd9787f60c8e..e50ef82b1914 100644 --- a/middle_end/flambda/compilenv_deps/reg_width_things.ml +++ b/middle_end/flambda/compilenv_deps/reg_width_things.ml @@ -26,13 +26,15 @@ let const_flags = 2 let simple_flags = 3 module Const_data = struct - type t = - | Naked_immediate of Target_imm.t - | Tagged_immediate of Target_imm.t - | Naked_float of Numbers.Float_by_bit_pattern.t - | Naked_int32 of Int32.t - | Naked_int64 of Int64.t - | Naked_nativeint of Targetint.t + type is_poison = Value | Poison + + type t = + | Naked_immediate of is_poison * Target_imm.t + | Tagged_immediate of is_poison * Target_imm.t + | Naked_float of is_poison * Numbers.Float_by_bit_pattern.t + | Naked_int32 of is_poison * Int32.t + | Naked_int64 of is_poison * Int64.t + | Naked_nativeint of is_poison * Targetint.t let flags = const_flags @@ -41,52 +43,94 @@ module Const_data = struct let print ppf (t : t) = match t with - | Naked_immediate i -> + | Naked_immediate (Value, i) -> Format.fprintf ppf "@<0>%s#%a@<0>%s" (Flambda_colours.naked_number ()) Target_imm.print i (Flambda_colours.normal ()) - | Tagged_immediate i -> + | Naked_immediate (Poison, i) -> + Format.fprintf ppf "@<0>%s#Poison %a@<0>%s" + (Flambda_colours.naked_number ()) + Target_imm.print i + (Flambda_colours.normal ()) + | Tagged_immediate (Value, i) -> Format.fprintf ppf "@<0>%s%a@<0>%s" (Flambda_colours.tagged_immediate ()) Target_imm.print i (Flambda_colours.normal ()) - | Naked_float f -> + | Tagged_immediate (Poison, i) -> + Format.fprintf ppf "@<0>%sPoison %a@<0>%s" + (Flambda_colours.tagged_immediate ()) + Target_imm.print i + (Flambda_colours.normal ()) + | Naked_float (Value, f) -> Format.fprintf ppf "@<0>%s#%a@<0>%s" (Flambda_colours.naked_number ()) Numbers.Float_by_bit_pattern.print f (Flambda_colours.normal ()) - | Naked_int32 n -> + | Naked_float (Poison, f) -> + Format.fprintf ppf "@<0>%s#Poison %a@<0>%s" + (Flambda_colours.naked_number ()) + Numbers.Float_by_bit_pattern.print f + (Flambda_colours.normal ()) + | Naked_int32 (Value, n) -> Format.fprintf ppf "@<0>%s#%ldl@<0>%s" (Flambda_colours.naked_number ()) n (Flambda_colours.normal ()) - | Naked_int64 n -> + | Naked_int32 (Poison, n) -> + Format.fprintf ppf "@<0>%s#Poison %ldl@<0>%s" + (Flambda_colours.naked_number ()) + n + (Flambda_colours.normal ()) + | Naked_int64 (Value, n) -> Format.fprintf ppf "@<0>%s#%LdL@<0>%s" (Flambda_colours.naked_number ()) n (Flambda_colours.normal ()) - | Naked_nativeint n -> + | Naked_int64 (Poison, n) -> + Format.fprintf ppf "@<0>%s#Poison %LdL@<0>%s" + (Flambda_colours.naked_number ()) + n + (Flambda_colours.normal ()) + | Naked_nativeint (Value, n) -> Format.fprintf ppf "@<0>%s#%an@<0>%s" (Flambda_colours.naked_number ()) Targetint.print n (Flambda_colours.normal ()) + | Naked_nativeint (Poison, n) -> + Format.fprintf ppf "@<0>%s#Poison %an@<0>%s" + (Flambda_colours.naked_number ()) + Targetint.print n + (Flambda_colours.normal ()) let output _ _ = Misc.fatal_error "[output] not yet implemented" let compare t1 t2 = match t1, t2 with - | Naked_immediate i1, Naked_immediate i2 -> + | Naked_immediate (Poison, _), Naked_immediate (Value, _) -> -1 + | Naked_immediate (Value, _), Naked_immediate (Poison, _) -> 1 + | Naked_immediate ((Poison | Value), i1), Naked_immediate ((Poison | Value), i2) -> Target_imm.compare i1 i2 - | Tagged_immediate i1, Tagged_immediate i2 -> + | Tagged_immediate (Poison, _), Tagged_immediate (Value, _) -> -1 + | Tagged_immediate (Value, _), Tagged_immediate (Poison, _) -> 1 + | Tagged_immediate ((Poison | Value), i1), Tagged_immediate ((Poison | Value), i2) -> Target_imm.compare i1 i2 - | Naked_float f1, Naked_float f2 -> + | Naked_float (Poison, _), Naked_float (Value, _) -> -1 + | Naked_float (Value, _), Naked_float (Poison, _) -> 1 + | Naked_float ((Poison | Value), f1), Naked_float ((Poison | Value), f2) -> Numbers.Float_by_bit_pattern.compare f1 f2 - | Naked_int32 n1, Naked_int32 n2 -> + | Naked_int32 (Poison, _), Naked_int32 (Value, _) -> -1 + | Naked_int32 (Value, _), Naked_int32 (Poison, _) -> 1 + | Naked_int32 ((Poison | Value), n1), Naked_int32 ((Poison | Value), n2) -> Int32.compare n1 n2 - | Naked_int64 n1, Naked_int64 n2 -> + | Naked_int64 (Poison, _), Naked_int64 (Value, _) -> -1 + | Naked_int64 (Value, _), Naked_int64 (Poison, _) -> 1 + | Naked_int64 ((Poison | Value), n1), Naked_int64 ((Poison | Value), n2) -> Int64.compare n1 n2 - | Naked_nativeint n1, Naked_nativeint n2 -> + | Naked_nativeint (Poison, _), Naked_nativeint (Value, _) -> -1 + | Naked_nativeint (Value, _), Naked_nativeint (Poison, _) -> 1 + | Naked_nativeint ((Poison | Value), n1), Naked_nativeint ((Poison | Value), n2) -> Targetint.compare n1 n2 | Naked_immediate _, _ -> -1 | _, Naked_immediate _ -> 1 @@ -99,33 +143,50 @@ module Const_data = struct | Naked_int64 _, _ -> -1 | _, Naked_int64 _ -> 1 + let equal_poison (p1 : is_poison) (p2 : is_poison) = + match p1, p2 with + | Poison, Poison -> true + | Value, Value -> true + | Poison, Value + | Value, Poison -> false + let equal t1 t2 = if t1 == t2 then true else match t1, t2 with - | Naked_immediate i1, Naked_immediate i2 -> - Target_imm.equal i1 i2 - | Tagged_immediate i1, Tagged_immediate i2 -> - Target_imm.equal i1 i2 - | Naked_float f1, Naked_float f2 -> - Numbers.Float_by_bit_pattern.equal f1 f2 - | Naked_int32 n1, Naked_int32 n2 -> - Int32.equal n1 n2 - | Naked_int64 n1, Naked_int64 n2 -> - Int64.equal n1 n2 - | Naked_nativeint n1, Naked_nativeint n2 -> - Targetint.equal n1 n2 + | Naked_immediate (p1, i1), Naked_immediate (p2, i2) -> + equal_poison p1 p2 && Target_imm.equal i1 i2 + | Tagged_immediate (p1, i1), Tagged_immediate (p2, i2) -> + equal_poison p1 p2 && Target_imm.equal i1 i2 + | Naked_float (p1, f1), Naked_float (p2, f2) -> + equal_poison p1 p2 && Numbers.Float_by_bit_pattern.equal f1 f2 + | Naked_int32 (p1, n1), Naked_int32 (p2, n2) -> + equal_poison p1 p2 && Int32.equal n1 n2 + | Naked_int64 (p1, n1), Naked_int64 (p2, n2) -> + equal_poison p1 p2 && Int64.equal n1 n2 + | Naked_nativeint (p1, n1), Naked_nativeint (p2, n2) -> + equal_poison p1 p2 && Targetint.equal n1 n2 | (Naked_immediate _ | Tagged_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _), _ -> false + let hash_poison = function + | Value -> 0 + | Poison -> 1 + let hash t = match t with - | Naked_immediate n -> Target_imm.hash n - | Tagged_immediate n -> Target_imm.hash n - | Naked_float n -> Numbers.Float_by_bit_pattern.hash n - | Naked_int32 n -> Hashtbl.hash n - | Naked_int64 n -> Hashtbl.hash n - | Naked_nativeint n -> Targetint.hash n + | Naked_immediate (p, n) -> + Misc.hash2 (hash_poison p) (Target_imm.hash n) + | Tagged_immediate (p, n) -> + Misc.hash2 (hash_poison p) (Target_imm.hash n) + | Naked_float (p, n) -> + Misc.hash2 (hash_poison p) (Numbers.Float_by_bit_pattern.hash n) + | Naked_int32 (p, n) -> + Misc.hash2 (hash_poison p) (Hashtbl.hash n) + | Naked_int64 (p, n) -> + Misc.hash2 (hash_poison p) (Hashtbl.hash n) + | Naked_nativeint (p, n) -> + Misc.hash2 (hash_poison p) (Targetint.hash n) end) end @@ -265,12 +326,12 @@ module Const = struct let create (data : Const_data.t) = Table.add !grand_table_of_constants data - let naked_immediate imm = create (Naked_immediate imm) - let tagged_immediate imm = create (Tagged_immediate imm) - let naked_float f = create (Naked_float f) - let naked_int32 i = create (Naked_int32 i) - let naked_int64 i = create (Naked_int64 i) - let naked_nativeint i = create (Naked_nativeint i) + let naked_immediate imm = create (Naked_immediate (Value, imm)) + let tagged_immediate imm = create (Tagged_immediate (Value, imm)) + let naked_float f = create (Naked_float (Value, f)) + let naked_int32 i = create (Naked_int32 (Value, i)) + let naked_int64 i = create (Naked_int64 (Value, i)) + let naked_nativeint i = create (Naked_nativeint (Value, i)) let const_true = tagged_immediate Target_imm.bool_true let const_false = tagged_immediate Target_imm.bool_false @@ -288,8 +349,30 @@ module Const = struct let const_one = tagged_immediate Target_imm.one let const_unit = const_zero + let naked_immediate_poison = + create (Naked_immediate (Poison, Target_imm.zero)) + let tagged_immediate_poison = + create (Tagged_immediate (Poison, Target_imm.zero)) + let naked_float_poison = + create (Naked_float (Poison, Numbers.Float_by_bit_pattern.zero)) + let naked_int32_poison = + create (Naked_int32 (Poison, Int32.zero)) + let naked_int64_poison = + create (Naked_int64 (Poison, Int64.zero)) + let naked_nativeint_poison = + create (Naked_nativeint (Poison, Targetint.zero)) + let descr t = find_data t + let is_poison t = + match find_data t with + | Naked_immediate (p, _) -> p + | Tagged_immediate (p, _) -> p + | Naked_float (p, _) -> p + | Naked_int32 (p, _) -> p + | Naked_int64 (p, _) -> p + | Naked_nativeint (p, _) -> p + module T0 = struct let compare = Id.compare let equal = Id.equal diff --git a/middle_end/flambda/compilenv_deps/reg_width_things.mli b/middle_end/flambda/compilenv_deps/reg_width_things.mli index b69a89f1b475..ba04037bba62 100644 --- a/middle_end/flambda/compilenv_deps/reg_width_things.mli +++ b/middle_end/flambda/compilenv_deps/reg_width_things.mli @@ -52,20 +52,31 @@ module Const : sig val naked_int64 : Int64.t -> t val naked_nativeint : Targetint.t -> t + val naked_immediate_poison : t + val tagged_immediate_poison : t + val naked_float_poison : t + val naked_int32_poison : t + val naked_int64_poison : t + val naked_nativeint_poison : t + module Descr : sig + type is_poison = private Value | Poison + type t = private - | Naked_immediate of Target_imm.t - | Tagged_immediate of Target_imm.t - | Naked_float of Numbers.Float_by_bit_pattern.t - | Naked_int32 of Int32.t - | Naked_int64 of Int64.t - | Naked_nativeint of Targetint.t + | Naked_immediate of is_poison * Target_imm.t + | Tagged_immediate of is_poison * Target_imm.t + | Naked_float of is_poison * Numbers.Float_by_bit_pattern.t + | Naked_int32 of is_poison * Int32.t + | Naked_int64 of is_poison * Int64.t + | Naked_nativeint of is_poison * Targetint.t include Identifiable.S with type t := t end val descr : t -> Descr.t + val is_poison : t -> Descr.is_poison + val export : t -> exported val import : exported -> t diff --git a/middle_end/flambda/parser/flambda_to_fexpr.ml b/middle_end/flambda/parser/flambda_to_fexpr.ml index d944c37ef254..fa626d7858da 100644 --- a/middle_end/flambda/parser/flambda_to_fexpr.ml +++ b/middle_end/flambda/parser/flambda_to_fexpr.ml @@ -260,18 +260,25 @@ let name env n = let const c : Fexpr.const = match Reg_width_things.Const.descr c with - | Naked_immediate imm -> + | Naked_immediate (Value, imm) -> Naked_immediate (imm |> Target_imm.to_targetint' |> Targetint.to_string) - | Tagged_immediate imm -> + | Tagged_immediate (Value, imm) -> Tagged_immediate (imm |> Target_imm.to_targetint' |> Targetint.to_string) - | Naked_float f -> + | Naked_float (Value, f) -> Naked_float (f |> Numbers.Float_by_bit_pattern.to_float) - | Naked_int32 i -> + | Naked_int32 (Value, i) -> Naked_int32 i - | Naked_int64 i -> + | Naked_int64 (Value, i) -> Naked_int64 i - | Naked_nativeint i -> + | Naked_nativeint (Value, i) -> Naked_nativeint (i |> Targetint.to_int64) + | Naked_immediate (Poison, _) + | Tagged_immediate (Poison, _) + | Naked_float (Poison, _) + | Naked_int32 (Poison, _) + | Naked_int64 (Poison, _) + | Naked_nativeint (Poison, _) -> + Misc.fatal_errorf "TODO: Poison constants" let simple env s = Simple.pattern_match s diff --git a/middle_end/flambda/simplify/simplify_named.ml b/middle_end/flambda/simplify/simplify_named.ml index a22a01980a72..9fc181d2cf84 100644 --- a/middle_end/flambda/simplify/simplify_named.ml +++ b/middle_end/flambda/simplify/simplify_named.ml @@ -71,7 +71,7 @@ let record_any_symbol_projection dacc (defining_expr : Simplified_named.t) Simple.pattern_match index ~const:(fun const -> match Reg_width_const.descr const with - | Tagged_immediate imm -> + | Tagged_immediate (_, imm) -> Simple.pattern_match' block ~const:(fun _ -> None) ~symbol:(fun symbol_projected_from -> diff --git a/middle_end/flambda/simplify/simplify_static_const.ml b/middle_end/flambda/simplify/simplify_static_const.ml index 74fef9a6569c..8045a9cb3ba1 100644 --- a/middle_end/flambda/simplify/simplify_static_const.ml +++ b/middle_end/flambda/simplify/simplify_static_const.ml @@ -41,7 +41,10 @@ let simplify_field_of_block dacc (field : Field_of_block.t) = ~symbol:(fun sym -> Field_of_block.Symbol sym, ty)) ~const:(fun const -> match Reg_width_const.descr const with - | Tagged_immediate imm -> Field_of_block.Tagged_immediate imm, ty + | Tagged_immediate (Value, imm) -> Field_of_block.Tagged_immediate imm, ty + | Tagged_immediate (Poison, _) -> + (* CR pchambart: This should be "invalid" and propagate up *) + field, T.bottom K.value | Naked_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _ -> (* CR mshinwell: This should be "invalid" and propagate up *) diff --git a/middle_end/flambda/simplify/simplify_switch_expr.ml b/middle_end/flambda/simplify/simplify_switch_expr.ml index cd8d0ee5b3f7..67bb7f672cd8 100644 --- a/middle_end/flambda/simplify/simplify_switch_expr.ml +++ b/middle_end/flambda/simplify/simplify_switch_expr.ml @@ -82,7 +82,7 @@ let rebuild_switch ~simplify_let dacc ~arms ~scrutinee ~scrutinee_ty uacc *) let [@inline always] const arg = match Reg_width_const.descr arg with - | Tagged_immediate arg -> + | Tagged_immediate (_, arg) -> if Target_imm.equal arm arg then let identity_arms = Target_imm.Map.add arm action identity_arms diff --git a/middle_end/flambda/to_cmm/un_cps.ml b/middle_end/flambda/to_cmm/un_cps.ml index 0dad1e2de481..7a38078e39dd 100644 --- a/middle_end/flambda/to_cmm/un_cps.ml +++ b/middle_end/flambda/to_cmm/un_cps.ml @@ -75,15 +75,15 @@ let targetint_of_imm i = Targetint.OCaml.to_targetint i.Target_imm.value let const _env cst = match Reg_width_const.descr cst with - | Naked_immediate i -> + | Naked_immediate (_, i) -> C.targetint (targetint_of_imm i) - | Tagged_immediate i -> + | Tagged_immediate (_, i) -> C.targetint (tag_targetint (targetint_of_imm i)) - | Naked_float f -> + | Naked_float (_, f) -> C.float (Numbers.Float_by_bit_pattern.to_float f) - | Naked_int32 i -> C.int32 i - | Naked_int64 i -> C.int64 i - | Naked_nativeint t -> C.targetint t + | Naked_int32 (_, i) -> C.int32 i + | Naked_int64 (_, i) -> C.int64 i + | Naked_nativeint (_, t) -> C.targetint t let default_of_kind (k : Flambda_kind.t) = match k with diff --git a/middle_end/flambda/to_cmm/un_cps_static.ml b/middle_end/flambda/to_cmm/un_cps_static.ml index 3a1d7f4f24b7..b427b92ee3f2 100644 --- a/middle_end/flambda/to_cmm/un_cps_static.ml +++ b/middle_end/flambda/to_cmm/un_cps_static.ml @@ -55,18 +55,18 @@ let name_static env name = let const_static _env cst = match Reg_width_const.descr cst with - | Naked_immediate i -> + | Naked_immediate (_, i) -> [C.cint (nativeint_of_targetint (targetint_of_imm i))] - | Tagged_immediate i -> + | Tagged_immediate (_, i) -> [C.cint (nativeint_of_targetint (tag_targetint (targetint_of_imm i)))] - | Naked_float f -> + | Naked_float (_, f) -> [C.cfloat (Numbers.Float_by_bit_pattern.to_float f)] - | Naked_int32 i -> + | Naked_int32 (_, i) -> [C.cint (Nativeint.of_int32 i)] - | Naked_int64 i -> + | Naked_int64 (_, i) -> if C.arch32 then todo() (* split int64 on 32-bit archs *) else [C.cint (Int64.to_nativeint i)] - | Naked_nativeint t -> + | Naked_nativeint (_, t) -> [C.cint (nativeint_of_targetint t)] let simple_static env s = diff --git a/middle_end/flambda/types/template/flambda_type.templ.ml b/middle_end/flambda/types/template/flambda_type.templ.ml index 2f246c137779..9ad2fe06f9c2 100644 --- a/middle_end/flambda/types/template/flambda_type.templ.ml +++ b/middle_end/flambda/types/template/flambda_type.templ.ml @@ -132,7 +132,7 @@ let prove_equals_to_var_or_symbol_or_tagged_immediate env t Simple.pattern_match simple ~const:(fun cst : _ proof -> match Reg_width_const.descr cst with - | Tagged_immediate imm -> Proved (Tagged_immediate imm) + | Tagged_immediate (_, imm) -> Proved (Tagged_immediate imm) | _ -> Misc.fatal_errorf "[Simple] %a in the [Equals] field has a kind \ different from that returned by [kind] (%a):@ %a" @@ -152,7 +152,7 @@ let prove_equals_to_var_or_symbol_or_tagged_immediate env t Simple.pattern_match simple ~const:(fun cst : _ proof -> match Reg_width_const.descr cst with - | Tagged_immediate imm -> Proved (Tagged_immediate imm) + | Tagged_immediate (_, imm) -> Proved (Tagged_immediate imm) | _ -> let kind = kind t in Misc.fatal_errorf "Kind returned by [get_canonical_simple] (%a) \ @@ -213,7 +213,8 @@ let prove_naked_floats env t : _ proof = Misc.fatal_errorf "Kind error: expected [Naked_float]:@ %a" print t in match expand_head t env with - | Const (Naked_float f) -> Proved (Float.Set.singleton f) + | Const (Naked_float (Value, f)) -> Proved (Float.Set.singleton f) + | Const (Naked_float (Poison, _)) -> Invalid | Const (Naked_immediate _ | Tagged_immediate _ | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _) -> wrong_kind () | Naked_float (Ok fs) -> @@ -232,7 +233,8 @@ let prove_naked_int32s env t : _ proof = Misc.fatal_errorf "Kind error: expected [Naked_int32]:@ %a" print t in match expand_head t env with - | Const (Naked_int32 i) -> Proved (Int32.Set.singleton i) + | Const (Naked_int32 (Value, i)) -> Proved (Int32.Set.singleton i) + | Const (Naked_int32 (Poison, _)) -> Invalid | Const (Naked_immediate _ | Tagged_immediate _ | Naked_float _ | Naked_int64 _ | Naked_nativeint _) -> wrong_kind () | Naked_int32 (Ok is) -> @@ -251,7 +253,8 @@ let prove_naked_int64s env t : _ proof = Misc.fatal_errorf "Kind error: expected [Naked_int64]:@ %a" print t in match expand_head t env with - | Const (Naked_int64 i) -> Proved (Int64.Set.singleton i) + | Const (Naked_int64 (Value, i)) -> Proved (Int64.Set.singleton i) + | Const (Naked_int64 (Poison, _)) -> Invalid | Const (Naked_immediate _ | Tagged_immediate _ | Naked_float _ | Naked_int32 _ | Naked_nativeint _) -> wrong_kind () | Naked_int64 (Ok is) -> @@ -270,7 +273,8 @@ let prove_naked_nativeints env t : _ proof = Misc.fatal_errorf "Kind error: expected [Naked_nativeint]:@ %a" print t in match expand_head t env with - | Const (Naked_nativeint i) -> Proved (Targetint.Set.singleton i) + | Const (Naked_nativeint (Value, i)) -> Proved (Targetint.Set.singleton i) + | Const (Naked_nativeint (Poison, _)) -> Invalid | Const (Naked_immediate _ | Tagged_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _) -> wrong_kind () | Naked_nativeint (Ok is) -> @@ -373,7 +377,8 @@ let prove_naked_immediates env t : Target_imm.Set.t proof = Misc.fatal_errorf "Kind error: expected [Naked_immediate]:@ %a" print t in match expand_head t env with - | Const (Naked_immediate i) -> Proved (Target_imm.Set.singleton i) + | Const (Naked_immediate (Value, i)) -> Proved (Target_imm.Set.singleton i) + | Const (Naked_immediate (Poison, _)) -> Invalid | Const (Tagged_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _) -> wrong_kind () | Naked_immediate (Ok (Naked_immediates is)) -> @@ -417,7 +422,8 @@ let prove_equals_tagged_immediates env t : Target_imm.Set.t proof = Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t in match expand_head t env with - | Const (Tagged_immediate imm) -> Proved (Target_imm.Set.singleton imm) + | Const (Tagged_immediate (Value, imm)) -> Proved (Target_imm.Set.singleton imm) + | Const (Tagged_immediate (Poison, _)) -> Invalid | Const (Naked_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _) -> wrong_kind () | Value (Ok (Variant blocks_imms)) -> diff --git a/middle_end/flambda/types/type_descr.rec.ml b/middle_end/flambda/types/type_descr.rec.ml index cbd9bdd0d068..17bcab9ad5ff 100644 --- a/middle_end/flambda/types/type_descr.rec.ml +++ b/middle_end/flambda/types/type_descr.rec.ml @@ -163,12 +163,12 @@ module Make (Head : Type_head_intf.S let [@inline always] const const = let typ = match Reg_width_const.descr const with - | Naked_immediate i -> T.this_naked_immediate_without_alias i - | Tagged_immediate i -> T.this_tagged_immediate_without_alias i - | Naked_float f -> T.this_naked_float_without_alias f - | Naked_int32 i -> T.this_naked_int32_without_alias i - | Naked_int64 i -> T.this_naked_int64_without_alias i - | Naked_nativeint i -> T.this_naked_nativeint_without_alias i + | Naked_immediate (_, i) -> T.this_naked_immediate_without_alias i + | Tagged_immediate (_, i) -> T.this_tagged_immediate_without_alias i + | Naked_float (_, f) -> T.this_naked_float_without_alias f + | Naked_int32 (_, i) -> T.this_naked_int32_without_alias i + | Naked_int64 (_, i) -> T.this_naked_int64_without_alias i + | Naked_nativeint (_, i) -> T.this_naked_nativeint_without_alias i in force_to_head ~force_to_kind typ in diff --git a/middle_end/flambda/types/type_grammar.rec.ml b/middle_end/flambda/types/type_grammar.rec.ml index bf778f62bc87..c5d2fd10f728 100644 --- a/middle_end/flambda/types/type_grammar.rec.ml +++ b/middle_end/flambda/types/type_grammar.rec.ml @@ -704,12 +704,12 @@ let array_of_length ~length = let type_for_const const = match Reg_width_const.descr const with - | Naked_immediate i -> this_naked_immediate i - | Tagged_immediate i -> this_tagged_immediate i - | Naked_float f -> this_naked_float f - | Naked_int32 n -> this_naked_int32 n - | Naked_int64 n -> this_naked_int64 n - | Naked_nativeint n -> this_naked_nativeint n + | Naked_immediate (_, i) -> this_naked_immediate i + | Tagged_immediate (_, i) -> this_tagged_immediate i + | Naked_float (_, f) -> this_naked_float f + | Naked_int32 (_, n) -> this_naked_int32 n + | Naked_int64 (_, n) -> this_naked_int64 n + | Naked_nativeint (_, n) -> this_naked_nativeint n let kind_for_const const = kind (type_for_const const) From d29f44fd0f198927232f4f5ecfa18cb267537c8b Mon Sep 17 00:00:00 2001 From: Pierre Chambart Date: Mon, 29 Mar 2021 19:53:50 +0200 Subject: [PATCH 2/6] Example of situation where two unboxing passes occur --- flambdatest/mlexamples/unboxing_need_poison.ml | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 flambdatest/mlexamples/unboxing_need_poison.ml diff --git a/flambdatest/mlexamples/unboxing_need_poison.ml b/flambdatest/mlexamples/unboxing_need_poison.ml new file mode 100644 index 000000000000..229a108b1819 --- /dev/null +++ b/flambdatest/mlexamples/unboxing_need_poison.ml @@ -0,0 +1,17 @@ +type ('a, 'b) t = A of int * 'a | B of 'b + +let[@inline] f b y z g = + let v = + if b then + A (42, g y) + else + B (g z) + in + match v with + | A (_, a) -> a + | B c -> c + +let[@inline] g x = 12 + +let test b y z = + f b y z g From 90627dd427435d03ef86231094b7dce85882d5bb Mon Sep 17 00:00:00 2001 From: Pierre Chambart Date: Tue, 30 Mar 2021 01:31:39 +0200 Subject: [PATCH 3/6] fixup! Introduce poison constants --- .../flambda/compilenv_deps/reg_width_things.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/middle_end/flambda/compilenv_deps/reg_width_things.ml b/middle_end/flambda/compilenv_deps/reg_width_things.ml index e50ef82b1914..06045823d554 100644 --- a/middle_end/flambda/compilenv_deps/reg_width_things.ml +++ b/middle_end/flambda/compilenv_deps/reg_width_things.ml @@ -49,7 +49,7 @@ module Const_data = struct Target_imm.print i (Flambda_colours.normal ()) | Naked_immediate (Poison, i) -> - Format.fprintf ppf "@<0>%s#Poison %a@<0>%s" + Format.fprintf ppf "@<0>%s#Poison_%a@<0>%s" (Flambda_colours.naked_number ()) Target_imm.print i (Flambda_colours.normal ()) @@ -59,7 +59,7 @@ module Const_data = struct Target_imm.print i (Flambda_colours.normal ()) | Tagged_immediate (Poison, i) -> - Format.fprintf ppf "@<0>%sPoison %a@<0>%s" + Format.fprintf ppf "@<0>%sPoison_%a@<0>%s" (Flambda_colours.tagged_immediate ()) Target_imm.print i (Flambda_colours.normal ()) @@ -69,7 +69,7 @@ module Const_data = struct Numbers.Float_by_bit_pattern.print f (Flambda_colours.normal ()) | Naked_float (Poison, f) -> - Format.fprintf ppf "@<0>%s#Poison %a@<0>%s" + Format.fprintf ppf "@<0>%s#Poison_%a@<0>%s" (Flambda_colours.naked_number ()) Numbers.Float_by_bit_pattern.print f (Flambda_colours.normal ()) @@ -79,7 +79,7 @@ module Const_data = struct n (Flambda_colours.normal ()) | Naked_int32 (Poison, n) -> - Format.fprintf ppf "@<0>%s#Poison %ldl@<0>%s" + Format.fprintf ppf "@<0>%s#Poison_%ldl@<0>%s" (Flambda_colours.naked_number ()) n (Flambda_colours.normal ()) @@ -89,7 +89,7 @@ module Const_data = struct n (Flambda_colours.normal ()) | Naked_int64 (Poison, n) -> - Format.fprintf ppf "@<0>%s#Poison %LdL@<0>%s" + Format.fprintf ppf "@<0>%s#Poison_%LdL@<0>%s" (Flambda_colours.naked_number ()) n (Flambda_colours.normal ()) @@ -99,7 +99,7 @@ module Const_data = struct Targetint.print n (Flambda_colours.normal ()) | Naked_nativeint (Poison, n) -> - Format.fprintf ppf "@<0>%s#Poison %an@<0>%s" + Format.fprintf ppf "@<0>%s#Poison_%an@<0>%s" (Flambda_colours.naked_number ()) Targetint.print n (Flambda_colours.normal ()) From a1b95dd693a357c1b083ccf81f8e4ad289bda1e4 Mon Sep 17 00:00:00 2001 From: Pierre Chambart Date: Tue, 30 Mar 2021 01:31:58 +0200 Subject: [PATCH 4/6] fixup! Example of situation where two unboxing passes occur --- flambdatest/mlexamples/unboxing_need_poison.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/flambdatest/mlexamples/unboxing_need_poison.ml b/flambdatest/mlexamples/unboxing_need_poison.ml index 229a108b1819..89a11f762e8d 100644 --- a/flambdatest/mlexamples/unboxing_need_poison.ml +++ b/flambdatest/mlexamples/unboxing_need_poison.ml @@ -8,8 +8,8 @@ let[@inline] f b y z g = B (g z) in match v with - | A (_, a) -> a - | B c -> c + | A (_, a) -> a + 2 + | B c -> c + 2 let[@inline] g x = 12 From dec7312620001d9d64e7e759836e9e33dc1b986b Mon Sep 17 00:00:00 2001 From: Pierre Chambart Date: Tue, 30 Mar 2021 03:41:51 +0200 Subject: [PATCH 5/6] Poison in types --- compilerlibs/Makefile.compilerlibs | 1 + .../basic/or_unknown_or_bottom_or_poison.ml | 64 ++++++++++++++++ .../basic/or_unknown_or_bottom_or_poison.mli | 39 ++++++++++ middle_end/flambda/types/flambda_type.mli | 6 ++ .../types/template/flambda_type.templ.ml | 6 +- middle_end/flambda/types/type_descr.rec.ml | 75 ++++++++++++++----- middle_end/flambda/types/type_descr_intf.ml | 3 +- middle_end/flambda/types/type_grammar.rec.ml | 35 +++++++-- middle_end/flambda/types/type_grammar.rec.mli | 9 +++ .../unboxing/unbox_continuation_params.ml | 12 +-- 10 files changed, 215 insertions(+), 35 deletions(-) create mode 100644 middle_end/flambda/types/basic/or_unknown_or_bottom_or_poison.ml create mode 100644 middle_end/flambda/types/basic/or_unknown_or_bottom_or_poison.mli diff --git a/compilerlibs/Makefile.compilerlibs b/compilerlibs/Makefile.compilerlibs index a510f8034d33..8667119c08ad 100644 --- a/compilerlibs/Makefile.compilerlibs +++ b/compilerlibs/Makefile.compilerlibs @@ -262,6 +262,7 @@ MIDDLE_END_FLAMBDA_TYPES=\ middle_end/flambda/types/basic/or_bottom.cmo \ middle_end/flambda/types/basic/string_info.cmo \ middle_end/flambda/types/basic/or_unknown_or_bottom.cmo \ + middle_end/flambda/types/basic/or_unknown_or_bottom_or_poison.cmo \ middle_end/flambda/types/structures/code_age_relation.cmo \ middle_end/flambda/types/structures/type_structure_intf.cmo \ middle_end/flambda/types/structures/product_intf.cmo \ diff --git a/middle_end/flambda/types/basic/or_unknown_or_bottom_or_poison.ml b/middle_end/flambda/types/basic/or_unknown_or_bottom_or_poison.ml new file mode 100644 index 000000000000..e64622401efd --- /dev/null +++ b/middle_end/flambda/types/basic/or_unknown_or_bottom_or_poison.ml @@ -0,0 +1,64 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2018 OCamlPro SAS *) +(* Copyright 2018 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +type 'a t = + | Unknown + | Ok of 'a + | Poison + | Bottom + +let print f ppf t = + match t with + | Unknown -> Format.pp_print_string ppf "Unknown" + | Ok contents -> Format.fprintf ppf "@[(Ok %a)@]" f contents + | Poison -> Format.pp_print_string ppf "Poison" + | Bottom -> Format.pp_print_string ppf "Bottom" + +let equal eq_contents t1 t2 = + match t1, t2 with + | Unknown, Unknown -> true + | Ok contents1, Ok contents2 -> eq_contents contents1 contents2 + | Bottom, Bottom -> true + | Poison, Poison -> true + | (Unknown | Ok _ | Poison | Bottom), _ -> false + +let map t ~f = + match t with + | Unknown -> Unknown + | Bottom -> Bottom + | Poison -> Poison + | Ok contents -> Ok (f contents) + +let map_sharing t ~f = + match t with + | Unknown | Bottom | Poison -> t + | Ok contents -> + let contents' = f contents in + if contents == contents' then t + else Ok contents' + +let of_or_unknown (unk : _ Or_unknown.t) : _ t = + match unk with + | Known contents -> Ok contents + | Unknown -> Unknown + +let of_or_unknown_or_bottom (unk : _ Or_unknown_or_bottom.t) : _ t = + match unk with + | Ok contents -> Ok contents + | Unknown -> Unknown + | Bottom -> Bottom diff --git a/middle_end/flambda/types/basic/or_unknown_or_bottom_or_poison.mli b/middle_end/flambda/types/basic/or_unknown_or_bottom_or_poison.mli new file mode 100644 index 000000000000..f1239f14cec8 --- /dev/null +++ b/middle_end/flambda/types/basic/or_unknown_or_bottom_or_poison.mli @@ -0,0 +1,39 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2018 OCamlPro SAS *) +(* Copyright 2018 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +type 'a t = + | Unknown + | Ok of 'a + | Poison + | Bottom + +val print + : (Format.formatter -> 'a -> unit) + -> Format.formatter + -> 'a t + -> unit + +val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + +val map : 'a t -> f:('a -> 'b) -> 'b t + +val map_sharing : 'a t -> f:('a -> 'a) -> 'a t + +val of_or_unknown : 'a Or_unknown.t -> 'a t + +val of_or_unknown_or_bottom : 'a Or_unknown_or_bottom.t -> 'a t diff --git a/middle_end/flambda/types/flambda_type.mli b/middle_end/flambda/types/flambda_type.mli index f80706c0646a..6b7ad6ec69e9 100644 --- a/middle_end/flambda/types/flambda_type.mli +++ b/middle_end/flambda/types/flambda_type.mli @@ -291,6 +291,12 @@ val bottom : Flambda_kind.t -> t (** Construct a top ("unknown") type of the given kind. *) val unknown : Flambda_kind.t -> t +(** Construct a poison type of the given kind. + Poison behaves like bottom, but presence of a type poison + in an environment doesn't make the environment bottom. + expand_head on poison is bottom. *) +val poison : Flambda_kind.t -> t + val unknown_with_subkind : Flambda_kind.With_subkind.t -> t (** Create an bottom type with the same kind as the given type. *) diff --git a/middle_end/flambda/types/template/flambda_type.templ.ml b/middle_end/flambda/types/template/flambda_type.templ.ml index 9ad2fe06f9c2..6dd6565b4fcb 100644 --- a/middle_end/flambda/types/template/flambda_type.templ.ml +++ b/middle_end/flambda/types/template/flambda_type.templ.ml @@ -293,7 +293,8 @@ let prove_is_int env t : bool proof = Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t in match expand_head t env with - | Const (Tagged_immediate _) -> Proved true + | Const (Tagged_immediate (Value, _)) -> Proved true + | Const (Tagged_immediate (Poison, _)) -> Invalid | Const _ -> wrong_kind () | Value (Ok (Variant blocks_imms)) -> begin match blocks_imms.blocks, blocks_imms.immediates with @@ -323,7 +324,8 @@ let prove_tags_must_be_a_block env t : Tag.Set.t proof = Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t in match expand_head t env with - | Const (Tagged_immediate _) -> Unknown + | Const (Tagged_immediate (Value, _)) -> Unknown + | Const (Tagged_immediate (Poison, _)) -> Invalid | Const _ -> wrong_kind () | Value (Ok (Variant blocks_imms)) -> begin match blocks_imms.immediates with diff --git a/middle_end/flambda/types/type_descr.rec.ml b/middle_end/flambda/types/type_descr.rec.ml index 17bcab9ad5ff..c2b04866a108 100644 --- a/middle_end/flambda/types/type_descr.rec.ml +++ b/middle_end/flambda/types/type_descr.rec.ml @@ -30,7 +30,7 @@ module Make (Head : Type_head_intf.S = struct module Descr = struct type t = - | No_alias of Head.t Or_unknown_or_bottom.t + | No_alias of Head.t Or_unknown_or_bottom_or_poison.t | Equals of Simple.t let print_with_cache ~cache ppf t = @@ -48,6 +48,12 @@ module Make (Head : Type_head_intf.S colour (Flambda_colours.normal ()) else Format.fprintf ppf "@<0>%s_|_@<0>%s" colour (Flambda_colours.normal ()) + | No_alias Poison -> + if !Clflags.flambda_unicode then + Format.fprintf ppf "@<0>%s@<1>\u{2620}@<0>%s" + colour (Flambda_colours.normal ()) + else + Format.fprintf ppf "@<0>%sP@<0>%s" colour (Flambda_colours.normal ()) | No_alias (Ok head) -> Head.print_with_cache ~cache ppf head | Equals simple -> Format.fprintf ppf "@[(@<0>%s=@<0>%s %a)@]" @@ -62,7 +68,9 @@ module Make (Head : Type_head_intf.S if Renaming.is_empty renaming then t else match t with - | No_alias Bottom | No_alias Unknown -> t + | No_alias Bottom + | No_alias Unknown + | No_alias Poison -> t | No_alias (Ok head) -> let head' = Head.apply_renaming head renaming in if head == head' then t @@ -74,7 +82,9 @@ module Make (Head : Type_head_intf.S let free_names t = match t with - | No_alias Bottom | No_alias Unknown -> Name_occurrences.empty + | No_alias Bottom + | No_alias Unknown + | No_alias Poison -> Name_occurrences.empty | No_alias (Ok head) -> Head.free_names head | Equals simple -> Name_occurrences.downgrade_occurrences_at_strictly_greater_kind @@ -88,7 +98,9 @@ module Make (Head : Type_head_intf.S let all_ids_for_export t = match descr t with - | No_alias Bottom | No_alias Unknown -> Ids_for_export.empty + | No_alias Bottom + | No_alias Unknown + | No_alias Poison -> Ids_for_export.empty | No_alias (Ok head) -> Head.all_ids_for_export head | Equals simple -> Ids_for_export.from_simple simple @@ -98,12 +110,16 @@ module Make (Head : Type_head_intf.S let print ppf t = print_with_cache ~cache:(Printing_cache.create ()) ppf t - let create_no_alias head = create (No_alias head) + let create_no_alias head = + let head = Or_unknown_or_bottom_or_poison.of_or_unknown_or_bottom head in + create (No_alias head) let create_equals simple = create (Equals simple) + let poison = lazy (create (No_alias Poison)) let bottom = lazy (create (No_alias Bottom)) let unknown = lazy (create (No_alias Unknown)) + let poison () = Lazy.force poison let bottom () = Lazy.force bottom let unknown () = Lazy.force unknown @@ -112,13 +128,13 @@ module Make (Head : Type_head_intf.S let is_obviously_bottom t = match peek_descr t with | No_alias Bottom -> true - | No_alias (Ok _ | Unknown) + | No_alias (Ok _ | Unknown | Poison) | Equals _ -> false let is_obviously_unknown t = match peek_descr t with | No_alias Unknown -> true - | No_alias (Ok _ | Bottom) + | No_alias (Ok _ | Bottom | Poison) | Equals _ -> false let get_alias_exn t = @@ -137,20 +153,32 @@ module Make (Head : Type_head_intf.S | None -> Bottom | Some simple -> Ok (create_equals simple) end - | No_alias Unknown -> Ok t + | No_alias (Unknown | Poison) -> Ok t | No_alias Bottom -> Bottom | No_alias (Ok head) -> Or_bottom.map (Head.apply_rec_info head rec_info) ~f:(fun head -> create head) - let force_to_head ~force_to_kind t = + let force_to_head ~force_to_kind t : _ Or_unknown_or_bottom.t = match descr (force_to_kind t) with - | No_alias head -> head + | No_alias head -> begin + match head with + | Ok t -> Ok t + | Unknown -> Unknown + | Bottom -> Bottom + | Poison -> Bottom + end | Equals _ -> Misc.fatal_errorf "Expected [No_alias]:@ %a" T.print t let expand_head ~force_to_kind t env kind : _ Or_unknown_or_bottom.t = match descr t with - | No_alias head -> head + | No_alias head -> begin + match head with + | Ok t -> Ok t + | Unknown -> Unknown + | Bottom -> Bottom + | Poison -> Bottom + end | Equals simple -> let min_name_mode = Name_mode.min_in_types in match TE.get_canonical_simple_exn env simple ~min_name_mode with @@ -160,21 +188,28 @@ module Make (Head : Type_head_intf.S so [Unknown] is fine here. *) Unknown | simple -> - let [@inline always] const const = + let [@inline always] const const : _ Or_unknown_or_bottom.t = let typ = match Reg_width_const.descr const with - | Naked_immediate (_, i) -> T.this_naked_immediate_without_alias i - | Tagged_immediate (_, i) -> T.this_tagged_immediate_without_alias i - | Naked_float (_, f) -> T.this_naked_float_without_alias f - | Naked_int32 (_, i) -> T.this_naked_int32_without_alias i - | Naked_int64 (_, i) -> T.this_naked_int64_without_alias i - | Naked_nativeint (_, i) -> T.this_naked_nativeint_without_alias i + | Naked_immediate (Poison, _) -> T.poison_naked_immediate () + | Naked_immediate (Value, i) -> T.this_naked_immediate_without_alias i + | Tagged_immediate (Poison, _) -> T.poison_value () + | Tagged_immediate (Value, i) -> T.this_tagged_immediate_without_alias i + | Naked_float (Poison, _) -> T.poison_naked_float () + | Naked_float (Value, f) -> T.this_naked_float_without_alias f + | Naked_int32 (Poison, _) -> T.poison_naked_int32 () + | Naked_int32 (Value, i) -> T.this_naked_int32_without_alias i + | Naked_int64 (Poison, _) -> T.poison_naked_int64 () + | Naked_int64 (Value, i) -> T.this_naked_int64_without_alias i + | Naked_nativeint (Poison, _) -> T.poison_naked_nativeint () + | Naked_nativeint (Value, i) -> T.this_naked_nativeint_without_alias i in force_to_head ~force_to_kind typ in let [@inline always] name name : _ Or_unknown_or_bottom.t = let t = force_to_kind (TE.find env name (Some kind)) in match descr t with + | No_alias Poison -> Bottom | No_alias Bottom -> Bottom | No_alias Unknown -> Unknown | No_alias (Ok head) -> Ok head @@ -209,7 +244,7 @@ module Make (Head : Type_head_intf.S let eviscerate ~force_to_kind t env kind = match descr t with - | No_alias (Bottom | Unknown) -> t + | No_alias (Bottom | Unknown | Poison) -> t | No_alias (Ok head) -> begin match Head.eviscerate head with | Known head -> create_no_alias (Ok head) @@ -220,7 +255,7 @@ module Make (Head : Type_head_intf.S else let t = expand_head' ~force_to_kind t env kind in match descr t with - | No_alias (Bottom | Unknown) -> t + | No_alias (Bottom | Unknown | Poison) -> t | No_alias (Ok head) -> begin match Head.eviscerate head with | Known head -> create_no_alias (Ok head) diff --git a/middle_end/flambda/types/type_descr_intf.ml b/middle_end/flambda/types/type_descr_intf.ml index aae949412eb6..21c25c7bdf30 100644 --- a/middle_end/flambda/types/type_descr_intf.ml +++ b/middle_end/flambda/types/type_descr_intf.ml @@ -27,7 +27,7 @@ module type S = sig module Descr : sig type t = private - | No_alias of head Or_unknown_or_bottom.t + | No_alias of head Or_unknown_or_bottom_or_poison.t (** For each kind there is a lattice of types. Unknown = "Any value can flow to this point": the top element. Bottom = "No value can flow to this point": the least element. @@ -48,6 +48,7 @@ module type S = sig val unknown : unit -> t val bottom : unit -> t + val poison : unit -> t val descr : t -> Descr.t diff --git a/middle_end/flambda/types/type_grammar.rec.ml b/middle_end/flambda/types/type_grammar.rec.ml index c5d2fd10f728..dd617905299d 100644 --- a/middle_end/flambda/types/type_grammar.rec.ml +++ b/middle_end/flambda/types/type_grammar.rec.ml @@ -320,6 +320,23 @@ let unknown (kind : K.t) = let unknown_like t = unknown (kind t) +let poison_value () = Value (T_V.poison ()) +let poison_naked_immediate () = Naked_immediate (T_NI.poison ()) +let poison_naked_float () = Naked_float (T_Nf.poison ()) +let poison_naked_int32 () = Naked_int32 (T_N32.poison ()) +let poison_naked_int64 () = Naked_int64 (T_N64.poison ()) +let poison_naked_nativeint () = Naked_nativeint (T_NN.poison ()) + +let poison (kind : K.t) = + match kind with + | Value -> poison_value () + | Naked_number Naked_immediate -> poison_naked_immediate () + | Naked_number Naked_float -> poison_naked_float () + | Naked_number Naked_int32 -> poison_naked_int32 () + | Naked_number Naked_int64 -> poison_naked_int64 () + | Naked_number Naked_nativeint -> poison_naked_nativeint () + | Fabricated -> Misc.fatal_error "Only used in [Flambda_static] now" + let this_naked_immediate i : t = Naked_immediate (T_NI.create_equals (Simple.const ( Reg_width_const.naked_immediate i))) @@ -704,12 +721,18 @@ let array_of_length ~length = let type_for_const const = match Reg_width_const.descr const with - | Naked_immediate (_, i) -> this_naked_immediate i - | Tagged_immediate (_, i) -> this_tagged_immediate i - | Naked_float (_, f) -> this_naked_float f - | Naked_int32 (_, n) -> this_naked_int32 n - | Naked_int64 (_, n) -> this_naked_int64 n - | Naked_nativeint (_, n) -> this_naked_nativeint n + | Naked_immediate (Poison, _) -> poison_naked_immediate () + | Naked_immediate (Value, i) -> this_naked_immediate i + | Tagged_immediate (Poison, _) -> poison_value () + | Tagged_immediate (Value, i) -> this_tagged_immediate i + | Naked_float (Poison, _) -> poison_naked_float () + | Naked_float (Value, f) -> this_naked_float f + | Naked_int32 (Poison, _) -> poison_naked_int32 () + | Naked_int32 (Value, n) -> this_naked_int32 n + | Naked_int64 (Poison, _) -> poison_naked_int64 () + | Naked_int64 (Value, n) -> this_naked_int64 n + | Naked_nativeint (Poison, _) -> poison_naked_nativeint () + | Naked_nativeint (Value, n) -> this_naked_nativeint n let kind_for_const const = kind (type_for_const const) diff --git a/middle_end/flambda/types/type_grammar.rec.mli b/middle_end/flambda/types/type_grammar.rec.mli index bfe9db7c2e29..f271356a6748 100644 --- a/middle_end/flambda/types/type_grammar.rec.mli +++ b/middle_end/flambda/types/type_grammar.rec.mli @@ -54,6 +54,8 @@ val bottom_like : t -> t val unknown : Flambda_kind.t -> t val unknown_like : t -> t +val poison : Flambda_kind.t -> t + val any_value : unit -> t val any_tagged_immediate : unit -> t @@ -70,6 +72,13 @@ val any_naked_int32 : unit -> t val any_naked_int64 : unit -> t val any_naked_nativeint : unit -> t +val poison_value : unit -> t +val poison_naked_immediate : unit -> t +val poison_naked_float : unit -> t +val poison_naked_int32 : unit -> t +val poison_naked_int64 : unit -> t +val poison_naked_nativeint : unit -> t + val this_tagged_immediate : Target_imm.t -> t val this_boxed_float : Numbers.Float_by_bit_pattern.t -> t val this_boxed_int32 : Int32.t -> t diff --git a/middle_end/flambda/unboxing/unbox_continuation_params.ml b/middle_end/flambda/unboxing/unbox_continuation_params.ml index 56cc2981f3c7..96b65de3b4ba 100644 --- a/middle_end/flambda/unboxing/unbox_continuation_params.ml +++ b/middle_end/flambda/unboxing/unbox_continuation_params.ml @@ -598,7 +598,7 @@ struct | Is_int | Tag -> (* These arguments are filled in later via [project_field]. *) - Some Simple.untagged_const_zero + Some (Simple.const Reg_width_const.naked_immediate_poison) | Const_ctor -> begin match use_info with | Const_ctor -> @@ -609,7 +609,7 @@ struct | Block _ -> (* There are no constant constructors in the variant at the use site. We provide a dummy value. *) - Some Simple.untagged_const_zero + Some (Simple.const Reg_width_const.tagged_immediate_poison) end | Field { index; } -> begin match use_info with @@ -622,12 +622,12 @@ struct (* If the argument at the use is known to be a block, but it has fewer fields than the maximum number of fields for the variant, then we provide a dummy value. *) - Some Simple.const_zero + Some (Simple.const Reg_width_const.tagged_immediate_poison) end | Const_ctor -> (* There are no blocks in the variant at the use site. We again provide a dummy value. *) - Some Simple.const_zero + Some (Simple.const Reg_width_const.tagged_immediate_poison) end let make_boxed_value variant ~param_being_unboxed ~new_params ~fields = @@ -735,10 +735,10 @@ struct end | Field { index; } -> match use_info with - | Const_ctor -> Simple Simple.const_zero + | Const_ctor -> Simple (Simple.const Reg_width_const.tagged_immediate_poison) | Block { tag = _; size = size_at_use; } -> if Targetint.OCaml.compare index size_at_use >= 0 then - Simple Simple.const_zero + Simple (Simple.const Reg_width_const.tagged_immediate_poison) else Default_behaviour No_untagging end From 084c2360e1248acc0e779261012004d73f697aee Mon Sep 17 00:00:00 2001 From: Pierre Chambart Date: Wed, 31 Mar 2021 00:13:23 +0200 Subject: [PATCH 6/6] Change poison representation --- middle_end/flambda/basic/reg_width_const.ml | 33 ++- .../compilenv_deps/reg_width_things.ml | 241 +++++++++--------- .../compilenv_deps/reg_width_things.mli | 31 ++- middle_end/flambda/parser/flambda_to_fexpr.ml | 24 +- middle_end/flambda/simplify/simplify_named.ml | 7 +- .../flambda/simplify/simplify_static_const.ml | 8 +- .../flambda/simplify/simplify_switch_expr.ml | 3 +- middle_end/flambda/to_cmm/un_cps.ml | 21 +- middle_end/flambda/to_cmm/un_cps_static.ml | 26 +- .../types/template/flambda_type.templ.ml | 67 +++-- middle_end/flambda/types/type_descr.rec.ml | 24 +- middle_end/flambda/types/type_grammar.rec.ml | 24 +- .../unboxing/unbox_continuation_params.ml | 10 +- 13 files changed, 287 insertions(+), 232 deletions(-) diff --git a/middle_end/flambda/basic/reg_width_const.ml b/middle_end/flambda/basic/reg_width_const.ml index 3238ef7715bf..77ef407fb333 100644 --- a/middle_end/flambda/basic/reg_width_const.ml +++ b/middle_end/flambda/basic/reg_width_const.ml @@ -27,18 +27,27 @@ let kind t = | Naked_int32 _ -> K.naked_int32 | Naked_int64 _ -> K.naked_int64 | Naked_nativeint _ -> K.naked_nativeint + | Poison k -> begin + match k with + | Naked_immediate -> K.naked_immediate + | Value -> K.value + | Naked_float -> K.naked_float + | Naked_int32 -> K.naked_int32 + | Naked_int64 -> K.naked_int64 + | Naked_nativeint -> K.naked_nativeint + end let of_descr (descr : Descr.t) = match descr with - | Naked_immediate (Value, i) -> naked_immediate i - | Tagged_immediate (Value, i) -> tagged_immediate i - | Naked_float (Value, f) -> naked_float f - | Naked_int32 (Value, i) -> naked_int32 i - | Naked_int64 (Value, i) -> naked_int64 i - | Naked_nativeint (Value, i) -> naked_nativeint i - | Naked_immediate (Poison, _) -> naked_immediate_poison - | Tagged_immediate (Poison, _) -> tagged_immediate_poison - | Naked_float (Poison, _) -> naked_float_poison - | Naked_int32 (Poison, _) -> naked_int32_poison - | Naked_int64 (Poison, _) -> naked_int64_poison - | Naked_nativeint (Poison, _) -> naked_nativeint_poison + | Naked_immediate i -> naked_immediate i + | Tagged_immediate i -> tagged_immediate i + | Naked_float f -> naked_float f + | Naked_int32 i -> naked_int32 i + | Naked_int64 i -> naked_int64 i + | Naked_nativeint i -> naked_nativeint i + | Poison Naked_immediate -> naked_immediate_poison + | Poison Value -> value_poison + | Poison Naked_float -> naked_float_poison + | Poison Naked_int32 -> naked_int32_poison + | Poison Naked_int64 -> naked_int64_poison + | Poison Naked_nativeint -> naked_nativeint_poison diff --git a/middle_end/flambda/compilenv_deps/reg_width_things.ml b/middle_end/flambda/compilenv_deps/reg_width_things.ml index 06045823d554..df7ed7a99e72 100644 --- a/middle_end/flambda/compilenv_deps/reg_width_things.ml +++ b/middle_end/flambda/compilenv_deps/reg_width_things.ml @@ -26,15 +26,56 @@ let const_flags = 2 let simple_flags = 3 module Const_data = struct - type is_poison = Value | Poison - + module Kind = struct type t = - | Naked_immediate of is_poison * Target_imm.t - | Tagged_immediate of is_poison * Target_imm.t - | Naked_float of is_poison * Numbers.Float_by_bit_pattern.t - | Naked_int32 of is_poison * Int32.t - | Naked_int64 of is_poison * Int64.t - | Naked_nativeint of is_poison * Targetint.t + | Value + | Naked_immediate + | Naked_float + | Naked_int32 + | Naked_int64 + | Naked_nativeint + + let compare t1 t2 = + match t1, t2 with + | Value, Value -> 0 + | Value, _ -> 1 + | _, Value -> -1 + | Naked_immediate, Naked_immediate -> 0 + | Naked_immediate, _ -> 1 + | _, Naked_immediate -> -1 + | Naked_float, Naked_float -> 0 + | Naked_float, _ -> 1 + | _, Naked_float -> -1 + | Naked_int32, Naked_int32 -> 0 + | Naked_int32, _ -> 1 + | _, Naked_int32 -> -1 + | Naked_int64, Naked_int64 -> 0 + | Naked_int64, _ -> 1 + | _, Naked_int64 -> -1 + | Naked_nativeint, Naked_nativeint -> 0 + + let equal k1 k2 = + match k1, k2 with + | Value, Value + | Naked_immediate, Naked_immediate + | Naked_float, Naked_float + | Naked_int32, Naked_int32 + | Naked_int64, Naked_int64 + | Naked_nativeint, Naked_nativeint -> + true + | ( Value | Naked_immediate | Naked_float + | Naked_int32 | Naked_int64 | Naked_nativeint ), _ -> + false + end + + type t = + | Naked_immediate of Target_imm.t + | Tagged_immediate of Target_imm.t + | Naked_float of Numbers.Float_by_bit_pattern.t + | Naked_int32 of Int32.t + | Naked_int64 of Int64.t + | Naked_nativeint of Targetint.t + | Poison of Kind.t let flags = const_flags @@ -43,95 +84,73 @@ module Const_data = struct let print ppf (t : t) = match t with - | Naked_immediate (Value, i) -> + | Naked_immediate i -> Format.fprintf ppf "@<0>%s#%a@<0>%s" (Flambda_colours.naked_number ()) Target_imm.print i (Flambda_colours.normal ()) - | Naked_immediate (Poison, i) -> - Format.fprintf ppf "@<0>%s#Poison_%a@<0>%s" - (Flambda_colours.naked_number ()) - Target_imm.print i - (Flambda_colours.normal ()) - | Tagged_immediate (Value, i) -> + | Tagged_immediate i -> Format.fprintf ppf "@<0>%s%a@<0>%s" (Flambda_colours.tagged_immediate ()) Target_imm.print i (Flambda_colours.normal ()) - | Tagged_immediate (Poison, i) -> - Format.fprintf ppf "@<0>%sPoison_%a@<0>%s" - (Flambda_colours.tagged_immediate ()) - Target_imm.print i - (Flambda_colours.normal ()) - | Naked_float (Value, f) -> + | Naked_float f -> Format.fprintf ppf "@<0>%s#%a@<0>%s" (Flambda_colours.naked_number ()) Numbers.Float_by_bit_pattern.print f (Flambda_colours.normal ()) - | Naked_float (Poison, f) -> - Format.fprintf ppf "@<0>%s#Poison_%a@<0>%s" - (Flambda_colours.naked_number ()) - Numbers.Float_by_bit_pattern.print f - (Flambda_colours.normal ()) - | Naked_int32 (Value, n) -> + | Naked_int32 n -> Format.fprintf ppf "@<0>%s#%ldl@<0>%s" (Flambda_colours.naked_number ()) n (Flambda_colours.normal ()) - | Naked_int32 (Poison, n) -> - Format.fprintf ppf "@<0>%s#Poison_%ldl@<0>%s" - (Flambda_colours.naked_number ()) - n - (Flambda_colours.normal ()) - | Naked_int64 (Value, n) -> + | Naked_int64 n -> Format.fprintf ppf "@<0>%s#%LdL@<0>%s" (Flambda_colours.naked_number ()) n (Flambda_colours.normal ()) - | Naked_int64 (Poison, n) -> - Format.fprintf ppf "@<0>%s#Poison_%LdL@<0>%s" - (Flambda_colours.naked_number ()) - n - (Flambda_colours.normal ()) - | Naked_nativeint (Value, n) -> + | Naked_nativeint n -> Format.fprintf ppf "@<0>%s#%an@<0>%s" (Flambda_colours.naked_number ()) Targetint.print n (Flambda_colours.normal ()) - | Naked_nativeint (Poison, n) -> - Format.fprintf ppf "@<0>%s#Poison_%an@<0>%s" - (Flambda_colours.naked_number ()) - Targetint.print n + | Poison kind -> + let colour = + match kind with + | Value -> Flambda_colours.tagged_immediate + | Naked_immediate | Naked_float | Naked_int32 + | Naked_int64 | Naked_nativeint -> + Flambda_colours.naked_number + in + let poison = + if !Clflags.flambda_unicode then + "\u{2620}" + else + "Poison" + in + Format.fprintf ppf "@<0>%s%s@<0>%s" + (colour ()) + poison (Flambda_colours.normal ()) let output _ _ = Misc.fatal_error "[output] not yet implemented" let compare t1 t2 = match t1, t2 with - | Naked_immediate (Poison, _), Naked_immediate (Value, _) -> -1 - | Naked_immediate (Value, _), Naked_immediate (Poison, _) -> 1 - | Naked_immediate ((Poison | Value), i1), Naked_immediate ((Poison | Value), i2) -> + | Naked_immediate i1, Naked_immediate i2 -> Target_imm.compare i1 i2 - | Tagged_immediate (Poison, _), Tagged_immediate (Value, _) -> -1 - | Tagged_immediate (Value, _), Tagged_immediate (Poison, _) -> 1 - | Tagged_immediate ((Poison | Value), i1), Tagged_immediate ((Poison | Value), i2) -> + | Tagged_immediate i1, Tagged_immediate i2 -> Target_imm.compare i1 i2 - | Naked_float (Poison, _), Naked_float (Value, _) -> -1 - | Naked_float (Value, _), Naked_float (Poison, _) -> 1 - | Naked_float ((Poison | Value), f1), Naked_float ((Poison | Value), f2) -> + | Naked_float f1, Naked_float f2 -> Numbers.Float_by_bit_pattern.compare f1 f2 - | Naked_int32 (Poison, _), Naked_int32 (Value, _) -> -1 - | Naked_int32 (Value, _), Naked_int32 (Poison, _) -> 1 - | Naked_int32 ((Poison | Value), n1), Naked_int32 ((Poison | Value), n2) -> + | Naked_int32 n1, Naked_int32 n2 -> Int32.compare n1 n2 - | Naked_int64 (Poison, _), Naked_int64 (Value, _) -> -1 - | Naked_int64 (Value, _), Naked_int64 (Poison, _) -> 1 - | Naked_int64 ((Poison | Value), n1), Naked_int64 ((Poison | Value), n2) -> + | Naked_int64 n1, Naked_int64 n2 -> Int64.compare n1 n2 - | Naked_nativeint (Poison, _), Naked_nativeint (Value, _) -> -1 - | Naked_nativeint (Value, _), Naked_nativeint (Poison, _) -> 1 - | Naked_nativeint ((Poison | Value), n1), Naked_nativeint ((Poison | Value), n2) -> + | Naked_nativeint n1, Naked_nativeint n2 -> Targetint.compare n1 n2 + | Poison k1, Poison k2 -> + Kind.compare k1 k2 | Naked_immediate _, _ -> -1 | _, Naked_immediate _ -> 1 | Tagged_immediate _, _ -> -1 @@ -142,51 +161,40 @@ module Const_data = struct | _, Naked_int32 _ -> 1 | Naked_int64 _, _ -> -1 | _, Naked_int64 _ -> 1 - - let equal_poison (p1 : is_poison) (p2 : is_poison) = - match p1, p2 with - | Poison, Poison -> true - | Value, Value -> true - | Poison, Value - | Value, Poison -> false + | Naked_nativeint _, _ -> -1 + | _, Naked_nativeint _ -> 1 let equal t1 t2 = if t1 == t2 then true else match t1, t2 with - | Naked_immediate (p1, i1), Naked_immediate (p2, i2) -> - equal_poison p1 p2 && Target_imm.equal i1 i2 - | Tagged_immediate (p1, i1), Tagged_immediate (p2, i2) -> - equal_poison p1 p2 && Target_imm.equal i1 i2 - | Naked_float (p1, f1), Naked_float (p2, f2) -> - equal_poison p1 p2 && Numbers.Float_by_bit_pattern.equal f1 f2 - | Naked_int32 (p1, n1), Naked_int32 (p2, n2) -> - equal_poison p1 p2 && Int32.equal n1 n2 - | Naked_int64 (p1, n1), Naked_int64 (p2, n2) -> - equal_poison p1 p2 && Int64.equal n1 n2 - | Naked_nativeint (p1, n1), Naked_nativeint (p2, n2) -> - equal_poison p1 p2 && Targetint.equal n1 n2 + | Naked_immediate i1, Naked_immediate i2 -> + Target_imm.equal i1 i2 + | Tagged_immediate i1, Tagged_immediate i2 -> + Target_imm.equal i1 i2 + | Naked_float f1, Naked_float f2 -> + Numbers.Float_by_bit_pattern.equal f1 f2 + | Naked_int32 n1, Naked_int32 n2 -> + Int32.equal n1 n2 + | Naked_int64 n1, Naked_int64 n2 -> + Int64.equal n1 n2 + | Naked_nativeint n1, Naked_nativeint n2 -> + Targetint.equal n1 n2 + | Poison k1, Poison k2 -> + Kind.equal k1 k2 | (Naked_immediate _ | Tagged_immediate _ | Naked_float _ - | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _), _ -> false - - let hash_poison = function - | Value -> 0 - | Poison -> 1 + | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _ + | Poison _ ), _ -> false let hash t = match t with - | Naked_immediate (p, n) -> - Misc.hash2 (hash_poison p) (Target_imm.hash n) - | Tagged_immediate (p, n) -> - Misc.hash2 (hash_poison p) (Target_imm.hash n) - | Naked_float (p, n) -> - Misc.hash2 (hash_poison p) (Numbers.Float_by_bit_pattern.hash n) - | Naked_int32 (p, n) -> - Misc.hash2 (hash_poison p) (Hashtbl.hash n) - | Naked_int64 (p, n) -> - Misc.hash2 (hash_poison p) (Hashtbl.hash n) - | Naked_nativeint (p, n) -> - Misc.hash2 (hash_poison p) (Targetint.hash n) + | Naked_immediate n -> Target_imm.hash n + | Tagged_immediate n -> Target_imm.hash n + | Naked_float n -> Numbers.Float_by_bit_pattern.hash n + | Naked_int32 n -> Hashtbl.hash n + | Naked_int64 n -> Hashtbl.hash n + | Naked_nativeint n -> Targetint.hash n + | Poison k -> Hashtbl.hash k end) end @@ -326,12 +334,12 @@ module Const = struct let create (data : Const_data.t) = Table.add !grand_table_of_constants data - let naked_immediate imm = create (Naked_immediate (Value, imm)) - let tagged_immediate imm = create (Tagged_immediate (Value, imm)) - let naked_float f = create (Naked_float (Value, f)) - let naked_int32 i = create (Naked_int32 (Value, i)) - let naked_int64 i = create (Naked_int64 (Value, i)) - let naked_nativeint i = create (Naked_nativeint (Value, i)) + let naked_immediate imm = create (Naked_immediate imm) + let tagged_immediate imm = create (Tagged_immediate imm) + let naked_float f = create (Naked_float f) + let naked_int32 i = create (Naked_int32 i) + let naked_int64 i = create (Naked_int64 i) + let naked_nativeint i = create (Naked_nativeint i) let const_true = tagged_immediate Target_imm.bool_true let const_false = tagged_immediate Target_imm.bool_false @@ -349,30 +357,15 @@ module Const = struct let const_one = tagged_immediate Target_imm.one let const_unit = const_zero - let naked_immediate_poison = - create (Naked_immediate (Poison, Target_imm.zero)) - let tagged_immediate_poison = - create (Tagged_immediate (Poison, Target_imm.zero)) - let naked_float_poison = - create (Naked_float (Poison, Numbers.Float_by_bit_pattern.zero)) - let naked_int32_poison = - create (Naked_int32 (Poison, Int32.zero)) - let naked_int64_poison = - create (Naked_int64 (Poison, Int64.zero)) - let naked_nativeint_poison = - create (Naked_nativeint (Poison, Targetint.zero)) + let naked_immediate_poison = create (Poison Naked_immediate) + let value_poison = create (Poison Value) + let naked_float_poison = create (Poison Naked_float) + let naked_int32_poison = create (Poison Naked_int32) + let naked_int64_poison = create (Poison Naked_int64) + let naked_nativeint_poison = create (Poison Naked_nativeint) let descr t = find_data t - let is_poison t = - match find_data t with - | Naked_immediate (p, _) -> p - | Tagged_immediate (p, _) -> p - | Naked_float (p, _) -> p - | Naked_int32 (p, _) -> p - | Naked_int64 (p, _) -> p - | Naked_nativeint (p, _) -> p - module T0 = struct let compare = Id.compare let equal = Id.equal diff --git a/middle_end/flambda/compilenv_deps/reg_width_things.mli b/middle_end/flambda/compilenv_deps/reg_width_things.mli index ba04037bba62..d44899f5b85c 100644 --- a/middle_end/flambda/compilenv_deps/reg_width_things.mli +++ b/middle_end/flambda/compilenv_deps/reg_width_things.mli @@ -53,30 +53,37 @@ module Const : sig val naked_nativeint : Targetint.t -> t val naked_immediate_poison : t - val tagged_immediate_poison : t + val value_poison : t val naked_float_poison : t val naked_int32_poison : t val naked_int64_poison : t val naked_nativeint_poison : t module Descr : sig - type is_poison = private Value | Poison - - type t = private - | Naked_immediate of is_poison * Target_imm.t - | Tagged_immediate of is_poison * Target_imm.t - | Naked_float of is_poison * Numbers.Float_by_bit_pattern.t - | Naked_int32 of is_poison * Int32.t - | Naked_int64 of is_poison * Int64.t - | Naked_nativeint of is_poison * Targetint.t + module Kind : sig + type t = private + | Value + | Naked_immediate + | Naked_float + | Naked_int32 + | Naked_int64 + | Naked_nativeint + end + + type t = private + | Naked_immediate of Target_imm.t + | Tagged_immediate of Target_imm.t + | Naked_float of Numbers.Float_by_bit_pattern.t + | Naked_int32 of Int32.t + | Naked_int64 of Int64.t + | Naked_nativeint of Targetint.t + | Poison of Kind.t include Identifiable.S with type t := t end val descr : t -> Descr.t - val is_poison : t -> Descr.is_poison - val export : t -> exported val import : exported -> t diff --git a/middle_end/flambda/parser/flambda_to_fexpr.ml b/middle_end/flambda/parser/flambda_to_fexpr.ml index fa626d7858da..66bced2c5aa1 100644 --- a/middle_end/flambda/parser/flambda_to_fexpr.ml +++ b/middle_end/flambda/parser/flambda_to_fexpr.ml @@ -260,24 +260,24 @@ let name env n = let const c : Fexpr.const = match Reg_width_things.Const.descr c with - | Naked_immediate (Value, imm) -> + | Naked_immediate imm -> Naked_immediate (imm |> Target_imm.to_targetint' |> Targetint.to_string) - | Tagged_immediate (Value, imm) -> + | Tagged_immediate imm -> Tagged_immediate (imm |> Target_imm.to_targetint' |> Targetint.to_string) - | Naked_float (Value, f) -> + | Naked_float f -> Naked_float (f |> Numbers.Float_by_bit_pattern.to_float) - | Naked_int32 (Value, i) -> + | Naked_int32 i -> Naked_int32 i - | Naked_int64 (Value, i) -> + | Naked_int64 i -> Naked_int64 i - | Naked_nativeint (Value, i) -> + | Naked_nativeint i -> Naked_nativeint (i |> Targetint.to_int64) - | Naked_immediate (Poison, _) - | Tagged_immediate (Poison, _) - | Naked_float (Poison, _) - | Naked_int32 (Poison, _) - | Naked_int64 (Poison, _) - | Naked_nativeint (Poison, _) -> + | Poison Naked_immediate + | Poison Value + | Poison Naked_float + | Poison Naked_int32 + | Poison Naked_int64 + | Poison Naked_nativeint -> Misc.fatal_errorf "TODO: Poison constants" let simple env s = diff --git a/middle_end/flambda/simplify/simplify_named.ml b/middle_end/flambda/simplify/simplify_named.ml index 9fc181d2cf84..83cea75f1573 100644 --- a/middle_end/flambda/simplify/simplify_named.ml +++ b/middle_end/flambda/simplify/simplify_named.ml @@ -71,7 +71,8 @@ let record_any_symbol_projection dacc (defining_expr : Simplified_named.t) Simple.pattern_match index ~const:(fun const -> match Reg_width_const.descr const with - | Tagged_immediate (_, imm) -> + | Poison Value -> None + | Tagged_immediate imm -> Simple.pattern_match' block ~const:(fun _ -> None) ~symbol:(fun symbol_projected_from -> @@ -80,7 +81,9 @@ let record_any_symbol_projection dacc (defining_expr : Simplified_named.t) (SP.Projection.block_load ~index))) ~var:(fun _ -> None) | Naked_immediate _ | Naked_float _ - | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _ -> + | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _ + | Poison ( Naked_immediate | Naked_float | Naked_int32 + | Naked_int64 | Naked_nativeint )-> Misc.fatal_errorf "Kind error for [Block_load] index:@ \ %a@ =@ %a" Bindable_let_bound.print bindable_let_bound diff --git a/middle_end/flambda/simplify/simplify_static_const.ml b/middle_end/flambda/simplify/simplify_static_const.ml index 8045a9cb3ba1..6f1513764b37 100644 --- a/middle_end/flambda/simplify/simplify_static_const.ml +++ b/middle_end/flambda/simplify/simplify_static_const.ml @@ -41,12 +41,14 @@ let simplify_field_of_block dacc (field : Field_of_block.t) = ~symbol:(fun sym -> Field_of_block.Symbol sym, ty)) ~const:(fun const -> match Reg_width_const.descr const with - | Tagged_immediate (Value, imm) -> Field_of_block.Tagged_immediate imm, ty - | Tagged_immediate (Poison, _) -> + | Tagged_immediate imm -> Field_of_block.Tagged_immediate imm, ty + | Poison Value -> (* CR pchambart: This should be "invalid" and propagate up *) field, T.bottom K.value | Naked_immediate _ | Naked_float _ | Naked_int32 _ - | Naked_int64 _ | Naked_nativeint _ -> + | Naked_int64 _ | Naked_nativeint _ + | Poison ( Naked_immediate | Naked_float | Naked_int32 + | Naked_int64 | Naked_nativeint ) -> (* CR mshinwell: This should be "invalid" and propagate up *) field, ty) diff --git a/middle_end/flambda/simplify/simplify_switch_expr.ml b/middle_end/flambda/simplify/simplify_switch_expr.ml index 67bb7f672cd8..9bb7e4f96ed3 100644 --- a/middle_end/flambda/simplify/simplify_switch_expr.ml +++ b/middle_end/flambda/simplify/simplify_switch_expr.ml @@ -82,7 +82,7 @@ let rebuild_switch ~simplify_let dacc ~arms ~scrutinee ~scrutinee_ty uacc *) let [@inline always] const arg = match Reg_width_const.descr arg with - | Tagged_immediate (_, arg) -> + | Tagged_immediate arg -> if Target_imm.equal arm arg then let identity_arms = Target_imm.Map.add arm action identity_arms @@ -99,6 +99,7 @@ let rebuild_switch ~simplify_let dacc ~arms ~scrutinee ~scrutinee_ty uacc normal_case ~identity_arms ~not_arms else normal_case ~identity_arms ~not_arms + | Poison _ | Naked_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _ -> normal_case ~identity_arms ~not_arms diff --git a/middle_end/flambda/to_cmm/un_cps.ml b/middle_end/flambda/to_cmm/un_cps.ml index 7a38078e39dd..117fd4d68a02 100644 --- a/middle_end/flambda/to_cmm/un_cps.ml +++ b/middle_end/flambda/to_cmm/un_cps.ml @@ -75,15 +75,24 @@ let targetint_of_imm i = Targetint.OCaml.to_targetint i.Target_imm.value let const _env cst = match Reg_width_const.descr cst with - | Naked_immediate (_, i) -> + | Naked_immediate i -> C.targetint (targetint_of_imm i) - | Tagged_immediate (_, i) -> + | Poison Naked_immediate -> + C.targetint (targetint_of_imm Target_imm.zero) + | Tagged_immediate i -> C.targetint (tag_targetint (targetint_of_imm i)) - | Naked_float (_, f) -> + | Poison Value -> + C.targetint (tag_targetint (targetint_of_imm Target_imm.zero)) + | Naked_float f -> C.float (Numbers.Float_by_bit_pattern.to_float f) - | Naked_int32 (_, i) -> C.int32 i - | Naked_int64 (_, i) -> C.int64 i - | Naked_nativeint (_, t) -> C.targetint t + | Poison Naked_float -> + C.float 0. + | Naked_int32 i -> C.int32 i + | Poison Naked_int32 -> C.int32 0l + | Naked_int64 i -> C.int64 i + | Poison Naked_int64 -> C.int64 0L + | Naked_nativeint t -> C.targetint t + | Poison Naked_nativeint -> C.targetint Targetint.zero let default_of_kind (k : Flambda_kind.t) = match k with diff --git a/middle_end/flambda/to_cmm/un_cps_static.ml b/middle_end/flambda/to_cmm/un_cps_static.ml index b427b92ee3f2..531b70e4de32 100644 --- a/middle_end/flambda/to_cmm/un_cps_static.ml +++ b/middle_end/flambda/to_cmm/un_cps_static.ml @@ -55,19 +55,33 @@ let name_static env name = let const_static _env cst = match Reg_width_const.descr cst with - | Naked_immediate (_, i) -> + | Naked_immediate i -> [C.cint (nativeint_of_targetint (targetint_of_imm i))] - | Tagged_immediate (_, i) -> + | Poison Naked_immediate -> + (* CR pchambart: Should we use something more noticeable than 0 ? *) + [C.cint 0n] + | Tagged_immediate i -> [C.cint (nativeint_of_targetint (tag_targetint (targetint_of_imm i)))] - | Naked_float (_, f) -> + | Poison Value -> + [C.cint 1n] + | Naked_float f -> [C.cfloat (Numbers.Float_by_bit_pattern.to_float f)] - | Naked_int32 (_, i) -> + | Poison Naked_float -> + [C.cfloat 0.] + | Naked_int32 i -> [C.cint (Nativeint.of_int32 i)] - | Naked_int64 (_, i) -> + | Poison Naked_int32 -> + [C.cint 0n] + | Naked_int64 i -> if C.arch32 then todo() (* split int64 on 32-bit archs *) else [C.cint (Int64.to_nativeint i)] - | Naked_nativeint (_, t) -> + | Poison Naked_int64 -> + if C.arch32 then todo() (* split int64 on 32-bit archs *) + else [C.cint 0n] + | Naked_nativeint t -> [C.cint (nativeint_of_targetint t)] + | Poison Naked_nativeint -> + [C.cint 0n] let simple_static env s = Simple.pattern_match s diff --git a/middle_end/flambda/types/template/flambda_type.templ.ml b/middle_end/flambda/types/template/flambda_type.templ.ml index 6dd6565b4fcb..b508e5ec3ac8 100644 --- a/middle_end/flambda/types/template/flambda_type.templ.ml +++ b/middle_end/flambda/types/template/flambda_type.templ.ml @@ -132,7 +132,7 @@ let prove_equals_to_var_or_symbol_or_tagged_immediate env t Simple.pattern_match simple ~const:(fun cst : _ proof -> match Reg_width_const.descr cst with - | Tagged_immediate (_, imm) -> Proved (Tagged_immediate imm) + | Tagged_immediate imm -> Proved (Tagged_immediate imm) | _ -> Misc.fatal_errorf "[Simple] %a in the [Equals] field has a kind \ different from that returned by [kind] (%a):@ %a" @@ -152,7 +152,7 @@ let prove_equals_to_var_or_symbol_or_tagged_immediate env t Simple.pattern_match simple ~const:(fun cst : _ proof -> match Reg_width_const.descr cst with - | Tagged_immediate (_, imm) -> Proved (Tagged_immediate imm) + | Tagged_immediate imm -> Proved (Tagged_immediate imm) | _ -> let kind = kind t in Misc.fatal_errorf "Kind returned by [get_canonical_simple] (%a) \ @@ -213,10 +213,12 @@ let prove_naked_floats env t : _ proof = Misc.fatal_errorf "Kind error: expected [Naked_float]:@ %a" print t in match expand_head t env with - | Const (Naked_float (Value, f)) -> Proved (Float.Set.singleton f) - | Const (Naked_float (Poison, _)) -> Invalid + | Const (Naked_float f) -> Proved (Float.Set.singleton f) + | Const (Poison Naked_float) -> Invalid | Const (Naked_immediate _ | Tagged_immediate _ | Naked_int32 _ - | Naked_int64 _ | Naked_nativeint _) -> wrong_kind () + | Naked_int64 _ | Naked_nativeint _ + | Poison (Value | Naked_immediate | Naked_int32 + | Naked_int64 | Naked_nativeint)) -> wrong_kind () | Naked_float (Ok fs) -> if Float.Set.is_empty fs then Invalid else Proved fs @@ -233,10 +235,12 @@ let prove_naked_int32s env t : _ proof = Misc.fatal_errorf "Kind error: expected [Naked_int32]:@ %a" print t in match expand_head t env with - | Const (Naked_int32 (Value, i)) -> Proved (Int32.Set.singleton i) - | Const (Naked_int32 (Poison, _)) -> Invalid + | Const (Naked_int32 i) -> Proved (Int32.Set.singleton i) + | Const (Poison Naked_int32) -> Invalid | Const (Naked_immediate _ | Tagged_immediate _ | Naked_float _ - | Naked_int64 _ | Naked_nativeint _) -> wrong_kind () + | Naked_int64 _ | Naked_nativeint _ + | Poison (Value | Naked_immediate | Naked_float + | Naked_int64 | Naked_nativeint)) -> wrong_kind () | Naked_int32 (Ok is) -> if Int32.Set.is_empty is then Invalid else Proved is @@ -253,10 +257,12 @@ let prove_naked_int64s env t : _ proof = Misc.fatal_errorf "Kind error: expected [Naked_int64]:@ %a" print t in match expand_head t env with - | Const (Naked_int64 (Value, i)) -> Proved (Int64.Set.singleton i) - | Const (Naked_int64 (Poison, _)) -> Invalid + | Const (Naked_int64 i) -> Proved (Int64.Set.singleton i) + | Const (Poison Naked_int64) -> Invalid | Const (Naked_immediate _ | Tagged_immediate _ | Naked_float _ - | Naked_int32 _ | Naked_nativeint _) -> wrong_kind () + | Naked_int32 _ | Naked_nativeint _ + | Poison (Value | Naked_immediate | Naked_float + | Naked_int32 | Naked_nativeint)) -> wrong_kind () | Naked_int64 (Ok is) -> if Int64.Set.is_empty is then Invalid else Proved is @@ -273,10 +279,12 @@ let prove_naked_nativeints env t : _ proof = Misc.fatal_errorf "Kind error: expected [Naked_nativeint]:@ %a" print t in match expand_head t env with - | Const (Naked_nativeint (Value, i)) -> Proved (Targetint.Set.singleton i) - | Const (Naked_nativeint (Poison, _)) -> Invalid + | Const (Naked_nativeint i) -> Proved (Targetint.Set.singleton i) + | Const (Poison Naked_nativeint) -> Invalid | Const (Naked_immediate _ | Tagged_immediate _ | Naked_float _ - | Naked_int32 _ | Naked_int64 _) -> wrong_kind () + | Naked_int32 _ | Naked_int64 _ + | Poison (Value | Naked_immediate | Naked_float + | Naked_int32 | Naked_int64)) -> wrong_kind () | Naked_nativeint (Ok is) -> if Targetint.Set.is_empty is then Invalid else Proved is @@ -293,8 +301,8 @@ let prove_is_int env t : bool proof = Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t in match expand_head t env with - | Const (Tagged_immediate (Value, _)) -> Proved true - | Const (Tagged_immediate (Poison, _)) -> Invalid + | Const (Tagged_immediate _) -> Proved true + | Const (Poison Value) -> Invalid | Const _ -> wrong_kind () | Value (Ok (Variant blocks_imms)) -> begin match blocks_imms.blocks, blocks_imms.immediates with @@ -324,8 +332,8 @@ let prove_tags_must_be_a_block env t : Tag.Set.t proof = Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t in match expand_head t env with - | Const (Tagged_immediate (Value, _)) -> Unknown - | Const (Tagged_immediate (Poison, _)) -> Invalid + | Const (Tagged_immediate _) -> Unknown + | Const (Poison Value) -> Invalid | Const _ -> wrong_kind () | Value (Ok (Variant blocks_imms)) -> begin match blocks_imms.immediates with @@ -379,10 +387,12 @@ let prove_naked_immediates env t : Target_imm.Set.t proof = Misc.fatal_errorf "Kind error: expected [Naked_immediate]:@ %a" print t in match expand_head t env with - | Const (Naked_immediate (Value, i)) -> Proved (Target_imm.Set.singleton i) - | Const (Naked_immediate (Poison, _)) -> Invalid + | Const (Naked_immediate i) -> Proved (Target_imm.Set.singleton i) + | Const (Poison Naked_immediate) -> Invalid | Const (Tagged_immediate _ | Naked_float _ | Naked_int32 _ - | Naked_int64 _ | Naked_nativeint _) -> wrong_kind () + | Naked_int64 _ | Naked_nativeint _ + | Poison (Value | Naked_float | Naked_int32 + | Naked_int64 | Naked_nativeint)) -> wrong_kind () | Naked_immediate (Ok (Naked_immediates is)) -> (* CR mshinwell: As noted elsewhere, add abstraction to avoid the need for these checks *) @@ -424,10 +434,12 @@ let prove_equals_tagged_immediates env t : Target_imm.Set.t proof = Misc.fatal_errorf "Kind error: expected [Value]:@ %a" print t in match expand_head t env with - | Const (Tagged_immediate (Value, imm)) -> Proved (Target_imm.Set.singleton imm) - | Const (Tagged_immediate (Poison, _)) -> Invalid - | Const (Naked_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _ - | Naked_nativeint _) -> wrong_kind () + | Const (Tagged_immediate imm) -> Proved (Target_imm.Set.singleton imm) + | Const (Poison Value) -> Invalid + | Const (Naked_immediate _ | Naked_float _ | Naked_int32 _ + | Naked_int64 _ | Naked_nativeint _ + | Poison (Naked_immediate | Naked_float | Naked_int32 + | Naked_int64 | Naked_nativeint)) -> wrong_kind () | Value (Ok (Variant blocks_imms)) -> begin match blocks_imms.blocks, blocks_imms.immediates with | Unknown, Unknown | Unknown, Known _ | Known _, Unknown -> Unknown @@ -571,6 +583,7 @@ let prove_variant env t : variant_proof proof_allowing_kind_mismatch = let prove_is_a_tagged_immediate env t : _ proof_allowing_kind_mismatch = match expand_head t env with | Const (Tagged_immediate _) -> Proved () + | Const (Poison Value) -> Invalid | Const _ -> Wrong_kind | Value Unknown -> Unknown | Value (Ok (Variant { blocks; immediates; is_unique = _; })) -> @@ -586,6 +599,7 @@ let prove_is_a_tagged_immediate env t : _ proof_allowing_kind_mismatch = let prove_is_a_boxed_float env t : _ proof_allowing_kind_mismatch = match expand_head t env with + | Const (Poison Value) -> Invalid | Const _ -> Wrong_kind | Value Unknown -> Unknown | Value (Ok (Boxed_float _)) -> Proved () @@ -594,6 +608,7 @@ let prove_is_a_boxed_float env t : _ proof_allowing_kind_mismatch = let prove_is_a_boxed_int32 env t : _ proof_allowing_kind_mismatch = match expand_head t env with + | Const (Poison Value) -> Invalid | Const _ -> Wrong_kind | Value Unknown -> Unknown | Value (Ok (Boxed_int32 _)) -> Proved () @@ -602,6 +617,7 @@ let prove_is_a_boxed_int32 env t : _ proof_allowing_kind_mismatch = let prove_is_a_boxed_int64 env t : _ proof_allowing_kind_mismatch = match expand_head t env with + | Const (Poison Value) -> Invalid | Const _ -> Wrong_kind | Value Unknown -> Unknown | Value (Ok (Boxed_int64 _)) -> Proved () @@ -610,6 +626,7 @@ let prove_is_a_boxed_int64 env t : _ proof_allowing_kind_mismatch = let prove_is_a_boxed_nativeint env t : _ proof_allowing_kind_mismatch = match expand_head t env with + | Const (Poison Value) -> Invalid | Const _ -> Wrong_kind | Value Unknown -> Unknown | Value (Ok (Boxed_nativeint _)) -> Proved () diff --git a/middle_end/flambda/types/type_descr.rec.ml b/middle_end/flambda/types/type_descr.rec.ml index c2b04866a108..3b206e4527ba 100644 --- a/middle_end/flambda/types/type_descr.rec.ml +++ b/middle_end/flambda/types/type_descr.rec.ml @@ -191,18 +191,18 @@ module Make (Head : Type_head_intf.S let [@inline always] const const : _ Or_unknown_or_bottom.t = let typ = match Reg_width_const.descr const with - | Naked_immediate (Poison, _) -> T.poison_naked_immediate () - | Naked_immediate (Value, i) -> T.this_naked_immediate_without_alias i - | Tagged_immediate (Poison, _) -> T.poison_value () - | Tagged_immediate (Value, i) -> T.this_tagged_immediate_without_alias i - | Naked_float (Poison, _) -> T.poison_naked_float () - | Naked_float (Value, f) -> T.this_naked_float_without_alias f - | Naked_int32 (Poison, _) -> T.poison_naked_int32 () - | Naked_int32 (Value, i) -> T.this_naked_int32_without_alias i - | Naked_int64 (Poison, _) -> T.poison_naked_int64 () - | Naked_int64 (Value, i) -> T.this_naked_int64_without_alias i - | Naked_nativeint (Poison, _) -> T.poison_naked_nativeint () - | Naked_nativeint (Value, i) -> T.this_naked_nativeint_without_alias i + | Naked_immediate i -> T.this_naked_immediate_without_alias i + | Tagged_immediate i -> T.this_tagged_immediate_without_alias i + | Naked_float f -> T.this_naked_float_without_alias f + | Naked_int32 i -> T.this_naked_int32_without_alias i + | Naked_int64 i -> T.this_naked_int64_without_alias i + | Naked_nativeint i -> T.this_naked_nativeint_without_alias i + | Poison Naked_immediate -> T.poison_naked_immediate () + | Poison Value -> T.poison_value () + | Poison Naked_float -> T.poison_naked_float () + | Poison Naked_int32 -> T.poison_naked_int32 () + | Poison Naked_int64 -> T.poison_naked_int64 () + | Poison Naked_nativeint -> T.poison_naked_nativeint () in force_to_head ~force_to_kind typ in diff --git a/middle_end/flambda/types/type_grammar.rec.ml b/middle_end/flambda/types/type_grammar.rec.ml index dd617905299d..37ffe9dafbd5 100644 --- a/middle_end/flambda/types/type_grammar.rec.ml +++ b/middle_end/flambda/types/type_grammar.rec.ml @@ -721,18 +721,18 @@ let array_of_length ~length = let type_for_const const = match Reg_width_const.descr const with - | Naked_immediate (Poison, _) -> poison_naked_immediate () - | Naked_immediate (Value, i) -> this_naked_immediate i - | Tagged_immediate (Poison, _) -> poison_value () - | Tagged_immediate (Value, i) -> this_tagged_immediate i - | Naked_float (Poison, _) -> poison_naked_float () - | Naked_float (Value, f) -> this_naked_float f - | Naked_int32 (Poison, _) -> poison_naked_int32 () - | Naked_int32 (Value, n) -> this_naked_int32 n - | Naked_int64 (Poison, _) -> poison_naked_int64 () - | Naked_int64 (Value, n) -> this_naked_int64 n - | Naked_nativeint (Poison, _) -> poison_naked_nativeint () - | Naked_nativeint (Value, n) -> this_naked_nativeint n + | Naked_immediate i -> this_naked_immediate i + | Tagged_immediate i -> this_tagged_immediate i + | Naked_float f -> this_naked_float f + | Naked_int32 n -> this_naked_int32 n + | Naked_int64 n -> this_naked_int64 n + | Naked_nativeint n -> this_naked_nativeint n + | Poison Naked_immediate -> poison_naked_immediate () + | Poison Value -> poison_value () + | Poison Naked_float -> poison_naked_float () + | Poison Naked_int32 -> poison_naked_int32 () + | Poison Naked_int64 -> poison_naked_int64 () + | Poison Naked_nativeint -> poison_naked_nativeint () let kind_for_const const = kind (type_for_const const) diff --git a/middle_end/flambda/unboxing/unbox_continuation_params.ml b/middle_end/flambda/unboxing/unbox_continuation_params.ml index 96b65de3b4ba..a39c278474df 100644 --- a/middle_end/flambda/unboxing/unbox_continuation_params.ml +++ b/middle_end/flambda/unboxing/unbox_continuation_params.ml @@ -609,7 +609,7 @@ struct | Block _ -> (* There are no constant constructors in the variant at the use site. We provide a dummy value. *) - Some (Simple.const Reg_width_const.tagged_immediate_poison) + Some (Simple.const Reg_width_const.value_poison) end | Field { index; } -> begin match use_info with @@ -622,12 +622,12 @@ struct (* If the argument at the use is known to be a block, but it has fewer fields than the maximum number of fields for the variant, then we provide a dummy value. *) - Some (Simple.const Reg_width_const.tagged_immediate_poison) + Some (Simple.const Reg_width_const.value_poison) end | Const_ctor -> (* There are no blocks in the variant at the use site. We again provide a dummy value. *) - Some (Simple.const Reg_width_const.tagged_immediate_poison) + Some (Simple.const Reg_width_const.value_poison) end let make_boxed_value variant ~param_being_unboxed ~new_params ~fields = @@ -735,10 +735,10 @@ struct end | Field { index; } -> match use_info with - | Const_ctor -> Simple (Simple.const Reg_width_const.tagged_immediate_poison) + | Const_ctor -> Simple (Simple.const Reg_width_const.value_poison) | Block { tag = _; size = size_at_use; } -> if Targetint.OCaml.compare index size_at_use >= 0 then - Simple (Simple.const Reg_width_const.tagged_immediate_poison) + Simple (Simple.const Reg_width_const.value_poison) else Default_behaviour No_untagging end