<?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/MSampleVar.hs</title> <link type='text/css' rel='stylesheet' href='hscolour.css' /> </head> <body> <pre><a name="line-1"></a><span class='hs-comment'>{-# LANGUAGE DeriveDataTypeable #-}</span> <a name="line-2"></a><span class='hs-comment'>--</span> <a name="line-3"></a><span class='hs-comment'>-- Module : Control.Concurrent.MSampleVar</span> <a name="line-4"></a><span class='hs-comment'>-- Copyright : (c) Chris Kuklewicz 2011</span> <a name="line-5"></a><span class='hs-comment'>-- License : 3 clause BSD-style (see the file LICENSE)</span> <a name="line-6"></a><span class='hs-comment'>-- </span> <a name="line-7"></a><span class='hs-comment'>-- Maintainer : haskell@list.mightyreason.com</span> <a name="line-8"></a><span class='hs-comment'>-- Stability : experimental</span> <a name="line-9"></a><span class='hs-comment'>-- Portability : non-portable (concurrency)</span> <a name="line-10"></a><span class='hs-comment'>--</span> <a name="line-11"></a> <a name="line-12"></a><span class='hs-comment'>-- | 'MSampleVar' is a safer version of the "Control.Concurrent.SampleVar" in</span> <a name="line-13"></a><span class='hs-comment'>-- base. The same problem as QSem(N) is being fixed, that of handling waiters</span> <a name="line-14"></a><span class='hs-comment'>-- that die before being woken normally. For "Control.Concurrent.SampleVar" in</span> <a name="line-15"></a><span class='hs-comment'>-- base this error can lead to thinking a full 'SampleVar' is really empty and</span> <a name="line-16"></a><span class='hs-comment'>-- cause 'writeSampleVar' to hang. The 'MSampleVar' in this module is immune</span> <a name="line-17"></a><span class='hs-comment'>-- to this error, and has a simpler implementation.</span> <a name="line-18"></a><span class='hs-comment'>--</span> <a name="line-19"></a><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'>MSampleVar</span> <a name="line-20"></a> <span class='hs-layout'>(</span> <span class='hs-comment'>-- * Sample Variables</span> <a name="line-21"></a> <span class='hs-conid'>MSampleVar</span><span class='hs-layout'>,</span> <a name="line-22"></a> <span class='hs-varid'>newEmptySV</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- :: IO (MSampleVar a)</span> <a name="line-23"></a> <span class='hs-varid'>newSV</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- :: a -> IO (MSampleVar a)</span> <a name="line-24"></a> <span class='hs-varid'>emptySV</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- :: MSampleVar a -> IO ()</span> <a name="line-25"></a> <span class='hs-varid'>readSV</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- :: MSampleVar a -> IO a</span> <a name="line-26"></a> <span class='hs-varid'>writeSV</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- :: MSampleVar a -> a -> IO ()</span> <a name="line-27"></a> <span class='hs-varid'>isEmptySV</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- :: MSampleVar a -> IO Bool</span> <a name="line-28"></a> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span> <a name="line-29"></a> <a name="line-30"></a><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'>void</span><span class='hs-layout'>,</span><span class='hs-varid'>join</span><span class='hs-layout'>)</span> <a name="line-31"></a><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><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'>tryTakeMVar</span><span class='hs-layout'>,</span><span class='hs-varid'>takeMVar</span><span class='hs-layout'>,</span><span class='hs-varid'>putMVar</span><span class='hs-layout'>,</span><span class='hs-varid'>withMVar</span><span class='hs-layout'>,</span><span class='hs-varid'>isEmptyMVar</span><span class='hs-layout'>)</span> <a name="line-32"></a><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'>mask_</span><span class='hs-layout'>)</span> <a name="line-33"></a><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'>Typeable1</span><span class='hs-layout'>(</span><span class='hs-varid'>typeOf1</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span><span class='hs-varid'>mkTyCon</span><span class='hs-layout'>,</span><span class='hs-varid'>mkTyConApp</span><span class='hs-layout'>)</span> <a name="line-34"></a> <a name="line-35"></a><a name="MSampleVar"></a><span class='hs-comment'>-- |</span> <a name="line-36"></a><a name="MSampleVar"></a><span class='hs-comment'>-- Sample variables are slightly different from a normal 'MVar':</span> <a name="line-37"></a><a name="MSampleVar"></a><span class='hs-comment'>-- </span> <a name="line-38"></a><a name="MSampleVar"></a><span class='hs-comment'>-- * Reading an empty 'MSampleVar' causes the reader to block.</span> <a name="line-39"></a><a name="MSampleVar"></a><span class='hs-comment'>-- (same as 'takeMVar' on empty 'MVar')</span> <a name="line-40"></a><a name="MSampleVar"></a><span class='hs-comment'>-- </span> <a name="line-41"></a><a name="MSampleVar"></a><span class='hs-comment'>-- * Reading a filled 'MSampleVar' empties it and returns value.</span> <a name="line-42"></a><a name="MSampleVar"></a><span class='hs-comment'>-- (same as 'takeMVar')</span> <a name="line-43"></a><a name="MSampleVar"></a><span class='hs-comment'>--</span> <a name="line-44"></a><a name="MSampleVar"></a><span class='hs-comment'>-- * Try reading a filled 'MSampleVar' returns a Maybe value.</span> <a name="line-45"></a><a name="MSampleVar"></a><span class='hs-comment'>-- (same as 'tryTakeMVar')</span> <a name="line-46"></a><a name="MSampleVar"></a><span class='hs-comment'>-- </span> <a name="line-47"></a><a name="MSampleVar"></a><span class='hs-comment'>-- * Writing to an empty 'MSampleVar' fills it with a value, and</span> <a name="line-48"></a><a name="MSampleVar"></a><span class='hs-comment'>-- potentially, wakes up a blocked reader (same as for 'putMVar' on</span> <a name="line-49"></a><a name="MSampleVar"></a><span class='hs-comment'>-- empty 'MVar').</span> <a name="line-50"></a><a name="MSampleVar"></a><span class='hs-comment'>--</span> <a name="line-51"></a><a name="MSampleVar"></a><span class='hs-comment'>-- * Writing to a filled 'MSampleVar' overwrites the current value.</span> <a name="line-52"></a><a name="MSampleVar"></a><span class='hs-comment'>-- (different from 'putMVar' on full 'MVar'.)</span> <a name="line-53"></a><a name="MSampleVar"></a><span class='hs-comment'>--</span> <a name="line-54"></a><a name="MSampleVar"></a><span class='hs-comment'>-- The readers queue in FIFO order, with the lead reader joining the writers in</span> <a name="line-55"></a><a name="MSampleVar"></a><span class='hs-comment'>-- a second FIFO queue to access the stored value. Thus writers can jump the</span> <a name="line-56"></a><a name="MSampleVar"></a><span class='hs-comment'>-- queue of non-leading waiting readers to update the value, but the lead</span> <a name="line-57"></a><a name="MSampleVar"></a><span class='hs-comment'>-- reader has to wait on all previous writes to finish before taking the value.</span> <a name="line-58"></a><a name="MSampleVar"></a><span class='hs-comment'>--</span> <a name="line-59"></a><a name="MSampleVar"></a><span class='hs-comment'>-- This design choice emphasises that each reader sees the most up-to-date</span> <a name="line-60"></a><a name="MSampleVar"></a><span class='hs-comment'>-- value possible while still guaranteeing progress.</span> <a name="line-61"></a><a name="MSampleVar"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>MSampleVar</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>MSampleVar</span> <span class='hs-layout'>{</span> <span class='hs-varid'>readQueue</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MVar</span> <span class='hs-conid'>()</span> <a name="line-62"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>lockedStore</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MVar</span> <span class='hs-layout'>(</span><span class='hs-conid'>MVar</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span> <a name="line-63"></a> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eq</span><span class='hs-layout'>)</span> <a name="line-64"></a> <a name="line-65"></a><a name="instance%20Typeable1%20MSampleVar"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Typeable1</span> <span class='hs-conid'>MSampleVar</span> <span class='hs-keyword'>where</span> <a name="line-66"></a> <span class='hs-varid'>typeOf1</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkTyConApp</span> <span class='hs-varid'>tc</span> <span class='hs-conid'>[]</span> <a name="line-67"></a> <span class='hs-keyword'>where</span> <span class='hs-varid'>tc</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkTyCon</span> <span class='hs-str'>"MSampleVar"</span> <a name="line-68"></a> <a name="line-69"></a> <a name="line-70"></a><a name="newEmptySV"></a><span class='hs-comment'>-- | 'newEmptySV' allocates a new MSampleVar in an empty state. No futher</span> <a name="line-71"></a><span class='hs-comment'>-- allocation is done when using the 'MSampleVar'.</span> <a name="line-72"></a><span class='hs-definition'>newEmptySV</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IO</span> <span class='hs-layout'>(</span><span class='hs-conid'>MSampleVar</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <a name="line-73"></a><span class='hs-definition'>newEmptySV</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <a name="line-74"></a> <span class='hs-varid'>newReadQueue</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newMVar</span> <span class='hs-conid'>()</span> <a name="line-75"></a> <span class='hs-varid'>newLockedStore</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newMVar</span> <span class='hs-varop'>=<<</span> <span class='hs-varid'>newEmptyMVar</span> <a name="line-76"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>MSampleVar</span> <span class='hs-layout'>{</span> <span class='hs-varid'>readQueue</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>newReadQueue</span> <a name="line-77"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>lockedStore</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>newLockedStore</span> <span class='hs-layout'>}</span><span class='hs-layout'>)</span> <a name="line-78"></a> <a name="line-79"></a><a name="newSV"></a><span class='hs-comment'>-- | 'newSV' allocates a new MSampleVar containing the passed value. The value</span> <a name="line-80"></a><span class='hs-comment'>-- is not evalated or forced, but stored lazily. No futher allocation is done</span> <a name="line-81"></a><span class='hs-comment'>-- when using the 'MSampleVar'.</span> <a name="line-82"></a><span class='hs-definition'>newSV</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-layout'>(</span><span class='hs-conid'>MSampleVar</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <a name="line-83"></a><span class='hs-definition'>newSV</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <a name="line-84"></a> <span class='hs-varid'>newReadQueue</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newMVar</span> <span class='hs-conid'>()</span> <a name="line-85"></a> <span class='hs-varid'>newLockedStore</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newMVar</span> <span class='hs-varop'>=<<</span> <span class='hs-varid'>newMVar</span> <span class='hs-varid'>a</span> <a name="line-86"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>MSampleVar</span> <span class='hs-layout'>{</span> <span class='hs-varid'>readQueue</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>newReadQueue</span> <a name="line-87"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>lockedStore</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>newLockedStore</span> <span class='hs-layout'>}</span><span class='hs-layout'>)</span> <a name="line-88"></a> <a name="line-89"></a><a name="isEmptySV"></a><span class='hs-comment'>-- | 'isEmptySV' can block and be interrupted, in which case it does nothing.</span> <a name="line-90"></a><span class='hs-comment'>-- If 'isEmptySV' returns then it reports the momentary status the</span> <a name="line-91"></a><span class='hs-comment'>-- 'MSampleVar'. Using this value without producing unwanted race conditions</span> <a name="line-92"></a><span class='hs-comment'>-- is left up to the programmer.</span> <a name="line-93"></a><span class='hs-definition'>isEmptySV</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MSampleVar</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>Bool</span> <a name="line-94"></a><span class='hs-definition'>isEmptySV</span> <span class='hs-layout'>(</span><span class='hs-conid'>MSampleVar</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>ls</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>withMVar</span> <span class='hs-varid'>ls</span> <span class='hs-varid'>isEmptyMVar</span> <a name="line-95"></a> <span class='hs-comment'>-- (withMVar ls) might block, interrupting is okay</span> <a name="line-96"></a> <a name="line-97"></a><a name="emptySV"></a><span class='hs-comment'>-- | If the 'MSampleVar' is full, forget the value and leave it empty.</span> <a name="line-98"></a><span class='hs-comment'>-- Otherwise, do nothing. This avoids any the FIFO queue of blocked 'readSV'</span> <a name="line-99"></a><span class='hs-comment'>-- threads.</span> <a name="line-100"></a><span class='hs-comment'>--</span> <a name="line-101"></a><span class='hs-comment'>-- 'emptySV' can block and be interrupted, in which case it does nothing. If</span> <a name="line-102"></a><span class='hs-comment'>-- 'emptySV' returns then it left the 'MSampleVar' in an empty state.</span> <a name="line-103"></a><span class='hs-definition'>emptySV</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MSampleVar</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span> <a name="line-104"></a><span class='hs-definition'>emptySV</span> <span class='hs-layout'>(</span><span class='hs-conid'>MSampleVar</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>ls</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>withMVar</span> <span class='hs-varid'>ls</span> <span class='hs-layout'>(</span><span class='hs-varid'>void</span> <span class='hs-varop'>.</span> <span class='hs-varid'>tryTakeMVar</span><span class='hs-layout'>)</span> <a name="line-105"></a> <span class='hs-comment'>-- (withMVar ls) might block, interrupting is okay</span> <a name="line-106"></a> <a name="line-107"></a><a name="readSV"></a><span class='hs-comment'>-- | Wait for a value to become available, then take it and return. The queue</span> <a name="line-108"></a><span class='hs-comment'>-- of blocked 'readSV' threads is a fair FIFO queue.</span> <a name="line-109"></a><span class='hs-comment'>--</span> <a name="line-110"></a><span class='hs-comment'>-- 'readSV' can block and be interrupted, in which case it takes nothing. If</span> <a name="line-111"></a><span class='hs-comment'>-- 'readSV returns normally then it has taken a value.</span> <a name="line-112"></a><span class='hs-definition'>readSV</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MSampleVar</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-113"></a><span class='hs-definition'>readSV</span> <span class='hs-layout'>(</span><span class='hs-conid'>MSampleVar</span> <span class='hs-varid'>rq</span> <span class='hs-varid'>ls</span><span class='hs-layout'>)</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-varid'>rq</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span> <span class='hs-conid'>()</span> <span class='hs-keyglyph'>-></span> <a name="line-114"></a> <span class='hs-varid'>join</span> <span class='hs-varop'>$</span> <span class='hs-varid'>withMVar</span> <span class='hs-varid'>ls</span> <span class='hs-layout'>(</span><span class='hs-varid'>return</span> <span class='hs-varop'>.</span> <span class='hs-varid'>takeMVar</span><span class='hs-layout'>)</span> <a name="line-115"></a> <span class='hs-comment'>-- (withMVar rq) might block, interrupting is okay</span> <a name="line-116"></a> <span class='hs-comment'>-- (withMVar ls) might block, interrupting is okay</span> <a name="line-117"></a> <span class='hs-comment'>-- join (takeMVar _) will block if empty, interrupting is okay</span> <a name="line-118"></a> <a name="line-119"></a><a name="writeSV"></a><span class='hs-comment'>-- | Write a value into the 'MSampleVar', overwriting any previous value that</span> <a name="line-120"></a><span class='hs-comment'>-- was there.</span> <a name="line-121"></a><span class='hs-comment'>--</span> <a name="line-122"></a><span class='hs-comment'>-- 'writeSV' can block and be interrupted, in which case it does nothing.</span> <a name="line-123"></a><span class='hs-definition'>writeSV</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MSampleVar</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span> <a name="line-124"></a><span class='hs-definition'>writeSV</span> <span class='hs-layout'>(</span><span class='hs-conid'>MSampleVar</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>ls</span><span class='hs-layout'>)</span> <span class='hs-varid'>a</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-varid'>ls</span> <span class='hs-varop'>$</span> <span class='hs-keyglyph'>\</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span> <a name="line-125"></a> <span class='hs-varid'>void</span> <span class='hs-layout'>(</span><span class='hs-varid'>tryTakeMVar</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span> <a name="line-126"></a> <span class='hs-varid'>putMVar</span> <span class='hs-varid'>v</span> <span class='hs-varid'>a</span> <span class='hs-comment'>-- cannot block</span> <a name="line-127"></a> <span class='hs-comment'>-- (withMVar ls) might block, interrupting is okay</span> <a name="line-128"></a> <a name="line-129"></a><span class='hs-comment'>{- <a name="line-130"></a> Design notes: <a name="line-131"></a> <a name="line-132"></a> 1) The outer MVar of lockedStore is employed in 'writeSV'. If two 'writeSV' are <a name="line-133"></a> racing in different threads then without the "withMVar ls" they can each <a name="line-134"></a> execute "void (tryTakeMVar v)" and then both execute "putMVar v a", causing <a name="line-135"></a> the second to block. Change putMVar to tryPutMVar lets the first 'writeSV' <a name="line-136"></a> win which arguably contradicts the specification, though this race makes it a <a name="line-137"></a> weak contradiction. <a name="line-138"></a> <a name="line-139"></a> Thus the lockedStore outer MVar is used as a FIFO queue for writeSV/emptySV <a name="line-140"></a> that gives the "previous" in the specification a precise meaning. <a name="line-141"></a> <a name="line-142"></a> 2) There is no 'tryReadSV' because the desired semantics are unclear. With <a name="line-143"></a> 'tryTakeMVar' one is guaranteed to block and a value (Just a) if and only if <a name="line-144"></a> 'takeMVar' would have suceeded without blocking. Also, if you know there are <a name="line-145"></a> no other readers then a Nothing return from 'tryTakeMVar' means that it is <a name="line-146"></a> empty, which is the handiest property. <a name="line-147"></a> <a name="line-148"></a> 3) An alternate design would queue the writers separately and let only <a name="line-149"></a> lead-reader and lead-writer access the stored value. Imagine several queued <a name="line-150"></a> writers and no readers are waiting and then a reader arrives, this reader can <a name="line-151"></a> see a value from the middle of the queue of writers. This would no longer <a name="line-152"></a> guarantees the most up-to-date value is read. <a name="line-153"></a> <a name="line-154"></a> The current design has a very orderly priority of readers and writers. Design <a name="line-155"></a> (3) makes the ordering between readers and writers choatic. Design (1) goes <a name="line-156"></a> further and also makes ordering between different writers chaotic. <a name="line-157"></a> <a name="line-158"></a>-}</span> <a name="line-159"></a> </pre></body> </html>