Initial support static heaps in MaPLe

MLton/mlton#357 (revising MLton/mlton#328) introduced a number of "static heaps"
into the compilation.  Essentially, many "global" objects can be fully evaluated
at compile time and represented in the compiled program as statics.  The
"static" objects look like regular ML objects (with proper headers, etc.), but
exist outside the MLton heap.

This is a "path of least resistance" commit for MaPLe.  The
`collectStatics.Globals` and `collectStatics.RealConsts` passes are disabled,
but the `collectStatics.WordXVectorConsts` pass is enabled.  In the `backend`
pass (translation of RSSA to Machine), all RSSA statics are forced to the
`Dynamic` static heap (and assigned a corresponding global objptr slot);
similarly, any remaining `WordXVector` constants are forced to the `Dynamic`
static heap.  At program startup, the `Dynamic` static heap is copied into the
root hierarchical heap.  (This is slightly more complicated than the copy of the
`Dynamic` static heap into the initial heap in MLton, because in MaPLe the
`Dynamic` static heap may need to be split across multiple chunks.)

See MPLLang#127 for more discussion.

mlton/backend/backend.fun

@@ -373,14 +373,14 @@ fun toMachine (rssa: Rssa.Program.t) =
                    ({offset = offset, src = src},
                     hasDynamic' orelse hasDynamic)
                 end)
-            fun translateObject obj =
+            fun translateObject (obj, {forceDynamic}) =
                case obj of
                   R.Object.Normal {init, tycon} =>
                      let
                         val {components, ...} = ObjectType.deNormal (tyconTy tycon)
                         val (init, hasDynamic) = translateInit init
                         val kind =
-                           if hasDynamic
+                           if forceDynamic orelse hasDynamic
                               then Kind.Dynamic
                               else if Prod.someIsMutable components
                                       then if Vector.exists (Prod.dest components,
@@ -414,7 +414,7 @@ fun toMachine (rssa: Rssa.Program.t) =
                                (init, hasDynamic' orelse hasDynamic)
                             end)
                         val kind =
-                           if hasDynamic
+                           if forceDynamic orelse hasDynamic
                               then Kind.Dynamic
                               else if hasIdentity
                                       then if Vector.isEmpty init
@@ -448,10 +448,10 @@ fun toMachine (rssa: Rssa.Program.t) =
                                          nextIndex = Counter.generator 0,
                                          nextOffset = ref Bytes.zero})
 
-            fun add obj =
+            fun add (obj, forceDynamic) =
                let
                   val {kind, obj, offset, size, tycon} =
-                     translateObject obj
+                     translateObject (obj, forceDynamic)
                   val {objs, nextIndex, nextOffset} = kindAcc kind
                   val r = Ref.T {index = nextIndex (),
                                  kind = kind,
@@ -481,7 +481,7 @@ fun toMachine (rssa: Rssa.Program.t) =
 
       val () = Vector.foreach (statics, fn {dst = (dstVar, dstTy), obj} =>
                                let
-                                  val oper = addToStaticHeaps obj
+                                  val oper = addToStaticHeaps (obj, {forceDynamic = true})
                                in
                                   setVarInfo (dstVar, {operand = VarOperand.Const oper, ty = dstTy})
                                end)
@@ -519,7 +519,10 @@ fun toMachine (rssa: Rssa.Program.t) =
          val globalWordVector =
             make {equals = WordXVector.equals,
                   hash = WordXVector.hash,
-                  oper = addToStaticHeaps o R.Object.fromWordXVector}
+                  oper = (fn wxv =>
+                          addToStaticHeaps
+                          (R.Object.fromWordXVector wxv,
+                           {forceDynamic = true}))}
       end
       fun constOperand (c: Const.t): M.Operand.t =
          let

mlton/backend/rssa-simplify.fun

@@ -23,10 +23,10 @@ val rssaPasses =
     execute = true} ::
    {name = "collectStatics.Globals",
     doit = CollectStatics.Globals.transform,
-    execute = true} ::
+    execute = false} ::
    {name = "collectStatics.RealConsts",
     doit = CollectStatics.RealConsts.transform,
-    execute = true} ::
+    execute = false} ::
    {name = "insertLimitChecks", doit = LimitCheck.transform, execute = true} ::
    {name = "insertSignalChecks", doit = SignalCheck.transform, execute = true} ::
    (* must be before implementHandlers *)

runtime/gc/init-world.c

@@ -22,123 +22,104 @@ size_t sizeofInitialBytesLive (GC_state s) {
 }
 
 void initDynHeap(GC_state s, GC_thread thread) {
+  assert(0 == thread->currentDepth);
+
+  HM_chunk currentChunk;
+  pointer frontier, limit;
+  pointer start = s->staticHeaps.dynamic.start;
+  pointer end = start + s->staticHeaps.dynamic.size;
+  pointer p = start;
+  size_t metaDataSize = 0, objectSize = 0;
+
+  // While there are segments of the initial dynamic heap to be copied
+  // into the root hierarchical heap.
+  while (1) {
+    currentChunk = thread->currentChunk;
+    frontier = HM_getChunkFrontier(currentChunk);
+    assert(isFrontierAligned(s, frontier));
+    limit = HM_getChunkLimit(currentChunk);
+    assert(frontier <= limit);
+
+    // Find the end of this segement of the initial dynamic heap to
+    // copy into the current chunk of the root hierarchical heap.
+    // `start` is the start of the segment.
+    // `p` is the candidate end of segment.
+    while (1) {
+      if (p >= end) {
+        // This segment is the last to be copied.
+        break;
+      }
+      pointer q = advanceToObjectData (s, p);
+#if ASSERT
+      GC_header header = getHeader (q);
+      assert (header == GC_REAL32_VECTOR_HEADER
+              || header == GC_REAL64_VECTOR_HEADER
+              || header == GC_WORD8_VECTOR_HEADER
+              || header == GC_WORD16_VECTOR_HEADER
+              || header == GC_WORD32_VECTOR_HEADER
+              || header == GC_WORD64_VECTOR_HEADER);
+#endif
+      sizeofObjectAux (s, q, &metaDataSize, &objectSize);
+      pointer r = q + objectSize;
+      if (!inFirstBlockOfChunk(currentChunk, frontier + (q - start))
+          || frontier + (r - start) > limit) {
+        // Next object does not fit into current chunk.
+        break;
+      }
+      // Next object fits into current chunk; advance `p`.
+      p = r;
+    }
+
+    // Copy segment `[start,p)` into current segment.
+    memcpy (frontier, start, p - start);
+    // Adjust global objptrs that referenced an object in the segment.
+    for (uint32_t i = 0; i < s->globalsLength; i++) {
+      pointer g = objptrToPointer(s->globals[i], NULL);
+      if (start <= g && g < p) {
+        g = (g - start) + frontier;
+        s->globals[i] = pointerToObjptr(g, NULL);
+      }
+    }
+    // Advance frontier.
+    frontier += p - start;
+    HM_updateChunkValues(currentChunk, frontier);
+
+    if (p >= end) {
+      // This segment was the last to be copied.
+      break;
+    }
+
+    // Initialize search for next segment.
+    start = p;
+    // `p` points to the beginning of an object that did not fit in
+    // the last chunk; extend hierarchical heap with a chunk
+    // sufficient to hold the next object.
+    if (!HM_HH_extend(s, thread, metaDataSize + objectSize)) {
+      DIE("Ran out of space for Hierarchical Heap!");
+    }
+  }
+
+  /* If the last allocation passed a block boundary, we need to extend to have
+   * a valid frontier. Extending with GC_HEAP_LIMIT_SLOP is arbitrary. */
+  if (!inFirstBlockOfChunk(currentChunk, frontier + GC_SEQUENCE_METADATA_SIZE)) {
+    if (!HM_HH_extend(s, thread, GC_HEAP_LIMIT_SLOP)) {
+      DIE("Ran out of space for Hierarchical Heap!");
+    }
+    currentChunk = thread->currentChunk;
+    frontier = HM_getChunkFrontier(currentChunk);
+    assert(isFrontierAligned(s, frontier));
+    limit = HM_getChunkLimit(currentChunk);
+    assert(frontier <= limit);
+  }
+
+  s->frontier = frontier;
+  s->limitPlusSlop = limit;
+  s->limit = s->limitPlusSlop - GC_HEAP_LIMIT_SLOP;
 
+  assert(isFrontierAligned(s, s->frontier));
+  assert(inFirstBlockOfChunk(currentChunk, s->frontier + GC_SEQUENCE_METADATA_SIZE));
 }
 
-/* void initVectors(GC_state s, GC_thread thread) { */
-/*   struct GC_vectorInit *inits; */
-/*   HM_chunk currentChunk; */
-/*   pointer frontier; */
-/*   pointer limit; */
-/*   uint32_t i; */
-
-/*   assert(isFrontierAligned(s, s->frontier)); */
-/*   inits = s->vectorInits; */
-/*   frontier = s->frontier; */
-/*   limit = s->limitPlusSlop; */
-
-/*   currentChunk = HM_getChunkOf(frontier); */
-/*   assert(currentChunk == thread->currentChunk); */
-/*   assert(0 == thread->currentDepth); */
-
-/*   for (i = 0; i < s->vectorInitsLength; i++) { */
-/*     size_t elementSize; */
-/*     size_t dataBytes; */
-/*     size_t objectSize; */
-/*     uint32_t typeIndex; */
-
-/*     elementSize = inits[i].elementSize; */
-/*     dataBytes = elementSize * inits[i].length; */
-/*     objectSize = align(GC_SEQUENCE_METADATA_SIZE + dataBytes, s->alignment); */
-
-/* #if ASSERT */
-/*     assert(limit == HM_getChunkLimit(currentChunk)); */
-/*     assert(frontier >= HM_getChunkFrontier(currentChunk)); */
-/*     assert(frontier <= limit); */
-/* #endif */
-
-/*     /\* Extend with a new chunk, if there is not enough free space or if we have */
-/*      * crossed a block boundary. *\/ */
-/*     if ((size_t)(limit - frontier) < objectSize || */
-/*         !inFirstBlockOfChunk(currentChunk, frontier + GC_SEQUENCE_METADATA_SIZE)) */
-/*     { */
-/*       HM_HH_updateValues(thread, frontier); */
-/*       if (!HM_HH_extend(s, thread, objectSize)) { */
-/*         DIE("Ran out of space for Hierarchical Heap!"); */
-/*       } */
-/*       s->frontier = HM_HH_getFrontier(thread); */
-/*       s->limitPlusSlop = HM_HH_getLimit(thread); */
-/*       s->limit = s->limitPlusSlop - GC_HEAP_LIMIT_SLOP; */
-
-/*       frontier = s->frontier; */
-/*       limit = s->limitPlusSlop; */
-
-/*       currentChunk = HM_getChunkOf(frontier); */
-/*       assert(currentChunk == thread->currentChunk); */
-/*     } */
-
-/*     assert(isFrontierAligned(s, frontier)); */
-/*     assert((size_t)(limit - frontier) >= objectSize); */
-/*     assert(inFirstBlockOfChunk(currentChunk, frontier + GC_SEQUENCE_METADATA_SIZE)); */
-
-/*     *((GC_sequenceCounter*)(frontier)) = 0; */
-/*     frontier = frontier + GC_SEQUENCE_COUNTER_SIZE; */
-/*     *((GC_sequenceLength*)(frontier)) = inits[i].length; */
-/*     frontier = frontier + GC_SEQUENCE_LENGTH_SIZE; */
-/*     switch (elementSize) { */
-/*     case 1: */
-/*       typeIndex = WORD8_VECTOR_TYPE_INDEX; */
-/*       break; */
-/*     case 2: */
-/*       typeIndex = WORD16_VECTOR_TYPE_INDEX; */
-/*       break; */
-/*     case 4: */
-/*       typeIndex = WORD32_VECTOR_TYPE_INDEX; */
-/*       break; */
-/*     case 8: */
-/*       typeIndex = WORD64_VECTOR_TYPE_INDEX; */
-/*       break; */
-/*     default: */
-/*       die ("unknown element size in vectorInit: %"PRIuMAX"", */
-/*            (uintmax_t)elementSize); */
-/*     } */
-/*     *((GC_header*)(frontier)) = buildHeaderFromTypeIndex (typeIndex); */
-/*     frontier = frontier + GC_HEADER_SIZE; */
-/*     // *((objptr*)(frontier)) = BOGUS_OBJPTR; */
-/*     // frontier = frontier + OBJPTR_SIZE; */
-/*     s->globals[inits[i].globalIndex] = pointerToObjptr(frontier, NULL); */
-/*     if (DEBUG_DETAILED) */
-/*       fprintf (stderr, "allocated vector at "FMTPTR"\n", */
-/*                (uintptr_t)(s->globals[inits[i].globalIndex])); */
-/*     memcpy (frontier, inits[i].words, dataBytes); */
-/*     frontier += objectSize - GC_SEQUENCE_METADATA_SIZE; */
-/*   } */
-
-/*   s->frontier = frontier; */
-
-/*   /\* If the last allocation passed a block boundary, we need to extend to have */
-/*    * a valid frontier. Extending with GC_HEAP_LIMIT_SLOP is arbitrary. *\/ */
-/*   if (!inFirstBlockOfChunk(currentChunk, frontier + GC_SEQUENCE_METADATA_SIZE)) */
-/*   { */
-/*     HM_HH_updateValues(thread, frontier); */
-/*     if (!HM_HH_extend(s, thread, GC_HEAP_LIMIT_SLOP)) { */
-/*       DIE("Ran out of space for Hierarchical Heap!"); */
-/*     } */
-/*     s->frontier = HM_HH_getFrontier(thread); */
-/*     s->limitPlusSlop = HM_HH_getLimit(thread); */
-/*     s->limit = s->limitPlusSlop - GC_HEAP_LIMIT_SLOP; */
-
-/*     frontier = s->frontier; */
-/*     limit = s->limitPlusSlop; */
-
-/*     currentChunk = HM_getChunkOf(frontier); */
-/*     assert(currentChunk == thread->currentChunk); */
-/*   } */
-
-/*   assert(isFrontierAligned(s, s->frontier)); */
-/*   assert(inFirstBlockOfChunk(currentChunk, s->frontier + GC_SEQUENCE_METADATA_SIZE)); */
-/* } */
-
 GC_thread initThreadAndHeap(GC_state s, uint32_t depth) {
   GC_thread thread = newThreadWithHeap(s, sizeofStackInitialReserved(s), depth);