Buggy behavior with threaded runtime (-N1 working, -N2 getting into <<loop>>)

Compiling the test case with:

ghc -O2 -threaded -eventlog -rtsopts ghc-bug.hs

Now, trying with some inputs and -N2

$ ./ghc-bug 7 +RTS -N2 => ghc-bug: <<loop>> $ ./ghc-bug 6 +RTS -N2 => ghc-bug: <<loop>> $ ./ghc-bug 5 +RTS -N2 => 3125 $ ./ghc-bug 5 +RTS -N2 ghc-bug: <<loop>>

Reducing the number of capabilities to 1, it works for those inputs

$ ./ghc-bug 7 +RTS -N1

As a side-note, the problem only happens randomly with small inputs (on my hardware), and it seems to go away with bigger inputs (the original testcase felt a bit more deterministic, but I think the testcase in the ticket is good enough)

I only tested this with GHC 7.8.4 (on Debian), but people on IRC reported the same behavior with GHC 7.10.1 on OS X and Debian

Similar bug: #10218 (closed) (-fno-cse and -flate-dmd-anal didn't help with this)

import           Control.Applicative
import           Control.Monad

import           Control.Parallel.Strategies

import           System.Environment
    
newtype ParList a = ParList { unParList :: [a] }

nil :: ParList a
nil = ParList []
cons :: a -> ParList a -> ParList a
cons x (ParList xs) = ParList (x:xs)

instance Functor ParList where
    fmap = liftM

instance Applicative ParList where
    pure = return
    (<*>) = ap

instance Monad ParList where
    return = ParList . return
    {- v code that doesn't work -}
    (ParList xs) >>= f = ParList (withStrategy (parListChunk 8 rseq) (xs >>= unParList . f))
    --(ParList xs) >>= f = ParList (concat (parMap rseq (unParList . f) xs))
    {- ^ code that works -}
    
type Pair = (Int, [Int])

loop' :: Pair -> ParList Pair 
loop' (size,qns) = go 1
    where go n | n > size  = nil
               | otherwise = cons (size, n:qns) (go (n+1))
          
worker :: Int -> Pair -> [Pair]
worker n = unParList . go n
    where go 1 = loop'
          go n = loop' >=> go (n-1)
          
main :: IO ()
main = do
    [n] <- (read <$>) <$> getArgs
    print $ length (worker n (n,[]))