CODEOWNERS

@@ -60,6 +60,7 @@
 /libraries/base/                  @hvr
 /libraries/ghci/                  @simonmar
 /libraries/template-haskell/      @rae
+/testsuite/tests/interface-stability/ @core-libraries
 
 [Internal utilities and libraries]
 /utils/iserv-proxy/               @angerman @simonmar

compiler/GHC/Builtin/primops.txt.pp

@@ -1852,6 +1852,70 @@ section "Byte Arrays"
 
 ------------------------------------------------------------------------
 
+-- Note [Byte arrays outside of the HEAP_ALLOCED space]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- It is useful to be able to allocate byte arrays outside of the heap,
+-- i.e. outside of the memory space covered by the HEAP_ALLOCED() test.
+--
+-- There are two major use cases (see issue #17747):
+--
+--  1. Having foreign memory appear as a normal GHC byte array. This
+--     are use cases similar to the use of a ForeignPtr, but where it
+--     is useful to have the representation be a byte array type, for
+--     easier interoperability with existing libraries.
+--
+--  2. Static byte arrays in object files for constant values.
+--
+-- The second is not yet available as it requires additional support
+-- from the code gen.
+--
+-- An example of the first category can be seen in GHC test T17747.
+-- A concrete use-case is to memory map a file
+-- but have it appear as a ByteArray# rather than a ForeignPtr. Doing
+-- so of course requires that space is reserved immediately before the
+-- file data for the byte array heap object header. See the
+-- placeByteArray# primop documentation below and the FFI section of
+-- the user guide for more details.
+--
+-- To have the first use-case work requires a few things:
+--
+-- * For the GC to not fail when it encounters byte arrays outside of
+--   the HEAP_ALLOCED space. This is straightforward because the GC
+--   has support for a number of different closure types to appear
+--   outside the heap (primarily for statically allocated values), and
+--   byte arrays are easy because they contain no heap pointers. See
+--   the reference back to this note in `evacuate(StgClosure **p)` in
+--   `rts/sm/Evac.c`
+--
+-- * For all other byte array primops (e.g. shrinkMutableByteArray#,
+--   sameMutableByteArray#, isByteArrayPinned#, etc.) to not fail when
+--   encountering byte arrays outside of the heap. Specifically
+--   isByteArrayPinned# requires special support. This is currently the
+--   only primop that needs special support.
+--   See Note [isByteArrayPinned# support for off heap byte arrays].
+--
+-- * A mechanism to set up the heap object header for a byte array at
+--   an address outside of the HEAP_ALLOCED space. This is needed to
+--   make the foreign allocated memory look like a byte array. This is
+--   provided by the placeByteArray# primop.
+--
+
+-- Note [isByteArrayPinned# support for off heap byte arrays]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The isByteArrayPinned# primop is implemented by reading block descriptor
+-- flags. Since off heap byte arrays don't have block descriptors,
+-- isByteArrayPinned# must explicitly check if the byte array is HEAP_ALLOCED
+-- or not. If not HEAP_ALLOCED then it is certainly pinned. This requires CMM
+-- support for the HEAP_ALLOCED test, which is otherwise only called from C
+-- code in the RTS. The current design is to provide full CMM
+-- implementations of HEAP_ALLOCED enabled in `rts/storage/HeapAlloc.h` with the
+-- CMINUSMINUS cpp flag. This includes HEAP_ALLOCED_CALLISH which essentially
+-- duplicates what is already a complex C implementation. This is fast
+-- but an alternative would be to use a CMM C call to a C function that use
+-- the existing C implementation of HEAP_ALLOCED.
+
+
 primtype ByteArray#
 {
   A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap,
@@ -1902,6 +1966,20 @@ primop  NewByteArrayOp_Char "newByteArray#" GenPrimOp
    with out_of_line = True
         effect = ReadWriteEffect
 
+-- See [Byte arrays outside of the HEAP_ALLOCED space]
+primop  PlaceByteArrayOp_Char "placeByteArray#" GenPrimOp
+   Addr# -> Int# -> State# s -> (# State# s, MutableByteArray# s #)
+   {Place a new byte array header at the specified address outside of the heap,
+   for the specified payload size (in bytes), in the specified state thread. In
+   C code with `#include "Rts.h"`, use `sizeOf(StgArrBytes)` or
+   `sizeOfW(StgArrBytes)` to get the size of a byte array header in bytes or
+   words respectively. The caller must ensure `sizeof(StgArrBytes) + n` bytes of
+   space is allocated at the give address for the heap object header followed by
+   n bytes of payload. See the FFI section of the user guide for more details
+   on how to use this primop.}
+   with out_of_line = True
+        effect = ReadWriteEffect
+
 primop  NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp
    Int# -> State# s -> (# State# s, MutableByteArray# s #)
    {Like 'newByteArray#' but GC guarantees not to move it.}

compiler/GHC/StgToCmm/Prim.hs

@@ -1665,6 +1665,7 @@ emitPrimOp cfg primop =
   CasArrayOp -> alwaysExternal
   UnsafeThawSmallArrayOp -> alwaysExternal
   CasSmallArrayOp -> alwaysExternal
+  PlaceByteArrayOp_Char -> alwaysExternal
   NewPinnedByteArrayOp_Char -> alwaysExternal
   NewAlignedPinnedByteArrayOp_Char -> alwaysExternal
   MutableByteArrayIsPinnedOp -> alwaysExternal

compiler/GHC/StgToJS/Prim.hs

@@ -1198,6 +1198,10 @@ genPrim prof bound ty op = case op of
   VecReadScalarOffAddrOp _ _ _      -> unhandledPrimop op
   VecWriteScalarOffAddrOp _ _ _     -> unhandledPrimop op
 
+  -- This primop can be used to create a ByteArray# header outside the managed heap.
+  -- This operation is not supported in the Javascript backend.
+  PlaceByteArrayOp_Char             -> unhandledPrimop op
+
   PrefetchByteArrayOp3              -> noOp
   PrefetchMutableByteArrayOp3       -> noOp
   PrefetchAddrOp3                   -> noOp

docs/users_guide/exts/ffi.rst

@@ -811,6 +811,37 @@ the different kinds of allocation perform with GHC.
     allocation than using one of the other forms of allocation. They are
     backed by the RTS internal arena instead of ``malloc/free``.
 
+Foreign allocation of native byte arrays
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+GHC allows ``ByteArray#`` and ``MutableByteArray#`` to be allocated
+outside of the GHC heap. This enables manually allocated data to be
+represented as these native types. It is also possible to attach weak
+pointers with finalisers to these byte array types. For example, in
+principle it is possible to arrange for a memory mapped file to be
+presented as a byte array, including a weak pointer finaliser to unmap
+the file after it is no longer referenced. This can be useful because
+these native types are used directly or indirectly by many libraries.
+It does however require some care and attention.
+
+The in-memory representation of ``ByteArray#`` and ``MutableByteArray#``
+are exactly the same whether inside or outside the heap. In particular
+they use a few prefix words for the object header and array size field.
+Note that the object header size is different for normal and profiling
+builds. When allocating in foreign memory, space must be made available
+for this in the memory layout immediately before the data payload.
+
+In C code, ``#include "Rts.h"`` and use ``sizeOf(StgArrBytes)`` or
+``sizeOfW(StgArrBytes)`` to get the size of a byte array heap object
+header in bytes or words respectively. This is the space that must be
+reserved at the memory location immediately before the intended payload.
+Then use the primop ``placeByteArray#`` to place the heap object header
+at the intended location with the appropriate payload size in bytes.
+
+To add a finaliser, use GHC's weak pointer support. If appropriate make
+use of the ability to use C functions for finalisers.
+
+
 .. _ffi-threads:
 
 Multi-threading and the FFI

libraries/ghc-internal/src/GHC/Internal/Exception.hs

@@ -79,7 +79,7 @@ import GHC.Internal.Exception.Type
 -- WARNING: You may want to use 'throwIO' instead so that your pure code
 -- stays exception-free.
 throw :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
-         (?callStack :: CallStack, Exception e) => e -> a
+         (HasCallStack, Exception e) => e -> a
 throw e =
     let !se = unsafePerformIO (toExceptionWithBacktrace e)
     in raise# se

rts/Inlines.c

-// all functions declared with EXTERN_INLINE in the header files get
-// compiled for real here, just in case the definition was not inlined
-// at some call site:
+// All functions declared with EXTERN_INLINE in the header files get
+// compiled for real here. Some of them are called by Cmm (e.g.
+// recordClosureMutated) and therefore the real thing needs to reside
+// in Inlines.o for Cmm ccall to work.
 #define KEEP_INLINES
 #include "rts/PosixSource.h"
 #include "Rts.h"
@@ -8,3 +9,4 @@
 #include "Capability.h"
 #include "WSDeque.h"
 #include "SMPClosureOps.h"
+#include "rts/storage/HeapAlloc.h"

rts/PrimOps.cmm

@@ -24,6 +24,7 @@
 #include "Cmm.h"
 #include "MachDeps.h"
 #include "SMPClosureOps.h"
+#include "rts/storage/HeapAlloc.h" /* for HEAP_ALLOCED() */
 
 #if defined(__PIC__)
 import pthread_mutex_lock;
@@ -133,9 +134,22 @@ stg_newByteArrayzh ( W_ n )
     return (p);
 }
 
+stg_placeByteArrayzh ( W_ addr, W_ n )
+// Addr# -> Int# -> MutableByteArray# {
+{
+    /* Place an ARR_WORDS object header at the given address outside the heap.
+       The caller must arrange for space for the heap object header. */
+    gcptr p;
+    p = addr;
+    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
+    StgArrBytes_bytes(p) = n;
+    return (p);
+}
+
 #define BA_ALIGN 16
 #define BA_MASK  (BA_ALIGN-1)
 
+// See Note [Byte arrays outside of the HEAP_ALLOCED space]
 stg_newPinnedByteArrayzh ( W_ n )
 {
     W_ words, bytes, payload_words;
@@ -203,16 +217,29 @@ stg_isByteArrayPinnedzh ( gcptr ba )
 // ByteArray# s -> Int#
 {
     W_ bd, flags;
-    bd = Bdescr(ba);
-    // Pinned byte arrays live in blocks with the BF_PINNED flag set.
-    // We also consider BF_LARGE objects to be immovable. See #13894.
-    // See the comment in Storage.c:allocatePinned.
-    // We also consider BF_COMPACT objects to be immovable. See #14900.
-    flags = TO_W_(bdescr_flags(bd));
 
-    // We used to also consider BF_LARGE pinned, but stopped doing so
-    // because it interacted badly with compact regions. See #22255
-    return (flags & BF_PINNED != 0);
+// See Note [Byte arrays outside of the HEAP_ALLOCED space]
+#if defined(HEAP_ALLOCED)
+    if (HEAP_ALLOCED(ba)) {
+#else
+    W_ result;
+    HEAP_ALLOCED_CALLISH(result, ba)
+    if (result == 1) {
+#endif
+        // Safe to look up the block descriptor when the object is in the heap.
+        bd = Bdescr(ba);
+
+        // Pinned byte arrays live in blocks with the BF_PINNED flag set.
+        // See the comment in Storage.c:allocatePinned.
+        // We used to also considered BF_LARGE & BF_COMPACT pinned. See #13894 & 14900.
+        // We stopped doing so because it interacted badly with compact regions. See #22255.
+        flags = TO_W_(bdescr_flags(bd));
+        return (flags & BF_PINNED != 0);
+    } else {
+        // If it's not in the heap at all then we GC will not move it, so we
+        // can report to application code that it is pinned.
+        return (1);
+    }
 }
 
 stg_isMutableByteArrayPinnedzh ( gcptr mba )
@@ -2975,4 +3002,3 @@ stg_castFloatToWord32zh(F_ f)
 
     return (w);
 }
-

rts/RtsSymbols.c

@@ -637,6 +637,7 @@ extern char **environ;
       SymI_HasDataProto(stg_copyArray_barrier)                              \
       SymI_HasDataProto(stg_newBCOzh)                                       \
       SymI_HasDataProto(stg_newByteArrayzh)                                 \
+      SymI_HasDataProto(stg_placeByteArrayzh)                               \
       SymI_HasDataProto(stg_casIntArrayzh)                                  \
       SymI_HasDataProto(stg_casInt8Arrayzh)                                 \
       SymI_HasDataProto(stg_casInt16Arrayzh)                                \

rts/include/Stg.h

@@ -114,57 +114,19 @@
  * 'Portable' inlining:
  * INLINE_HEADER is for inline functions in header files (macros)
  * STATIC_INLINE is for inline functions in source files
- * EXTERN_INLINE is for functions that we want to inline sometimes
- * (we also compile a static version of the function; see Inlines.c)
+ * EXTERN_INLINE is for functions that may be called in Cmm
+ * (we also compile a static version of an EXTERN_INLINE function; see Inlines.c)
  */
 
-// We generally assume C99 semantics albeit these two definitions work fine even
-// when gnu90 semantics are active (i.e. when __GNUC_GNU_INLINE__ is defined or
-// when a GCC older than 4.2 is used)
-//
-// The problem, however, is with 'extern inline' whose semantics significantly
-// differs between gnu90 and C99
 #define INLINE_HEADER static inline
 #define STATIC_INLINE static inline
 
-// Figure out whether `__attributes__((gnu_inline))` is needed
-// to force gnu90-style 'external inline' semantics.
-#if defined(FORCE_GNU_INLINE)
-// disable auto-detection since HAVE_GNU_INLINE has been defined externally
-#elif defined(__GNUC_GNU_INLINE__) && __GNUC__ == 4 && __GNUC_MINOR__ == 2
-// GCC 4.2.x didn't properly support C99 inline semantics (GCC 4.3 was the first
-// release to properly support C99 inline semantics), and therefore warned when
-// using 'extern inline' while in C99 mode unless `__attributes__((gnu_inline))`
-// was explicitly set.
-# define FORCE_GNU_INLINE 1
-#endif
-
-#if defined(FORCE_GNU_INLINE)
-// Force compiler into gnu90 semantics
-# if defined(KEEP_INLINES)
-#  define EXTERN_INLINE inline __attribute__((gnu_inline))
-# else
-#  define EXTERN_INLINE extern inline __attribute__((gnu_inline))
-# endif
-#elif defined(__GNUC_GNU_INLINE__)
-// we're currently in gnu90 inline mode by default and
-// __attribute__((gnu_inline)) may not be supported, so better leave it off
-# if defined(KEEP_INLINES)
-#  define EXTERN_INLINE inline
-# else
-#  define EXTERN_INLINE extern inline
-# endif
-#else
-// Assume C99 semantics (yes, this curiously results in swapped definitions!)
-// This is the preferred branch, and at some point we may drop support for
-// compilers not supporting C99 semantics altogether.
+// See comment in rts/Inlines.c for explanation.
 # if defined(KEEP_INLINES)
 #  define EXTERN_INLINE extern inline
 # else
-#  define EXTERN_INLINE inline
+#  define EXTERN_INLINE static inline
 # endif
-#endif
-
 
 /*
  * GCC attributes

rts/include/rts/storage/HeapAlloc.h

@@ -8,6 +8,8 @@
 
 #pragma once
 
+#if !defined(CMINUSMINUS)
+
 #if defined(THREADED_RTS)
 // needed for HEAP_ALLOCED below
 extern SpinLock gc_alloc_block_sync;
@@ -16,6 +18,8 @@ extern SpinLock gc_alloc_block_sync;
 #define ACQUIRE_ALLOC_BLOCK_SPIN_LOCK() ACQUIRE_SPIN_LOCK(&gc_alloc_block_sync)
 #define RELEASE_ALLOC_BLOCK_SPIN_LOCK() RELEASE_SPIN_LOCK(&gc_alloc_block_sync)
 
+#endif // !defined(CMINUSMINUS)
+
 /* -----------------------------------------------------------------------------
    The HEAP_ALLOCED() test.
 
@@ -56,6 +60,9 @@ extern SpinLock gc_alloc_block_sync;
 
 #if defined(USE_LARGE_ADDRESS_SPACE)
 
+#if !defined(CMINUSMINUS)
+
+// If this struct is changed, the CMM macro below must be adjusted to match.
 struct mblock_address_range {
     W_ begin, end;
     W_ padding[6];  // ensure nothing else inhabits this cache line
@@ -66,7 +73,21 @@ extern struct mblock_address_range mblock_address_space;
                                  (W_)(p) < (mblock_address_space.end))
 # define HEAP_ALLOCED_GC(p)     HEAP_ALLOCED(p)
 
+#else /* defined(CMINUSMINUS) */
+
+/* See Note [Byte arrays outside of the HEAP_ALLOCED space] */
+
+import mblock_address_space;
+
+# define HEAP_ALLOCED(p)        ((p) >= W_[mblock_address_space + WDS(0)] && \
+                                 (p) <  W_[mblock_address_space + WDS(1)])
+
+#endif
+
 #elif SIZEOF_VOID_P == 4
+
+#if !defined(CMINUSMINUS)
+
 extern StgWord8 mblock_map[];
 
 # define MBLOCK_MAP_SIZE        (1 << (32 - MBLOCK_SHIFT))
@@ -74,6 +95,17 @@ extern StgWord8 mblock_map[];
 # define HEAP_ALLOCED(p)        mblock_map[MBLOCK_MAP_ENTRY(p)]
 # define HEAP_ALLOCED_GC(p)     HEAP_ALLOCED(p)
 
+#else /* defined(CMINUSMINUS) */
+
+/* See Note [Byte arrays outside of the HEAP_ALLOCED space] */
+
+import mblock_map;
+
+# define MBLOCK_MAP_ENTRY(p)    ((p) >> MBLOCK_SHIFT)
+# define HEAP_ALLOCED(p)        (TO_W_(I8[mblock_map + MBLOCK_MAP_ENTRY(p)]) != 0)
+
+#endif
+
 /* -----------------------------------------------------------------------------
    HEAP_ALLOCED for 64-bit machines (without LARGE_ADDRESS_SPACE).
 
@@ -130,11 +162,13 @@ extern StgWord8 mblock_map[];
 
  ---------------------------------------------------------------------------- */
 
-#elif SIZEOF_VOID_P == 8
+#elif SIZEOF_VOID_P == 8 /* && !defined(USE_LARGE_ADDRESS_SPACE) */
 
 #define MBC_LINE_BITS 0
 #define MBC_TAG_BITS 15
 
+#if !defined(CMINUSMINUS)
+
 #if defined(x86_64_HOST_ARCH)
 // 32bits are enough for 'entry' as modern amd64 boxes have
 // only 48bit sized virtual address.
@@ -168,7 +202,7 @@ extern W_ mpc_misses;
 
 StgBool HEAP_ALLOCED_miss(StgWord mblock, const void *p);
 
-INLINE_HEADER
+EXTERN_INLINE
 StgBool HEAP_ALLOCED(const void *p)
 {
     StgWord mblock;
@@ -222,6 +256,21 @@ StgBool HEAP_ALLOCED_GC(const void *p)
     }
 }
 
+#else /* defined(CMINUSMINUS) */
+
+/* See Note [Byte arrays outside of the HEAP_ALLOCED space] */
+
+// This is a call to HEAP_ALLOCED C function defined above. That function is reified via the
+// Inlines.c file. Since the implementation that can't use USE_LARGE_ADDRESS_SPACE is big and
+// complicated we prevent duplicating it's logic. We define the interface to be used in a statement
+// "callish op" style.
+#define HEAP_ALLOCED_CALLISH(result, p)                             \
+    CInt r;                                                         \
+    (r) = ccall HEAP_ALLOCED(p "ptr");                              \
+    result = TO_W_(r);                                              \
+
+#endif
+
 #else
 # error HEAP_ALLOCED not defined
 #endif

rts/include/stg/MiscClosures.h

@@ -450,6 +450,7 @@ RTS_FUN_DECL(stg_decodeDoublezuInt64zh);
 RTS_FUN_DECL(stg_unsafeThawArrayzh);
 RTS_FUN_DECL(stg_casArrayzh);
 RTS_FUN_DECL(stg_newByteArrayzh);
+RTS_FUN_DECL(stg_placeByteArrayzh);
 RTS_FUN_DECL(stg_newPinnedByteArrayzh);
 RTS_FUN_DECL(stg_newAlignedPinnedByteArrayzh);
 RTS_FUN_DECL(stg_isByteArrayPinnedzh);

rts/sm/Evac.c

@@ -741,6 +741,8 @@ loop:
       case CONSTR_0_1:
       case CONSTR_0_2:
       case CONSTR_NOCAF:
+      /* See Note [Byte arrays outside of the HEAP_ALLOCED space] */
+      case ARR_WORDS:
           /* no need to put these on the static linked list, they don't need
            * to be scavenged.
            */

testsuite/tests/interface-stability/base-exports.stdout

@@ -292,7 +292,7 @@ module Control.Exception where
   mask_ :: forall a. GHC.Types.IO a -> GHC.Types.IO a
   onException :: forall a b. GHC.Types.IO a -> GHC.Types.IO b -> GHC.Types.IO a
   someExceptionContext :: SomeException -> GHC.Internal.Exception.Context.ExceptionContext
-  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (?callStack::GHC.Internal.Stack.Types.CallStack, Exception e) => e -> a
+  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> a
   throwIO :: forall e a. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> GHC.Types.IO a
   throwTo :: forall e. Exception e => GHC.Internal.Conc.Sync.ThreadId -> e -> GHC.Types.IO ()
   try :: forall e a. Exception e => GHC.Types.IO a -> GHC.Types.IO (GHC.Internal.Data.Either.Either e a)
@@ -407,7 +407,7 @@ module Control.Exception.Base where
   patError :: forall (q :: GHC.Types.RuntimeRep) (a :: TYPE q). GHC.Prim.Addr# -> a
   recConError :: forall (q :: GHC.Types.RuntimeRep) (a :: TYPE q). GHC.Prim.Addr# -> a
   recSelError :: forall (q :: GHC.Types.RuntimeRep) (a :: TYPE q). GHC.Prim.Addr# -> a
-  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (?callStack::GHC.Internal.Stack.Types.CallStack, Exception e) => e -> a
+  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> a
   throwIO :: forall e a. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> GHC.Types.IO a
   throwTo :: forall e. Exception e => GHC.Internal.Conc.Sync.ThreadId -> e -> GHC.Types.IO ()
   try :: forall e a. Exception e => GHC.Types.IO a -> GHC.Types.IO (GHC.Internal.Data.Either.Either e a)
@@ -5319,7 +5319,7 @@ module GHC.Exception where
   prettySrcLoc :: SrcLoc -> GHC.Internal.Base.String
   ratioZeroDenomException :: SomeException
   showCCSStack :: [GHC.Internal.Base.String] -> [GHC.Internal.Base.String]
-  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (?callStack::CallStack, Exception e) => e -> a
+  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> a
   underflowException :: SomeException
 module GHC.Exception.Type where

testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs

@@ -292,7 +292,7 @@ module Control.Exception where
   mask_ :: forall a. GHC.Types.IO a -> GHC.Types.IO a
   onException :: forall a b. GHC.Types.IO a -> GHC.Types.IO b -> GHC.Types.IO a
   someExceptionContext :: SomeException -> GHC.Internal.Exception.Context.ExceptionContext
-  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (?callStack::GHC.Internal.Stack.Types.CallStack, Exception e) => e -> a
+  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> a
   throwIO :: forall e a. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> GHC.Types.IO a
   throwTo :: forall e. Exception e => GHC.Internal.Conc.Sync.ThreadId -> e -> GHC.Types.IO ()
   try :: forall e a. Exception e => GHC.Types.IO a -> GHC.Types.IO (GHC.Internal.Data.Either.Either e a)
@@ -407,7 +407,7 @@ module Control.Exception.Base where
   patError :: forall (q :: GHC.Types.RuntimeRep) (a :: TYPE q). GHC.Prim.Addr# -> a
   recConError :: forall (q :: GHC.Types.RuntimeRep) (a :: TYPE q). GHC.Prim.Addr# -> a
   recSelError :: forall (q :: GHC.Types.RuntimeRep) (a :: TYPE q). GHC.Prim.Addr# -> a
-  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (?callStack::GHC.Internal.Stack.Types.CallStack, Exception e) => e -> a
+  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> a
   throwIO :: forall e a. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> GHC.Types.IO a
   throwTo :: forall e. Exception e => GHC.Internal.Conc.Sync.ThreadId -> e -> GHC.Types.IO ()
   try :: forall e a. Exception e => GHC.Types.IO a -> GHC.Types.IO (GHC.Internal.Data.Either.Either e a)
@@ -5288,7 +5288,7 @@ module GHC.Exception where
   prettySrcLoc :: SrcLoc -> GHC.Internal.Base.String
   ratioZeroDenomException :: SomeException
   showCCSStack :: [GHC.Internal.Base.String] -> [GHC.Internal.Base.String]
-  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (?callStack::CallStack, Exception e) => e -> a
+  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> a
   underflowException :: SomeException
 module GHC.Exception.Type where

testsuite/tests/interface-stability/base-exports.stdout-mingw32

@@ -292,7 +292,7 @@ module Control.Exception where
   mask_ :: forall a. GHC.Types.IO a -> GHC.Types.IO a
   onException :: forall a b. GHC.Types.IO a -> GHC.Types.IO b -> GHC.Types.IO a
   someExceptionContext :: SomeException -> GHC.Internal.Exception.Context.ExceptionContext
-  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (?callStack::GHC.Internal.Stack.Types.CallStack, Exception e) => e -> a
+  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> a
   throwIO :: forall e a. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> GHC.Types.IO a
   throwTo :: forall e. Exception e => GHC.Internal.Conc.Sync.ThreadId -> e -> GHC.Types.IO ()
   try :: forall e a. Exception e => GHC.Types.IO a -> GHC.Types.IO (GHC.Internal.Data.Either.Either e a)
@@ -407,7 +407,7 @@ module Control.Exception.Base where
   patError :: forall (q :: GHC.Types.RuntimeRep) (a :: TYPE q). GHC.Prim.Addr# -> a
   recConError :: forall (q :: GHC.Types.RuntimeRep) (a :: TYPE q). GHC.Prim.Addr# -> a
   recSelError :: forall (q :: GHC.Types.RuntimeRep) (a :: TYPE q). GHC.Prim.Addr# -> a
-  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (?callStack::GHC.Internal.Stack.Types.CallStack, Exception e) => e -> a
+  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> a
   throwIO :: forall e a. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> GHC.Types.IO a
   throwTo :: forall e. Exception e => GHC.Internal.Conc.Sync.ThreadId -> e -> GHC.Types.IO ()
   try :: forall e a. Exception e => GHC.Types.IO a -> GHC.Types.IO (GHC.Internal.Data.Either.Either e a)
@@ -5465,7 +5465,7 @@ module GHC.Exception where
   prettySrcLoc :: SrcLoc -> GHC.Internal.Base.String
   ratioZeroDenomException :: SomeException
   showCCSStack :: [GHC.Internal.Base.String] -> [GHC.Internal.Base.String]
-  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (?callStack::CallStack, Exception e) => e -> a
+  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> a
   underflowException :: SomeException
 module GHC.Exception.Type where

testsuite/tests/interface-stability/base-exports.stdout-ws-32

@@ -292,7 +292,7 @@ module Control.Exception where
   mask_ :: forall a. GHC.Types.IO a -> GHC.Types.IO a
   onException :: forall a b. GHC.Types.IO a -> GHC.Types.IO b -> GHC.Types.IO a
   someExceptionContext :: SomeException -> GHC.Internal.Exception.Context.ExceptionContext
-  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (?callStack::GHC.Internal.Stack.Types.CallStack, Exception e) => e -> a
+  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> a
   throwIO :: forall e a. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> GHC.Types.IO a
   throwTo :: forall e. Exception e => GHC.Internal.Conc.Sync.ThreadId -> e -> GHC.Types.IO ()
   try :: forall e a. Exception e => GHC.Types.IO a -> GHC.Types.IO (GHC.Internal.Data.Either.Either e a)
@@ -407,7 +407,7 @@ module Control.Exception.Base where
   patError :: forall (q :: GHC.Types.RuntimeRep) (a :: TYPE q). GHC.Prim.Addr# -> a
   recConError :: forall (q :: GHC.Types.RuntimeRep) (a :: TYPE q). GHC.Prim.Addr# -> a
   recSelError :: forall (q :: GHC.Types.RuntimeRep) (a :: TYPE q). GHC.Prim.Addr# -> a
-  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (?callStack::GHC.Internal.Stack.Types.CallStack, Exception e) => e -> a
+  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> a
   throwIO :: forall e a. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> GHC.Types.IO a
   throwTo :: forall e. Exception e => GHC.Internal.Conc.Sync.ThreadId -> e -> GHC.Types.IO ()
   try :: forall e a. Exception e => GHC.Types.IO a -> GHC.Types.IO (GHC.Internal.Data.Either.Either e a)
@@ -5319,7 +5319,7 @@ module GHC.Exception where
   prettySrcLoc :: SrcLoc -> GHC.Internal.Base.String
   ratioZeroDenomException :: SomeException
   showCCSStack :: [GHC.Internal.Base.String] -> [GHC.Internal.Base.String]
-  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (?callStack::CallStack, Exception e) => e -> a
+  throw :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) e. (GHC.Internal.Stack.Types.HasCallStack, Exception e) => e -> a
   underflowException :: SomeException
 module GHC.Exception.Type where

testsuite/tests/rts/Makefile

@@ -126,6 +126,12 @@ EventlogOutput2:
 	./EventlogOutput +RTS -l
 	ls EventlogOutput.eventlog >/dev/null
 
+.PHONY: T17747
+T17747:
+	$(RM) T17747_c.o T17747.o T17747.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make T17747 T17747_c.c T17747_cmm.cmm -I$(TOP)/../rts
+	./T17747
+
 .PHONY: EventlogOutputNull
 EventlogOutputNull:
 	"$(TEST_HC)" -rtsopts -v0 EventlogOutput.hs

testsuite/tests/rts/T17747.hs

+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+
+module Main (main) where
+
+import Foreign.C
+import Foreign.Ptr
+import Foreign.Storable
+import System.Mem (performMajorGC)
+
+import GHC.Exts
+import GHC.Base (IO(IO))
+
+
+-- | Test that we can allocate 'ByteArray#'s outside of the @HEAP_ALLOCED()@ address space without
+-- upsetting the GC. To be extra sure we attach weak pointers with C finalizers to the
+-- 'ByteArray#'s. We keep them alive and run a major GC so that the GC has to trace the live
+-- 'ByteArray#'s.
+--
+-- On older GHC versions this upsets the GC because it does not expect heap objects with closure
+-- type @ARR_WORDS@ to exist outside the heap.
+--
+-- > internal error: evacuate(static): strange closure type 42
+--
+-- Finally we free the backing memory with `unsafeFreeByteArray`. Then we rerun the GC'd again.
+-- Note: When connecting finalizers they seem to fire on shutdown of the RTS not on a major GC
+-- invocation.
+--
+main :: IO ()
+main = do
+    heapallocedTest
+
+    bytearrayTest
+
+-- | This checks that the CMM impl of HEAP_ALLOCED matches the behaviour of
+-- the C version. This test lives here since the CMM HEAP_ALLOCED is used by
+-- the isByteArrayPinned# primop now that it supports byte arrays that are
+-- not themselves HEAP_ALLOCED.
+--
+heapallocedTest :: IO ()
+heapallocedTest = do
+    let same = and [ c_HEAP_ALLOCED ptr == cmm_HEAP_ALLOCED ptr
+                   | addr <- addrs
+                   , let ptr = plusPtr nullPtr addr ]
+    putStrLn ("HEAP_ALLOCED  = " ++ show same
+                 ++ "\t(c_HEAP_ALLOCED ptr == cmm_HEAP_ALLOCED ptr)")
+  where
+    -- For values selected here see OSMem.c
+    heapLowerbound = 8 * (2^30) -- 8GB lower bound starting index of the heap
+    heapDefaultStart = 0x4200000000 -- > 32GB default starting address of the heap
+    heapSizes = [0 -- Check the heap lower starting bound
+                , 2^40, 2^38] -- Check the heap upper bounds at both 1TB and 1/4TB of virtual memory
+    addrs
+      -- Addresses around the start of the heap
+      = [heapStart + heapSize + offset
+          | heapStart <- [heapLowerbound, heapDefaultStart]
+          , heapSize <-  heapSizes
+          , offset <- [-1000..1000]] -- Area of the bounds check
+      -- 2k address probes, appropriate to the address space
+      ++ case sizeOf (nullPtr :: Ptr ()) of
+        4 -> [0, 2^21 .. 2^32-1] -- 0 to 4Gb-1 in 2Mb jumps
+        8 -> [0, 2^30 .. 2^41-1] -- 0 to 2Tb-1 in 1Gb jumps
+        _ -> error "sizeOf ptr not 4 or 8"
+
+bytearrayTest :: IO ()
+bytearrayTest = do
+    printMallocCount "initial"
+
+    let byteLengths = [0..99]
+
+    -- malloc() a bunch of ByteArray#s on the C heap
+    (foreignPtrs, foreignBAs) <- unzip <$> mapM newForeignHeapByteArray byteLengths
+    printMallocCount "alloced"
+
+    -- allocate a bunch of ByteArray#s on the GHC heap
+    nativeBAs <- mapM newNativeHeapByteArray byteLengths
+
+    -- as a sanity check compare them to each other
+    let same = and (zipWith equalByteArrays foreignBAs nativeBAs)
+    putStrLn ("arrays equal  = " ++ show same
+                ++ "\t(and (zipWith equalByteArrays foreignBAs nativeBAs))")
+
+    -- and test the isByteArrayPinned# primop on them foreign byte arrays
+    let pinnedForeign = all isByteArrayPinned foreignBAs
+    putStrLn ("arrays pinned = " ++ show pinnedForeign
+                 ++ "\t(all isByteArrayPinned foreignBAs)")
+
+    -- and test the isByteArrayPinned# primop on them native byte arrays
+    let pinnedNative = all isByteArrayPinned nativeBAs
+    putStrLn ("arrays pinned = " ++ show pinnedNative
+                 ++ "\t(all isByteArrayPinned nativeBAs)")
+
+    -- while they're still live, have the GC inspect them all
+    performMajorGC
+    printMallocCount "alive"
+    mapM_ touchByteArray foreignBAs
+
+    -- after they have been freed, have another GC run
+    mapM_ unsafeFreeByteArray foreignPtrs
+    -- WARNING: DO NOT USE `foreignPtrs` OR `foreignBAs` AFTER THIS POINT
+    -- We have released the memory backing the byte arrays
+    performMajorGC
+    printMallocCount "final"
+
+printMallocCount :: String -> IO ()
+printMallocCount phase = do
+    n <- getMallocByteArrayCount
+    putStrLn ("malloc_count  = " ++ show n ++ "\t" ++ phase)
+
+data ByteArray        = ByteArray ByteArray#
+data MutableByteArray = MutableByteArray (MutableByteArray# RealWorld)
+
+newNativeHeapByteArray :: Int -> IO ByteArray
+newNativeHeapByteArray n = do
+    mba <- newByteArray n
+    fillAndFreezeByteArray mba n
+
+newForeignHeapByteArray :: Int -> IO (Ptr a, ByteArray)
+newForeignHeapByteArray n = do
+    -- mallocByteArray also allocates memory for the header of a ByteArray#
+    ptr <- mallocByteArray (fromIntegral n)
+    -- placeByteArray# writes the ByteArray# header in this additionally allocated memory
+    mba <- placeByteArray ptr n
+    ba  <- fillAndFreezeByteArray mba n
+    pure (ptr, ba)
+
+newByteArray :: Int -> IO MutableByteArray
+newByteArray  (I# n#) =
+    IO $ \s0 ->
+      case newByteArray# n# s0 of
+        (# s1, mba# #) -> (# s1, MutableByteArray mba# #)
+
+placeByteArray :: Ptr a -> Int -> IO MutableByteArray
+placeByteArray (Ptr addr#) (I# n#) =
+    IO $ \s0 ->
+      case placeByteArray# addr# n# s0 of
+        (# s1, mba# #) -> (# s1, MutableByteArray mba# #)
+
+fillAndFreezeByteArray :: MutableByteArray -> Int -> IO ByteArray
+fillAndFreezeByteArray (MutableByteArray mba#) (I# n#) =
+    IO $ \s0 ->
+      case setByteArray# mba# 0# n# n# s0 of
+        s1 ->
+          case unsafeFreezeByteArray# mba# s1 of
+            (# s2, ba# #) -> (# s2, ByteArray ba# #)
+
+touchByteArray :: ByteArray -> IO ()
+touchByteArray (ByteArray ba#) =
+    IO $ \s0 ->
+      case touch# ba# s0 of
+        s1 -> (# s1, () #)
+
+equalByteArrays :: ByteArray -> ByteArray -> Bool
+equalByteArrays (ByteArray ba1#) (ByteArray ba2#)
+  | let ba1len = I# (sizeofByteArray# ba1#)
+        ba2len = I# (sizeofByteArray# ba2#)
+        I# balen# = ba1len
+  , ba1len == ba2len
+  = isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# balen#)
+
+isByteArrayPinned :: ByteArray -> Bool
+isByteArrayPinned (ByteArray ba#) = isTrue# (isByteArrayPinned# ba#)
+
+cmm_HEAP_ALLOCED :: Ptr a -> Int
+cmm_HEAP_ALLOCED (Ptr addr#) = I# (cmm_HEAP_ALLOCED# addr#)
+
+
+foreign import ccall unsafe "mallocByteArray"
+  mallocByteArray :: CInt -> IO (Ptr a)
+
+foreign import ccall unsafe "unsafeFreeByteArray"
+  unsafeFreeByteArray :: Ptr a -> IO ()
+
+foreign import ccall unsafe "getMallocByteArrayCount"
+  getMallocByteArrayCount :: IO CInt
+
+foreign import ccall unsafe "c_HEAP_ALLOCED"
+  c_HEAP_ALLOCED :: Ptr a -> Int
+
+foreign import prim "cmm_HEAP_ALLOCED"
+  cmm_HEAP_ALLOCED# :: Addr# -> Int#

testsuite/tests/rts/T17747.stdout

+HEAP_ALLOCED  = True	(c_HEAP_ALLOCED ptr == cmm_HEAP_ALLOCED ptr)
+malloc_count  = 0	initial
+malloc_count  = 100	alloced
+arrays equal  = True	(and (zipWith equalByteArrays foreignBAs nativeBAs))
+arrays pinned = True	(all isByteArrayPinned foreignBAs)
+arrays pinned = False	(all isByteArrayPinned nativeBAs)
+malloc_count  = 100	alive
+malloc_count  = 0	final