diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `linear-locks` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2026 Author name here + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,236 @@ + + +# linear-locks + +`linear-locks` is a port of the +[Surelock](https://notes.brooklynzelenka.com/Blog/Surelock) Rust crate +to Linear Haskell. + +The package provides locking primitives that are statically guaranteed +not to lead to deadlocks. + +It achieves this by breaking one of the [Coffman conditions for +deadlocks](https://en.wikipedia.org/wiki/Deadlock_(computer_science)#Prevention): +the "circular wait" condition. `linear-locks` ensures locks are always +acquired in a consistent order. + +Currently supported lock types: + +- "LinearLocks.Mutex" +- "LinearLocks.Mutex.Strict" +- "LinearLocks.RWLock" +- "LinearLocks.RWLock.Strict" + +See [Getting Started](#getting-started) for a quick introduction to the +API. Some examples can also be found in the +[examples](https://github.com/dcastro/linear-locks/tree/main/examples/src) +folder. + +## Motivation + +In Haskell, [`STM` is the holy +grail](https://chrispenner.ca/posts/mutexes) for synchronizing access to +multiple shared resources without risking deadlocks, and it should +absolutely be the first thing on your mind when writing concurrent code. + +Still, `STM` does have its limitations: + +- You cannot run arbitrary `IO` actions within `STM` transactions, which + can be a roadblock if you need to interact with the outside world + while holding locks. +- Due to its optimistic nature, scenarios with high contention can lead + to excessive transaction retries and livelocks. + +Locking primitives like `MVar`s solve both of these issues, but juggling +multiple `MVar`s is a sure way to hit a deadlock sooner or later. + +Enter `linear-locks`: it provides locking primitives that are statically +guaranteed to be free of deadlocks. + +## Getting started + +`linear-locks` is meant to be used alongside the +[`linear-base`](https://hackage.haskell.org/package/linear-base) +package. + +We'll need `QualifiedDo`: + +``` haskell +{-# LANGUAGE GHC2024 #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE QualifiedDo #-} +``` + +And the following imports: + +``` haskell +import LinearLocks +import LinearLocks.Mutex qualified as Mutex + +-- From `linear-base`: +import Prelude.Linear (Ur (..)) +import Control.Functor.Linear qualified as Linear +import Control.Monad.IO.Class.Linear qualified as Linear +``` + +Each lock is assigned a "level" at compile-time. + +``` haskell + -- `Mutex 0 Config` + configMutex <- Mutex.new 0 Config { verbose = True } + + -- `Mutex 1 DbConn` + dbMutex <- Mutex.new 1 DbConn {} +``` + +We can then enter a "lock scope". + +We're given a `LockKey lvl` that we can use to acquire locks. The key +starts off with level 0 (`LockKey 0`) and it can be used to acquire any +lock with level 0 or above. + +Every time we acquire a lock, the key's level increases. Acquiring +`Mutex 0 Config` consumes our `LockKey 0` and gives us a `LockKey 1` +back. Acquiring `Mutex 1 DbConn` then gives us a `LockKey 2`. + +``` haskell + lockScope \key -> Linear.do + -- ↓ Consumes `LockKey 0` to acquire a `Mutex 0` + (configGuard, key) <- Mutex.acquire key configMutex + -- ↑ Returns `LockKey 1` + + + -- ↓ Consumes `LockKey 1` to acquire a `Mutex 1` + (dbGuard, key) <- Mutex.acquire key dbMutex + -- ↑ Returns `LockKey 2` + + Mutex.release configGuard + Mutex.release dbGuard + dropKey key + Linear.pure (Ur ()) +``` + +Acquiring locks in the wrong order (e.g. trying to acquire a lock of +level 0 with a key of level 2) would be a type error. This ensures locks +are always acquired in order of increasing level, preventing circular +waits and thus deadlocks. + +The key is linearly typed; it must be consumed *exactly once*. Using the +same key to acquire 2 locks would be a type error. + +Notice how we had to use `Linear.do` (enabled by the `QualifiedDo` +extension) and `Linear.pure` instead of `Prelude.pure` to chain our +actions together. This is because the lock scope action runs in +[`RIO`](https://hackage-content.haskell.org/package/linear-base/docs/System-IO-Resource-Linear.html), +and `RIO` does not implement `Prelude.Monad`; instead, it implements +[`Linear.Monad`](https://hackage-content.haskell.org/package/linear-base/docs/Control-Functor-Linear.html#t:Monad) +from `linear-base`. This ensures values bound by `>>=` must be consumed +exactly once. + +Since dropping the key before returning is a common pattern, we provide +the `dropKeyAndReturn` function to conveniently do both at once. + +

+ +Guards +

+ +When we acquire a mutex, we get back a `MutexGuard a` that represents +our ownership of the lock. We can freely read from / write to it while +the lock is held. + +The guard is also linearly typed, thus ensuring: + +- We can never forget to release it with `release`. +- It cannot be used after being released. + +``` haskell + lockScope \key -> Linear.do + (configGuard, key) <- Mutex.acquire key configMutex + + (Ur config, configGuard) <- Mutex.read configGuard + + configGuard <- Mutex.write configGuard config { verbose = False } + + Mutex.release configGuard + dropKeyAndReturn key () +``` + +Since the guard is linear, `read` and `write` must consume the guard and +return a new one. + +`read configGuard` returns a `Ur Config`. `Ur` is short for +"unrestricted", meaning the value is *not* linear and can be freely used +as many times as needed. + +

+ +LockSet +

+ +Locks with the same level must be acquired simultaneously by adding them +to a `LockSet` and using `acquireMany`. + +``` haskell + alice <- Mutex.new 3 User { balance = 100 } + bob <- Mutex.new 3 User { balance = 100 } + + users <- newLockSet (alice, bob) + + lockScope \key -> Linear.do + ((aliceGuard, bobGuard), key) <- acquireMany key users + (Ur alice, aliceGuard) <- Mutex.read aliceGuard + (Ur bob, bobGuard) <- Mutex.read bobGuard + + bobGuard <- Mutex.write bobGuard bob { balance = balance bob + 10 } + aliceGuard <- Mutex.write aliceGuard alice { balance = balance alice - 10 } + + Mutex.release bobGuard + Mutex.release aliceGuard + dropKeyAndReturn key () +``` + +To prevent deadlocks, locks in a set are always acquired in a +deterministic order. Creating a set with `(alice, bob)` or +`(bob, alice)` will always result in them being acquired in the same +order. + +

+ +IO +

+ +You can use the linear [`MonadIO` from +`linear-base`](https://hackage-content.haskell.org/package/linear-base/docs/Control-Monad-IO-Class-Linear.html) +to lift `IO` actions into the lock scope. + +``` haskell + lockScope \key -> Linear.do + (configGuard, key) <- Mutex.acquire key configMutex + (Ur config, configGuard) <- Mutex.read configGuard + + Ur newVerbose <- Linear.liftSystemIOU do + putStrLn $ "Verbose mode is: " <> show (verbose config) + putStrLn $ "Enter new verbose mode: " + readLn @Bool + + configGuard <- Mutex.write configGuard config { verbose = newVerbose } + Mutex.release configGuard + dropKeyAndReturn key () +``` + +Note: for the time being, the `linear-locks` package conditionally +provides an orphan instance of `MonadIO` for the `RIO` monad when +compiled against `linear-base <= 0.7.0`. The next version of +`linear-base` [will +include](https://github.com/tweag/linear-base/pull/505) a `MonadIO` +instance itself. + +## Roadmap + +- [ ] Allow backtracking of `LockKey`'s level when a lock is released diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/linear-locks.cabal b/linear-locks.cabal new file mode 100644 --- /dev/null +++ b/linear-locks.cabal @@ -0,0 +1,101 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.39.1. +-- +-- see: https://github.com/sol/hpack + +name: linear-locks +version: 0.1.0.0 +synopsis: Locking primitives free of deadlocks. +description: `linear-locks` provides locking primitives that are statically guaranteed to be free of deadlocks. + Please see the README on GitHub at +category: Concurrency, Parallelism, Mutable State +homepage: https://github.com/dcastro/linear-locks#readme +bug-reports: https://github.com/dcastro/linear-locks/issues +author: Diogo Castro +maintainer: dc@diogocastro.com +copyright: 2026 Diogo Castro +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +tested-with: + GHC == 9.10.3 , GHC == 9.12.4 , GHC == 9.14.1 +extra-source-files: + README.md +extra-doc-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/dcastro/linear-locks + +library + exposed-modules: + LinearLocks + LinearLocks.Internal + LinearLocks.Internal.LockSet + LinearLocks.Internal.Mutex + LinearLocks.Internal.RWLock + LinearLocks.Internal.StrictMutex + LinearLocks.Internal.StrictRWLock + LinearLocks.Mutex + LinearLocks.Mutex.Strict + LinearLocks.RWLock + LinearLocks.RWLock.Strict + other-modules: + Paths_linear_locks + autogen-modules: + Paths_linear_locks + hs-source-dirs: + src + default-extensions: + BlockArguments + StrictData + TypeFamilies + ghc-options: -Weverything -Wno-name-shadowing -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-export-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-missing-kind-signatures -Wno-missing-role-annotations + build-depends: + atomic-primops >=0.8.4 + , base >=4.20 && <5 + , concurrent-extra >=0.7.0.12 + , containers >=0.6.8 + , deepseq >=1.5.0.0 + , focus >=1.0.3.2 + , linear-base >=0.4.0 + , stm-containers >=1.2.1 + , vector >=0.13.1.0 + , vector-algorithms >=0.9.0.1 + default-language: GHC2024 + +test-suite linear-locks-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.LinearLocks.LockSetSpec + Test.LinearLocks.MutexSpec + Test.LinearLocks.RWLockSpec + Test.LinearLocks.StrictMutexSpec + Test.LinearLocks.StrictRWLockSpec + Paths_linear_locks + autogen-modules: + Paths_linear_locks + hs-source-dirs: + test + default-extensions: + BlockArguments + StrictData + TypeFamilies + ghc-options: -Weverything -Wno-name-shadowing -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-export-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-missing-kind-signatures -Wno-missing-role-annotations + build-tool-depends: + tasty-discover:tasty-discover + build-depends: + base + , concurrent-extra + , hspec-expectations-pretty-diff + , linear-base + , linear-locks + , list-t + , stm-containers + , tasty + , tasty-hunit-compat + , vector + default-language: GHC2024 diff --git a/src/LinearLocks.hs b/src/LinearLocks.hs new file mode 100644 --- /dev/null +++ b/src/LinearLocks.hs @@ -0,0 +1,68 @@ +{- ORMOLU_DISABLE -} +{- | + +@linear-locks@ provides locking primitives that are statically guaranteed to not lead to deadlocks. + +An in-depth description and tutorial can be found in the [README](https://github.com/dcastro/linear-locks#readme). + +It is meant to be used with @QualifiedDo@ and these imports: + +>>> :set -XQualifiedDo -XGHC2024 -XBlockArguments +>>> import LinearLocks +>>> import LinearLocks.Mutex qualified as Mutex +>>> import Prelude.Linear (Ur (..)) +>>> import Control.Functor.Linear qualified as Linear +>>> import Control.Monad.IO.Class.Linear qualified as Linear + + +>>> :{ +example :: IO () +example = do + -- Create mutexes with a chosen level + configMutex <- Mutex.new 0 Config { verbose = True } + dbMutex <- Mutex.new 1 DbConn {} + -- + -- Enter a lockscope + lockScope \key -> Linear.do + -- Acquire locks + (configGuard, key) <- acquire key configMutex + (dbGuard, key) <- acquire key dbMutex + -- + -- Read/write + (Ur config, configGuard) <- Mutex.read configGuard + configGuard <- Mutex.write configGuard config { verbose = False } + -- + -- IO actions + Linear.liftSystemIO do + putStrLn $ "Verbose mode was: " <> show (verbose config) + -- + -- Release locks + Mutex.release configGuard + Mutex.release dbGuard + dropKeyAndReturn key () +:} + +-} +{- ORMOLU_ENABLE -} +module LinearLocks + ( -- * Lock scope + LockKey, + lockScope, + dropKey, + dropKeyAndReturn, + NestedLocksScopeException (..), + + -- * Lock sets + LockSet, + IsLockSet (), -- Note: do not export the typeclass members + newLockSet, + acquireMany, + ) +where + +import LinearLocks.Internal +import LinearLocks.Internal.LockSet + +-- $setup +-- >>> data Config = Config { verbose :: Bool } +-- >>> data DbConn = DbConn diff --git a/src/LinearLocks/Internal.hs b/src/LinearLocks/Internal.hs new file mode 100644 --- /dev/null +++ b/src/LinearLocks/Internal.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RequiredTypeArguments #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_HADDOCK not-home #-} + +#if !MIN_VERSION_linear_base(0,7,1) +{-# OPTIONS_GHC -Wno-orphans #-} +#endif + +module LinearLocks.Internal where + +import Control.Concurrent (ThreadId, myThreadId) +import Control.DeepSeq (NFData, force) +import Control.Exception (Exception (..), bracket_, throw) +import Control.Functor.Linear qualified as L +import Control.Monad.IO.Class.Linear qualified as L +import Data.Atomics.Counter (AtomicCounter) +import Data.Atomics.Counter qualified as Atomic +import Data.IntMap.Strict qualified as IntMap +import Data.Vector.Generic qualified as VG +import Data.Vector.Generic.Mutable qualified as VGM +import Data.Vector.Primitive qualified as VP +import Data.Vector.Unboxed qualified as VU +import Focus qualified +import GHC.Base (Type) +import GHC.Conc (atomically) +import GHC.IO (unsafePerformIO) +import GHC.TypeLits (Nat, type (+), type (<=)) +import Prelude.Linear (Ur (..)) +import StmContainers.Set qualified as StmSet +import System.IO.Linear qualified as L +import System.IO.Resource.Linear (RIO) +import System.IO.Resource.Linear qualified as RIO +import System.IO.Resource.Linear.Internal qualified as RIOInternal + +-- | A key used to acquire locks. +-- A key of level @n@ can only acquire locks of level @n@ or higher. +-- +-- Acquiring a lock with `acquire` or `LinearLocks.acquireMany` will consume the key and return a new key with an increased level, +-- ensuring locks are always acquired in a consistent order. +data LockKey (lvl :: Nat) + = -- Notes: + -- * Do not export the constructor + -- * Do not implement `Consumable` / `Dupable` / `Movable` + UnsafeLockKey + +-- | A unique identifier for a lock. +newtype LockId = LockId Int + deriving newtype (Eq, Ord, Show) + +newtype instance VU.MVector s LockId = MV_LockId (VP.MVector s Int) + +newtype instance VU.Vector LockId = V_LockId (VP.Vector Int) + +deriving via (VU.UnboxViaPrim Int) instance VGM.MVector VU.MVector LockId + +deriving via (VU.UnboxViaPrim Int) instance VG.Vector VU.Vector LockId + +instance VU.Unbox LockId + +-- | Creates a new lock scope with a key of level 0, and runs the given function with it. +-- The key can be used to acquire locks with `acquire` and `LinearLocks.acquireMany`. +-- +-- After acquiring all the necessary locks, the key must be dropped with +-- `dropKey` or `dropKeyAndReturn`. +-- +-- Will throw a t`NestedLocksScopeException` if a nested `lockScope` is created at runtime. +lockScope :: + forall a. + -- NOTE: The use of `Ur` prevents the key (and any other linear values) from escaping the scope + -- of the `lockScope` function via the variable `a`. + -- See: https://www.tweag.io/blog/2023-03-23-linear-constraints-linearly/#sticky-ends-of-scopes + (LockKey 0 %1 -> RIO (Ur a)) -> + IO a +lockScope run = do + ensureNotNested do + RIO.run L.do + let key = UnsafeLockKey @0 + run key + where + -- Ensures nested lock scopes are not created. + -- We can't really detect this at compile-time, so we'll make do with a runtime check. + ensureNotNested :: IO a -> IO a + ensureNotNested action = do + tid <- myThreadId + bracket_ + -- Acquire: register the thread ID in the set of active lock scopes. + ( do + success <- atomically do + StmSet.focus + ( do + -- Check if the thread ID is already in the set. + Focus.lookup >>= \case + Just () -> + -- The thread ID was found in the set, which means we're trying to create a nested lock scope. + -- We return `False` to signal an error. + pure False + Nothing -> do + Focus.insert () + pure True + ) + tid + lockScopes + if success + then pure () + else throw NestedLocksScopeException + ) + -- Release: remove the thread ID from the set of active lock scopes. + ( atomically do + StmSet.delete tid lockScopes + ) + action + +-- | Discard a key. Should be used after acquiring all the necessary locks in a lock scope. +dropKey :: LockKey lvl %1 -> RIO () +dropKey UnsafeLockKey = L.pure () + +-- | Convenience function to drop the key and return a pure value at the end of a lock scope. +dropKeyAndReturn :: LockKey lvl %1 -> a -> RIO (Ur a) +dropKeyAndReturn key a = L.do + dropKey key + L.pure (Ur a) + +data NestedLocksScopeException = NestedLocksScopeException + deriving stock (Show) + +instance Exception NestedLocksScopeException where + displayException NestedLocksScopeException = "Nested lock scopes are not allowed" + +-- | Acquires a lock. +-- Consumes the key and return a new key (with an increased level). +acquire :: + forall keyLvl acquirable. + (Acquirable acquirable) => + (keyLvl <= Level acquirable) => + LockKey keyLvl %1 -> + acquirable -> + RIO (Guard acquirable, LockKey (Level acquirable + 1)) +acquire UnsafeLockKey m = L.do + guard <- unsafeAcquire m + L.pure (guard, UnsafeLockKey) + +class (Releasable (Guard acquirable)) => Acquirable acquirable where + type Guard acquirable :: Type + type Level acquirable :: Nat + + getId :: acquirable -> LockId + + -- | This is marked as unsafe because it does not consume a `LockKey`. + unsafeAcquire :: acquirable -> RIO (Guard acquirable) + +class Releasable guard where + -- Design decision: `doRelease` generalizes over releasing any kind of guard, but we don't export it. + -- We only export the monomorphic `release` functions for each guard type, because they might have + -- important notes in their haddock docs (e.g. `StrictMutex.release` does deep evaluation and might throw an exception as a result), + -- so it's important those docs are easily discoverable and not hidden behind a more general `doRelease` function. + doRelease :: guard %1 -> RIO () + +---------------------------------------------------------------------------- +-- Global variables +---------------------------------------------------------------------------- + +-- | A set of the ThreadIds currently holding a lock scope. +-- We use this to prevent nested lock scopes at runtime. +{-# NOINLINE lockScopes #-} +lockScopes :: StmSet.Set ThreadId +lockScopes = + -- See: https://wiki.haskell.org/index.php?oldid=64612 + unsafePerformIO StmSet.newIO + +-- | An atomic counter used to generate unique IDs for locks. +{-# NOINLINE lockIdCounter #-} +lockIdCounter :: AtomicCounter +lockIdCounter = + unsafePerformIO $ Atomic.newCounter 0 + +-- | Generates the next unique lock ID. +nextLockId :: IO LockId +nextLockId = do + newId <- Atomic.incrCounter 1 lockIdCounter + pure (LockId newId) + +-- Only provide this orphan instance for linear-base <= 0.7.0 +-- The next release will come with this instance built-in: https://github.com/tweag/linear-base/pull/505 +#if !MIN_VERSION_linear_base(0,7,1) +instance L.MonadIO RIO where + liftIO action = RIOInternal.RIO (\_ -> action) +#endif + +---------------------------------------------------------------------------- +-- Utils +---------------------------------------------------------------------------- + +-- | Similar to 'System.IO.Resource.Linear.release', except it uses a different release action than the one registered by 'System.IO.Resource.Linear.unsafeAcquire'. +release' :: RIO.Resource a %1 -> L.IO () -> RIO () +release' (RIOInternal.UnsafeResource key _) release = RIOInternal.RIO (\st -> L.mask_ (releaseWith key st)) + where + releaseWith key rrm = L.do + Ur (RIOInternal.ReleaseMap releaseMap) <- L.readIORef rrm + () <- release + L.writeIORef rrm (RIOInternal.ReleaseMap (IntMap.delete key releaseMap)) + +-- | A wrapper type to force the contents to be fully evaluated before being put back into an MVar / IORef. +-- +-- NOTE: `NF` will only turn "shallow evaluation" into "deep evaluation". +-- You must still use a bang pattern on `NF` to force it. +newtype NF a = UnsafeNF {unNF :: a} + deriving newtype (Show, Eq) + +mkNF :: (NFData a) => a -> NF a +mkNF = UnsafeNF . force diff --git a/src/LinearLocks/Internal/LockSet.hs b/src/LinearLocks/Internal/LockSet.hs new file mode 100644 --- /dev/null +++ b/src/LinearLocks/Internal/LockSet.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_HADDOCK not-home #-} + +module LinearLocks.Internal.LockSet where + +import Control.Functor.Linear qualified as L +import Control.Monad.IO.Class.Linear qualified as L +import Control.Monad.ST (ST, runST) +import Data.Function (on) +import Data.Kind (Type) +import Data.Vector.Algorithms.Insertion qualified as Sort +import Data.Vector.Generic qualified as VG +import Data.Vector.Generic.Mutable qualified as VGM +import Data.Vector.Primitive qualified as VP +import Data.Vector.Unboxed qualified as VU +import Data.Vector.Unboxed.Mutable qualified as VUM +import GHC.TypeLits (Nat, type (+), type (<=)) +import LinearLocks.Internal +import System.IO.Resource.Linear (RIO) + +-- | The index of a lock in a lock set. +newtype LockSetIndex = LockSetIndex Int + deriving newtype (Enum) + +newtype instance VU.MVector s LockSetIndex = MV_LockSetIndex (VP.MVector s Int) + +newtype instance VU.Vector LockSetIndex = V_LockSetIndex (VP.Vector Int) + +deriving via (VU.UnboxViaPrim Int) instance VGM.MVector VU.MVector LockSetIndex + +deriving via (VU.UnboxViaPrim Int) instance VG.Vector VU.Vector LockSetIndex + +instance VU.Unbox LockSetIndex + +-- | A set of locks with the same level that can be acquired together with 'acquireMany'. +data LockSet set where + MkLockSet :: set -> VU.Vector LockSetIndex -> LockSet set + +-- | Creates a 'LockSet' from a set of locks. +-- All locks must have the same level. +-- +-- Locks in a 'LockSet' can be acquired simultaneously using 'acquireMany'. +-- +-- Fails if the set contains duplicate locks. +-- +-- >>> import LinearLocks.Mutex qualified as Mutex +-- >>> m1 <- Mutex.new 1 "a" +-- >>> m2 <- Mutex.new 1 "b" +-- >>> m3 <- Mutex.new 1 "c" +-- >>> set <- newLockSet (m1, m2, m3) +newLockSet :: forall m set. (IsLockSet set, MonadFail m) => set -> m (LockSet set) +newLockSet set = + if hasDups + then fail "LockSet: duplicate locks are not allowed" + else pure $ MkLockSet set sortedIndices + where + (hasDups, sortedIndices) = runST do + idsAndIndices <- VU.thaw $ VU.fromList $ collectIds set `zip` [LockSetIndex 0 ..] + + -- Sort by lock IDs + Sort.sortBy (compare `on` fst) idsAndIndices + + -- Check whether this set contains duplicate locks. + -- NOTE: the vector must already be sorted. + hasDups <- hasDuplicateIds idsAndIndices + + sortedIndices <- VU.map snd <$> VU.unsafeFreeze idsAndIndices + + pure (hasDups, sortedIndices) + + hasDuplicateIds :: VUM.MVector (VUM.PrimState (ST s)) (LockId, LockSetIndex) -> ST s Bool + hasDuplicateIds idsAndIndices = do + let go i = + if i >= VUM.length idsAndIndices - 1 + then pure False + else do + (id1, _) <- VUM.read idsAndIndices i + (id2, _) <- VUM.read idsAndIndices (i + 1) + if id1 == id2 + then pure True + else go (i + 1) + go 0 + +acquireMany :: + forall keyLvl lockLvl set. + (IsLockSet set, lockLvl ~ LockSetLevel set, keyLvl <= lockLvl) => + LockKey keyLvl %1 -> + LockSet set -> + RIO (LockSetGuard set, LockKey (lockLvl + 1)) +acquireMany UnsafeLockKey (MkLockSet set indices) = L.do + guards <- acquireInOrder indices set + L.pure (guards, UnsafeLockKey) + +class IsLockSet set where + type LockSetGuard set :: Type + type LockSetLevel set :: Nat + + collectIds :: set -> [LockId] + + -- | Acquires the locks in the set in the given order. + -- E.g. `acquireInOrder [1, 3, 2]` will acquire the first lock in the set, then the third, then the second. + -- + -- Invariants: + -- * The indices must refer to every lock in the set, without duplicates. + acquireInOrder :: VU.Vector LockSetIndex -> set -> RIO (LockSetGuard set) + +instance + ( Acquirable l1, + Acquirable l2, + Level l1 ~ Level l2 + ) => + IsLockSet (l1, l2) + where + type LockSetGuard (l1, l2) = (Guard l1, Guard l2) + type LockSetLevel (l1, l2) = Level l1 + + collectIds (l1, l2) = [getId l1, getId l2] + + acquireInOrder indices (l1, l2) = L.do + guards <- L.execStateT (forM_' indices acquireAt) (Nothing, Nothing) + case guards of + (Just g1, Just g2) -> L.pure (g1, g2) + guards -> releaseAndFail guards missingIndices + where + acquireAt :: LockSetIndex -> L.StateT (Maybe (Guard l1), Maybe (Guard l2)) RIO () + acquireAt (LockSetIndex index) = + case index of + 0 -> modifyM \case + (Nothing, g2) -> L.do + g1 <- unsafeAcquire l1 + L.pure (Just g1, g2) + guards -> releaseAndFail guards (dupIndex index) + 1 -> modifyM \case + (g1, Nothing) -> L.do + g2 <- unsafeAcquire l2 + L.pure (g1, Just g2) + guards -> releaseAndFail guards (dupIndex index) + _ -> L.lift (failRIO (invalidIndex index)) + + releaseAndFail :: (Maybe (Guard l1), Maybe (Guard l2)) %1 -> String -> RIO x + releaseAndFail (g1, g2) errMsg = L.do + releaseMb g1 + releaseMb g2 + failRIO errMsg + +instance + ( Acquirable l1, + Acquirable l2, + Acquirable l3, + Level l1 ~ Level l2, + Level l1 ~ Level l3 + ) => + IsLockSet (l1, l2, l3) + where + type LockSetGuard (l1, l2, l3) = (Guard l1, Guard l2, Guard l3) + type LockSetLevel (l1, l2, l3) = Level l1 + + collectIds (l1, l2, l3) = [getId l1, getId l2, getId l3] + + acquireInOrder indices (l1, l2, l3) = L.do + guards <- L.execStateT (forM_' indices acquireAt) (Nothing, Nothing, Nothing) + case guards of + (Just g1, Just g2, Just g3) -> L.pure (g1, g2, g3) + guards -> releaseAndFail guards missingIndices + where + acquireAt :: LockSetIndex -> L.StateT (Maybe (Guard l1), Maybe (Guard l2), Maybe (Guard l3)) RIO () + acquireAt (LockSetIndex index) = + case index of + 0 -> modifyM \case + (Nothing, g2, g3) -> L.do + g1 <- unsafeAcquire l1 + L.pure (Just g1, g2, g3) + guards -> L.do + releaseAndFail guards (dupIndex index) + 1 -> modifyM \case + (g1, Nothing, g3) -> L.do + g2 <- unsafeAcquire l2 + L.pure (g1, Just g2, g3) + guards -> L.do + releaseAndFail guards (dupIndex index) + 2 -> modifyM \case + (g1, g2, Nothing) -> L.do + g3 <- unsafeAcquire l3 + L.pure (g1, g2, Just g3) + guards -> L.do + releaseAndFail guards (dupIndex index) + _ -> L.lift (failRIO (invalidIndex index)) + + releaseAndFail :: (Maybe (Guard l1), Maybe (Guard l2), Maybe (Guard l3)) %1 -> String -> RIO x + releaseAndFail (g1, g2, g3) errMsg = L.do + releaseMb g1 + releaseMb g2 + releaseMb g3 + failRIO errMsg + +instance + ( Acquirable l1, + Acquirable l2, + Acquirable l3, + Acquirable l4, + Level l1 ~ Level l2, + Level l1 ~ Level l3, + Level l1 ~ Level l4 + ) => + IsLockSet (l1, l2, l3, l4) + where + type LockSetGuard (l1, l2, l3, l4) = (Guard l1, Guard l2, Guard l3, Guard l4) + type LockSetLevel (l1, l2, l3, l4) = Level l1 + + collectIds (l1, l2, l3, l4) = [getId l1, getId l2, getId l3, getId l4] + + acquireInOrder indices (l1, l2, l3, l4) = L.do + guards <- L.execStateT (forM_' indices acquireAt) (Nothing, Nothing, Nothing, Nothing) + case guards of + (Just g1, Just g2, Just g3, Just g4) -> L.pure (g1, g2, g3, g4) + guards -> releaseAndFail guards missingIndices + where + acquireAt :: LockSetIndex -> L.StateT (Maybe (Guard l1), Maybe (Guard l2), Maybe (Guard l3), Maybe (Guard l4)) RIO () + acquireAt (LockSetIndex index) = + case index of + 0 -> modifyM \case + (Nothing, g2, g3, g4) -> L.do + g1 <- unsafeAcquire l1 + L.pure (Just g1, g2, g3, g4) + guards -> L.do + releaseAndFail guards (dupIndex index) + 1 -> modifyM \case + (g1, Nothing, g3, g4) -> L.do + g2 <- unsafeAcquire l2 + L.pure (g1, Just g2, g3, g4) + guards -> L.do + releaseAndFail guards (dupIndex index) + 2 -> modifyM \case + (g1, g2, Nothing, g4) -> L.do + g3 <- unsafeAcquire l3 + L.pure (g1, g2, Just g3, g4) + guards -> L.do + releaseAndFail guards (dupIndex index) + 3 -> modifyM \case + (g1, g2, g3, Nothing) -> L.do + g4 <- unsafeAcquire l4 + L.pure (g1, g2, g3, Just g4) + guards -> L.do + releaseAndFail guards (dupIndex index) + _ -> L.lift (failRIO (invalidIndex index)) + + releaseAndFail :: (Maybe (Guard l1), Maybe (Guard l2), Maybe (Guard l3), Maybe (Guard l4)) %1 -> String -> RIO x + releaseAndFail (g1, g2, g3, g4) errMsg = L.do + releaseMb g1 + releaseMb g2 + releaseMb g3 + releaseMb g4 + failRIO errMsg + +instance + ( Acquirable l1, + Acquirable l2, + Acquirable l3, + Acquirable l4, + Acquirable l5, + Level l1 ~ Level l2, + Level l1 ~ Level l3, + Level l1 ~ Level l4, + Level l1 ~ Level l5 + ) => + IsLockSet (l1, l2, l3, l4, l5) + where + type LockSetGuard (l1, l2, l3, l4, l5) = (Guard l1, Guard l2, Guard l3, Guard l4, Guard l5) + type LockSetLevel (l1, l2, l3, l4, l5) = Level l1 + + collectIds (l1, l2, l3, l4, l5) = [getId l1, getId l2, getId l3, getId l4, getId l5] + + acquireInOrder indices (l1, l2, l3, l4, l5) = L.do + guards <- L.execStateT (forM_' indices acquireAt) (Nothing, Nothing, Nothing, Nothing, Nothing) + case guards of + (Just g1, Just g2, Just g3, Just g4, Just g5) -> L.pure (g1, g2, g3, g4, g5) + guards -> releaseAndFail guards missingIndices + where + acquireAt :: LockSetIndex -> L.StateT (Maybe (Guard l1), Maybe (Guard l2), Maybe (Guard l3), Maybe (Guard l4), Maybe (Guard l5)) RIO () + acquireAt (LockSetIndex index) = + case index of + 0 -> modifyM \case + (Nothing, g2, g3, g4, g5) -> L.do + g1 <- unsafeAcquire l1 + L.pure (Just g1, g2, g3, g4, g5) + guards -> L.do + releaseAndFail guards (dupIndex index) + 1 -> modifyM \case + (g1, Nothing, g3, g4, g5) -> L.do + g2 <- unsafeAcquire l2 + L.pure (g1, Just g2, g3, g4, g5) + guards -> L.do + releaseAndFail guards (dupIndex index) + 2 -> modifyM \case + (g1, g2, Nothing, g4, g5) -> L.do + g3 <- unsafeAcquire l3 + L.pure (g1, g2, Just g3, g4, g5) + guards -> L.do + releaseAndFail guards (dupIndex index) + 3 -> modifyM \case + (g1, g2, g3, Nothing, g5) -> L.do + g4 <- unsafeAcquire l4 + L.pure (g1, g2, g3, Just g4, g5) + guards -> L.do + releaseAndFail guards (dupIndex index) + 4 -> modifyM \case + (g1, g2, g3, g4, Nothing) -> L.do + g5 <- unsafeAcquire l5 + L.pure (g1, g2, g3, g4, Just g5) + guards -> L.do + releaseAndFail guards (dupIndex index) + _ -> L.lift (failRIO (invalidIndex index)) + + releaseAndFail :: (Maybe (Guard l1), Maybe (Guard l2), Maybe (Guard l3), Maybe (Guard l4), Maybe (Guard l5)) %1 -> String -> RIO x + releaseAndFail (g1, g2, g3, g4, g5) errMsg = L.do + releaseMb g1 + releaseMb g2 + releaseMb g3 + releaseMb g4 + releaseMb g5 + failRIO errMsg + +---------------------------------------------------------------------------- +-- Utils +---------------------------------------------------------------------------- + +missingIndices :: String +missingIndices = "LockSet: missing indices" + +dupIndex :: Int -> String +dupIndex index = "LockSet: duplicate index: " <> show index + +invalidIndex :: Int -> String +invalidIndex index = "LockSet: invalid index: " <> show index + +releaseMb :: (Releasable g) => Maybe g %1 -> RIO () +releaseMb = \case + Nothing -> L.pure () + Just guard -> doRelease guard + +failRIO :: String -> RIO a +failRIO msg = L.do + L.liftSystemIO (fail msg) + +modifyM :: forall m s. (L.Functor m) => (s %1 -> m s) %1 -> L.StateT s m () +modifyM f = + L.StateT \s -> L.do + f s L.<&> \s' -> ((), s') + +-- | A version of 'Data.Vector.Unboxed.forM_' that runs in a linear monad. +forM_' :: (VU.Unbox a, L.Monad m) => VU.Vector a -> (a -> m ()) -> m () +forM_' vec action = go 0 + where + go i + | i >= VU.length vec = L.pure () + | otherwise = L.do + action (vec VU.! i) + go (i + 1) diff --git a/src/LinearLocks/Internal/Mutex.hs b/src/LinearLocks/Internal/Mutex.hs new file mode 100644 --- /dev/null +++ b/src/LinearLocks/Internal/Mutex.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RequiredTypeArguments #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_HADDOCK not-home #-} + +module LinearLocks.Internal.Mutex where + +import Control.Concurrent (MVar) +import Control.Concurrent qualified as MVar +import Control.Functor.Linear qualified as L +import GHC.TypeLits (Nat) +import LinearLocks.Internal +import Prelude.Linear (Ur (..)) +import Prelude.Linear qualified as L hiding (IO) +import System.IO.Linear qualified as L +import System.IO.Resource.Linear (RIO) +import System.IO.Resource.Linear qualified as RIO +import System.IO.Resource.Linear.Internal qualified as Internal + +-- | A deadlock-free mutex. +-- +-- This implementation is lazy. +-- This means that if you place an expensive unevaluated thunk inside a t`Mutex`, +-- it will be evaluated by the thread that consumes it, not the thread that produced it. +-- To avoid this, use "LinearLocks.Mutex.Strict" instead. +data Mutex (lvl :: Nat) a = Mutex + { var :: MVar a, + -- | The unique ID for this mutex. It's used to ensure t'LinearLocks.LockSet's don't contain duplicate mutexes, see 'LinearLocks.newLockSet'. + id :: LockId + } + +-- | A t`MutexGuard` represents the ownership of a mutex. +-- +-- It can be used to read/write the mutex while the lock is held. +-- +-- It must be released with `release`, after which the guard will be consumed and can no longer be used. +data MutexGuard a = MutexGuard + { resource :: RIO.Resource (MutexResource a), + -- | The latest value set by the user. + -- This will be comitted to the MVar when the guard is released. + newValue :: Ur a + } + +data MutexResource a = MutexResource + { -- | The value that was read from the `MVar` when it was acquired. + -- + -- If an exception occurs before the mutex guard is manually released, this value will be put back into the `MVar`. + initialValue :: a, + var :: MVar a + } + +instance Acquirable (Mutex lvl a) where + type Guard (Mutex lvl a) = MutexGuard a + type Level (Mutex lvl a) = lvl + + getId m = m.id + + unsafeAcquire :: forall lvl a. Mutex lvl a -> RIO (MutexGuard a) + unsafeAcquire m = L.do + -- Note: we have to match on `UnsafeResource` so we can extract the `guard.initialValue` + Internal.UnsafeResource key guard <- RIO.unsafeAcquire acq rel + L.pure + MutexGuard + { resource = Internal.UnsafeResource key guard, + newValue = Ur guard.initialValue + } + where + acq :: L.IO (Ur (MutexResource a)) + acq = L.do + Ur a <- L.fromSystemIOU L.$ MVar.takeMVar m.var + L.pure (Ur (MutexResource {initialValue = a, var = m.var})) + + -- The action to run if an exception is thrown before the guard is manually released with `release`. + rel :: MutexResource a -> L.IO () + rel (MutexResource initialValue var) = + L.void L.$ L.fromSystemIO L.$ MVar.putMVar var initialValue + +instance Releasable (MutexGuard a) where + doRelease = release + +read :: MutexGuard a %1 -> RIO (Ur a, MutexGuard a) +read (MutexGuard resource (Ur newValue)) = + L.pure (Ur newValue, MutexGuard {resource, newValue = Ur newValue}) + +-- | Writes a new value to the mutex, which will be committed when the guard is released. +-- +-- If an exception is thrown after `write` but before `release`, +-- the mutex will be rolled back to its original state. +write :: MutexGuard a %1 -> a -> RIO (MutexGuard a) +write (MutexGuard resource (Ur _)) newValue = + L.pure (MutexGuard {resource, newValue = Ur newValue}) + +-- | Releases the mutex and commits the latest value set by `write`. +release :: MutexGuard a %1 -> RIO () +release (MutexGuard ((Internal.UnsafeResource key mr)) (Ur newValue)) = L.do + -- Note: the resource was initially registered with a release action that puts the original value back into the MVar. + -- That release action should be run if an exception is thrown before `release` is called, + -- which ensures the MVar will "rollback" to its original state. + -- + -- However, if `release` is called explicitly by the user, + -- we want to update the release action to put `newValue` back into the MVar instead. + -- Therefore, we must call `release'` with a _new release action_ that puts `newValue` into the MVar. + release' (Internal.UnsafeResource key mr) L.do + L.void L.$ L.fromSystemIO L.$ MVar.putMVar mr.var newValue + +-- | Creates a new mutex with the given initial value. +-- +-- The @lvl@ parameter determines the order in which this mutex can be acquired relative to other mutexes. +-- +-- It does not have to be unique, multiple mutexes can have the same level. +-- Mutexes with the same level can be added to a t`LinearLocks.LockSet` and acquired with 'LinearLocks.acquireMany'. +new :: forall a. forall (lvl :: Nat) -> a -> IO (Mutex lvl a) +new _lvl a = do + var <- MVar.newMVar a + id <- nextLockId + pure Mutex {var, id} diff --git a/src/LinearLocks/Internal/RWLock.hs b/src/LinearLocks/Internal/RWLock.hs new file mode 100644 --- /dev/null +++ b/src/LinearLocks/Internal/RWLock.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RequiredTypeArguments #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_HADDOCK not-home #-} + +module LinearLocks.Internal.RWLock where + +import Control.Concurrent.ReadWriteLock qualified as Conc +import Control.Functor.Linear qualified as L +import Control.Monad.IO.Class.Linear qualified as L +import Data.IORef (IORef) +import Data.IORef qualified as IORef +import Data.Kind (Type) +import GHC.TypeLits (Nat, type (+), type (<=)) +import LinearLocks.Internal +import Prelude.Linear (Ur (..)) +import Prelude.Linear qualified as L hiding (IO) +import System.IO.Linear qualified as L +import System.IO.Resource.Linear (RIO) +import System.IO.Resource.Linear qualified as RIO + +-- $setup +-- >>> data Config = Config { verbose :: Bool } + +{- ORMOLU_DISABLE -} +{- | A deadlock-free lock that allows multiple concurrent readers or a single writer. + +>>> import LinearLocks +>>> import LinearLocks.RWLock qualified as RWLock +>>> import Prelude.Linear (Ur (..)) +>>> import Control.Functor.Linear qualified as Linear + +>>> :{ +example :: IO () +example = do + configLock <- RWLock.new 0 Config { verbose = True } + -- + -- Enter a lockscope + lockScope \key -> Linear.do + -- Acquire the lock in "write mode" + (guard, key) <- RWLock.acquireWrite key configLock + -- + -- Read/write + (Ur config, guard) <- RWLock.read guard + guard <- RWLock.write guard config { verbose = False } + -- + -- Release lock + RWLock.releaseWrite guard + dropKeyAndReturn key () +:} +-} +{- ORMOLU_ENABLE -} +data RWLock (lvl :: Nat) a = RWLock + { var :: IORef a, + -- | A read-write lock gating access to the `IORef`. + lock :: Conc.RWLock, + -- | The unique ID for this lock. It's used to ensure t'LinearLocks.LockSet's don't contain duplicate locks, see 'LinearLocks.newLockSet'. + id :: LockId + } + +-- | Creates a new read-write lock with the given initial value. +-- +-- The @lvl@ parameter determines the order in which this lock can be acquired relative to other locks. +-- +-- It does not have to be unique, multiple locks can have the same level. +-- Locks with the same level can be added to a t`LinearLocks.LockSet` and acquired with 'LinearLocks.acquireMany'. +new :: forall a. forall (lvl :: Nat) -> a -> IO (RWLock lvl a) +new _lvl a = do + lock <- Conc.new + var <- IORef.newIORef a + id <- nextLockId + pure RWLock {var, lock, id} + +class Readable guard where + type Elem guard :: Type + read :: guard %1 -> RIO (Ur (Elem guard), guard) + +---------------------------------------------------------------------------- +-- Read mode +---------------------------------------------------------------------------- + +-- | Acquires the t'RWLock' in "read mode". Consumes the key and return a new key (with an increased level). +acquireRead :: + forall a keyLvl lockLvl. + (keyLvl <= lockLvl) => + LockKey keyLvl %1 -> + RWLock lockLvl a -> + RIO (ReadGuard a, LockKey (lockLvl + 1)) +acquireRead key m = acquire key (AsRead m) + +-- | A t`ReadGuard` represents the ownership of a RWLock in read mode. +-- +-- It must be released with `releaseRead`, after which the guard will be consumed and can no longer be used. +data ReadGuard a = ReadGuard + { resource :: RIO.Resource Resource, + -- | The value that was read when the lock was acquired. + readValue :: Ur a + } + +newtype Resource = Resource + { lock :: Conc.RWLock + } + +-- | Newtype used to add t'RWLock's to t'LinearLocks.LockSet's. +newtype AsRead lvl a = AsRead (RWLock lvl a) + +instance Acquirable (AsRead lvl a) where + type Guard (AsRead lvl a) = ReadGuard a + type Level (AsRead lvl a) = lvl + + getId (AsRead m) = m.id + + unsafeAcquire :: forall lvl a. AsRead lvl a -> RIO (ReadGuard a) + unsafeAcquire (AsRead m) = L.do + -- Acquire the rwlock in "read mode" and *then* read the `IORef`. + resource <- RIO.unsafeAcquire acq rel + Ur readValue <- L.liftSystemIOU (IORef.readIORef m.var) + L.pure + ReadGuard + { resource = resource, + readValue = Ur readValue + } + where + acq :: L.IO (Ur Resource) + acq = L.do + L.fromSystemIO L.$ Conc.acquireRead m.lock + L.pure (Ur (Resource {lock = m.lock})) + + rel :: Resource -> L.IO () + rel (Resource lock) = + L.fromSystemIO L.$ Conc.releaseRead lock + +-- | Releases the lock. +releaseRead :: ReadGuard a %1 -> RIO () +releaseRead (ReadGuard resource (Ur _readValue)) = + RIO.release resource + +instance Releasable (ReadGuard a) where + doRelease = releaseRead + +instance Readable (ReadGuard a) where + type Elem (ReadGuard a) = a + + read :: ReadGuard a %1 -> RIO (Ur a, ReadGuard a) + read (ReadGuard resource (Ur readValue)) = + L.pure (Ur readValue, ReadGuard {resource, readValue = Ur readValue}) + +---------------------------------------------------------------------------- +-- Write mode +---------------------------------------------------------------------------- + +-- | Acquires the t'RWLock' in "write mode". Consumes the key and return a new key (with an increased level). +acquireWrite :: + forall a keyLvl lockLvl. + (keyLvl <= lockLvl) => + LockKey keyLvl %1 -> + RWLock lockLvl a -> + RIO (WriteGuard a, LockKey (lockLvl + 1)) +acquireWrite key m = acquire key (AsWrite m) + +-- | A t`WriteGuard` represents the ownership of a RWLock in write mode. +-- +-- It must be released with `releaseWrite`, after which the guard will be consumed and can no longer be used. +data WriteGuard a = WriteGuard + { resource :: RIO.Resource Resource, + -- | The latest value set by the user. + -- This will be comitted when the guard is released. + newValue :: Ur a, + var :: Ur (IORef a) + } + +-- | Newtype used to add t'RWLock's to t'LinearLocks.LockSet's. +newtype AsWrite lvl a = AsWrite (RWLock lvl a) + +instance Acquirable (AsWrite lvl a) where + type Guard (AsWrite lvl a) = WriteGuard a + type Level (AsWrite lvl a) = lvl + + getId (AsWrite m) = m.id + + unsafeAcquire :: forall lvl a. AsWrite lvl a -> RIO (WriteGuard a) + unsafeAcquire (AsWrite m) = L.do + -- Acquire the rwlock in "write mode" and *then* read the `IORef`. + resource <- RIO.unsafeAcquire acq rel + Ur initialValue <- L.liftSystemIOU (IORef.readIORef m.var) + L.pure + WriteGuard + { resource = resource, + newValue = Ur initialValue, + var = Ur m.var + } + where + acq :: L.IO (Ur Resource) + acq = L.do + L.fromSystemIO L.$ Conc.acquireWrite m.lock + L.pure (Ur (Resource {lock = m.lock})) + + rel :: Resource -> L.IO () + rel (Resource lock) = + L.fromSystemIO L.$ Conc.releaseWrite lock + +-- | Releases the lock and commits the latest value set by `write`. +releaseWrite :: WriteGuard a %1 -> RIO () +releaseWrite (WriteGuard resource (Ur newValue) (Ur var)) = L.do + L.liftSystemIO $ IORef.writeIORef var newValue + RIO.release resource + +instance Releasable (WriteGuard a) where + doRelease = releaseWrite + +instance Readable (WriteGuard a) where + type Elem (WriteGuard a) = a + + read :: WriteGuard a %1 -> RIO (Ur a, WriteGuard a) + read (WriteGuard resource (Ur newValue) var) = + L.pure (Ur newValue, WriteGuard {resource, newValue = Ur newValue, var}) + +-- | Writes a new value to the t'RWLock', which will be committed when the guard is released. +-- +-- If an exception is thrown after `write` but before `releaseWrite`, +-- the t'RWLock' will be rolled back to its original state. +write :: WriteGuard a %1 -> a -> RIO (WriteGuard a) +write (WriteGuard resource (Ur _) var) newValue = + L.pure (WriteGuard {resource, newValue = Ur newValue, var}) diff --git a/src/LinearLocks/Internal/StrictMutex.hs b/src/LinearLocks/Internal/StrictMutex.hs new file mode 100644 --- /dev/null +++ b/src/LinearLocks/Internal/StrictMutex.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RequiredTypeArguments #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_HADDOCK not-home #-} + +module LinearLocks.Internal.StrictMutex where + +import Control.Concurrent (MVar) +import Control.Concurrent qualified as MVar +import Control.DeepSeq (NFData) +import Control.Functor.Linear qualified as L +import GHC.TypeLits (Nat) +import LinearLocks.Internal +import Prelude.Linear (Ur (..)) +import Prelude.Linear qualified as L hiding (IO) +import System.IO.Linear qualified as L +import System.IO.Resource.Linear (RIO) +import System.IO.Resource.Linear qualified as RIO +import System.IO.Resource.Linear.Internal qualified as Internal + +-- | A strict version of "LinearLocks.Mutex". +data Mutex (lvl :: Nat) a = Mutex + { -- NOTE: we're using `MVar (NF a)` instead of e.g. `Control.Concurrent.MVar.Strict.MVar` (from the `strict-concurrency` package) + -- because we don't want to require `NFData` when taking the mvar's (already evaluated) value and putting it right back in, unmodified. + -- + -- In other words, this allows `lock` to not require `NFData` to setup the "release on exception" action. + var :: MVar (NF a), + -- | The unique ID for this mutex. It's used to ensure t'LinearLocks.LockSet's don't contain duplicate mutexes, see 'LinearLocks.newLockSet'. + id :: LockId + } + +-- | A t`MutexGuard` represents the ownership of a mutex. +-- +-- It can be used to read/write the mutex while the lock is held. +-- +-- It must be released with `release`, after which the guard will be consumed and can no longer be used. +data MutexGuard a = MutexGuard + { resource :: RIO.Resource (MutexResource a), + -- | The latest value set by the user. + -- This will be comitted to the MVar when the guard is released. + newValue :: Ur a + } + +data MutexResource a = MutexResource + { -- | The value that was read from the `MVar` when it was acquired. + -- + -- If an exception occurs before the mutex guard is manually released, this value will be put back into the `MVar`. + initialValue :: (NF a), + var :: MVar (NF a) + } + +instance (NFData a) => Acquirable (Mutex lvl a) where + type Guard (Mutex lvl a) = MutexGuard a + type Level (Mutex lvl a) = lvl + + getId m = m.id + + unsafeAcquire :: forall lvl a. Mutex lvl a -> RIO (MutexGuard a) + unsafeAcquire m = L.do + -- Note: we have to match on `UnsafeResource` so we can extract the `guard.initialValue` + Internal.UnsafeResource key guard <- RIO.unsafeAcquire acq rel + L.pure + MutexGuard + { resource = Internal.UnsafeResource key guard, + newValue = Ur guard.initialValue.unNF + } + where + acq :: L.IO (Ur (MutexResource a)) + acq = L.do + Ur a <- L.fromSystemIOU L.$ MVar.takeMVar m.var + L.pure (Ur (MutexResource {initialValue = a, var = m.var})) + + -- The action to run if an exception is thrown before the guard is manually released with `release`. + rel :: MutexResource a -> L.IO () + rel (MutexResource initialValue var) = + L.void L.$ L.fromSystemIO L.$ MVar.putMVar var initialValue + +instance (NFData a) => Releasable (MutexGuard a) where + doRelease = release + +read :: MutexGuard a %1 -> RIO (Ur a, MutexGuard a) +read (MutexGuard resource (Ur newValue)) = + L.pure (Ur newValue, MutexGuard {resource, newValue = Ur newValue}) + +-- | Writes a new value to the mutex, which will be committed when the guard is released. +-- +-- If an exception is thrown after `write` but before `release`, +-- the mutex will be rolled back to its original state. +-- +-- Note: The value will only be evaluated to Normal Form when the mutex is released, not when it's written. +write :: MutexGuard a %1 -> a -> RIO (MutexGuard a) +write (MutexGuard resource (Ur _)) newValue = + L.pure (MutexGuard {resource, newValue = Ur newValue}) + +-- | Releases the mutex and commits the latest value set by `write`. +-- +-- Fully evaluates the value to Normal Form before releasing the mutex. +release :: (NFData a) => MutexGuard a %1 -> RIO () +release (MutexGuard ((Internal.UnsafeResource key mr)) (Ur (mkNF -> !newValue))) = L.do + -- Note: the resource was initially registered with a release action that puts the original value back into the MVar. + -- That release action should be run if an exception is thrown before `release` is called, + -- which ensures the MVar will "rollback" to its original state. + -- + -- However, if `release` is called explicitly by the user, + -- we want to update the release action to put `newValue` back into the MVar instead. + -- Therefore, we must call `release'` with a _new release action_ that puts `newValue` into the MVar. + release' (Internal.UnsafeResource key mr) L.do + L.void L.$ L.fromSystemIO L.$ MVar.putMVar mr.var newValue + +-- | Creates a new mutex with the given initial value. +-- +-- The @lvl@ parameter determines the order in which this mutex can be acquired relative to other mutexes. +-- +-- It does not have to be unique, multiple mutexes can have the same level. +-- Mutexes with the same level can be added to a t`LinearLocks.LockSet` and acquired with 'LinearLocks.acquireMany'. +-- +-- This function fully evaluates the initial value to Normal Form. +new :: forall a. (NFData a) => forall (lvl :: Nat) -> a -> IO (Mutex lvl a) +new _lvl (mkNF -> !a) = do + var <- MVar.newMVar a + id <- nextLockId + pure Mutex {var, id} diff --git a/src/LinearLocks/Internal/StrictRWLock.hs b/src/LinearLocks/Internal/StrictRWLock.hs new file mode 100644 --- /dev/null +++ b/src/LinearLocks/Internal/StrictRWLock.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RequiredTypeArguments #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_HADDOCK not-home #-} + +module LinearLocks.Internal.StrictRWLock where + +import Control.Concurrent.ReadWriteLock qualified as Conc +import Control.DeepSeq (NFData) +import Control.Functor.Linear qualified as L +import Control.Monad.IO.Class.Linear qualified as L +import Data.IORef (IORef) +import Data.IORef qualified as IORef +import Data.Kind (Type) +import GHC.TypeLits (Nat, type (+), type (<=)) +import LinearLocks.Internal +import Prelude.Linear (Ur (..)) +import Prelude.Linear qualified as L hiding (IO) +import System.IO.Linear qualified as L +import System.IO.Resource.Linear (RIO) +import System.IO.Resource.Linear qualified as RIO + +-- $setup +-- >>> newtype Config = Config { verbose :: Bool } deriving newtype NFData + +{- ORMOLU_DISABLE -} +{- | A strict version of "LinearLocks.RWLock". + +>>> import LinearLocks +>>> import LinearLocks.RWLock.Strict qualified as RWLock +>>> import Prelude.Linear (Ur (..)) +>>> import Control.Functor.Linear qualified as Linear + +>>> :{ +example :: IO () +example = do + configLock <- RWLock.new 0 Config { verbose = True } + -- + -- Enter a lockscope + lockScope \key -> Linear.do + -- Acquire the lock in "write mode" + (guard, key) <- RWLock.acquireWrite key configLock + -- + -- Read/write + (Ur config, guard) <- RWLock.read guard + guard <- RWLock.write guard config { verbose = False } + -- + -- Release lock + RWLock.releaseWrite guard + dropKeyAndReturn key () +:} +-} +{- ORMOLU_ENABLE -} +data RWLock (lvl :: Nat) a = RWLock + { var :: IORef (NF a), + -- | A read-write lock gating access to the `IORef`. + lock :: Conc.RWLock, + -- | The unique ID for this lock. It's used to ensure t'LinearLocks.LockSet's don't contain duplicate locks, see 'LinearLocks.newLockSet'. + id :: LockId + } + +-- | Creates a new read-write lock with the given initial value. +-- +-- The @lvl@ parameter determines the order in which this lock can be acquired relative to other locks. +-- +-- It does not have to be unique, multiple locks can have the same level. +-- Locks with the same level can be added to a t`LinearLocks.LockSet` and acquired with 'LinearLocks.acquireMany'. +-- +-- This function fully evaluates the initial value to Normal Form. +new :: forall a. (NFData a) => forall (lvl :: Nat) -> a -> IO (RWLock lvl a) +new _lvl (mkNF -> !a) = do + lock <- Conc.new + var <- IORef.newIORef a + id <- nextLockId + pure RWLock {var, lock, id} + +class Readable guard where + type Elem guard :: Type + read :: guard %1 -> RIO (Ur (Elem guard), guard) + +---------------------------------------------------------------------------- +-- Read mode +---------------------------------------------------------------------------- + +-- | Acquires the t'RWLock' in "read mode". Consumes the key and return a new key (with an increased level). +acquireRead :: + forall a keyLvl lockLvl. + (keyLvl <= lockLvl) => + LockKey keyLvl %1 -> + RWLock lockLvl a -> + RIO (ReadGuard a, LockKey (lockLvl + 1)) +acquireRead key m = acquire key (AsRead m) + +-- | A t`ReadGuard` represents the ownership of a RWLock in read mode. +-- +-- It must be released with `releaseRead`, after which the guard will be consumed and can no longer be used. +data ReadGuard a = ReadGuard + { resource :: RIO.Resource Resource, + -- | The value that was read when the lock was acquired. + readValue :: Ur a + } + +newtype Resource = Resource + { lock :: Conc.RWLock + } + +-- | Newtype used to add t'RWLock's to t'LinearLocks.LockSet's. +newtype AsRead lvl a = AsRead (RWLock lvl a) + +instance Acquirable (AsRead lvl a) where + type Guard (AsRead lvl a) = ReadGuard a + type Level (AsRead lvl a) = lvl + + getId (AsRead m) = m.id + + unsafeAcquire :: forall lvl a. AsRead lvl a -> RIO (ReadGuard a) + unsafeAcquire (AsRead m) = L.do + -- Acquire the rwlock in "read mode" and *then* read the `IORef`. + resource <- RIO.unsafeAcquire acq rel + Ur readValue <- L.liftSystemIOU (IORef.readIORef m.var) + L.pure + ReadGuard + { resource = resource, + readValue = Ur readValue.unNF + } + where + acq :: L.IO (Ur Resource) + acq = L.do + L.fromSystemIO L.$ Conc.acquireRead m.lock + L.pure (Ur (Resource {lock = m.lock})) + + rel :: Resource -> L.IO () + rel (Resource lock) = + L.fromSystemIO L.$ Conc.releaseRead lock + +-- | Releases the lock. +releaseRead :: ReadGuard a %1 -> RIO () +releaseRead (ReadGuard resource (Ur _readValue)) = + RIO.release resource + +instance Releasable (ReadGuard a) where + doRelease = releaseRead + +instance Readable (ReadGuard a) where + type Elem (ReadGuard a) = a + + read :: ReadGuard a %1 -> RIO (Ur a, ReadGuard a) + read (ReadGuard resource (Ur readValue)) = + L.pure (Ur readValue, ReadGuard {resource, readValue = Ur readValue}) + +---------------------------------------------------------------------------- +-- Write mode +---------------------------------------------------------------------------- + +-- | Acquires the t'RWLock' in "write mode". Consumes the key and return a new key (with an increased level). +acquireWrite :: + forall a keyLvl lockLvl. + (keyLvl <= lockLvl) => + (NFData a) => + LockKey keyLvl %1 -> + RWLock lockLvl a -> + RIO (WriteGuard a, LockKey (lockLvl + 1)) +acquireWrite key m = acquire key (AsWrite m) + +-- | A t`WriteGuard` represents the ownership of a RWLock in write mode. +-- +-- It must be released with `releaseWrite`, after which the guard will be consumed and can no longer be used. +data WriteGuard a = WriteGuard + { resource :: RIO.Resource Resource, + -- | The latest value set by the user. + -- This will be comitted when the guard is released. + newValue :: Ur a, + var :: Ur (IORef (NF a)) + } + +-- | Newtype used to add t'RWLock's to t'LinearLocks.LockSet's. +newtype AsWrite lvl a = AsWrite (RWLock lvl a) + +instance (NFData a) => Acquirable (AsWrite lvl a) where + type Guard (AsWrite lvl a) = WriteGuard a + type Level (AsWrite lvl a) = lvl + + getId (AsWrite m) = m.id + + unsafeAcquire :: forall lvl a. AsWrite lvl a -> RIO (WriteGuard a) + unsafeAcquire (AsWrite m) = L.do + -- Acquire the rwlock in "write mode" and *then* read the `IORef`. + resource <- RIO.unsafeAcquire acq rel + Ur initialValue <- L.liftSystemIOU (IORef.readIORef m.var) + L.pure + WriteGuard + { resource = resource, + newValue = Ur initialValue.unNF, + var = Ur m.var + } + where + acq :: L.IO (Ur Resource) + acq = L.do + L.fromSystemIO L.$ Conc.acquireWrite m.lock + L.pure (Ur (Resource {lock = m.lock})) + + rel :: Resource -> L.IO () + rel (Resource lock) = + L.fromSystemIO L.$ Conc.releaseWrite lock + +-- | Releases the lock and commits the latest value set by `write`. +-- +-- Fully evaluates the value to Normal Form before releasing the lock. +releaseWrite :: (NFData a) => WriteGuard a %1 -> RIO () +releaseWrite (WriteGuard resource (Ur (mkNF -> !newValue)) (Ur var)) = L.do + L.liftSystemIO $ IORef.writeIORef var newValue + RIO.release resource + +instance (NFData a) => Releasable (WriteGuard a) where + doRelease = releaseWrite + +instance Readable (WriteGuard a) where + type Elem (WriteGuard a) = a + + read :: WriteGuard a %1 -> RIO (Ur a, WriteGuard a) + read (WriteGuard resource (Ur newValue) var) = + L.pure (Ur newValue, WriteGuard {resource, newValue = Ur newValue, var}) + +-- | Writes a new value to the t'RWLock', which will be committed when the guard is released. +-- +-- If an exception is thrown after `write` but before `releaseWrite`, +-- the t'RWLock' will be rolled back to its original state. +-- +-- Note: The value will only be evaluated to Normal Form when the mutex is released, not when it's written. +write :: WriteGuard a %1 -> a -> RIO (WriteGuard a) +write (WriteGuard resource (Ur _) var) newValue = + L.pure (WriteGuard {resource, newValue = Ur newValue, var}) diff --git a/src/LinearLocks/Mutex.hs b/src/LinearLocks/Mutex.hs new file mode 100644 --- /dev/null +++ b/src/LinearLocks/Mutex.hs @@ -0,0 +1,16 @@ +module LinearLocks.Mutex + ( -- * Mutex + Mutex, + new, + acquire, + + -- * Mutex guards + MutexGuard, + Mutex.read, + write, + release, + ) +where + +import LinearLocks.Internal (acquire) +import LinearLocks.Internal.Mutex as Mutex diff --git a/src/LinearLocks/Mutex/Strict.hs b/src/LinearLocks/Mutex/Strict.hs new file mode 100644 --- /dev/null +++ b/src/LinearLocks/Mutex/Strict.hs @@ -0,0 +1,16 @@ +module LinearLocks.Mutex.Strict + ( -- * Mutex + Mutex, + new, + acquire, + + -- * Mutex guards + MutexGuard, + StrictMutex.read, + write, + release, + ) +where + +import LinearLocks.Internal (acquire) +import LinearLocks.Internal.StrictMutex as StrictMutex diff --git a/src/LinearLocks/RWLock.hs b/src/LinearLocks/RWLock.hs new file mode 100644 --- /dev/null +++ b/src/LinearLocks/RWLock.hs @@ -0,0 +1,32 @@ +module LinearLocks.RWLock + ( -- * RWLock + RWLock, + new, + acquireRead, + acquireWrite, + + -- * Read mode + ReadGuard, + RWLock.read, + releaseRead, + + -- * Write mode + WriteGuard, + write, + releaseWrite, + + -- * Lock sets + + -- | The t'AsRead' and t'AsWrite' newtypes can be used to add t'RWLock's to t'LinearLocks.LockSet's. + -- + -- >>> import LinearLocks + -- >>> import LinearLocks.RWLock qualified as RWLock + -- >>> rw1 <- RWLock.new 0 "hello" + -- >>> rw2 <- RWLock.new 0 "world" + -- >>> set <- newLockSet (RWLock.AsRead rw1, RWLock.AsWrite rw2) + AsRead (..), + AsWrite (..), + ) +where + +import LinearLocks.Internal.RWLock as RWLock diff --git a/src/LinearLocks/RWLock/Strict.hs b/src/LinearLocks/RWLock/Strict.hs new file mode 100644 --- /dev/null +++ b/src/LinearLocks/RWLock/Strict.hs @@ -0,0 +1,32 @@ +module LinearLocks.RWLock.Strict + ( -- * RWLock + RWLock, + new, + acquireRead, + acquireWrite, + + -- * Read mode + ReadGuard, + RWLock.read, + releaseRead, + + -- * Write mode + WriteGuard, + write, + releaseWrite, + + -- * Lock sets + + -- | The t'AsRead' and t'AsWrite' newtypes can be used to add t'RWLock's to t'LinearLocks.LockSet's. + -- + -- >>> import LinearLocks + -- >>> import LinearLocks.RWLock.Strict qualified as RWLock + -- >>> rw1 <- RWLock.new 0 "hello" + -- >>> rw2 <- RWLock.new 0 "world" + -- >>> set <- newLockSet (RWLock.AsRead rw1, RWLock.AsWrite rw2) + AsRead (..), + AsWrite (..), + ) +where + +import LinearLocks.Internal.StrictRWLock as RWLock diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/test/Test/LinearLocks/LockSetSpec.hs b/test/Test/LinearLocks/LockSetSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/LinearLocks/LockSetSpec.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Test.LinearLocks.LockSetSpec where + +import Control.Functor.Linear qualified as L +import Control.Monad.IO.Class.Linear qualified as L +import Data.Vector.Unboxed qualified as VU +import LinearLocks +import LinearLocks.Internal.LockSet qualified as Internal +import LinearLocks.Internal.Mutex qualified as Internal +import LinearLocks.Mutex qualified as Mutex +import LinearLocks.Mutex.Strict qualified as StrictMutex +import LinearLocks.RWLock qualified as RWLock +import Prelude.Linear (Ur (..)) +import Test.Hspec.Expectations.Pretty (shouldNotBe, shouldThrow) +import "tasty-hunit-compat" Test.Tasty.HUnit + +-- | Doctests +-- +-- >>> :{ +-- >>> unit_locks_in_a_set_must_have_the_same_level :: IO () +-- >>> unit_locks_in_a_set_must_have_the_same_level = do +-- >>> m1 <- Mutex.new 2 "hello" +-- >>> m2 <- Mutex.new 3 "world" +-- >>> set <- newLockSet (m1, m2) +-- >>> pure () +-- >>> :} +-- ... +-- ... • Couldn't match type ‘2’ with ‘3’ +-- ... arising from a use of ‘newLockSet’ +-- ... +unit_read_lock_set :: IO () +unit_read_lock_set = do + m1 <- Mutex.new 0 "m1" + m2 <- Mutex.new 0 "m2" + m3 <- Mutex.new 0 "m3" + set <- newLockSet (m1, m2, m3) + + lockScope \key -> L.do + ((mg1, mg2, mg3), key) <- acquireMany key set + + (Ur str1, mg1) <- Mutex.read mg1 + (Ur str2, mg2) <- Mutex.read mg2 + (Ur str3, mg3) <- Mutex.read mg3 + + L.liftSystemIO do + str1 @?= "m1" + str2 @?= "m2" + str3 @?= "m3" + + Mutex.release mg1 + Mutex.release mg2 + Mutex.release mg3 + dropKeyAndReturn key () + +unit_write_lock_set :: IO () +unit_write_lock_set = do + m1 <- Mutex.new 0 "m1" + m2 <- Mutex.new 0 "m2" + m3 <- Mutex.new 0 "m3" + set <- newLockSet (m3, m2, m1) + + lockScope \key -> L.do + ((mg3, mg2, mg1), key) <- acquireMany key set + + mg3 <- Mutex.write mg3 "m3 updated" + mg2 <- Mutex.write mg2 "m2 updated" + mg1 <- Mutex.write mg1 "m1 updated" + + Mutex.release mg3 + Mutex.release mg2 + Mutex.release mg1 + dropKeyAndReturn key () + + lockScope \key -> L.do + ((mg3, mg2, mg1), key) <- acquireMany key set + + (Ur str3, mg3) <- Mutex.read mg3 + (Ur str2, mg2) <- Mutex.read mg2 + (Ur str1, mg1) <- Mutex.read mg1 + + L.liftSystemIO do + str3 @?= "m3 updated" + str2 @?= "m2 updated" + str1 @?= "m1 updated" + + Mutex.release mg3 + Mutex.release mg2 + Mutex.release mg1 + dropKeyAndReturn key () + +unit_assigns_unique_lock_ids :: IO () +unit_assigns_unique_lock_ids = do + m1 <- Mutex.new 0 "" + m2 <- Mutex.new 0 "" + m3 <- Mutex.new 0 "" + + m1.id `shouldNotBe` m2.id + m2.id `shouldNotBe` m3.id + m1.id `shouldNotBe` m3.id + +unit_throws_when_lock_set_contains_duplicates :: IO () +unit_throws_when_lock_set_contains_duplicates = do + m1 <- Mutex.new 0 "" + m2 <- Mutex.new 0 "" + + newLockSet (m1, m2, m1) `shouldThrow` \(err :: IOError) -> err == userError "LockSet: duplicate locks are not allowed" + +unit_sorts_locks_deterministically :: IO () +unit_sorts_locks_deterministically = do + m1 <- Mutex.new 0 "" + m2 <- Mutex.new 0 "" + m3 <- Mutex.new 0 "" + + newLockSet (m1, m2, m3) >>= \set -> sortedIndices set @?= VU.fromList [0, 1, 2] + newLockSet (m2, m1, m3) >>= \set -> sortedIndices set @?= VU.fromList [1, 0, 2] + newLockSet (m3, m1, m2) >>= \set -> sortedIndices set @?= VU.fromList [1, 2, 0] + newLockSet (m1, m3, m2) >>= \set -> sortedIndices set @?= VU.fromList [0, 2, 1] + newLockSet (m2, m3, m1) >>= \set -> sortedIndices set @?= VU.fromList [2, 0, 1] + newLockSet (m3, m2, m1) >>= \set -> sortedIndices set @?= VU.fromList [2, 1, 0] + where + sortedIndices :: forall set. LockSet set -> VU.Vector Int + sortedIndices (Internal.MkLockSet _ indices) = VU.map (\(Internal.LockSetIndex i) -> i) indices + +unit_sets_can_have_mixed_lock_types :: IO () +unit_sets_can_have_mixed_lock_types = do + m1 <- StrictMutex.new 0 "hello" + m2 <- Mutex.new @Int 0 99 + m3 <- RWLock.new 0 True + set <- newLockSet (m1, m2, RWLock.AsRead (m3)) + + lockScope \key -> L.do + ((g1, g2, g3), key) <- acquireMany key set + + (Ur res1, g1) <- StrictMutex.read g1 + (Ur res2, g2) <- Mutex.read g2 + (Ur res3, g3) <- RWLock.read g3 + + L.liftSystemIO do + res1 @?= "hello" + res2 @?= 99 + res3 @?= True + + StrictMutex.release g1 + Mutex.release g2 + RWLock.releaseRead g3 + dropKeyAndReturn key () diff --git a/test/Test/LinearLocks/MutexSpec.hs b/test/Test/LinearLocks/MutexSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/LinearLocks/MutexSpec.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Test.LinearLocks.MutexSpec where + +import Control.Concurrent (ThreadId, myThreadId) +import Control.Concurrent.MVar qualified as MVar +import Control.Exception (SomeException, throwIO, try) +import Control.Functor.Linear qualified as L +import Control.Monad (void) +import Control.Monad.IO.Class.Linear qualified as L +import Data.Function ((&)) +import GHC.Conc (atomically) +import LinearLocks +import LinearLocks.Internal qualified as Internal +import LinearLocks.Internal.Mutex qualified as Internal +import LinearLocks.Mutex qualified as Mutex +import ListT qualified +import Prelude.Linear (Ur (..)) +import Prelude.Linear qualified as L hiding (IO) +import StmContainers.Set qualified as StmSet +import Test.Hspec.Expectations.Pretty (anyIOException, shouldThrow) +import "tasty-hunit-compat" Test.Tasty.HUnit + +-- | Doctests +-- +-- >>> :{ +-- >>> unit_mutexes_cannot_be_locked_in_wrong_order :: IO () +-- >>> unit_mutexes_cannot_be_locked_in_wrong_order = do +-- >>> m1 <- Mutex.new 2 "hello" +-- >>> m2 <- Mutex.new 4 "world" +-- >>> lockScope \key -> L.do +-- >>> (mg2, key) <- Mutex.acquire key m2 +-- >>> (mg1, key) <- Mutex.acquire key m1 +-- >>> Mutex.release mg1 +-- >>> Mutex.release mg2 +-- >>> dropKeyAndReturn key () +-- >>> :} +-- ... +-- ... • Cannot satisfy: 5 <= 2 +-- ... • In a stmt of a 'do' block: (mg1, key) <- Mutex.acquire key m1 +-- ... +unit_read_mutex :: IO () +unit_read_mutex = do + mutex <- Mutex.new 0 "hello" + str <- lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + (Ur str, mg) <- Mutex.read mg + Mutex.release mg + dropKeyAndReturn key str + str @?= "hello" + +unit_write_mutex :: IO () +unit_write_mutex = do + mutex <- Mutex.new 0 "hello" + lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + mg <- Mutex.write mg "world" + Mutex.release mg + dropKeyAndReturn key () + + str <- lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + (Ur str, mg) <- Mutex.read mg + Mutex.release mg + dropKeyAndReturn key str + + str @?= "world" + + str <- MVar.readMVar mutex.var + str @?= "world" + +unit_realeases_mvar :: IO () +unit_realeases_mvar = do + mutex <- Mutex.new 0 "hello" + lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + + L.liftSystemIO do + isEmpty <- MVar.isEmptyMVar mutex.var + isEmpty @?= True + + Mutex.release mg + + L.liftSystemIO do + isEmpty <- MVar.isEmptyMVar mutex.var + isEmpty @?= False + + dropKeyAndReturn key () + + isEmpty <- MVar.isEmptyMVar mutex.var + isEmpty @?= False + +unit_cant_nest_lockscopes :: IO () +unit_cant_nest_lockscopes = do + let run = + lockScope \key -> L.do + L.liftSystemIO do + lockScope \key -> dropKeyAndReturn key () + dropKeyAndReturn key () + + run `shouldThrow` \(_ :: NestedLocksScopeException) -> True + +unit_updates_thread_ids :: IO () +unit_updates_thread_ids = do + tid <- myThreadId + + getThreadIds >>= \tids -> tids @?= [] + lockScope \key -> L.do + L.liftSystemIO L.$ getThreadIds >>= \tids -> tids @?= [tid] + dropKeyAndReturn key () + getThreadIds >>= \tids -> tids @?= [] + + -- Check that the thread ID is removed even if an exception is thrown. + let run = + lockScope \key -> L.do + L.liftSystemIO L.$ getThreadIds >>= \tids -> tids @?= [tid] + L.liftSystemIO L.$ throwIO (userError "oops") + dropKeyAndReturn key () + run `shouldThrow` anyIOException + getThreadIds >>= \tids -> tids @?= [] + + -- Check that the thread ID is removed even if when a nested lock scope is attempted + let run = + lockScope \key -> L.do + L.liftSystemIO L.$ getThreadIds >>= \tids -> tids @?= [tid] + L.liftSystemIO do + lockScope \key -> dropKeyAndReturn key () + dropKeyAndReturn key () + run `shouldThrow` \(_ :: NestedLocksScopeException) -> True + getThreadIds >>= \tids -> tids @?= [] + + -- Check that the thread ID is NOT removed if a nested lock scope is caught + lockScope \key -> L.do + L.liftSystemIO L.$ getThreadIds >>= \tids -> tids @?= [tid] + L.liftSystemIO do + Left _ <- try @SomeException $ lockScope \key -> dropKeyAndReturn key () + pure () + L.liftSystemIO L.$ getThreadIds >>= \tids -> tids @?= [tid] + dropKeyAndReturn key () + getThreadIds >>= \tids -> tids @?= [] + where + getThreadIds :: IO [ThreadId] + getThreadIds = + Internal.lockScopes & StmSet.listT & ListT.toList & atomically + +unit_rolls_back_on_exception :: IO () +unit_rolls_back_on_exception = do + mutex <- Mutex.new 0 "hello" + Left _ <- try @SomeException $ lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + mg <- Mutex.write mg "world" + L.liftSystemIO L.$ throwIO (userError "oops") + Mutex.release mg + dropKeyAndReturn key () + + -- The MVar should have been released, and the original value should have been put back into the MVar. + mbResult <- MVar.tryTakeMVar mutex.var + mbResult @?= Just "hello" + +unit_rolls_back_on_imprecise_exception :: IO () +unit_rolls_back_on_imprecise_exception = do + mutex <- Mutex.new 0 "hello" + Left _ <- try @SomeException $ lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + mg <- Mutex.write mg "world" + error "err" + Mutex.release mg + dropKeyAndReturn key () + + -- The MVar should have been released, and the original value should have been put back into the MVar. + mbResult <- MVar.tryTakeMVar mutex.var + mbResult @?= Just "hello" + +unit_new_doesnt_evaluate_value_to_normal_form :: IO () +unit_new_doesnt_evaluate_value_to_normal_form = do + -- This should not throw, the "error" thunk should not be evaluated + void $ Mutex.new @[Int] 0 [1, 2, error "oops", 4] + +unit_release_doesnt_evaluate_value_to_normal_form :: IO () +unit_release_doesnt_evaluate_value_to_normal_form = do + mutex <- Mutex.new @[Int] 0 [1] + + lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + -- This should not throw, the "error" thunk should not be evaluated + mg <- Mutex.write mg [1, 2, error "oops", 4] + -- This should not throw + Mutex.release mg + dropKeyAndReturn key () diff --git a/test/Test/LinearLocks/RWLockSpec.hs b/test/Test/LinearLocks/RWLockSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/LinearLocks/RWLockSpec.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Test.LinearLocks.RWLockSpec where + +import Control.Concurrent.ReadWriteLock qualified as Conc +import Control.Exception (SomeException, throwIO, try) +import Control.Functor.Linear qualified as L +import Control.Monad (void, when) +import Control.Monad.IO.Class.Linear qualified as L +import Data.IORef qualified as IORef +import LinearLocks +import LinearLocks.Internal.RWLock qualified as Internal +import LinearLocks.RWLock qualified as RWLock +import Prelude.Linear (Ur (..)) +import Prelude.Linear qualified as L hiding (IO) +import "tasty-hunit-compat" Test.Tasty.HUnit + +-- | Doctests +-- +-- >>> :{ +-- >>> unit_mutexes_cannot_be_locked_in_wrong_order :: IO () +-- >>> unit_mutexes_cannot_be_locked_in_wrong_order = do +-- >>> m1 <- RWLock.new 2 "hello" +-- >>> m2 <- RWLock.new 4 "world" +-- >>> lockScope \key -> L.do +-- >>> (g2, key) <- RWLock.acquireRead key m2 +-- >>> (g1, key) <- RWLock.acquireRead key m1 +-- >>> RWLock.releaseRead g1 +-- >>> RWLock.releaseRead g2 +-- >>> dropKeyAndReturn key () +-- >>> :} +-- ... +-- ... • Cannot satisfy: 5 <= 2 +-- ... • In a stmt of a 'do' block: (g1, key) <- RWLock.acquireRead key m1 +-- ... +unit_read_mutex :: IO () +unit_read_mutex = do + rwl <- RWLock.new 0 "hello" + -- Read in "read mode" + str <- lockScope \key -> L.do + (guard, key) <- RWLock.acquireRead key rwl + (Ur str, guard) <- RWLock.read guard + RWLock.releaseRead guard + dropKeyAndReturn key str + str @?= "hello" + + -- Read in "write mode" + str <- lockScope \key -> L.do + (guard, key) <- RWLock.acquireWrite key rwl + (Ur str, guard) <- RWLock.read guard + RWLock.releaseWrite guard + dropKeyAndReturn key str + str @?= "hello" + +unit_write_mutex :: IO () +unit_write_mutex = do + rwl <- RWLock.new 0 "hello" + + -- Write in "write mode" + lockScope \key -> L.do + (guard, key) <- RWLock.acquireWrite key rwl + guard <- RWLock.write guard "world" + RWLock.releaseWrite guard + dropKeyAndReturn key () + + -- Read in "read mode" + str <- lockScope \key -> L.do + (guard, key) <- RWLock.acquireRead key rwl + (Ur str, guard) <- RWLock.read guard + RWLock.releaseRead guard + dropKeyAndReturn key str + str @?= "world" + + -- Read in "write mode" + str <- lockScope \key -> L.do + (guard, key) <- RWLock.acquireWrite key rwl + (Ur str, guard) <- RWLock.read guard + RWLock.releaseWrite guard + dropKeyAndReturn key str + str @?= "world" + + str <- IORef.readIORef rwl.var + str @?= "world" + +unit_realeases_ioref_in_read_mode :: IO () +unit_realeases_ioref_in_read_mode = do + rwl <- RWLock.new 0 "hello" + lockScope \key -> L.do + (mg, key) <- RWLock.acquireRead key rwl + + -- If the lock was acquired in "read mode", + -- we shouldn't be able to acquire it again in "write mode", + -- but we should be able to acquire it in "read mode". + L.liftSystemIO do + assertCanRead rwl True + assertCanWrite rwl False + + RWLock.releaseRead mg + + -- The lock was released, we should be able to acquire it in both "read mode" and "write mode". + L.liftSystemIO do + assertCanRead rwl True + assertCanWrite rwl True + + dropKeyAndReturn key () + + -- The lock was released, we should be able to acquire it in both "read mode" and "write mode". + assertCanRead rwl True + assertCanWrite rwl True + +unit_realeases_ioref_in_write_mode :: IO () +unit_realeases_ioref_in_write_mode = do + rwl <- RWLock.new 0 "hello" + lockScope \key -> L.do + (mg, key) <- RWLock.acquireWrite key rwl + + -- If the lock was acquired in "write mode", + -- we shouldn't be able to acquire it again in "write mode" or "read mode". + L.liftSystemIO do + assertCanRead rwl False + assertCanWrite rwl False + + RWLock.releaseWrite mg + + -- The lock was released, we should be able to acquire it in both "read mode" and "write mode". + L.liftSystemIO do + assertCanRead rwl True + assertCanWrite rwl True + + dropKeyAndReturn key () + + -- The lock was released, we should be able to acquire it in both "read mode" and "write mode". + assertCanRead rwl True + assertCanWrite rwl True + +unit_rolls_back_on_exception :: IO () +unit_rolls_back_on_exception = do + rwl <- RWLock.new 0 "hello" + Left _ <- try @SomeException $ lockScope \key -> L.do + (mg, key) <- RWLock.acquireWrite key rwl + mg <- RWLock.write mg "world" + L.liftSystemIO L.$ throwIO (userError "oops") + RWLock.releaseWrite mg + dropKeyAndReturn key () + + -- The IORef should have been released, and the original value should have been put back into the IORef. + assertCanRead rwl True + assertCanWrite rwl True + mbResult <- IORef.readIORef rwl.var + mbResult @?= "hello" + +unit_rolls_back_on_imprecise_exception :: IO () +unit_rolls_back_on_imprecise_exception = do + rwl <- RWLock.new 0 "hello" + Left _ <- try @SomeException $ lockScope \key -> L.do + (mg, key) <- RWLock.acquireWrite key rwl + mg <- RWLock.write mg "world" + error "err" + RWLock.releaseWrite mg + dropKeyAndReturn key () + + -- The IORef should have been released, and the original value should have been put back into the IORef. + assertCanRead rwl True + assertCanWrite rwl True + mbResult <- IORef.readIORef rwl.var + mbResult @?= "hello" + +unit_new_doesnt_evaluate_value_to_normal_form :: IO () +unit_new_doesnt_evaluate_value_to_normal_form = do + -- This should not throw, the "error" thunk should not be evaluated + void $ RWLock.new @[Int] 0 [1, 2, error "oops", 4] + +unit_release_doesnt_evaluate_value_to_normal_form :: IO () +unit_release_doesnt_evaluate_value_to_normal_form = do + mutex <- RWLock.new @[Int] 0 [1] + + lockScope \key -> L.do + (mg, key) <- RWLock.acquireWrite key mutex + -- This should not throw, the "error" thunk should not be evaluated + mg <- RWLock.write mg [1, 2, error "oops", 4] + -- This should not throw + RWLock.releaseWrite mg + dropKeyAndReturn key () + +assertCanRead :: RWLock.RWLock lvl a -> Bool -> IO () +assertCanRead rwl expected = do + canRead <- Conc.tryAcquireRead rwl.lock + canRead @?= expected + -- Release the lock if it was acquired. + when canRead do + Conc.releaseRead rwl.lock + +assertCanWrite :: RWLock.RWLock lvl a -> Bool -> IO () +assertCanWrite rwl expected = do + canWrite <- Conc.tryAcquireWrite rwl.lock + canWrite @?= expected + -- Release the lock if it was acquired. + when canWrite do + Conc.releaseWrite rwl.lock diff --git a/test/Test/LinearLocks/StrictMutexSpec.hs b/test/Test/LinearLocks/StrictMutexSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/LinearLocks/StrictMutexSpec.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Test.LinearLocks.StrictMutexSpec where + +import Control.Concurrent.MVar qualified as MVar +import Control.Exception (SomeException, throwIO, try) +import Control.Functor.Linear qualified as L +import Control.Monad.IO.Class.Linear qualified as L +import LinearLocks +import LinearLocks.Internal qualified as Internal +import LinearLocks.Internal.StrictMutex qualified as Internal +import LinearLocks.Mutex.Strict qualified as Mutex +import Prelude.Linear (Ur (..)) +import Prelude.Linear qualified as L hiding (IO) +import System.IO.Resource.Linear (RIO) +import Test.Hspec.Expectations.Pretty (errorCall, shouldThrow) +import "tasty-hunit-compat" Test.Tasty.HUnit + +-- | Doctests +-- +-- >>> :{ +-- >>> unit_mutexes_cannot_be_locked_in_wrong_order :: IO () +-- >>> unit_mutexes_cannot_be_locked_in_wrong_order = do +-- >>> m1 <- Mutex.new 2 "hello" +-- >>> m2 <- Mutex.new 4 "world" +-- >>> lockScope \key -> L.do +-- >>> (mg2, key) <- Mutex.acquire key m2 +-- >>> (mg1, key) <- Mutex.acquire key m1 +-- >>> Mutex.release mg1 +-- >>> Mutex.release mg2 +-- >>> dropKeyAndReturn key () +-- >>> :} +-- ... +-- ... • Cannot satisfy: 5 <= 2 +-- ... • In a stmt of a 'do' block: (mg1, key) <- Mutex.acquire key m1 +-- ... +unit_read_mutex :: IO () +unit_read_mutex = do + mutex <- Mutex.new 0 "hello" + str <- lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + (Ur str, mg) <- Mutex.read mg + Mutex.release mg + dropKeyAndReturn key str + str @?= "hello" + +unit_write_mutex :: IO () +unit_write_mutex = do + mutex <- Mutex.new 0 "hello" + lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + mg <- Mutex.write mg "world" + Mutex.release mg + dropKeyAndReturn key () + + str <- lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + (Ur str, mg) <- Mutex.read mg + Mutex.release mg + dropKeyAndReturn key str + + str @?= "world" + + str <- MVar.readMVar mutex.var + str.unNF @?= "world" + +unit_realeases_mvar :: IO () +unit_realeases_mvar = do + mutex <- Mutex.new 0 "hello" + lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + + L.liftSystemIO do + isEmpty <- MVar.isEmptyMVar mutex.var + isEmpty @?= True + + Mutex.release mg + + L.liftSystemIO do + isEmpty <- MVar.isEmptyMVar mutex.var + isEmpty @?= False + + dropKeyAndReturn key () + + isEmpty <- MVar.isEmptyMVar mutex.var + isEmpty @?= False + +unit_rolls_back_on_exception :: IO () +unit_rolls_back_on_exception = do + mutex <- Mutex.new 0 "hello" + Left _ <- try @SomeException $ lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + mg <- Mutex.write mg "world" + L.liftSystemIO L.$ throwIO (userError "oops") + Mutex.release mg + dropKeyAndReturn key () + + -- The MVar should have been released, and the original value should have been put back into the MVar. + mbResult <- MVar.tryTakeMVar mutex.var + mbResult @?= Just (Internal.mkNF "hello") + +unit_rolls_back_on_imprecise_exception :: IO () +unit_rolls_back_on_imprecise_exception = do + mutex <- Mutex.new 0 "hello" + Left _ <- try @SomeException $ lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + mg <- Mutex.write mg "world" + error "err" + Mutex.release mg + dropKeyAndReturn key () + + -- The MVar should have been released, and the original value should have been put back into the MVar. + mbResult <- MVar.tryTakeMVar mutex.var + mbResult @?= Just (Internal.mkNF "hello") + +unit_new_evaluates_value_to_normal_form :: IO () +unit_new_evaluates_value_to_normal_form = do + Mutex.new @[Int] 0 [1, 2, error "oops", 4] + `shouldThrow` errorCall "oops" + +unit_release_evaluates_value_to_normal_form :: IO () +unit_release_evaluates_value_to_normal_form = do + mutex <- Mutex.new @[Int] 0 [1] + + logs <- MVar.newMVar @[String] [] + let logMsg :: String -> RIO () + logMsg msg = L.liftSystemIO do + MVar.modifyMVar_ logs \logs -> pure (logs <> [msg]) + + let run = + lockScope \key -> L.do + (mg, key) <- Mutex.acquire key mutex + logMsg "ran 'acquire'" + mg <- Mutex.write mg [1, 2, error "oops", 4] + logMsg "ran 'write'" + Mutex.release mg + logMsg "ran 'release'" + dropKeyAndReturn key () + + run `shouldThrow` errorCall "oops" + + -- The exception should be thrown WHILE running `release`. + -- `write` should NOT throw. + msgs <- MVar.takeMVar logs + msgs @?= ["ran 'acquire'", "ran 'write'"] diff --git a/test/Test/LinearLocks/StrictRWLockSpec.hs b/test/Test/LinearLocks/StrictRWLockSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/LinearLocks/StrictRWLockSpec.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Test.LinearLocks.StrictRWLockSpec where + +import Control.Concurrent.MVar qualified as MVar +import Control.Concurrent.ReadWriteLock qualified as Conc +import Control.Exception (SomeException, throwIO, try) +import Control.Functor.Linear qualified as L +import Control.Monad (when) +import Control.Monad.IO.Class.Linear qualified as L +import Data.IORef qualified as IORef +import LinearLocks +import LinearLocks.Internal qualified as Internal +import LinearLocks.Internal.StrictRWLock qualified as Internal +import LinearLocks.RWLock.Strict qualified as RWLock +import Prelude.Linear (Ur (..)) +import Prelude.Linear qualified as L hiding (IO) +import System.IO.Resource.Linear (RIO) +import Test.Hspec.Expectations.Pretty (errorCall, shouldThrow) +import "tasty-hunit-compat" Test.Tasty.HUnit + +-- | Doctests +-- +-- >>> :{ +-- >>> unit_mutexes_cannot_be_locked_in_wrong_order :: IO () +-- >>> unit_mutexes_cannot_be_locked_in_wrong_order = do +-- >>> m1 <- RWLock.new 2 "hello" +-- >>> m2 <- RWLock.new 4 "world" +-- >>> lockScope \key -> L.do +-- >>> (g2, key) <- RWLock.acquireRead key m2 +-- >>> (g1, key) <- RWLock.acquireRead key m1 +-- >>> RWLock.releaseRead g1 +-- >>> RWLock.releaseRead g2 +-- >>> dropKeyAndReturn key () +-- >>> :} +-- ... +-- ... • Cannot satisfy: 5 <= 2 +-- ... • In a stmt of a 'do' block: (g1, key) <- RWLock.acquireRead key m1 +-- ... +unit_read_mutex :: IO () +unit_read_mutex = do + rwl <- RWLock.new 0 "hello" + -- Read in "read mode" + str <- lockScope \key -> L.do + (guard, key) <- RWLock.acquireRead key rwl + (Ur str, guard) <- RWLock.read guard + RWLock.releaseRead guard + dropKeyAndReturn key str + str @?= "hello" + + -- Read in "write mode" + str <- lockScope \key -> L.do + (guard, key) <- RWLock.acquireWrite key rwl + (Ur str, guard) <- RWLock.read guard + RWLock.releaseWrite guard + dropKeyAndReturn key str + str @?= "hello" + +unit_write_mutex :: IO () +unit_write_mutex = do + rwl <- RWLock.new 0 "hello" + + -- Write in "write mode" + lockScope \key -> L.do + (guard, key) <- RWLock.acquireWrite key rwl + guard <- RWLock.write guard "world" + RWLock.releaseWrite guard + dropKeyAndReturn key () + + -- Read in "read mode" + str <- lockScope \key -> L.do + (guard, key) <- RWLock.acquireRead key rwl + (Ur str, guard) <- RWLock.read guard + RWLock.releaseRead guard + dropKeyAndReturn key str + str @?= "world" + + -- Read in "write mode" + str <- lockScope \key -> L.do + (guard, key) <- RWLock.acquireWrite key rwl + (Ur str, guard) <- RWLock.read guard + RWLock.releaseWrite guard + dropKeyAndReturn key str + str @?= "world" + + str <- IORef.readIORef rwl.var + str.unNF @?= "world" + +unit_realeases_ioref_in_read_mode :: IO () +unit_realeases_ioref_in_read_mode = do + rwl <- RWLock.new 0 "hello" + lockScope \key -> L.do + (mg, key) <- RWLock.acquireRead key rwl + + -- If the lock was acquired in "read mode", + -- we shouldn't be able to acquire it again in "write mode", + -- but we should be able to acquire it in "read mode". + L.liftSystemIO do + assertCanRead rwl True + assertCanWrite rwl False + + RWLock.releaseRead mg + + -- The lock was released, we should be able to acquire it in both "read mode" and "write mode". + L.liftSystemIO do + assertCanRead rwl True + assertCanWrite rwl True + + dropKeyAndReturn key () + + -- The lock was released, we should be able to acquire it in both "read mode" and "write mode". + assertCanRead rwl True + assertCanWrite rwl True + +unit_realeases_ioref_in_write_mode :: IO () +unit_realeases_ioref_in_write_mode = do + rwl <- RWLock.new 0 "hello" + lockScope \key -> L.do + (mg, key) <- RWLock.acquireWrite key rwl + + -- If the lock was acquired in "write mode", + -- we shouldn't be able to acquire it again in "write mode" or "read mode". + L.liftSystemIO do + assertCanRead rwl False + assertCanWrite rwl False + + RWLock.releaseWrite mg + + -- The lock was released, we should be able to acquire it in both "read mode" and "write mode". + L.liftSystemIO do + assertCanRead rwl True + assertCanWrite rwl True + + dropKeyAndReturn key () + + -- The lock was released, we should be able to acquire it in both "read mode" and "write mode". + assertCanRead rwl True + assertCanWrite rwl True + +unit_rolls_back_on_exception :: IO () +unit_rolls_back_on_exception = do + rwl <- RWLock.new 0 "hello" + Left _ <- try @SomeException $ lockScope \key -> L.do + (mg, key) <- RWLock.acquireWrite key rwl + mg <- RWLock.write mg "world" + L.liftSystemIO L.$ throwIO (userError "oops") + RWLock.releaseWrite mg + dropKeyAndReturn key () + + -- The IORef should have been released, and the original value should have been put back into the IORef. + assertCanRead rwl True + assertCanWrite rwl True + mbResult <- IORef.readIORef rwl.var + mbResult.unNF @?= "hello" + +unit_rolls_back_on_imprecise_exception :: IO () +unit_rolls_back_on_imprecise_exception = do + rwl <- RWLock.new 0 "hello" + Left _ <- try @SomeException $ lockScope \key -> L.do + (mg, key) <- RWLock.acquireWrite key rwl + mg <- RWLock.write mg "world" + error "err" + RWLock.releaseWrite mg + dropKeyAndReturn key () + + -- The IORef should have been released, and the original value should have been put back into the IORef. + assertCanRead rwl True + assertCanWrite rwl True + mbResult <- IORef.readIORef rwl.var + mbResult.unNF @?= "hello" + +unit_new_evaluates_value_to_normal_form :: IO () +unit_new_evaluates_value_to_normal_form = do + RWLock.new @[Int] 0 [1, 2, error "oops", 4] + `shouldThrow` errorCall "oops" + +unit_release_evaluates_value_to_normal_form :: IO () +unit_release_evaluates_value_to_normal_form = do + mutex <- RWLock.new @[Int] 0 [1] + + logs <- MVar.newMVar @[String] [] + let logMsg :: String -> RIO () + logMsg msg = L.liftSystemIO do + MVar.modifyMVar_ logs \logs -> pure (logs <> [msg]) + + let run = + lockScope \key -> L.do + (mg, key) <- RWLock.acquireWrite key mutex + logMsg "ran 'acquire'" + mg <- RWLock.write mg [1, 2, error "oops", 4] + logMsg "ran 'write'" + RWLock.releaseWrite mg + logMsg "ran 'release'" + dropKeyAndReturn key () + + run `shouldThrow` errorCall "oops" + + -- The exception should be thrown WHILE running `release`. + -- `write` should NOT throw. + msgs <- MVar.takeMVar logs + msgs @?= ["ran 'acquire'", "ran 'write'"] + +assertCanRead :: RWLock.RWLock lvl a -> Bool -> IO () +assertCanRead rwl expected = do + canRead <- Conc.tryAcquireRead rwl.lock + canRead @?= expected + -- Release the lock if it was acquired. + when canRead do + Conc.releaseRead rwl.lock + +assertCanWrite :: RWLock.RWLock lvl a -> Bool -> IO () +assertCanWrite rwl expected = do + canWrite <- Conc.tryAcquireWrite rwl.lock + canWrite @?= expected + -- Release the lock if it was acquired. + when canWrite do + Conc.releaseWrite rwl.lock