[GHC] #367: Infinite loops can hang Concurrent Haskell

[GHC]

#367: Infinite loops can hang Concurrent Haskell
-----------------------+----------------------------------------------------
  Reporter:  simonpj   |          Owner:  nobody  
      Type:  bug       |         Status:  assigned
  Priority:  lowest    |      Milestone:          
 Component:  Compiler  |        Version:  6.4.1   
  Severity:  normal    |     Resolution:  None    
  Keywords:            |             Os:  Unknown 
Difficulty:  Unknown   |   Architecture:  Unknown 
-----------------------+----------------------------------------------------
Changes (by simonmar):

  * architecture:  => Unknown
  * difficulty:  => Unknown
  * version:  None => 6.4.1
  * os:  => Unknown

Old description:

> {{{
> An infinite loop that does not allocate can hang
> Concurrent Haskell, becuase no thread switching
> occurs.  Demo code below (from Koen Claessen).
>
> Bites occasionally, but not often.
>
> Simon
>

>
> module Main where
>
> import Control.Concurrent
>   ( forkIO
>   , threadDelay
>   , killThread
>   , newEmptyMVar
>   , takeMVar
>   , putMVar
>   )
>
> import Data.IORef
>
> import IO( hFlush, stdout )
>
> timeout :: Int -> a -> IO (Maybe a)
> timeout n x =
>   do put "Race starts ..."
>      resV <- newEmptyMVar
>      pidV <- newEmptyMVar
>
>      let waitAndFail =
>            do put "Waiting ..."
>               threadDelay n
>               put "Done waiting!"
>               putMVar resV Nothing
>
>          eval =
>            do put "Evaluating ..."
>               x `seq` put "Done!"
>               putMVar resV (Just x)
>
>      -- used "mfix" here before but got non-termination
> problems
>      -- (not sure they had anything to do with mfix)
>      pid1  <- forkIO $ do pid2 <- takeMVar pidV
>                           eval
>                           killThread pid2
>      pid2  <- forkIO $ do waitAndFail
>                           killThread pid1
>      putMVar pidV pid2
>
>      put "Blocking ..."
>      takeMVar resV
>
> put s =
>   do putStrLn s
>      hFlush stdout
>
> main =
>   do timeout 1 (sum (repeat 1))
> <<<
>
> The above program produces the following (expected
> result):
>
> >>>
> Race starts ...
> Blocking ...
> Evaluating ...
> Waiting ...
> Done waiting!
> <<<
>
> If you replace 'sum (repeat 1)' by 'last (repeat 1)' the
> program hangs.
>

> }}}

New description:

 {{{
 An infinite loop that does not allocate can hang
 Concurrent Haskell, becuase no thread switching
 occurs.  Demo code below (from Koen Claessen).

 Bites occasionally, but not often.

 Simon



 module Main where

 import Control.Concurrent
   ( forkIO
   , threadDelay
   , killThread
   , newEmptyMVar
   , takeMVar
   , putMVar
   )

 import Data.IORef

 import IO( hFlush, stdout )

 timeout :: Int -> a -> IO (Maybe a)
 timeout n x =
   do put "Race starts ..."
      resV <- newEmptyMVar
      pidV <- newEmptyMVar

      let waitAndFail =
            do put "Waiting ..."
               threadDelay n
               put "Done waiting!"
               putMVar resV Nothing

          eval =
            do put "Evaluating ..."
               x `seq` put "Done!"
               putMVar resV (Just x)

      -- used "mfix" here before but got non-termination
 problems
      -- (not sure they had anything to do with mfix)
      pid1  <- forkIO $ do pid2 <- takeMVar pidV
                           eval
                           killThread pid2
      pid2  <- forkIO $ do waitAndFail
                           killThread pid1
      putMVar pidV pid2

      put "Blocking ..."
      takeMVar resV

 put s =
   do putStrLn s
      hFlush stdout

 main =
   do timeout 1 (sum (repeat 1))
 <<<

 The above program produces the following (expected
 result):

 >>>
 Race starts ...
 Blocking ...
 Evaluating ...
 Waiting ...
 Done waiting!
 <<<

 If you replace 'sum (repeat 1)' by 'last (repeat 1)' the
 program hangs.


 }}}

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