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

2 files changed, 79 insertions, 0 deletions

diff --git a/testsuite/tests/rts/T11108.hs b/testsuite/tests/rts/T11108.hs
new file mode 100644
index 0000000000..d70f333435
--- /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 720ebfb4c2..d462e39c72 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.