[project @ 2004-11-18 09:56:07 by tharris]

Support for atomic memory transactions and associated regression tests conc041-048

4 files changed, 78 insertions, 1 deletions

diff --git a/ghc/compiler/codeGen/CgPrimOp.hs b/ghc/compiler/codeGen/CgPrimOp.hs
index 65ad0cc724..5c01903c8c 100644
--- a/ghc/compiler/codeGen/CgPrimOp.hs
+++ b/ghc/compiler/codeGen/CgPrimOp.hs
@@ -486,6 +486,7 @@ translateOp SameMutVarOp           = Just mo_wordEq
 translateOp SameMVarOp             = Just mo_wordEq
 translateOp SameMutableArrayOp     = Just mo_wordEq
 translateOp SameMutableByteArrayOp = Just mo_wordEq
+translateOp SameTVarOp             = Just mo_wordEq
 translateOp EqForeignObj           = Just mo_wordEq
 translateOp EqStablePtrOp          = Just mo_wordEq
 
diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index 893fed28a0..f534abe659 100644
--- a/ghc/compiler/prelude/PrelNames.lhs
+++ b/ghc/compiler/prelude/PrelNames.lhs
@@ -789,6 +789,7 @@ threadIdPrimTyConKey			= mkPreludeTyConUnique 72
 bcoPrimTyConKey				= mkPreludeTyConUnique 73
 ptrTyConKey				= mkPreludeTyConUnique 74
 funPtrTyConKey				= mkPreludeTyConUnique 75
+tVarPrimTyConKey		    	= mkPreludeTyConUnique 76
 
 -- Generic Type Constructors
 crossTyConKey		      		= mkPreludeTyConUnique 79
diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs
index 0cc59d98f7..155fdf8238 100644
--- a/ghc/compiler/prelude/TysPrim.lhs
+++ b/ghc/compiler/prelude/TysPrim.lhs
@@ -28,6 +28,7 @@ module TysPrim(
 	mutVarPrimTyCon,		mkMutVarPrimTy,
 
 	mVarPrimTyCon,			mkMVarPrimTy,	
+        tVarPrimTyCon,                  mkTVarPrimTy,
 	stablePtrPrimTyCon,		mkStablePtrPrimTy,
 	stableNamePrimTyCon,		mkStableNamePrimTy,
 	bcoPrimTyCon,			bcoPrimTy,
@@ -87,6 +88,7 @@ primTyCons
     , mutableArrayPrimTyCon
     , mutableByteArrayPrimTyCon
     , mVarPrimTyCon
+    , tVarPrimTyCon
     , mutVarPrimTyCon
     , realWorldTyCon
     , stablePtrPrimTyCon
@@ -124,6 +126,7 @@ mutableArrayPrimTyConName     = mkPrimTc FSLIT("MutableArray#") mutableArrayPrim
 mutableByteArrayPrimTyConName = mkPrimTc FSLIT("MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon
 mutVarPrimTyConName	      = mkPrimTc FSLIT("MutVar#") mutVarPrimTyConKey mutVarPrimTyCon
 mVarPrimTyConName	      = mkPrimTc FSLIT("MVar#") mVarPrimTyConKey mVarPrimTyCon
+tVarPrimTyConName	      = mkPrimTc FSLIT("TVar#") tVarPrimTyConKey tVarPrimTyCon
 stablePtrPrimTyConName        = mkPrimTc FSLIT("StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon
 stableNamePrimTyConName       = mkPrimTc FSLIT("StableName#") stableNamePrimTyConKey stableNamePrimTyCon
 foreignObjPrimTyConName       = mkPrimTc FSLIT("ForeignObj#") foreignObjPrimTyConKey foreignObjPrimTyCon
@@ -314,6 +317,18 @@ mkMVarPrimTy s elt 	    = mkTyConApp mVarPrimTyCon [s, elt]
 
 %************************************************************************
 %*									*
+\subsection[TysPrim-stm-var]{The transactional variable type}
+%*									*
+%************************************************************************
+
+\begin{code}
+tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName vrcsZP PtrRep
+
+mkTVarPrimTy s elt 	    = mkTyConApp tVarPrimTyCon [s, elt]
+\end{code}
+
+%************************************************************************
+%*									*
 \subsection[TysPrim-stable-ptrs]{The stable-pointer type}
 %*									*
 %************************************************************************
diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp
index 4d7d4d9198..04a7885e0c 100644
--- a/ghc/compiler/prelude/primops.txt.pp
+++ b/ghc/compiler/prelude/primops.txt.pp
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------
--- $Id: primops.txt.pp,v 1.30 2003/10/01 10:57:39 wolfgang Exp $
+-- $Id: primops.txt.pp,v 1.31 2004/11/18 09:56:15 tharris Exp $
 --
 -- Primitive Operations
 --
@@ -1334,6 +1334,66 @@ primop  UnblockAsyncExceptionsOp "unblockAsyncExceptions#" GenPrimOp
    out_of_line = True
 
 ------------------------------------------------------------------------
+section "STM-accessible Mutable Variables"
+------------------------------------------------------------------------
+
+primop	AtomicallyOp "atomically#" GenPrimOp
+      (State# RealWorld -> (# State# RealWorld, a #) )
+   -> State# RealWorld -> (# State# RealWorld, a #)
+   with
+   out_of_line = True
+   has_side_effects = True
+
+primop  RetryOp "retry#" GenPrimOp
+   State# RealWorld -> (# State# RealWorld, a #)
+   with 
+   out_of_line = True
+   has_side_effects = True
+
+primop  CatchRetryOp "catchRetry#" GenPrimOp
+      (State# RealWorld -> (# State# RealWorld, a #) )
+   -> (State# RealWorld -> (# State# RealWorld, a #) )
+   -> (State# RealWorld -> (# State# RealWorld, a #) )
+   with 
+   out_of_line = True
+   has_side_effects = True
+
+primop  CatchSTMOp "catchSTM#" GenPrimOp
+      (State# RealWorld -> (# State# RealWorld, a #) )
+   -> (b -> State# RealWorld -> (# State# RealWorld, a #) )
+   -> (State# RealWorld -> (# State# RealWorld, a #) )
+   with 
+   out_of_line = True
+   has_side_effects = True
+
+primop	NewTVarOp "newTVar#" GenPrimOp
+       a
+    -> State# s -> (# State# s, TVar# s a #)
+   {Create a new Tar\# holding a specified initial value.}
+   with
+   out_of_line  = True
+
+primop	ReadTVarOp "readTVar#" GenPrimOp
+       TVar# s a
+    -> State# s -> (# State# s, a #)
+   {Read contents of TVar\#.  Result is not yet evaluated.}
+   with
+   out_of_line	= True
+
+primop	WriteTVarOp "writeTVar#" GenPrimOp
+       TVar# s a
+    -> a
+    -> State# s -> State# s
+   {Write contents of TVar\#.}
+   with
+   out_of_line	    = True
+   has_side_effects = True
+
+primop  SameTVarOp "sameTVar#" GenPrimOp
+   TVar# s a -> TVar# s a -> Bool
+
+
+------------------------------------------------------------------------
 section "Synchronized Mutable Variables"
 	{Operations on MVar\#s, which are shared mutable variables
 	({\it not} the same as MutVar\#s!). (Note: in a non-concurrent implementation,