Pisnull

lthls · Nov 12, 2024 · 199c9f9 · 199c9f9
1 parent 164d116
commit 199c9f9
Show file tree

Hide file tree

Showing 16 changed files with 53 additions and 31 deletions.
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
@@ -169,7 +169,7 @@ let preserve_tailcall_for_prim = function
   | Pcompare_ints | Pcompare_floats _ | Pcompare_bints _
   | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
   | Pmakearray _ | Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _
-  | Parrayrefs _ | Parraysets _ | Pisint _ | Pisout | Pbintofint _ | Pintofbint _
+  | Parrayrefs _ | Parraysets _ | Pisint _ | Pisnull | Pisout | Pbintofint _ | Pintofbint _
   | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _
   | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _
   | Pasrbint _ | Pbintcomp _ | Punboxed_int_comp _
@@ -561,6 +561,7 @@ let comp_primitive stack_info p sz args =
        | Runtime5 -> "runtime5" in
      Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1)
   | Pisint _ -> Kisint
+  | Pisnull -> Misc.fatal_error "null not implemented in bytecode" (* CR layouts v3: support null in bytecode *)
   | Pisout -> Kisout
   | Pbintofint (bi,_) -> comp_bint_primitive bi "of_int" args
   | Pintofbint bi -> comp_bint_primitive bi "to_int" args

diff --git a/lambda/lambda.ml b/lambda/lambda.ml
@@ -197,6 +197,8 @@ type primitive =
   | Parraysets of array_set_kind * array_index_kind
   (* Test if the argument is a block or an immediate integer *)
   | Pisint of { variant_only : bool }
+  (* Test if the argument is a null pointer *)
+  | Pisnull
   (* Test if the (integer) argument is outside an interval *)
   | Pisout
   (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
@@ -1777,7 +1779,7 @@ let primitive_may_allocate : primitive -> locality_mode option = function
       | Punboxedvectorarray_ref _), _, _) -> None
   | Parrayrefu ((Pgenarray_ref m | Pfloatarray_ref m), _, _)
   | Parrayrefs ((Pgenarray_ref m | Pfloatarray_ref m), _, _) -> Some m
-  | Pisint _ | Pisout -> None
+  | Pisint _ | Pisnull | Pisout -> None
   | Pintofbint _ -> None
   | Pbintofint (_,m)
   | Pcvtbint (_,_,m)
@@ -1993,7 +1995,7 @@ let primitive_result_layout (p : primitive) =
   | Pfloatcomp (_, _) | Punboxed_float_comp (_, _)
   | Pstringlength | Pstringrefu | Pstringrefs
   | Pbyteslength | Pbytesrefu | Pbytesrefs
-  | Parraylength _ | Pisint _ | Pisout | Pintofbint _
+  | Parraylength _ | Pisint _ | Pisnull | Pisout | Pintofbint _
   | Pbintcomp _ | Punboxed_int_comp _
   | Pstring_load_16 _ | Pbytes_load_16 _ | Pbigstring_load_16 _
   | Pprobe_is_enabled _ | Pbswap16

diff --git a/lambda/lambda.mli b/lambda/lambda.mli
@@ -189,6 +189,8 @@ type primitive =
   | Parraysets of array_set_kind * array_index_kind
   (* Test if the argument is a block or an immediate integer *)
   | Pisint of { variant_only : bool }
+  (* Test if the argument is a null pointer *)
+  | Pisnull
   (* Test if the (integer) argument is outside an interval *)
   | Pisout
   (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)

diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml
@@ -659,6 +659,7 @@ let primitive ppf = function
      fprintf ppf "sys.constant_%s" const_name
   | Pisint { variant_only } ->
       fprintf ppf (if variant_only then "isint" else "obj_is_int")
+  | Pisnull -> fprintf ppf "isnull"
   | Pisout -> fprintf ppf "isout"
   | Pbintofint (bi,m) -> print_boxed_integer "of_int" ppf bi m
   | Pintofbint bi -> print_boxed_integer "to_int" ppf bi alloc_heap
@@ -952,6 +953,7 @@ let name_of_primitive = function
   | Parraysets _ -> "Parraysets"
   | Pctconst _ -> "Pctconst"
   | Pisint _ -> "Pisint"
+  | Pisnull -> "Pisnull"
   | Pisout -> "Pisout"
   | Pbintofint _ -> "Pbintofint"
   | Pintofbint _ -> "Pintofbint"

diff --git a/lambda/tmc.ml b/lambda/tmc.ml
@@ -891,7 +891,7 @@ let rec choice ctx t =
     | Pstringlength | Pstringrefu  | Pstringrefs
     | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
     | Parraylength _ | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _
-    | Pisint _ | Pisout
+    | Pisint _ | Pisnull | Pisout
     | Pignore
     | Pcompare_ints | Pcompare_floats _ | Pcompare_bints _
     | Preinterpret_tagged_int63_as_unboxed_int64

diff --git a/lambda/translprim.ml b/lambda/translprim.ml
@@ -523,6 +523,7 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p =
     | "%floatarray_unsafe_set" ->
       Primitive ((Parraysetu (Pfloatarray_set, Ptagged_int_index)), 3)
     | "%obj_is_int" -> Primitive (Pisint { variant_only = false }, 1)
+    | "%is_null" -> Primitive (Pisnull, 1)
     | "%lazy_force" -> Lazy_force pos
     | "%nativeint_of_int" -> Primitive ((Pbintofint (Pnativeint, mode)), 1)
     | "%nativeint_to_int" -> Primitive ((Pintofbint Pnativeint), 1)
@@ -1648,7 +1649,7 @@ let lambda_primitive_needs_event_after = function
   | Pbytessetu
   | Pmakearray ((Pintarray | Paddrarray | Pfloatarray | Punboxedfloatarray _
       | Punboxedintarray _ | Punboxedvectorarray _), _, _)
-  | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisout
+  | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisnull | Pisout
   | Pprobe_is_enabled _
   | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _
   | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer _ | Popaque _

diff --git a/lambda/value_rec_compiler.ml b/lambda/value_rec_compiler.ml
@@ -305,6 +305,7 @@ let compute_static_size lam =
     | Parrayrefu _
     | Parrayrefs _
     | Pisint _
+    | Pisnull
     | Pisout
     | Pbintofint _
     | Pintofbint _

diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml
@@ -943,7 +943,7 @@ let close_primitive acc env ~let_bound_ids_with_kinds named
       | Punboxed_float_comp (_, _)
       | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu
       | Pbytessetu | Pbytesrefs | Pbytessets | Pduparray _ | Parraylength _
-      | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ | Pisint _
+      | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ | Pisint _ | Pisnull
       | Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _
       | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _
       | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _

diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml
@@ -708,8 +708,8 @@ let primitive_can_raise (prim : Lambda.primitive) =
   | Punboxed_float_comp (_, _)
   | Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu | Pbytessetu
   | Pmakearray _ | Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _
-  | Pisint _ | Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _
-  | Paddbint _ | Psubbint _ | Pmulbint _
+  | Pisint _ | Pisnull | Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _
+  | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _
   | Pdivbint { is_safe = Unsafe; _ }
   | Pmodbint { is_safe = Unsafe; _ }
   | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _

diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml
@@ -1509,6 +1509,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
         Bytes ~boxed bytes ~index_kind index new_value ]
   | Pisint { variant_only }, [[arg]] ->
     [tag_int (Unary (Is_int { variant_only }, arg))]
+  | Pisnull, [[arg]] -> [tag_int (Unary (Is_null, arg))]
   | Pisout, [[arg1]; [arg2]] ->
     [ tag_int
         (Binary
@@ -2075,7 +2076,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
       | Pabsfloat (_, _)
       | Pstringlength | Pbyteslength | Pbintofint _ | Pintofbint _ | Pnegbint _
       | Popaque _ | Pduprecord _ | Parraylength _ | Pduparray _ | Pfloatfield _
-      | Pcvtbint _ | Poffsetref _ | Pbswap16 | Pbbswap _ | Pisint _
+      | Pcvtbint _ | Poffsetref _ | Pbswap16 | Pbbswap _ | Pisint _ | Pisnull
       | Pint_as_pointer _ | Pbigarraydim _ | Pobj_dup | Pobj_magic _
       | Punbox_float _
       | Pbox_float (_, _)

diff --git a/middle_end/flambda2/parser/flambda_to_fexpr.ml b/middle_end/flambda2/parser/flambda_to_fexpr.ml
@@ -567,6 +567,7 @@ let unop env (op : Flambda_primitive.unary_primitive) : Fexpr.unop =
   | Int_arith (i, o) -> Int_arith (i, o)
   | Is_flat_float_array -> Is_flat_float_array
   | Is_int _ -> Is_int (* CR vlaviron: discuss *)
+  | Is_null -> Misc.fatal_error "null not implemented in fexpr"
   | Num_conv { src; dst } -> Num_conv { src; dst }
   | Opaque_identity _ -> Opaque_identity
   | Unbox_number bk -> Unbox_number bk

diff --git a/middle_end/flambda2/simplify/simplify_unary_primitive.ml b/middle_end/flambda2/simplify/simplify_unary_primitive.ml
@@ -888,6 +888,10 @@ let simplify_mutable_block_load _access_kind ~field:_ ~original_prim dacc
       (P.result_kind' original_prim)
       ~original_term
 
+(* CR layouts v3: implement a real simplifier. *)
+let simplify_is_null dacc ~original_term ~arg:_ ~arg_ty:_ ~result_var =
+  SPR.create_unknown dacc ~result_var K.naked_immediate ~original_term
+
 let simplify_unary_primitive dacc original_prim (prim : P.unary_primitive) ~arg
     ~arg_ty dbg ~result_var =
   let min_name_mode = Bound_var.name_mode result_var in
@@ -909,6 +913,7 @@ let simplify_unary_primitive dacc original_prim (prim : P.unary_primitive) ~arg
     | Tag_immediate -> simplify_tag_immediate
     | Untag_immediate -> simplify_untag_immediate
     | Is_int { variant_only } -> simplify_is_int ~variant_only
+    | Is_null -> simplify_is_null
     | Get_tag -> simplify_get_tag
     | Array_length array_kind -> simplify_array_length array_kind
     | String_length _ -> simplify_string_length

diff --git a/middle_end/flambda2/terms/code_size.ml b/middle_end/flambda2/terms/code_size.ml
@@ -343,7 +343,7 @@ let unary_prim_size prim =
   match (prim : Flambda_primitive.unary_primitive) with
   | Block_load { kind; _ } -> block_load kind
   | Duplicate_array _ | Duplicate_block _ -> needs_caml_c_call_extcall_size + 1
-  | Is_int _ -> 1
+  | Is_int _ | Is_null -> 1
   | Get_tag -> 2
   | Array_length array_kind -> (
     match array_kind with

diff --git a/middle_end/flambda2/terms/flambda_primitive.ml b/middle_end/flambda2/terms/flambda_primitive.ml
@@ -1031,6 +1031,7 @@ type unary_primitive =
         destination_mutability : Mutability.t
       }
   | Is_int of { variant_only : bool }
+  | Is_null
   | Get_tag
   | Array_length of Array_kind_for_length.t
   | Bigarray_length of { dimension : int }
@@ -1075,7 +1076,7 @@ let unary_primitive_eligible_for_cse p ~arg =
   | Block_load _ -> false
   | Duplicate_array _ -> false
   | Duplicate_block { kind = _ } -> false
-  | Is_int _ | Get_tag | Get_header -> true
+  | Is_int _ | Is_null | Get_tag | Get_header -> true
   | Array_length _ -> true
   | Bigarray_length _ -> false
   | String_length _ -> true
@@ -1131,6 +1132,7 @@ let compare_unary_primitive p1 p2 =
     | Obj_dup -> 25
     | Get_header -> 26
     | Atomic_load _ -> 27
+    | Is_null -> 28
   in
   match p1, p2 with
   | ( Block_load { kind = kind1; mut = mut1; field = field1 },
@@ -1216,13 +1218,13 @@ let compare_unary_primitive p1 p2 =
   | End_try_region { ghost = ghost1 }, End_try_region { ghost = ghost2 } ->
     Bool.compare ghost1 ghost2
   | ( ( Block_load _ | Duplicate_array _ | Duplicate_block _ | Is_int _
-      | Get_tag | String_length _ | Int_as_pointer _ | Opaque_identity _
-      | Int_arith _ | Num_conv _ | Boolean_not | Reinterpret_64_bit_word _
-      | Float_arith _ | Array_length _ | Bigarray_length _ | Unbox_number _
-      | Box_number _ | Untag_immediate | Tag_immediate | Project_function_slot _
-      | Project_value_slot _ | Is_boxed_float | Is_flat_float_array
-      | End_region _ | End_try_region _ | Obj_dup | Get_header | Atomic_load _
-        ),
+      | Is_null | Get_tag | String_length _ | Int_as_pointer _
+      | Opaque_identity _ | Int_arith _ | Num_conv _ | Boolean_not
+      | Reinterpret_64_bit_word _ | Float_arith _ | Array_length _
+      | Bigarray_length _ | Unbox_number _ | Box_number _ | Untag_immediate
+      | Tag_immediate | Project_function_slot _ | Project_value_slot _
+      | Is_boxed_float | Is_flat_float_array | End_region _ | End_try_region _
+      | Obj_dup | Get_header | Atomic_load _ ),
       _ ) ->
     Stdlib.compare (unary_primitive_numbering p1) (unary_primitive_numbering p2)
 
@@ -1243,6 +1245,7 @@ let print_unary_primitive ppf p =
       Mutability.print destination_mutability
   | Is_int { variant_only } ->
     if variant_only then fprintf ppf "Is_int" else fprintf ppf "Is_int_generic"
+  | Is_null -> fprintf ppf "Is_null"
   | Get_tag -> fprintf ppf "Get_tag"
   | String_length _ -> fprintf ppf "String_length"
   | Int_as_pointer alloc_mode ->
@@ -1294,6 +1297,7 @@ let arg_kind_of_unary_primitive p =
   | Block_load _ -> block_kind
   | Duplicate_array _ | Duplicate_block _ -> K.value
   | Is_int _ -> K.value
+  | Is_null -> K.value
   | Get_tag -> K.value
   | String_length _ -> K.value
   | Int_as_pointer _ -> K.value
@@ -1327,7 +1331,7 @@ let result_kind_of_unary_primitive p : result_kind =
   | Block_load { kind; _ } ->
     Singleton (Block_access_kind.element_kind_for_load kind)
   | Duplicate_array _ | Duplicate_block _ -> Singleton K.value
-  | Is_int _ | Get_tag -> Singleton K.naked_immediate
+  | Is_int _ | Is_null | 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
@@ -1382,7 +1386,7 @@ let effects_and_coeffects_of_unary_primitive p : Effects_and_coeffects.t =
     (* We have to assume that the fields might be mutable. (This information
        isn't currently propagated from [Lambda].) *)
     Only_generative_effects Mutable, Has_coeffects, Strict
-  | Is_int _ -> No_effects, No_coeffects, Strict
+  | Is_int _ | Is_null -> No_effects, No_coeffects, Strict
   | Get_tag ->
     (* [Obj.truncate] has now been removed. *)
     No_effects, No_coeffects, Strict
@@ -1452,8 +1456,8 @@ let unary_classify_for_printing p =
   match p with
   | Duplicate_array _ | Duplicate_block _ | Obj_dup -> Constructive
   | String_length _ | Get_tag -> Destructive
-  | Is_int _ | Opaque_identity _ | Int_arith _ | Num_conv _ | Boolean_not
-  | Reinterpret_64_bit_word _ | Float_arith _ ->
+  | Is_int _ | Is_null | Opaque_identity _ | Int_arith _ | Num_conv _
+  | Boolean_not | Reinterpret_64_bit_word _ | Float_arith _ ->
     Neither
   | Array_length _ | Bigarray_length _ | Unbox_number _ | Untag_immediate ->
     Destructive
@@ -1479,9 +1483,9 @@ let free_names_unary_primitive p =
       (Name_occurrences.add_value_slot_in_projection Name_occurrences.empty
          value_slot Name_mode.normal)
       project_from Name_mode.normal
-  | Block_load _ | Duplicate_array _ | Duplicate_block _ | Is_int _ | Get_tag
-  | String_length _ | Opaque_identity _ | Int_arith _ | Num_conv _ | Boolean_not
-  | Reinterpret_64_bit_word _ | Float_arith _ | Array_length _
+  | Block_load _ | Duplicate_array _ | Duplicate_block _ | Is_int _ | Is_null
+  | Get_tag | String_length _ | Opaque_identity _ | Int_arith _ | Num_conv _
+  | Boolean_not | Reinterpret_64_bit_word _ | Float_arith _ | Array_length _
   | Bigarray_length _ | Unbox_number _ | Untag_immediate | Tag_immediate
   | Is_boxed_float | Is_flat_float_array | End_region _ | End_try_region _
   | Obj_dup | Get_header
@@ -1500,9 +1504,9 @@ let apply_renaming_unary_primitive p renaming =
       Alloc_mode.For_allocations.apply_renaming alloc_mode renaming
     in
     if alloc_mode == alloc_mode' then p else Int_as_pointer alloc_mode'
-  | Block_load _ | Duplicate_array _ | Duplicate_block _ | Is_int _ | Get_tag
-  | String_length _ | Opaque_identity _ | Int_arith _ | Num_conv _ | Boolean_not
-  | Reinterpret_64_bit_word _ | Float_arith _ | Array_length _
+  | Block_load _ | Duplicate_array _ | Duplicate_block _ | Is_int _ | Is_null
+  | Get_tag | String_length _ | Opaque_identity _ | Int_arith _ | Num_conv _
+  | Boolean_not | Reinterpret_64_bit_word _ | Float_arith _ | Array_length _
   | Bigarray_length _ | Unbox_number _ | Untag_immediate | Tag_immediate
   | Is_boxed_float | Is_flat_float_array | End_region _ | End_try_region _
   | Project_function_slot _ | Project_value_slot _ | Obj_dup | Get_header
@@ -1513,9 +1517,9 @@ let ids_for_export_unary_primitive p =
   match p with
   | Box_number (_, alloc_mode) | Int_as_pointer alloc_mode ->
     Alloc_mode.For_allocations.ids_for_export alloc_mode
-  | Block_load _ | Duplicate_array _ | Duplicate_block _ | Is_int _ | Get_tag
-  | String_length _ | Opaque_identity _ | Int_arith _ | Num_conv _ | Boolean_not
-  | Reinterpret_64_bit_word _ | Float_arith _ | Array_length _
+  | Block_load _ | Duplicate_array _ | Duplicate_block _ | Is_int _ | Is_null
+  | Get_tag | String_length _ | Opaque_identity _ | Int_arith _ | Num_conv _
+  | Boolean_not | Reinterpret_64_bit_word _ | Float_arith _ | Array_length _
   | Bigarray_length _ | Unbox_number _ | Untag_immediate | Tag_immediate
   | Is_boxed_float | Is_flat_float_array | End_region _ | End_try_region _
   | Project_function_slot _ | Project_value_slot _ | Obj_dup | Get_header

diff --git a/middle_end/flambda2/terms/flambda_primitive.mli b/middle_end/flambda2/terms/flambda_primitive.mli
@@ -366,6 +366,7 @@ type unary_primitive =
         destination_mutability : Mutability.t
       }
   | Is_int of { variant_only : bool }
+  | Is_null
   | Get_tag
   | Array_length of Array_kind_for_length.t
   | Bigarray_length of { dimension : int }

diff --git a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml
@@ -794,6 +794,7 @@ let unary_primitive env res dbg f arg =
         ~effects:Arbitrary_effects ~coeffects:Has_coeffects ~ty_args:[]
         "caml_obj_dup" Cmm.typ_val [arg] )
   | Is_int _ -> None, res, C.and_int arg (C.int ~dbg 1) dbg
+  | Is_null -> None, res, C.eq ~dbg arg (C.nativeint ~dbg 0n)
   | Get_tag -> None, res, C.get_tag arg dbg
   | Array_length (Array_kind array_kind) ->
     None, res, array_length ~dbg arg array_kind