diff options
Diffstat (limited to 'Control/Concurrent')
| -rw-r--r-- | Control/Concurrent/MSampleVar.hs | 164 |
1 files changed, 164 insertions, 0 deletions
diff --git a/Control/Concurrent/MSampleVar.hs b/Control/Concurrent/MSampleVar.hs new file mode 100644 index 0000000..578d391 --- /dev/null +++ b/Control/Concurrent/MSampleVar.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DeriveDataTypeable, CPP #-} +-- +-- Module : Control.Concurrent.MSampleVar +-- Copyright : (c) Chris Kuklewicz 2011 +-- License : 3 clause BSD-style (see the file LICENSE) +-- +-- Maintainer : haskell@list.mightyreason.com +-- Stability : experimental +-- Portability : non-portable (concurrency) +-- + +-- | 'MSampleVar' is a safer version of the "Control.Concurrent.SampleVar" in +-- base. The same problem as QSem(N) is being fixed, that of handling waiters +-- that die before being woken normally. For "Control.Concurrent.SampleVar" in +-- base this error can lead to thinking a full 'SampleVar' is really empty and +-- cause 'writeSampleVar' to hang. The 'MSampleVar' in this module is immune +-- to this error, and has a simpler implementation. +-- +module Control.Concurrent.MSampleVar + ( -- * Sample Variables + MSampleVar, + newEmptySV, -- :: IO (MSampleVar a) + newSV, -- :: a -> IO (MSampleVar a) + emptySV, -- :: MSampleVar a -> IO () + readSV, -- :: MSampleVar a -> IO a + writeSV, -- :: MSampleVar a -> a -> IO () + isEmptySV, -- :: MSampleVar a -> IO Bool + ) where + +import Control.Monad(void,join) +import Control.Concurrent.MVar(MVar,newMVar,newEmptyMVar,tryTakeMVar,takeMVar,putMVar,withMVar,isEmptyMVar) +import Control.Exception(mask_) +import Data.Typeable + +-- | +-- Sample variables are slightly different from a normal 'MVar': +-- +-- * Reading an empty 'MSampleVar' causes the reader to block. +-- (same as 'takeMVar' on empty 'MVar') +-- +-- * Reading a filled 'MSampleVar' empties it and returns value. +-- (same as 'takeMVar') +-- +-- * Try reading a filled 'MSampleVar' returns a Maybe value. +-- (same as 'tryTakeMVar') +-- +-- * Writing to an empty 'MSampleVar' fills it with a value, and +-- potentially, wakes up a blocked reader (same as for 'putMVar' on +-- empty 'MVar'). +-- +-- * Writing to a filled 'MSampleVar' overwrites the current value. +-- (different from 'putMVar' on full 'MVar'.) +-- +-- The readers queue in FIFO order, with the lead reader joining the writers in +-- a second FIFO queue to access the stored value. Thus writers can jump the +-- queue of non-leading waiting readers to update the value, but the lead +-- reader has to wait on all previous writes to finish before taking the value. +-- +-- This design choice emphasises that each reader sees the most up-to-date +-- value possible while still guaranteeing progress. +data MSampleVar a = MSampleVar { readQueue :: MVar () + , lockedStore :: MVar (MVar a) } + deriving ( Eq +#if __GLASGOW_HASKELL__ >= 707 + , Typeable +#endif + ) + +#if __GLASGOW_HASKELL__ < 707 +instance Typeable1 MSampleVar where + typeOf1 _ = mkTyConApp tc [] + where tc = mkTyCon "MSampleVar" +#endif + + +-- | 'newEmptySV' allocates a new MSampleVar in an empty state. No futher +-- allocation is done when using the 'MSampleVar'. +newEmptySV :: IO (MSampleVar a) +newEmptySV = do + newReadQueue <- newMVar () + newLockedStore <- newMVar =<< newEmptyMVar + return (MSampleVar { readQueue = newReadQueue + , lockedStore = newLockedStore }) + +-- | 'newSV' allocates a new MSampleVar containing the passed value. The value +-- is not evalated or forced, but stored lazily. No futher allocation is done +-- when using the 'MSampleVar'. +newSV :: a -> IO (MSampleVar a) +newSV a = do + newReadQueue <- newMVar () + newLockedStore <- newMVar =<< newMVar a + return (MSampleVar { readQueue = newReadQueue + , lockedStore = newLockedStore }) + +-- | 'isEmptySV' can block and be interrupted, in which case it does nothing. +-- If 'isEmptySV' returns then it reports the momentary status the +-- 'MSampleVar'. Using this value without producing unwanted race conditions +-- is left up to the programmer. +isEmptySV :: MSampleVar a -> IO Bool +isEmptySV (MSampleVar _ ls) = withMVar ls isEmptyMVar + -- (withMVar ls) might block, interrupting is okay + +-- | If the 'MSampleVar' is full, forget the value and leave it empty. +-- Otherwise, do nothing. This avoids any the FIFO queue of blocked 'readSV' +-- threads. +-- +-- 'emptySV' can block and be interrupted, in which case it does nothing. If +-- 'emptySV' returns then it left the 'MSampleVar' in an empty state. +emptySV :: MSampleVar a -> IO () +emptySV (MSampleVar _ ls) = withMVar ls (void . tryTakeMVar) + -- (withMVar ls) might block, interrupting is okay + +-- | Wait for a value to become available, then take it and return. The queue +-- of blocked 'readSV' threads is a fair FIFO queue. +-- +-- 'readSV' can block and be interrupted, in which case it takes nothing. If +-- 'readSV returns normally then it has taken a value. +readSV :: MSampleVar a -> IO a +readSV (MSampleVar rq ls) = mask_ $ withMVar rq $ \ () -> + join $ withMVar ls (return . takeMVar) + -- (withMVar rq) might block, interrupting is okay + -- (withMVar ls) might block, interrupting is okay + -- join (takeMVar _) will block if empty, interrupting is okay + +-- | Write a value into the 'MSampleVar', overwriting any previous value that +-- was there. +-- +-- 'writeSV' can block and be interrupted, in which case it does nothing. +writeSV :: MSampleVar a -> a -> IO () +writeSV (MSampleVar _ ls) a = mask_ $ withMVar ls $ \ v -> do + void (tryTakeMVar v) + putMVar v a -- cannot block + -- (withMVar ls) might block, interrupting is okay + +{- + Design notes: + + 1) The outer MVar of lockedStore is employed in 'writeSV'. If two 'writeSV' are + racing in different threads then without the "withMVar ls" they can each + execute "void (tryTakeMVar v)" and then both execute "putMVar v a", causing + the second to block. Change putMVar to tryPutMVar lets the first 'writeSV' + win which arguably contradicts the specification, though this race makes it a + weak contradiction. + + Thus the lockedStore outer MVar is used as a FIFO queue for writeSV/emptySV + that gives the "previous" in the specification a precise meaning. + + 2) There is no 'tryReadSV' because the desired semantics are unclear. With + 'tryTakeMVar' one is guaranteed to block and a value (Just a) if and only if + 'takeMVar' would have suceeded without blocking. Also, if you know there are + no other readers then a Nothing return from 'tryTakeMVar' means that it is + empty, which is the handiest property. + + 3) An alternate design would queue the writers separately and let only + lead-reader and lead-writer access the stored value. Imagine several queued + writers and no readers are waiting and then a reader arrives, this reader can + see a value from the middle of the queue of writers. This would no longer + guarantees the most up-to-date value is read. + + The current design has a very orderly priority of readers and writers. Design + (3) makes the ordering between readers and writers choatic. Design (1) goes + further and also makes ordering between different writers chaotic. + +-} |