[Added Result. Removed memory leaks and race conditions.
nad**20041022145737] {
hunk ./ChasingBottoms/TimeOut.hs 21
-  ( timeOut
+  ( Result(..)
+  , timeOut
hunk ./ChasingBottoms/TimeOut.hs 29
-import Control.Exception
-import Data.Typeable
+import Data.Dynamic
+import qualified Control.Exception as E
hunk ./ChasingBottoms/TimeOut.hs 32
-data WakeUp = WakeUp deriving Typeable
+data Result a
+  = Value a
+  | NonTermination
+  | Exception E.Exception
+    deriving (Eq, Show, Typeable)
hunk ./ChasingBottoms/TimeOut.hs 39
--- scheduling issues). If the computation terminates before that, then
--- the resulting value is returned, and otherwise 'Nothing' is returned.
-timeOut :: Int -> IO a -> IO (Maybe a)
+--   scheduling issues).
+--   * If the computation terminates before that, then
+--     @'Value' v@ is returned, where @v@ is the resulting value. Note
+--     that this value may be equal to bottom, e.g. if @c = 'return'
+--     'bottom'@.
+--   * If the computation does not terminate, then 'NonTermination' is
+--     returned.
+--   * If the computation raises an exception, then @'Exception' e@ is
+--     returned, where @e@ is the exception.
+
+timeOut :: Int -> IO a -> IO (Result a)
hunk ./ChasingBottoms/TimeOut.hs 54
--- was 0.02 seconds).
-timeOutMicro :: Int -> IO a -> IO (Maybe a)
+-- was 0.02 seconds when using the standard runtime system settings
+-- for GHC).
+
+timeOutMicro :: Int -> IO a -> IO (Result a)
hunk ./ChasingBottoms/TimeOut.hs 59
-  id <- myThreadId
hunk ./ChasingBottoms/TimeOut.hs 60
-  ioThread <- forkIO $ do
-    a <- io
-    putMVar mv a
+  let putException = putMVar mv . Exception
+  ioThread <- forkIO $ (io >>= putMVar mv . Value)
+                      `E.catch` (\e -> case e of
+                        E.DynException d -> case fromDynamic d of
+                          Just Die -> return ()  -- Thread properly killed.
+                          Nothing -> putException e
+                        _ -> putException e)
hunk ./ChasingBottoms/TimeOut.hs 69
-    throwDynTo id WakeUp
-  (fmap Just (takeMVar mv) `catchDyn` \WakeUp -> do
-    killThread ioThread
-    return Nothing)
-    `finally` killThread reaper
+    putMVar mv NonTermination
+  result <- takeMVar mv
+  killThread' ioThread
+  killThread reaper
+  return result
+
+-- Since 'ioThread' above should return exceptions raised in the code
+-- we cannot kill the thread using killThread, which raises
+-- @'AsyncException' 'ThreadKilled'@. We use the locally defined type
+-- 'Die' together with a dynamic exception instead.
+
+data Die = Die deriving Typeable
+
+killThread' threadId = E.throwDynTo threadId Die
hunk ./ChasingBottoms/TimeOut.hs 91
--- ensures that @'timeOut'' 1 bottom@ usually returns 'Nothing'.
--- (@'timeOut' 1 (return bottom)@ usually returns @'Just' 'bottom'@.)
-timeOut' :: Int -> a -> IO (Maybe a)
-timeOut' n = timeOut n . evaluate
+-- ensures that @'timeOut'' 1 bottom@ usually returns @'Exception'
+-- <something>@.  (@'timeOut' 1 (return bottom)@ usually returns
+-- @'Value' 'bottom'@; in other words, the computation reaches whnf
+-- almost immediately, defeating the purpose of the time-out.)
+
+timeOut' :: Int -> a -> IO (Result a)
+timeOut' n = timeOut n . E.evaluate
hunk ./ChasingBottoms/TimeOut.hs 104
-timeOutMicro' :: Int -> a -> IO (Maybe a)
-timeOutMicro' n = timeOutMicro n . evaluate
+
+timeOutMicro' :: Int -> a -> IO (Result a)
+timeOutMicro' n = timeOutMicro n . E.evaluate
+
+------------------------------------------------------------------------
+
+-- There shouldn't be any memory leaks in the code above. Profiling
+-- the code below also seems to suggest that there aren't any
+-- problems. However, GHCi (with :set +r) eats up more and more memory
+-- if the computation below is rerun a couple of times. Hmm, that
+-- seems to be the case also when running simply (reverse [1..]). It
+-- probably means that GHCi never releases any memory.
+
+main = do
+  let n = 1; d = 000000
+  {-# SCC "a" #-} timeOut' n (reverse [1..]) >>= print
+  threadDelay d
+  {-# SCC "b" #-} timeOut' n (reverse [1..]) >>= print
+  threadDelay d
+  {-# SCC "c" #-} timeOut' n (reverse [1..]) >>= print
+  threadDelay d
+  {-# SCC "d" #-} timeOut' n (reverse [1..]) >>= print
}