concurrent-supply (empty) → 0.1

raw patch · 4 files changed

+192/−0 lines, 4 filesdep +basedep +ghc-primdep +hashablesetup-changed

Dependencies added: base, ghc-prim, hashable

Files

Control/Concurrent/Supply.hs +131/−0
LICENSE +30/−0
Setup.hs +2/−0
concurrent-supply.cabal +29/−0

+ Control/Concurrent/Supply.hs view

@@ -0,0 +1,131 @@+{-# LANGUAGE MagicHash, UnboxedTuples, Trustworthy #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.Supply+-- Copyright   :  (C) 2011 Edward Kmett,+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- A globally unique fresh identifier supply with local pooling and replay+-- support.+----------------------------------------------------------------------------+module Control.Concurrent.Supply+  ( Supply+  -- * Variables+  , newSupply+  , freshId+  , splitSupply+  -- * Unboxed API+  , freshId#+  , splitSupply#+  ) where++import Data.Hashable+import Data.IORef+import Data.Functor ((<$>))+import Data.Monoid+import GHC.IO (unsafeDupablePerformIO)+import GHC.Types (Int(..))+import GHC.Prim (Int#)++infixr 5 :-+data Stream a = a :- Stream a++instance Functor Stream where+  fmap f (a :- as) = f a :- fmap f as++extract :: Stream a -> a+extract (a :- _) = a++units :: Stream ()+units = () :- units++data Block = Block Int !(Stream Block)++instance Eq Block where+  Block a (Block b _ :- _) == Block c (Block d _ :- _) = a == c && b == d++instance Ord Block where+  Block a (Block b _ :- _) `compare` Block c (Block d _ :- _) = compare a c `mappend` compare b d++instance Show Block where+  showsPrec d (Block a (Block b _ :- _)) = showParen (d >= 10) $+    showString "Block " . showsPrec 10 a . showString " (Block " . showsPrec 10 b . showString " ... :- ...)"++instance Hashable Block where+  hashWithSalt s (Block a (Block b _ :- _)) = s `hashWithSalt` a `hashWithSalt` b++blockSize :: Int+blockSize = 1024+{-# INLINE blockSize #-}++-- Minimum size to be worth splitting a supply rather than just CAS'ing twice to avoid multiple subsequent biased splits+minSplitSupplySize :: Int+minSplitSupplySize = 32 -- based on sqrt blockSize+{-# INLINE minSplitSupplySize #-}++blockCounter :: IORef Int+blockCounter = unsafeDupablePerformIO $ newIORef 0++gen :: () -> Block+gen _ = Block (unsafeDupablePerformIO $ atomicModifyIORef blockCounter $ \ i -> let i' = i + blockSize in (i', i))+              (gen <$> units)+{-# NOINLINE gen #-}++newBlock :: IO Block+newBlock = return $ gen ()+{-# NOINLINE newBlock #-}++splitBlock# :: Block -> (# Block, Block #)+splitBlock# (Block i (x :- xs)) = (# x, Block i xs #)+{-# INLINE splitBlock# #-}++-- | A user managed globally unique variable supply.+data Supply = Supply {-# UNPACK #-} !Int {-# UNPACK #-} !Int Block+  deriving (Eq,Ord,Show)++instance Hashable Supply where+  hashWithSalt s (Supply i j b) = s `hashWithSalt` i `hashWithSalt` j `hashWithSalt` b++blockSupply :: Block -> Supply+blockSupply (Block i bs) = Supply i (i + blockSize - 1) (extract bs)++-- | Grab a new supply. Any two supplies obtained with newSupply are guaranteed to return+-- disjoint sets of identifiers. Replaying the same sequence of operations on the same+-- Supply will yield the same results.+newSupply :: IO Supply+newSupply = blockSupply <$> newBlock++-- | Obtain a fresh Id from a Supply.+freshId :: Supply -> (Int, Supply)+freshId s = case freshId# s of+  (# i, s' #) -> (I# i, s')++-- | Split a supply into two supplies that will return disjoint identifiers+splitSupply :: Supply -> (Supply, Supply)+splitSupply s = case splitSupply# s of+  (# l, r #) -> (l, r)++-- | An unboxed version of freshId+freshId# :: Supply -> (# Int#, Supply #)+freshId# (Supply i@(I# i#) j b)+  | i /= j = (# i#, Supply (i + 1) j b #)+  | otherwise = case b of+    Block k b' -> (# i#, Supply k (k + blockSize - 1) (extract b') #)+{-# INLINE freshId# #-}++-- | An unboxed version of splitSupply+splitSupply# :: Supply -> (# Supply, Supply #)+splitSupply# (Supply i k b) = case splitBlock# b of+    (# bl, br #)+      | k - i >= minSplitSupplySize+      , j <- i + div (k - i) 2 ->+        (# Supply i j bl, Supply (j + 1) k br #)+      | Block x (l :- r :- _) <- bl+      , y <- x + div blockSize 2+      , z <- x + blockSize - 1 ->+        (# Supply x (y - 1) l, Supply y z r #)+{-# INLINE splitSupply# #-}

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright 2011 Edward Kmett++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 AUTHORS ``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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ concurrent-supply.cabal view

@@ -0,0 +1,29 @@+name:          concurrent-supply+category:      Concurrency, Parallelism+version:       0.1+license:       BSD3+cabal-version: >= 1.10+license-file:  LICENSE+author:        Edward A. Kmett+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     experimental+homepage:      http://github.com/ekmett/concurrent-supply/+copyright:     Copyright (C) 2011 Edward A. Kmett+synopsis:      A fast current unique identifier supply with a pure API+description:   A fast current unique identifier supply with a pure API+build-type:    Simple++source-repository head+  type: git+  location: git://github.com/ekmett/concurrent-supply.git++library+  default-language: Haskell2010+  other-extensions: MagicHash, UnboxedTuples+  exposed-modules:+    Control.Concurrent.Supply+  ghc-options: -Wall+  build-depends:+    base     >= 4 && < 5,+    hashable >= 1.1 && < 1.2,+    ghc-prim >= 0.2 && < 0.4