[commit: ghc] ghc-8.0: Fix ASSERT failure and re-enable setnumcapabilities001 (2f31960)

[git at git.haskell.org]

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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/2f319609ef0ebffc46aad7f4ad14d5c26750e3ba/ghc

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

commit 2f319609ef0ebffc46aad7f4ad14d5c26750e3ba
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Wed May 11 15:38:25 2016 +0100

    Fix ASSERT failure and re-enable setnumcapabilities001
    
    The assertion failure was fairly benign, I think, but this fixes it.
    I've been running the test repeatedly for the last 30 mins and it hasn't
    triggered.
    
    There are other problems exposed by this test (see #12038), but I've
    worked around those in the test itself for now.
    
    I also copied the relevant bits of the parallel library here so that we
    don't need parallel for the test to run.
    
    (cherry picked from commit cfc5df43a7789832a2789e517d8270650cc31b7f)


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

2f319609ef0ebffc46aad7f4ad14d5c26750e3ba
 rts/Schedule.c                                     |  7 ++-
 testsuite/tests/concurrent/should_run/all.T        | 13 ++---
 .../concurrent/should_run/setnumcapabilities001.hs | 55 ++++++++++++++++++++--
 3 files changed, 62 insertions(+), 13 deletions(-)

diff --git a/rts/Schedule.c b/rts/Schedule.c
index 632b9d3..adb1aa1 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -1622,11 +1622,14 @@ scheduleDoGC (Capability **pcap, Task *task USED_IF_THREADS,
             if (was_syncing) {
                 stgFree(idle_cap);
             }
-            if (was_syncing && (prev_sync == SYNC_GC_SEQ ||
-                                prev_sync == SYNC_GC_PAR)) {
+            if (was_syncing &&
+                (prev_sync == SYNC_GC_SEQ || prev_sync == SYNC_GC_PAR) &&
+                !(sched_state == SCHED_INTERRUPTING && force_major)) {
                 // someone else had a pending sync request for a GC, so
                 // let's assume GC has been done and we don't need to GC
                 // again.
+                // Exception to this: if SCHED_INTERRUPTING, then we still
+                // need to do the final GC.
                 return;
             }
             if (sched_state == SCHED_SHUTTING_DOWN) {
diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T
index 1dd1e1a..3719101 100644
--- a/testsuite/tests/concurrent/should_run/all.T
+++ b/testsuite/tests/concurrent/should_run/all.T
@@ -244,14 +244,11 @@ test('conc067', ignore_output, compile_and_run, [''])
 # than one CPU.
 test('conc068', [ omit_ways('threaded2'), exit_code(1) ], compile_and_run, [''])
 
-# Commented out, instead of marked expect_broken, because it fails only
-# sometimes. See #10860.
-#test('setnumcapabilities001',
-#     [ only_ways(['threaded1','threaded2']),
-#       extra_run_opts('4 12 2000'),
-#       reqlib('parallel'),
-#       req_smp ],
-#     compile_and_run, [''])
+test('setnumcapabilities001',
+     [ only_ways(['threaded1','threaded2']),
+       extra_run_opts('4 12 2000'),
+       req_smp ],
+     compile_and_run, [''])
 
 # omit ghci, which can't handle unboxed tuples:
 test('compareAndSwap', [omit_ways(['ghci','hpc']), reqlib('primitive')], compile_and_run, [''])
diff --git a/testsuite/tests/concurrent/should_run/setnumcapabilities001.hs b/testsuite/tests/concurrent/should_run/setnumcapabilities001.hs
index 1927cd8..27685f0 100644
--- a/testsuite/tests/concurrent/should_run/setnumcapabilities001.hs
+++ b/testsuite/tests/concurrent/should_run/setnumcapabilities001.hs
@@ -1,19 +1,25 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
 import GHC.Conc
-import Control.Parallel
-import Control.Parallel.Strategies
+import GHC.Prim
 import System.Environment
 import System.IO
 import Control.Monad
 import Text.Printf
 import Data.Time.Clock
+import Control.DeepSeq
 
 main = do
   [n,q,t] <- fmap (fmap read) getArgs
-  forkIO $ do
+  t <- forkIO $ do
     forM_ (cycle ([n,n-1..1] ++ [2..n-1])) $ \m -> do
       setNumCapabilities m
       threadDelay t
   printf "%d" (nqueens q)
+  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 [])
@@ -32,3 +38,46 @@ nqueens nq = length (pargen 0 [])
        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