testsuite/tests/rts/T17747.hs

@@ -15,33 +15,26 @@ 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.
+-- | 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.
+-- 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 allow everything to be GC'd again, and check that the C
--- finalizers did run.
+-- 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
 
-    n1 <- getMallocByteArrayCount
-    putStrLn ("malloc_count  = " ++ show n1)
-
     bytearrayTest
 
-    -- check that all the C finalizers ran to free() the things we allocated
-    performMajorGC
-    n2 <- getMallocByteArrayCount
-    putStrLn ("malloc_count  = " ++ show n1)
-
 -- | 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
@@ -55,10 +48,17 @@ heapallocedTest = do
     putStrLn ("HEAP_ALLOCED  = " ++ show same
                  ++ "\t(c_HEAP_ALLOCED ptr == cmm_HEAP_ALLOCED ptr)")
   where
-    heapStart = 0x4200000000
+    -- 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 + offset | offset <- [-1000..1000]]
+      = [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
@@ -67,31 +67,48 @@ heapallocedTest = do
 
 bytearrayTest :: IO ()
 bytearrayTest = do
+    printMallocCount "initial"
+
+    let byteLengths = [0..99]
 
     -- malloc() a bunch of ByteArray#s on the C heap
-    foreignBAs <- mapM newForeignHeapByteArray [0..99]
-    n1 <- getMallocByteArrayCount
-    putStrLn ("malloc_count  = " ++ show n1)
+    (foreignPtrs, foreignBAs) <- unzip <$> mapM newForeignHeapByteArray byteLengths
+    printMallocCount "alloced"
 
     -- allocate a bunch of ByteArray#s on the GHC heap
-    nativeBAs <- mapM newNativeHeapByteArray [0..99]
+    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 all
-    let pinned = all isByteArrayPinned foreignBAs
-    putStrLn ("arrays pinned = " ++ show pinned
+    -- 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
-    n2 <- getMallocByteArrayCount
-    putStrLn ("malloc_count  = " ++ show n2)
+    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)
@@ -101,12 +118,14 @@ newNativeHeapByteArray n = do
     mba <- newByteArray n
     fillAndFreezeByteArray mba n
 
-newForeignHeapByteArray :: Int -> IO ByteArray
+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
-    addCFinalizerToByteArray mba freeByteArray ptr
-    fillAndFreezeByteArray mba n
+    ba  <- fillAndFreezeByteArray mba n
+    pure (ptr, ba)
 
 newByteArray :: Int -> IO MutableByteArray
 newByteArray  (I# n#) =
@@ -128,18 +147,6 @@ fillAndFreezeByteArray (MutableByteArray mba#) (I# n#) =
           case unsafeFreezeByteArray# mba# s1 of
             (# s2, ba# #) -> (# s2, ByteArray ba# #)
 
-addCFinalizerToByteArray :: MutableByteArray
-                         -> FunPtr (Ptr a -> IO ())
-                         -> Ptr a
-                         -> IO ()
-addCFinalizerToByteArray (MutableByteArray ba#) (FunPtr cfunptr#) (Ptr ptr#) =
-    IO $ \s0 ->
-      case mkWeakNoFinalizer# ba# () s0 of
-        (# s1, weak# #) ->
-          -- 0# flag here means don't pass any env ptr to the finalizer
-          case addCFinalizerToWeak# cfunptr# ptr# 0# nullAddr# weak# s1 of
-            (# s2, _success# #) -> (# s2, () #)
-
 touchByteArray :: ByteArray -> IO ()
 touchByteArray (ByteArray ba#) =
     IO $ \s0 ->
@@ -164,8 +171,8 @@ cmm_HEAP_ALLOCED (Ptr addr#) = I# (cmm_HEAP_ALLOCED# addr#)
 foreign import ccall unsafe "mallocByteArray"
   mallocByteArray :: CInt -> IO (Ptr a)
 
-foreign import ccall unsafe "&freeByteArray"
-  freeByteArray :: FunPtr (Ptr a -> IO ())
+foreign import ccall unsafe "unsafeFreeByteArray"
+  unsafeFreeByteArray :: Ptr a -> IO ()
 
 foreign import ccall unsafe "getMallocByteArrayCount"
   getMallocByteArrayCount :: IO CInt
@@ -175,4 +182,3 @@ foreign import ccall unsafe "c_HEAP_ALLOCED"
 
 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
-malloc_count  = 100
+malloc_count  = 0	initial
+malloc_count  = 100	alloced
 arrays equal  = True	(and (zipWith equalByteArrays foreignBAs nativeBAs))
 arrays pinned = True	(all isByteArrayPinned foreignBAs)
-malloc_count  = 100
-malloc_count  = 0
+arrays pinned = False	(all isByteArrayPinned nativeBAs)
+malloc_count  = 100	alive
+malloc_count  = 0	final

testsuite/tests/rts/T17747_c.c

@@ -11,7 +11,7 @@ void *mallocByteArray (StgWord len)
   return malloc(sizeof(StgArrBytes) + len);
 }
 
-void freeByteArray (void *arr)
+void unsafeFreeByteArray (void *arr)
 {
     free(arr);
     malloc_count--;
@@ -26,4 +26,3 @@ int c_HEAP_ALLOCED(void * p)
 {
   return HEAP_ALLOCED(p);
 }
-

testsuite/tests/rts/all.T

@@ -532,7 +532,10 @@ 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)],
+      when(arch('wasm32'), expect_fail),
+      # Cross compiling fails for:
+      # x86_64-linux-alpine3_17-wasm-cross_wasm32-wasi-release+fully_static
+      when(isCross(), expect_fail)],
      makefile_test,
      ['T17747'])