amb :: a -> a -> IO a
amb = race `on` evaluate

by

amb :: a -> a -> IO a
amb = race `on` return

I get back 1.

But of course that might not be what you want, since the semantics of evaluate are different (I don’t fully understand from the GHC documentation what evaluate really does…)

If I replace amb by “race on (($!) return)” I get the exception again

I also made a version that hangs under GHCi instead of throwing the exception:

race :: IO a -> IO a -> IO a
race a b = bracket entry exit (takeMVar . fst)
    where
      entry = block $ do
                v <- newEmptyMVar
                ta <- forkIO (a >>= putMVar v)
                tb <- forkIO (b >>= putMVar v)
                putStrLn ("Waiting for either "++show ta++" or "++show tb ++"n")
                return (v,((ta,tb)))
      exit (v,((ta,tb))) = do
        putStrLn ("Killing "++show ta++"n")
        killThread ta
        putStrLn ("Killing "++show tb++"n")
        killThread tb
        putStrLn ("Killed request send to "++show ta++" and "++show tb++"n")

The version above – when run via GHCi – blocks. If I press CTRL-C it interrupts. When running again in the same session, I get 1. When running a compiled version without optimization, I get the exception. When running a compile version with optimization, I get 1.

Weird behavior…

race :: IO a -> IO a -> IO a
race a b = bracket entry exit (return . fst)
    where
      entry = block $ do
                v <- newEmptyMVar
                ta <- forkIO (a >>= putMVar v)
                tb <- forkIO (b >>= putMVar v)
                x <- takeMVar v
                return (x,((ta,tb)))
      exit (_,((ta,tb))) = do
        killThread ta
        killThread tb

Using GHCi or GHC –make, I get the thread killed exception…

When using GHC –make -O, I don’t get the thread killed exception, just get the correct answer 1

Sometimes, using GHCi, it just blocks.

I get the same with Spencer’s version… Haven’t tried the other versions, but I expect they will also behave correctly with GHC -O…

test :: Int
test = f (f 1) where f v = (v `unamb` 1) `seq` v

The error message (in ghci) is “*** Exception: thread killed”.

Definitions that give this error include my three

a `race` b = do v  <- newEmptyMVar
                ta <- forkPut a v
                tb <- forkPut b v
                takeMVar v `finally` (killThread ta >> killThread tb)
 
a `race` b = do v <- newEmptyMVar
                ta <- forkPut a v
                (do tb <- forkPut b v
                    takeMVar v `finally` killThread tb)
                 `finally` killThread ta
 
a `race` b = do v <- newEmptyMVar
                forking (putCatch a v) $
                  forking (putCatch b v) $
                    takeMVar v

and Luke’s:

race a b = do
    v <- newEmptyMVar
    block $ do
        ta <- forkPut a v
        tb <- forkPut b v
        unblock (takeMVar v) `finally` (killThread ta >> killThread tb)

and Spencer’s:

race a b = do
    v <- newEmptyMVar
    let t x = x >>= putMVar v
    withThread (t a) $ withThread (t b) $ takeMVar v
 where
   withThread u v = bracket (forkIO u) killThread (const v)

My original version gives the answer I want, namely 1:

a `race` b = do v  <- newEmptyMVar
                ta <- forkPut a v
                tb <- forkPut b v
                x  <- takeMVar  v
                killThread ta
                killThread tb
                return x

Here’s a definition that comes from inlining finally in the first smart version above:

a `race` b = do v  <- newEmptyMVar
                ta <- forkPut a v
                tb <- forkPut b v
                block (do
                  x <- unblock (takeMVar v) `onException` (killThread ta >> killThread tb)
                  killThread ta >> killThread tb
                  return x)

It also fails. However, if I remove the inner unblock, I get 1, as desired:

a `race` b = do v  <- newEmptyMVar
                ta <- forkPut a v
                tb <- forkPut b v
                block (do
                  x <- (takeMVar v) `onException` (killThread ta >> killThread tb)
                  killThread ta >> killThread tb
                  return x)

What is going on here? What is causing “*** Exception: thread killed”?

Here is a possibly-relevant excerpt from the documentation:

Some operations are interruptible, which means that they can receive asynchronous exceptions even in the scope of a block. Any function which may itself block is defined as interruptible; this includes Control.Concurrent.MVar.takeMVar (but not Control.Concurrent.MVar.tryTakeMVar), and most operations which perform some I/O with the outside world.

I think the problem here is simply that the process exits before the threads all get a chance to terminate. In my experiments, adding even a yield to the end of main seems to ensure that all threads get killed.

Ugly code follows:

import Prelude hiding (catch)

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception
import System.IO
import Data.Char

withThread a b = bracket (forkIO a) kill (const b)
    where
      kill id = do
        putStrLn ("Killing "++show id++"n")
        killThread id
        putStrLn ("Killed "++show id++"n")

race a b = do
    v <- newEmptyMVar
    let t x = x >>= putMVar v
    withThread (t a) $ withThread (t b) $ takeMVar v

forkPut :: IO a -> MVar a -> IO ThreadId
forkPut act v = forkIO ((act >>= putMVar v) `catch` uhandler `catch` bhandler)
 where
   uhandler (ErrorCall "Prelude.undefined") = return ()
   uhandler err                             = throw err
   bhandler BlockedOnDeadMVar               = return ()

sleep n = do
  tid <- myThreadId
  putStrLn ("Sleeping "++show n++" sec on "++show tid++"n")
  threadDelay (n*1000000)
  putStrLn ("Slept "++show n++" sec on "++show tid++"n")

f = sleep 2 `race` sleep 3

g = f `race` sleep 1

main = do
  hSetBuffering stdout LineBuffering
  g

Output with GHCI:

C:temp>runghc racetest
Sleeping 1 sec on ThreadId 26
Sleeping 2 sec on ThreadId 27
Sleeping 3 sec on ThreadId 28
Slept 1 sec on ThreadId 26
Killing ThreadId 26
Killed ThreadId 26
Killing ThreadId 25
Killed ThreadId 25
Killing ThreadId 28
Killed ThreadId 28

Output from compiled EXE:

C:temp> racetest
Sleeping 1 sec on ThreadId 5
Sleeping 3 sec on ThreadId 7
Sleeping 2 sec on ThreadId 6
Slept 1 sec on ThreadId 5
Killing ThreadId 5
Killed ThreadId 5
Killing ThreadId 4
Killed ThreadId 4
Killing ThreadId 7

So “Killed ThreadId 7″ is not printed

Output with +RTS -N2:

C:temp> racetest +RTS -N2
Sleeping 1 sec on ThreadId 5
Sleeping 3 sec on ThreadId 7
Sleeping 2 sec on ThreadId 6
Slept 1 sec on ThreadId 5

Killing ThreadId 5
Killed ThreadId 5
Killing ThreadId 4
Killed ThreadId 4
Killing ThreadId 7
Killed ThreadId 7

Nice to see it works. Simon Marlow also replied on your question. He posted code for the timeout function, which does something similar. See http://darcs.haskell.org/packages/base/System/Timeout.hs

At home I played a bit with the bracket function and tested the following code:

import Prelude hiding (catch)

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception
import System.IO
import Data.Char

a `race` b = do bracket entry exit (takeMVar.fst) 
    where
      entry = do
               v  <- newEmptyMVar
               ta <- forkPut a v
               tb <- forkPut b v
               return (v,(ta,tb))

      exit (_,(ta,tb)) = do
        putChar 'a'
        killThread ta
        putChar 'b'
        killThread tb
        putChar 'c'

forkPut :: IO a -> MVar a -> IO ThreadId
forkPut act v = forkIO ((act >>= putMVar v) `catch` uhandler `catch` bhandler)
 where
   uhandler (ErrorCall "Prelude.undefined") = return ()
   uhandler err                             = throw err
   bhandler BlockedOnDeadMVar               = return ()

sleep n = putChar (intToDigit n) >> threadDelay (n*1000000) >> putChar (intToDigit n)

f = sleep 2 `race` sleep 3

g = f `race` sleep 1

main = do
  hSetBuffering stdout NoBuffering
  g

Now, under Windows, when I run this with GHCI, I get 1231abcabc, as expected.

But when compiling with ghc, and running the EXE, I get 1231abacb.

I’m missing a ‘c’, which might mean some tb thread is not killed…

When compiling with GHC -threaded and running the EXE (with or without +RTS -N2), I get 1231abacbc, so correct again.

Bob has similar problems under OSX, he just got abc…

What did I do wrong? Might this indicate a bug in GHC’s runtime?