[GHC] #10414: Buggy behavior with threaded runtime (-N1 working, -N2 getting into <<loop>>)

[GHC]

#10414: Buggy behavior with threaded runtime (-N1 working, -N2 getting into
<<loop>>)
-------------------------------------+-------------------------------------
              Reporter:  exio4       |             Owner:
                  Type:  bug         |            Status:  new
              Priority:  normal      |         Milestone:
             Component:  Compiler    |           Version:  7.10.1
              Keywords:              |  Operating System:  Unknown/Multiple
          Architecture:              |   Type of failure:  Incorrect result
  Unknown/Multiple                   |  at runtime
             Test Case:              |        Blocked By:
              Blocking:              |   Related Tickets:
Differential Revisions:              |
-------------------------------------+-------------------------------------
 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
 [http://lpaste.net/132564/ 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] (-fno-cse and -flate-dmd-anal didn't help with this)

 {{{#!hs
 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,[]))

 }}}

--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/10414>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler