Infinite loops can hang Concurrent Haskell

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.