Permalink
Browse files

Initial commit.

  • Loading branch information...
0 parents commit 92fbbba73a29e54bfc4a54a57e40f482784e5a7a @nominolo committed Aug 24, 2009
Showing with 182 additions and 0 deletions.
  1. +1 −0 .gitignore
  2. +29 −0 LICENSE
  3. +2 −0 README.md
  4. +29 −0 named-lock.cabal
  5. +121 −0 src/Control/Concurrent/NamedLock.hs
@@ -0,0 +1 @@
+dist/
29 LICENSE
@@ -0,0 +1,29 @@
+Copyright 2009, Thomas Schilling
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+
+- Neither name of the author nor the names of its contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
@@ -0,0 +1,2 @@
+named-lock
+========
@@ -0,0 +1,29 @@
+Name: named-lock
+Version: 0.1
+License: BSD3
+License-File: LICENSE
+Author: Thomas Schilling <nominolo@googlemail.com>
+Maintainer: Thomas Schilling <nominolo@googlemail.com>
+Homepage: http://github.com/nominolo/named-lock
+Description: A named lock that is created on demand.
+Synopsis:
+ A named lock that is created on demand.
+ .
+ This is useful for situations where there is a potentially infinite
+ number of resources (e.g., database queries) that should not be used
+ concurrently.
+
+Category: Concurrency
+Stability: provisional
+Build-Type: Simple
+Cabal-Version: >= 1.4
+
+Library
+ Build-Depends:
+ base == 4.*, containers == 0.2.*
+ GHC-Options:
+ -Wall
+ Exposed-Modules:
+ Control.Concurrent.NamedLock
+ Hs-Source-Dirs: src
+
@@ -0,0 +1,121 @@
+{-# 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.
+--
+module Control.Concurrent.NamedLock
+ ( -- * Creating Lock Pools
+ newLockPool, LockPool,
+ -- * Working with Named Locks
+ grabNamedLock, releaseNamedLock, withNamedLock )
+where
+
+import Control.Concurrent
+import qualified Data.Map as M
+import Control.Exception ( block, unblock, onException )
+
+newtype LockPool name = LockPool (MVar (M.Map name NLItem))
+
+data NLItem = NLItem {-# UNPACK #-} !Int
+ {-# UNPACK #-} !(MVar ())
+
+-- | Create a new, empty, lock pool.
+newLockPool :: IO (LockPool name)
+newLockPool = LockPool `fmap` newMVar M.empty
+
+-- | Grab the lock with given name. Blocks until the lock becomes
+-- available.
+grabNamedLock :: Ord name => LockPool name -> name -> IO ()
+grabNamedLock (LockPool mvar) name = block $ do
+ mp <- takeMVar mvar
+ case M.lookup name mp of
+ Nothing -> do
+ -- No one currently holds the lock named 'name', so we create it.
+ name_mvar <- newEmptyMVar
+ let mp' = M.insert name (NLItem 1 name_mvar) mp
+ putMVar mvar mp'
+ Just (NLItem ctr name_mvar) -> do
+ -- Someone is currently holding the lock.
+ --
+ -- 1. Increase the reference counter.
+ let mp' = M.insert name (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.
+ putMVar mvar mp'
+
+ -- 3. Finally, wait for the lock to become available.
+ takeMVar name_mvar
+
+-- | Release the lock with the given name.
+--
+-- The released lock must have previously been grabbed via
+-- 'grabNamedLock'.
+releaseNamedLock :: Ord name => LockPool name -> name -> IO ()
+releaseNamedLock (LockPool mvar) name = block $ do
+ mp <- takeMVar mvar
+ case M.lookup name mp of
+ Nothing -> do
+ putMVar mvar mp
+ error $ "releaseNamedLock: cannot release non-existent lock."
+
+ Just (NLItem ctr name_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.
+ let mp'
+ | ctr > 1 = M.insert name (NLItem (ctr - 1) name_mvar) mp
+ | otherwise = M.delete name mp
+ putMVar mvar mp'
+ -- Release the lock. This will never block, since no two
+ -- threads can write to the lock without having a reader
+ -- waiting.
+ putMVar name_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 :: Ord name => LockPool name -> name -> IO a -> IO a
+withNamedLock pool name action = block $ do
+ grabNamedLock pool name
+ unblock action `onException` releaseNamedLock pool name
+
+{-
+-- 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
+-}

0 comments on commit 92fbbba

Please sign in to comment.