GitLab

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

a48dcdf3

by Duncan Coutts at 2025-07-07T20:45:18-04:00

Reorganise documentation for allocate* functions

Consolodate interface information into the .h file, keeping just
implementation details in the .c file.

Use Notes stlye in the .h file and refer to notes from the .c file.

de5b528c

by Duncan Coutts at 2025-07-07T20:45:18-04:00

Introduce common utilities for allocating arrays

The intention is to share code among the several places that do this
already.

b321319d

by Duncan Coutts at 2025-07-07T20:45:18-04:00

Use new array alloc utils in Heap.c

The CMM primop can now report heap overflow.

1d557ffb

by Duncan Coutts at 2025-07-07T20:45:18-04:00

Use new array alloc utils in ThreadLabels.c

Replacing a local utility.

e59a1430

by Duncan Coutts at 2025-07-07T20:45:18-04:00

Use new array alloc utils in Threads.c

Replacing local open coded version.

482df1c9

by Duncan Coutts at 2025-07-07T20:45:18-04:00

Add exitHeapOverflow helper utility

This will be useful with the array alloc functions, since unlike
allocate/allocateMaybeFail, they do not come in two versions. So if it's
not convenient to propagate failure, then one can use this.

4d3ec8f9

by Duncan Coutts at 2025-07-07T20:45:18-04:00

Use new array alloc utils in Weak.c

Also add a cpp macro CCS_SYSTEM_OR_NULL which does what it says. The
benefit of this is that it allows us to referece CCS_SYSTEM even when
we're not in PROFILING mode. That makes abstracting over profiling vs
normal mode a lot easier.

0c4f2fde

by Duncan Coutts at 2025-07-07T20:45:18-04:00

Convert the array alloc primops to use the new array alloc utils

a3354ad9

by Duncan Coutts at 2025-07-07T20:45:18-04:00

While we're at it, add one missing 'likely' hint

To a cmm primops that raises an exception, like the others now do.

Changes:

rts/AllocArray.c

 +#include "rts/PosixSource.h"
 +#include "Rts.h"
++
 +#include "AllocArray.h"
++
 +StgMutArrPtrs *allocateMutArrPtrs (Capability *cap,
 +                                   StgWord nelements,
 +                                   CostCentreStack *ccs USED_IF_PROFILING)
 +{
 +    /* All sizes in words */
++
 +    /* The card table contains one byte for each 2^MUT_ARR_PTRS_CARD_BITS words
 +     * in the array, making sure we round up, and then rounding up to a whole
 +     * number of words. */
 +    StgWord cardsize = mutArrPtrsCardTableSize(nelements); /* card table */
 +    StgWord arrsize  = nelements + cardsize;               /* +array size */
 +    StgWord objsize  = sizeofW(StgMutArrPtrs) + arrsize;   /* +header size */
 +    StgMutArrPtrs *arr;
 +    arr = (StgMutArrPtrs *)allocateMightFail(cap, objsize);
 +    if (RTS_UNLIKELY(arr == NULL)) return NULL;
 +    TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), arrsize, 0);
++
 +    /* No write barrier needed since this is a new allocation. */
 +    SET_HDR(arr, &stg_MUT_ARR_PTRS_DIRTY_info, ccs);
 +    arr->ptrs = nelements;
 +    arr->size = arrsize;
++
 +    /* Initialize the card array. Note that memset needs sizes in bytes. */
 +    memset(&(arr->payload[nelements]), 0, mutArrPtrsCards(nelements));
++
 +    return arr;
 +}
++
 +StgSmallMutArrPtrs *allocateSmallMutArrPtrs (Capability *cap,
 +                                             StgWord nelements,
 +                                             CostCentreStack *ccs
 +                                               USED_IF_PROFILING)
 +{
 +    /* All sizes in words */
 +    StgWord arrsize = nelements;                              /* array size */
 +    StgWord objsize = sizeofW(StgSmallMutArrPtrs) + arrsize;  /* +header size */
 +    StgSmallMutArrPtrs *arr;
 +    arr = (StgSmallMutArrPtrs *)allocateMightFail(cap, objsize);
 +    if (RTS_UNLIKELY(arr == NULL)) return NULL;
 +    TICK_ALLOC_PRIM(sizeofW(StgSmallMutArrPtrs), arrsize, 0);
++
 +    /* No write barrier needed since this is a new allocation. */
 +    SET_HDR(arr, &stg_SMALL_MUT_ARR_PTRS_DIRTY_info, ccs);
 +    arr->ptrs = nelements;
 +    return arr;
 +}
++
 +StgArrBytes *allocateArrBytes (Capability *cap,
 +                               StgWord arrbytes,
 +                               CostCentreStack *ccs USED_IF_PROFILING)
 +{
 +    /* All sizes in words */
 +    StgWord arrwords = ROUNDUP_BYTES_TO_WDS(arrbytes);
 +    StgWord objsize  = sizeofW(StgArrBytes) + arrwords;
 +    StgArrBytes *arr;
 +    arr = (StgArrBytes *)allocateMightFail(cap, objsize);
 +    if (RTS_UNLIKELY(arr == NULL)) return NULL;
 +    TICK_ALLOC_PRIM(sizeofW(StgArrBytes), arrwords, 0);
 +    /* No write barrier needed since this is a new allocation. */
 +    SET_HDR(arr, &stg_ARR_WORDS_info, ccs);
 +    arr->bytes = arrbytes;
 +    return arr;
 +}
++
 +StgArrBytes *allocateArrBytesPinned (Capability *cap,
 +                                     StgWord arrbytes,
 +                                     StgWord alignment,
 +                                     CostCentreStack *ccs USED_IF_PROFILING)
 +{
 +    /* we always supply at least word-aligned memory, so there's no
 +       need to allow extra space for alignment if the requirement is less
 +       than a word.  This also prevents mischief with alignment == 0. */
 +    if (alignment <= sizeof(StgWord)) { alignment = sizeof(StgWord); }
++
 +    /* All sizes in words */
 +    StgWord arrwords = ROUNDUP_BYTES_TO_WDS(arrbytes);
 +    StgWord objsize  = sizeofW(StgArrBytes) + arrwords;
 +    StgWord alignoff = sizeof(StgArrBytes); // it's the payload to be aligned
 +    StgArrBytes *arr;
 +    arr = (StgArrBytes *)allocatePinned(cap, objsize, alignment, alignoff);
 +    if (RTS_UNLIKELY(arr == NULL)) return NULL;
 +    TICK_ALLOC_PRIM(sizeofW(StgArrBytes), arrwords, 0);
 +    /* No write barrier needed since this is a new allocation. */
 +    SET_HDR(arr, &stg_ARR_WORDS_info, ccs);
 +    arr->bytes = arrbytes;
 +    return arr;
 +}

rts/AllocArray.h

 +/* -----------------------------------------------------------------------------
 + *
 + * (c) The GHC Team 2025
 + *
 + * Prototypes for functions in AllocArray.c
 + *
 + * RTS internal utilities for allocating arrays of pointers (StgMutArrPtrs) and
 + * arrays of bytes (StgArrBytes).
 + * -------------------------------------------------------------------------*/
++
 +#pragma once
++
 +#include "Capability.h"
++
 +#include "BeginPrivate.h"
++
 +/* All these allocation functions return NULL on failure. If the context
 + * allows, then propagatethe failure upwards, e.g. to a CMM primop where a
 + * heap overflow exception can be thrown. Otherwise, use:
 + *   if (RTS_UNLIKELY(p == NULL)) exitHeapOverflow();
 + */
++
 +/* Allocate a StgMutArrPtrs for a given number of elements. It is allocated in
 + * the DIRTY state.
 + */
 +StgMutArrPtrs *allocateMutArrPtrs (Capability *cap,
 +                                   StgWord nelements,
 +                                   CostCentreStack *ccs);
++
 +/* Allocate a StgSmallMutArrPtrs for a given number of elements.
 + */
 +StgSmallMutArrPtrs *allocateSmallMutArrPtrs (Capability *cap,
 +                                             StgWord nelements,
 +                                             CostCentreStack *ccs);
++
 +/* Allocate a StgArrBytes for a given number of bytes.
 + */
 +StgArrBytes *allocateArrBytes (Capability *cap,
 +                               StgWord nbytes,
 +                               CostCentreStack *ccs);
++
 +/* Allocate a pinned (and optionally aligned) StgArrBytes for a given number
 + * of bytes.
 + */
 +StgArrBytes *allocateArrBytesPinned (Capability *cap,
 +                                     StgWord nbytes,
 +                                     StgWord alignment,
 +                                     CostCentreStack *ccs);
++
 +#include "EndPrivate.h"

rts/Heap.c

@@ -13,6 +13,7 @@
  #include "Capability.h"
  #include "Printer.h"
 +#include "AllocArray.h"
  StgWord heap_view_closureSize(StgClosure *closure) {
      ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
@@ -278,18 +279,14 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
      StgClosure **ptrs = (StgClosure **) stgMallocBytes(sizeof(StgClosure *) * size, "heap_view_closurePtrs");
      StgWord nptrs = collect_pointers(closure, ptrs);
 -    size = nptrs + mutArrPtrsCardTableSize(nptrs);
 -    StgMutArrPtrs *arr =
 -        (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size);
 -    TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), nptrs, 0);
 -    SET_HDR(arr, &stg_MUT_ARR_PTRS_FROZEN_CLEAN_info, cap->r.rCCCS);
 -    arr->ptrs = nptrs;
 -    arr->size = size;
 +    StgMutArrPtrs *arr = allocateMutArrPtrs(cap, nptrs, cap->r.rCCCS);
 +    if (RTS_UNLIKELY(arr == NULL)) goto end;
 +    SET_INFO((StgClosure *) arr, &stg_MUT_ARR_PTRS_FROZEN_CLEAN_info);
      for (StgWord i = 0; i<nptrs; i++) {
          arr->payload[i] = ptrs[i];
+     }
 +end:
      stgFree(ptrs);
+-
      return arr;
+ }

rts/PrimOps.cmm

@@ -112,20 +112,14 @@ import CLOSURE stg_sel_0_upd_info;
  stg_newByteArrayzh ( W_ n )
+ {
 -    W_ words, payload_words;
      gcptr p;
      MAYBE_GC_N(stg_newByteArrayzh, n);
 -    payload_words = ROUNDUP_BYTES_TO_WDS(n);
 -    words = BYTES_TO_WDS(SIZEOF_StgArrBytes) + payload_words;
 -    ("ptr" p) = ccall allocateMightFail(MyCapability() "ptr", words);
 -    if (p == NULL) {
 +    ("ptr" p) = ccall allocateArrBytes(MyCapability() "ptr", n, CCCS);
 +    if (p == NULL) (likely: False) {
          jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure);
+     }
 -    TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0);
 -    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
 -    StgArrBytes_bytes(p) = n;
      return (p);
+ }
@@ -134,64 +128,29 @@ stg_newByteArrayzh ( W_ n )
  stg_newPinnedByteArrayzh ( W_ n )
+ {
 -    W_ words, bytes, payload_words;
      gcptr p;
      MAYBE_GC_N(stg_newPinnedByteArrayzh, n);
 -    bytes = n;
 -    /* payload_words is what we will tell the profiler we had to allocate */
 -    payload_words = ROUNDUP_BYTES_TO_WDS(bytes);
 -    /* When we actually allocate memory, we need to allow space for the
 -       header: */
 -    bytes = bytes + SIZEOF_StgArrBytes;
 -    /* Now we convert to a number of words: */
 -    words = ROUNDUP_BYTES_TO_WDS(bytes);
+-
 -    ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words, BA_ALIGN, SIZEOF_StgArrBytes);
 -    if (p == NULL) {
 +    ("ptr" p) = ccall allocateArrBytesPinned(MyCapability() "ptr", n,
 +                                             BA_ALIGN, CCCS);
 +    if (p == NULL) (likely: False) {
          jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure);
+     }
 -    TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0);
+-
 -    /* No write barrier needed since this is a new allocation. */
 -    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
 -    StgArrBytes_bytes(p) = n;
      return (p);
+ }
  stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment )
+ {
 -    W_ words, bytes, payload_words;
      gcptr p;
      again: MAYBE_GC(again);
 -    /* we always supply at least word-aligned memory, so there's no
 -       need to allow extra space for alignment if the requirement is less
 -       than a word.  This also prevents mischief with alignment == 0. */
 -    if (alignment <= SIZEOF_W) { alignment = SIZEOF_W; }
+-
 -    bytes = n;
+-
 -    /* payload_words is what we will tell the profiler we had to allocate */
 -    payload_words = ROUNDUP_BYTES_TO_WDS(bytes);
+-
 -    /* When we actually allocate memory, we need to allow space for the
 -       header: */
 -    bytes = bytes + SIZEOF_StgArrBytes;
 -    /* Now we convert to a number of words: */
 -    words = ROUNDUP_BYTES_TO_WDS(bytes);
+-
 -    ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words, alignment, SIZEOF_StgArrBytes);
 -    if (p == NULL) {
 +    ("ptr" p) = ccall allocateArrBytesPinned(MyCapability() "ptr", n,
 +                                             alignment, CCCS);
 +    if (p == NULL) (likely: False) {
          jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure);
+     }
 -    TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0);
+-
 -    /* No write barrier needed since this is a new allocation. */
 -    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
 -    StgArrBytes_bytes(p) = n;
      return (p);
+ }
@@ -399,36 +358,23 @@ stg_casInt64Arrayzh( gcptr arr, W_ ind, I64 old, I64 new )
  stg_newArrayzh ( W_ n /* words */, gcptr init )
+ {
 -    W_ words, size, p;
      gcptr arr;
      again: MAYBE_GC(again);
 -    // the mark area contains one byte for each 2^MUT_ARR_PTRS_CARD_BITS words
 -    // in the array, making sure we round up, and then rounding up to a whole
 -    // number of words.
 -    size = n + mutArrPtrsCardWords(n);
 -    words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size;
 -    ("ptr" arr) = ccall allocateMightFail(MyCapability() "ptr",words);
 -    if (arr == NULL) {
 +    ("ptr" arr) = ccall allocateMutArrPtrs(MyCapability() "ptr", n, CCCS);
 +    if (arr == NULL) (likely: False) {
          jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure);
+     }
 -    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);
+-
 -    /* No write barrier needed since this is a new allocation. */
 -    SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);
 -    StgMutArrPtrs_ptrs(arr) = n;
 -    StgMutArrPtrs_size(arr) = size;
+-
 -    /* Ensure that the card array is initialized */
 -    if (n != 0) {
 -        setCardsValue(arr, 0, n, 0);
 -    }
 -    // Initialise all elements of the array with the value in R2
 +    // Initialise all elements of the array with the value init
 +    W_ p;
      p = arr + SIZEOF_StgMutArrPtrs;
 +    // Avoid the shift for `WDS(n)` in the inner loop
 +    W_ limit;
 +    limit = arr + SIZEOF_StgMutArrPtrs + WDS(n);
    for:
 -    if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) (likely: True) {
 +    if (p < limit) (likely: True) {
          W_[p] = init;
          p = p + WDS(1);
          goto for;
@@ -522,23 +468,17 @@ stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
  stg_newSmallArrayzh ( W_ n /* words */, gcptr init )
+ {
 -    W_ words, size, p;
      gcptr arr;
      again: MAYBE_GC(again);
 -    words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + n;
 -    ("ptr" arr) = ccall allocateMightFail(MyCapability() "ptr",words);
 +    ("ptr" arr) = ccall allocateSmallMutArrPtrs(MyCapability() "ptr", n, CCCS);
      if (arr == NULL) (likely: False) {
          jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure);
+     }
 -    TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0);
+-
 -    /* No write barrier needed since this is a new allocation. */
 -    SET_HDR(arr, stg_SMALL_MUT_ARR_PTRS_DIRTY_info, CCCS);
 -    StgSmallMutArrPtrs_ptrs(arr) = n;
 -    // Initialise all elements of the array with the value in R2
 +    // Initialise all elements of the array with the value init
 +    W_ p;
      p = arr + SIZEOF_StgSmallMutArrPtrs;
      // Avoid the shift for `WDS(n)` in the inner loop
      W_ limit;
@@ -1148,6 +1088,11 @@ stg_listThreadszh ()
    P_ arr;
    ("ptr" arr) = ccall listThreads(MyCapability() "ptr");
++
 +  if (arr == NULL) (likely: False) {
 +    jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure);
 +  }
++
    return (arr);
+ }
@@ -1414,7 +1359,7 @@ stg_atomicallyzh (P_ stm)
      old_trec = StgTSO_trec(CurrentTSO);
      /* Nested transactions are not allowed; raise an exception */
 -    if (old_trec != NO_TREC) {
 +    if (old_trec != NO_TREC) (likely: False) {
          jump stg_raisezh(ghczminternal_GHCziInternalziControlziExceptionziBase_nestedAtomically_closure);
+     }
@@ -2537,6 +2482,10 @@ for:
      // Collect pointers.
      ("ptr" ptrArray) = foreign "C" heap_view_closurePtrs(MyCapability() "ptr", clos "ptr");
 +    if (ptrArray == NULL) (likely: False) {
 +        jump stg_raisezh(ghczminternal_GHCziInternalziIOziException_heapOverflow_closure);
 +    }
++
      return (info, dat_arr, ptrArray);
+ }

rts/RtsUtils.c

@@ -198,6 +198,13 @@ reportHeapOverflow(void)
                              (W_)RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE);
+ }
 +void
 +exitHeapOverflow(void)
 +{
 +    reportHeapOverflow();  // reportHeapOverflow() doesn't exit (see #2592)
 +    stg_exit(EXIT_HEAPOVERFLOW);
 +}
++
  /* -----------------------------------------------------------------------------
     Sleep for the given period of time.
     -------------------------------------------------------------------------- */

rts/ThreadLabels.c

@@ -15,6 +15,7 @@
  #include "RtsFlags.h"
  #include "Hash.h"
  #include "Trace.h"
 +#include "AllocArray.h"
  #include <stdlib.h>
  #include <string.h>
@@ -31,25 +32,16 @@
   * determined by the ByteArray# length.
   */
 -static StgArrBytes *
 -allocateArrBytes(Capability *cap, size_t size_in_bytes)
 -{
 -    /* round up to a whole number of words */
 -    uint32_t data_size_in_words  = ROUNDUP_BYTES_TO_WDS(size_in_bytes);
 -    uint32_t total_size_in_words = sizeofW(StgArrBytes) + data_size_in_words;
+-
 -    StgArrBytes *arr = (StgArrBytes *) allocate(cap, total_size_in_words);
 -    SET_ARR_HDR(arr, &stg_ARR_WORDS_info, cap->r.rCCCS, size_in_bytes);
 -    return arr;
 -}
+-
  void
  setThreadLabel(Capability  *cap,
                 StgTSO      *tso,
                 char *label)
+ {
      int len = strlen(label);
 -    StgArrBytes *arr = allocateArrBytes(cap, len);
 +    StgArrBytes *arr = allocateArrBytes(cap, len, cap->r.rCCCS);
 +    // On allocation failure don't perform the effect. It's not convenient to
 +    // propagate failure from here since there are multiple callers in the RTS.
 +    if (RTS_UNLIKELY(arr == NULL)) return;
      memcpy(&arr->payload, label, len);
      labelThread(cap, tso, arr);
+ }

rts/Threads.c

@@ -25,6 +25,7 @@
  #include "Printer.h"
  #include "sm/Sanity.h"
  #include "sm/Storage.h"
 +#include "AllocArray.h"
  #include <string.h>
@@ -879,6 +880,7 @@ loop:
      return true;
+ }
 +/* Return NULL on allocation failure */
  StgMutArrPtrs *listThreads(Capability *cap)
+ {
      ACQUIRE_LOCK(&sched_mutex);
@@ -892,13 +894,8 @@ StgMutArrPtrs *listThreads(Capability *cap)
+     }
      // Allocate a suitably-sized array...
 -    const StgWord size = n_threads + mutArrPtrsCardTableSize(n_threads);
 -    StgMutArrPtrs *arr =
 -        (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size);
 -    SET_HDR(arr, &stg_MUT_ARR_PTRS_DIRTY_info, CCS_SYSTEM);
 -    TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), size, 0);
 -    arr->ptrs = n_threads;
 -    arr->size = size;
 +    StgMutArrPtrs *arr = allocateMutArrPtrs(cap, n_threads, cap->r.rCCCS);
 +    if (RTS_UNLIKELY(arr == NULL)) goto end;
      // Populate it...
      StgWord i = 0;
@@ -913,6 +910,7 @@ StgMutArrPtrs *listThreads(Capability *cap)
+         }
+     }
      CHECKM(i == n_threads, "listThreads: Found too few threads");
 +end:
      RELEASE_LOCK(&sched_mutex);
      return arr;
+ }

rts/Weak.c

@@ -17,6 +17,7 @@
  #include "Prelude.h"
  #include "ThreadLabels.h"
  #include "Trace.h"
 +#include "AllocArray.h"
  // List of dead weak pointers collected by the last GC
  static StgWeak *finalizer_list = NULL;
@@ -89,8 +90,6 @@ scheduleFinalizers(Capability *cap, StgWeak *list)
+ {
      StgWeak *w;
      StgTSO *t;
 -    StgMutArrPtrs *arr;
 -    StgWord size;
      uint32_t n, i;
      // n_finalizers is not necessarily zero under non-moving collection
@@ -147,13 +146,10 @@ scheduleFinalizers(Capability *cap, StgWeak *list)
      debugTrace(DEBUG_weak, "weak: batching %d finalizers", n);
 -    size = n + mutArrPtrsCardTableSize(n);
 -    arr = (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size);
 -    TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
 +    StgMutArrPtrs *arr = allocateMutArrPtrs(cap, n, CCS_SYSTEM_OR_NULL);
 +    if (RTS_UNLIKELY(arr == NULL)) exitHeapOverflow();
      // No write barrier needed here; this array is only going to referred to by this core.
 -    SET_HDR(arr, &stg_MUT_ARR_PTRS_FROZEN_CLEAN_info, CCS_SYSTEM);
 -    arr->ptrs = n;
 -    arr->size = size;
 +    SET_INFO((StgClosure *) arr, &stg_MUT_ARR_PTRS_FROZEN_CLEAN_info);
      n = 0;
      for (w = list; w; w = w->link) {
@@ -163,6 +159,10 @@ scheduleFinalizers(Capability *cap, StgWeak *list)
+         }
+     }
      // set all the cards to 1
 +    StgWord size = n + mutArrPtrsCardTableSize(n);
 +    // TODO: does this need to be a StgMutArrPtrs with a card table?
 +    // If the cards are all 1 and the array is clean, couldn't it
 +    // be a StgSmallMutArrPtrs instead?
      for (i = n; i < size; i++) {
          arr->payload[i] = (StgClosure *)(W_)(-1);
+     }

rts/include/Rts.h

@@ -291,6 +291,7 @@ DLL_IMPORT_RTS extern char  *prog_name;
  void reportStackOverflow(StgTSO* tso);
  void reportHeapOverflow(void);
 +void exitHeapOverflow(void) STG_NORETURN;;
  void stg_exit(int n) STG_NORETURN;

rts/include/rts/prof/CCS.h

@@ -220,9 +220,14 @@ extern CostCentre * RTS_VAR(CC_LIST);               // registered CC list
  #define CCS_ALLOC(ccs, size) (ccs)->mem_alloc += ((size)-sizeofW(StgProfHeader))
  #define ENTER_CCS_THUNK(cap,p) cap->r.rCCCS = p->header.prof.ccs
 +/* Allow using CCS_SYSTEM somewhat consistently with/without profiling mode */
 +#define CCS_SYSTEM_OR_NULL CCS_SYSTEM
++
  #else /* !PROFILING */
  #define CCS_ALLOC(ccs, amount) doNothing()
  #define ENTER_CCS_THUNK(cap,p) doNothing()
 +#define CCS_SYSTEM_OR_NULL NULL
++
  #endif /* PROFILING */

rts/include/rts/storage/GC.h

@@ -170,36 +170,106 @@ void listAllBlocks(ListBlocksCb cb, void *user);
  /* -----------------------------------------------------------------------------
     Generic allocation
 -   StgPtr allocate(Capability *cap, W_ n)
 -                                Allocates memory from the nursery in
 -                                the current Capability.
+-
 -   StgPtr allocatePinned(Capability *cap, W_ n, W_ alignment, W_ align_off)
 -                                Allocates a chunk of contiguous store
 -                                n words long, which is at a fixed
 -                                address (won't be moved by GC). The
 -                                word at the byte offset 'align_off'
 -                                will be aligned to 'alignment', which
 -                                must be a power of two.
 -                                Returns a pointer to the first word.
 -                                Always succeeds.
+-
 -                                NOTE: the GC can't in general handle
 -                                pinned objects, so allocatePinned()
 -                                can only be used for ByteArrays at the
 -                                moment.
+-
 -                                Don't forget to TICK_ALLOC_XXX(...)
 -                                after calling allocate or
 -                                allocatePinned, for the
 -                                benefit of the ticky-ticky profiler.
+-
 +   See: Note [allocate and allocateMightFail]
 +        Note [allocatePinned]
 +        Note [allocate failure]
     -------------------------------------------------------------------------- */
  StgPtr  allocate          ( Capability *cap, W_ n );
  StgPtr  allocateMightFail ( Capability *cap, W_ n );
  StgPtr  allocatePinned    ( Capability *cap, W_ n, W_ alignment, W_ align_off);
 +/* Note [allocate and allocateMightFail]
 +   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
++
 +   allocate() and allocateMightFail() allocate an area of memory n
 +   *words* large, from the nursery of the supplied Capability, or from
 +   the global block pool if the area requested is larger than
 +   LARGE_OBJECT_THRESHOLD.  Memory is not allocated from the current
 +   nursery block, so as not to interfere with Hp/HpLim.
++
 +   The address of the allocated memory is returned.
++
 +   After allocating, fill in the heap closure header, e.g.
 +   SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);
 +   and call TICK_ALLOC_XXX(...) for the benefit of the ticky-ticky
 +   profiler.
++
 +   On allocation failure, allocateMightFail() returns NULL whereas
 +   allocate() terminates the RTS. See Note [allocate failure]. You
 +   should prefer allocateMightFail() in cases where you can propagate
 +   the failure up to a context in which you can raise exceptions, e.g.
 +   in primops.
 + */
++
 +/* Note [allocatePinned]
 +   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +   allocatePinned() allocates a chunk of contiguous store n *words*
 +   long, which is at a fixed address (i.e. won't be moved by GC). The
 +   word at the byte offset 'align_off' will be aligned to 'alignment',
 +   which must be a power of two.
++
 +   The address of the allocated memory is returned.
++
 +   The GC can't in general handle pinned objects, so allocatePinned()
 +   can only be used for ByteArrays / stg_ARR_WORDS at the moment.
++
 +   On allocation failure, allocatePinned() returns NULL.
 +   See Note [allocate failure].
 + */
++
 +/* Note [allocate failure]
 +   ~~~~~~~~~~~~~~~~~~~~~~~
++
 +   The allocation functions differ in how they handle failure to
 +   allocate:
++
 +    * on failure allocateMightFail() returns NULL
 +    * on failure allocatePinned() returns NULL
 +    * on failure allocate() terminates the RTS (and thus typically
 +      the whole process)
++
 +   Each of these functions tries _quite_ hard to avoid allocation
 +   failure however. If the nursery is already full, then another block
 +   is allocated from the global block pool. If we need to get memory
 +   from the OS and that operation fails, or if we would exceed
 +   maxHeapSize then we fail.
++
 +   There are two main existing conventions within the RTS for handling
 +   allocation failure.
++
 +   1. Start from a primop that uses one of the MAYBE_GC_* macros to
 +      provide an opportunity to GC. Then buried deeply within C code
 +      called from the primop, use allocate().
++
 +   2. Start from a primop that uses one of the MAYBE_GC_* macros to
 +      provide an opportunity to GC. Use allocateMightFail() within the
 +      C code called from the primop. If that fails, propagate the
 +      failure up to the primop where it can throw a HeapOverflow
 +      exception.
++
 +   Being able to throw an exception is preferable, since it's more
 +   polite, provides better reporting and potentially it can be
 +   caught and handled by the user program.
++
 +   An advantage of the first approach is that its simpler to implement.
 +   It does not require any mechanism to propagate failure (and undoing
 +   any effects along the way so the operation can be safely retried
 +   after GC).
++
 +   Arguably neither existing convention is ideal. One might imagine
 +   that when failure from allocateMightFail() propagates to the top
 +   level primop, the primop would not throw a HeapOverflow exception
 +   but invoke the GC with a request to make available at least the
 +   required number of words. The GC may be able to succeed, in which
 +   case the original operation can be retried. Or if the GC is unable
 +   to free enough memory then it can throw the HeapOverflow exception.
 +   In practice however, though there is a mechanism (via HpAlloc) to
 +   tell the GC how much memory was needed, this is not used to decide
 +   if we have to fail the allocation, it is just used for error
 +   reporting.
 + */
++
  /* memory allocator for executable memory */
  typedef void* AdjustorWritable;
  typedef void* AdjustorExecutable;

rts/include/rts/storage/Heap.h

@@ -10,6 +10,7 @@
  #include "rts/storage/Closures.h"
 +/* Returns NULL on allocation failure */
  StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure);
  void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs

rts/rts.cabal

@@ -400,6 +400,7 @@ library
          asm-sources: StgCRunAsm.S
        c-sources: Adjustor.c
 +                 AllocArray.c
                   adjustor/AdjustorPool.c
                   ExecPage.c
                   Arena.c

rts/sm/Storage.c

@@ -1065,46 +1065,31 @@ accountAllocation(Capability *cap, W_ n)
   * overwriting closures].
   */
 -/* -----------------------------------------------------------------------------
 -   StgPtr allocate (Capability *cap, W_ n)
+-
 -   Allocates an area of memory n *words* large, from the nursery of
 -   the supplied Capability, or from the global block pool if the area
 -   requested is larger than LARGE_OBJECT_THRESHOLD.  Memory is not
 -   allocated from the current nursery block, so as not to interfere
 -   with Hp/HpLim.
+-
 -   The address of the allocated memory is returned. allocate() never
 -   fails; if it returns, the returned value is a valid address.  If
 -   the nursery is already full, then another block is allocated from
 -   the global block pool.  If we need to get memory from the OS and
 -   that operation fails, then the whole process will be killed.
 -   -------------------------------------------------------------------------- */
+-
  /*
 - * Allocate some n words of heap memory; terminating
 - * on heap overflow
 + * Allocate some n words of heap memory; terminating on heap overflow.
 + *
 + * See Note [allocate and allocateMightFail].
   */
  StgPtr
  allocate (Capability *cap, W_ n)
+ {
      StgPtr p = allocateMightFail(cap, n);
 -    if (p == NULL) {
 -        reportHeapOverflow();
 -        // heapOverflow() doesn't exit (see #2592), but we aren't
 +    if (RTS_UNLIKELY(p == NULL)) {
 +        // reportHeapOverflow() doesn't exit (see #2592), but we aren't
          // in a position to do a clean shutdown here: we
          // either have to allocate the memory or exit now.
          // Allocating the memory would be bad, because the user
          // has requested that we not exceed maxHeapSize, so we
          // just exit.
 -        stg_exit(EXIT_HEAPOVERFLOW);
 +        exitHeapOverflow();
+     }
      return p;
+ }
  /*
 - * Allocate some n words of heap memory; returning NULL
 - * on heap overflow
 + * Allocate some n words of heap memory; returning NULL on heap overflow.
 + *
 + * See Note [allocate and allocateMightFail].
   */
  StgPtr
  allocateMightFail (Capability *cap, W_ n)
@@ -1303,6 +1288,9 @@ start_new_pinned_block(Capability *cap)
  /* ---------------------------------------------------------------------------
     Allocate a fixed/pinned object.
 +   See Note [allocatePinned] for the interface. This describes the
 +   implementation.
++
     We allocate small pinned objects into a single block, allocating a
     new block when the current one overflows.  The block is chained
     onto the large_object_list of generation 0.