X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FConcurrent%2FMVar.hs;h=352d01ec138dfcefc6d50548273475680218245f;hb=167f2174f717dc3698c9e66928860cd8e6fb822b;hp=7213cf14c5ff15e178c78795c7961c0037d6744c;hpb=7963d762784ec906ad5b7f22ed4020c2fb40df08;p=ghc-base.git

diff --git a/Control/Concurrent/MVar.hs b/Control/Concurrent/MVar.hs
index 7213cf1..352d01e 100644
--- a/Control/Concurrent/MVar.hs
+++ b/Control/Concurrent/MVar.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Concurrent.MVar
@@ -13,40 +14,45 @@
 -----------------------------------------------------------------------------
 
 module Control.Concurrent.MVar
-	( 
-	  -- * @MVar@s
-	  MVar		-- abstract
-	, newEmptyMVar  -- :: IO (MVar a)
-	, newMVar 	-- :: a -> IO (MVar a)
-	, takeMVar 	-- :: MVar a -> IO a
-	, putMVar  	-- :: MVar a -> a -> IO ()
-	, readMVar 	-- :: MVar a -> IO a
-	, swapMVar 	-- :: MVar a -> a -> IO a
-	, tryTakeMVar   -- :: MVar a -> IO (Maybe a)
-	, tryPutMVar    -- :: MVar a -> a -> IO Bool
-	, isEmptyMVar	-- :: MVar a -> IO Bool
-	, withMVar	-- :: MVar a -> (a -> IO b) -> IO b
-	, modifyMVar_ 	-- :: MVar a -> (a -> IO a) -> IO ()
-	, modifyMVar 	-- :: MVar a -> (a -> IO (a,b)) -> IO b
+        (
+          -- * @MVar@s
+          MVar          -- abstract
+        , newEmptyMVar  -- :: IO (MVar a)
+        , newMVar       -- :: a -> IO (MVar a)
+        , takeMVar      -- :: MVar a -> IO a
+        , putMVar       -- :: MVar a -> a -> IO ()
+        , readMVar      -- :: MVar a -> IO a
+        , swapMVar      -- :: MVar a -> a -> IO a
+        , tryTakeMVar   -- :: MVar a -> IO (Maybe a)
+        , tryPutMVar    -- :: MVar a -> a -> IO Bool
+        , isEmptyMVar   -- :: MVar a -> IO Bool
+        , withMVar      -- :: MVar a -> (a -> IO b) -> IO b
+        , modifyMVar_   -- :: MVar a -> (a -> IO a) -> IO ()
+        , modifyMVar    -- :: MVar a -> (a -> IO (a,b)) -> IO b
 #ifndef __HUGS__
-	, addMVarFinalizer -- :: MVar a -> IO () -> IO ()
+        , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
 #endif
     ) where
 
 #ifdef __HUGS__
 import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
-		  tryTakeMVar, tryPutMVar, isEmptyMVar,
-		)
+                  tryTakeMVar, tryPutMVar, isEmptyMVar,
+                )
 #endif
 
 #ifdef __GLASGOW_HASKELL__
-import GHC.Conc	( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
-		  tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer
-		)
+import GHC.MVar ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
+                  tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer
+                )
 #endif
 
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+#else
 import Prelude
-import Control.Exception as Exception
+#endif
+
+import Control.Exception.Base
 
 {-|
   This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value
@@ -59,7 +65,12 @@ readMVar m =
     putMVar m a
     return a
 
--- |Swap the contents of an 'MVar' for a new value.
+{-|
+  Take a value from an 'MVar', put a new value into the 'MVar' and
+  return the value taken. Note that there is a race condition whereby
+  another process can put something in the 'MVar' after the take
+  happens but before the put does.
+-}
 swapMVar :: MVar a -> a -> IO a
 swapMVar mvar new =
   block $ do
@@ -77,11 +88,10 @@ swapMVar mvar new =
 -- inlining has been reported to have dramatic effects; see
 -- http://www.haskell.org//pipermail/haskell/2006-May/017907.html
 withMVar :: MVar a -> (a -> IO b) -> IO b
-withMVar m io = 
+withMVar m io =
   block $ do
     a <- takeMVar m
-    b <- Exception.catch (unblock (io a))
-      	    (\e -> do putMVar m a; throw e)
+    b <- unblock (io a) `onException` putMVar m a
     putMVar m a
     return b
 
@@ -92,11 +102,10 @@ withMVar m io =
 -}
 {-# INLINE modifyMVar_ #-}
 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
-modifyMVar_ m io = 
+modifyMVar_ m io =
   block $ do
     a  <- takeMVar m
-    a' <- Exception.catch (unblock (io a))
-      	    (\e -> do putMVar m a; throw e)
+    a' <- unblock (io a) `onException` putMVar m a
     putMVar m a'
 
 {-|
@@ -105,10 +114,9 @@ modifyMVar_ m io =
 -}
 {-# INLINE modifyMVar #-}
 modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
-modifyMVar m io = 
+modifyMVar m io =
   block $ do
     a      <- takeMVar m
-    (a',b) <- Exception.catch (unblock (io a))
-      	        (\e -> do putMVar m a; throw e)
+    (a',b) <- unblock (io a) `onException` putMVar m a
     putMVar m a'
     return b