[ ghc-Bugs-1190056 ] Infinite loops can hang Concurrent Haskell

Bugs item #1190056, was opened at 2005-04-26 07:35
Message generated for change (Tracker Item Submitted) made by Item Submitter
You can respond by visiting: 
https://sourceforge.net/tracker/?func=detail&atid=108032&aid=1190056&group_id=8032

Category: Compiler
Group: None
Status: Open
Resolution: None
Priority: 2
Submitted By: Simon Peyton Jones (simonpj)
Assigned to: Nobody/Anonymous (nobody)
Summary: Infinite loops can hang Concurrent Haskell

Initial Comment:
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.



----------------------------------------------------------------------

You can respond by visiting: 
https://sourceforge.net/tracker/?func=detail&atid=108032&aid=1190056&group_id=8032