testsuite: Add tests for #14375

5 files changed, 99 insertions, 0 deletions

diff --git a/testsuite/tests/primops/should_run/T14375-2.hs b/testsuite/tests/primops/should_run/T14375-2.hs
new file mode 100644
index 0000000000..8f53c5d62f
--- /dev/null
+++ b/testsuite/tests/primops/should_run/T14375-2.hs
@@ -0,0 +1,38 @@
+-- Make sure @with#@ holds on to its argument, as promised, keeping it from
+-- being garbage-collected.
+
+{-#LANGUAGE MagicHash #-}
+
+import System.Mem
+import System.Mem.Weak
+import GHC.Base
+import GHC.IO
+import GHC.Prim
+import Control.Concurrent
+import Control.Monad
+
+main = do
+  do
+    -- For reasons that are unclear to me, we have to nest the @let@ binding in
+    -- another @do@ block in order to make its scope smaller. If we scope @a@
+    -- on the entire body of 'main', then the finalizer doesn't seem to run
+    -- at all.
+    let a = 2
+    mkWeakPtr a (Just $ putStrLn "finalize")
+    with a $ do
+      putStrLn "with"
+      performMajorGC
+      threadDelay 10000
+      putStrLn "without"
+    performMajorGC
+    threadDelay 10000
+    putStrLn "going"
+
+  performMajorGC
+  threadDelay 10000
+  putStrLn "gone"
+
+-- | A simple wrapper for 'with#', making it more palatable to normal 'IO'
+-- code.
+with :: a -> IO () -> IO ()
+with thing action = IO (with# thing $ unIO action)
diff --git a/testsuite/tests/primops/should_run/T14375-2.stdout b/testsuite/tests/primops/should_run/T14375-2.stdout
new file mode 100644
index 0000000000..006ff3031f
--- /dev/null
+++ b/testsuite/tests/primops/should_run/T14375-2.stdout
@@ -0,0 +1,5 @@
+with
+without
+finalize
+going
+gone
diff --git a/testsuite/tests/primops/should_run/T14375.hs b/testsuite/tests/primops/should_run/T14375.hs
new file mode 100644
index 0000000000..a9a6424757
--- /dev/null
+++ b/testsuite/tests/primops/should_run/T14375.hs
@@ -0,0 +1,52 @@
+-- Check that the bug from #14346 doesn't regress.
+--
+-- We currently have (at least) two remedies in place: the workaround of
+-- marking @allocaBytes(Aligned)@ as @INLINE@, and the new @with#@ primop
+-- described in #14375, which should solve the root cause.
+--
+-- To reproduce the problem, we need to trick the optimizer into considering
+-- the end of the allocaBytes scope unreachable; we do this by using @forever@,
+-- and then throwing an exception inside it after we have run enough iterations
+-- to either trigger the bug or conclude that things are fine.
+
+{-#LANGUAGE LambdaCase #-}
+
+import System.Mem
+import System.Mem.Weak
+import Control.Concurrent
+import Control.Monad
+import System.IO
+import Data.Maybe
+import Data.Word
+import GHC.Prim
+import Foreign.Marshal.Alloc
+import Foreign.Storable
+import Control.Exception
+import Text.Printf
+import Numeric
+
+newtype Stop = Stop String
+  deriving (Show)
+
+instance Exception Stop where
+
+main = go `catch` handle
+  where
+    handle :: Stop -> IO ()
+    handle (Stop e) = putStrLn e
+
+go :: IO ()
+go = do
+  replicateM_ 1000 $ threadDelay 1
+  allocaBytes 4 $ \p -> do
+    performMajorGC
+    poke p (0xdeadbeef :: Word32)
+    forever $ do
+      replicateM_ 10000 $ do
+        threadDelay 10
+        performMajorGC
+        x <- peek p
+        unless (x == 0xdeadbeef) $ do
+          putStrLn $ showHex x ""
+          throw (Stop "invalid") -- detected bug: abort.
+      throw (Stop "OK") -- probably no bug: abort.
diff --git a/testsuite/tests/primops/should_run/T14375.stdout b/testsuite/tests/primops/should_run/T14375.stdout
new file mode 100644
index 0000000000..d86bac9de5
--- /dev/null
+++ b/testsuite/tests/primops/should_run/T14375.stdout
@@ -0,0 +1 @@
+OK
diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T
index bbcbdd8f78..b96b09ffe0 100644
--- a/testsuite/tests/primops/should_run/all.T
+++ b/testsuite/tests/primops/should_run/all.T
@@ -28,3 +28,6 @@ test('CmpInt16', normal, compile_and_run, [''])
 test('CmpWord16', normal, compile_and_run, [''])
 test('ShrinkSmallMutableArrayA', normal, compile_and_run, [''])
 test('ShrinkSmallMutableArrayB', normal, compile_and_run, [''])
+
+test('T14375', normal, compile_and_run, ['-threaded'])
+test('T14375-2', normal, compile_and_run, [''])