Reimplement Obj.reachable_word using a hash table to detect sharing

The previous implementation (caml_obj_reachable_words in runtime/obj.c)
was using the mark bits of block headers to detect sharing.

This is not compatible with Multicore OCaml.

This commit reimplements caml_obj_reachable_words to detect sharing
with a hash table of addresses already seen.

The implementation reuses the hash table used to detect sharing
during marshaling (commit 67ada54ce), and other bits of the marshaler,
hence the function caml_obj_reachable_words was moved to runtime/extern.c.

In no-naked-pointers mode, to anticipate the disappearance of the page
table, statically-allocated blocks cannot be treated specially and will
be counted towards the size.  This change of semantics is mentioned
in the documentation for Obj.reachable_words.

runtime/extern.c

@@ -1130,3 +1130,66 @@ CAMLexport void caml_serialize_block_float_8(void * data, intnat len)
   }
 #endif
 }
+
+CAMLprim value caml_obj_reachable_words(value v)
+{
+  intnat size;
+  struct extern_item * sp;
+  uintnat h = 0;
+  uintnat pos;
+
+  extern_init_position_table();
+  sp = extern_stack;
+  size = 0;
+  while (1) {
+    if (Is_long(v)) {
+      /* Tagged integers contribute 0 to the size, nothing to do */
+#ifndef NO_NAKED_POINTERS
+    } else if (! Is_in_heap_or_young(v)) {
+      /* Out-of-heap blocks contribute 0 to the size, nothing to do */
+      /* However, once we get rid of the page table, we will no longer
+         be able to distinguish major heap blocks and out-of-heap blocks,
+         so we will need to count out-of-heap blocks too. */
+#endif
+    } else if (extern_lookup_position(v, &pos, &h)) {
+      /* Already seen and counted, nothing to do */
+    } else {
+      header_t hd = Hd_val(v);
+      tag_t tag = Tag_hd(hd);
+      mlsize_t sz = Wosize_hd(hd);
+      /* Infix pointer: go back to containing closure */
+      if (tag == Infix_tag) {
+        v = v - Infix_offset_hd(hd);
+        continue;
+      }
+      /* Remember that we've visited this block */
+      extern_record_location(v, h);
+      /* The block contributes to the total size */
+      size += 1 + sz;           /* header word included */
+      if (tag < No_scan_tag) {
+        /* i is the position of the first field to traverse recursively */
+        uintnat i =
+          tag == Closure_tag ? Start_env_closinfo(Closinfo_val(v)) : 0;
+        if (i < sz) {
+          if (i < sz - 1) {
+            /* Remember that we need to count fields i + 1 ... sz - 1 */
+            sp++;
+            if (sp >= extern_stack_limit) sp = extern_resize_stack(sp);
+            sp->v = &Field(v, i + 1);
+            sp->count = sz - i - 1;
+          }
+          /* Continue with field i */
+          v = Field(v, i);
+          continue;
+        }
+      }
+    }
+    /* Pop one more item to traverse, if any */
+    if (sp == extern_stack) break;
+    v = *((sp->v)++);
+    if (--(sp->count) == 0) sp--;
+  }
+  extern_free_stack();
+  extern_free_position_table();
+  return Val_long(size);
+}

runtime/obj.c

@@ -340,113 +340,3 @@ struct queue_chunk {
   struct queue_chunk *next;
   value entries[ENTRIES_PER_QUEUE_CHUNK];
 };
-
-
-CAMLprim value caml_obj_reachable_words(value v)
-{
-  static struct queue_chunk first_chunk;
-  struct queue_chunk *read_chunk, *write_chunk;
-  int write_pos, read_pos, i;
-
-  intnat size = 0;
-  header_t hd;
-  mlsize_t sz;
-
-  if (Is_long(v) || !Is_in_heap_or_young(v)) return Val_int(0);
-  if (Tag_hd(Hd_val(v)) == Infix_tag) v -= Infix_offset_hd(Hd_val(v));
-  hd = Hd_val(v);
-  sz = Wosize_hd(hd);
-
-  read_chunk = write_chunk = &first_chunk;
-  read_pos = 0;
-  write_pos = 1;
-  write_chunk->entries[0] = v | Colornum_hd(hd);
-  Hd_val(v) = Bluehd_hd(hd);
-
-  /* We maintain a queue of "interesting" blocks that have been seen.
-     An interesting block is a block in the heap which does not
-     represent an infix pointer. Infix pointers are normalized to the
-     beginning of their block.  Blocks in the static data area are excluded.
-
-     The function maintains a queue of block pointers.  Concretely,
-     the queue is stored as a linked list of chunks, each chunk
-     holding a number of pointers to interesting blocks.  Initially,
-     it contains only the "root" value.  The first chunk of the queue
-     is allocated statically.  More chunks can be allocated as needed
-     and released before this function exits.
-
-     When a block is inserted in the queue, it is marked as blue.
-     This mark is used to avoid a second visit of the same block.
-     The real color is stored in the last 2 bits of the pointer in the
-     queue.  (Same technique as in extern.c.)
-
-     Note: we make the assumption that there is no pointer
-     from the static data area to the heap.
-  */
-
-  /* First pass: mark accessible blocks and compute their total size */
-  while (read_pos != write_pos || read_chunk != write_chunk) {
-    /* Pop the next element from the queue */
-    if (read_pos == ENTRIES_PER_QUEUE_CHUNK) {
-      read_pos = 0;
-      read_chunk = read_chunk->next;
-    }
-    v = read_chunk->entries[read_pos++] & ~3;
-
-    hd = Hd_val(v);
-    sz = Wosize_hd(hd);
-
-    size += Whsize_wosize(sz);
-
-    if (Tag_hd(hd) < No_scan_tag) {
-      /* Push the interesting fields on the queue */
-      for (i = 0; i < sz; i++) {
-        value v2 = Field(v, i);
-        if (Is_block(v2) && Is_in_heap_or_young(v2)) {
-          if (Tag_hd(Hd_val(v2)) == Infix_tag){
-            v2 -= Infix_offset_hd(Hd_val(v2));
-          }
-          hd = Hd_val(v2);
-          if (Color_hd(hd) != Caml_blue) {
-            if (write_pos == ENTRIES_PER_QUEUE_CHUNK) {
-              struct queue_chunk *new_chunk =
-                malloc(sizeof(struct queue_chunk));
-              if (new_chunk == NULL) {
-                size = (-1);
-                goto release;
-              }
-              write_chunk->next = new_chunk;
-              write_pos = 0;
-              write_chunk = new_chunk;
-            }
-            write_chunk->entries[write_pos++] = v2 | Colornum_hd(hd);
-            Hd_val(v2) = Bluehd_hd(hd);
-          }
-        }
-      }
-    }
-  }
-
-  /* Second pass: restore colors and free extra queue chunks */
- release:
-  read_pos = 0;
-  read_chunk = &first_chunk;
-  while (read_pos != write_pos || read_chunk != write_chunk) {
-    color_t colornum;
-    if (read_pos == ENTRIES_PER_QUEUE_CHUNK) {
-      struct queue_chunk *prev = read_chunk;
-      read_pos = 0;
-      read_chunk = read_chunk->next;
-      if (prev != &first_chunk) free(prev);
-    }
-    v = read_chunk->entries[read_pos++];
-    colornum = v & 3;
-    v &= ~3;
-    Hd_val(v) = Coloredhd_hd(Hd_val(v), colornum);
-  }
-  if (read_chunk != &first_chunk) free(read_chunk);
-
-  if (size < 0)
-    caml_raise_out_of_memory();
-  return Val_int(size);
-}

stdlib/obj.mli

@@ -33,7 +33,8 @@ external reachable_words : t -> int = "caml_obj_reachable_words"
   (**
      Computes the total size (in words, including the headers) of all
      heap blocks accessible from the argument.  Statically
-     allocated blocks are excluded.
+     allocated blocks are excluded, unless the runtime system
+     was configured with [--disable-naked-pointers].
 
      @Since 4.04
   *)