From fcf1a95395777c7335f3313795d3495abf29b921 Mon Sep 17 00:00:00 2001
From: Ross Paterson <ross@soi.city.ac.uk>
Date: Tue, 13 Jun 2006 14:27:51 +0000
Subject: [PATCH] offer a subset of the interface to sequential implementations
---
Control/Concurrent/STM.hs | 21 +++++++++++-
Control/Concurrent/STM/TArray.hs | 4 +++
Control/Concurrent/STM/TVar.hs | 5 ++-
Control/Sequential/STM.hs | 59 ++++++++++++++++++++++++++++++++
LICENSE | 31 +++++++++++++++++
Makefile | 2 +-
stm.cabal | 16 +++++++++
7 files changed, 135 insertions(+), 3 deletions(-)
create mode 100644 Control/Sequential/STM.hs
create mode 100644 LICENSE
create mode 100644 stm.cabal
diff --git a/Control/Concurrent/STM.hs b/Control/Concurrent/STM.hs
index 1c9d623..31281b3 100644
--- a/Control/Concurrent/STM.hs
+++ b/Control/Concurrent/STM.hs
@@ -9,7 +9,12 @@
-- Portability : non-portable (requires STM)
--
-- Software Transactional Memory: a modular composable concurrency
--- abstraction.
+-- abstraction. See
+--
+-- * /Composable memory transactions/, by Tim Harris, Simon Marlow, Simon
+-- Peyton Jones, and Maurice Herlihy, in /ACM Conference on Principles
+-- and Practice of Parallel Programming/ 2005.
+-- <http://research.microsoft.com/Users/simonpj/papers/stm/index.htm>
--
-----------------------------------------------------------------------------
@@ -17,35 +22,49 @@ module Control.Concurrent.STM (
-- * The STM monad and basic operations
STM,
atomically,
+#ifdef __GLASGOW_HASKELL__
retry,
orElse,
check,
+#endif
catchSTM,
+#ifdef __GLASGOW_HASKELL__
registerDelay,
+#endif
-- * TVars
module Control.Concurrent.STM.TVar,
+#ifdef __GLASGOW_HASKELL__
-- * TMVars
module Control.Concurrent.STM.TMVar,
-- * TChan
module Control.Concurrent.STM.TChan,
+#endif
-- * TArray
module Control.Concurrent.STM.TArray
) where
+#ifdef __GLASGOW_HASKELL__
import GHC.Conc
import Control.Monad ( MonadPlus(..) )
+#else
+import Control.Sequential.STM
+#endif
import Control.Concurrent.STM.TVar
+#ifdef __GLASGOW_HASKELL__
import Control.Concurrent.STM.TMVar
import Control.Concurrent.STM.TChan
+#endif
import Control.Concurrent.STM.TArray
+#ifdef __GLASGOW_HASKELL__
instance MonadPlus STM where
mzero = retry
mplus = orElse
check :: Bool -> STM a
check b = if b then return undefined else retry
+#endif
diff --git a/Control/Concurrent/STM/TArray.hs b/Control/Concurrent/STM/TArray.hs
index f4f6538..709806a 100644
--- a/Control/Concurrent/STM/TArray.hs
+++ b/Control/Concurrent/STM/TArray.hs
@@ -22,7 +22,11 @@ import Data.Array (Array)
import Data.Array.Base (listArray, arrEleBottom, unsafeAt, MArray(..), HasBounds(..))
import Data.Ix (rangeSize)
import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar, writeTVar)
+#ifdef __GLASGOW_HASKELL__
import GHC.Conc (STM)
+#else
+import Control.Sequential.STM (STM)
+#endif
-- |TArray is a transactional array, supporting the usual 'MArray'
-- interface for mutable arrays.
diff --git a/Control/Concurrent/STM/TVar.hs b/Control/Concurrent/STM/TVar.hs
index b8b7ad9..ee9734e 100644
--- a/Control/Concurrent/STM/TVar.hs
+++ b/Control/Concurrent/STM/TVar.hs
@@ -21,5 +21,8 @@ module Control.Concurrent.STM.TVar (
newTVarIO
) where
+#ifdef __GLASGOW_HASKELL__
import GHC.Conc
-
+#else
+import Control.Sequential.STM
+#endif
diff --git a/Control/Sequential/STM.hs b/Control/Sequential/STM.hs
new file mode 100644
index 0000000..9ce7fa0
--- /dev/null
+++ b/Control/Sequential/STM.hs
@@ -0,0 +1,59 @@
+-- Transactional memory for sequential implementations.
+-- Transactions do not run concurrently, but are atomic in the face
+-- of exceptions.
+
+-- #hide
+module Control.Sequential.STM (
+ STM, atomically, catchSTM,
+ TVar, newTVar, newTVarIO, readTVar, writeTVar
+ ) where
+
+import Prelude hiding (catch)
+import Control.Exception
+import Data.IORef
+
+-- The reference contains a rollback action to be executed on exceptions
+newtype STM a = STM (IORef (IO ()) -> IO a)
+
+unSTM :: STM a -> IORef (IO ()) -> IO a
+unSTM (STM f) = f
+
+instance Functor STM where
+ fmap f (STM m) = STM (fmap f . m)
+
+instance Monad STM where
+ return x = STM (const (return x))
+ STM m >>= k = STM $ \ r -> do
+ x <- m r
+ unSTM (k x) r
+
+atomically :: STM a -> IO a
+atomically (STM m) = do
+ r <- newIORef (return ())
+ m r `catch` \ ex -> do
+ rollback <- readIORef r
+ rollback
+ throw ex
+
+catchSTM :: STM a -> (Exception -> STM a) -> STM a
+catchSTM (STM m) h = STM $ \ r -> m r `catch` \ ex -> unSTM (h ex) r
+
+newtype TVar a = TVar (IORef a)
+ deriving (Eq)
+
+newTVar :: a -> STM (TVar a)
+newTVar a = STM (const (newTVarIO a))
+
+newTVarIO :: a -> IO (TVar a)
+newTVarIO a = do
+ ref <- newIORef a
+ return (TVar ref)
+
+readTVar :: TVar a -> STM a
+readTVar (TVar ref) = STM (const (readIORef ref))
+
+writeTVar :: TVar a -> a -> STM ()
+writeTVar (TVar ref) a = STM $ \ r -> do
+ oldval <- readIORef ref
+ modifyIORef r (writeIORef ref oldval >>)
+ writeIORef ref a
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..4ec14bf
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,31 @@
+The Glasgow Haskell Compiler License
+
+Copyright 2004, The University Court of the University of Glasgow.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+- 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.
+
+- Neither name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF
+GLASGOW AND THE 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
+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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/Makefile b/Makefile
index 79423e4..121d3de 100644
--- a/Makefile
+++ b/Makefile
@@ -9,7 +9,7 @@ PACKAGE = stm
VERSION = 1.0
PACKAGE_DEPS = base
-SRC_HC_OPTS += -fglasgow-exts
+SRC_HC_OPTS += -fglasgow-exts -cpp
SRC_HADDOCK_OPTS += -t "Haskell Hierarchical Libraries (stm package)"
diff --git a/stm.cabal b/stm.cabal
new file mode 100644
index 0000000..dde2a78
--- /dev/null
+++ b/stm.cabal
@@ -0,0 +1,16 @@
+name: stm
+version: 1.0
+license: BSD3
+license-file: LICENSE
+maintainer: libraries@haskell.org
+synopsis: Software Transactional Memory
+description: A modular composable concurrency abstraction.
+-- these are the modules exposed by the cut-down non-GHC interface.
+exposed-modules:
+ Control.Concurrent.STM
+ Control.Concurrent.STM.TArray
+ Control.Concurrent.STM.TVar
+other-modules:
+ Control.Sequential.STM
+build-depends: base
+extensions: CPP
--
GitLab