[Haskell] Optimizing locking with MVars

[Bulat Ziganshin]

Hello John,

Wednesday, May 3, 2006, 2:37:03 AM, you wrote:

> This reminds me, I wonder if we should have an MVar varient that is
> _just_ for locking, it would have no separate take and put primitives,
> just a withLock, enforcing the restriction that the thread that took the
> lock is the same one that will return it.

to be exact, i has the following definitions, which uses class to
define 'lock' operation and therefore allow alternative
implementations in future without need to change application code that
uses this operation:

> data WithLocking h = WithLocking h !(MVar ())
> 
> -- | Add lock to object to ensure its proper use in concurrent threads
> addLocking h = do
>     mvar <- newMVar ()
>     return (WithLocking h mvar)
> 
> -- | Run `action` with locked version of object `h`
> withLocking :: h -> (WithLocking h -> IO a) -> IO a
> withLocking h action = do
>     addLocking h >>= action
> 
> -- | Define class of locking implementations, where 'lh' holds lock around 'h'
> class Locking lh h | lh->h where
>     -- | Perform `action` while exclusively locking wrapped object
>     lock :: lh -> (h->IO a) -> IO a
> 
> instance Locking (WithLocking h) h where
>     {-# INLINE lock #-}
>     lock (WithLocking h mvar) action = do
>           -- Faster analog of withMVar
>           Exception.catch (do takeMVar mvar
>                               result <- action h
>                               putMVar mvar ()
>                               return res
>                           )
>                           (\e -> do tryPutMVar mvar (); throw e)
> 
> liftLock1 action h         = lock h (\a -> action a)
> liftLock2 action h x       = lock h (\a -> action a x)
> liftLock3 action h x y     = lock h (\a -> action a x y)
> liftLock4 action h x y z   = lock h (\a -> action a x y z)
> liftLock5 action h x y z t = lock h (\a -> action a x y z t)
> {-# INLINE liftLock1 #-}
> {-# INLINE liftLock2 #-}
> 
> instance (Show h) => Show (WithLocking h) where
>     show (WithLocking h _) = "WithLocking ("++ show h ++")"


and then any type class can be made client of this library, f.e.:

> type WithLocking2 a e m = WithLocking (a e m)
> 
> instance (MArray a e m) => (MArray (WithLocking2 a) e m) where
>     newArray lu e = newArray lu e >>= addLocking
>     newArray_ lu  = newArray_ lu  >>= addLocking
>     unsafeReadArray = liftLock2 unsafeReadArray
>     unsafeWriteArray = liftLock3 unsafeWriteArray
> 
> 
> main = do arr <- newArray (0,9) 0 >>= addLocking
>           readArray arr 0 >>= writeArray arr 1
>           .....



-- 
Best regards,
 Bulat                            mailto:Bulat.Ziganshin at gmail.com