<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html>
<head>
<!-- Generated by HsColour, http://code.haskell.org/~malcolm/hscolour/ -->
<title>src/Control/Concurrent/MSem.lhs</title>
<link type='text/css' rel='stylesheet' href='hscolour.css' />
</head>
<body>
<pre><a name="line-1"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# LANGUAGE DeriveDataTypeable #-}</span>
<a name="line-2"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- |</span>
<a name="line-3"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- Module : Control.Concurrent.MSem</span>
<a name="line-4"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- Copyright : (c) Chris Kuklewicz 2011</span>
<a name="line-5"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- License : 3 clause BSD-style (see the file LICENSE)</span>
<a name="line-6"></a><span class='hs-varop'>></span> <span class='hs-comment'>--</span>
<a name="line-7"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- Maintainer : haskell@list.mightyreason.com</span>
<a name="line-8"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- Stability : experimental</span>
<a name="line-9"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- Portability : non-portable (concurrency)</span>
<a name="line-10"></a><span class='hs-varop'>></span> <span class='hs-comment'>--</span>
<a name="line-11"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- This is a literate haskell version of Control.Concurrent.MSem for increased clarity.</span>
<a name="line-12"></a><span class='hs-varop'>></span> <span class='hs-comment'>--</span>
<a name="line-13"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- A semaphore in which operations may 'wait' for or 'signal' single units of value. This modules</span>
<a name="line-14"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- is intended to improve on "Control.Concurrent.QSem".</span>
<a name="line-15"></a><span class='hs-varop'>></span> <span class='hs-comment'>--</span>
<a name="line-16"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- This semaphore gracefully handles threads which die while blocked waiting. The fairness</span>
<a name="line-17"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- guarantee is that blocked threads are servied in a FIFO order.</span>
<a name="line-18"></a><span class='hs-varop'>></span> <span class='hs-comment'>--</span>
<a name="line-19"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- If 'with' is used to guard a critical section then no quantity of the semaphore will be lost if</span>
<a name="line-20"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- the activity throws an exception or if this thread is killed by the rest of the program.</span>
<a name="line-21"></a><span class='hs-varop'>></span> <span class='hs-comment'>--</span>
<a name="line-22"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- 'new' can initialize the semaphore to negative, zero, or positive quantity.</span>
<a name="line-23"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- 'wait' always leaves the 'MSem' with non-negative quantity.</span>
<a name="line-24"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- 'signal' alawys adds one to the quantity.</span>
<a name="line-25"></a><span class='hs-varop'>></span> <span class='hs-comment'>--</span>
<a name="line-26"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- The functions below are generic in (Integral i) with specialization to Int, Word, and Integer.</span>
<a name="line-27"></a><span class='hs-varop'>></span> <span class='hs-comment'>--</span>
<a name="line-28"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- Overflow warning: These operations do not check for overflow errors. If the Integral type is too</span>
<a name="line-29"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- small to accept the new total then the behavior of 'signal' is undefined. Using (MSem</span>
<a name="line-30"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- Integer) prevents the possibility of an overflow error. [ A version of 'signal' that checks the upper</span>
<a name="line-31"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- bound could be added, but how would it report failure and how would you use this sanely? ]</span>
<a name="line-32"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- </span>
<a name="line-33"></a><span class='hs-varop'>></span>
<a name="line-34"></a><span class='hs-varop'>></span> <span class='hs-keyword'>module</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Concurrent</span><span class='hs-varop'>.</span><span class='hs-conid'>MSem</span>
<a name="line-35"></a><span class='hs-varop'>></span> <span class='hs-layout'>(</span><span class='hs-conid'>MSem</span> <span class='hs-comment'>-- do not export the constructor, kept abstract</span>
<a name="line-36"></a><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>new</span> <span class='hs-comment'>-- :: Integral i => i -> IO (MSem i)</span>
<a name="line-37"></a><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>with</span> <span class='hs-comment'>-- :: Integral i => MSem i -> IO a -> IO a</span>
<a name="line-38"></a><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>wait</span> <span class='hs-comment'>-- :: Integral i => MSem i -> IO ()</span>
<a name="line-39"></a><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>signal</span> <span class='hs-comment'>-- :: Integral i => MSem i -> IO ()</span>
<a name="line-40"></a><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>peekAvail</span> <span class='hs-comment'>-- :: Integral i => MSem i -> IO i</span>
<a name="line-41"></a><span class='hs-varop'>></span> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
</pre>
The above export list shows the API.
The amount of value in the orignal QSem is always of type Int. This module
generalizes the type to any Integral, where comparison (<) to 'fromIntegral 0'
and 'pred' and 'succ' are employed.
The 'new', 'wait', and 'signal' operations mimic the QSem API. The peekAvail
query is also provided, primarily for monitoring or debugging purposes. The
with combinator is used to safely and conveniently bracket operations.
<pre><a name="line-1"></a><span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Prelude</span><span class='hs-layout'>(</span> <span class='hs-conid'>Integral</span><span class='hs-layout'>,</span><span class='hs-conid'>Eq</span><span class='hs-layout'>,</span><span class='hs-conid'>IO</span><span class='hs-layout'>,</span><span class='hs-conid'>Int</span><span class='hs-layout'>,</span><span class='hs-conid'>Integer</span><span class='hs-layout'>,</span><span class='hs-conid'>Maybe</span><span class='hs-layout'>(</span><span class='hs-conid'>Just</span><span class='hs-layout'>,</span><span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span>
<a name="line-2"></a><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>seq</span><span class='hs-layout'>,</span><span class='hs-varid'>pred</span><span class='hs-layout'>,</span><span class='hs-varid'>succ</span><span class='hs-layout'>,</span><span class='hs-varid'>return</span>
<a name="line-3"></a><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varop'>.</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varop'><</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varop'>$</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span><span class='hs-layout'>(</span><span class='hs-varop'>$!</span><span class='hs-layout'>)</span> <span class='hs-layout'>)</span>
<a name="line-4"></a><span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Concurrent</span><span class='hs-varop'>.</span><span class='hs-conid'>MVar</span><span class='hs-layout'>(</span> <span class='hs-conid'>MVar</span>
<a name="line-5"></a><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>withMVar</span><span class='hs-layout'>,</span><span class='hs-varid'>modifyMVar</span><span class='hs-layout'>,</span><span class='hs-varid'>modifyMVar_</span><span class='hs-layout'>,</span><span class='hs-varid'>tryPutMVar</span>
<a name="line-6"></a><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>newMVar</span><span class='hs-layout'>,</span><span class='hs-varid'>newEmptyMVar</span><span class='hs-layout'>,</span><span class='hs-varid'>putMVar</span><span class='hs-layout'>,</span><span class='hs-varid'>takeMVar</span><span class='hs-layout'>,</span><span class='hs-varid'>tryTakeMVar</span><span class='hs-layout'>)</span>
<a name="line-7"></a><span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Exception</span><span class='hs-layout'>(</span><span class='hs-varid'>bracket_</span><span class='hs-layout'>,</span><span class='hs-varid'>uninterruptibleMask_</span><span class='hs-layout'>,</span><span class='hs-varid'>mask_</span><span class='hs-layout'>)</span>
<a name="line-8"></a><span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-layout'>(</span><span class='hs-varid'>join</span><span class='hs-layout'>)</span>
<a name="line-9"></a><span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Typeable</span><span class='hs-layout'>(</span><span class='hs-conid'>Typeable</span><span class='hs-layout'>)</span>
<a name="line-10"></a><span class='hs-varop'>></span> <span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Word</span><span class='hs-layout'>(</span><span class='hs-conid'>Word</span><span class='hs-layout'>)</span>
</pre>
The import list shows that most of the power of MVar's will be exploited, and
that the rather dangerous uninterruptibleMask_ will be employed (in 'signal').
A new semaphore is created with a specified avaiable quantity. The mutable
available quantity will be called the value of the semaphore for brevity's
sake.
The use of a semaphore involves multiple threads executing 'wait' and 'signal'
commands. This stream of wait and 'signal' commands will be executed as if
they arrive in some sequential, non-overlapping, order which is an interleaving
of the commands from each thread.
From the local perspective of a single thread the semantics are simple to
specify. The 'signal' command will find the MSem to have a value and mutate
this to add one to the value. The 'wait' command will find the MSem to have a
value and if this is greater than zero it will mutate this to be one less and
finish, otherwise the value is negative or zero and the execution of the 'wait'
thread will block. Eventually another thread executes 'signal' and raises the
value to be positive, at this point the blocked 'wait' thread will reduce the
value by one and finish executing the 'wait' command.
From a broader perspective there is a question of precedence and starvation.
If there is a blocked wait thread and a second 'wait' command starts to execute
then will the second thread "find the MSem to have a value" before or after the
orignal blocked thread has finished? If there are several blocked 'wait'
threads and a 'signal' arrives then which blocked thread has priority to take
the quatity and finish waiting? Are there any fairness guarantees or might a
blocked thread never get priority over its bretheren leading to starvation?
I have designed this module to provide a fair semaphore: multiple 'wait'
threads are serviced in FIFO order. All 'signal' operations, while they may
block, are individually quick.
There are precisely three components, all MVars alloced by 'new': queueWait,
quantityStore, and headWait.
1) The 'wait' operations are forced into a FIFO queue by taking an (MVar ())
called queueWait during their operation. The thread holding this token is the
"head" waiter.
2) The 'signal' operations are forced into a FIFO queue by taking the MVar
called quantityStore which holds an integral value.
3) The logical value stored in the semaphore might be represented by one of two
different states of the semaphore data structure, depending on whether
'headWait :: MVar ()' is empty or full. In this module a full headWait
reprents a single unit of value stored in the semaphore.
<pre><a name="line-1"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- | A 'MSem' is a semaphore in which the available quantity can be added and removed in single</span>
<a name="line-2"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- units, and which can start with positive, zero, or negative value.</span>
<a name="line-3"></a><span class='hs-varop'>></span> <span class='hs-keyword'>data</span> <span class='hs-conid'>MSem</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>MSem</span> <span class='hs-layout'>{</span> <span class='hs-varid'>quantityStore</span> <span class='hs-keyglyph'>::</span> <span class='hs-varop'>!</span><span class='hs-layout'>(</span><span class='hs-conid'>MVar</span> <span class='hs-varid'>i</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- ^ Used to lock access to state of semaphore quantity. Never updated.</span>
<a name="line-4"></a><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>queueWait</span> <span class='hs-keyglyph'>::</span> <span class='hs-varop'>!</span><span class='hs-layout'>(</span><span class='hs-conid'>MVar</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- ^ Used as FIFO queue for waiter, held by head of queue. Never updated.</span>
<a name="line-5"></a><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>headWait</span> <span class='hs-keyglyph'>::</span> <span class='hs-varop'>!</span><span class='hs-layout'>(</span><span class='hs-conid'>MVar</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- ^ The head of the waiter queue blocks on headWait. Never updated.</span>
<a name="line-6"></a><span class='hs-varop'>></span> <span class='hs-layout'>}</span>
<a name="line-7"></a><span class='hs-varop'>></span> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eq</span><span class='hs-layout'>,</span><span class='hs-conid'>Typeable</span><span class='hs-layout'>)</span>
<a name="line-8"></a><span class='hs-varop'>></span>
<a name="line-9"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- |'new' allows positive, zero, and negative initial values. The initial value is forced here to</span>
<a name="line-10"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- better localize errors.</span>
<a name="line-11"></a><span class='hs-varop'>></span> <span class='hs-comment'>--</span>
<a name="line-12"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- The only way to achieve a negative value with MSem is to start negative with 'new'. Once a negative quantity becomes non-negative</span>
<a name="line-13"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- by use of 'signal' it will never later be negative.</span>
<a name="line-14"></a><span class='hs-varop'>></span> <span class='hs-definition'>new</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Integral</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>=></span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-layout'>(</span><span class='hs-conid'>MSem</span> <span class='hs-varid'>i</span><span class='hs-layout'>)</span>
<a name="line-15"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE new :: Int -> IO (MSem Int) #-}</span>
<a name="line-16"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE new :: Word -> IO (MSem Word) #-}</span>
<a name="line-17"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE new :: Integer -> IO (MSem Integer) #-}</span>
<a name="line-18"></a><span class='hs-varop'>></span> <span class='hs-definition'>new</span> <span class='hs-varid'>initial</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-19"></a><span class='hs-varop'>></span> <span class='hs-varid'>newQuantityStore</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newMVar</span> <span class='hs-varop'>$!</span> <span class='hs-varid'>initial</span>
<a name="line-20"></a><span class='hs-varop'>></span> <span class='hs-varid'>newQueueWait</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newMVar</span> <span class='hs-conid'>()</span>
<a name="line-21"></a><span class='hs-varop'>></span> <span class='hs-varid'>newHeadWait</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newEmptyMVar</span>
<a name="line-22"></a><span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>MSem</span> <span class='hs-layout'>{</span> <span class='hs-varid'>quantityStore</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>newQuantityStore</span>
<a name="line-23"></a><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>queueWait</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>newQueueWait</span>
<a name="line-24"></a><span class='hs-varop'>></span> <span class='hs-layout'>,</span> <span class='hs-varid'>headWait</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>newHeadWait</span> <span class='hs-layout'>}</span><span class='hs-layout'>)</span>
<a name="line-25"></a><span class='hs-varop'>></span>
</pre>
Note that the only MVars that get allocated are all by these three commands in
'new'. The other commands change the stored values but do not allocate new
mutable storage. None of these three MVars can be simply replaced by an IORef
because the possibility of blocking on each of them is used in the design. A
design with two MVar is possible but I think it would have more contention
between threads and be more complex to ensure thread safety.
There are four operations on the semaphore leading to two possible states for
headWait:
1) If the most recent operation to finish was 'new' then headWait is definitely
empty and the value of the MSem is the quantity in quantityStore.
2) If the most recent operation to finish was 'wait' then headWait is
definitely empty and the value of the MSem is the quantity in quantityStore.
3) If the most recent operation to finish was a 'signal' and the new value is
positive then headWait is definitely full and the value of the MSem is the
quantity in quantityStore PLUS ONE.
4) If the most recent operation to finish was a 'signal' and the new value is
non-positive then headWait is definitely empty and the value of the MSem is the
quantity in quantityStore.
If the "head" 'wait' thread finds a non-positive value then it will need to
sleep until being awakened by a future 'signal'. This sleeping is accomplished
by the head waiter taking an empty headWait.
All uses of the semaphore API to guard execution of an action should use 'with'
to simplify ensuring exceptions are safely handled. Other uses should use
still try and use combinators in Control.Exception to ensure that no 'signal'
commands get lost so that no quantity of the semaphore leaks when exceptions
occur.
<pre><a name="line-1"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- | 'with' takes a unit of value from the semaphore to hold while performing the provided</span>
<a name="line-2"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- operation. 'with' ensures the quantity of the sempahore cannot be lost if there are exceptions or</span>
<a name="line-3"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- if killThread is used.</span>
<a name="line-4"></a><span class='hs-varop'>></span> <span class='hs-comment'>--</span>
<a name="line-5"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- 'with' uses 'bracket_' to ensure 'wait' and 'signal' get called correctly.</span>
<a name="line-6"></a><span class='hs-varop'>></span> <span class='hs-definition'>with</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Integral</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>MSem</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-varid'>a</span>
<a name="line-7"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE with :: MSem Int -> IO a -> IO a #-}</span>
<a name="line-8"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE with :: MSem Word -> IO a -> IO a #-}</span>
<a name="line-9"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE with :: MSem Integer -> IO a -> IO a #-}</span>
<a name="line-10"></a><span class='hs-varop'>></span> <span class='hs-definition'>with</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>bracket_</span> <span class='hs-layout'>(</span><span class='hs-varid'>wait</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>signal</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span>
</pre>
<pre><a name="line-1"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- |'wait' will take one unit of value from the sempahore, but will block if the quantity available</span>
<a name="line-2"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- is not positive.</span>
<a name="line-3"></a><span class='hs-varop'>></span> <span class='hs-comment'>--</span>
<a name="line-4"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- If 'wait' returns normally (not interrupted) then it left the 'MSem' with a remaining quantity that was</span>
<a name="line-5"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- greater than or equal to zero. If 'wait' is interrupted then no quantity is lost. If 'wait'</span>
<a name="line-6"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- returns without interruption then it is known that each earlier waiter has definitely either been</span>
<a name="line-7"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- interrupted or has retured without interruption (the FIFO guarantee).</span>
<a name="line-8"></a><span class='hs-varop'>></span> <span class='hs-definition'>wait</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Integral</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>MSem</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-9"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE wait :: MSem Int -> IO () #-}</span>
<a name="line-10"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE wait :: MSem Word -> IO () #-}</span>
<a name="line-11"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE wait :: MSem Integer -> IO () #-}</span>
<a name="line-12"></a><span class='hs-varop'>></span> <span class='hs-definition'>wait</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mask_</span> <span class='hs-varop'>.</span> <span class='hs-varid'>withMVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>queueWait</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span> <span class='hs-conid'>()</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-13"></a><span class='hs-varop'>></span> <span class='hs-varid'>join</span> <span class='hs-varop'>.</span> <span class='hs-varid'>modifyMVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>quantityStore</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span> <span class='hs-varid'>quantity</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-14"></a><span class='hs-varop'>></span> <span class='hs-varid'>mayGrab</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>tryTakeMVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>headWait</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- First try optimistic grab on (headWait w)</span>
<a name="line-15"></a><span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>mayGrab</span> <span class='hs-keyword'>of</span>
<a name="line-16"></a><span class='hs-varop'>></span> <span class='hs-conid'>Just</span> <span class='hs-conid'>()</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>quantity</span><span class='hs-layout'>,</span><span class='hs-varid'>return</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Took unit of value, done</span>
<a name="line-17"></a><span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>if</span> <span class='hs-num'>0</span> <span class='hs-varop'><</span> <span class='hs-varid'>quantity</span> <span class='hs-comment'>-- Did not take unit of value, check quantity</span>
<a name="line-18"></a><span class='hs-varop'>></span> <span class='hs-keyword'>then</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>quantity'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>pred</span> <span class='hs-varid'>quantity</span> <span class='hs-comment'>-- quantity' is never negative</span>
<a name="line-19"></a><span class='hs-varop'>></span> <span class='hs-keyword'>in</span> <span class='hs-varid'>seq</span> <span class='hs-varid'>quantity'</span> <span class='hs-varop'>$</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>quantity'</span><span class='hs-layout'>,</span> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span>
<a name="line-20"></a><span class='hs-varop'>></span> <span class='hs-keyword'>else</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>quantity</span><span class='hs-layout'>,</span> <span class='hs-varid'>takeMVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>headWait</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- go to sleep</span>
</pre>
The needed invariant is that 'wait' takes a unit of value iff it returns
normally (i.e. it is not interrupted). The 'mask_' is needed above because we
may decrement 'headWait' with 'tryTakeMVar' and must then finished the
'withMVar' without being interrupted. Under the 'mask_' the 'wait' might block
and then be interruptable at one or more of
1) 'withMVar (queueWait m)' : the 'wait' dies before becoming head waiter while
blocked by previous 'wait'.
2) 'modifyMVar (quantityStore m)' : the 'wait' dies as head waiter while
blocked by previous 'signal'.
3) 'takeMVar (headWait m)' from 'join' : the 'wait' dies as head waiter while
sleeping on 'headWait'.
All three of those are safe places to die. The unsafe possibilities would be
to die after a 'tryTakeMVar (headWait m)' returns 'Just ()' or after
'modifyMVar' puts the decremented quantity into (quantityStore m). These are
prevented by the 'mask_'.
Note that the head waiter must also get to the front of the FIFO queue of
signals to get the value of 'quantityStore'. Only the head waiter competes
with the 'signal' & peek threads for obtaining 'quantityStore'.
<pre><a name="line-1"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- | 'signal' adds one unit to the sempahore. Overflow is not checked.</span>
<a name="line-2"></a><span class='hs-varop'>></span> <span class='hs-comment'>--</span>
<a name="line-3"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- 'signal' may block, but it cannot be interrupted, which allows it to dependably restore value to</span>
<a name="line-4"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- the 'MSem'. All 'signal', 'peekAvail', and the head waiter may momentarily block in a fair FIFO</span>
<a name="line-5"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- manner.</span>
<a name="line-6"></a><span class='hs-varop'>></span> <span class='hs-definition'>signal</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Integral</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>MSem</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-7"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE signal :: MSem Int -> IO () #-}</span>
<a name="line-8"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE signal :: MSem Word -> IO () #-}</span>
<a name="line-9"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE signal :: MSem Integer -> IO () #-}</span>
<a name="line-10"></a><span class='hs-varop'>></span> <span class='hs-definition'>signal</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>uninterruptibleMask_</span> <span class='hs-varop'>.</span> <span class='hs-varid'>modifyMVar_</span> <span class='hs-layout'>(</span><span class='hs-varid'>quantityStore</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span> <span class='hs-varid'>quantity</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-11"></a><span class='hs-varop'>></span> <span class='hs-keyword'>if</span> <span class='hs-varid'>quantity</span> <span class='hs-varop'><</span> <span class='hs-num'>0</span>
<a name="line-12"></a><span class='hs-varop'>></span> <span class='hs-keyword'>then</span> <span class='hs-varid'>return</span> <span class='hs-varop'>$!</span> <span class='hs-varid'>succ</span> <span class='hs-varid'>quantity</span>
<a name="line-13"></a><span class='hs-varop'>></span> <span class='hs-keyword'>else</span> <span class='hs-keyword'>do</span>
<a name="line-14"></a><span class='hs-varop'>></span> <span class='hs-varid'>didPlace</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>tryPutMVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>headWait</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-conid'>()</span> <span class='hs-comment'>-- quantity is never negative</span>
<a name="line-15"></a><span class='hs-varop'>></span> <span class='hs-keyword'>if</span> <span class='hs-varid'>didPlace</span>
<a name="line-16"></a><span class='hs-varop'>></span> <span class='hs-keyword'>then</span> <span class='hs-varid'>return</span> <span class='hs-varid'>quantity</span>
<a name="line-17"></a><span class='hs-varop'>></span> <span class='hs-keyword'>else</span> <span class='hs-varid'>return</span> <span class='hs-varop'>$!</span> <span class='hs-varid'>succ</span> <span class='hs-varid'>quantity</span>
</pre>
The 'signal' operation first has the FIFO grab of (quantityStore m). If
'tryPutMVar' returns True then a currently sleeping head waiter will be woken
up.
The 'modifyMVar_' will block until prior 'signal' and 'peek' threads and
perhaps a prior head 'wait' finish. This is the only point that may block.
Thus 'uninterruptibleMask_' only differs from 'mask_' in that once 'signal'
starts executing it cannot be interrupted before returning the unit of value to
the MSem. All the operations 'signal' would be waiting for are quick and are
themselves non-blocking, so the uninterruptible operation here should finish
without arbitrary delay.
Consider 'with m act = bracket_ (wait m) (signal m) act', refer to
http://www.haskell.org/ghc/docs/latest/html/libraries/base/src/Control-Exception-Base.html#bracket_
for the details. Specifically a killThread arrives at one of these points:
1) during (wait m) the exception is masked by both 'bracket' and 'wait' so this
occurs at one of the blocking points mentioned above. This does not affect the
MSe, and aborts the 'bracket_' without calling act or (signal m).
2) during (restore act) the `onException` in the definition of 'bracket' will
shift control to (signal m).
3) during (signal m) regardless of how act exited. Here we know (wait m)
exited normally and thus took a unit of value from the MSem. The mask_ of
'bracket' ensures that the uninterruptibleMask_ in 'signal' ensures that the
unit of value is returned to MSem even if 'signal' blocks on 'modifyMVar_
(quantityStore m)'.
4) Outside of any of the above the mask_ in 'bracket' prevents the killThread
from being recognized until one of the above or until the 'bracket' finishes.
If 'signal' did not use 'uninterruptibleMask_' then point (3) could be
interrupted without returning the value to the MSem. Avoiding losing quantity
is the primary design criterion for this semaphore library, and I think it
requires this apparantly safe use of uninterruptibleMask_ to ensure that
'signal' can and will succeed.
<pre><a name="line-1"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- | 'peekAvail' skips the queue of any blocked 'wait' threads, but may momentarily block on</span>
<a name="line-2"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- 'signal', other 'peekAvail', and the head waiter. This returns the amount of value available to</span>
<a name="line-3"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- be taken. Using this value without producing unwanted race conditions is left up to the</span>
<a name="line-4"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- programmer.</span>
<a name="line-5"></a><span class='hs-varop'>></span> <span class='hs-comment'>--</span>
<a name="line-6"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- Note that "Control.Concurrent.MSemN" offers a more powerful API for making decisions based on the</span>
<a name="line-7"></a><span class='hs-varop'>></span> <span class='hs-comment'>-- available amount.</span>
<a name="line-8"></a><span class='hs-varop'>></span> <span class='hs-definition'>peekAvail</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Integral</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>MSem</span> <span class='hs-varid'>i</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-varid'>i</span>
<a name="line-9"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE peekAvail :: MSem Int -> IO Int #-}</span>
<a name="line-10"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE peekAvail :: MSem Word -> IO Word #-}</span>
<a name="line-11"></a><span class='hs-varop'>></span> <span class='hs-comment'>{-# SPECIALIZE peekAvail :: MSem Integer -> IO Integer #-}</span>
<a name="line-12"></a><span class='hs-varop'>></span> <span class='hs-definition'>peekAvail</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mask_</span> <span class='hs-varop'>$</span> <span class='hs-varid'>withMVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>quantityStore</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span> <span class='hs-varid'>quantity</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-13"></a><span class='hs-varop'>></span> <span class='hs-varid'>extraFlag</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>tryTakeMVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>headWait</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span>
<a name="line-14"></a><span class='hs-varop'>></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>extraFlag</span> <span class='hs-keyword'>of</span>
<a name="line-15"></a><span class='hs-varop'>></span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varid'>quantity</span>
<a name="line-16"></a><span class='hs-varop'>></span> <span class='hs-conid'>Just</span> <span class='hs-conid'>()</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span> <span class='hs-varid'>putMVar</span> <span class='hs-layout'>(</span><span class='hs-varid'>headWait</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-conid'>()</span> <span class='hs-comment'>-- cannot block</span>
<a name="line-17"></a><span class='hs-varop'>></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$!</span> <span class='hs-varid'>succ</span> <span class='hs-varid'>quantity</span>
</pre>
The implementaion of peekAvail is slightly complicated by the interplay of
tryTakeMVar and putMVar. Only this thread will be holding the lock on
quantityStore and the putMVar only runs to put a () just taken from headWait.
Thus the putMVar will never block. The 'mask_' ensures that there can be no
external interruption between a tryTakeMVar and putMVar.
</body>
</html>
