[commit: ghc] master: Add a test for #11108 (ba3e1fd)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/ba3e1fd37dc5004c4307ed205f6701b16faceb59/ghc

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

commit ba3e1fd37dc5004c4307ed205f6701b16faceb59
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Tue May 17 19:03:16 2016 +0200

    Add a test for #11108
    
    Reviewers: austin, simonmar, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D2196
    
    GHC Trac Issues: #11108


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

ba3e1fd37dc5004c4307ed205f6701b16faceb59
 testsuite/tests/rts/T11108.hs | 77 +++++++++++++++++++++++++++++++++++++++++++
 testsuite/tests/rts/all.T     |  2 ++
 2 files changed, 79 insertions(+)

diff --git a/testsuite/tests/rts/T11108.hs b/testsuite/tests/rts/T11108.hs
new file mode 100644
index 0000000..d70f333
--- /dev/null
+++ b/testsuite/tests/rts/T11108.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE RecursiveDo, LambdaCase #-}
+
+import Control.Monad.Fix
+import Data.IORef
+import System.Mem.Weak
+import System.Mem
+
+import Control.Monad
+import Data.Foldable
+
+data Pull = Pull
+  { weakSelf  :: Weak Pull
+  , compute :: Weak Pull -> IO Int
+  , invalidators :: IORef [Weak Pull]
+  , cached  :: IORef (Maybe Int)
+  }
+
+
+makePull :: (Weak Pull -> IO Int) -> IO Pull
+makePull f = do
+  rec
+    -- This seems to be the culprit, changing the order makes the weakRef get gc'ed
+    -- In this configuration it crashes
+
+    foo <- Pull weak f <$> newIORef [] <*> newIORef Nothing
+    weak <- mkWeakPtr foo (Just $ print "died")
+
+  return foo
+
+
+invalidate :: Pull -> IO ()
+invalidate p = do
+  writeIORef (cached p) Nothing
+  invs <- readIORef (invalidators p)
+  writeIORef (invalidators p) []
+  traverse_ (deRefWeak >=> traverse_ invalidate) invs
+
+
+pull :: Weak Pull -> Pull -> IO Int
+pull weak p = do
+  modifyIORef (invalidators p) (weak :)
+  pull' p
+
+pull' :: Pull -> IO Int
+pull' p = do
+  readIORef (cached p) >>= \case
+    Nothing -> do
+      r <- compute p (weakSelf p)
+      writeIORef (cached p) (Just r)
+      return r
+
+    Just r -> return r
+
+add :: Pull -> Int -> IO (Pull)
+add p n = makePull (\w -> (+n) <$> pull w p)
+
+main = do
+  h <- newIORef 0
+
+  source <- makePull (const $ readIORef h)
+  p <- foldM add source (take 1000 (repeat 1))   -- 100 is not enough for crash
+
+  forM_ [1..10] $ \i -> do
+
+    writeIORef h i
+    invalidate source -- Crashes here on second iteration
+
+    --performGC
+    -- This avoids the crash
+
+    print =<< pull' p
+
+
+
+
+
+
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index 720ebfb..d462e39 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -260,6 +260,8 @@ test('T9078', [ omit_ways(threaded_ways) ], compile_and_run, ['-with-rtsopts="-D
 test('T10017', [ when(opsys('mingw32'), skip)
                , only_ways(threaded_ways), extra_run_opts('+RTS -N2 -RTS') ], compile_and_run, [''])
 
+test('T11108', normal, compile_and_run, [''])
+
 test('rdynamic', [ unless(opsys('linux') or opsys('mingw32'), skip)
                  # this needs runtime infrastructure to do in ghci:
                  #  '-rdynamic' ghc, load modules only via dlopen(RTLD_BLOBAL) and more.