Ticket #785: Locking.hs

File Locking.hs, 6.3 KB (added by guest, 9 years ago)

required by kinds2

Line 
1{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
2-----------------------------------------------------------------------------
3-- |
4-- Module      :  Control.Concurrent.LockingBZ
5-- Copyright   :  (c) Bulat Ziganshin <[email protected]> 2006
6-- License     :  BSD-style (see the file libraries/base/LICENSE)
7--
8-- Maintainer  :  [email protected]
9-- Stability   :  experimental
10-- Portability :  non-portable (concurrency)
11--
12-- Attaching lock to immutable value.
13--
14-----------------------------------------------------------------------------
15
16module Locking
17  (
18          -- * Locking
19
20          -- $intro
21
22          -- ** The 'WithLocking h' type constructor
23        WithLocking(..),        -- instance of Show
24
25          -- ** Attaching lock to value
26        addLocking,             -- :: h -> IO (WithLocking h)
27        withLocking,            -- :: h -> (WithLocking h -> IO a) -> IO a
28
29          -- ** Using value inside lock
30#if defined (__GLASGOW_HASKELL__) || defined (__HUGS__)
31        Locking(..),
32#else
33        lock,
34#endif
35
36          -- ** Promoting operations to use locks
37        liftLock1,
38        liftLock2,
39        liftLock3,
40        liftLock4,
41        liftLock5,
42
43   ) where
44
45import Control.Concurrent.MVar
46import Control.Exception as Exception
47
48{- $intro
49
50This library allows to attach lock to any immutable value so that access
51to this value can be obtained only via the 'lock' operation that ensures
52that this value will never be used at the same time by concurrent threads.
53Lock attached to value by 'addLocking' operation, it's also possible to run
54code block with locked version of some value by 'withLocking' operation.
55
56To work with value contained inside lock, you should use 'lock' operation;
57it's usage is very like to using 'withMVar' for the same purpose, but you
58don't got ability to return new value of internal data from the action
59performed. On the other side, 'lock' operation is about two times faster
60than 'withMVar' according to my tests. There are also 'liftLock*'
61operations that simplifies promoting operations on original value to
62operations on it's locked version. Hugs/GHC version of this library defines
63'lock' as operation of class 'Locking' that opens possibility to define
64alternative 'lock' implementations.
65
66First usage example - adding lock to mutable array and promoting the mutable
67array with lock to support mutable array interface again. This can be done
68with any objects what are accessed through some interface defined via type
69class:
70
71>   import Control.Concurrent.Locking
72>
73>   type WithLocking2 a e m = WithLocking (a e m)
74>
75>   instance (MArray a e m) => (MArray (WithLocking2 a) e m) where
76>       newArray lu e = newArray lu e >>= addLocking
77>       newArray_ lu  = newArray_ lu  >>= addLocking
78>       unsafeRead = liftLock2 unsafeRead
79>       unsafeWrite = liftLock3 unsafeWrite
80>
81>   main = do arr <- newArray (0,9) 0 >>= addLocking
82>             readArray arr 0 >>= writeArray arr 1
83>             .....
84>
85
86Another example where 'lock' operation used to get exclusive access to file
87while performing sequence of operations on it:
88
89>   main = do lh <- openBinaryFile "test" ReadMode >>= addLocking
90>             ....
91>             str <- readStringAt lh pos
92>             ....
93>
94>   readStringAt lh pos =
95>       lock lh $ \h -> do
96>           saved_pos <- hTell h
97>           hSeek h AbsoluteSeek pos
98>           str <- hGetLine h
99>           hSeek h AbsoluteSeek saved_pos
100>           return str
101
102In this example, any thread can use 'readStringAt' on the same locked handle
103without risk to interfere with each other's operation
104
105-}
106
107
108-- -----------------------------------------------------------------------------
109-- 'WithLocking' type constructor and it's constructor functions
110
111-- | Type constructor that attaches lock to immutable value @h@
112data WithLocking h = WithLocking h !(MVar ())
113
114instance (Show h) => Show (WithLocking h) where
115    show (WithLocking h _) = "WithLocking ("++ show h ++")"
116
117-- | Add lock to object to ensure it's proper use in concurrent threads
118addLocking :: h -> IO (WithLocking h)
119addLocking h = do
120    mvar <- newMVar ()
121    return (WithLocking h mvar)
122
123-- | Run @action@ with locked version of object
124withLocking :: h -> (WithLocking h -> IO a) -> IO a
125withLocking h action = do
126    addLocking h >>= action
127
128-- -----------------------------------------------------------------------------
129-- 'lock' operation definition: use MPTC+FD for Hugs/GHC or simple function for
130-- compilers that don't support MPTC+FD
131
132#if defined (__GLASGOW_HASKELL__) || defined (__HUGS__)
133
134-- | Define class of locking implementations, where 'lh' holds lock around 'h'
135class Locking lh h | lh->h where
136    -- | Perform action while exclusively locking wrapped object
137    -- (faster analog of using 'withMVar' for the same purpose)
138    lock :: lh -> (h->IO a) -> IO a
139
140instance Locking (WithLocking h) h where
141    {-# INLINE lock #-}
142    lock
143
144#else
145
146{-# INLINE lock #-}
147-- | Perform action while exclusively locking wrapped object
148-- (faster analog of using 'withMVar' for the same purpose)
149lock :: (WithLocking h) -> (h->IO a) -> IO a
150lock
151
152#endif
153     (WithLocking h mvar) action = do
154        Exception.catch (do takeMVar mvar
155                            result <- action h
156                            putMVar mvar ()
157                            return result
158                        )
159                        (\e -> do tryPutMVar mvar (); throw e)
160
161-- -----------------------------------------------------------------------------
162-- Helper operations - wrappers around 'lock'
163
164{-# INLINE liftLock1 #-}
165-- | Lift 1-parameter action to operation on locked variable
166liftLock1 action h         = lock h (\a -> action a)
167
168{-# INLINE liftLock2 #-}
169-- | Lift 2-parameter action to operation on locked variable
170liftLock2 action h x       = lock h (\a -> action a x)
171
172{-# INLINE liftLock3 #-}
173-- | Lift 3-parameter action to operation on locked variable
174liftLock3 action h x y     = lock h (\a -> action a x y)
175
176{-# INLINE liftLock4 #-}
177-- | Lift 4-parameter action to operation on locked variable
178liftLock4 action h x y z   = lock h (\a -> action a x y z)
179
180{-# INLINE liftLock5 #-}
181-- | Lift 5-parameter action to operation on locked variable
182liftLock5 action h x y z t = lock h (\a -> action a x y z t)
183