diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) Keegan McAllister 2011 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 AUTHORS OR 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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,12 @@ +global-lock provides a single global lock for Haskell code, implemented without +unsafePerformIO. You can use this, for example, to protect a thread-unsafe C +library. global-lock is usable as-is, or as a template for including a similar +lock in your own Haskell project. + +Documentation is hosted at http://hackage.haskell.org/package/global-lock + +To build the documentation yourself, run + + $ cabal configure && cabal haddock --hyperlink-source + +This will produce HTML documentation under dist/doc/html/global-lock diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#! /usr/bin/runhaskell + +import Distribution.Simple +main = defaultMain diff --git a/System/GlobalLock.hs b/System/GlobalLock.hs new file mode 100644 --- /dev/null +++ b/System/GlobalLock.hs @@ -0,0 +1,14 @@ +-- | Provides a single global lock for @'IO'@ actions. +module System.GlobalLock + ( lock + ) where + +import Control.Concurrent.MVar + +import System.GlobalLock.Internal ( get ) + +-- | Take the global lock for the duration of an @'IO'@ action. +-- +-- Two actions executed via @'lock'@ will never run simultaneously. +lock :: IO a -> IO a +lock act = get >>= flip withMVar (const act) diff --git a/System/GlobalLock/Internal.hs b/System/GlobalLock/Internal.hs new file mode 100644 --- /dev/null +++ b/System/GlobalLock/Internal.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE + ForeignFunctionInterface #-} + +-- | Internals of global locking. +-- +-- Use with caution! +module System.GlobalLock.Internal + ( get + ) where + +import Foreign +import Foreign.C +import Control.Monad +import Control.Concurrent.MVar + + +{- Importing c_get_global with 'unsafe' decreases locking latency by + about 50%. The C function just reads a static variable, so it's + okay to use 'unsafe'. + + c_set_global must not be imported 'unsafe' because it uses GCC + atomic-operation builtins which, in the worst case, might call a + blocking library function. -} + +{- If you are copying this file to your own Haskell project, see the + note in cbits/global.c regarding naming. -} + +foreign import ccall unsafe "hs_globalzmlock_get_global" + c_get_global :: IO (Ptr ()) + +foreign import ccall "hs_globalzmlock_set_global" + c_set_global :: Ptr () -> IO CInt + + +set :: IO () +set = do + mv <- newMVar () + ptr <- newStablePtr mv + ret <- c_set_global (castStablePtrToPtr ptr) + when (ret == 0) $ + -- The variable was already set; our StablePtr is unused. + freeStablePtr ptr + +-- | Get the single @'MVar'@ used for global locking. +get :: IO (MVar ()) +get = do + p <- c_get_global + if p == nullPtr + then set >> get + else deRefStablePtr (castPtrToStablePtr p) diff --git a/cbits/global.c b/cbits/global.c new file mode 100644 --- /dev/null +++ b/cbits/global.c @@ -0,0 +1,28 @@ +// Atomic builtins were added in GCC 4.1. +#if !defined(__GNUC__) \ + || (__GNUC__ < 4) \ + || (__GNUC__ == 4 && __GNUC_MINOR__ < 1) +#error global-lock requires GCC 4.1 or later. +#endif + +static void* global = 0; + +/* + If you are copying this file to your own Haskell project, you should + probably change these function names. I suggest replacing 'globalzmlock' + with your package's z-encoded name, following + +*/ + +// Imported 'unsafe' in Haskell code. Must not block! +void* hs_globalzmlock_get_global(void) { + return global; +} + +int hs_globalzmlock_set_global(void* new_global) { + // Set 'global', if it was previously zero. + void* old = __sync_val_compare_and_swap(&global, 0, new_global); + + // Return true iff we set it successfully. + return (old == 0); +} diff --git a/global-lock.cabal b/global-lock.cabal new file mode 100644 --- /dev/null +++ b/global-lock.cabal @@ -0,0 +1,46 @@ +name: global-lock +version: 0.1 +license: BSD3 +license-file: LICENSE +synopsis: A global lock implemented without unsafePerformIO +category: System, Concurrency +author: Keegan McAllister +maintainer: Keegan McAllister +build-type: Simple +cabal-version: >=1.6 +description: + This library provides a single global lock. You can use it, for example, + to protect a thread-unsafe C library. + . + The implementation does not use @unsafePerformIO@. It should be safe + against GHC bugs such as . + . + You can use this library as-is, or as a template for including a similar + lock in your own Haskell project. + . + This library requires that the C compiler invoked by Cabal is GCC 4.1 or + newer. + +extra-source-files: + README + , test/counter.hs + , test/bench.hs + +library + exposed-modules: + System.GlobalLock + , System.GlobalLock.Internal + + c-sources: + cbits/global.c + + ghc-options: -Wall + build-depends: + base >= 3 && < 5 + + other-extensions: + ForeignFunctionInterface + +source-repository head + type: git + location: git://github.com/kmcallister/global-lock diff --git a/test/bench.hs b/test/bench.hs new file mode 100644 --- /dev/null +++ b/test/bench.hs @@ -0,0 +1,12 @@ +import System.GlobalLock + +import Control.Concurrent.MVar +import Criterion.Main + +main :: IO () +main = do + mVar <- newMVar () + defaultMain + [ bench "bare" $ (return () :: IO ()) + , bench "MVar" $ withMVar mVar (const $ return ()) + , bench "global" $ lock (return ()) ] diff --git a/test/counter.hs b/test/counter.hs new file mode 100644 --- /dev/null +++ b/test/counter.hs @@ -0,0 +1,25 @@ +import System.GlobalLock + +import Data.IORef +import Control.Monad +import Control.Concurrent +import Control.Concurrent.Spawn -- package 'spawn' +import System.Exit +import System.Random + +thread :: IORef Int -> IO () +thread ref = replicateM_ 40 . lock $ do + v <- readIORef ref + when (v /= 0) $ do + putStrLn "ERROR: mutual exclusion violation" + exitFailure + + atomicModifyIORef ref (\n -> (n+1,())) + delay <- randomRIO (0,4000) + threadDelay delay + atomicModifyIORef ref (\n -> (n-1,())) + +main :: IO () +main = do + ref <- newIORef 0 + parMapIO_ (const $ thread ref) [0..200]