Differentiate is_int primitive between generic and variant-only versions

middle_end/convert_primitives.ml

@@ -85,7 +85,7 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
   | Parraysetu kind -> Parraysetu kind
   | Parrayrefs kind -> Parrayrefs kind
   | Parraysets kind -> Parraysets kind
-  | Pisint -> Pisint
+  | Pisint _ -> Pisint
   | Pisout -> Pisout
   | Pcvtbint (src, dest, m) -> Pcvtbint (src, dest, m)
   | Pnegbint (bi,m) -> Pnegbint (bi,m)

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -636,7 +636,7 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args
       | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pfloatcomp _ | Pstringlength
       | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu
       | Pbytesrefs | Pbytessets | Pduparray _ | Parraylength _ | Parrayrefu _
-      | Parraysetu _ | Parrayrefs _ | Parraysets _ | Pisint | Pisout
+      | Parraysetu _ | Parrayrefs _ | Parraysets _ | Pisint _ | Pisout
       | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _
       | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _
       | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -783,10 +783,10 @@ let primitive_can_raise (prim : Lambda.primitive) =
   | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _
   | Pdivfloat _ | Pfloatcomp _ | Pstringlength | Pstringrefu | Pbyteslength
   | Pbytesrefu | Pbytessetu | Pmakearray _ | Pduparray _ | Parraylength _
-  | Parrayrefu _ | Parraysetu _ | Pisint | Pisout | Pbintofint _ | Pintofbint _
-  | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _
-  | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _
-  | Pasrbint _ | Pbintcomp _ | Pbigarraydim _
+  | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisout | Pbintofint _
+  | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _
+  | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _
+  | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp _ | Pbigarraydim _
   | Pbigarrayref (true, _, _, _)
   | Pbigarrayset (true, _, _, _)
   | Pstring_load_16 true
@@ -1764,7 +1764,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg
             in
             CC.close_let acc ccenv is_scrutinee_int Not_user_visible
               (Prim
-                 { prim = Pisint;
+                 { prim = Pisint { variant_only = true };
                    args = [Var scrutinee];
                    loc = Loc_unknown;
                    exn_continuation = None

middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml

@@ -795,7 +795,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list)
   | Pbytes_set_64 false (* safe *), [bytes; index; new_value] ->
     bytes_like_set_safe ~dbg ~size_int ~access_size:Sixty_four Bytes bytes index
       new_value
-  | Pisint, [arg] -> tag_int (Unary (Is_int, arg))
+  | Pisint { variant_only }, [arg] ->
+    tag_int (Unary (Is_int { variant_only }, arg))
   | Pisout, [arg1; arg2] ->
     tag_int
       (Binary
@@ -1087,7 +1088,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list)
       | Pnegfloat _ | Pabsfloat _ | Pstringlength | Pbyteslength | Pbintofint _
       | Pintofbint _ | Pnegbint _ | Popaque | Pduprecord _ | Parraylength _
       | Pduparray _ | Pfloatfield _ | Pcvtbint _ | Poffsetref _ | Pbswap16
-      | Pbbswap _ | Pisint | Pint_as_pointer | Pbigarraydim _ ),
+      | Pbbswap _ | Pisint _ | Pint_as_pointer | Pbigarraydim _ ),
       ([] | _ :: _ :: _) ) ->
     Misc.fatal_errorf
       "Closure_conversion.convert_primitive: Wrong arity for unary primitive \

middle_end/flambda2/parser/fexpr_to_flambda.ml

@@ -309,7 +309,7 @@ let unop env (unop : Fexpr.unop) : Flambda_primitive.unary_primitive =
   | Tag_immediate -> Tag_immediate
   | Untag_immediate -> Untag_immediate
   | Get_tag -> Get_tag
-  | Is_int -> Is_int
+  | Is_int -> Is_int { variant_only = true } (* CR vlaviron: discuss *)
   | Num_conv { src; dst } -> Num_conv { src; dst }
   | Opaque_identity -> Opaque_identity
   | Project_value_slot { project_from; value_slot } ->

middle_end/flambda2/parser/flambda_to_fexpr.ml

@@ -432,7 +432,7 @@ let unop env (op : Flambda_primitive.unary_primitive) : Fexpr.unop =
   | Box_number (bk, _alloc_mode) -> Box_number bk
   | Tag_immediate -> Tag_immediate
   | Get_tag -> Get_tag
-  | Is_int -> Is_int
+  | Is_int _ -> Is_int (* CR vlaviron: discuss *)
   | Num_conv { src; dst } -> Num_conv { src; dst }
   | Opaque_identity -> Opaque_identity
   | Unbox_number bk -> Unbox_number bk

middle_end/flambda2/simplify/common_subexpression_elimination.ml

@@ -240,7 +240,7 @@ let join_one_cse_equation ~cse_at_each_use prim bound_to_map
            the join of the types will usually give us the relevant equation
            anyway. *)
         match[@ocaml.warning "-fragile-match"] EP.to_primitive prim with
-        | Unary (Is_int, scrutinee) ->
+        | Unary (Is_int { variant_only = true }, scrutinee) ->
           Name.Map.add (Name.var var)
             (T.is_int_for_scrutinee ~scrutinee)
             extra_equations

middle_end/flambda2/simplify/simplify_unary_primitive.ml

@@ -180,10 +180,21 @@ let simplify_is_int_or_get_tag dacc ~original_term ~scrutinee ~scrutinee_ty:_
   let dacc = DA.add_variable dacc result_var (make_shape scrutinee) in
   SPR.create original_term ~try_reify:true dacc
 
-let simplify_is_int dacc ~original_term ~arg:scrutinee ~arg_ty:scrutinee_ty
-    ~result_var =
-  simplify_is_int_or_get_tag dacc ~original_term ~scrutinee ~scrutinee_ty
-    ~result_var ~make_shape:(fun scrutinee -> T.is_int_for_scrutinee ~scrutinee)
+let simplify_is_int ~variant_only dacc ~original_term ~arg:scrutinee
+    ~arg_ty:scrutinee_ty ~result_var =
+  if variant_only
+  then
+    simplify_is_int_or_get_tag dacc ~original_term ~scrutinee ~scrutinee_ty
+      ~result_var ~make_shape:(fun scrutinee ->
+        T.is_int_for_scrutinee ~scrutinee)
+  else
+    match T.prove_is_int (DA.typing_env dacc) scrutinee_ty with
+    | Proved b ->
+      let ty = T.this_naked_immediate (Targetint_31_63.bool b) in
+      let dacc = DA.add_variable dacc result_var ty in
+      SPR.create original_term ~try_reify:false dacc
+    | Unknown ->
+      SPR.create_unknown dacc ~result_var K.naked_immediate ~original_term
 
 let simplify_get_tag dacc ~original_term ~arg:scrutinee ~arg_ty:scrutinee_ty
     ~result_var =
@@ -218,9 +229,7 @@ let simplify_string_length dacc ~original_term ~arg:_ ~arg_ty:str_ty ~result_var
       let dacc = DA.add_variable dacc result_var ty in
       SPR.create original_term ~try_reify:true dacc
   | Need_meet ->
-    let ty = T.unknown K.naked_immediate in
-    let dacc = DA.add_variable dacc result_var ty in
-    SPR.create original_term ~try_reify:false dacc
+    SPR.create_unknown dacc ~result_var K.naked_immediate ~original_term
   | Invalid -> SPR.create_invalid dacc
 
 module Unary_int_arith (I : A.Int_number_kind) = struct
@@ -239,12 +248,10 @@ module Unary_int_arith (I : A.Int_number_kind) = struct
       let dacc = DA.add_variable dacc result_var ty in
       SPR.create original_term ~try_reify:true dacc
     | Need_meet ->
-      let dacc =
-        DA.add_variable dacc result_var
-          (T.unknown
-             (K.Standard_int_or_float.to_kind I.standard_int_or_float_kind))
+      let result_kind =
+        K.Standard_int_or_float.to_kind I.standard_int_or_float_kind
       in
-      SPR.create original_term ~try_reify:false dacc
+      SPR.create_unknown dacc ~result_var result_kind ~original_term
     | Invalid -> SPR.create_invalid dacc
 end
 
@@ -343,9 +350,8 @@ module Make_simplify_int_conv (N : A.Number_kind) = struct
           end) in
           M.result)
       | Need_meet ->
-        let ty = T.unknown (K.Standard_int_or_float.to_kind dst) in
-        let dacc = DA.add_variable dacc result_var ty in
-        SPR.create original_term ~try_reify:false dacc
+        let result_kind = K.Standard_int_or_float.to_kind dst in
+        SPR.create_unknown dacc ~result_var result_kind ~original_term
       | Invalid -> SPR.create_invalid dacc
 end
 
@@ -424,9 +430,7 @@ let simplify_float_arith_op (op : P.unary_float_arith_op) dacc ~original_term
     let dacc = DA.add_variable dacc result_var ty in
     SPR.create original_term ~try_reify:true dacc
   | Known_result _ | Need_meet ->
-    let ty = T.unknown K.naked_float in
-    let dacc = DA.add_variable dacc result_var ty in
-    SPR.create original_term ~try_reify:false dacc
+    SPR.create_unknown dacc ~result_var K.naked_float ~original_term
   | Invalid -> SPR.create_invalid dacc
 
 let simplify_is_boxed_float dacc ~original_term ~arg:_ ~arg_ty ~result_var =
@@ -438,9 +442,7 @@ let simplify_is_boxed_float dacc ~original_term ~arg:_ ~arg_ty ~result_var =
     let dacc = DA.add_variable dacc result_var ty in
     SPR.create original_term ~try_reify:true dacc
   | Unknown ->
-    let ty = T.unknown K.naked_immediate in
-    let dacc = DA.add_variable dacc result_var ty in
-    SPR.create original_term ~try_reify:false dacc
+    SPR.create_unknown dacc ~result_var K.naked_immediate ~original_term
 
 let simplify_is_flat_float_array dacc ~original_term ~arg:_ ~arg_ty ~result_var
     =
@@ -458,25 +460,19 @@ let simplify_is_flat_float_array dacc ~original_term ~arg:_ ~arg_ty ~result_var
   | Invalid -> SPR.create_invalid dacc
 
 let simplify_opaque_identity dacc ~original_term ~arg:_ ~arg_ty:_ ~result_var =
-  let ty = T.unknown K.value in
-  let dacc = DA.add_variable dacc result_var ty in
-  SPR.create original_term ~try_reify:false dacc
+  SPR.create_unknown dacc ~result_var K.value ~original_term
 
 let simplify_end_region dacc ~original_term ~arg:_ ~arg_ty:_ ~result_var =
   let ty = T.this_tagged_immediate Targetint_31_63.zero in
   let dacc = DA.add_variable dacc result_var ty in
   SPR.create original_term ~try_reify:false dacc
 
 let simplify_int_as_pointer dacc ~original_term ~arg:_ ~arg_ty:_ ~result_var =
-  let ty = T.unknown K.value in
-  let dacc = DA.add_variable dacc result_var ty in
-  SPR.create original_term ~try_reify:false dacc
+  SPR.create_unknown dacc ~result_var K.value ~original_term
 
 let simplify_bigarray_length ~dimension:_ dacc ~original_term ~arg:_ ~arg_ty:_
     ~result_var =
-  let ty = T.unknown K.naked_immediate in
-  let dacc = DA.add_variable dacc result_var ty in
-  SPR.create original_term ~try_reify:false dacc
+  SPR.create_unknown dacc ~result_var K.naked_immediate ~original_term
 
 let simplify_duplicate_array ~kind:_ ~(source_mutability : Mutability.t)
     ~(destination_mutability : Mutability.t) dacc ~original_term ~arg:_ ~arg_ty
@@ -523,7 +519,7 @@ let simplify_unary_primitive dacc original_prim (prim : P.unary_primitive) ~arg
       simplify_box_number boxable_number_kind alloc_mode
     | Tag_immediate -> simplify_tag_immediate
     | Untag_immediate -> simplify_untag_immediate
-    | Is_int -> simplify_is_int
+    | Is_int { variant_only } -> simplify_is_int ~variant_only
     | Get_tag -> simplify_get_tag
     | Array_length -> simplify_array_length
     | String_length _ -> simplify_string_length

middle_end/flambda2/simplify/unboxing/build_unboxing_denv.ml

@@ -89,7 +89,7 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t =
         (T.get_tag_for_block ~block:(Simple.var param_var))
     in
     let get_tag_prim =
-      P.Eligible_for_cse.create_exn (Unary (Get_tag, Simple.var param_var))
+      P.Eligible_for_cse.create_get_tag ~block:(Name.var param_var)
     in
     let denv = DE.add_cse denv get_tag_prim ~bound_to:(Simple.var tag.param) in
     (* Same thing for is_int *)
@@ -104,7 +104,8 @@ let rec denv_of_decision denv ~param_var (decision : U.decision) : DE.t =
             (T.is_int_for_scrutinee ~scrutinee:(Simple.var param_var))
         in
         let is_int_prim =
-          P.Eligible_for_cse.create_exn (Unary (Is_int, Simple.var param_var))
+          P.Eligible_for_cse.create_is_int ~variant_only:true
+            ~immediate_or_block:(Name.var param_var)
         in
         let denv =
           DE.add_cse denv is_int_prim ~bound_to:(Simple.var is_int.param)

middle_end/flambda2/terms/code_size.ml

@@ -311,7 +311,7 @@ let nullary_prim_size prim =
 let unary_prim_size prim =
   match (prim : Flambda_primitive.unary_primitive) with
   | Duplicate_array _ | Duplicate_block _ -> alloc_extcall_size + 1
-  | Is_int -> 1
+  | Is_int _ -> 1
   | Get_tag -> 2
   | Array_length -> array_length_size
   | Bigarray_length _ -> 2 (* cadda + load *)

middle_end/flambda2/terms/flambda_primitive.ml

@@ -604,7 +604,7 @@ type unary_primitive =
         source_mutability : Mutability.t;
         destination_mutability : Mutability.t
       }
-  | Is_int
+  | Is_int of { variant_only : bool }
   | Get_tag
   | Array_length
   | Bigarray_length of { dimension : int }
@@ -641,7 +641,7 @@ let unary_primitive_eligible_for_cse p ~arg =
   match p with
   | Duplicate_array _ -> false
   | Duplicate_block { kind = _ } -> false
-  | Is_int | Get_tag -> true
+  | Is_int _ | Get_tag -> true
   | Array_length -> true
   | Bigarray_length _ -> false
   | String_length _ -> true
@@ -671,7 +671,7 @@ let compare_unary_primitive p1 p2 =
     match p with
     | Duplicate_array _ -> 0
     | Duplicate_block _ -> 1
-    | Is_int -> 2
+    | Is_int _ -> 2
     | Get_tag -> 3
     | Array_length -> 4
     | Bigarray_length _ -> 5
@@ -714,7 +714,9 @@ let compare_unary_primitive p1 p2 =
       else Stdlib.compare destination_mutability1 destination_mutability2
   | Duplicate_block { kind = kind1 }, Duplicate_block { kind = kind2 } ->
     Duplicate_block_kind.compare kind1 kind2
-  | Is_int, Is_int -> 0
+  | ( Is_int { variant_only = variant_only1 },
+      Is_int { variant_only = variant_only2 } ) ->
+    Bool.compare variant_only1 variant_only2
   | Get_tag, Get_tag -> 0
   | String_length kind1, String_length kind2 -> Stdlib.compare kind1 kind2
   | Int_arith (kind1, op1), Int_arith (kind2, op2) ->
@@ -745,7 +747,7 @@ let compare_unary_primitive p1 p2 =
         { project_from = function_slot2; value_slot = value_slot2 } ) ->
     let c = Function_slot.compare function_slot1 function_slot2 in
     if c <> 0 then c else Value_slot.compare value_slot1 value_slot2
-  | ( ( Duplicate_array _ | Duplicate_block _ | Is_int | Get_tag
+  | ( ( Duplicate_array _ | Duplicate_block _ | Is_int _ | Get_tag
       | String_length _ | Int_as_pointer | Opaque_identity | Int_arith _
       | Num_conv _ | Boolean_not | Reinterpret_int64_as_float | Float_arith _
       | Array_length | Bigarray_length _ | Unbox_number _ | Box_number _
@@ -767,7 +769,8 @@ let print_unary_primitive ppf p =
     fprintf ppf "@[<hov 1>(Duplicate_array %a (source %a) (dest %a))@]"
       Duplicate_array_kind.print kind Mutability.print source_mutability
       Mutability.print destination_mutability
-  | Is_int -> fprintf ppf "Is_int"
+  | Is_int { variant_only } ->
+    if variant_only then fprintf ppf "Is_int" else fprintf ppf "Is_int_generic"
   | Get_tag -> fprintf ppf "Get_tag"
   | String_length _ -> fprintf ppf "String_length"
   | Int_as_pointer -> fprintf ppf "Int_as_pointer"
@@ -806,7 +809,7 @@ let print_unary_primitive ppf p =
 let arg_kind_of_unary_primitive p =
   match p with
   | Duplicate_array _ | Duplicate_block _ -> K.value
-  | Is_int -> K.value
+  | Is_int _ -> K.value
   | Get_tag -> K.value
   | String_length _ -> K.value
   | Int_as_pointer -> K.value
@@ -828,7 +831,7 @@ let arg_kind_of_unary_primitive p =
 let result_kind_of_unary_primitive p : result_kind =
   match p with
   | Duplicate_array _ | Duplicate_block _ -> Singleton K.value
-  | Is_int | Get_tag -> Singleton K.naked_immediate
+  | Is_int _ | Get_tag -> Singleton K.naked_immediate
   | String_length _ -> Singleton K.naked_immediate
   | Int_as_pointer ->
     (* This primitive is *only* to be used when the resulting pointer points at
@@ -875,7 +878,7 @@ let effects_and_coeffects_of_unary_primitive p =
     (* We have to assume that the fields might be mutable. (This information
        isn't currently propagated from [Lambda].) *)
     Effects.Only_generative_effects Mutable, Coeffects.Has_coeffects
-  | Is_int -> Effects.No_effects, Coeffects.No_coeffects
+  | Is_int _ -> Effects.No_effects, Coeffects.No_coeffects
   | Get_tag ->
     (* [Obj.truncate] has now been removed. *)
     Effects.No_effects, Coeffects.No_coeffects
@@ -931,7 +934,7 @@ let unary_classify_for_printing p =
   match p with
   | Duplicate_array _ | Duplicate_block _ -> Constructive
   | String_length _ | Get_tag -> Destructive
-  | Is_int | Int_as_pointer | Opaque_identity | Int_arith _ | Num_conv _
+  | Is_int _ | Int_as_pointer | Opaque_identity | Int_arith _ | Num_conv _
   | Boolean_not | Reinterpret_int64_as_float | Float_arith _ ->
     Neither
   | Array_length | Bigarray_length _ | Unbox_number _ | Untag_immediate ->
@@ -1658,8 +1661,8 @@ module Eligible_for_cse = struct
     | Some t -> t
     | None -> Misc.fatal_errorf "Primitive %a not eligible for CSE" print prim
 
-  let create_is_int ~immediate_or_block =
-    Unary (Is_int, Simple.name immediate_or_block)
+  let create_is_int ~variant_only ~immediate_or_block =
+    Unary (Is_int { variant_only }, Simple.name immediate_or_block)
 
   let create_get_tag ~block = Unary (Get_tag, Simple.name block)
 

middle_end/flambda2/terms/flambda_primitive.mli

@@ -226,7 +226,7 @@ type unary_primitive =
         source_mutability : Mutability.t;
         destination_mutability : Mutability.t
       }
-  | Is_int
+  | Is_int of { variant_only : bool }
   | Get_tag
   | Array_length
   | Bigarray_length of { dimension : int }
@@ -449,7 +449,7 @@ module Eligible_for_cse : sig
 
   val create_exn : primitive_application -> t
 
-  val create_is_int : immediate_or_block:Name.t -> t
+  val create_is_int : variant_only:bool -> immediate_or_block:Name.t -> t
 
   val create_get_tag : block:Name.t -> t
 

middle_end/flambda2/to_cmm/to_cmm_primitive.ml

@@ -519,7 +519,7 @@ let unary_primitive env res dbg f arg =
       res,
       C.extcall ~dbg ~alloc:true ~returns:true ~is_c_builtin:false ~ty_args:[]
         "caml_obj_dup" Cmm.typ_val [arg] )
-  | Is_int -> None, res, C.and_int arg (C.int ~dbg 1) dbg
+  | Is_int _ -> None, res, C.and_int arg (C.int ~dbg 1) dbg
   | Get_tag -> None, res, C.get_tag arg dbg
   | Array_length -> None, res, array_length ~dbg arg
   | Bigarray_length { dimension } ->

middle_end/flambda2/types/grammar/type_grammar.mli

@@ -66,8 +66,8 @@ and head_of_kind_value = private
 
 and head_of_kind_naked_immediate = private
   | Naked_immediates of Targetint_31_63.Set.t
-  | Is_int of t
-  | Get_tag of t
+  | Is_int of t  (** For variants only *)
+  | Get_tag of t  (** For variants only *)
 
 (** Invariant: the float/integer sets for naked float, int32, int64 and
     nativeint heads are non-empty. (Empty sets are represented as an overall

middle_end/flambda2/types/provers.ml

@@ -76,6 +76,8 @@ let prove_equals_to_simple_of_kind_value env t : Simple.t proof_of_property =
       | exception Not_found -> Unknown
       | simple -> Proved simple)
 
+(* Note: this function is used for simplifying Obj.is_int, so should not assume
+   that the argument represents a variant *)
 let prove_is_int_generic env t : bool generic_proof =
   match expand_head env t with
   | Value (Ok (Variant blocks_imms)) -> (