{-# OPTIONS_GHC -funbox-strict-fields #-}-- |-- Module : Control.Concurrent.NamedLock-- Copyright : (c) Thomas Schilling 2009-- License : BSD-style-- -- Maintainer : nominolo@googlemail.com-- Stability : experimental-- Portability : portable-- -- This module implements \"named locks\".-- -- A named lock is like a normal lock (@MVar ()@) but is created-- on demand. This is useful when you have a potentially infinite-- number of resources that should not be used concurrently.-- -- For example, in a web-server you might create a new lock for each-- database query so that the same query is only run once.-- -- Named locks are allocated in a 'LockPool'. Names are arbitrary,-- well-behaved instances of the 'Ord' class.-- moduleControl.Concurrent.NamedLock(-- * Creating Lock PoolsnewLockPool,LockPool,-- * Working with Named LocksgrabNamedLock,releaseNamedLock,withNamedLock)whereimportControl.ConcurrentimportqualifiedData.MapasMimportControl.Exception(block,unblock,onException)newtypeLockPoolname=LockPool(MVar(M.MapnameNLItem))dataNLItem=NLItem{-# UNPACK #-}!Int{-# UNPACK #-}!(MVar())-- | Create a new, empty, lock pool.newLockPool::IO(LockPoolname)newLockPool=LockPool`fmap`newMVarM.empty-- | Grab the lock with given name. Blocks until the lock becomes-- available.grabNamedLock::Ordname=>LockPoolname->name->IO()grabNamedLock(LockPoolmvar)name=block$domp<-takeMVarmvarcaseM.lookupnamempofNothing->do-- No one currently holds the lock named 'name', so we create it.name_mvar<-newEmptyMVarletmp'=M.insertname(NLItem1name_mvar)mpputMVarmvarmp'Just(NLItemctrname_mvar)->do-- Someone is currently holding the lock.---- 1. Increase the reference counter.letmp'=M.insertname(NLItem(ctr+1)name_mvar)mp-- Integer overflow is possible in principle, but that would-- imply to have (maxBound :: Int) threads contending for-- the same lock, which seems very unlikely.-- 2. Release the outer lock.putMVarmvarmp'-- 3. Finally, wait for the lock to become available.takeMVarname_mvar-- | Release the lock with the given name.-- -- The released lock must have previously been grabbed via-- 'grabNamedLock'.releaseNamedLock::Ordname=>LockPoolname->name->IO()releaseNamedLock(LockPoolmvar)name=block$domp<-takeMVarmvarcaseM.lookupnamempofNothing->doputMVarmvarmperror$"releaseNamedLock: cannot release non-existent lock."Just(NLItemctrname_mvar)->do-- We must not delete the lock before every thread that was-- trying to get it has released it. We use a reference counter-- to keep track of the number of threads that try to grab the-- lock.letmp'|ctr>1=M.insertname(NLItem(ctr-1)name_mvar)mp|otherwise=M.deletenamempputMVarmvarmp'-- Release the lock. This will never block, since no two-- threads can write to the lock without having a reader-- waiting.putMVarname_mvar()-- | Hold the lock while running the action.-- -- If the action throws an exception, the lock is released an the-- exception propagated. Returns the result of the action.withNamedLock::Ordname=>LockPoolname->name->IOa->IOawithNamedLockpoolnameaction=block$dograbNamedLockpoolnameunblockaction`onException`releaseNamedLockpoolname{-
-- Use this for testing.
main = do
lpool <- newLockPool
sequence_ (replicate 20 (forkIO (worker lpool =<< myThreadId)))
worker lpool =<< myThreadId
where
lock_names = ["a", "b", "c", "d", "e"]
num_names = length lock_names
worker lpool tid = do
n <- (lock_names !!) `fmap` randomRIO (0, num_names - 1)
putStrLn $ show tid ++ ": grabbing " ++ show n
grabNamedLock lpool n
--threadDelay 1000000
putStrLn $ show tid ++ ": releasing " ++ show n
releaseNamedLock lpool n
worker lpool tid
-}