diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,17 @@ +# Changelog + +## 1.0.0.0 + +## 0.6.0.0 + +## 0.5.0.0 + +## 0.4.0.0 + +## 0.3.0.0 + +* split modules in a similar way that the `stm` package is. +* added `StrictTChan`, `TSem` and `StrictTArray` +* added `unGetTQueue` & `unGetTBQueue` +* added `StrictTQueue` & `StrictTBQueue` +* support `ghc-9.2` & `ghc-9.4` diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/NOTICE b/NOTICE new file mode 100644 --- /dev/null +++ b/NOTICE @@ -0,0 +1,14 @@ +Copyright 2019-2023 Input Output Global Inc (IOG) + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,18 @@ +# Strict Software Transaction Memory + +The `strict-stm` package provides a strict interface to software transaction +memory. It builds on top of [`io-classes`] and thus it provides the interface +for both [`stm`] as well as [`io-sim`]. + +# Novel testing / space-leak elimination approach + +The strict interface provides a novel way of testing/eliminating space-leaks +which might lurk in `stm` shared mutable variables. Together with the +[`nothunks`] library it was successfully used to eliminate and keep a large +system ([`cardano-node`]) space leak free. + +[`cardano-node`]: https://www.github.com/input-output-hk/cardano-node +[`io-classes`]: https://hackage.haskell.org/package/io-classes +[`io-sim`]: https://hackage.haskell.org/package/io-sim +[`nothunks`]: https://hackage.haskell.org/package/nothunks +[`stm`]: https://hackage.haskell.org/package/stm diff --git a/src/Control/Concurrent/Class/MonadSTM/Strict.hs b/src/Control/Concurrent/Class/MonadSTM/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/Strict.hs @@ -0,0 +1,19 @@ +-- | This module corresponds to `Control.Concurrent.STM` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict + (module STM) + where + +import Control.Monad.Class.MonadSTM as STM hiding ( traceTVar, traceTVarIO, + traceTMVar, traceTMVarIO, + traceTQueue, traceTQueueIO, + traceTBQueue, traceTBQueueIO + ) +import Control.Concurrent.Class.MonadSTM.Strict.TVar as STM +import Control.Concurrent.Class.MonadSTM.Strict.TMVar as STM +import Control.Concurrent.Class.MonadSTM.Strict.TChan as STM +import Control.Concurrent.Class.MonadSTM.Strict.TQueue as STM +import Control.Concurrent.Class.MonadSTM.Strict.TBQueue as STM +import Control.Concurrent.Class.MonadSTM.Strict.TArray as STM + + diff --git a/src/Control/Concurrent/Class/MonadSTM/Strict/TArray.hs b/src/Control/Concurrent/Class/MonadSTM/Strict/TArray.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/Strict/TArray.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module corresponds to `Control.Concurrent.STM.TArray` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict.TArray + ( StrictTArray + , LazyTArray + , toLazyTArray + , fromLazyTArray + ) where + + +import qualified Control.Concurrent.Class.MonadSTM.TArray as Lazy + +import Data.Array.Base (MArray (..)) + + +type LazyTArray m = Lazy.TArray m + +newtype StrictTArray m i e = StrictTArray { toLazyTArray :: LazyTArray m i e } + +fromLazyTArray :: LazyTArray m i e -> StrictTArray m i e +fromLazyTArray = StrictTArray + +instance ( MArray (Lazy.TArray m) e stm + , Monad stm + ) + => MArray (StrictTArray m) e stm where + getBounds (StrictTArray arr) = getBounds arr + newArray b !e = StrictTArray <$> newArray b e + newArray_ b = StrictTArray <$> newArray_ b + unsafeRead (StrictTArray arr) i = unsafeRead arr i + unsafeWrite (StrictTArray arr) i !e = unsafeWrite arr i e + getNumElements (StrictTArray arr) = getNumElements arr + diff --git a/src/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs b/src/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module corresponds to `Control.Concurrent.STM.TBQueue` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict.TBQueue + ( -- * MonadSTM + StrictTBQueue + , LazyTBQueue + , toLazyTBQueue + , fromLazyTBQueue + , castStrictTBQueue + , newTBQueue + , newTBQueueIO + , readTBQueue + , tryReadTBQueue + , peekTBQueue + , tryPeekTBQueue + , flushTBQueue + , writeTBQueue + , lengthTBQueue + , isEmptyTBQueue + , isFullTBQueue + , unGetTBQueue + -- * MonadLabelledSTM + , labelTBQueue + , labelTBQueueIO + -- * MonadTraceSTM + , traceTBQueue + , traceTBQueueIO + ) where + + +import qualified Control.Concurrent.Class.MonadSTM.TBQueue as Lazy +import Control.Monad.Class.MonadSTM hiding (traceTBQueue, traceTBQueueIO) + +import Numeric.Natural (Natural) + + +type LazyTBQueue m = Lazy.TBQueue m + +newtype StrictTBQueue m a = StrictTBQueue { toLazyTBQueue :: LazyTBQueue m a } + +fromLazyTBQueue :: LazyTBQueue m a -> StrictTBQueue m a +fromLazyTBQueue = StrictTBQueue + +castStrictTBQueue :: LazyTBQueue m ~ LazyTBQueue n + => StrictTBQueue m a -> StrictTBQueue n a +castStrictTBQueue (StrictTBQueue var) = StrictTBQueue var + +labelTBQueue :: MonadLabelledSTM m => StrictTBQueue m a -> String -> STM m () +labelTBQueue (StrictTBQueue queue) = Lazy.labelTBQueue queue + +labelTBQueueIO :: MonadLabelledSTM m => StrictTBQueue m a -> String -> m () +labelTBQueueIO (StrictTBQueue queue) = Lazy.labelTBQueueIO queue + +traceTBQueue :: MonadTraceSTM m + => proxy m + -> StrictTBQueue m a + -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> STM m () +traceTBQueue p (StrictTBQueue queue) = Lazy.traceTBQueue p queue + +traceTBQueueIO :: MonadTraceSTM m + => StrictTBQueue m a + -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> m () +traceTBQueueIO (StrictTBQueue queue) = Lazy.traceTBQueueIO queue + +newTBQueue :: MonadSTM m => Natural -> STM m (StrictTBQueue m a) +newTBQueue n = StrictTBQueue <$> Lazy.newTBQueue n + +newTBQueueIO :: MonadSTM m => Natural -> m (StrictTBQueue m a) +newTBQueueIO = atomically . newTBQueue + +readTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m a +readTBQueue = Lazy.readTBQueue . toLazyTBQueue + +tryReadTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m (Maybe a) +tryReadTBQueue = Lazy.tryReadTBQueue . toLazyTBQueue + +peekTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m a +peekTBQueue = Lazy.peekTBQueue . toLazyTBQueue + +tryPeekTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m (Maybe a) +tryPeekTBQueue = Lazy.tryPeekTBQueue . toLazyTBQueue + +flushTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m [a] +flushTBQueue = Lazy.flushTBQueue . toLazyTBQueue + +writeTBQueue :: MonadSTM m => StrictTBQueue m a -> a -> STM m () +writeTBQueue (StrictTBQueue tqueue) !a = Lazy.writeTBQueue tqueue a + +lengthTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m Natural +lengthTBQueue = Lazy.lengthTBQueue . toLazyTBQueue + +isEmptyTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m Bool +isEmptyTBQueue = Lazy.isEmptyTBQueue . toLazyTBQueue + +isFullTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m Bool +isFullTBQueue = Lazy.isFullTBQueue . toLazyTBQueue + +unGetTBQueue :: MonadSTM m => StrictTBQueue m a -> a -> STM m () +unGetTBQueue (StrictTBQueue queue) !a = Lazy.unGetTBQueue queue a diff --git a/src/Control/Concurrent/Class/MonadSTM/Strict/TChan.hs b/src/Control/Concurrent/Class/MonadSTM/Strict/TChan.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/Strict/TChan.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module corresponds to `Control.Concurrent.STM.TChan` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict.TChan + ( StrictTChan + , LazyTChan + , toLazyTChan + , fromLazyTChan + , castStrictTChan + , newTChan + , newBroadcastTChan + , writeTChan + , readTChan + , tryReadTChan + , peekTChan + , tryPeekTChan + , dupTChan + , unGetTChan + , isEmptyTChan + , cloneTChan + ) where + + +import qualified Control.Concurrent.Class.MonadSTM.TChan as Lazy +import Control.Monad.Class.MonadSTM + + +type LazyTChan m = Lazy.TChan m + +newtype StrictTChan m a = StrictTChan { toLazyTChan :: LazyTChan m a } + +fromLazyTChan :: LazyTChan m a -> StrictTChan m a +fromLazyTChan = StrictTChan + +castStrictTChan :: LazyTChan m ~ LazyTChan n + => StrictTChan m a -> StrictTChan n a +castStrictTChan (StrictTChan var) = StrictTChan var + +newTChan :: MonadSTM m => STM m (StrictTChan m a) +newTChan = StrictTChan <$> Lazy.newTChan + +newBroadcastTChan :: MonadSTM m => STM m (StrictTChan m a) +newBroadcastTChan = StrictTChan <$> Lazy.newBroadcastTChan + +writeTChan :: MonadSTM m => StrictTChan m a -> a -> STM m () +writeTChan (StrictTChan chan) !a = Lazy.writeTChan chan a + +readTChan :: MonadSTM m => StrictTChan m a -> STM m a +readTChan = Lazy.readTChan . toLazyTChan + +tryReadTChan :: MonadSTM m => StrictTChan m a -> STM m (Maybe a) +tryReadTChan = Lazy.tryReadTChan . toLazyTChan + +peekTChan :: MonadSTM m => StrictTChan m a -> STM m a +peekTChan = Lazy.peekTChan . toLazyTChan + +tryPeekTChan :: MonadSTM m => StrictTChan m a -> STM m (Maybe a) +tryPeekTChan = Lazy.tryPeekTChan . toLazyTChan + +dupTChan :: MonadSTM m => StrictTChan m a -> STM m (StrictTChan m a) +dupTChan = fmap fromLazyTChan . Lazy.dupTChan . toLazyTChan + +unGetTChan :: MonadSTM m => StrictTChan m a -> a -> STM m () +unGetTChan (StrictTChan chan) !a = Lazy.unGetTChan chan a + +isEmptyTChan :: MonadSTM m => StrictTChan m a -> STM m Bool +isEmptyTChan = Lazy.isEmptyTChan . toLazyTChan + +cloneTChan :: MonadSTM m => StrictTChan m a -> STM m (StrictTChan m a) +cloneTChan = fmap fromLazyTChan . Lazy.cloneTChan . toLazyTChan diff --git a/src/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs b/src/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module corresponds to `Control.Concurrent.STM.TMVar` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict.TMVar + ( -- * StrictTMVar + StrictTMVar + , LazyTMVar + , toLazyTMVar + , fromLazyTMVar + , castStrictTMVar + , newTMVar + , newEmptyTMVar + , newTMVarIO + , newEmptyTMVarIO + , takeTMVar + , tryTakeTMVar + , putTMVar + , tryPutTMVar + , readTMVar + , tryReadTMVar + , swapTMVar + , isEmptyTMVar + -- * deprecated api + , newTMVarM + , newEmptyTMVarM + -- * MonadLabelledSTM + , labelTMVar + , labelTMVarIO + -- * MonadTraceSTM + , traceTMVar + , traceTMVarIO + ) where + + +import qualified Control.Concurrent.Class.MonadSTM.TMVar as Lazy +import Control.Monad.Class.MonadSTM hiding (traceTMVar, traceTMVarIO) + + +type LazyTMVar m = Lazy.TMVar m + +-- | 'TMVar' that keeps its value in WHNF at all times +-- +-- Does not support an invariant: if the invariant would not be satisfied, +-- we would not be able to put a value into an empty TMVar, which would lead +-- to very hard to debug bugs where code is blocked indefinitely. +newtype StrictTMVar m a = StrictTMVar { toLazyTMVar :: LazyTMVar m a } + +fromLazyTMVar :: LazyTMVar m a -> StrictTMVar m a +fromLazyTMVar = StrictTMVar + +labelTMVar :: MonadLabelledSTM m => StrictTMVar m a -> String -> STM m () +labelTMVar (StrictTMVar tvar) = Lazy.labelTMVar tvar + +labelTMVarIO :: MonadLabelledSTM m => StrictTMVar m a -> String -> m () +labelTMVarIO v = atomically . labelTMVar v + +traceTMVar :: MonadTraceSTM m + => proxy m + -> StrictTMVar m a + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> STM m () +traceTMVar p (StrictTMVar var) = Lazy.traceTMVar p var + +traceTMVarIO :: MonadTraceSTM m + => StrictTMVar m a + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> m () +traceTMVarIO (StrictTMVar var) = Lazy.traceTMVarIO var + +castStrictTMVar :: LazyTMVar m ~ LazyTMVar n + => StrictTMVar m a -> StrictTMVar n a +castStrictTMVar (StrictTMVar var) = StrictTMVar var + +newTMVar :: MonadSTM m => a -> STM m (StrictTMVar m a) +newTMVar !a = StrictTMVar <$> Lazy.newTMVar a + +newTMVarIO :: MonadSTM m => a -> m (StrictTMVar m a) +newTMVarIO !a = StrictTMVar <$> Lazy.newTMVarIO a + +newTMVarM :: MonadSTM m => a -> m (StrictTMVar m a) +newTMVarM = newTMVarIO +{-# DEPRECATED newTMVarM "Use newTVarIO" #-} + +newEmptyTMVar :: MonadSTM m => STM m (StrictTMVar m a) +newEmptyTMVar = StrictTMVar <$> Lazy.newEmptyTMVar + +newEmptyTMVarIO :: MonadSTM m => m (StrictTMVar m a) +newEmptyTMVarIO = StrictTMVar <$> Lazy.newEmptyTMVarIO + +newEmptyTMVarM :: MonadSTM m => m (StrictTMVar m a) +newEmptyTMVarM = newEmptyTMVarIO +{-# DEPRECATED newEmptyTMVarM "Use newEmptyTMVarIO" #-} + +takeTMVar :: MonadSTM m => StrictTMVar m a -> STM m a +takeTMVar (StrictTMVar tmvar) = Lazy.takeTMVar tmvar + +tryTakeTMVar :: MonadSTM m => StrictTMVar m a -> STM m (Maybe a) +tryTakeTMVar (StrictTMVar tmvar) = Lazy.tryTakeTMVar tmvar + +putTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m () +putTMVar (StrictTMVar tmvar) !a = Lazy.putTMVar tmvar a + +tryPutTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m Bool +tryPutTMVar (StrictTMVar tmvar) !a = Lazy.tryPutTMVar tmvar a + +readTMVar :: MonadSTM m => StrictTMVar m a -> STM m a +readTMVar (StrictTMVar tmvar) = Lazy.readTMVar tmvar + +tryReadTMVar :: MonadSTM m => StrictTMVar m a -> STM m (Maybe a) +tryReadTMVar (StrictTMVar tmvar) = Lazy.tryReadTMVar tmvar + +swapTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m a +swapTMVar (StrictTMVar tmvar) !a = Lazy.swapTMVar tmvar a + +isEmptyTMVar :: MonadSTM m => StrictTMVar m a -> STM m Bool +isEmptyTMVar (StrictTMVar tmvar) = Lazy.isEmptyTMVar tmvar diff --git a/src/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs b/src/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module corresponds to `Control.Concurrent.STM.TQueue` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict.TQueue + ( -- * MonadSTM + StrictTQueue + , LazyTQueue + , toLazyTQueue + , fromLazyTQueue + , castStrictTQueue + , newTQueue + , newTQueueIO + , readTQueue + , tryReadTQueue + , peekTQueue + , tryPeekTQueue + , flushTQueue + , writeTQueue + , unGetTQueue + , isEmptyTQueue + -- * MonadLabelledSTM + , labelTQueue + , labelTQueueIO + -- * MonadTraceSTM + , traceTQueue + , traceTQueueIO + ) where + + +import qualified Control.Concurrent.Class.MonadSTM.TQueue as Lazy +import Control.Monad.Class.MonadSTM hiding (traceTQueue, traceTQueueIO) + + +type LazyTQueue m = Lazy.TQueue m + +newtype StrictTQueue m a = StrictTQueue { toLazyTQueue :: LazyTQueue m a } + +fromLazyTQueue :: LazyTQueue m a -> StrictTQueue m a +fromLazyTQueue = StrictTQueue + +castStrictTQueue :: LazyTQueue m ~ LazyTQueue n + => StrictTQueue m a -> StrictTQueue n a +castStrictTQueue (StrictTQueue var) = StrictTQueue var + +labelTQueue :: MonadLabelledSTM m => StrictTQueue m a -> String -> STM m () +labelTQueue (StrictTQueue queue) = Lazy.labelTQueue queue + +labelTQueueIO :: MonadLabelledSTM m => StrictTQueue m a -> String -> m () +labelTQueueIO (StrictTQueue queue) = Lazy.labelTQueueIO queue + +traceTQueue :: MonadTraceSTM m + => proxy m + -> StrictTQueue m a + -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> STM m () +traceTQueue p (StrictTQueue queue) = Lazy.traceTQueue p queue + +traceTQueueIO :: MonadTraceSTM m + => StrictTQueue m a + -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> m () +traceTQueueIO (StrictTQueue queue) = Lazy.traceTQueueIO queue + +newTQueue :: MonadSTM m => STM m (StrictTQueue m a) +newTQueue = StrictTQueue <$> Lazy.newTQueue + +newTQueueIO :: MonadSTM m => m (StrictTQueue m a) +newTQueueIO = atomically newTQueue + +readTQueue :: MonadSTM m => StrictTQueue m a -> STM m a +readTQueue = Lazy.readTQueue . toLazyTQueue + +tryReadTQueue :: MonadSTM m => StrictTQueue m a -> STM m (Maybe a) +tryReadTQueue = Lazy.tryReadTQueue . toLazyTQueue + +peekTQueue :: MonadSTM m => StrictTQueue m a -> STM m a +peekTQueue = Lazy.peekTQueue . toLazyTQueue + +tryPeekTQueue :: MonadSTM m => StrictTQueue m a -> STM m (Maybe a) +tryPeekTQueue = Lazy.tryPeekTQueue . toLazyTQueue + +flushTQueue :: MonadSTM m => StrictTQueue m a -> STM m [a] +flushTQueue = Lazy.flushTQueue . toLazyTQueue + +writeTQueue :: MonadSTM m => StrictTQueue m a -> a -> STM m () +writeTQueue (StrictTQueue tqueue) !a = Lazy.writeTQueue tqueue a + +isEmptyTQueue :: MonadSTM m => StrictTQueue m a -> STM m Bool +isEmptyTQueue = Lazy.isEmptyTQueue . toLazyTQueue + +unGetTQueue :: MonadSTM m => StrictTQueue m a -> a -> STM m () +unGetTQueue (StrictTQueue queue) !a = Lazy.unGetTQueue queue a + diff --git a/src/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs b/src/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module corresponds to `Control.Concurrent.STM.TVar` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict.TVar + ( -- * StrictTVar + StrictTVar + , LazyTVar + , toLazyTVar + , fromLazyTVar + , castStrictTVar + , newTVar + , newTVarIO + , newTVarWithInvariant + , newTVarWithInvariantIO + , readTVar + , readTVarIO + , writeTVar + , modifyTVar + , stateTVar + , swapTVar + , check + -- ** Low-level API + , checkInvariant + -- ** deprecated API + , updateTVar + , newTVarM + , newTVarWithInvariantM + -- * MonadLabelSTM + , labelTVar + , labelTVarIO + -- * MonadTraceSTM + , traceTVar + , traceTVarIO + ) where + +import qualified Control.Concurrent.Class.MonadSTM.TVar as Lazy +import Control.Monad.Class.MonadSTM hiding (traceTVar, traceTVarIO) + +import GHC.Stack + + +type LazyTVar m = Lazy.TVar m + +#if CHECK_TVAR_INVARIANT +data StrictTVar m a = StrictTVar + { invariant :: !(a -> Maybe String) + -- ^ Invariant checked whenever updating the 'StrictTVar'. + , tvar :: !(LazyTVar m a) + } +#else +newtype StrictTVar m a = StrictTVar + { tvar :: LazyTVar m a + } +#endif + +labelTVar :: MonadLabelledSTM m => StrictTVar m a -> String -> STM m () +labelTVar StrictTVar { tvar } = Lazy.labelTVar tvar + +labelTVarIO :: MonadLabelledSTM m => StrictTVar m a -> String -> m () +labelTVarIO v = atomically . labelTVar v + +traceTVar :: MonadTraceSTM m + => proxy m + -> StrictTVar m a + -> (Maybe a -> a -> InspectMonad m TraceValue) + -> STM m () +traceTVar p StrictTVar {tvar} = Lazy.traceTVar p tvar + +traceTVarIO :: MonadTraceSTM m + => StrictTVar m a + -> (Maybe a -> a -> InspectMonad m TraceValue) + -> m () +traceTVarIO StrictTVar {tvar} = Lazy.traceTVarIO tvar + +castStrictTVar :: LazyTVar m ~ LazyTVar n + => StrictTVar m a -> StrictTVar n a +castStrictTVar v@StrictTVar {tvar} = + mkStrictTVar (getInvariant v) tvar + +-- | Get the underlying @TVar@ +-- +-- Since we obviously cannot guarantee that updates to this 'LazyTVar' will be +-- strict, this should be used with caution. +toLazyTVar :: StrictTVar m a -> LazyTVar m a +toLazyTVar StrictTVar { tvar } = tvar + +fromLazyTVar :: LazyTVar m a -> StrictTVar m a +fromLazyTVar tvar = +#if CHECK_TVAR_INVARIANT + StrictTVar { invariant = const Nothing + , tvar + } +#else + StrictTVar { tvar } +#endif + +newTVar :: MonadSTM m => a -> STM m (StrictTVar m a) +newTVar !a = (\tvar -> mkStrictTVar (const Nothing) tvar) + <$> Lazy.newTVar a + +newTVarIO :: MonadSTM m => a -> m (StrictTVar m a) +newTVarIO = newTVarWithInvariantIO (const Nothing) + +newTVarM :: MonadSTM m => a -> m (StrictTVar m a) +newTVarM = newTVarIO +{-# DEPRECATED newTVarM "Use newTVarIO" #-} + +newTVarWithInvariant :: (MonadSTM m, HasCallStack) + => (a -> Maybe String) -- ^ Invariant (expect 'Nothing') + -> a + -> STM m (StrictTVar m a) +newTVarWithInvariant invariant !a = + checkInvariant (invariant a) $ + (\tvar -> mkStrictTVar invariant tvar) + <$> Lazy.newTVar a + +newTVarWithInvariantIO :: (MonadSTM m, HasCallStack) + => (a -> Maybe String) -- ^ Invariant (expect 'Nothing') + -> a + -> m (StrictTVar m a) +newTVarWithInvariantIO invariant !a = + checkInvariant (invariant a) $ + (\tvar -> mkStrictTVar invariant tvar) + <$> Lazy.newTVarIO a + +newTVarWithInvariantM :: (MonadSTM m, HasCallStack) + => (a -> Maybe String) -- ^ Invariant (expect 'Nothing') + -> a + -> m (StrictTVar m a) +newTVarWithInvariantM = newTVarWithInvariantIO +{-# DEPRECATED newTVarWithInvariantM "Use newTVarWithInvariantIO" #-} + +readTVar :: MonadSTM m => StrictTVar m a -> STM m a +readTVar StrictTVar { tvar } = Lazy.readTVar tvar + +readTVarIO :: MonadSTM m => StrictTVar m a -> m a +readTVarIO StrictTVar { tvar } = Lazy.readTVarIO tvar + +writeTVar :: (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m () +writeTVar v !a = + checkInvariant (getInvariant v a) $ + Lazy.writeTVar (tvar v) a + +modifyTVar :: MonadSTM m => StrictTVar m a -> (a -> a) -> STM m () +modifyTVar v f = readTVar v >>= writeTVar v . f + +stateTVar :: MonadSTM m => StrictTVar m s -> (s -> (a, s)) -> STM m a +stateTVar v f = do + a <- readTVar v + let (b, a') = f a + writeTVar v a' + return b + +swapTVar :: MonadSTM m => StrictTVar m a -> a -> STM m a +swapTVar v a' = do + a <- readTVar v + writeTVar v a' + return a + + +updateTVar :: MonadSTM m => StrictTVar m s -> (s -> (a, s)) -> STM m a +updateTVar = stateTVar +{-# DEPRECATED updateTVar "Use stateTVar" #-} + + +{------------------------------------------------------------------------------- + Dealing with invariants +-------------------------------------------------------------------------------} + +getInvariant :: StrictTVar m a -> a -> Maybe String +mkStrictTVar :: (a -> Maybe String) -> Lazy.TVar m a -> StrictTVar m a + +-- | Check invariant (if enabled) before continuing +-- +-- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws +-- an error @err@ if @mErr == Just err@. +-- +-- This is exported so that other code that wants to conditionally check +-- invariants can reuse the same logic, rather than having to introduce new +-- per-package flags. +checkInvariant :: HasCallStack => Maybe String -> a -> a + +#if CHECK_TVAR_INVARIANT +getInvariant StrictTVar {invariant} = invariant +mkStrictTVar invariant tvar = StrictTVar {invariant, tvar} + +checkInvariant Nothing k = k +checkInvariant (Just err) _ = error $ "Invariant violation: " ++ err +#else +getInvariant _ = \_ -> Nothing +mkStrictTVar _invariant tvar = StrictTVar {tvar} + +checkInvariant _err k = k +#endif diff --git a/strict-stm.cabal b/strict-stm.cabal new file mode 100644 --- /dev/null +++ b/strict-stm.cabal @@ -0,0 +1,75 @@ +cabal-version: 3.0 +name: strict-stm +version: 1.0.0.0 +synopsis: Strict STM interface polymorphic over stm implementation. +description: + Strict STM interface provided on top of + [io-classes](https://hackage.haskell.org/package/io-classes) and thus + compatible with [stm](https://hackage.haskell.org/package/stm) + & [io-sim](https://hackage.haskell.org/package/io-sim). +license: Apache-2.0 +license-files: + LICENSE + NOTICE +copyright: 2019-2023 Input Output Global Inc (IOG) +author: Alexander Vieth, Duncan Coutts, Marcin Szamotulski, Thomas Winant +maintainer: Duncan Coutts dunca@well-typed.com, Marcin Szamotulski coot@coot.me +category: Control +build-type: Simple +extra-source-files: CHANGELOG.md + README.md +tested-with: GHC == { 8.10, 9.2, 9.4 } + +source-repository head + type: git + location: https://github.com/input-output-hk/io-sim + subdir: strict-stm + +flag checktvarinvariant + Description: Enable runtime invariant checks on StrictT(M)Var + Manual: True + Default: False + +flag asserts + description: Enable assertions + manual: False + default: False + +library + hs-source-dirs: src + + exposed-modules: Control.Concurrent.Class.MonadSTM.Strict + Control.Concurrent.Class.MonadSTM.Strict.TArray + Control.Concurrent.Class.MonadSTM.Strict.TBQueue + Control.Concurrent.Class.MonadSTM.Strict.TChan + Control.Concurrent.Class.MonadSTM.Strict.TMVar + Control.Concurrent.Class.MonadSTM.Strict.TQueue + Control.Concurrent.Class.MonadSTM.Strict.TVar + reexported-modules: Control.Concurrent.Class.MonadSTM.TSem as Control.Concurrent.Class.MonadSTM.Strict.TSem + default-language: Haskell2010 + default-extensions: BangPatterns, + CPP, + ExplicitNamespaces, + FlexibleContexts, + FlexibleInstances, + GADTs, + NamedFieldPuns, + TypeOperators + build-depends: base >= 4.9 && <4.18, + array, + stm >= 2.5 && <2.6, + + io-classes ^>= 1.0 + ghc-options: -Wall + -Wno-unticked-promoted-constructors + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + + if flag(asserts) + ghc-options: -fno-ignore-asserts + + if flag(checktvarinvariant) + cpp-options: -DCHECK_TVAR_INVARIAN