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,4 +9,4 @@
 #include "Capability.h"
 #include "WSDeque.h"
 #include "SMPClosureOps.h"
-#include "sm/HeapAlloc.h"
+#include "rts/storage/HeapAlloc.h"

rts/PrimOps.cmm

@@ -24,7 +24,7 @@
 #include "Cmm.h"
 #include "MachDeps.h"
 #include "SMPClosureOps.h"
-#include "sm/HeapAlloc.h" /* for HEAP_ALLOCED() */
+#include "rts/storage/HeapAlloc.h" /* for HEAP_ALLOCED() */
 
 #if defined(__PIC__)
 import pthread_mutex_lock;
@@ -135,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. */
@@ -148,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;
@@ -3000,4 +3002,3 @@ stg_castFloatToWord32zh(F_ f)
 
     return (w);
 }
-

rts/include/rts/storage/HeapAlloc.h

@@ -78,6 +78,8 @@ extern struct mblock_address_range mblock_address_space;
 
 #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
@@ -100,10 +102,12 @@ extern StgWord8 mblock_map[];
 
 #else /* defined(CMINUSMINUS) */
 
+/* See Note [Byte arrays outside of the HEAP_ALLOCED space] */
+
 import CLOSURE mblock_map;
 
 # define MBLOCK_MAP_ENTRY(p)    ((p) >> MBLOCK_SHIFT)
-# define HEAP_ALLOCED(p)        I8[mblock_map + MBLOCK_MAP_ENTRY(p)]
+# define HEAP_ALLOCED(p)        (TO_W_(I8[mblock_map + MBLOCK_MAP_ENTRY(p)]) != 0)
 
 #endif
 
@@ -259,6 +263,8 @@ 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

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/interface-stability/base-exports.stdout

@@ -4223,6 +4223,7 @@ module GHC.Base where
   pext32# :: Word# -> Word# -> Word#
   pext64# :: Word64# -> Word64# -> Word64#
   pext8# :: Word# -> Word# -> Word#
+  placeByteArray# :: forall d. Addr# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
   plusAddr# :: Addr# -> Int# -> Addr#
   plusDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
   plusDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
@@ -6325,6 +6326,7 @@ module GHC.Exts where
   pext32# :: Word# -> Word# -> Word#
   pext64# :: Word64# -> Word64# -> Word64#
   pext8# :: Word# -> Word# -> Word#
+  placeByteArray# :: forall d. Addr# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
   plusAddr# :: Addr# -> Int# -> Addr#
   plusDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
   plusDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#

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

@@ -4223,6 +4223,7 @@ module GHC.Base where
   pext32# :: Word# -> Word# -> Word#
   pext64# :: Word64# -> Word64# -> Word64#
   pext8# :: Word# -> Word# -> Word#
+  placeByteArray# :: forall d. Addr# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
   plusAddr# :: Addr# -> Int# -> Addr#
   plusDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
   plusDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
@@ -6294,6 +6295,7 @@ module GHC.Exts where
   pext32# :: Word# -> Word# -> Word#
   pext64# :: Word64# -> Word64# -> Word64#
   pext8# :: Word# -> Word# -> Word#
+  placeByteArray# :: forall d. Addr# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
   plusAddr# :: Addr# -> Int# -> Addr#
   plusDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
   plusDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#

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

@@ -4226,6 +4226,7 @@ module GHC.Base where
   pext32# :: Word# -> Word# -> Word#
   pext64# :: Word64# -> Word64# -> Word64#
   pext8# :: Word# -> Word# -> Word#
+  placeByteArray# :: forall d. Addr# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
   plusAddr# :: Addr# -> Int# -> Addr#
   plusDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
   plusDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
@@ -6474,6 +6475,7 @@ module GHC.Exts where
   pext32# :: Word# -> Word# -> Word#
   pext64# :: Word64# -> Word64# -> Word64#
   pext8# :: Word# -> Word# -> Word#
+  placeByteArray# :: forall d. Addr# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
   plusAddr# :: Addr# -> Int# -> Addr#
   plusDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
   plusDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#

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

@@ -4223,6 +4223,7 @@ module GHC.Base where
   pext32# :: Word# -> Word# -> Word#
   pext64# :: Word64# -> Word64# -> Word64#
   pext8# :: Word# -> Word# -> Word#
+  placeByteArray# :: forall d. Addr# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
   plusAddr# :: Addr# -> Int# -> Addr#
   plusDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
   plusDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#
@@ -6325,6 +6326,7 @@ module GHC.Exts where
   pext32# :: Word# -> Word# -> Word#
   pext64# :: Word64# -> Word64# -> Word64#
   pext8# :: Word# -> Word# -> Word#
+  placeByteArray# :: forall d. Addr# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
   plusAddr# :: Addr# -> Int# -> Addr#
   plusDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2#
   plusDoubleX4# :: DoubleX4# -> DoubleX4# -> DoubleX4#

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,16 @@ 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),
+      #  The virtual memory that is allocated outside of the managed heap is outside the 32 bit
+      #  pointer space. This is a problem due to the smaller address space this architecture allows.
+      when(opsys('i386'), expect_fail)],
+     makefile_test,
+     ['T17747'])
 
 test('T19481',
      [extra_run_opts('+RTS -T -RTS'),