Port upstream's #12193 (compaction) (#2078)

* Apply diff from upstream's #12193.

* Remove deleted file from dune `install` stanza.

* Fix to POOL_BLOCKS, and indentation fix to pool_free

---------

Co-authored-by: Mark Shinwell <[email protected]>

Author: xclerc

ocaml/.gitattributes

@@ -193,7 +193,7 @@ tools/ocaml-objcopy-macosx text eol=lf
 tools/ocamlsize text eol=lf
 tools/pre-commit-githook text eol=lf
 tools/markdown-add-pr-links.sh text eol=lf
-runtime/caml/sizeclasses.h typo.missing-header typo.white-at-eol
+runtime/caml/sizeclasses.h typo.missing-header
 
 # Tests which include references spanning multiple lines fail with \r\n
 # endings, so use \n endings only, even on Windows.

ocaml/otherlibs/runtime_events/runtime_events.ml

@@ -72,6 +72,10 @@ type runtime_phase =
 | EV_MINOR_LOCAL_ROOTS_PROMOTE
 | EV_DOMAIN_CONDITION_WAIT
 | EV_DOMAIN_RESIZE_HEAP_RESERVATION
+| EV_COMPACT
+| EV_COMPACT_EVACUATE
+| EV_COMPACT_FORWARD
+| EV_COMPACT_RELEASE
 
 type lifecycle =
   EV_RING_START
@@ -153,6 +157,10 @@ let runtime_phase_name phase =
   | EV_DOMAIN_CONDITION_WAIT -> "domain_condition_wait"
   | EV_MAJOR_FINISH_CYCLE -> "major_finish_cycle"
   | EV_DOMAIN_RESIZE_HEAP_RESERVATION -> "domain_resize_heap_reservation"
+  | EV_COMPACT -> "compaction"
+  | EV_COMPACT_EVACUATE -> "compaction_evacuate"
+  | EV_COMPACT_FORWARD -> "compaction_forward"
+  | EV_COMPACT_RELEASE -> "compaction_release"
 
 let lifecycle_name lifecycle =
   match lifecycle with

ocaml/otherlibs/runtime_events/runtime_events.mli

@@ -130,6 +130,10 @@ type runtime_phase =
 | EV_MINOR_LOCAL_ROOTS_PROMOTE
 | EV_DOMAIN_CONDITION_WAIT
 | EV_DOMAIN_RESIZE_HEAP_RESERVATION
+| EV_COMPACT
+| EV_COMPACT_EVACUATE
+| EV_COMPACT_FORWARD
+| EV_COMPACT_RELEASE
 
 (** Lifecycle events for the ring itself *)
 type lifecycle =

ocaml/runtime/caml/compact.h

@@ -40,7 +40,6 @@
     (callback.h as caml/callback.h)
     (camlatomic.h as caml/camlatomic.h)
     (codefrag.h as caml/codefrag.h)
-    (compact.h as caml/compact.h)
     (compare.h as caml/compare.h)
     (config.h as caml/config.h)
     (custom.h as caml/custom.h)

ocaml/runtime/caml/dune

@@ -53,8 +53,10 @@ void caml_darken(void*, value, volatile value* ignored);
 void caml_darken_cont(value);
 void caml_mark_root(value, value*);
 void caml_empty_mark_stack(void);
-void caml_finish_major_cycle(void);
-
+void caml_finish_major_cycle(int force_compaction);
+#ifdef DEBUG
+int caml_mark_stack_is_empty(void);
+#endif
 /* Ephemerons and finalisers */
 void caml_orphan_allocated_words(void);
 void caml_add_to_orphaned_ephe_list(struct caml_ephe_info* ephe_info);

ocaml/runtime/caml/major_gc.h

@@ -108,7 +108,7 @@ extern void caml_print_timestamp(FILE* channel, int formatted);
 
 /* Memory management platform-specific operations */
 
-void *caml_plat_mem_map(uintnat, uintnat, int);
+void *caml_plat_mem_map(uintnat, int);
 void *caml_plat_mem_commit(void *, uintnat);
 void caml_plat_mem_decommit(void *, uintnat);
 void caml_plat_mem_unmap(void *, uintnat);

ocaml/runtime/caml/osdeps.h

@@ -122,13 +122,8 @@ uintnat caml_mem_round_up_pages(uintnat size);
 /* The size given to caml_mem_map and caml_mem_commit must be a multiple of
    caml_plat_pagesize. The size given to caml_mem_unmap and caml_mem_decommit
    must match the size given to caml_mem_map/caml_mem_commit for mem.
-
-   The Windows and Cygwin implementations do not support arbitrary alignment
-   and will fail for alignment values greater than caml_plat_mmap_alignment.
-   Luckily, this value is rather large on those platforms: 64KiB. This is enough
-   for all alignments used in the runtime system so far, the larger being the
-   major heap pools aligned on 32KiB boundaries. */
-void* caml_mem_map(uintnat size, uintnat alignment, int reserve_only);
+*/
+void* caml_mem_map(uintnat size, int reserve_only);
 void* caml_mem_commit(void* mem, uintnat size);
 void caml_mem_decommit(void* mem, uintnat size);
 void caml_mem_unmap(void* mem, uintnat size);

ocaml/runtime/caml/platform.h

@@ -110,7 +110,11 @@ typedef enum {
     EV_MINOR_REMEMBERED_SET_PROMOTE,
     EV_MINOR_LOCAL_ROOTS_PROMOTE,
     EV_DOMAIN_CONDITION_WAIT,
-    EV_DOMAIN_RESIZE_HEAP_RESERVATION
+    EV_DOMAIN_RESIZE_HEAP_RESERVATION,
+    EV_COMPACT,
+    EV_COMPACT_EVACUATE,
+    EV_COMPACT_FORWARD,
+    EV_COMPACT_RELEASE
 } ev_runtime_phase;
 
 typedef enum {

ocaml/runtime/caml/runtime_events.h

@@ -24,14 +24,16 @@
 #include "misc.h"
 #include "gc_stats.h"
 
+CAMLextern atomic_uintnat caml_compactions_count;
+
 struct caml_heap_state;
 struct pool;
 
 struct caml_heap_state* caml_init_shared_heap(void);
 void caml_teardown_shared_heap(struct caml_heap_state* heap);
 
 value* caml_shared_try_alloc(struct caml_heap_state*,
-                             mlsize_t, tag_t, reserved_t, int);
+                             mlsize_t, tag_t, reserved_t);
 
 /* Copy the domain-local heap stats into a heap stats sample. */
 void caml_collect_heap_stats_sample(
@@ -45,7 +47,9 @@ uintnat caml_heap_size(struct caml_heap_state*);
 uintnat caml_top_heap_words(struct caml_heap_state*);
 uintnat caml_heap_blocks(struct caml_heap_state*);
 
-struct pool* caml_pool_of_shared_block(value v);
+void caml_compact_heap(caml_domain_state* domain_state,
+                         int participating_count,
+                         caml_domain_state** participants);
 
 void caml_shared_unpin(value v);
 

ocaml/runtime/caml/shared_heap.h

@@ -3,13 +3,13 @@
 #define POOL_HEADER_WSIZE 4
 #define SIZECLASS_MAX 128
 #define NUM_SIZECLASSES 32
-static const unsigned int wsize_sizeclass[NUM_SIZECLASSES] = 
+static const unsigned int wsize_sizeclass[NUM_SIZECLASSES] =
 { 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 12, 14, 16, 18, 20, 23, 26, 29, 33, 37, 42,
   47, 53, 59, 65, 73, 81, 89, 99, 108, 118, 128 };
-static const unsigned char wastage_sizeclass[NUM_SIZECLASSES] = 
+static const unsigned char wastage_sizeclass[NUM_SIZECLASSES] =
 { 0, 0, 0, 0, 2, 0, 4, 4, 6, 2, 0, 4, 12, 6, 12, 21, 10, 3, 0, 22, 18, 3, 11,
   21, 62, 4, 42, 87, 33, 96, 80, 124 };
-static const unsigned char sizeclass_wsize[SIZECLASS_MAX + 1] = 
+static const unsigned char sizeclass_wsize[SIZECLASS_MAX + 1] =
 { 255, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 10, 11, 11, 12, 12, 13, 13, 14, 14,
   15, 15, 15, 16, 16, 16, 17, 17, 17, 18, 18, 18, 18, 19, 19, 19, 19, 20, 20,
   20, 20, 20, 21, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23,

ocaml/runtime/caml/sizeclasses.h

@@ -735,8 +735,7 @@ static void reserve_minor_heaps(void) {
   minor_heap_reservation_bsize = minor_heap_max_bsz * Max_domains;
 
   /* reserve memory space for minor heaps */
-  heaps_base = caml_mem_map(minor_heap_reservation_bsize, caml_plat_pagesize,
-                1 /* reserve_only */);
+  heaps_base = caml_mem_map(minor_heap_reservation_bsize, 1 /* reserve_only */);
   if (heaps_base == NULL)
     caml_fatal_error("Not enough heap memory to reserve minor heaps");
 
@@ -1747,7 +1746,7 @@ static void handover_finalisers(caml_domain_state* domain_state)
     if (caml_gc_phase != Phase_sweep_and_mark_main) {
       /* Force a major GC cycle to simplify constraints for
        * handing over finalisers. */
-      caml_finish_major_cycle();
+      caml_finish_major_cycle(0);
       CAMLassert(caml_gc_phase == Phase_sweep_and_mark_main);
     }
     caml_add_orphaned_finalisers (f);

ocaml/runtime/domain.c

@@ -56,11 +56,12 @@ CAMLprim value caml_gc_quick_stat(value v)
   CAMLlocal1 (res);
 
   /* get a copy of these before allocating anything... */
-  intnat majcoll, mincoll;
+  intnat majcoll, mincoll, compactions;
   struct gc_stats s;
   caml_compute_gc_stats(&s);
   majcoll = caml_major_cycles_completed;
   mincoll = atomic_load(&caml_minor_collections_count);
+  compactions = atomic_load(&caml_compactions_count);
 
   res = caml_alloc_tuple (17);
   Store_field (res, 0, caml_copy_double ((double)s.alloc_stats.minor_words));
@@ -81,7 +82,7 @@ CAMLprim value caml_gc_quick_stat(value v)
   Store_field (res, 10, Val_long (0));
   Store_field (res, 11, Val_long (0));
   Store_field (res, 12, Val_long (s.heap_stats.pool_frag_words));
-  Store_field (res, 13, Val_long (0));
+  Store_field (res, 13, Val_long (compactions));
   Store_field (res, 14, Val_long (
     s.heap_stats.pool_max_words + s.heap_stats.large_max_words));
   Store_field (res, 15, Val_long (0));
@@ -239,12 +240,12 @@ CAMLprim value caml_gc_minor(value v)
   return caml_raise_if_exception(exn);
 }
 
-static value gc_major_exn(void)
+static value gc_major_exn(int force_compaction)
 {
   CAML_EV_BEGIN(EV_EXPLICIT_GC_MAJOR);
   caml_gc_log ("Major GC cycle requested");
   caml_empty_minor_heaps_once();
-  caml_finish_major_cycle();
+  caml_finish_major_cycle(force_compaction);
   value exn = caml_process_pending_actions_exn();
   CAML_EV_END(EV_EXPLICIT_GC_MAJOR);
   return exn;
@@ -254,7 +255,7 @@ CAMLprim value caml_gc_major(value v)
 {
   Caml_check_caml_state();
   CAMLassert (v == Val_unit);
-  return caml_raise_if_exception(gc_major_exn());
+  return caml_raise_if_exception(gc_major_exn(0));
 }
 
 static value gc_full_major_exn(void)
@@ -267,7 +268,7 @@ static value gc_full_major_exn(void)
      currently-unreachable object to be collected. */
   for (i = 0; i < 3; i++) {
     caml_empty_minor_heaps_once();
-    caml_finish_major_cycle();
+    caml_finish_major_cycle(0);
     exn = caml_process_pending_actions_exn();
     if (Is_exception_result(exn)) break;
   }
@@ -296,13 +297,12 @@ CAMLprim value caml_gc_major_slice (value v)
 CAMLprim value caml_gc_compaction(value v)
 {
   Caml_check_caml_state();
-  value exn = Val_unit;
   CAML_EV_BEGIN(EV_EXPLICIT_GC_COMPACT);
   CAMLassert (v == Val_unit);
-  exn = gc_major_exn();
+  value exn = gc_major_exn(1);
   ++ Caml_state->stat_forced_major_collections;
   CAML_EV_END(EV_EXPLICIT_GC_COMPACT);
-  return exn;
+  return caml_raise_if_exception(exn);
 }
 
 CAMLprim value caml_gc_stat(value v)

ocaml/runtime/gc_ctrl.c

@@ -401,8 +401,7 @@ static value intern_alloc_obj(struct caml_intern_state* s, caml_domain_state* d,
     s->intern_dest += 1 + wosize;
   } else {
     p = caml_shared_try_alloc(d->shared_heap, wosize, tag,
-                              0, /* no reserved bits */
-                              0 /* not pinned */);
+                              0 /* no reserved bits */);
     d->allocated_words += Whsize_wosize(wosize);
     if (p == NULL) {
       intern_cleanup (s);