Make extension callbacks part of the public MPS

code/arenavm.c

@@ -428,6 +428,10 @@ static Bool vmChunkDestroy(Tree tree, void *closure)
 {
   Chunk chunk;
   VMChunk vmChunk;
+  Arena arena;
+  Addr base;
+  Size size;
+  VMArena vmArena;
 
   AVERT(Tree, tree);
   AVER(closure == UNUSED_POINTER);
@@ -437,8 +441,14 @@ static Bool vmChunkDestroy(Tree tree, void *closure)
   AVERT(Chunk, chunk);
   vmChunk = Chunk2VMChunk(chunk);
   AVERT(VMChunk, vmChunk);
+  arena = ChunkArena(chunk);
+  vmArena = MustBeA(VMArena, arena);
+  base = chunk->base;
+  size = ChunkSize(chunk);
 
-  (void)vmArenaUnmapSpare(ChunkArena(chunk), ChunkSize(chunk), chunk);
+  (*vmArena->contracted)(arena, base, size);
+
+  (void)vmArenaUnmapSpare(arena, size, chunk);
 
   SparseArrayFinish(&vmChunk->pages);
 
@@ -778,6 +788,7 @@ static void VMArenaDestroy(Arena arena)
    * <design/arena#.chunk.delete> */
   arena->primary = NULL;
   TreeTraverseAndDelete(&arena->chunkTree, vmChunkDestroy, UNUSED_POINTER);
+  AVER(arena->chunkTree == TreeEMPTY);
 
   /* Must wait until the chunks are destroyed, since vmChunkDestroy
      calls vmArenaUnmapSpare which uses the spare land. */
@@ -1223,7 +1234,6 @@ static Bool vmChunkCompact(Tree tree, void *closure)
 {
   Chunk chunk;
   Arena arena = closure;
-  VMArena vmArena = MustBeA(VMArena, arena);
 
   AVERT(Tree, tree);
 
@@ -1232,11 +1242,6 @@ static Bool vmChunkCompact(Tree tree, void *closure)
   if(chunk != arena->primary
      && BTIsResRange(chunk->allocTable, 0, chunk->pages))
   {
-    Addr base = chunk->base;
-    Size size = ChunkSize(chunk);
-    /* Callback before destroying the chunk, as the arena is (briefly)
-       invalid afterwards. See job003893. */
-    (*vmArena->contracted)(arena, base, size);
     vmChunkDestroy(tree, UNUSED_POINTER);
     return TRUE;
   } else {

code/comm.gmk

@@ -267,6 +267,7 @@ TEST_TARGETS=\
     btcv \
     bttest \
     djbench \
+    extcon \
     finalcv \
     finaltest \
     forktest \
@@ -487,6 +488,9 @@ $(PFM)/$(VARIETY)/bttest: $(PFM)/$(VARIETY)/bttest.o \
 $(PFM)/$(VARIETY)/djbench: $(PFM)/$(VARIETY)/djbench.o \
 	$(TESTLIBOBJ) $(TESTTHROBJ)
 
+$(PFM)/$(VARIETY)/extcon: $(PFM)/$(VARIETY)/extcon.o \
+	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
+
 $(PFM)/$(VARIETY)/finalcv: $(PFM)/$(VARIETY)/finalcv.o \
 	$(FMTDYTSTOBJ) $(TESTLIBOBJ) $(PFM)/$(VARIETY)/mps.a
 

code/commpost.nmk

@@ -225,6 +225,9 @@ $(PFM)\$(VARIETY)\cvmicv.exe: $(PFM)\$(VARIETY)\cvmicv.obj \
 $(PFM)\$(VARIETY)\djbench.exe: $(PFM)\$(VARIETY)\djbench.obj \
 	$(TESTLIBOBJ) $(TESTTHROBJ)
 
+$(PFM)\$(VARIETY)\extcon.exe: $(PFM)\$(VARIETY)\extcon.obj \
+	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
+
 $(PFM)\$(VARIETY)\finalcv.exe: $(PFM)\$(VARIETY)\finalcv.obj \
 	$(PFM)\$(VARIETY)\mps.lib $(FMTTESTOBJ) $(TESTLIBOBJ)
 

code/commpre.nmk

@@ -73,6 +73,7 @@ TEST_TARGETS=\
     btcv.exe \
     bttest.exe \
     djbench.exe \
+    extcon.exe \
     finalcv.exe \
     finaltest.exe \
     fotest.exe \

code/extcon.c

@@ -0,0 +1,306 @@
+/* extcon.c: ARENA EXTENDED AND CONTRACTED CALLBACK TEST
+ *
+ * $Id$
+ * Copyright (c) 2022-2023 Ravenbrook Limited.  See end of file for license.
+ *
+ * .overview: This test case allocates a bunch of large objects, of a size 
+ * similar to the size of the arena, to force the arena to extend. It then
+ * discards the base pointers to those objects, and forces a collection.
+ *
+ * .limitations: This test checks that the EXTENDED and CONTRACTED
+ * callbacks were called at least once, and that they are called the
+ * same number of times. It does not check that the extensions and
+ * contractions themselves were performed correctly, nor does it check
+ * that an appropriate number of extensions and contractions took
+ * place, nor does it check that they took place at sensible times.
+ *
+ * .dylan: This test uses Dylan format objects in common with most
+ * other tests for convenience and brevity.
+ */
+
+#include "mps.h"
+#include "testlib.h"
+#include "fmtdy.h"
+#include "fmtdytst.h"
+#include "mpsavm.h"
+#include "mpscamc.h"
+#include <stdio.h>
+#include <stdlib.h>
+
+/* Number of test objects to allocate */
+#define N_TESTOBJ 100
+/* The number of slots determines the size of each object */
+#define N_SLOT_TESTOBJ 10000
+/* The initial arena size is requested to be bigger the test object by
+   this many bytes */
+#define SIZEDIFF 10
+
+/* Set alignment to mps_word_ts */
+#define ALIGNMENT sizeof(mps_word_t)
+
+/* Align size upwards to the next multiple of the word size. */
+#define ALIGN_WORD(size) \
+    (((size) + ALIGNMENT - 1) & ~(ALIGNMENT - 1))
+
+/* Global objects*/
+static mps_arena_t arena;       /* the arena */
+static mps_pool_t obj_pool;     /* pool for test objects */
+static mps_ap_t obj_ap;         /* allocation point used to allocate objects */
+
+/* Count of number of arena contractions and extensions */
+static int n_contract = 0;
+static int n_extend = 0;
+
+/* Callback functions for arena extension and contraction */
+static void arena_extended_cb(mps_arena_t arena_in, mps_addr_t addr, size_t size)
+{
+  testlib_unused(arena_in);
+  testlib_unused(addr);
+  testlib_unused(size);
+  printf("Arena extended by %"PRIuLONGEST" bytes\n", (ulongest_t)size);
+  n_extend++;
+}
+
+static void arena_contracted_cb(mps_arena_t arena_in, mps_addr_t addr, size_t size)
+{
+  testlib_unused(arena_in);
+  testlib_unused(addr);
+  testlib_unused(size);
+  printf("Arena contracted by %"PRIuLONGEST" bytes\n", (ulongest_t)size);
+  n_contract++;
+}
+
+/* Messages for testbench debugging */
+static void print_messages(void)
+{
+  mps_message_type_t type;
+
+  while (mps_message_queue_type(&type, arena)) {
+    mps_message_t message;
+
+    cdie(mps_message_get(&message, arena, type),
+         "get");
+
+    switch(type) {
+      case mps_message_type_gc_start():
+        printf("GC start at %"PRIuLONGEST": %s\n",
+               (ulongest_t)mps_message_clock(arena, message),
+               mps_message_gc_start_why(arena, message));
+        break;
+
+      case mps_message_type_gc():
+        printf("GC end at %"PRIuLONGEST" "
+               "condemned %"PRIuLONGEST" "
+               "not condemned %"PRIuLONGEST" "
+               "live %"PRIuLONGEST"\n",
+               (ulongest_t)mps_message_clock(arena, message),
+               (ulongest_t)mps_message_gc_condemned_size(arena, message),
+               (ulongest_t)mps_message_gc_not_condemned_size(arena, message),
+               (ulongest_t)mps_message_gc_live_size(arena, message));
+        break;
+
+      default:
+        cdie(0, "message type");
+        break;
+    }
+
+    mps_message_discard(arena, message);
+  }
+}
+
+/* Disabling inlining is necessary (but perhaps not sufficient) if using stack roots.
+   See comment below with link to GitHub issue*/
+ATTRIBUTE_NOINLINE
+static void test_main(void *cold_stack_end)
+{
+  mps_fmt_t obj_fmt;
+  mps_thr_t thread;
+  mps_root_t stack_root, testobj_root;
+  size_t arena_size, obj_size;
+  int i;
+  /* In the original version of extcon this was a stack root, but we
+     observed unreliable failures to do with registering the cold end
+     of the stack.  See GitHub issue #210
+     <https://github.com/Ravenbrook/mps/issues/210>.  For now, we
+     declare this as a separate root. */
+  static mps_word_t testobj[N_TESTOBJ];
+
+  /* The testobj array must be below (on all current Posix platforms)
+     the cold end of the stack in order for the MPS to scan it.  We
+     have observed a Heisenbug where GCC will inline test_main into
+     main and lose this condition if the expression below is removed.
+     This is a problem we are analysing in GitHub issue #210
+     <https://github.com/Ravenbrook/mps/issues/210>.  For now, we
+     disable this Insist to allow the test to run with a static
+     testobj array. */
+#if 0
+  Insist((void *)&testobj[N_TESTOBJ] <= cold_stack_end);
+  if ((void *)&testobj[N_TESTOBJ] > cold_stack_end)
+    printf("Cold stack marker invalid!\n");
+  else
+    printf("Cold stack marker probably valid.\n");
+#endif
+
+  /* Make initial arena size slightly bigger than the test object size to force an extension as early as possible */
+  /* See definition of make_dylan_vector() in fmtdytst.c for calculation of vector size */  
+  obj_size = ALIGN_WORD((N_SLOT_TESTOBJ + 2) * sizeof(mps_word_t));
+  arena_size = ALIGN_WORD(obj_size + SIZEDIFF);
+
+  /* Create arena and register callbacks */
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_SIZE, arena_size);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_EXTENDED, (mps_fun_t)&arena_extended_cb);
+    MPS_ARGS_ADD(args, MPS_KEY_ARENA_CONTRACTED, (mps_fun_t)&arena_contracted_cb);
+    die(mps_arena_create_k(&arena, mps_arena_class_vm(), args), "mps_arena_create_k");
+  } MPS_ARGS_END(args);
+
+  printf("Initial reservation %"PRIuLONGEST".\n", (ulongest_t)mps_arena_reserved(arena));
+
+  die(dylan_fmt(&obj_fmt, arena), "dylan_fmt()");
+
+  /* Create new pool */
+  MPS_ARGS_BEGIN(args) {
+    MPS_ARGS_ADD(args, MPS_KEY_FORMAT, obj_fmt);
+    die(mps_pool_create_k(&obj_pool, arena, mps_class_amcz(), args),
+      "mps_pool_create_k");
+  } MPS_ARGS_END(args);
+
+  /* Register thread */
+  die(mps_thread_reg(&thread, arena), "Thread reg");
+
+  /* Register stack roots */
+  /* Since this testbench is currently not using a stack root, #IF 0 this out */
+  testlib_unused(cold_stack_end);
+  testlib_unused(stack_root);
+#if 0
+  die(mps_root_create_thread(&stack_root, arena, thread, cold_stack_end), "Create Stack root");
+#endif
+
+  /* Register ambiguous array of object roots. */
+  die(mps_root_create_area(&testobj_root, arena,
+                            mps_rank_ambig(), (mps_rm_t)0,
+                            &testobj[0], &testobj[N_TESTOBJ],
+                            mps_scan_area, NULL),
+      "root_create_area(testobj)");
+
+  /* Create allocation point */
+  die(mps_ap_create_k(&obj_ap, obj_pool, mps_args_none), "Create Allocation point");
+
+  mps_message_type_enable(arena, mps_message_type_gc_start());
+  mps_message_type_enable(arena, mps_message_type_gc());
+
+  /* Allocate objects and force arena extension */
+  for (i = 0; i < N_TESTOBJ; i++) {
+
+    die(make_dylan_vector(&testobj[i], obj_ap, N_SLOT_TESTOBJ), "make_dylan_vector"); 
+
+    printf("Object %d committed.  "
+           "Arena reserved: %"PRIuLONGEST".\n",
+           i,
+           (ulongest_t)mps_arena_reserved(arena));
+
+    print_messages();
+  }
+
+  /* overwrite all the references to the objects*/
+  for (i = 0; i < N_TESTOBJ; i++) {
+
+    /* bonus test of mps_addr_object */
+#if 0 /* Comment this out until mps_addr_object becomes available. */
+    mps_addr_t out;
+    Insist(N_TESTOBJ <= N_INT_TESTOBJ);
+
+    /* use "i" to as a convenient way to generate different interior pointers
+       To guarantee the i index will give us an interior pointer the number of test
+       objects must be <= the number of integers in each object */
+    Insist(N_TESTOBJ <= N_INT_TESTOBJ);
+    die(mps_addr_object(&out, arena, &(testobj[i])->int_array[i]), "Address object");
+
+    Insist(out == testobj[i]);
+
+    /* end piggy back testbench */
+#endif
+
+    /* now overwrite the ref */
+    testobj[i] = (mps_word_t)NULL;
+
+    print_messages();
+  }
+
+  /* Collect */
+  mps_arena_collect(arena);
+
+  print_messages();
+
+  /* Clean up */
+  mps_root_destroy(testobj_root);
+  /* mps_root_destroy(stack_root);*/ /*commented out while not using stack root */
+  mps_thread_dereg(thread);
+  mps_ap_destroy(obj_ap);
+  mps_pool_destroy(obj_pool);
+  mps_fmt_destroy(obj_fmt);
+  mps_arena_destroy(arena);
+
+  /* Destroying the arena should cause contraction callbacks on all
+     remaining chunks, even if they had contents. */
+  Insist(n_extend == n_contract);
+
+  printf("Arena extended %d times\n", n_extend);
+  printf("Arena contracted %d times\n", n_contract);
+
+  /* comment out some diagnostics for investigating issue #210 mentioned above */
+#if 0
+  printf("&testobj[N_TESTOBJ] = %p\n", (void *)&testobj[N_TESTOBJ]);
+  printf("cold_stack_end = %p\n", cold_stack_end);
+#endif
+  if (n_extend == 0) 
+    printf("No callbacks received upon arena extended!\n");
+  if (n_contract == 0)
+    printf("No callbacks received upon arena contracted!\n");
+
+  if (n_contract == 0 || n_extend == 0)
+    exit(EXIT_FAILURE);
+}
+
+int main(int argc, char* argv[])
+{
+  void *stack_marker = &stack_marker;
+
+  testlib_init(argc, argv);
+
+  test_main(stack_marker);
+
+  printf("%s: Conclusion: Failed to find any defects.\n", argv[0]);
+
+  return 0;
+}
+
+
+/* C. COPYRIGHT AND LICENSE
+ *
+ * Copyright (C) 2022-2023 Ravenbrook Limited <https://www.ravenbrook.com/>.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright
+ *    notice, this list of conditions and the following disclaimer in the
+ *    documentation and/or other materials provided with the
+ *    distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+ * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+ * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ * HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */