testsuite: 21651 add test for closeFdWith + setNumCapabilities

This bug does not affect windows, which does not use the
base module GHC.Event.Thread.

3 files changed, 135 insertions, 1 deletions

diff --git a/testsuite/tests/concurrent/should_run/T21651.hs b/testsuite/tests/concurrent/should_run/T21651.hs
new file mode 100644
index 0000000000..bb9fba26e1
--- /dev/null
+++ b/testsuite/tests/concurrent/should_run/T21651.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+-- This test is adapted from setnumcapabilities001.
+
+import GHC.Conc hiding (threadWaitRead, threadWaitWrite)
+import GHC.Exts
+import GHC.IO.Encoding
+import System.Environment
+import System.IO
+import Control.Monad
+import Text.Printf
+import Data.Time.Clock
+import Control.DeepSeq
+
+import System.Posix.IO
+import System.Posix.Types
+import Control.Concurrent
+import Control.Exception
+
+passTheParcel :: Int -> IO (IO ())
+passTheParcel n = do
+  pipes@(p1 : rest) <- forM [0..n-1] $ \_ -> createPipe
+  rs@((_,tid1) : _) <- forM (pipes `zip` (rest ++ [p1])) $ \((readfd, _), (_, writefd)) -> do
+    let
+      read = fdRead readfd $ fromIntegral 1
+      write = fdWrite writefd
+    mv <- newEmptyMVar
+    tid <- forkIO $ let
+      loop = flip catch (\(x :: IOException) -> pure ()) $ forever $ do
+        threadWaitRead readfd
+        (s, _) <- read
+        threadWaitWrite writefd
+        write s
+      cleanup = do
+        closeFdWith closeFd readfd
+        closeFdWith closeFd writefd
+        putMVar mv ()
+      in loop `finally` cleanup
+    pure (mv, tid)
+
+  let
+    cleanup = do
+      killThread tid1
+      forM_ rs $ \(mv, _) -> takeMVar mv
+
+  fdWrite (snd p1) "a"
+  pure cleanup
+
+
+main = do
+  setLocaleEncoding latin1 -- fdRead and fdWrite depend on the current locale
+  [n,q,t,z] <- fmap (fmap read) getArgs
+  cleanup_ptp <- passTheParcel z
+  t <- forkIO $ do
+    forM_ (cycle ([n,n-1..1] ++ [2..n-1])) $ \m -> do
+      setNumCapabilities m
+      threadDelay t
+  printf "%d\n" (nqueens q)
+  cleanup_ptp
+  killThread t
+      -- If we don't kill the child thread, it might be about to
+      -- call setNumCapabilities() in C when the main thread exits,
+      -- and chaos can ensue.  See #12038
+
+nqueens :: Int -> Int
+nqueens nq = length (pargen 0 [])
+ where
+    safe :: Int -> Int -> [Int] -> Bool
+    safe x d []    = True
+    safe x d (q:l) = x /= q && x /= q+d && x /= q-d && safe x (d+1) l
+
+    gen :: [[Int]] -> [[Int]]
+    gen bs = [ (q:b) | b <- bs, q <- [1..nq], safe q 1 b ]
+
+    pargen :: Int -> [Int] -> [[Int]]
+    pargen n b
+       | n >= threshold = iterate gen [b] !! (nq - n)
+       | otherwise      = concat bs
+       where bs = map (pargen (n+1)) (gen [b]) `using` parList rdeepseq
+
+    threshold = 3
+
+using :: a -> Strategy a -> a
+x `using` strat = runEval (strat x)
+
+type Strategy a = a -> Eval a
+
+newtype Eval a = Eval (State# RealWorld -> (# State# RealWorld, a #))
+
+runEval :: Eval a -> a
+runEval (Eval x) = case x realWorld# of (# _, a #) -> a
+
+instance Functor Eval where
+  fmap = liftM
+
+instance Applicative Eval where
+  pure x = Eval $ \s -> (# s, x #)
+  (<*>)  = ap
+
+instance Monad Eval where
+  return = pure
+  Eval x >>= k = Eval $ \s -> case x s of
+                                (# s', a #) -> case k a of
+                                                      Eval f -> f s'
+
+parList :: Strategy a -> Strategy [a]
+parList strat = traverse (rparWith strat)
+
+rpar :: Strategy a
+rpar  x = Eval $ \s -> spark# x s
+
+rseq :: Strategy a
+rseq x = Eval $ \s -> seq# x s
+
+rparWith :: Strategy a -> Strategy a
+rparWith s a = do l <- rpar r; return (case l of Lift x -> x)
+  where r = case s a of
+              Eval f -> case f realWorld# of
+                          (# _, a' #) -> Lift a'
+
+data Lift a = Lift a
+
+rdeepseq :: NFData a => Strategy a
+rdeepseq x = do rseq (rnf x); return x
diff --git a/testsuite/tests/concurrent/should_run/T21651.stdout b/testsuite/tests/concurrent/should_run/T21651.stdout
new file mode 100644
index 0000000000..753d1bf068
--- /dev/null
+++ b/testsuite/tests/concurrent/should_run/T21651.stdout
@@ -0,0 +1 @@
+14200
diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T
index 6f015b1df3..11cecb3d14 100644
--- a/testsuite/tests/concurrent/should_run/all.T
+++ b/testsuite/tests/concurrent/should_run/all.T
@@ -218,12 +218,21 @@ test('conc067', ignore_stdout, compile_and_run, [''])
 test('conc068', [ omit_ways(concurrent_ways), exit_code(1) ], compile_and_run, [''])
 
 test('setnumcapabilities001',
-     [ only_ways(['threaded1','threaded2', 'nonmoving_thr']),
+     [ only_ways(['threaded1','threaded2', 'nonmoving_thr', 'profthreaded']),
        extra_run_opts('8 12 2000'),
        when(have_thread_sanitizer(), expect_broken(18808)),
        req_smp ],
      compile_and_run, [''])
 
+test('T21651',
+     [ only_ways(['threaded1','threaded2', 'nonmoving_thr', 'profthreaded']),
+       when(opsys('mingw32'),skip), # uses POSIX pipes
+       when(opsys('darwin'),extra_run_opts('8 12 2000 100')),
+       unless(opsys('darwin'),extra_run_opts('8 12 2000 200')), # darwin runners complain of too many open files
+       expect_broken('21651'),
+       req_smp ],
+     compile_and_run, [''])
+
 test('hs_try_putmvar001',
      [
      when(opsys('mingw32'),skip), # uses pthread APIs in the C code