[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
      Resolution:                    |                Keywords:
Operating System:  Unknown/Multiple  |            Architecture:
 Type of failure:  Incorrect result  |  Unknown/Multiple
  at runtime                         |               Test Case:
      Blocked By:                    |                Blocking:
 Related Tickets:                    |  Differential Revisions:
-------------------------------------+-------------------------------------
Description changed by rwbarton:

Old description:

> 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,[]))
>
> }}}

New description:

 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#comment:1>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler