how to implement timeouts for IO operations?

[Simon Marlow]

The correct way to implement timeout in GHC 5.00 is below.  This should
really be in a library somewhere.

This implementation works for GHC's current "blocking" semantics for
throwTo, but if we change the semantics of throwTo to match the
asynchronous exceptions paper
(http://www.haskell.org/~simonmar/papers/async.ps.gz) then a different
implementation of timeout will be needed.

Cheers,
	Simon

------------------------------------------------------------------------
-----
import Dynamic
import Unique
import Exception
import Concurrent

data TimeOut =3D TimeOut Unique

timeOutTc =3D mkTyCon "TimeOut";
instance Typeable TimeOut where { typeOf _ =3D mkAppTy timeOutTc [] }

timeout secs on_timeout action
  =3D do {
       parent  <- myThreadId;
       i       <- newUnique;
       block (do
          timeout <- forkIO (timeout_thread secs parent i);
          Exception.catchDyn
            ( unblock (
                do {
                   result <- action;
                   killThread timeout;
                   return result;
                   }
              )
            )
            ( \exception ->=20
                case exception of
                    TimeOut u | u =3D=3D i -> unblock on_timeout
                    other -> do {=20
                                killThread timeout;
                                throwDyn exception=20
                                }
            )
         )
       }

timeout_thread secs parent i
  =3D do {=20
       threadDelay (secs * 1000000);
       throwTo parent (DynException (toDyn (TimeOut i)))
       }