packages feed

stm-containers 0.1.2 → 0.1.3

raw patch · 14 files changed

+350/−89 lines, 14 filesdep +base-preludedep ~base

Dependencies added: base-prelude

Dependency ranges changed: base

Files

executables/APITests.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -F -pgmF htfpp #-}  import Test.Framework-import STMContainers.Prelude+import BasePrelude  import {-@ HTF_TESTS @-} APITests.MapTests
executables/ConcurrentInsertionBench.hs view
@@ -128,4 +128,4 @@           ]   where     actionsNum = 100000-    threadsNums = [1, 2, 4, 6, 8, 12, 16, 32]+    threadsNums = [1, 2, 4, 6, 8, 12, 16, 32, 40, 52, 64, 80, 128]
executables/ConcurrentTransactionsBench.hs view
@@ -192,7 +192,7 @@   -- Pregenerate the transactions:   transactionsGroups <-      MWC.runWithCreate $ replicateM (maximum threadsNums) $-    transactionsGroupGenerator (actionsNum `div` (maximum threadsNums))+    transactionsGroupGenerator (transactionsNum `div` (maximum threadsNums))    -- Run the benchmark:   defaultMain $! flip map threadsNums $ \threadsNum -> @@ -201,8 +201,8 @@         map concat $!          slices (length transactionsGroups `div` threadsNum) transactionsGroups       in-        bench (shows threadsNum . showString "/" . shows (actionsNum `div` threadsNum) $ "") $+        bench (shows threadsNum . showString "/" . shows (transactionsNum `div` threadsNum) $ "") $           scSessionRunner specializedSCInterpreter session   where-    threadsNums = [1, 2, 4, 6, 8, 12, 16, 32, 64, 128]-    actionsNum = 200000+    threadsNums = [1, 2, 4, 6, 8, 12, 16, 32, 40, 52, 64, 80, 128]+    transactionsNum = 400000
executables/WordArrayTests.hs view
@@ -34,3 +34,7 @@   where     w = WordArray.fromList [(3, 'a'), (7, 'b'), (14, 'c')] +test_foldable = do+  assertEqual "abdc" $ toList w+  where+    w = WordArray.fromList [(3, 'a'), (7, 'b'), (8, 'd'), (14, 'c')]
+ library/STMContainers/Bimap.hs view
@@ -0,0 +1,133 @@+module STMContainers.Bimap+(+  Bimap,+  Association,+  new,+  insert1,+  insert2,+  delete1,+  delete2,+  lookup1,+  lookup2,+  focus1,+  focus2,+  foldM,+  null,+)+where++import STMContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)+import qualified Focus+import qualified STMContainers.Map as Map+++-- |+-- A bidirectional map.+-- Essentially a bijection between subsets of its two argument types.+-- +-- For one value of a left-hand type there this map contains one value +-- of the right-hand type and vice versa.+data Bimap a b = +  Bimap {m1 :: !(Map.Map a b), m2 :: !(Map.Map b a)}++-- |+-- A standard constraint for associations.+type Association a b = (Map.Key a, Map.Key b)++-- |+-- Construct a new bimap.+{-# INLINABLE new #-}+new :: STM (Bimap a b)+new = Bimap <$> Map.new <*> Map.new++-- |+-- Check on being empty.+{-# INLINABLE null #-}+null :: Bimap a b -> STM Bool+null = Map.null . m1++-- |+-- Look up a right value by a left value.+{-# INLINABLE lookup1 #-}+lookup1 :: (Association a b) => a -> Bimap a b -> STM (Maybe b)+lookup1 k = Map.lookup k . m1++-- |+-- Look up a left value by a right value.+{-# INLINABLE lookup2 #-}+lookup2 :: (Association a b) => b -> Bimap a b -> STM (Maybe a)+lookup2 k = Map.lookup k . m2++-- |+-- Insert an association by a left value.+{-# INLINABLE insert1 #-}+insert1 :: (Association a b) => b -> a -> Bimap a b -> STM ()+insert1 b a (Bimap m1 m2) = +  do+    Map.insert b a m1+    Map.insert a b m2++-- |+-- Insert an association by a right value.+{-# INLINABLE insert2 #-}+insert2 :: (Association a b) => a -> b -> Bimap a b -> STM ()+insert2 b a (Bimap m1 m2) = (inline insert1) b a (Bimap m2 m1)++-- |+-- Delete an association by a left value.+{-# INLINABLE delete1 #-}+delete1 :: (Association a b) => a -> Bimap a b -> STM ()+delete1 k (Bimap m1 m2) =+  Map.focus lookupAndDeleteStrategy k m1 >>= +    mapM_ (\k' -> Map.delete k' m2)+  where+    lookupAndDeleteStrategy r =+      return (r, Focus.Remove)++-- |+-- Delete an association by a right value.+{-# INLINABLE delete2 #-}+delete2 :: (Association a b) => b -> Bimap a b -> STM ()+delete2 k (Bimap m1 m2) = (inline delete1) k (Bimap m2 m1)++-- |+-- Focus on a right value by a left value with a strategy.+-- +-- This function allows to perform composite operations in a single access+-- to a map item.+-- E.g., you can look up an item and delete it at the same time,+-- or update it and return the new value.+{-# INLINABLE focus1 #-}+focus1 :: (Association a b) => Focus.StrategyM STM b r -> a -> Bimap a b -> STM r+focus1 s a (Bimap m1 m2) =+  do +    (r, d, mb) <- Map.focus s' a m1+    case d of+      Focus.Keep -> +        return ()+      Focus.Remove -> +        forM_ mb $ \b -> Map.delete b m2+      Focus.Replace b' ->+        do+          forM_ mb $ \b -> Map.delete b m2+          Map.insert a b' m2+    return r+  where+    s' = \k -> s k >>= \(r, d) -> return ((r, d, k), d)++-- |+-- Focus on a left value by a right value with a strategy.+-- +-- This function allows to perform composite operations in a single access+-- to a map item.+-- E.g., you can look up an item and delete it at the same time,+-- or update it and return the new value.+{-# INLINABLE focus2 #-}+focus2 :: (Association a b) => Focus.StrategyM STM a r -> b -> Bimap a b -> STM r+focus2 s b (Bimap m1 m2) = (inline focus1) s b (Bimap m2 m1)++-- |+-- Fold all the associations.+{-# INLINABLE foldM #-}+foldM :: (r -> (a, b) -> STM r) -> r -> Bimap a b -> STM r+foldM s r = Map.foldM s r . m1
library/STMContainers/HAMT/Nodes.hs view
@@ -1,6 +1,7 @@ module STMContainers.HAMT.Nodes where  import STMContainers.Prelude hiding (insert, lookup, delete, foldM, null)+import qualified STMContainers.Prelude as Prelude import qualified STMContainers.WordArray as WordArray import qualified STMContainers.SizedArray as SizedArray import qualified STMContainers.HAMT.Level as Level@@ -134,16 +135,13 @@                     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+  readTVar >=> foldlM step' acc   where     step' acc' = \case       Nodes ns -> foldM step acc' (Level.succ level) ns
library/STMContainers/Map.hs view
@@ -45,7 +45,7 @@ lookup k = focus Focus.lookupM k  -- |--- Insert a key and a value.+-- Insert a value at a key. {-# INLINE insert #-} insert :: (Key k) => v -> k -> Map k v -> STM () insert !v !k (Map h) = HAMT.insert (k, v) h@@ -61,7 +61,7 @@ --  -- 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,+-- E.g., you can look up 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
+ library/STMContainers/Multimap.hs view
@@ -0,0 +1,131 @@+module STMContainers.Multimap+(+  Multimap,+  Association,+  new,+  insert,+  delete,+  lookup,+  focus,+  foldM,+  null,+)+where++import STMContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)+import qualified Focus+import qualified STMContainers.Map as Map+import qualified STMContainers.Set as Set+++-- |+-- A multimap, based on an STM-specialized hash array mapped trie.+-- +-- Basically it's just a wrapper API around @'Map.Map' k ('Set.Set' v)@.+newtype Multimap k v = Multimap (Map.Map k (Set.Set v))++-- |+-- A standard constraint for items.+type Association k v = (Eq k, Hashable k, Eq v, Hashable v)++-- |+-- Look up an item by a value and a key.+{-# INLINE lookup #-}+lookup :: (Association k v) => v -> k -> Multimap k v -> STM Bool+lookup v k (Multimap m) = +  maybe (return False) (Set.lookup v) =<< Map.lookup k m++-- |+-- Insert an item.+{-# INLINABLE insert #-}+insert :: (Association k v) => v -> k -> Multimap k v -> STM ()+insert v k (Multimap m) =+  Map.focus ms k m+  where+    ms = +      \case +        Just s -> +          do+            Set.insert v s+            return ((), Focus.Keep)+        Nothing ->+          do+            s <- Set.new+            Set.insert v s+            return ((), Focus.Replace s)++-- |+-- Delete an item by a value and a key.+{-# INLINABLE delete #-}+delete :: (Association k v) => v -> k -> Multimap k v -> STM ()+delete v k (Multimap m) =+  Map.focus ms k m+  where+    ms = +      \case +        Just s -> +          do+            Set.delete v s+            Set.null s >>= returnDecision . bool Focus.Keep Focus.Remove+        Nothing ->+          returnDecision Focus.Keep+      where+        returnDecision c = return ((), c)++-- |+-- Focus on an item with a strategy by a value and a key.+-- +-- This function allows to perform simultaneous lookup and modification.+-- +-- The strategy is over a unit since we already know,+-- which value we're focusing on and it doesn't make sense to replace it,+-- however we still can still decide wether to keep or remove it.+{-# INLINE focus #-}+focus :: (Association k v) => Focus.StrategyM STM () r -> v -> k -> Multimap k v -> STM r+focus = +  \s v k (Multimap m) -> Map.focus (liftSetItemStrategy v s) k m+  where+    liftSetItemStrategy :: +      (Set.Element e) => e -> Focus.StrategyM STM () r -> Focus.StrategyM STM (Set.Set e) r+    liftSetItemStrategy e s =+      \case+        Nothing ->+          traversePair liftDecision =<< s Nothing+          where+            liftDecision =+              \case+                Focus.Replace b ->+                  do+                    s <- Set.new+                    Set.insert e s+                    return (Focus.Replace s)+                _ ->+                  return Focus.Keep+        Just set -> +          do+            r <- Set.focus s e set+            (r,) . bool Focus.Keep Focus.Remove <$> Set.null set++-- |+-- Fold all the items.+{-# INLINE foldM #-}+foldM :: (a -> (k, v) -> STM a) -> a -> Multimap k v -> STM a+foldM f a (Multimap m) = +  Map.foldM f' a m+  where+    f' a' (k, set) = +      Set.foldM f'' a' set+      where+        f'' a'' v = f a'' (k, v)++-- |+-- Construct a new multimap.+{-# INLINE new #-}+new :: STM (Multimap k v)+new = Multimap <$> Map.new++-- |+-- Check on being empty.+{-# INLINE null #-}+null :: Multimap k v -> STM Bool+null (Multimap m) = Map.null m
library/STMContainers/Prelude.hs view
@@ -3,53 +3,13 @@   module Exports,   bug,   bottom,-  bool,+  traversePair, ) 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)+import BasePrelude as Exports  -- placeholders -------------------------@@ -69,6 +29,6 @@  bottom = [e| $bug "Bottom evaluated" |] -bool :: a -> a -> Bool -> a-bool f _ False = f-bool _ t True  = t+-- | A replacement for the missing 'Traverse' instance of pair in base < 4.7.+traversePair :: Functor f => (a -> f b) -> (c, a) -> f (c, b)+traversePair f (x, y) = (,) x <$> f y
library/STMContainers/Set.hs view
@@ -6,6 +6,7 @@   insert,   delete,   lookup,+  focus,   foldM,   null, )@@ -31,42 +32,57 @@   type ElementKey (HAMTElement e) = e   elementKey (HAMTElement e) = e -{-# INLINABLE elementValue #-}+{-# INLINE elementValue #-} elementValue :: HAMTElement e -> e elementValue (HAMTElement e) = e  -- | -- Insert a new element.-{-# INLINABLE insert #-}+{-# INLINE insert #-} insert :: (Element e) => e -> Set e -> STM () insert e = HAMT.insert (HAMTElement e) . hamt  -- | -- Delete an element.-{-# INLINABLE delete #-}+{-# INLINE delete #-} delete :: (Element e) => e -> Set e -> STM () delete e = HAMT.focus Focus.deleteM e . hamt  -- | -- Lookup an element.-{-# INLINABLE lookup #-}+{-# INLINE lookup #-} lookup :: (Element e) => e -> Set e -> STM Bool lookup e = fmap (maybe False (const True)) . HAMT.focus Focus.lookupM e . hamt  -- |+-- Focus on an element with a strategy.+-- +-- This function allows to perform simultaneous lookup and modification.+-- +-- The strategy is over a unit since we already know, +-- which element we're focusing on and it doesn't make sense to replace it,+-- however we still can still decide wether to keep or remove it.+{-# INLINE focus #-}+focus :: (Element e) => Focus.StrategyM STM () r -> e -> Set e -> STM r+focus s e = HAMT.focus elementStrategy e . hamt+  where+    elementStrategy = +      (fmap . fmap . fmap) (const (HAMTElement e)) . s . fmap (const ())++-- | -- Fold all the elements.-{-# INLINABLE foldM #-}+{-# INLINE 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 #-}+{-# INLINE new #-} new :: STM (Set e) new = Set <$> HAMT.new  -- | -- Check, whether the set is empty.-{-# INLINABLE null #-}+{-# INLINE null #-} null :: Set e -> STM Bool null = HAMT.null . hamt
library/STMContainers/SizedArray.hs view
@@ -11,6 +11,11 @@ data SizedArray a =   SizedArray {-# UNPACK #-} !Int {-# UNPACK #-} !(Array a) +instance Foldable SizedArray where+  {-# INLINE foldr #-}+  foldr step r (SizedArray size array) =+    foldr step r $ map (indexArray array) [0 .. pred size]+ -- | -- An index of an element. type Index = Int
library/STMContainers/WordArray.hs view
@@ -13,6 +13,11 @@ data WordArray e =   WordArray {-# UNPACK #-} !Indices {-# UNPACK #-} !(Array e) +instance Foldable WordArray where+  {-# INLINE foldr #-}+  foldr step r (WordArray indices array) =+    foldr (step . indexArray array) r $ Indices.positions indices+ -- |  -- A bitmap of set elements. type Indices = Indices.Indices@@ -178,16 +183,6 @@ {-# 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))
library/STMContainers/WordArray/Indices.hs view
@@ -10,10 +10,12 @@  type Index = Int +type Position = Int+ -- | -- A number of indexes, preceding this one. {-# INLINE position #-}-position :: Index -> Indices -> Int+position :: Index -> Indices -> Position position i b = popCount (b .&. (bit i - 1))  {-# INLINE singleton #-}@@ -46,16 +48,21 @@  {-# INLINE fromList #-} fromList :: [Index] -> Indices-fromList = foldr (.|.) 0 . map bit+fromList = Prelude.foldr (.|.) 0 . map bit  {-# INLINE toList #-} toList :: Indices -> [Index] toList w = filter (testBit w) allIndices +{-# INLINE positions #-}+positions :: Indices -> [Position]+positions = enumFromTo 0 . pred . size+ {-# 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+{-# INLINE foldr #-}+foldr :: (Index -> r -> r) -> r -> Indices -> r+foldr s r ix = +  Prelude.foldr (\i r' -> if testBit ix i then s i r' else r') r allIndices
stm-containers.cabal view
@@ -1,7 +1,7 @@ name:   stm-containers version:-  0.1.2+  0.1.3 synopsis:   Containers for STM description:@@ -51,15 +51,21 @@     STMContainers.HAMT.Nodes     STMContainers.HAMT   exposed-modules:+    STMContainers.Bimap+    STMContainers.Multimap     STMContainers.Map     STMContainers.Set   build-depends:+    -- data:+    hashable < 1.3,+    -- control:+    focus > 0.1.0 && < 0.2,+    -- preludes:+    base-prelude == 0.1.*,     -- 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:@@ -77,16 +83,21 @@   main-is:     WordArrayTests.hs   build-depends:+    -- testing:+    free >= 4.6 && < 4.10,+    mtl == 2.*,     QuickCheck == 2.7.*,     HTF == 0.11.*,+    -- data:+    hashable < 1.3,+    -- control:+    focus > 0.1.0 && < 0.2,+    -- preludes:+    base-prelude == 0.1.*,     -- 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:@@ -110,6 +121,7 @@     loch-th == 0.2.*,     placeholders == 0.1.*,     -- general:+    base-prelude == 0.1.*,     focus > 0.1.0 && < 0.2,     unordered-containers == 0.2.*,     free >= 4.6 && < 4.10,@@ -151,7 +163,7 @@     loch-th == 0.2.*,     placeholders == 0.1.*,     -- general:-    base >= 4.5 && < 5+    base >= 4.5 && < 4.8   benchmark concurrent-insertion-bench@@ -183,7 +195,7 @@     -- general:     free >= 4.5 && < 4.10,     async == 2.0.*,-    base >= 4.5 && < 5+    base >= 4.5 && < 4.8   benchmark concurrent-transactions-bench@@ -217,4 +229,4 @@     mtl == 2.*,     free >= 4.5 && < 4.10,     async == 2.0.*,-    base >= 4.5 && < 5+    base >= 4.5 && < 4.8