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,10 +1966,17 @@ 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 for the specified size (in bytes), at the
-    specified address outside of the heap, in the specified state thread.}
+   {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
 

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

rts/Inlines.c

@@ -9,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;
@@ -134,6 +135,7 @@ stg_newByteArrayzh ( W_ n )
 }
 
 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. */
@@ -147,6 +149,7 @@ stg_placeByteArrayzh ( W_ addr, W_ n )
 #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;
@@ -214,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 )
@@ -2986,4 +3002,3 @@ stg_castFloatToWord32zh(F_ f)
 
     return (w);
 }
-

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,17 +60,39 @@ 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
 } ATTRIBUTE_ALIGNED(64);
 extern struct mblock_address_range mblock_address_space;
 
+// This implementation is duplicated to `Cmm` because performing an `ccall` is relatively high
+// compared to the bounds check performed here. If this implementation changes the decisions should
+// be reevaluated.
 # define HEAP_ALLOCED(p)        ((W_)(p) >= mblock_address_space.begin && \
                                  (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;
+
+// We explicitly duplicate the bound checking implementation of `HEAP_ALLOCED` for performance
+// reasons. It doesn't make sense to perform a `ccall` for such a simple implementation.
+# 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 +100,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 +167,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 +207,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 +261,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/sm/Evac.c

@@ -741,6 +741,7 @@ 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/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

testsuite/tests/rts/T17747_c.c

+#include "Rts.h"
+#include "rts/storage/HeapAlloc.h"
+
+int malloc_count = 0;
+
+void *mallocByteArray (StgWord len)
+{
+  malloc_count++;
+
+  /* allocate enough space for the object header + length */
+  return malloc(sizeof(StgArrBytes) + len);
+}
+
+void unsafeFreeByteArray (void *arr)
+{
+    free(arr);
+    malloc_count--;
+}
+
+int getMallocByteArrayCount(void)
+{
+  return malloc_count;
+}
+
+int c_HEAP_ALLOCED(void * p)
+{
+  return HEAP_ALLOCED(p);
+}

testsuite/tests/rts/T17747_cmm.cmm

+#include "Cmm.h"
+#include "rts/storage/HeapAlloc.h" /* for HEAP_ALLOCED() */
+
+cmm_HEAP_ALLOCED ( W_ p )
+// Addr# -> Int#
+{
+#if defined(HEAP_ALLOCED)
+    if (HEAP_ALLOCED(p)) {
+#else
+    W_ result;
+    HEAP_ALLOCED_CALLISH(result, p)
+    if (result == 1) {
+#endif
+        return (1);
+    } else {
+        return (0);
+    }
+}

testsuite/tests/rts/all.T

@@ -523,6 +523,13 @@ test('T17088',
      compile_and_run, ['-rtsopts -O2'])
 
 test('T15427', js_broken(22374), compile_and_run, [''])
+test('T17747',
+     [# This test tries to allocate virtual memory outside of the managed heap.
+      # The required primops are not available on the following platforms:
+      when(arch('javascript'), expect_fail),
+      when(arch('wasm32'), expect_fail)],
+     makefile_test,
+     ['T17747'])
 
 test('T19481',
      [extra_run_opts('+RTS -T -RTS'),