1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3-- | 'Async', yet using 'MVar's. 4-- 5-- Adopted from @async@ library 6-- Copyright (c) 2012, Simon Marlow 7-- Licensed under BSD-3-Clause 8-- 9-- @since 3.2.0.0 10-- 11module Distribution.Compat.Async ( 12 AsyncM, 13 withAsync, waitCatch, 14 wait, asyncThreadId, 15 cancel, uninterruptibleCancel, AsyncCancelled (..), 16 -- * Cabal extras 17 withAsyncNF, 18 ) where 19 20import Control.Concurrent (ThreadId, forkIO) 21import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) 22import Control.DeepSeq (NFData, force) 23import Control.Exception 24 (BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_) 25import Control.Monad (void) 26import Data.Typeable (Typeable) 27import GHC.Exts (inline) 28 29#if MIN_VERSION_base(4,7,0) 30import Control.Exception (asyncExceptionFromException, asyncExceptionToException) 31#endif 32 33-- | Async, but based on 'MVar', as we don't depend on @stm@. 34data AsyncM a = Async 35 { asyncThreadId :: {-# UNPACK #-} !ThreadId 36 -- ^ Returns the 'ThreadId' of the thread running 37 -- the given 'Async'. 38 , _asyncMVar :: MVar (Either SomeException a) 39 } 40 41-- | Spawn an asynchronous action in a separate thread, and pass its 42-- @Async@ handle to the supplied function. When the function returns 43-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@. 44-- 45-- > withAsync action inner = mask $ \restore -> do 46-- > a <- async (restore action) 47-- > restore (inner a) `finally` uninterruptibleCancel a 48-- 49-- This is a useful variant of 'async' that ensures an @Async@ is 50-- never left running unintentionally. 51-- 52-- Note: a reference to the child thread is kept alive until the call 53-- to `withAsync` returns, so nesting many `withAsync` calls requires 54-- linear memory. 55-- 56withAsync :: IO a -> (AsyncM a -> IO b) -> IO b 57withAsync = inline withAsyncUsing forkIO 58 59withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b 60withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) where 61 evaluateNF = evaluate . force 62 63withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b 64-- The bracket version works, but is slow. We can do better by 65-- hand-coding it: 66withAsyncUsing doFork = \action inner -> do 67 var <- newEmptyMVar 68 mask $ \restore -> do 69 t <- doFork $ try (restore action) >>= putMVar var 70 let a = Async t var 71 r <- restore (inner a) `catchAll` \e -> do 72 uninterruptibleCancel a 73 throwIO e 74 uninterruptibleCancel a 75 return r 76 77-- | Wait for an asynchronous action to complete, and return its 78-- value. If the asynchronous action threw an exception, then the 79-- exception is re-thrown by 'wait'. 80-- 81-- > wait = atomically . waitSTM 82-- 83{-# INLINE wait #-} 84wait :: AsyncM a -> IO a 85wait a = do 86 res <- waitCatch a 87 case res of 88 Left (SomeException e) -> throwIO e 89 Right x -> return x 90 91-- | Wait for an asynchronous action to complete, and return either 92-- @Left e@ if the action raised an exception @e@, or @Right a@ if it 93-- returned a value @a@. 94-- 95-- > waitCatch = atomically . waitCatchSTM 96-- 97{-# INLINE waitCatch #-} 98waitCatch :: AsyncM a -> IO (Either SomeException a) 99waitCatch (Async _ var) = tryAgain (readMVar var) 100 where 101 -- See: https://github.com/simonmar/async/issues/14 102 tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f 103 104catchAll :: IO a -> (SomeException -> IO a) -> IO a 105catchAll = catch 106 107-- | Cancel an asynchronous action by throwing the @AsyncCancelled@ 108-- exception to it, and waiting for the `Async` thread to quit. 109-- Has no effect if the 'Async' has already completed. 110-- 111-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a 112-- 113-- Note that 'cancel' will not terminate until the thread the 'Async' 114-- refers to has terminated. This means that 'cancel' will block for 115-- as long said thread blocks when receiving an asynchronous exception. 116-- 117-- For example, it could block if: 118-- 119-- * It's executing a foreign call, and thus cannot receive the asynchronous 120-- exception; 121-- * It's executing some cleanup handler after having received the exception, 122-- and the handler is blocking. 123{-# INLINE cancel #-} 124cancel :: AsyncM a -> IO () 125cancel a@(Async t _) = do 126 throwTo t AsyncCancelled 127 void (waitCatch a) 128 129-- | The exception thrown by `cancel` to terminate a thread. 130data AsyncCancelled = AsyncCancelled 131 deriving (Show, Eq 132 , Typeable 133 ) 134 135instance Exception AsyncCancelled where 136#if MIN_VERSION_base(4,7,0) 137 -- wraps in SomeAsyncException 138 -- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09 139 fromException = asyncExceptionFromException 140 toException = asyncExceptionToException 141#endif 142 143-- | Cancel an asynchronous action 144-- 145-- This is a variant of `cancel`, but it is not interruptible. 146{-# INLINE uninterruptibleCancel #-} 147uninterruptibleCancel :: AsyncM a -> IO () 148uninterruptibleCancel = uninterruptibleMask_ . cancel 149