%obj_magic

middle_end/convert_primitives.ml

@@ -154,6 +154,7 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
       ~native_name:"caml_obj_dup"
       ~native_repr_args:[P.Prim_global, P.Same_as_ocaml_repr]
       ~native_repr_res:(P.Prim_global, P.Same_as_ocaml_repr))
+  | Pobj_magic
   | Pbytes_to_string
   | Pbytes_of_string
   | Pctconst _

middle_end/flambda/closure_conversion.ml

@@ -424,7 +424,8 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
         (If_then_else (cond, arg2, Var const_false, Pintval)))
   | Lprim ((Psequand | Psequor), _, _) ->
     Misc.fatal_error "Psequand / Psequor must have exactly two arguments"
-  | Lprim ((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _) ->
+  | Lprim ((Pidentity | Pbytes_to_string | Pbytes_of_string | Pobj_magic),
+           [arg], _) ->
     close t env arg
   | Lprim (Pignore, [arg], _) ->
     let var = Variable.create Names.ignore in

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -659,7 +659,7 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args
       | Pbigstring_load_32 _ | Pbigstring_load_64 _ | Pbigstring_set_16 _
       | Pbigstring_set_32 _ | Pbigstring_set_64 _ | Pctconst _ | Pbswap16
       | Pbbswap _ | Pint_as_pointer | Popaque | Pprobe_is_enabled _ | Pobj_dup
-        ->
+      | Pobj_magic ->
         (* Inconsistent with outer match *)
         assert false
     in

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -922,7 +922,7 @@ let primitive_can_raise (prim : Lambda.primitive) =
   | Pbigstring_set_32 true
   | Pbigstring_set_64 true
   | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer | Popaque
-  | Pprobe_is_enabled _ | Pobj_dup ->
+  | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic ->
     false
 
 let rec cps_non_tail acc env ccenv (lam : L.lambda)

middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml

@@ -628,7 +628,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list)
               ( Make_array (Naked_floats, mutability, mode),
                 List.map unbox_float args ),
             Variadic (Make_array (Values, mutability, mode), args) )))
-  | Popaque, [arg] -> Unary (Opaque_identity, arg)
+  | Popaque, [arg] -> Unary (Opaque_identity { middle_end_only = false }, arg)
+  | Pobj_magic, [arg] -> Unary (Opaque_identity { middle_end_only = true }, arg)
   | Pduprecord (repr, num_fields), [arg] ->
     let kind : P.Duplicate_block_kind.t =
       match repr with
@@ -1158,7 +1159,8 @@ 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 _ | Pobj_dup ),
+      | Pbbswap _ | Pisint _ | Pint_as_pointer | Pbigarraydim _ | Pobj_dup
+      | Pobj_magic ),
       ([] | _ :: _ :: _) ) ->
     Misc.fatal_errorf
       "Closure_conversion.convert_primitive: Wrong arity for unary primitive \

middle_end/flambda2/parser/fexpr_to_flambda.ml

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

middle_end/flambda2/parser/flambda_to_fexpr.ml

@@ -434,7 +434,7 @@ let unop env (op : Flambda_primitive.unary_primitive) : Fexpr.unop =
   | Get_tag -> Get_tag
   | Is_int _ -> Is_int (* CR vlaviron: discuss *)
   | Num_conv { src; dst } -> Num_conv { src; dst }
-  | Opaque_identity -> Opaque_identity
+  | Opaque_identity _ -> Opaque_identity
   | Unbox_number bk -> Unbox_number bk
   | Untag_immediate -> Untag_immediate
   | Project_value_slot { project_from; value_slot } ->

middle_end/flambda2/simplify/simplify_unary_primitive.ml

@@ -585,7 +585,7 @@ let simplify_unary_primitive dacc original_prim (prim : P.unary_primitive) ~arg
     | Duplicate_array { kind; source_mutability; destination_mutability } ->
       simplify_duplicate_array ~kind ~source_mutability ~destination_mutability
     | Duplicate_block { kind } -> simplify_duplicate_block ~kind
-    | Opaque_identity -> simplify_opaque_identity
+    | Opaque_identity { middle_end_only = _ } -> simplify_opaque_identity
     | End_region -> simplify_end_region
     | Obj_dup -> simplify_obj_dup dbg
   in

middle_end/flambda2/terms/code_size.ml

@@ -317,7 +317,7 @@ let unary_prim_size prim =
   | Bigarray_length _ -> 2 (* cadda + load *)
   | String_length _ -> 5
   | Int_as_pointer -> 1
-  | Opaque_identity -> 0
+  | Opaque_identity _ -> 0
   | Int_arith (kind, op) -> unary_int_prim_size kind op
   | Float_arith _ -> 2
   | Num_conv { src; dst } -> arith_conversion_size src dst

middle_end/flambda2/terms/flambda_primitive.ml

@@ -629,7 +629,7 @@ type unary_primitive =
   | Bigarray_length of { dimension : int }
   | String_length of string_or_bytes
   | Int_as_pointer
-  | Opaque_identity
+  | Opaque_identity of { middle_end_only : bool }
   | Int_arith of Flambda_kind.Standard_int.t * unary_int_arith_op
   | Float_arith of unary_float_arith_op
   | Num_conv of
@@ -666,7 +666,7 @@ let unary_primitive_eligible_for_cse p ~arg =
   | Bigarray_length _ -> false
   | String_length _ -> true
   | Int_as_pointer -> true
-  | Opaque_identity -> false
+  | Opaque_identity _ -> false
   | Int_arith _ -> true
   | Float_arith _ ->
     (* See comment in effects_and_coeffects *)
@@ -697,7 +697,7 @@ let compare_unary_primitive p1 p2 =
     | Bigarray_length _ -> 5
     | String_length _ -> 6
     | Int_as_pointer -> 7
-    | Opaque_identity -> 8
+    | Opaque_identity _ -> 8
     | Int_arith _ -> 9
     | Float_arith _ -> 10
     | Num_conv _ -> 11
@@ -768,8 +768,11 @@ 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
+  | ( Opaque_identity { middle_end_only = middle_end_only1 },
+      Opaque_identity { middle_end_only = middle_end_only2 } ) ->
+    Bool.compare middle_end_only1 middle_end_only2
   | ( ( Duplicate_array _ | Duplicate_block _ | Is_int _ | Get_tag
-      | String_length _ | Int_as_pointer | Opaque_identity | Int_arith _
+      | 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 _
       | Untag_immediate | Tag_immediate | Project_function_slot _
@@ -795,7 +798,8 @@ let print_unary_primitive ppf p =
   | Get_tag -> fprintf ppf "Get_tag"
   | String_length _ -> fprintf ppf "String_length"
   | Int_as_pointer -> fprintf ppf "Int_as_pointer"
-  | Opaque_identity -> fprintf ppf "Opaque_identity"
+  | Opaque_identity { middle_end_only } ->
+    fprintf ppf "@[(Opaque_identity@ (middle_end_only %b))@]" middle_end_only
   | Int_arith (_k, o) -> print_unary_int_arith_op ppf o
   | Num_conv { src; dst } ->
     fprintf ppf "Num_conv_%a_to_%a"
@@ -832,7 +836,7 @@ let arg_kind_of_unary_primitive p =
   | Get_tag -> K.value
   | String_length _ -> K.value
   | Int_as_pointer -> K.value
-  | Opaque_identity -> K.value
+  | Opaque_identity _ -> K.value
   | Int_arith (kind, _) -> K.Standard_int.to_kind kind
   | Num_conv { src; dst = _ } -> K.Standard_int_or_float.to_kind src
   | Boolean_not -> K.value
@@ -857,7 +861,7 @@ let result_kind_of_unary_primitive p : result_kind =
     (* This primitive is *only* to be used when the resulting pointer points at
        something which is a valid OCaml value (even if outside of the heap). *)
     Singleton K.value
-  | Opaque_identity -> Singleton K.value
+  | Opaque_identity _ -> Singleton K.value
   | Int_arith (kind, _) -> Singleton (K.Standard_int.to_kind kind)
   | Num_conv { src = _; dst } -> Singleton (K.Standard_int_or_float.to_kind dst)
   | Boolean_not -> Singleton K.value
@@ -905,7 +909,7 @@ let effects_and_coeffects_of_unary_primitive p =
     Effects.No_effects, Coeffects.No_coeffects
   | String_length _ -> Effects.No_effects, Coeffects.No_coeffects
   | Int_as_pointer -> Effects.No_effects, Coeffects.No_coeffects
-  | Opaque_identity -> Effects.Arbitrary_effects, Coeffects.Has_coeffects
+  | Opaque_identity _ -> Effects.Arbitrary_effects, Coeffects.Has_coeffects
   | Int_arith (_, (Neg | Swap_byte_endianness))
   | Num_conv _ | Boolean_not | Reinterpret_int64_as_float ->
     Effects.No_effects, Coeffects.No_coeffects
@@ -961,7 +965,7 @@ let unary_classify_for_printing p =
   match p with
   | Duplicate_array _ | Duplicate_block _ | Obj_dup -> 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 ->
@@ -986,7 +990,7 @@ let free_names_unary_primitive p =
          value_slot Name_mode.normal)
       project_from Name_mode.normal
   | Duplicate_array _ | Duplicate_block _ | Is_int _ | Get_tag | String_length _
-  | Int_as_pointer | Opaque_identity | Int_arith _ | Num_conv _ | Boolean_not
+  | Int_as_pointer | Opaque_identity _ | Int_arith _ | Num_conv _ | Boolean_not
   | Reinterpret_int64_as_float | Float_arith _ | Array_length
   | Bigarray_length _ | Unbox_number _ | Untag_immediate | Tag_immediate
   | Is_boxed_float | Is_flat_float_array | End_region | Obj_dup ->
@@ -1000,7 +1004,7 @@ let apply_renaming_unary_primitive p renaming =
     in
     if alloc_mode == alloc_mode' then p else Box_number (kind, alloc_mode')
   | Duplicate_array _ | Duplicate_block _ | Is_int _ | Get_tag | String_length _
-  | Int_as_pointer | Opaque_identity | Int_arith _ | Num_conv _ | Boolean_not
+  | Int_as_pointer | Opaque_identity _ | Int_arith _ | Num_conv _ | Boolean_not
   | Reinterpret_int64_as_float | Float_arith _ | Array_length
   | Bigarray_length _ | Unbox_number _ | Untag_immediate | Tag_immediate
   | Is_boxed_float | Is_flat_float_array | End_region | Project_function_slot _
@@ -1012,7 +1016,7 @@ let ids_for_export_unary_primitive p =
   | Box_number (_kind, alloc_mode) ->
     Alloc_mode.With_region.ids_for_export alloc_mode
   | Duplicate_array _ | Duplicate_block _ | Is_int _ | Get_tag | String_length _
-  | Int_as_pointer | Opaque_identity | Int_arith _ | Num_conv _ | Boolean_not
+  | Int_as_pointer | Opaque_identity _ | Int_arith _ | Num_conv _ | Boolean_not
   | Reinterpret_int64_as_float | Float_arith _ | Array_length
   | Bigarray_length _ | Unbox_number _ | Untag_immediate | Tag_immediate
   | Is_boxed_float | Is_flat_float_array | End_region | Project_function_slot _

middle_end/flambda2/terms/flambda_primitive.mli

@@ -239,7 +239,7 @@ type unary_primitive =
   (* CR gbury: Invariant check: 0 < dimension <= 3 *)
   | String_length of string_or_bytes
   | Int_as_pointer
-  | Opaque_identity
+  | Opaque_identity of { middle_end_only : bool }
   | Int_arith of Flambda_kind.Standard_int.t * unary_int_arith_op
   | Float_arith of unary_float_arith_op
   | Num_conv of

middle_end/flambda2/to_cmm/to_cmm_primitive.ml

@@ -529,7 +529,8 @@ let unary_primitive env res dbg f arg =
         ~addr:(C.field_address arg (4 + dimension) dbg) )
   | String_length _ -> None, res, C.string_length arg dbg
   | Int_as_pointer -> None, res, C.int_as_pointer arg dbg
-  | Opaque_identity -> None, res, C.opaque arg dbg
+  | Opaque_identity { middle_end_only = true } -> None, res, arg
+  | Opaque_identity { middle_end_only = false } -> None, res, C.opaque arg dbg
   | Int_arith (kind, op) ->
     None, res, unary_int_arith_primitive env dbg kind op arg
   | Float_arith op -> None, res, unary_float_arith_primitive env dbg op arg

middle_end/internal_variable_names.ml

@@ -127,6 +127,7 @@ let pcompare_ints = "Pcompare_ints"
 let pcompare_floats = "Pcompare_floats"
 let pcompare_bints = "Pcompare_bints"
 let pobj_dup = "Pobj_dup"
+let pobj_magic = "Pobj_magic"
 let pintofbint = "Pintofbint"
 let pintoffloat = "Pintoffloat"
 let pisint = "Pisint"
@@ -225,6 +226,7 @@ let pfloatfield_arg = "Pfloatfield_arg"
 let pfloatofint_arg = "Pfloatofint_arg"
 let pgetglobal_arg = "Pgetglobal_arg"
 let pobj_dup_arg = "Pobj_dup_arg"
+let pobj_magic_arg = "Pobj_magic_arg"
 let pidentity_arg = "Pidentity_arg"
 let pignore_arg = "Pignore_arg"
 let pint_as_pointer_arg = "Pint_as_pointer_arg"
@@ -424,6 +426,7 @@ let of_primitive : Lambda.primitive -> string = function
   | Popaque -> popaque
   | Pprobe_is_enabled _ -> pprobe_is_enabled
   | Pobj_dup -> pobj_dup
+  | Pobj_magic -> pobj_magic
 
 let of_primitive_arg : Lambda.primitive -> string = function
   | Pidentity -> pidentity_arg
@@ -533,3 +536,4 @@ let of_primitive_arg : Lambda.primitive -> string = function
   | Popaque -> popaque_arg
   | Pprobe_is_enabled _ -> pprobe_is_enabled_arg
   | Pobj_dup -> pobj_dup_arg
+  | Pobj_magic -> pobj_magic_arg

ocaml/boot/menhir/menhirLib.ml

@@ -1,3 +1,8 @@
+module Obj = struct
+  include Obj
+  external magic : 'a -> 'b = "%identity"
+end
+
 module General = struct
 (******************************************************************************)
 (*                                                                            *)

ocaml/bytecomp/bytegen.ml

@@ -109,7 +109,8 @@ let rec is_tailcall = function
    from the tail call optimization? *)
 
 let preserve_tailcall_for_prim = function
-    Pidentity | Popaque | Pdirapply _ | Prevapply _ | Psequor | Psequand ->
+    Pidentity | Popaque | Pdirapply _ | Prevapply _ | Psequor | Psequand
+  | Pobj_magic ->
       true
   | Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ | Psetglobal _
   | Pmakeblock _ | Pmakefloatblock _
@@ -681,7 +682,7 @@ let rec comp_expr env exp sz cont =
         in
         comp_init env sz decl_size
       end
-  | Lprim((Pidentity | Popaque), [arg], _) ->
+  | Lprim((Pidentity | Popaque | Pobj_magic), [arg], _) ->
       comp_expr env arg sz cont
   | Lprim(Pignore, [arg], _) ->
       comp_expr env arg sz (add_const_unit cont)

ocaml/lambda/lambda.ml

@@ -213,6 +213,7 @@ type primitive =
   | Pprobe_is_enabled of { name: string }
   (* Primitives for [Obj] *)
   | Pobj_dup
+  | Pobj_magic
 
 and integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge
@@ -1260,3 +1261,4 @@ let primitive_may_allocate : primitive -> alloc_mode option = function
   | Popaque -> None
   | Pprobe_is_enabled _ -> None
   | Pobj_dup -> Some alloc_heap
+  | Pobj_magic -> None

ocaml/lambda/lambda.mli

@@ -183,6 +183,7 @@ type primitive =
   | Pprobe_is_enabled of { name: string }
   (* Primitives for [Obj] *)
   | Pobj_dup
+  | Pobj_magic
 
 and integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge

ocaml/lambda/printlambda.ml

@@ -440,6 +440,7 @@ let primitive ppf = function
   | Popaque -> fprintf ppf "opaque"
   | Pprobe_is_enabled {name} -> fprintf ppf "probe_is_enabled[%s]" name
   | Pobj_dup -> fprintf ppf "obj_dup"
+  | Pobj_magic -> fprintf ppf "obj_magic"
 
 let name_of_primitive = function
   | Pidentity -> "Pidentity"
@@ -549,6 +550,7 @@ let name_of_primitive = function
   | Popaque -> "Popaque"
   | Pprobe_is_enabled _ -> "Pprobe_is_enabled"
   | Pobj_dup -> "Pobj_dup"
+  | Pobj_magic -> "Pobj_magic"
 
 let check_attribute ppf check =
   let check_property = function

ocaml/lambda/translprim.ml

@@ -381,6 +381,7 @@ let lookup_primitive loc poly pos p =
     | "%greaterthan" -> Comparison(Greater_than, Compare_generic)
     | "%compare" -> Comparison(Compare, Compare_generic)
     | "%obj_dup" -> Primitive(Pobj_dup, 1)
+    | "%obj_magic" -> Primitive(Pobj_magic, 1)
     | s when String.length s > 0 && s.[0] = '%' ->
        raise(Error(loc, Unknown_builtin_primitive s))
     | _ -> External p
@@ -824,7 +825,8 @@ let lambda_primitive_needs_event_after = function
   | Pbytessetu | Pmakearray ((Pintarray | Paddrarray | Pfloatarray), _, _)
   | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisout
   | Pprobe_is_enabled _
-  | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer | Popaque -> false
+  | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer | Popaque
+  | Pobj_magic -> false
 
 (* Determine if a primitive should be surrounded by an "after" debug event *)
 let primitive_needs_event_after = function

ocaml/stdlib/obj.ml

@@ -26,7 +26,7 @@ type raw_data = nativeint
 
 external repr : 'a -> t = "%identity"
 external obj : t -> 'a = "%identity"
-external magic : 'a -> 'b = "%identity"
+external magic : 'a -> 'b = "%obj_magic"
 external is_int : t -> bool = "%obj_is_int"
 let [@inline always] is_block a = not (is_int a)
 external tag : t -> int = "caml_obj_tag" [@@noalloc]

ocaml/stdlib/obj.mli

@@ -27,7 +27,7 @@ type raw_data = nativeint  (* @since 4.12 *)
 
 external repr : 'a -> t = "%identity"
 external obj : t -> 'a = "%identity"
-external magic : 'a -> 'b = "%identity"
+external magic : 'a -> 'b = "%obj_magic"
 val [@inline always] is_block : t -> bool
 external is_int : t -> bool = "%obj_is_int"
 external tag : t -> int = "caml_obj_tag" [@@noalloc]