Merge pull request #9655 from xavierleroy/obj-bits

Introduce type Obj.raw_data and functions Obj.raw_field, Obj.set_raw_field to manipulate out-of-heap pointers in no-naked-pointers mode, and more generally  all other data that is not a well-formed OCaml value

Changes

@@ -84,6 +84,11 @@ Working version
    are no arguments (an empty list) after the rest marker)
   (Gabriel Scherer, review by Nicolás Ojeda Bär and David Allsopp)
 
+- #9655: Obj: introduce type raw_data and functions raw_field, set_raw_field
+   to manipulate out-of-heap pointers in no-naked-pointer mode,
+   and more generally all other data that is not a well-formed OCaml value
+   (Xavier Leroy, review by Damien Doligez and Gabriel Scherer)
+
 ### Other libraries:
 
 * #9206, #9419: update documentation of the threads library;

bytecomp/meta.ml

@@ -23,7 +23,7 @@ external reify_bytecode :
                            = "caml_reify_bytecode"
 external release_bytecode : bytecode -> unit
                                  = "caml_static_release_bytecode"
-external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t
+external invoke_traced_function : Obj.raw_data -> Obj.t -> Obj.t -> Obj.t
                                 = "caml_invoke_traced_function"
 external get_section_table : unit -> (string * Obj.t) list
                            = "caml_get_section_table"

bytecomp/meta.mli

@@ -25,7 +25,7 @@ external reify_bytecode :
                            = "caml_reify_bytecode"
 external release_bytecode : bytecode -> unit
                                  = "caml_static_release_bytecode"
-external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t
+external invoke_traced_function : Obj.raw_data -> Obj.t -> Obj.t -> Obj.t
                                 = "caml_invoke_traced_function"
 external get_section_table : unit -> (string * Obj.t) list
                            = "caml_get_section_table"

runtime/meta.c

@@ -231,7 +231,7 @@ CAMLprim value caml_invoke_traced_function(value codeptr, value env, value arg)
   Caml_state->extern_sp -= 4;
   nsp = Caml_state->extern_sp;
   for (i = 0; i < 7; i++) nsp[i] = osp[i];
-  nsp[7] = codeptr;
+  nsp[7] = (value) Nativeint_val(codeptr);
   nsp[8] = env;
   nsp[9] = Val_int(0);
   nsp[10] = arg;

runtime/obj.c

@@ -73,6 +73,18 @@ CAMLprim value caml_obj_set_tag (value arg, value new_tag)
   return Val_unit;
 }
 
+CAMLprim value caml_obj_raw_field(value arg, value pos)
+{
+  /* Represent field contents as a native integer */
+  return caml_copy_nativeint((intnat) Field(arg, Long_val(pos)));
+}
+
+CAMLprim value caml_obj_set_raw_field(value arg, value pos, value bits)
+{
+  Field(arg, Long_val(pos)) = (value) Nativeint_val(bits);
+  return Val_unit;
+}
+
 CAMLprim value caml_obj_make_forward (value blk, value fwd)
 {
   caml_modify(&Field(blk, 0), fwd);

stdlib/obj.ml

@@ -17,6 +17,8 @@
 
 type t
 
+type raw_data = nativeint
+
 external repr : 'a -> t = "%identity"
 external obj : t -> 'a = "%identity"
 external magic : 'a -> 'b = "%identity"
@@ -34,6 +36,10 @@ external floatarray_set :
 let [@inline always] double_field x i = floatarray_get (obj x : floatarray) i
 let [@inline always] set_double_field x i v =
   floatarray_set (obj x : floatarray) i v
+external raw_field : t -> int -> raw_data = "caml_obj_raw_field"
+external set_raw_field : t -> int -> raw_data -> unit
+                                          = "caml_obj_set_raw_field"
+
 external new_block : int -> int -> t = "caml_obj_block"
 external dup : t -> t = "caml_obj_dup"
 external truncate : t -> int -> unit = "caml_obj_truncate"

stdlib/obj.mli

@@ -20,6 +20,8 @@
 
 type t
 
+type raw_data = nativeint  (* @since 4.12 *)
+
 external repr : 'a -> t = "%identity"
 external obj : t -> 'a = "%identity"
 external magic : 'a -> 'b = "%identity"
@@ -60,6 +62,13 @@ external set_tag : t -> int -> unit = "caml_obj_set_tag"
 val [@inline always] double_field : t -> int -> float  (* @since 3.11.2 *)
 val [@inline always] set_double_field : t -> int -> float -> unit
   (* @since 3.11.2 *)
+
+external raw_field : t -> int -> raw_data = "caml_obj_raw_field"
+  (* @since 4.12 *)
+external set_raw_field : t -> int -> raw_data -> unit
+                                          = "caml_obj_set_raw_field"
+  (* @since 4.12 *)
+
 external new_block : int -> int -> t = "caml_obj_block"
 external dup : t -> t = "caml_obj_dup"
 external truncate : t -> int -> unit = "caml_obj_truncate"

toplevel/trace.ml

@@ -21,7 +21,7 @@ open Longident
 open Types
 open Toploop
 
-type codeptr = Obj.t
+type codeptr = Obj.raw_data
 
 type traced_function =
   { path: Path.t;                       (* Name under which it is traced *)
@@ -42,9 +42,13 @@ let is_traced clos =
 
 (* Get or overwrite the code pointer of a closure *)
 
-let get_code_pointer cls = Obj.field cls 0
+let get_code_pointer cls =
+  assert (let t = Obj.tag cls in t = Obj.closure_tag || t = Obj.infix_tag);
+  Obj.raw_field cls 0
 
-let set_code_pointer cls ptr = Obj.set_field cls 0 ptr
+let set_code_pointer cls ptr =
+  assert (let t = Obj.tag cls in t = Obj.closure_tag || t = Obj.infix_tag);
+  Obj.set_raw_field cls 0 ptr
 
 (* Call a traced function (use old code pointer, but new closure as
    environment so that recursive calls are also traced).