stm-containers (empty) → 0.1.0

raw patch · 17 files changed

+1265/−0 lines, 17 filesdep +HTFdep +QuickCheckdep +asyncsetup-changed

Dependencies added: HTF, QuickCheck, async, base, containers, criterion, focus, free, hashable, hashtables, loch-th, mtl, mwc-random, mwc-random-monad, placeholders, primitive, stm-containers, text, unordered-containers

Files

• LICENSE +22/−0
• Setup.hs +2/−0
• executables/APITests.hs +9/−0
• executables/ConcurrentInsertionBench.hs +123/−0
• executables/InsertionBench.hs +52/−0
• executables/Profiling.hs +14/−0
• executables/WordArrayTests.hs +36/−0
• library/STMContainers/HAMT.hs +30/−0
• library/STMContainers/HAMT/Level.hs +29/−0
• library/STMContainers/HAMT/Nodes.hs +158/−0
• library/STMContainers/Map.hs +88/−0
• library/STMContainers/Prelude.hs +74/−0
• library/STMContainers/Set.hs +72/−0
• library/STMContainers/SizedArray.hs +82/−0
• library/STMContainers/WordArray.hs +202/−0
• library/STMContainers/WordArray/Indices.hs +61/−0
• stm-containers.cabal +211/−0

@@ -0,0 +1,22 @@+Copyright (c) 2014, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.

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

@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}++import Test.Framework+import STMContainers.Prelude++import {-@ HTF_TESTS @-} APITests.MapTests+++main = htfMain $ htf_thisModulesTests : htf_importedTests

@@ -0,0 +1,123 @@++import STMContainers.Prelude+import Criterion.Main+import Control.Monad.Free+import Control.Monad.Free.TH+import qualified Data.HashMap.Strict as UC+import qualified STMContainers.Map as SC+import qualified Control.Concurrent.Async as Async+import qualified System.Random.MWC.Monad as MWC+import qualified Focus+++type UCMap k v = TVar (UC.HashMap k (TVar v))+++-- * Actions +-------------------------++data ActionF k v n where+  Insert :: k -> v -> n -> ActionF k v n+  deriving (Functor)++type Action k v = Free (ActionF k v)+++-- * Interpreters+-------------------------++type Interpreter m = +  forall k v r. (Hashable k, Eq k) => m k v -> Action k v r -> STM r++ucInterpreter :: Interpreter UCMap+ucInterpreter m = +  iterM $ \case+    Insert k v n -> do+      mv <- readTVar m+      vt <- newTVar v+      writeTVar m $! UC.insert k vt mv+      n++specializedSCInterpreter :: Interpreter SC.Map+specializedSCInterpreter m =+  iterM $ \case+    Insert k v n -> SC.insert v k m >> n++focusSCInterpreter :: Interpreter SC.Map+focusSCInterpreter m =+  iterM $ \case+    Insert k v n -> SC.focus (Focus.insertM v) k m >> n+++-- * Session and runners+-------------------------++-- | A list of transactions per thread.+type Session k v = [[Action k v ()]]++type SessionRunner = +  forall k v. (Hashable k, Eq k) => Session k v -> IO ()++scSessionRunner :: Interpreter SC.Map -> SessionRunner+scSessionRunner interpreter threadActions = do+  m <- atomically $ SC.new+  void $ flip Async.mapConcurrently threadActions $ \actions -> do+    forM_ actions $ atomically . interpreter m++ucSessionRunner :: SessionRunner+ucSessionRunner threadActions = do+  m <- newTVarIO UC.empty+  void $ flip Async.mapConcurrently threadActions $ \actions -> do+    forM_ actions $ atomically . ucInterpreter m+++-- * Generators+-------------------------++type Generator a = MWC.Rand IO a++transactionGenerator :: Generator (Action Float Int ())+transactionGenerator =+  Free <$> (Insert <$> k <*> v <*> n)+  where+    k = MWC.uniform+    v = MWC.uniform+    n = MWC.uniform >>= bool (return (Pure ())) transactionGenerator+++-- * Utils+-------------------------++slices :: Int -> [a] -> [[a]]+slices size l =+  case splitAt size l of+    ([], _) -> []+    (a, b) -> a : slices size b+++-- * Main+-------------------------++main = do+  allActions <- MWC.runWithCreate $ replicateM actionsNum transactionGenerator+  defaultMain $! flip map threadsNums $! \threadsNum ->+    let+      sliceSize = actionsNum `div` threadsNum+      threadActions = slices sliceSize allActions+      in +        bgroup+          (shows threadsNum . showString "/" . shows sliceSize $ "")+          [+            bgroup "STM Containers"+              [+                bench "Focus-based" $ +                  scSessionRunner focusSCInterpreter threadActions,+                bench "Specialized" $ +                  scSessionRunner specializedSCInterpreter threadActions+              ],+            bench "Unordered Containers" $+              ucSessionRunner threadActions+          ]+  where+    actionsNum = 100000+    threadsNums = [1, 2, 4, 8, 16, 32]

@@ -0,0 +1,52 @@++import STMContainers.Prelude+import Criterion.Main+import qualified Data.HashTable.IO as Hashtables+import qualified Data.HashMap.Strict as UnorderedContainers+import qualified Data.Map as Containers+import qualified STMContainers.Map as STMContainers+import qualified Focus+import qualified System.Random.MWC.Monad as MWC+import qualified Data.Char as Char+import qualified Data.Text as Text++main = do+  keys <- MWC.runWithCreate $ replicateM rows keyGenerator+  defaultMain+    [+      bgroup "STM Containers"+      [+        bench "focus-based" $ +          do+            t <- atomically $ STMContainers.new :: IO (STMContainers.Map Text.Text ())+            forM_ keys $ \k -> atomically $ STMContainers.focus (Focus.insertM ()) k t+        ,+        bench "specialized" $+          do+            t <- atomically $ STMContainers.new :: IO (STMContainers.Map Text.Text ())+            forM_ keys $ \k -> atomically $ STMContainers.insert () k t+      ]+      ,+      bench "Unordered Containers" $+        nf (foldr (\k -> UnorderedContainers.insert k ()) UnorderedContainers.empty) keys+      ,+      bench "Containers" $+        nf (foldr (\k -> Containers.insert k ()) Containers.empty) keys+      ,+      bench "Hashtables" $ +        do+          t <- Hashtables.new :: IO (Hashtables.BasicHashTable Text.Text ())+          forM_ keys $ \k -> Hashtables.insert t k ()+    ]++rows :: Int = 100000++keyGenerator :: MWC.Rand IO Text.Text+keyGenerator = do+  l <- length+  s <- replicateM l char+  return $! Text.pack s+  where+    length = MWC.uniformR (7, 20)+    char = Char.chr <$> MWC.uniformR (Char.ord 'a', Char.ord 'z')+

@@ -0,0 +1,14 @@++import STMContainers.Prelude+import qualified STMContainers.Map as STMContainers+import qualified Control.Concurrent.Async as Async+++main = do+  t <- atomically $ STMContainers.new :: IO (STMContainers.Map Int ())+  void $ flip Async.mapConcurrently [0 .. pred threads] $ \ti -> do+    forM_ [ti * (rows `div` threads) .. (succ ti) * (rows `div` threads)] $ \ri -> do+      atomically $ STMContainers.insert () ri t+  where+    threads = 4+    rows = 100000

@@ -0,0 +1,36 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}++import Test.Framework+import STMContainers.Prelude+import STMContainers.Transformers+import qualified STMContainers.WordArray as WordArray+import qualified Focus+import qualified WordArrayTests.Update as Update+++main = htfMain $ htf_thisModulesTests++prop_differentInterpretersProduceSameResults (update :: Update.Update Char ()) =+  Update.interpretMaybeList update ==+  fmap WordArray.toMaybeList (Update.interpretWordArray update)++prop_fromListIsIsomorphicToToList =+  forAll gen prop+  where+    gen = do+      indices <- (nub . sort) <$> listOf index+      mapM (liftA2 (flip (,)) char . pure) indices+      where+        index = choose (0, pred (WordArray.maxSize)) :: Gen Int+        char = arbitrary :: Gen Char+    prop list = +      list === (WordArray.toList . WordArray.fromList) list++test_focusMLookup = do+  assertEqual (Just 'a') . fst =<< WordArray.focusM Focus.lookupM 3 w+  assertEqual (Just 'b') . fst =<< WordArray.focusM Focus.lookupM 7 w+  assertEqual Nothing . fst =<< WordArray.focusM Focus.lookupM 1 w+  assertEqual Nothing . fst =<< WordArray.focusM Focus.lookupM 11 w+  where+    w = WordArray.fromList [(3, 'a'), (7, 'b'), (14, 'c')]+

@@ -0,0 +1,30 @@+module STMContainers.HAMT where++import STMContainers.Prelude hiding (insert, lookup, delete, foldM)+import qualified STMContainers.HAMT.Nodes as Nodes+import qualified Focus+++type HAMT e = Nodes.Nodes e++type Element e = (Nodes.Element e, Hashable (Nodes.ElementKey e))++{-# INLINE insert #-}+insert :: (Element e) => e -> HAMT e -> STM ()+insert e = Nodes.insert e (hash (Nodes.elementKey e)) (Nodes.elementKey e) 0++{-# INLINE focus #-}+focus :: (Element e) => Focus.StrategyM STM e r -> Nodes.ElementKey e -> HAMT e -> STM r+focus s k = Nodes.focus s (hash k) k 0++{-# INLINE foldM #-}+foldM :: (a -> e -> STM a) -> a -> HAMT e -> STM a+foldM step acc = Nodes.foldM step acc 0++{-# INLINE new #-}+new :: STM (HAMT e)+new = Nodes.new++{-# INLINE null #-}+null :: HAMT e -> STM Bool+null v = $notImplemented

@@ -0,0 +1,29 @@+module STMContainers.HAMT.Level where++import STMContainers.Prelude hiding (mask)+++-- |+-- A depth level of a node.+-- Must be a multiple of the 'step' value.+type Level = Int++{-# INLINE hashIndex #-}+hashIndex :: Level -> (Int -> Int)+hashIndex l i = mask .&. unsafeShiftR i l++{-# INLINE mask #-}+mask :: Int+mask = bit step - 1++{-# INLINE step #-}+step :: Int+step = 5++{-# INLINE limit #-}+limit :: Int+limit = bitSize (undefined :: Int)++{-# INLINE succ #-}+succ :: Level -> Level+succ = (+ step)

@@ -0,0 +1,158 @@+module STMContainers.HAMT.Nodes where++import STMContainers.Prelude hiding (insert, lookup, delete, foldM, null)+import qualified STMContainers.WordArray as WordArray+import qualified STMContainers.SizedArray as SizedArray+import qualified STMContainers.HAMT.Level as Level+import qualified Focus+++type Nodes e = TVar (WordArray.WordArray (Node e))++data Node e = +  Nodes {-# UNPACK #-} !(Nodes e) |+  Leaf {-# UNPACK #-} !Hash !e |+  Leaves {-# UNPACK #-} !Hash {-# UNPACK #-} !(SizedArray.SizedArray e)++type Hash = Int++data Operation e r =+  Insert e |+  Delete |+  Lookup |+  Edit (Maybe e -> (r, Maybe e))+++class (Eq (ElementKey e)) => Element e where+  type ElementKey e+  elementKey :: e -> ElementKey e++{-# INLINE new #-}+new :: STM (Nodes e)+new = newTVar WordArray.empty++insert :: (Element e) => e -> Hash -> ElementKey e -> Level.Level -> Nodes e -> STM ()+insert e h k l ns = do+  a <- readTVar ns+  let write n = writeTVar ns $ WordArray.set i n a+  case WordArray.lookup i a of+    Nothing -> write (Leaf h e)+    Just n -> case n of+      Nodes ns' -> insert e h k (Level.succ l) ns'+      Leaf h' e' ->+        if h' == h+          then if elementKey e' == k+            then write (Leaf h e)+            else write (Leaves h (SizedArray.pair e e'))+          else do+            nodes <- pair h (Leaf h e) h' (Leaf h' e') (Level.succ l)+            write (Nodes nodes)+      Leaves h' la ->+        if h' == h+          then case SizedArray.find ((== k) . elementKey) la of+            Just (lai, _) ->+              write (Leaves h' (SizedArray.insert lai e la))+            Nothing ->+              write (Leaves h' (SizedArray.append e la))+          else+            write . Nodes =<< pair h (Leaf h e) h' (Leaves h' la) (Level.succ l)+  where+    i = Level.hashIndex l h++pair :: Hash -> Node e -> Hash -> Node e -> Level.Level -> STM (Nodes e)+pair h1 n1 h2 n2 l =+  if i1 == i2+    then newTVar . WordArray.singleton i1 . Nodes =<< pair h1 n1 h2 n2 (Level.succ l)+    else newTVar $ WordArray.pair i1 n1 i2 n2+  where+    hashIndex = Level.hashIndex l+    i1 = hashIndex h1+    i2 = hashIndex h2++focus :: (Element e) => Focus.StrategyM STM e r -> Hash -> ElementKey e -> Level.Level -> Nodes e -> STM r+focus s h k l ns = do+  a <- readTVar ns+  (r, a'm) <- WordArray.focusM s' ai a+  maybe (return ()) (writeTVar ns) a'm+  return r+  where+    ai = Level.hashIndex l h+    s' = \case+      Nothing -> traversePair (return . fmap (Leaf h)) =<< s Nothing+      Just n -> case n of+        Nodes ns' -> do+          r <- focus s h k (Level.succ l) ns'+          null ns' >>= \case+            True -> return (r, Focus.Remove)+            False -> return (r, Focus.Keep)+        Leaf h' e' ->+          case h' == h of+            True -> +              case elementKey e' == k of+                True  -> +                  traversePair (return . fmap (Leaf h)) =<< s (Just e')+                False -> +                  traversePair processDecision =<< s Nothing+                  where+                    processDecision = \case+                      Focus.Replace e -> +                        return (Focus.Replace (Leaves h (SizedArray.pair e e')))+                      _ -> +                        return Focus.Keep+            False -> +              traversePair processDecision =<< s Nothing+              where+                processDecision = \case+                  Focus.Replace e -> do+                    ns' <- pair h (Leaf h e) h' (Leaf h' e') (Level.succ l)+                    return (Focus.Replace (Nodes ns'))+                  _ -> return Focus.Keep+        Leaves h' a' ->+          case h' == h of+            True ->+              case SizedArray.find ((== k) . elementKey) a' of+                Just (i', e') -> +                  s (Just e') >>= traversePair processDecision+                  where+                    processDecision = \case+                      Focus.Keep -> +                        return Focus.Keep+                      Focus.Remove -> +                        case SizedArray.delete i' a' of+                          a'' -> case SizedArray.null a'' of+                            False -> return (Focus.Replace (Leaves h' a''))+                            True -> return Focus.Remove+                      Focus.Replace e ->+                        return (Focus.Replace (Leaves h' (SizedArray.insert i' e a')))+                Nothing -> +                  s Nothing >>= traversePair processDecision+                  where+                    processDecision = \case+                      Focus.Replace e ->+                        return (Focus.Replace (Leaves h' (SizedArray.append e a')))+                      _ ->+                        return Focus.Keep+            False ->+              s Nothing >>= traversePair processDecision+              where+                processDecision = \case+                  Focus.Replace e -> do+                    ns' <- pair h (Leaf h e) h' (Leaves h' a') (Level.succ l)+                    return (Focus.Replace (Nodes ns'))+                  _ ->+                    return Focus.Keep+    -- | A replacement for the missing 'Traverse' instance of pair in base < 4.7.+    traversePair f (x, y) = (,) x <$> f y+                  ++null :: Nodes e -> STM Bool+null = fmap WordArray.null . readTVar++foldM :: (a -> e -> STM a) -> a -> Level.Level -> Nodes e -> STM a+foldM step acc level = +  readTVar >=> WordArray.foldM step' acc+  where+    step' acc' = \case+      Nodes ns -> foldM step acc' (Level.succ level) ns+      Leaf _ e -> step acc' e+      Leaves _ a -> SizedArray.foldM step acc' a

@@ -0,0 +1,88 @@+module STMContainers.Map+(+  Map,+  Key,+  new,+  insert,+  delete,+  lookup,+  focus,+  foldM,+  null,+)+where++import STMContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)+import qualified STMContainers.HAMT as HAMT+import qualified STMContainers.HAMT.Nodes as HAMTNodes+import qualified Focus+++-- |+-- A hash table, based on an STM-specialized hash array mapped trie.+newtype Map k v = Map (HAMT.HAMT (Association k v))++-- |+-- A standard constraint for keys.+type Key a = (Eq a, Hashable a)++-- |+-- A key-value association.+type Association k v = (k, v)++instance (Eq k) => HAMTNodes.Element (Association k v) where+  type ElementKey (Association k v) = k+  elementKey (k, v) = k++{-# INLINE associationValue #-}+associationValue :: Association k v -> v+associationValue (_, v) = v++-- |+-- Look up an item.+{-# INLINE lookup #-}+lookup :: (Key k) => k -> Map k v -> STM (Maybe v)+lookup k = focus Focus.lookupM k++-- |+-- Insert a key and a value.+{-# INLINE insert #-}+insert :: (Key k) => v -> k -> Map k v -> STM ()+insert !v !k (Map h) = HAMT.insert (k, v) h++-- |+-- Delete an item by a key.+{-# INLINE delete #-}+delete :: (Key k) => k -> Map k v -> STM ()+delete k (Map h) = HAMT.focus Focus.deleteM k h++-- |+-- Focus on an item by a key with a strategy.+-- +-- This function allows to perform composite operations in a single access+-- to a map item.+-- E.g., you can lookup an item and delete it at the same time,+-- or update it and return the new value.+{-# INLINE focus #-}+focus :: (Key k) => Focus.StrategyM STM v r -> k -> Map k v -> STM r+focus f k (Map h) = HAMT.focus f' k h+  where+    f' = (fmap . fmap . fmap) (\v -> k `seq` v `seq` (k, v)) . f . fmap associationValue++-- |+-- Fold all the items of a map.+{-# INLINE foldM #-}+foldM :: (a -> (k, v) -> STM a) -> a -> Map k v -> STM a+foldM s a (Map h) = HAMT.foldM s a h++-- |+-- Construct a new map.+{-# INLINE new #-}+new :: STM (Map k v)+new = Map <$> HAMT.new++-- |+-- Check, whether the map is empty.+{-# INLINE null #-}+null :: Map k v -> STM Bool+null (Map h) = HAMT.null h

@@ -0,0 +1,74 @@+module STMContainers.Prelude+( +  module Exports,+  bug,+  bottom,+  bool,+)+where++-- base+-------------------------+import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, FilePath, id, (.))+import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Applicative as Exports+import Control.Arrow as Exports hiding (left, right)+import Control.Category as Exports+import Data.Monoid as Exports+import Data.Foldable as Exports+import Data.Traversable as Exports hiding (for)+import Data.Maybe as Exports+import Data.Either as Exports+import Data.List as Exports hiding (concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')+import Data.Tuple as Exports+import Data.Function as Exports hiding ((.), id)+import Data.Ord as Exports (Down(..))+import Data.String as Exports+import Data.Int as Exports+import Data.Word as Exports+import Data.Ratio as Exports+import Data.Bits as Exports+import Data.Fixed as Exports+import Data.Ix as Exports+import Data.Data as Exports+import Data.Bool as Exports hiding (bool)+import Text.Read as Exports (readMaybe, readEither)+import Control.Exception as Exports hiding (tryJust, try, assert)+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import System.Exit as Exports+import System.IO.Unsafe as Exports+import System.IO as Exports (Handle, hClose)+import System.IO.Error as Exports+import Unsafe.Coerce as Exports+import GHC.Conc as Exports+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import GHC.Exts as Exports (lazy, inline)+import Data.IORef as Exports+import Data.STRef as Exports+import Control.Monad.ST as Exports+import Debug.Trace as Exports hiding (traceM)++-- placeholders+-------------------------+import Development.Placeholders as Exports++-- hashable+-------------------------+import Data.Hashable as Exports (Hashable(..))++-- custom+-------------------------+import qualified Debug.Trace.LocationTH++bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]+  where+    msg = "A \"stm-containers\" package bug: " :: String++bottom = [e| $bug "Bottom evaluated" |]++bool :: a -> a -> Bool -> a+bool f _ False = f+bool _ t True  = t

@@ -0,0 +1,72 @@+module STMContainers.Set+(+  Set,+  Element,+  new,+  insert,+  delete,+  lookup,+  foldM,+  null,+)+where++import STMContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)+import qualified STMContainers.HAMT as HAMT+import qualified STMContainers.HAMT.Nodes as HAMTNodes+import qualified Focus+++-- |+-- A hash set, based on an STM-specialized hash array mapped trie.+newtype Set e = Set {hamt :: HAMT.HAMT (HAMTElement e)}++-- |+-- A standard constraint for elements.+type Element a = (Eq a, Hashable a)++newtype HAMTElement e = HAMTElement e++instance (Eq e) => HAMTNodes.Element (HAMTElement e) where+  type ElementKey (HAMTElement e) = e+  elementKey (HAMTElement e) = e++{-# INLINABLE elementValue #-}+elementValue :: HAMTElement e -> e+elementValue (HAMTElement e) = e++-- |+-- Insert a new element.+{-# INLINABLE insert #-}+insert :: (Element e) => e -> Set e -> STM ()+insert e = HAMT.insert (HAMTElement e) . hamt++-- |+-- Delete an element.+{-# INLINABLE delete #-}+delete :: (Element e) => e -> Set e -> STM ()+delete e = HAMT.focus Focus.deleteM e . hamt++-- |+-- Lookup an element.+{-# INLINABLE lookup #-}+lookup :: (Element e) => e -> Set e -> STM Bool+lookup e = fmap (maybe False (const True)) . HAMT.focus Focus.lookupM e . hamt++-- |+-- Fold all the elements.+{-# INLINABLE foldM #-}+foldM :: (a -> e -> STM a) -> a -> Set e -> STM a+foldM f a = HAMT.foldM (\a -> f a . elementValue) a . hamt++-- |+-- Construct a new set.+{-# INLINABLE new #-}+new :: STM (Set e)+new = Set <$> HAMT.new++-- |+-- Check, whether the set is empty.+{-# INLINABLE null #-}+null :: Set e -> STM Bool+null = HAMT.null . hamt

@@ -0,0 +1,82 @@+module STMContainers.SizedArray where++import STMContainers.Prelude hiding (lookup, toList, foldM)+import Data.Primitive.Array+import qualified STMContainers.Prelude as Prelude+import qualified Focus++-- |+-- An array, +-- which sacrifices the performance for space-efficiency and thread-safety.+data SizedArray a =+  SizedArray {-# UNPACK #-} !Int {-# UNPACK #-} !(Array a)++-- |+-- An index of an element.+type Index = Int++{-# INLINE pair #-}+pair :: a -> a -> SizedArray a+pair e e' =+  runST $ do+    a <- newArray 2 e+    writeArray a 1 e'+    SizedArray 2 <$> unsafeFreezeArray a++-- |+-- Get the amount of elements.+{-# INLINE size #-}+size :: SizedArray a -> Int+size (SizedArray b _) = b++-- |+-- Get the amount of elements.+{-# INLINE null #-}+null :: SizedArray a -> Bool+null = (== 0) . size++{-# INLINE find #-}+find :: (a -> Bool) -> SizedArray a -> Maybe (Index, a)+find p (SizedArray s a) = loop 0+  where+    loop i = if i < s+      then let e = indexArray a i in if p e+        then Just (i, e)+        else loop (succ i)+      else Nothing++-- |+-- Unsafe. Doesn't check the index overflow.+{-# INLINE insert #-}+insert :: Index -> a -> SizedArray a -> SizedArray a+insert i e (SizedArray s a) = +  runST $ do+    m' <- newArray s undefined+    forM_ [0 .. pred s] $ \i' -> indexArrayM a i' >>= writeArray m' i'+    writeArray m' i e+    SizedArray s <$> unsafeFreezeArray m'++{-# INLINE delete #-}+delete :: Index -> SizedArray a -> SizedArray a+delete i (SizedArray s a) = +  runST $ do+    m' <- newArray (pred s) undefined+    forM_ [0 .. pred i] $ \i' -> indexArrayM a i' >>= writeArray m' i'+    forM_ [succ i .. pred s] $ \i' -> indexArrayM a i' >>= writeArray m' (pred i')+    SizedArray (pred s) <$> unsafeFreezeArray m'++{-# INLINE append #-}+append :: a -> SizedArray a -> SizedArray a+append e (SizedArray s a) =+  runST $ do+    m' <- newArray (succ s) undefined+    forM_ [0 .. pred s] $ \i -> indexArrayM a i >>= writeArray m' i+    writeArray m' s e+    SizedArray (succ s) <$> unsafeFreezeArray m'++{-# INLINE foldM #-}+foldM :: (Monad m) => (a -> b -> m a) -> a -> SizedArray b -> m a+foldM step acc (SizedArray size array) =+  Prelude.foldM step' acc [0 .. pred size]+  where+    step' acc' i = indexArrayM array i >>= step acc'

@@ -0,0 +1,202 @@+module STMContainers.WordArray where++import STMContainers.Prelude hiding (lookup, toList, traverse_)+import Data.Primitive.Array+import qualified STMContainers.Prelude as Prelude+import qualified STMContainers.WordArray.Indices as Indices+import qualified Focus+++-- |+-- An immutable space-efficient sparse array, +-- which can store only as many elements as there are bits in the machine word.+data WordArray e =+  WordArray {-# UNPACK #-} !Indices {-# UNPACK #-} !(Array e)++-- | +-- A bitmap of set elements.+type Indices = Indices.Indices++-- |+-- An index of an element.+type Index = Int++{-# INLINE indices #-}+indices :: WordArray e -> Indices+indices (WordArray b _) = b++{-# INLINE maxSize #-}+maxSize :: Int+maxSize = Indices.maxSize++empty :: WordArray e+empty = WordArray 0 a+  where+    a = runST $ newArray 0 undefined >>= unsafeFreezeArray++-- |+-- An array with a single element at the specified index.+{-# INLINE singleton #-}+singleton :: Index -> e -> WordArray e+singleton i e = +  let b = Indices.insert i 0+      a = runST $ newArray 1 e >>= unsafeFreezeArray+      in WordArray b a++{-# INLINE pair #-}+pair :: Index -> e -> Index -> e -> WordArray e+pair i e i' e' =+  WordArray is a+  where +    is = Indices.fromList [i, i']+    a = +      runST $ if +        | i < i' -> do+          a <- newArray 2 e+          writeArray a 1 e'+          unsafeFreezeArray a+        | i > i' -> do+          a <- newArray 2 e+          writeArray a 0 e'+          unsafeFreezeArray a+        | i == i' -> do+          a <- newArray 1 e'+          unsafeFreezeArray a++-- |+-- Unsafe.+-- Assumes that the list is sorted and contains no duplicate indexes.+{-# INLINE fromList #-}+fromList :: [(Index, e)] -> WordArray e+fromList l = +  runST $ do+    indices <- newSTRef 0+    array <- newArray (length l) undefined+    forM_ (zip l [0..]) $ \((i, e), ai) -> do+      modifySTRef indices $ Indices.insert i+      writeArray array ai e+    WordArray <$> readSTRef indices <*> unsafeFreezeArray array+  +{-# INLINE toList #-}+toList :: WordArray e -> [(Index, e)]+toList (WordArray is a) = do+  i <- Indices.toList is+  e <- indexArrayM a (Indices.position i is)+  return (i, e)++-- |+-- Convert into a list representation.+{-# INLINE toMaybeList #-}+toMaybeList :: WordArray e -> [Maybe e]+toMaybeList w = do+  i <- [0 .. pred Indices.maxSize] +  return $ lookup i w++{-# INLINE elements #-}+elements :: WordArray e -> [e]+elements (WordArray indices array) =+  map (\i -> indexArray array (Indices.position i indices)) .+  Indices.toList $+  indices++-- |+-- Set an element value at the index.+{-# INLINE set #-}+set :: Index -> e -> WordArray e -> WordArray e+set i e (WordArray b a) = +  let +    sparseIndex = Indices.position i b+    size = Indices.size b+    in if Indices.elem i b+      then +        let a' = runST $ do+              ma' <- newArray size undefined+              forM_ [0 .. (size - 1)] $ \i -> indexArrayM a i >>= writeArray ma' i+              writeArray ma' sparseIndex e+              unsafeFreezeArray ma'+            in WordArray b a'+      else+        let a' = runST $ do+              ma' <- newArray (size + 1) undefined+              forM_ [0 .. (sparseIndex - 1)] $ \i -> indexArrayM a i >>= writeArray ma' i+              writeArray ma' sparseIndex e+              forM_ [sparseIndex .. (size - 1)] $ \i -> indexArrayM a i >>= writeArray ma' (i + 1)+              unsafeFreezeArray ma'+            b' = Indices.insert i b+            in WordArray b' a'++-- |+-- Remove an element.+{-# INLINE unset #-}+unset :: Index -> WordArray e -> WordArray e+unset i (WordArray b a) =+  if Indices.elem i b+    then+      let +        b' = Indices.invert i b+        a' = runST $ do+          ma' <- newArray (pred size) undefined+          forM_ [0 .. pred sparseIndex] $ \i -> indexArrayM a i >>= writeArray ma' i+          forM_ [succ sparseIndex .. pred size] $ \i -> indexArrayM a i >>= writeArray ma' (pred i)+          unsafeFreezeArray ma'+        sparseIndex = Indices.position i b+        size = Indices.size b+        in WordArray b' a'+    else WordArray b a++-- |+-- Lookup an item at the index.+{-# INLINE lookup #-}+lookup :: Index -> WordArray e -> Maybe e+lookup i (WordArray b a) =+  if Indices.elem i b+    then Just (indexArray a (Indices.position i b))+    else Nothing++-- |+-- Lookup strictly, using 'indexArrayM'.+{-# INLINE lookupM #-}+lookupM :: Monad m => Index -> WordArray e -> m (Maybe e)+lookupM i (WordArray b a) =+  if Indices.elem i b+    then liftM Just (indexArrayM a (Indices.position i b))+    else return Nothing++-- |+-- Check, whether there is an element at the index.+{-# INLINE isSet #-}+isSet :: Index -> WordArray e -> Bool+isSet i = Indices.elem i . indices++-- |+-- Get the amount of elements.+{-# INLINE size #-}+size :: WordArray e -> Int+size = Indices.size . indices++{-# INLINE null #-}+null :: WordArray e -> Bool+null = Indices.null . indices++{-# INLINE traverse_ #-}+traverse_ :: Applicative f => (a -> f b) -> WordArray a -> f ()+traverse_ f =+  inline Prelude.traverse_ f . elements++{-# INLINE foldM #-}+foldM :: Monad m => (a -> b -> m a) -> a -> WordArray b -> m a+foldM step acc =+  inline Prelude.foldM step acc . elements++{-# INLINE focusM #-}+focusM :: Monad m => Focus.StrategyM m a r -> Index -> WordArray a -> m (r, Maybe (WordArray a))+focusM f i w = do+  let em = lookup i w+  (r, c) <- f em+  let w' = case c of+        Focus.Keep -> Nothing+        Focus.Remove -> case em of+          Nothing -> Nothing+          Just _ -> Just $ unset i w+        Focus.Replace e' -> Just $ set i e' w+  return (r, w')

@@ -0,0 +1,61 @@+module STMContainers.WordArray.Indices where++import STMContainers.Prelude hiding (toList, traverse_)+import qualified STMContainers.Prelude as Prelude+++-- |+-- A compact set of indices.+type Indices = Int++type Index = Int++-- |+-- A number of indexes, preceding this one.+{-# INLINE position #-}+position :: Index -> Indices -> Int+position i b = popCount (b .&. (bit i - 1))++{-# INLINE singleton #-}+singleton :: Index -> Indices+singleton = bit++{-# INLINE insert #-}+insert :: Index -> Indices -> Indices+insert i = (bit i .|.)++{-# INLINE invert #-}+invert :: Index -> Indices -> Indices+invert i = (bit i `xor`)++{-# INLINE elem #-}+elem :: Index -> Indices -> Bool+elem = flip testBit++{-# INLINE size #-}+size :: Indices -> Int+size = popCount++{-# INLINE null #-}+null :: Indices -> Bool+null = (== 0)++{-# INLINE maxSize #-}+maxSize :: Int+maxSize = bitSize (undefined :: Indices)++{-# INLINE fromList #-}+fromList :: [Index] -> Indices+fromList = foldr (.|.) 0 . map bit++{-# INLINE toList #-}+toList :: Indices -> [Index]+toList w = filter (testBit w) allIndices++{-# NOINLINE allIndices #-}+allIndices :: [Index]+allIndices = [0 .. pred maxSize]++{-# INLINE traverse_ #-}+traverse_ :: Applicative f => (Index -> f b) -> Indices -> f ()+traverse_ f = inline Prelude.traverse_ f . inline toList

@@ -0,0 +1,211 @@+name:+  stm-containers+version:+  0.1.0+synopsis:+  Containers for STM+description:+  This library is based on an STM-specialized implementation of+  Hash Array Mapped Trie.+  It provides very efficient implementations of @Map@ and @Set@ data structures,+  which are slightly slower than \"unordered-containers\",+  but scale very well on concurrent access patterns.+category:+  Data Structures, STM, Concurrency+homepage:+  https://github.com/nikita-volkov/stm-containers +bug-reports:+  https://github.com/nikita-volkov/stm-containers/issues +author:+  Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+  Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+  (c) 2014, Nikita Volkov+license:+  MIT+license-file:+  LICENSE+build-type:+  Simple+cabal-version:+  >=1.10+++source-repository head+  type:+    git+  location:+    git://github.com/nikita-volkov/stm-containers.git+++library+  hs-source-dirs:+    library+  other-modules:+    STMContainers.Prelude+    STMContainers.WordArray.Indices+    STMContainers.WordArray+    STMContainers.SizedArray+    STMContainers.HAMT.Level+    STMContainers.HAMT.Nodes+    STMContainers.HAMT+  exposed-modules:+    STMContainers.Map+    STMContainers.Set+  build-depends:+    -- debugging:+    loch-th == 0.2.*,+    placeholders == 0.1.*,+    -- general:+    focus > 0.1.0 && < 0.2,+    hashable < 1.3,+    primitive == 0.5.*,+    base >= 4.5 && < 4.8+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+++test-suite word-array-tests+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    executables+    library+  main-is:+    WordArrayTests.hs+  build-depends:+    QuickCheck == 2.7.*,+    HTF == 0.11.*,+    -- debugging:+    loch-th == 0.2.*,+    placeholders == 0.1.*,+    -- general:+    focus > 0.1.0 && < 0.2,+    free >= 4.6 && < 4.10,+    mtl == 2.*,+    hashable < 1.3,+    primitive == 0.5.*,+    base >= 4.5 && < 4.8+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+++test-suite api-tests+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    executables+  main-is:+    APITests.hs+  build-depends:+    QuickCheck == 2.7.*,+    HTF == 0.11.*,+    stm-containers,+    -- debugging:+    loch-th == 0.2.*,+    placeholders == 0.1.*,+    -- general:+    focus > 0.1.0 && < 0.2,+    unordered-containers == 0.2.*,+    free >= 4.6 && < 4.10,+    mtl == 2.*,+    hashable < 1.3,+    base >= 4.5 && < 4.8+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+++benchmark insertion-bench+  type: +    exitcode-stdio-1.0+  hs-source-dirs:+    executables+  main-is:+    InsertionBench.hs+  ghc-options:+    -O2 -threaded "-with-rtsopts=-N"+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  build-depends:+    mwc-random == 0.13.*,+    mwc-random-monad == 0.7.*,+    criterion == 0.8.*,+    -- data:+    text < 1.2,+    focus > 0.1.0 && < 0.2,+    hashable < 1.3,+    hashtables == 1.1.*,+    containers == 0.5.*,+    unordered-containers == 0.2.*,+    stm-containers,+    -- debugging:+    loch-th == 0.2.*,+    placeholders == 0.1.*,+    -- general:+    base >= 4.5 && < 5+++benchmark concurrent-insertion-bench+  type: +    exitcode-stdio-1.0+  hs-source-dirs:+    executables+  main-is:+    ConcurrentInsertionBench.hs+  ghc-options:+    -O2 -threaded "-with-rtsopts=-N"+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  build-depends:+    criterion == 0.8.*,+    mwc-random == 0.13.*,+    mwc-random-monad == 0.7.*,+    focus > 0.1.0 && < 0.2,+    -- data:+    stm-containers,+    unordered-containers == 0.2.*,+    -- debugging:+    loch-th == 0.2.*,+    placeholders == 0.1.*,+    -- general:+    free >= 4.5 && < 4.10,+    async == 2.0.*,+    hashable < 1.3,+    base >= 4.5 && < 5+++executable stm-containers-profiling+  hs-source-dirs:+    executables+  main-is:+    Profiling.hs+  ghc-options:+    -O2+    -threaded+    -fprof-auto+    "-with-rtsopts=-N -p -s -h -i0.1"+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  build-depends:+    -- data:+    stm-containers,+    -- debugging:+    loch-th == 0.2.*,+    placeholders == 0.1.*,+    -- general:+    async == 2.0.*,+    hashable < 1.3,+    base >= 4.5 && < 5