Cabal/src/Distribution/Compat/Async.hs

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