Control/Concurrent/MVar.hs

   1 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  Control.Concurrent.MVar
   5 -- Copyright   :  (c) The University of Glasgow 2001
   6 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   7 --
   8 -- Maintainer  :  libraries@haskell.org
   9 -- Stability   :  experimental
  10 -- Portability :  non-portable (concurrency)
  11 --
  12 -- Synchronising variables
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 module Control.Concurrent.MVar
  17         (
  18           -- * @MVar@s
  19           MVar          -- abstract
  20         , newEmptyMVar  -- :: IO (MVar a)
  21         , newMVar       -- :: a -> IO (MVar a)
  22         , takeMVar      -- :: MVar a -> IO a
  23         , putMVar       -- :: MVar a -> a -> IO ()
  24         , readMVar      -- :: MVar a -> IO a
  25         , swapMVar      -- :: MVar a -> a -> IO a
  26         , tryTakeMVar   -- :: MVar a -> IO (Maybe a)
  27         , tryPutMVar    -- :: MVar a -> a -> IO Bool
  28         , isEmptyMVar   -- :: MVar a -> IO Bool
  29         , withMVar      -- :: MVar a -> (a -> IO b) -> IO b
  30         , modifyMVar_   -- :: MVar a -> (a -> IO a) -> IO ()
  31         , modifyMVar    -- :: MVar a -> (a -> IO (a,b)) -> IO b
  32 #ifndef __HUGS__
  33         , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
  34 #endif
  35     ) where
  36
  37 #ifdef __HUGS__
  38 import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
  39                   tryTakeMVar, tryPutMVar, isEmptyMVar,
  40                 )
  41 #endif
  42
  43 #ifdef __GLASGOW_HASKELL__
  44 import GHC.MVar ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
  45                   tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer
  46                 )
  47 #endif
  48
  49 #ifdef __GLASGOW_HASKELL__
  50 import GHC.Base
  51 #else
  52 import Prelude
  53 #endif
  54
  55 import Control.Exception.Base
  56
  57 {-|
  58   This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value
  59   from the 'MVar', puts it back, and also returns it.
  60 -}
  61 readMVar :: MVar a -> IO a
  62 readMVar m =
  63   mask_ $ do
  64     a <- takeMVar m
  65     putMVar m a
  66     return a
  67
  68 {-|
  69   Take a value from an 'MVar', put a new value into the 'MVar' and
  70   return the value taken. Note that there is a race condition whereby
  71   another process can put something in the 'MVar' after the take
  72   happens but before the put does.
  73 -}
  74 swapMVar :: MVar a -> a -> IO a
  75 swapMVar mvar new =
  76   mask_ $ do
  77     old <- takeMVar mvar
  78     putMVar mvar new
  79     return old
  80
  81 {-|
  82   'withMVar' is a safe wrapper for operating on the contents of an
  83   'MVar'.  This operation is exception-safe: it will replace the
  84   original contents of the 'MVar' if an exception is raised (see
  85   "Control.Exception").
  86 -}
  87 {-# INLINE withMVar #-}
  88 -- inlining has been reported to have dramatic effects; see
  89 -- http://www.haskell.org//pipermail/haskell/2006-May/017907.html
  90 withMVar :: MVar a -> (a -> IO b) -> IO b
  91 withMVar m io =
  92   mask $ \restore -> do
  93     a <- takeMVar m
  94     b <- restore (io a) `onException` putMVar m a
  95     putMVar m a
  96     return b
  97
  98 {-|
  99   A safe wrapper for modifying the contents of an 'MVar'.  Like 'withMVar',
 100   'modifyMVar' will replace the original contents of the 'MVar' if an
 101   exception is raised during the operation.
 102 -}
 103 {-# INLINE modifyMVar_ #-}
 104 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
 105 modifyMVar_ m io =
 106   mask $ \restore -> do
 107     a  <- takeMVar m
 108     a' <- restore (io a) `onException` putMVar m a
 109     putMVar m a'
 110
 111 {-|
 112   A slight variation on 'modifyMVar_' that allows a value to be
 113   returned (@b@) in addition to the modified value of the 'MVar'.
 114 -}
 115 {-# INLINE modifyMVar #-}
 116 modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
 117 modifyMVar m io =
 118   mask $ \restore -> do
 119     a      <- takeMVar m
 120     (a',b) <- restore (io a) `onException` putMVar m a
 121     putMVar m a'
 122     return b