init Control.Concurrent.MSampleVar

From: SafeSemaphore-0.10.1

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.
+
+-}