diff options
author | Tobias Dammers <tdammers@gmail.com> | 2018-11-27 13:16:57 +0100 |
---|---|---|
committer | Tobias Dammers <tdammers@gmail.com> | 2018-11-27 14:10:35 +0100 |
commit | b98fb15b3e6ee5bf01f37abe3598fa8145ed3c7b (patch) | |
tree | e6fab2a0c0097154c8d3b186f5c438aeab17cb9c | |
parent | 7099d2dbe6121a549dc6da8ed95b54959154d40c (diff) | |
download | haskell-b98fb15b3e6ee5bf01f37abe3598fa8145ed3c7b.tar.gz |
Tests for T14375
-rw-r--r-- | testsuite/tests/primops/should_run/T14375-2.hs | 38 | ||||
-rw-r--r-- | testsuite/tests/primops/should_run/T14375-2.stdout | 5 | ||||
-rw-r--r-- | testsuite/tests/primops/should_run/T14375.hs | 52 | ||||
-rw-r--r-- | testsuite/tests/primops/should_run/T14375.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/primops/should_run/all.T | 5 |
5 files changed, 100 insertions, 1 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 46954e3c58..2872d2b1c7 100644 --- a/testsuite/tests/primops/should_run/all.T +++ b/testsuite/tests/primops/should_run/all.T @@ -22,4 +22,7 @@ test('ShowPrim', normal, compile_and_run, ['']) test('ArithInt16', normal, compile_and_run, ['']) test('ArithWord16', normal, compile_and_run, ['']) test('CmpInt16', normal, compile_and_run, ['']) -test('CmpWord16', normal, compile_and_run, [''])
\ No newline at end of file +test('CmpWord16', normal, compile_and_run, ['']) + +test('T14375', normal, compile_and_run, ['-threaded']) +test('T14375-2', normal, compile_and_run, ['']) |