Use explicit language extensions & remove extension fields from base.cabal

[ghc-base.git] / Control / Concurrent / MVar.hs

diff --git a/Control/Concurrent/MVar.hs b/Control/Concurrent/MVar.hs
index ef1a2e6..9a95b8f 100644 (file)
--- a/Control/Concurrent/MVar.hs
+++ b/Control/Concurrent/MVar.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP, NoImplicitPrelude #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Concurrent.MVar
@@ -13,62 +15,69 @@
 -----------------------------------------------------------------------------
 
 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
-       , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
+        (
+          -- * @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 ()
+#endif
     ) where
 
 #ifdef __HUGS__
-import ConcBase        ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
-                 tryTakeMVar, tryPutMVar, isEmptyMVar,
-                  readMVar, swapMVar,
-               )
+import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
+                  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
-
-#ifdef __HUGS__
--- This is as close as Hugs gets to providing throw
-throw :: Exception -> IO a
-throw = throwIO
 #endif
 
-#ifdef __GLASGOW_HASKELL__
+import Control.Exception.Base
+
 {-|
   This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value
   from the 'MVar', puts it back, and also returns it.
 -}
 readMVar :: MVar a -> IO a
 readMVar m =
-  block $ do
+  mask_ $ do
     a <- takeMVar 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 = modifyMVar mvar (\old -> return (new,old))
-#endif
+swapMVar mvar new =
+  mask_ $ do
+    old <- takeMVar mvar
+    putMVar mvar new
+    return old
 
 {-|
   'withMVar' is a safe wrapper for operating on the contents of an
@@ -76,12 +85,14 @@ swapMVar mvar new = modifyMVar mvar (\old -> return (new,old))
   original contents of the 'MVar' if an exception is raised (see
   "Control.Exception").
 -}
+{-# INLINE withMVar #-}
+-- 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 = 
-  block $ do
+withMVar m io =
+  mask $ \restore -> do
     a <- takeMVar m
-    b <- Exception.catch (unblock (io a))
-           (\e -> do putMVar m a; throw e)
+    b <- restore (io a) `onException` putMVar m a
     putMVar m a
     return b
 
@@ -90,23 +101,23 @@ withMVar m io =
   'modifyMVar' will replace the original contents of the 'MVar' if an
   exception is raised during the operation.
 -}
+{-# INLINE modifyMVar_ #-}
 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
-modifyMVar_ m io = 
-  block $ do
+modifyMVar_ m io =
+  mask $ \restore -> do
     a  <- takeMVar m
-    a' <- Exception.catch (unblock (io a))
-           (\e -> do putMVar m a; throw e)
+    a' <- restore (io a) `onException` putMVar m a
     putMVar m a'
 
 {-|
   A slight variation on 'modifyMVar_' that allows a value to be
   returned (@b@) in addition to the modified value of the 'MVar'.
 -}
+{-# INLINE modifyMVar #-}
 modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
-modifyMVar m io = 
-  block $ do
+modifyMVar m io =
+  mask $ \restore -> do
     a      <- takeMVar m
-    (a',b) <- Exception.catch (unblock (io a))
-               (\e -> do putMVar m a; throw e)
+    (a',b) <- restore (io a) `onException` putMVar m a
     putMVar m a'
     return b