From 3f158717d3714b5381205af8626189dfd6796e98 Mon Sep 17 00:00:00 2001 From: tv Date: Sat, 17 Oct 2015 19:12:44 +0200 Subject: Control.Concurrent.MSampleVar{ -> X} --- Control/Concurrent/MSampleVar.hs | 164 -------------------------------------- Control/Concurrent/MSampleVarX.hs | 164 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 164 insertions(+), 164 deletions(-) delete mode 100644 Control/Concurrent/MSampleVar.hs create mode 100644 Control/Concurrent/MSampleVarX.hs diff --git a/Control/Concurrent/MSampleVar.hs b/Control/Concurrent/MSampleVar.hs deleted file mode 100644 index 578d391..0000000 --- a/Control/Concurrent/MSampleVar.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# 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. - --} diff --git a/Control/Concurrent/MSampleVarX.hs b/Control/Concurrent/MSampleVarX.hs new file mode 100644 index 0000000..578d391 --- /dev/null +++ b/Control/Concurrent/MSampleVarX.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. + +-} -- cgit v1.2.3