[commit: ghc] wip/tdammers/T14375: Tests for T14375 (b98fb15)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/tdammers/T14375
Link       : http://ghc.haskell.org/trac/ghc/changeset/b98fb15b3e6ee5bf01f37abe3598fa8145ed3c7b/ghc

>---------------------------------------------------------------

commit b98fb15b3e6ee5bf01f37abe3598fa8145ed3c7b
Author: Tobias Dammers <tdammers at gmail.com>
Date:   Tue Nov 27 13:16:57 2018 +0100

    Tests for T14375


>---------------------------------------------------------------

b98fb15b3e6ee5bf01f37abe3598fa8145ed3c7b
 testsuite/tests/primops/should_run/T14375-2.hs     | 38 ++++++++++++++++
 testsuite/tests/primops/should_run/T14375-2.stdout |  5 +++
 testsuite/tests/primops/should_run/T14375.hs       | 52 ++++++++++++++++++++++
 .../should_run/T14375.stdout}                      |  0
 testsuite/tests/primops/should_run/all.T           |  3 ++
 5 files changed, 98 insertions(+)

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 0000000..8f53c5d
--- /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 0000000..006ff30
--- /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 0000000..a9a6424
--- /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/driver/T11763.stdout b/testsuite/tests/primops/should_run/T14375.stdout
similarity index 100%
copy from testsuite/tests/driver/T11763.stdout
copy to testsuite/tests/primops/should_run/T14375.stdout
diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T
index 46954e3..2872d2b 100644
--- a/testsuite/tests/primops/should_run/all.T
+++ b/testsuite/tests/primops/should_run/all.T
@@ -23,3 +23,6 @@ test('ArithInt16', normal, compile_and_run, [''])
 test('ArithWord16', normal, compile_and_run, [''])
 test('CmpInt16', normal, compile_and_run, [''])
 test('CmpWord16', normal, compile_and_run, [''])
+
+test('T14375', normal, compile_and_run, ['-threaded'])
+test('T14375-2', normal, compile_and_run, [''])