X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FConcurrent%2FMVar.hs;h=2fda9f79c8324722bae37a3a363600ea12552eee;hb=a4f3f0790c84739ab08ee0e41a4b7a7132cdba0b;hp=eb1f03ff2c6a91d388af8d6f6c82099d03de2cb1;hpb=f7a485978f04e84b086f1974b88887cc72d832d0;p=ghc-base.git diff --git a/Control/Concurrent/MVar.hs b/Control/Concurrent/MVar.hs index eb1f03f..2fda9f7 100644 --- a/Control/Concurrent/MVar.hs +++ b/Control/Concurrent/MVar.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.MVar @@ -6,88 +8,226 @@ -- -- Maintainer : libraries@haskell.org -- Stability : experimental --- Portability : non-portable +-- Portability : non-portable (concurrency) +-- +-- An @'MVar' t@ is mutable location that is either empty or contains a +-- value of type @t@. It has two fundamental operations: 'putMVar' +-- which fills an 'MVar' if it is empty and blocks otherwise, and +-- 'takeMVar' which empties an 'MVar' if it is full and blocks +-- otherwise. They can be used in multiple different ways: +-- +-- 1. As synchronized mutable variables, +-- 2. As channels, with 'takeMVar' and 'putMVar' as receive and send, and +-- 3. As a binary semaphore @'MVar' ()@, with 'takeMVar' and 'putMVar' as +-- wait and signal. +-- +-- They were introduced in the paper "Concurrent Haskell" by Simon +-- Peyton Jones, Andrew Gordon and Sigbjorn Finne, though some details +-- of their implementation have since then changed (in particular, a +-- put on a full MVar used to error, but now merely blocks.) +-- +-- * Applicability +-- +-- 'MVar's offer more flexibility than 'IORef's, but less flexibility +-- than 'STM'. They are appropriate for building synchronization +-- primitives and performing simple interthread communication; however +-- they are very simple and susceptible to race conditions, deadlocks or +-- uncaught exceptions. Do not use them if you need perform larger +-- atomic operations such as reading from multiple variables: use 'STM' +-- instead. +-- +-- In particular, the "bigger" functions in this module ('readMVar', +-- 'swapMVar', 'withMVar', 'modifyMVar_' and 'modifyMVar') are simply +-- the composition of a 'takeMVar' followed by a 'putMVar' with +-- exception safety. +-- These only have atomicity guarantees if all other threads +-- perform a 'takeMVar' before a 'putMVar' as well; otherwise, they may +-- block. +-- +-- * Fairness +-- +-- No thread can be blocked indefinitely on an 'MVar' unless another +-- thread holds that 'MVar' indefinitely. One usual implementation of +-- this fairness guarantee is that threads blocked on an 'MVar' are +-- served in a first-in-first-out fashion, but this is not guaranteed +-- in the semantics. +-- +-- * Gotchas +-- +-- Like many other Haskell data structures, 'MVar's are lazy. This +-- means that if you place an expensive unevaluated thunk inside an +-- 'MVar', it will be evaluated by the thread that consumes it, not the +-- thread that produced it. Be sure to 'evaluate' values to be placed +-- in an 'MVar' to the appropriate normal form, or utilize a strict +-- MVar provided by the strict-concurrency package. +-- +-- * Ordering +-- +-- 'MVar' operations are always observed to take place in the order +-- they are written in the program, regardless of the memory model of +-- the underlying machine. This is in contrast to 'IORef' operations +-- which may appear out-of-order to another thread in some cases. +-- +-- * Example -- --- MVars: Synchronising variables +-- Consider the following concurrent data structure, a skip channel. +-- This is a channel for an intermittent source of high bandwidth +-- information (for example, mouse movement events.) Writing to the +-- channel never blocks, and reading from the channel only returns the +-- most recent value, or blocks if there are no new values. Multiple +-- readers are supported with a @dupSkipChan@ operation. +-- +-- A skip channel is a pair of 'MVar's. The first 'MVar' contains the +-- current value, and a list of semaphores that need to be notified +-- when it changes. The second 'MVar' is a semaphore for this particular +-- reader: it is full if there is a value in the channel that this +-- reader has not read yet, and empty otherwise. +-- +-- @ +-- data SkipChan a = SkipChan (MVar (a, [MVar ()])) (MVar ()) +-- +-- newSkipChan :: IO (SkipChan a) +-- newSkipChan = do +-- sem <- newEmptyMVar +-- main <- newMVar (undefined, [sem]) +-- return (SkipChan main sem) +-- +-- putSkipChan :: SkipChan a -> a -> IO () +-- putSkipChan (SkipChan main _) v = do +-- (_, sems) <- takeMVar main +-- putMVar main (v, []) +-- mapM_ (\sem -> putMVar sem ()) sems +-- +-- getSkipChan :: SkipChan a -> IO a +-- getSkipChan (SkipChan main sem) = do +-- takeMVar sem +-- (v, sems) <- takeMVar main +-- putMVar main (v, sem:sems) +-- return v +-- +-- dupSkipChan :: SkipChan a -> IO (SkipChan a) +-- dupSkipChan (SkipChan main _) = do +-- sem <- newEmptyMVar +-- (v, sems) <- takeMVar main +-- putMVar main (v, sem:sems) +-- return (SkipChan main sem) +-- @ +-- +-- This example was adapted from the original Concurrent Haskell paper. +-- For more examples of 'MVar's being used to build higher-level +-- synchronization primitives, see 'Control.Concurrent.Chan' and +-- 'Control.Concurrent.QSem'. -- ----------------------------------------------------------------------------- module Control.Concurrent.MVar - ( 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 Prelude hiding( catch ) +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 -import Control.Exception as Exception - -#ifdef __HUGS__ --- This is as close as Hugs gets to providing throw -throw :: Exception -> IO a -throw = throwIO +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#else +import Prelude #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. This function + is atomic only if there are no other producers (i.e. threads calling + 'putMVar') for this 'MVar'. +-} readMVar :: MVar a -> IO a readMVar m = - block $ do + mask_ $ do a <- takeMVar m putMVar m a return a +{-| + Take a value from an 'MVar', put a new value into the 'MVar' and + return the value taken. This function is atomic only if there are + no other producers for this 'MVar'. +-} 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 --- put back the same value, return something +{-| + 'withMVar' is an exception-safe wrapper for operating on the contents + of an 'MVar'. This operation is exception-safe: it will replace the + original contents of the 'MVar' if an exception is raised (see + "Control.Exception"). However, it is only atomic if there are no + other producers for this 'MVar'. +-} +{-# 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 --- put back a new value, return () +{-| + An exception-safe wrapper for modifying the contents of an 'MVar'. + Like 'withMVar', 'modifyMVar' will replace the original contents of + the 'MVar' if an exception is raised during the operation. This + function is only atomic if there are no other producers for this + 'MVar'. +-} +{-# 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' --- put back a new value, return something +{-| + 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