diff --git a/rts/Schedule.c b/rts/Schedule.c index d077ce2d5a62015e7a68dcd0f32eeda2ce9c6e3e..0db9ff8e9b45cb138a111b8e36bb90988b70fb2c 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -1626,11 +1626,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 cc3440e25b5e754e3a631b8314a3cca3efc2d57a..3d5e08b59b9dfc7e5d6a4b5fc81f91e19338c4e8 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 1927cd8a62677cc1ce205746490498cf2ba21842..27685f08943d07882f6b37aeff2223348737c7e8 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