/usr/lib/hugs/packages/base/Control/Concurrent/QSem.hs is in libhugs-base-bundled 98.200609.21-5.3ubuntu1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | -----------------------------------------------------------------------------
-- |
-- Module : Control.Concurrent.QSem
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable (concurrency)
--
-- Simple quantity semaphores.
--
-----------------------------------------------------------------------------
module Control.Concurrent.QSem
( -- * Simple Quantity Semaphores
QSem, -- abstract
newQSem, -- :: Int -> IO QSem
waitQSem, -- :: QSem -> IO ()
signalQSem -- :: QSem -> IO ()
) where
import Prelude
import Control.Concurrent.MVar
import Data.Typeable
-- General semaphores are also implemented readily in terms of shared
-- @MVar@s, only have to catch the case when the semaphore is tried
-- waited on when it is empty (==0). Implement this in the same way as
-- shared variables are implemented - maintaining a list of @MVar@s
-- representing threads currently waiting. The counter is a shared
-- variable, ensuring the mutual exclusion on its access.
-- |A 'QSem' is a simple quantity semaphore, in which the available
-- \"quantity\" is always dealt with in units of one.
newtype QSem = QSem (MVar (Int, [MVar ()]))
qSemTc = mkTyCon "QSem"; instance Typeable QSem where { typeOf _ = mkTyConApp qSemTc [] }
-- |Build a new 'QSem'
newQSem :: Int -> IO QSem
newQSem init = do
sem <- newMVar (init,[])
return (QSem sem)
-- |Wait for a unit to become available
waitQSem :: QSem -> IO ()
waitQSem (QSem sem) = do
(avail,blocked) <- takeMVar sem -- gain ex. access
if avail > 0 then
putMVar sem (avail-1,[])
else do
block <- newEmptyMVar
{-
Stuff the reader at the back of the queue,
so as to preserve waiting order. A signalling
process then only have to pick the MVar at the
front of the blocked list.
The version of waitQSem given in the paper could
lead to starvation.
-}
putMVar sem (0, blocked++[block])
takeMVar block
-- |Signal that a unit of the 'QSem' is available
signalQSem :: QSem -> IO ()
signalQSem (QSem sem) = do
(avail,blocked) <- takeMVar sem
case blocked of
[] -> putMVar sem (avail+1,[])
(block:blocked') -> do
putMVar sem (0,blocked')
putMVar block ()
|