From 1fcb071d1c2ce1bfaa849f45758eb423b4330fe5 Mon Sep 17 00:00:00 2001 From: Andrzej Rybczak Date: Thu, 5 Sep 2024 19:08:23 +0200 Subject: [PATCH] Use strict-mutable-base (#235) --- .github/workflows/haskell-ci.yml | 10 +- effectful-core/CHANGELOG.md | 2 + effectful-core/effectful-core.cabal | 1 + effectful-core/src/Effectful/Internal/Env.hs | 1 + .../src/Effectful/Internal/Unlift.hs | 3 +- .../src/Effectful/Internal/Utils.hs | 59 ----- .../src/Effectful/State/Static/Shared.hs | 31 ++- .../src/Effectful/Writer/Static/Shared.hs | 6 +- effectful/CHANGELOG.md | 9 +- effectful/effectful.cabal | 6 +- .../src/Effectful/Concurrent/Chan/Strict.hs | 50 ++++ effectful/src/Effectful/Concurrent/MVar.hs | 3 + .../src/Effectful/Concurrent/MVar/Strict.hs | 217 +++++++++--------- .../Concurrent/MVar/Strict/Compat.hs | 134 +++++++++++ effectful/src/Effectful/Concurrent/STM.hs | 6 + effectful/src/Effectful/Prim/IORef.hs | 3 + effectful/src/Effectful/Prim/IORef/Strict.hs | 62 +++++ effectful/tests/StateTests.hs | 2 +- 18 files changed, 405 insertions(+), 200 deletions(-) create mode 100644 effectful/src/Effectful/Concurrent/Chan/Strict.hs create mode 100644 effectful/src/Effectful/Concurrent/MVar/Strict/Compat.hs create mode 100644 effectful/src/Effectful/Prim/IORef/Strict.hs diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 6eecdc0..a97c801 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.19.20240514 +# version: 0.19.20240708 # -# REGENDATA ("0.19.20240514",["github","--config=cabal.haskell-ci","cabal.project"]) +# REGENDATA ("0.19.20240708",["github","--config=cabal.haskell-ci","cabal.project"]) # name: Haskell-CI on: @@ -74,10 +74,10 @@ jobs: apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -95,7 +95,7 @@ jobs: echo "HC=$HC" >> "$GITHUB_ENV" echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" diff --git a/effectful-core/CHANGELOG.md b/effectful-core/CHANGELOG.md index 1689061..9aa1807 100644 --- a/effectful-core/CHANGELOG.md +++ b/effectful-core/CHANGELOG.md @@ -21,6 +21,8 @@ replaced with `ThrowErrorWith`. - `stateEnv` and `modifyEnv` now take pure modification functions. If you rely on their old forms, switch to a combination of `getEnv` and `putEnv`. + - `runStateMVar`, `evalStateMVar` and `execStateMVar` now take a strict + `MVar'` from the `strict-mutable-base` package. # effectful-core-2.3.1.0 (2024-06-07) * Drop support for GHC 8.8. diff --git a/effectful-core/effectful-core.cabal b/effectful-core/effectful-core.cabal index cff9aee..7ee9641 100644 --- a/effectful-core/effectful-core.cabal +++ b/effectful-core/effectful-core.cabal @@ -67,6 +67,7 @@ library , exceptions >= 0.10.4 , monad-control >= 1.0.3 , primitive >= 0.7.3.0 + , strict-mutable-base >= 1.1.0.0 , transformers-base >= 0.4.6 , unliftio-core >= 0.2.0.1 diff --git a/effectful-core/src/Effectful/Internal/Env.hs b/effectful-core/src/Effectful/Internal/Env.hs index 6f0b876..631b4fe 100644 --- a/effectful-core/src/Effectful/Internal/Env.hs +++ b/effectful-core/src/Effectful/Internal/Env.hs @@ -40,6 +40,7 @@ module Effectful.Internal.Env import Control.Monad import Control.Monad.Primitive +import Data.IORef.Strict import Data.Primitive.PrimArray import Data.Primitive.SmallArray import GHC.Stack (HasCallStack) diff --git a/effectful-core/src/Effectful/Internal/Unlift.hs b/effectful-core/src/Effectful/Internal/Unlift.hs index 91212a3..63b6095 100644 --- a/effectful-core/src/Effectful/Internal/Unlift.hs +++ b/effectful-core/src/Effectful/Internal/Unlift.hs @@ -17,6 +17,7 @@ module Effectful.Internal.Unlift ) where import Control.Concurrent +import Control.Concurrent.MVar.Strict import Control.Monad import Data.IntMap.Strict qualified as IM import GHC.Conc.Sync (ThreadId(..)) @@ -295,7 +296,7 @@ consThreadData w (ThreadEntry i td) = ---------------------------------------- deleteThreadData :: Int -> EntryId -> MVar' (ThreadEntries es) -> IO () -deleteThreadData wkTid i v = modifyMVar_' v $ \te -> do +deleteThreadData wkTid i v = modifyMVar'_ v $ \te -> do pure ThreadEntries { teCapacity = case teCapacity te of -- If the template copy of the environment hasn't been consumed diff --git a/effectful-core/src/Effectful/Internal/Utils.hs b/effectful-core/src/Effectful/Internal/Utils.hs index e78b734..8f53aa4 100644 --- a/effectful-core/src/Effectful/Internal/Utils.hs +++ b/effectful-core/src/Effectful/Internal/Utils.hs @@ -14,20 +14,6 @@ module Effectful.Internal.Utils , toAny , fromAny - -- * Strict 'IORef' - , IORef' - , newIORef' - , readIORef' - , writeIORef' - - -- * Strict 'MVar' - , MVar' - , toMVar' - , newMVar' - , readMVar' - , modifyMVar' - , modifyMVar_' - -- * Unique , Unique , newUnique @@ -36,9 +22,7 @@ module Effectful.Internal.Utils , thawCallStack ) where -import Control.Concurrent.MVar import Control.Exception -import Data.IORef import Data.Primitive.ByteArray import GHC.Conc.Sync (ThreadId(..)) import GHC.Exts (Any, RealWorld) @@ -128,49 +112,6 @@ fromAny = unsafeCoerce ---------------------------------------- --- | A strict variant of 'IORef'. -newtype IORef' a = IORef' (IORef a) - deriving Eq - -newIORef' :: a -> IO (IORef' a) -newIORef' a = a `seq` (IORef' <$> newIORef a) - -readIORef' :: IORef' a -> IO a -readIORef' (IORef' var) = readIORef var - -writeIORef' :: IORef' a -> a -> IO () -writeIORef' (IORef' var) a = a `seq` writeIORef var a - ----------------------------------------- - --- | A strict variant of 'MVar'. -newtype MVar' a = MVar' (MVar a) - deriving Eq - -toMVar' :: MVar a -> IO (MVar' a) -toMVar' var = do - let var' = MVar' var - modifyMVar_' var' pure - pure var' - -newMVar' :: a -> IO (MVar' a) -newMVar' a = a `seq` (MVar' <$> newMVar a) - -readMVar' :: MVar' a -> IO a -readMVar' (MVar' var) = readMVar var - -modifyMVar' :: MVar' a -> (a -> IO (a, r)) -> IO r -modifyMVar' (MVar' var) action = modifyMVar var $ \a0 -> do - (a, r) <- action a0 - a `seq` pure (a, r) - -modifyMVar_' :: MVar' a -> (a -> IO a) -> IO () -modifyMVar_' (MVar' var) action = modifyMVar_ var $ \a0 -> do - a <- action a0 - a `seq` pure a - ----------------------------------------- - -- | A unique with no possibility for CAS contention. -- -- Credits for this go to Edward Kmett. diff --git a/effectful-core/src/Effectful/State/Static/Shared.hs b/effectful-core/src/Effectful/State/Static/Shared.hs index 900c43e..ffc80ba 100644 --- a/effectful-core/src/Effectful/State/Static/Shared.hs +++ b/effectful-core/src/Effectful/State/Static/Shared.hs @@ -45,13 +45,12 @@ module Effectful.State.Static.Shared , modifyM ) where -import Control.Concurrent.MVar +import Control.Concurrent.MVar.Strict import Data.Kind import Effectful import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive -import Effectful.Internal.Utils -- | Provide access to a strict (WHNF), shared, mutable value of type @s@. data State (s :: Type) :: Effect @@ -82,28 +81,24 @@ execState s m = do _ <- evalStaticRep (State v) m unsafeEff_ $ readMVar' v --- | Run the 'State' effect with the given initial state 'MVar' and return the +-- | Run the 'State' effect with the given initial state 'MVar'' and return the -- final value along with the final state. -runStateMVar :: MVar s -> Eff (State s : es) a -> Eff es (a, s) +runStateMVar :: MVar' s -> Eff (State s : es) a -> Eff es (a, s) runStateMVar v m = do - v' <- unsafeEff_ $ toMVar' v - a <- evalStaticRep (State v') m - (a, ) <$> unsafeEff_ (readMVar v) + a <- evalStaticRep (State v) m + (a, ) <$> unsafeEff_ (readMVar' v) --- | Run the 'State' effect with the given initial state 'MVar' and return the +-- | Run the 'State' effect with the given initial state 'MVar'' and return the -- final value, discarding the final state. -evalStateMVar :: MVar s -> Eff (State s : es) a -> Eff es a -evalStateMVar v m = do - v' <- unsafeEff_ $ toMVar' v - evalStaticRep (State v') m +evalStateMVar :: MVar' s -> Eff (State s : es) a -> Eff es a +evalStateMVar v = evalStaticRep (State v) --- | Run the 'State' effect with the given initial state 'MVar' and return the +-- | Run the 'State' effect with the given initial state 'MVar'' and return the -- final state, discarding the final value. -execStateMVar :: MVar s -> Eff (State s : es) a -> Eff es s +execStateMVar :: MVar' s -> Eff (State s : es) a -> Eff es s execStateMVar v m = do - v' <- unsafeEff_ $ toMVar' v - _ <- evalStaticRep (State v') m - unsafeEff_ $ readMVar v + _ <- evalStaticRep (State v) m + unsafeEff_ $ readMVar' v -- | Fetch the current value of the state. get :: State s :> es => Eff es s @@ -121,7 +116,7 @@ gets f = f <$> get put :: State s :> es => s -> Eff es () put s = unsafeEff $ \es -> do State v <- getEnv es - modifyMVar_' v $ \_ -> pure s + modifyMVar'_ v $ \_ -> pure s -- | Apply the function to the current state and return a value. -- diff --git a/effectful-core/src/Effectful/Writer/Static/Shared.hs b/effectful-core/src/Effectful/Writer/Static/Shared.hs index a42444e..c078f23 100644 --- a/effectful-core/src/Effectful/Writer/Static/Shared.hs +++ b/effectful-core/src/Effectful/Writer/Static/Shared.hs @@ -27,13 +27,13 @@ module Effectful.Writer.Static.Shared , listens ) where +import Control.Concurrent.MVar.Strict import Control.Exception (onException, uninterruptibleMask) import Data.Kind import Effectful import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive -import Effectful.Internal.Utils -- | Provide access to a strict (WHNF), shared, write only value of type @w@. data Writer (w :: Type) :: Effect @@ -61,7 +61,7 @@ execWriter m = do tell :: (Writer w :> es, Monoid w) => w -> Eff es () tell w1 = unsafeEff $ \es -> do Writer v <- getEnv es - modifyMVar_' v $ \w0 -> let w = w0 <> w1 in pure w + modifyMVar'_ v $ \w0 -> let w = w0 <> w1 in pure w -- | Execute an action and append its output to the overall output of the -- 'Writer'. @@ -97,7 +97,7 @@ listen m = unsafeEff $ \es -> do merge es v0 v1 = do putEnv es $ Writer v0 w1 <- readMVar' v1 - modifyMVar_' v0 $ \w0 -> let w = w0 <> w1 in pure w + modifyMVar'_ v0 $ \w0 -> let w = w0 <> w1 in pure w pure w1 -- | Execute an action and append its output to the overall output of the diff --git a/effectful/CHANGELOG.md b/effectful/CHANGELOG.md index 39e8d49..d2dd178 100644 --- a/effectful/CHANGELOG.md +++ b/effectful/CHANGELOG.md @@ -8,7 +8,8 @@ `Effectful.Labeled.Writer`. * Add `throwErrorWith` and `throwError_` to `Effectful.Error.Static` and `Effectful.Error.Dynamic`. -* Add `Effectful.Prim.IORef`. +* Add `Effectful.Concurrent.Chan.Strict`. +* Add `Effectful.Prim.IORef` and `Effectful.Prim.IORef.Strict`. * Fix a bug in `stateM` and `modifyM` of thread local `State` effect that might've caused dropped state updates ([#237](https://github.com/haskell-effectful/effectful/issues/237)). @@ -22,6 +23,12 @@ replaced with `ThrowErrorWith`. - `stateEnv` and `modifyEnv` now take pure modification functions. If you rely on their old forms, switch to a combination of `getEnv` and `putEnv`. + - `runStateMVar`, `evalStateMVar` and `execStateMVar` now take a strict + `MVar'` from the `strict-mutable-base` package. + - `Effectful.Concurrent.MVar.Strict` is now a lifted version of + `Control.Concurrent.MVar.Strict` from `strict-mutable-base`. The original + module was renamed to `Effectful.Concurrent.MVar.Strict.Compat` and + deprecated. # effectful-2.3.1.0 (2024-06-07) * Drop support for GHC 8.8. diff --git a/effectful/effectful.cabal b/effectful/effectful.cabal index c52cdfe..7edfbcf 100644 --- a/effectful/effectful.cabal +++ b/effectful/effectful.cabal @@ -72,7 +72,7 @@ library , directory >= 1.3.2 , effectful-core >= 2.4.0.0 && < 2.4.1.0 , process >= 1.6.9 - + , strict-mutable-base >= 1.1.0.0 , time >= 1.9.2 , stm >= 2.5.0.0 , unliftio >= 0.2.20 @@ -82,8 +82,10 @@ library exposed-modules: Effectful.Concurrent Effectful.Concurrent.Async Effectful.Concurrent.Chan + Effectful.Concurrent.Chan.Strict Effectful.Concurrent.MVar Effectful.Concurrent.MVar.Strict + Effectful.Concurrent.MVar.Strict.Compat Effectful.Concurrent.STM Effectful.Concurrent.QSem Effectful.Concurrent.QSemN @@ -97,6 +99,7 @@ library Effectful.FileSystem.IO.ByteString.Lazy Effectful.FileSystem.IO.File Effectful.Prim.IORef + Effectful.Prim.IORef.Strict Effectful.Process Effectful.Temporary Effectful.Timeout @@ -141,6 +144,7 @@ test-suite test , exceptions , lifted-base , primitive + , strict-mutable-base , tasty , tasty-hunit , unliftio diff --git a/effectful/src/Effectful/Concurrent/Chan/Strict.hs b/effectful/src/Effectful/Concurrent/Chan/Strict.hs new file mode 100644 index 0000000..26a5465 --- /dev/null +++ b/effectful/src/Effectful/Concurrent/Chan/Strict.hs @@ -0,0 +1,50 @@ +-- | Lifted "Control.Concurrent.Chan.Strict". +-- +-- @since 2.4.0.0 +module Effectful.Concurrent.Chan.Strict + ( -- * Effect + Concurrent + + -- ** Handlers + , runConcurrent + + -- * Chan + , Chan' + , newChan' + , writeChan' + , readChan' + , dupChan' + , getChan'Contents + , writeList2Chan' + ) where + +import Control.Concurrent.Chan.Strict (Chan') +import Control.Concurrent.Chan.Strict qualified as C + +import Effectful +import Effectful.Concurrent.Effect +import Effectful.Dispatch.Static + +-- | Lifted 'C.newChan''. +newChan' :: Concurrent :> es => Eff es (Chan' a) +newChan' = unsafeEff_ C.newChan' + +-- | Lifted 'C.writeChan''. +writeChan' :: Concurrent :> es => Chan' a -> a -> Eff es () +writeChan' c = unsafeEff_ . C.writeChan' c + +-- | Lifted 'C.readChan''. +readChan' :: Concurrent :> es => Chan' a -> Eff es a +readChan' = unsafeEff_ . C.readChan' + +-- | Lifted 'C.dupChan''. +dupChan' :: Concurrent :> es => Chan' a -> Eff es (Chan' a) +dupChan' = unsafeEff_ . C.dupChan' + +-- | Lifted 'C.getChan'Contents'. +getChan'Contents :: Concurrent :> es => Chan' a -> Eff es [a] +getChan'Contents = unsafeEff_ . C.getChan'Contents + +-- | Lifted 'C.writeList2Chan''. +writeList2Chan' :: Concurrent :> es => Chan' a -> [a] -> Eff es () +writeList2Chan' c = unsafeEff_ . C.writeList2Chan' c diff --git a/effectful/src/Effectful/Concurrent/MVar.hs b/effectful/src/Effectful/Concurrent/MVar.hs index edc21b6..819e383 100644 --- a/effectful/src/Effectful/Concurrent/MVar.hs +++ b/effectful/src/Effectful/Concurrent/MVar.hs @@ -114,6 +114,9 @@ modifyMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do {-# INLINE modifyMVarMasked #-} -- | Lifted 'M.mkWeakMVar'. +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. mkWeakMVar :: Concurrent :> es => MVar a -> Eff es () -> Eff es (Weak (MVar a)) mkWeakMVar var f = unsafeEff $ \es -> do -- The finalizer can run at any point and in any thread. diff --git a/effectful/src/Effectful/Concurrent/MVar/Strict.hs b/effectful/src/Effectful/Concurrent/MVar/Strict.hs index 2d69159..d404c0d 100644 --- a/effectful/src/Effectful/Concurrent/MVar/Strict.hs +++ b/effectful/src/Effectful/Concurrent/MVar/Strict.hs @@ -1,5 +1,6 @@ --- | Lifted "Control.Concurrent.MVar" with operations that force values put --- inside an 'MVar' to WHNF. +-- | Lifted "Control.Concurrent.MVar.Strict". +-- +-- @since 2.4.0.0 module Effectful.Concurrent.MVar.Strict ( -- * Effect Concurrent @@ -8,30 +9,29 @@ module Effectful.Concurrent.MVar.Strict , runConcurrent -- * MVar - , MVar - , newEmptyMVar - , newMVar - , takeMVar - , putMVar - , readMVar - , swapMVar - , tryTakeMVar - , tryPutMVar - , isEmptyMVar - , withMVar - , withMVarMasked - , modifyMVar - , modifyMVar_ - , modifyMVarMasked - , modifyMVarMasked_ - , tryReadMVar - , mkWeakMVar + , MVar' + , newEmptyMVar' + , newMVar' + , takeMVar' + , putMVar' + , readMVar' + , swapMVar' + , tryTakeMVar' + , tryPutMVar' + , tryReadMVar' + , isEmptyMVar' + , withMVar' + , withMVar'Masked + , modifyMVar' + , modifyMVar'_ + , modifyMVar'Masked + , modifyMVar'Masked_ + , mkWeakMVar' ) where import System.Mem.Weak (Weak) -import Control.Exception (evaluate) -import Control.Concurrent.MVar (MVar) -import Control.Concurrent.MVar qualified as M +import Control.Concurrent.MVar.Strict (MVar') +import Control.Concurrent.MVar.Strict qualified as M import Effectful import Effectful.Concurrent.Effect @@ -39,92 +39,87 @@ import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive import Effectful.Dispatch.Static.Unsafe --- | Lifted 'M.newEmptyMVar'. -newEmptyMVar :: Concurrent :> es => Eff es (MVar a) -newEmptyMVar = unsafeEff_ M.newEmptyMVar - --- | Lifted 'M.newMVar' that evaluates the value to WHNF. -newMVar :: Concurrent :> es => a -> Eff es (MVar a) -newMVar a = unsafeEff_ $ M.newMVar =<< evaluate a - --- | Lifted 'M.takeMVar'. -takeMVar :: Concurrent :> es => MVar a -> Eff es a -takeMVar = unsafeEff_ . M.takeMVar - --- | Lifted 'M.putMVar'. -putMVar :: Concurrent :> es => MVar a -> a -> Eff es () -putMVar var a = unsafeEff_ $ M.putMVar var =<< evaluate a - --- | Lifted 'M.readMVar'. -readMVar :: Concurrent :> es => MVar a -> Eff es a -readMVar = unsafeEff_ . M.readMVar - --- | Lifted 'M.swapMVar' that evaluates the new value to WHNF. -swapMVar :: Concurrent :> es => MVar a -> a -> Eff es a -swapMVar var a = unsafeEff_ $ M.swapMVar var =<< evaluate a - --- | Lifted 'M.tryTakeMVar'. -tryTakeMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a) -tryTakeMVar = unsafeEff_ . M.tryTakeMVar - --- | Lifted 'M.tryPutMVar' that evaluates the new value to WHNF. -tryPutMVar :: Concurrent :> es => MVar a -> a -> Eff es Bool -tryPutMVar var a = unsafeEff_ $ M.tryPutMVar var =<< evaluate a - --- | Lifted 'M.isEmptyMVar'. -isEmptyMVar :: Concurrent :> es => MVar a -> Eff es Bool -isEmptyMVar = unsafeEff_ . M.isEmptyMVar - --- | Lifted 'M.tryReadMVar'. -tryReadMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a) -tryReadMVar = unsafeEff_ . M.tryReadMVar - --- | Lifted 'M.withMVar'. -withMVar :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b -withMVar var f = reallyUnsafeUnliftIO $ \unlift -> do - M.withMVar var $ unlift . f -{-# INLINE withMVar #-} - --- | Lifted 'M.withMVarMasked'. -withMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b -withMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do - M.withMVarMasked var $ unlift . f -{-# INLINE withMVarMasked #-} - --- | Lifted 'M.modifyMVar_' that evaluates the new value to WHNF. -modifyMVar_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () -modifyMVar_ var f = reallyUnsafeUnliftIO $ \unlift -> do - M.modifyMVar_ var $ \a0 -> do - a <- unlift $ f a0 - evaluate a -{-# INLINE modifyMVar_ #-} - --- | Lifted 'M.modifyMVar' that evaluates the new value to WHNF. -modifyMVar :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b -modifyMVar var f = reallyUnsafeUnliftIO $ \unlift -> do - M.modifyMVar var $ \a0 -> do - (a, b) <- unlift $ f a0 - (, b) <$> evaluate a -{-# INLINE modifyMVar #-} - --- | Lifted 'M.modifyMVarMasked_' that evaluates the new value to WHNF. -modifyMVarMasked_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () -modifyMVarMasked_ var f = reallyUnsafeUnliftIO $ \unlift -> do - M.modifyMVarMasked_ var $ \a0 -> do - a <- unlift $ f a0 - evaluate a -{-# INLINE modifyMVarMasked_ #-} - --- | Lifted 'M.modifyMVarMasked' that evaluates the new value to WHNF. -modifyMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b -modifyMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do - M.modifyMVarMasked var $ \a0 -> do - (a, b) <- unlift $ f a0 - (, b) <$> evaluate a -{-# INLINE modifyMVarMasked #-} - --- | Lifted 'M.mkWeakMVar'. -mkWeakMVar :: Concurrent :> es => MVar a -> Eff es () -> Eff es (Weak (MVar a)) -mkWeakMVar var f = unsafeEff $ \es -> do +-- | Lifted 'M.newEmptyMVar''. +newEmptyMVar' :: Concurrent :> es => Eff es (MVar' a) +newEmptyMVar' = unsafeEff_ M.newEmptyMVar' + +-- | Lifted 'M.newMVar''. +newMVar' :: Concurrent :> es => a -> Eff es (MVar' a) +newMVar' = unsafeEff_ . M.newMVar' + +-- | Lifted 'M.takeMVar''. +takeMVar' :: Concurrent :> es => MVar' a -> Eff es a +takeMVar' = unsafeEff_ . M.takeMVar' + +-- | Lifted 'M.putMVar''. +putMVar' :: Concurrent :> es => MVar' a -> a -> Eff es () +putMVar' var = unsafeEff_ . M.putMVar' var + +-- | Lifted 'M.readMVar''. +readMVar' :: Concurrent :> es => MVar' a -> Eff es a +readMVar' = unsafeEff_ . M.readMVar' + +-- | Lifted 'M.swapMVar''. +swapMVar' :: Concurrent :> es => MVar' a -> a -> Eff es a +swapMVar' var = unsafeEff_ . M.swapMVar' var + +-- | Lifted 'M.tryTakeMVar''. +tryTakeMVar' :: Concurrent :> es => MVar' a -> Eff es (Maybe a) +tryTakeMVar' = unsafeEff_ . M.tryTakeMVar' + +-- | Lifted 'M.tryPutMVar''. +tryPutMVar' :: Concurrent :> es => MVar' a -> a -> Eff es Bool +tryPutMVar' var = unsafeEff_ . M.tryPutMVar' var + +-- | Lifted 'M.tryReadMVar''. +tryReadMVar' :: Concurrent :> es => MVar' a -> Eff es (Maybe a) +tryReadMVar' = unsafeEff_ . M.tryReadMVar' + +-- | Lifted 'M.isEmptyMVar''. +isEmptyMVar' :: Concurrent :> es => MVar' a -> Eff es Bool +isEmptyMVar' = unsafeEff_ . M.isEmptyMVar' + +-- | Lifted 'M.withMVar''. +withMVar' :: Concurrent :> es => MVar' a -> (a -> Eff es b) -> Eff es b +withMVar' var f = reallyUnsafeUnliftIO $ \unlift -> do + M.withMVar' var $ unlift . f +{-# INLINE withMVar' #-} + +-- | Lifted 'M.withMVar'Masked'. +withMVar'Masked :: Concurrent :> es => MVar' a -> (a -> Eff es b) -> Eff es b +withMVar'Masked var f = reallyUnsafeUnliftIO $ \unlift -> do + M.withMVar'Masked var $ unlift . f +{-# INLINE withMVar'Masked #-} + +-- | Lifted 'M.modifyMVar'_'. +modifyMVar'_ :: Concurrent :> es => MVar' a -> (a -> Eff es a) -> Eff es () +modifyMVar'_ var f = reallyUnsafeUnliftIO $ \unlift -> do + M.modifyMVar'_ var $ unlift . f +{-# INLINE modifyMVar'_ #-} + +-- | Lifted 'M.modifyMVar''. +modifyMVar' :: Concurrent :> es => MVar' a -> (a -> Eff es (a, b)) -> Eff es b +modifyMVar' var f = reallyUnsafeUnliftIO $ \unlift -> do + M.modifyMVar' var $ unlift . f +{-# INLINE modifyMVar' #-} + +-- | Lifted 'M.modifyMVar'Masked_'. +modifyMVar'Masked_ :: Concurrent :> es => MVar' a -> (a -> Eff es a) -> Eff es () +modifyMVar'Masked_ var f = reallyUnsafeUnliftIO $ \unlift -> do + M.modifyMVar'Masked_ var $ unlift . f +{-# INLINE modifyMVar'Masked_ #-} + +-- | Lifted 'M.modifyMVar'Masked'. +modifyMVar'Masked :: Concurrent :> es => MVar' a -> (a -> Eff es (a, b)) -> Eff es b +modifyMVar'Masked var f = reallyUnsafeUnliftIO $ \unlift -> do + M.modifyMVar'Masked var $ unlift . f +{-# INLINE modifyMVar'Masked #-} + +-- | Lifted 'M.mkWeakMVar''. +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. +mkWeakMVar' :: Concurrent :> es => MVar' a -> Eff es () -> Eff es (Weak (MVar' a)) +mkWeakMVar' var f = unsafeEff $ \es -> do -- The finalizer can run at any point and in any thread. - M.mkWeakMVar var . unEff f =<< cloneEnv es + M.mkWeakMVar' var . unEff f =<< cloneEnv es diff --git a/effectful/src/Effectful/Concurrent/MVar/Strict/Compat.hs b/effectful/src/Effectful/Concurrent/MVar/Strict/Compat.hs new file mode 100644 index 0000000..86cbf01 --- /dev/null +++ b/effectful/src/Effectful/Concurrent/MVar/Strict/Compat.hs @@ -0,0 +1,134 @@ +-- | Lifted "Control.Concurrent.MVar" with operations that force values put +-- inside an 'MVar' to WHNF. +module Effectful.Concurrent.MVar.Strict.Compat + {-# DEPRECATED "Use Effectful.Concurrent.MVar.Strict" #-} + ( -- * Effect + Concurrent + + -- ** Handlers + , runConcurrent + + -- * MVar + , MVar + , newEmptyMVar + , newMVar + , takeMVar + , putMVar + , readMVar + , swapMVar + , tryTakeMVar + , tryPutMVar + , isEmptyMVar + , withMVar + , withMVarMasked + , modifyMVar + , modifyMVar_ + , modifyMVarMasked + , modifyMVarMasked_ + , tryReadMVar + , mkWeakMVar + ) where + +import System.Mem.Weak (Weak) +import Control.Exception (evaluate) +import Control.Concurrent.MVar (MVar) +import Control.Concurrent.MVar qualified as M + +import Effectful +import Effectful.Concurrent.Effect +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Dispatch.Static.Unsafe + +-- | Lifted 'M.newEmptyMVar'. +newEmptyMVar :: Concurrent :> es => Eff es (MVar a) +newEmptyMVar = unsafeEff_ M.newEmptyMVar + +-- | Lifted 'M.newMVar' that evaluates the value to WHNF. +newMVar :: Concurrent :> es => a -> Eff es (MVar a) +newMVar a = unsafeEff_ $ M.newMVar =<< evaluate a + +-- | Lifted 'M.takeMVar'. +takeMVar :: Concurrent :> es => MVar a -> Eff es a +takeMVar = unsafeEff_ . M.takeMVar + +-- | Lifted 'M.putMVar'. +putMVar :: Concurrent :> es => MVar a -> a -> Eff es () +putMVar var a = unsafeEff_ $ M.putMVar var =<< evaluate a + +-- | Lifted 'M.readMVar'. +readMVar :: Concurrent :> es => MVar a -> Eff es a +readMVar = unsafeEff_ . M.readMVar + +-- | Lifted 'M.swapMVar' that evaluates the new value to WHNF. +swapMVar :: Concurrent :> es => MVar a -> a -> Eff es a +swapMVar var a = unsafeEff_ $ M.swapMVar var =<< evaluate a + +-- | Lifted 'M.tryTakeMVar'. +tryTakeMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a) +tryTakeMVar = unsafeEff_ . M.tryTakeMVar + +-- | Lifted 'M.tryPutMVar' that evaluates the new value to WHNF. +tryPutMVar :: Concurrent :> es => MVar a -> a -> Eff es Bool +tryPutMVar var a = unsafeEff_ $ M.tryPutMVar var =<< evaluate a + +-- | Lifted 'M.isEmptyMVar'. +isEmptyMVar :: Concurrent :> es => MVar a -> Eff es Bool +isEmptyMVar = unsafeEff_ . M.isEmptyMVar + +-- | Lifted 'M.tryReadMVar'. +tryReadMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a) +tryReadMVar = unsafeEff_ . M.tryReadMVar + +-- | Lifted 'M.withMVar'. +withMVar :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b +withMVar var f = reallyUnsafeUnliftIO $ \unlift -> do + M.withMVar var $ unlift . f +{-# INLINE withMVar #-} + +-- | Lifted 'M.withMVarMasked'. +withMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b +withMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do + M.withMVarMasked var $ unlift . f +{-# INLINE withMVarMasked #-} + +-- | Lifted 'M.modifyMVar_' that evaluates the new value to WHNF. +modifyMVar_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () +modifyMVar_ var f = reallyUnsafeUnliftIO $ \unlift -> do + M.modifyMVar_ var $ \a0 -> do + a <- unlift $ f a0 + evaluate a +{-# INLINE modifyMVar_ #-} + +-- | Lifted 'M.modifyMVar' that evaluates the new value to WHNF. +modifyMVar :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b +modifyMVar var f = reallyUnsafeUnliftIO $ \unlift -> do + M.modifyMVar var $ \a0 -> do + (a, b) <- unlift $ f a0 + (, b) <$> evaluate a +{-# INLINE modifyMVar #-} + +-- | Lifted 'M.modifyMVarMasked_' that evaluates the new value to WHNF. +modifyMVarMasked_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () +modifyMVarMasked_ var f = reallyUnsafeUnliftIO $ \unlift -> do + M.modifyMVarMasked_ var $ \a0 -> do + a <- unlift $ f a0 + evaluate a +{-# INLINE modifyMVarMasked_ #-} + +-- | Lifted 'M.modifyMVarMasked' that evaluates the new value to WHNF. +modifyMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b +modifyMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do + M.modifyMVarMasked var $ \a0 -> do + (a, b) <- unlift $ f a0 + (, b) <$> evaluate a +{-# INLINE modifyMVarMasked #-} + +-- | Lifted 'M.mkWeakMVar'. +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. +mkWeakMVar :: Concurrent :> es => MVar a -> Eff es () -> Eff es (Weak (MVar a)) +mkWeakMVar var f = unsafeEff $ \es -> do + -- The finalizer can run at any point and in any thread. + M.mkWeakMVar var . unEff f =<< cloneEnv es diff --git a/effectful/src/Effectful/Concurrent/STM.hs b/effectful/src/Effectful/Concurrent/STM.hs index 5c44585..556c538 100644 --- a/effectful/src/Effectful/Concurrent/STM.hs +++ b/effectful/src/Effectful/Concurrent/STM.hs @@ -116,6 +116,9 @@ registerDelay :: Concurrent :> es => Int -> Eff es (TVar Bool) registerDelay = unsafeEff_ . STM.registerDelay -- | Lifted 'STM.mkWeakTVar'. +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. mkWeakTVar :: Concurrent :> es => TVar a -> Eff es () -> Eff es (Weak (TVar a)) mkWeakTVar var f = unsafeEff $ \es -> do -- The finalizer can run at any point and in any thread. @@ -130,6 +133,9 @@ newEmptyTMVarIO :: Concurrent :> es => Eff es (TMVar a) newEmptyTMVarIO = unsafeEff_ STM.newEmptyTMVarIO -- | Lifted 'STM.mkWeakTMVar'. +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. mkWeakTMVar :: Concurrent :> es => TMVar a -> Eff es () -> Eff es (Weak (TMVar a)) mkWeakTMVar var f = unsafeEff $ \es -> do -- The finalizer can run at any point and in any thread. diff --git a/effectful/src/Effectful/Prim/IORef.hs b/effectful/src/Effectful/Prim/IORef.hs index 34b1684..e64b882 100644 --- a/effectful/src/Effectful/Prim/IORef.hs +++ b/effectful/src/Effectful/Prim/IORef.hs @@ -66,6 +66,9 @@ atomicWriteIORef :: Prim :> es => IORef a -> a -> Eff es () atomicWriteIORef var = unsafeEff_ . Ref.atomicWriteIORef var -- | Lifted 'Ref.mkWeakIORef'. +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. mkWeakIORef :: Prim :> es => IORef a -> Eff es () -> Eff es (Weak (IORef a)) mkWeakIORef var f = unsafeEff $ \es -> do -- The finalizer can run at any point and in any thread. diff --git a/effectful/src/Effectful/Prim/IORef/Strict.hs b/effectful/src/Effectful/Prim/IORef/Strict.hs new file mode 100644 index 0000000..c8a8a3c --- /dev/null +++ b/effectful/src/Effectful/Prim/IORef/Strict.hs @@ -0,0 +1,62 @@ +-- | Lifted "Data.IORef.Strict". +-- +-- @since 2.4.0.0 +module Effectful.Prim.IORef.Strict + ( -- * Effect + Prim + + -- ** Handlers + , runPrim + + -- * IORef + , IORef' + , newIORef' + , readIORef' + , writeIORef' + , modifyIORef' + , atomicModifyIORef' + , atomicWriteIORef' + , mkWeakIORef' + ) where + +import Data.IORef.Strict (IORef') +import Data.IORef.Strict qualified as Ref +import System.Mem.Weak (Weak) + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Prim + +-- | Lifted 'Ref.newIORef''. +newIORef' :: Prim :> es => a -> Eff es (IORef' a) +newIORef' = unsafeEff_ . Ref.newIORef' + +-- | Lifted 'Ref.readIORef''. +readIORef' :: Prim :> es => IORef' a -> Eff es a +readIORef' = unsafeEff_ . Ref.readIORef' + +-- | Lifted 'Ref.writeIORef''. +writeIORef' :: Prim :> es => IORef' a -> a -> Eff es () +writeIORef' var = unsafeEff_ . Ref.writeIORef' var + +-- | Lifted 'Ref.modifyIORef''. +modifyIORef' :: Prim :> es => IORef' a -> (a -> a) -> Eff es () +modifyIORef' var = unsafeEff_ . Ref.modifyIORef' var + +-- | Lifted 'Ref.atomicModifyIORef''. +atomicModifyIORef' :: Prim :> es => IORef' a -> (a -> (a, b)) -> Eff es b +atomicModifyIORef' var = unsafeEff_ . Ref.atomicModifyIORef' var + +-- | Lifted 'Ref.atomicWriteIORef''. +atomicWriteIORef' :: Prim :> es => IORef' a -> a -> Eff es () +atomicWriteIORef' var = unsafeEff_ . Ref.atomicWriteIORef' var + +-- | Lifted 'Ref.mkWeakIORef''. +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. +mkWeakIORef' :: Prim :> es => IORef' a -> Eff es () -> Eff es (Weak (IORef' a)) +mkWeakIORef' var f = unsafeEff $ \es -> do + -- The finalizer can run at any point and in any thread. + Ref.mkWeakIORef' var . unEff f =<< cloneEnv es diff --git a/effectful/tests/StateTests.hs b/effectful/tests/StateTests.hs index 85ac85a..16edadf 100644 --- a/effectful/tests/StateTests.hs +++ b/effectful/tests/StateTests.hs @@ -3,6 +3,7 @@ module StateTests (stateTests) where import Control.Exception.Lifted qualified as LE import Control.Monad import Control.Monad.Catch qualified as E +import Data.IORef.Strict import Test.Tasty import Test.Tasty.HUnit import UnliftIO.Exception qualified as UE @@ -11,7 +12,6 @@ import Effectful import Effectful.Dispatch.Dynamic import Effectful.Dispatch.Static import Effectful.Internal.Env -import Effectful.Internal.Utils import Effectful.State.Static.Local import Utils qualified as U