global-lock (empty) → 0.1

raw patch · 9 files changed

+217/−0 lines, 9 filesdep +basesetup-changed

Dependencies added: base

Files

• LICENSE +26/−0
• README +12/−0
• Setup.hs +4/−0
• System/GlobalLock.hs +14/−0
• System/GlobalLock/Internal.hs +50/−0
• cbits/global.c +28/−0
• global-lock.cabal +46/−0
• test/bench.hs +12/−0
• test/counter.hs +25/−0

@@ -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.

@@ -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

@@ -0,0 +1,4 @@+#! /usr/bin/runhaskell++import Distribution.Simple+main = defaultMain

@@ -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)

@@ -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)

@@ -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+    <http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/SymbolNames>+*/++// 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);+}

@@ -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 <mcallister.keegan@gmail.com>+maintainer:          Keegan McAllister <mcallister.keegan@gmail.com>+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 <http://hackage.haskell.org/trac/ghc/ticket/5558>.+    .+    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

@@ -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 ()) ]

@@ -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]