diff --git a/src/Quasar/Async/Fork.hs b/src/Quasar/Async/Fork.hs index aef8816207392b34c82c10c1021ee8c65d0cccab..787db634d98f57ab4ece8e9dd56c2754335dad31 100644 --- a/src/Quasar/Async/Fork.hs +++ b/src/Quasar/Async/Fork.hs @@ -1,16 +1,18 @@ module Quasar.Async.Fork ( -- * Forking with an asynchronous exception channel -- ** STM - fork, - fork_, - forkWithUnmask, - forkWithUnmask_, + forkSTM, + forkSTM_, + forkWithUnmaskSTM, + forkWithUnmaskSTM_, + forkAsyncSTM, + forkAsyncWithUnmaskSTM, -- ** ShortIO forkWithUnmaskShortIO, forkWithUnmaskShortIO_, - startIOThreadShortIO, - startIOThreadWithUnmaskShortIO, + forkAsyncShortIO, + forkAsyncWithUnmaskShortIO, ) where import Control.Concurrent (ThreadId) @@ -25,18 +27,25 @@ import Quasar.Utils.ShortIO -- * Fork in STM (with ExceptionChannel) -fork :: IO () -> TIOWorker -> ExceptionChannel -> STM (Awaitable ThreadId) -fork fn = forkWithUnmask (\unmask -> unmask fn) +forkSTM :: IO () -> TIOWorker -> ExceptionChannel -> STM (Awaitable ThreadId) +forkSTM fn = forkWithUnmaskSTM (\unmask -> unmask fn) -fork_ :: IO () -> TIOWorker -> ExceptionChannel -> STM () -fork_ fn worker exChan = void $ fork fn worker exChan +forkSTM_ :: IO () -> TIOWorker -> ExceptionChannel -> STM () +forkSTM_ fn worker exChan = void $ forkSTM fn worker exChan -forkWithUnmask :: ((forall a. IO a -> IO a) -> IO ()) -> TIOWorker -> ExceptionChannel -> STM (Awaitable ThreadId) -forkWithUnmask fn worker exChan = startShortIO (forkWithUnmaskShortIO fn exChan) worker exChan +forkWithUnmaskSTM :: ((forall a. IO a -> IO a) -> IO ()) -> TIOWorker -> ExceptionChannel -> STM (Awaitable ThreadId) +forkWithUnmaskSTM fn worker exChan = startShortIO (forkWithUnmaskShortIO fn exChan) worker exChan -forkWithUnmask_ :: ((forall a. IO a -> IO a) -> IO ()) -> TIOWorker -> ExceptionChannel -> STM () -forkWithUnmask_ fn worker exChan = void $ forkWithUnmask fn worker exChan +forkWithUnmaskSTM_ :: ((forall a. IO a -> IO a) -> IO ()) -> TIOWorker -> ExceptionChannel -> STM () +forkWithUnmaskSTM_ fn worker exChan = void $ forkWithUnmaskSTM fn worker exChan + + +forkAsyncSTM :: forall a. IO a -> TIOWorker -> ExceptionChannel -> STM (Awaitable a) +forkAsyncSTM fn worker exChan = join <$> startShortIO (forkAsyncShortIO fn exChan) worker exChan + +forkAsyncWithUnmaskSTM :: forall a. ((forall b. IO b -> IO b) -> IO a) -> TIOWorker -> ExceptionChannel -> STM (Awaitable a) +forkAsyncWithUnmaskSTM fn worker exChan = join <$> startShortIO (forkAsyncWithUnmaskShortIO fn exChan) worker exChan -- * Fork in ShortIO (with ExceptionChannel) @@ -55,8 +64,11 @@ forkWithUnmaskShortIO_ fn exChan = void $ forkWithUnmaskShortIO fn exChan -- * Fork in ShortIO while collecting the result (with ExceptionChannel) -startIOThreadWithUnmaskShortIO :: forall a. ((forall b. IO b -> IO b) -> IO a) -> ExceptionChannel -> ShortIO (Awaitable a) -startIOThreadWithUnmaskShortIO fn exChan = do +forkAsyncShortIO :: forall a. IO a -> ExceptionChannel -> ShortIO (Awaitable a) +forkAsyncShortIO fn = forkAsyncWithUnmaskShortIO ($ fn) + +forkAsyncWithUnmaskShortIO :: forall a. ((forall b. IO b -> IO b) -> IO a) -> ExceptionChannel -> ShortIO (Awaitable a) +forkAsyncWithUnmaskShortIO fn exChan = do resultVar <- newAsyncVarShortIO forkWithUnmaskShortIO_ (runAndPut resultVar) exChan pure $ toAwaitable resultVar @@ -72,7 +84,3 @@ startIOThreadWithUnmaskShortIO fn exChan = do failAsyncVar_ resultVar (AsyncException ex) Right retVal -> do putAsyncVar_ resultVar retVal - - -startIOThreadShortIO :: forall a. IO a -> ExceptionChannel -> ShortIO (Awaitable a) -startIOThreadShortIO fn = startIOThreadWithUnmaskShortIO ($ fn) diff --git a/src/Quasar/Async/V2.hs b/src/Quasar/Async/V2.hs index 8b66c934eb8722537f8e2890c26252357cc7e270..5b4adfc2e1cc266dd8a66e8be6ce28a434ec8bc0 100644 --- a/src/Quasar/Async/V2.hs +++ b/src/Quasar/Async/V2.hs @@ -1,7 +1,9 @@ module Quasar.Async.V2 ( Async, async, + async_, asyncWithUnmask, + asyncWithUnmask_, -- ** Async exceptions CancelAsync(..), @@ -11,8 +13,8 @@ module Quasar.Async.V2 ( isAsyncDisposed, -- ** Unmanaged variants - unmanagedAsync, - unmanagedAsyncWithUnmask, + unmanagedAsyncSTM, + unmanagedAsyncWithUnmaskSTM, ) where import Control.Concurrent (ThreadId) @@ -38,15 +40,15 @@ instance IsAwaitable a (Async a) where toAwaitable (Async awaitable _) = awaitable -unmanagedAsync :: IO a -> TIOWorker -> ExceptionChannel -> STM (Async a) -unmanagedAsync fn = unmanagedAsyncWithUnmask (\unmask -> unmask fn) +unmanagedAsyncSTM :: IO a -> TIOWorker -> ExceptionChannel -> STM (Async a) +unmanagedAsyncSTM fn = unmanagedAsyncWithUnmaskSTM (\unmask -> unmask fn) -unmanagedAsyncWithUnmask :: forall a. ((forall b. IO b -> IO b) -> IO a) -> TIOWorker -> ExceptionChannel -> STM (Async a) -unmanagedAsyncWithUnmask fn worker exChan = do +unmanagedAsyncWithUnmaskSTM :: forall a. ((forall b. IO b -> IO b) -> IO a) -> TIOWorker -> ExceptionChannel -> STM (Async a) +unmanagedAsyncWithUnmaskSTM fn worker exChan = do key <- newUniqueSTM resultVar <- newAsyncVarSTM disposer <- mfix \disposer -> do - tidAwaitable <- forkWithUnmask (runAndPut key resultVar disposer) worker exChan + tidAwaitable <- forkWithUnmaskSTM (runAndPut key resultVar disposer) worker exChan newPrimitiveDisposer (disposeFn key resultVar tidAwaitable) worker exChan pure $ Async (toAwaitable resultVar) disposer where @@ -78,6 +80,9 @@ unmanagedAsyncWithUnmask fn worker exChan = do async :: MonadQuasar m => QuasarIO a -> m (Async a) async fn = asyncWithUnmask ($ fn) +async_ :: MonadQuasar m => QuasarIO () -> m () +async_ fn = void $ asyncWithUnmask ($ fn) + asyncWithUnmask :: MonadQuasar m => ((forall b. QuasarIO b -> QuasarIO b) -> QuasarIO a) -> m (Async a) asyncWithUnmask fn = do quasar <- askQuasar @@ -85,7 +90,7 @@ asyncWithUnmask fn = do exChan <- askExceptionChannel rm <- askResourceManager runSTM do - as <- unmanagedAsyncWithUnmask (\unmask -> runReaderT (fn (liftUnmask unmask)) quasar) worker exChan + as <- unmanagedAsyncWithUnmaskSTM (\unmask -> runReaderT (fn (liftUnmask unmask)) quasar) worker exChan attachResource rm as pure as where @@ -93,3 +98,6 @@ asyncWithUnmask fn = do liftUnmask unmask innerAction = do quasar <- askQuasar liftIO $ unmask $ runReaderT innerAction quasar + +asyncWithUnmask_ :: MonadQuasar m => ((forall b. QuasarIO b -> QuasarIO b) -> QuasarIO ()) -> m () +asyncWithUnmask_ fn = void $ asyncWithUnmask fn diff --git a/src/Quasar/Resources.hs b/src/Quasar/Resources.hs index 80d39ffa20cea92d9eeb74aa441c32b1a90852e1..1d82df4bcbce507b3b1eebbe482106d207dcca96 100644 --- a/src/Quasar/Resources.hs +++ b/src/Quasar/Resources.hs @@ -42,7 +42,7 @@ import Quasar.Resources.Disposer newIODisposer :: IO () -> TIOWorker -> ExceptionChannel -> STM Disposer -newIODisposer fn worker exChan = newPrimitiveDisposer (startIOThreadShortIO fn exChan) worker exChan +newIODisposer fn worker exChan = newPrimitiveDisposer (forkAsyncShortIO fn exChan) worker exChan newSTMDisposer :: STM () -> TIOWorker -> ExceptionChannel -> STM Disposer newSTMDisposer fn = newIODisposer (atomically fn)