else do
ref <- newIORef undefined
let action_plus = Exception.try action >>= writeIORef ref
- resultOrException <-
- bracket (newStablePtr action_plus)
- freeStablePtr
- (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref)
- case resultOrException of
- Left exception -> Exception.throw (exception :: SomeException)
- Right result -> return result
+ bracket (newStablePtr action_plus)
+ freeStablePtr
+ (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref) >>=
+ unsafeResult
| otherwise = failNonThreaded
{- |
doesn't need it's main thread to be bound and makes /heavy/ use of concurrency
(e.g. a web server), might want to wrap it's @main@ action in
@runInUnboundThread@.
+
+Note that exceptions which are thrown to the current thread are thrown in turn
+to the thread that is executing the given computation. This ensures there's
+always a way of killing the forked thread.
-}
runInUnboundThread :: IO a -> IO a
runInUnboundThread action = do
- bound <- isCurrentThreadBound
- if bound
- then do
- mv <- newEmptyMVar
- b <- blocked
- _ <- mask $ \restore -> forkIO $
- Exception.try (if b then action else restore action) >>=
- putMVar mv
- takeMVar mv >>= \ei -> case ei of
- Left exception -> Exception.throw (exception :: SomeException)
- Right result -> return result
- else action
-
+ bound <- isCurrentThreadBound
+ if bound
+ then do
+ mv <- newEmptyMVar
+ mask $ \restore -> do
+ tid <- forkIO $ Exception.try (restore action) >>= putMVar mv
+ let wait = takeMVar mv `Exception.catch` \(e :: SomeException) ->
+ Exception.throwTo tid e >> wait
+ wait >>= unsafeResult
+ else action
+
+unsafeResult :: Either SomeException a -> IO a
+unsafeResult = either Exception.throwIO return
#endif /* __GLASGOW_HASKELL__ */
#ifdef __GLASGOW_HASKELL__
waitFd :: Fd -> CInt -> IO ()
waitFd fd write = do
throwErrnoIfMinus1_ "fdReady" $
- fdReady (fromIntegral fd) write (fromIntegral iNFINITE) 0
+ fdReady (fromIntegral fd) write iNFINITE 0
iNFINITE :: CInt
iNFINITE = 0xFFFFFFFF -- urgh