Port #1539 (add the %get_header primitive) (#2088)

ocaml-flambda · Nov 29, 2023 · b63f1ec · b63f1ec
1 parent 877f053
commit b63f1ec
Show file tree

Hide file tree

Showing 4 changed files with 15 additions and 4 deletions.
diff --git a/ocaml/runtime/obj.c b/ocaml/runtime/obj.c
@@ -73,6 +73,13 @@ CAMLprim value caml_obj_make_forward(value blk, value fwd)
   return Val_unit;
 }
 
+CAMLprim value caml_get_header(value blk)
+{
+  // undefined behaviour if blk is not a block
+  intnat r = Hd_val(blk);
+  return caml_copy_nativeint(r);
+}
+
 /* [size] is a value encoding a number of blocks */
 CAMLprim value caml_obj_block(value tag, value size)
 {

diff --git a/...e/tests/lib-obj/get_header.byte.reference → ...e/tests/lib-obj/get_header.heap.reference b/...e/tests/lib-obj/get_header.byte.reference → ...e/tests/lib-obj/get_header.heap.reference
diff --git a/ocaml/testsuite/tests/lib-obj/get_header.ml b/ocaml/testsuite/tests/lib-obj/get_header.ml
@@ -1,9 +1,13 @@
 (* TEST
-   * native
-     reference = "${test_source_directory}/get_header.opt.reference"
    * bytecode
-     reference = "${test_source_directory}/get_header.byte.reference"
-*)
+     reference = "${test_source_directory}/get_header.heap.reference"
+   * stack-allocation
+   ** native
+      reference = "${test_source_directory}/get_header.stack.reference"
+   * no-stack-allocation
+   ** native
+      reference = "${test_source_directory}/get_header.heap.reference"
+ *)
 
 (* We're likely to remove %get_header in favour of calls to
    caml_obj_is_stack under runtime5 (since testing a block's colour isn't

diff --git a/...te/tests/lib-obj/get_header.opt.reference → .../tests/lib-obj/get_header.stack.reference b/...te/tests/lib-obj/get_header.opt.reference → .../tests/lib-obj/get_header.stack.reference