data-vector-growable 0 → 0.0.1

raw patch · 5 files changed

+167/−52 lines, 5 filesdep +asyncdep +atomic-primopsdep +data-vector-growabledep ~basedep ~vectorsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: async, atomic-primops, data-vector-growable

Dependency ranges changed: base, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−5
• Data/Vector/Growable.hs +103/−19
• Setup.hs +2/−2
• data-vector-growable.cabal +37/−26
• tests/push.hs +20/−0

@@ -1,5 +1,5 @@-# Revision history for generic-grow-vector
-
-## 0.1.0.0 -- YYYY-mm-dd
-
-* First version. Released on an unsuspecting world.
+# Revision history for generic-grow-vector++## 0.0.1++* Added `atomicPush` and `atomicPop`

@@ -1,12 +1,16 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Data.Vector.Growable   ( Growable   -- * Type synonyms   , GrowableVector   , GrowableUnboxedVector   , GrowableStorableVector+  , GrowablePrimitiveVector   , GrowableIOVector   , GrowableUnboxedIOVector   , GrowableStorableIOVector+  , GrowablePrimitiveIOVector   -- * Operations   , new   , withCapacity@@ -24,12 +28,17 @@   , unsafeFreeze   , fromGrowable   , toGrowable+  -- * Atomic operation+  , CASVector(..)+  , atomicPush+  , atomicPop   ) where  import Prelude hiding (read, length, replicate, null) import Control.Exception import Control.Monad.Catch import Control.Monad.Primitive+import Data.Atomics import Data.Bits import Data.Primitive.MutVar import qualified Data.Vector.Generic as G@@ -37,25 +46,32 @@ import Data.Vector.Generic.Mutable (MVector) import qualified Data.Vector.Mutable as V import qualified Data.Vector.Unboxed.Mutable as U+import qualified Data.Vector.Primitive.Mutable as P import qualified Data.Vector.Storable.Mutable as S+import Unsafe.Coerce -data GVState v s a = GVState !Int !(v s a)+data Pending a = Pending !Int (Ticket a) !a | Complete +data GVState v s a = GVState !Int !(v s a) (MutVar s (Pending a))+ -- | 'Growable' is a dynamic vector based on mutable vector @v@. newtype Growable v s a = Growable (MutVar s (GVState v s a))  type GrowableVector = Growable V.MVector type GrowableUnboxedVector = Growable U.MVector type GrowableStorableVector = Growable S.MVector+type GrowablePrimitiveVector = Growable S.MVector type GrowableIOVector = Growable V.MVector RealWorld type GrowableUnboxedIOVector = Growable U.MVector RealWorld type GrowableStorableIOVector = Growable S.MVector RealWorld+type GrowablePrimitiveIOVector = Growable P.MVector RealWorld  -- | Create an empty vector with the given number of pre-allocated elements. withCapacity :: (PrimMonad m, MVector v a) => Int -> m (Growable v (PrimState m) a)  withCapacity cap = do   vec <- MV.new cap-  Growable <$> newMutVar (GVState 0 vec)+  ref <- newMutVar Complete+  Growable <$> newMutVar (GVState 0 vec ref) {-# INlINE withCapacity #-}  -- | Create an empty vector@@ -67,56 +83,58 @@ replicate :: (PrimMonad m, MVector v a) => Int -> a -> m (Growable v (PrimState m) a) replicate len a = do   vec <- MV.replicate len a-  Growable <$> newMutVar (GVState len vec)+  ref <- newMutVar Complete+  Growable <$> newMutVar (GVState len vec ref) {-# INLINE replicate #-}  -- | Like 'replicate', but initialises the elements by running the action repeatedly replicateM :: (PrimMonad m, MVector v a) => Int -> m a -> m (Growable v (PrimState m) a) replicateM len a = do   vec <- MV.replicateM len a-  Growable <$> newMutVar (GVState len vec)+  ref <- newMutVar Complete+  Growable <$> newMutVar (GVState len vec ref) {-# INLINE replicateM #-}  -- | Append an element to the vector (not atomic). push :: (PrimMonad m, MVector v a) => Growable v (PrimState m) a -> a -> m () push (Growable ref) val = do-  GVState len vec <- readMutVar ref+  GVState len vec pending <- readMutVar ref   vec' <- if MV.length vec == len     then MV.unsafeGrow vec (max 1 len)     else pure vec-  writeMutVar ref $ GVState (len + 1) vec'+  writeMutVar ref $ GVState (len + 1) vec' pending   MV.write vec' len val {-# INLINE push #-}  -- | Pop the last element. Returns 'Nothing' if the vector is empty. pop :: (PrimMonad m, MVector v a) => Growable v (PrimState m) a -> m (Maybe a) pop (Growable ref) = do-  GVState len vec <- readMutVar ref+  GVState len vec pending <- readMutVar ref   if len == 0     then pure Nothing     else do-      writeMutVar ref $ GVState (len - 1) vec+      writeMutVar ref $ GVState (len - 1) vec pending       Just <$> MV.unsafeRead vec (len - 1) {-# INLINE pop #-}  -- | Get the length of the vector. length :: (PrimMonad m) => Growable v (PrimState m) a -> m Int length (Growable ref) = do-  GVState len _ <- readMutVar ref+  GVState len _ _ <- readMutVar ref   pure len {-# INLINE length #-}  -- | Returns 'True' if the vector is empty null :: (PrimMonad m) => Growable v (PrimState m) a -> m Bool null (Growable ref) = do-  GVState len _ <- readMutVar ref+  GVState len _ _ <- readMutVar ref   pure $ len == 0 {-# INLINE null #-}  -- | May throw 'IndexOutOfBounds' read :: (PrimMonad m, MVector v a, MonadThrow m) => Growable v (PrimState m) a -> Int -> m a read (Growable ref) i = do-  GVState len vec <- readMutVar ref+  GVState len vec _ <- readMutVar ref   if i < len     then MV.unsafeRead vec i     else throwM $ IndexOutOfBounds $ show len <> " <= " <> show i@@ -125,20 +143,20 @@ -- | Throws 'IndexOutOfBounds' if the index is larger than the size. write :: (PrimMonad m, MVector v a, MonadThrow m) => Growable v (PrimState m) a -> Int -> a -> m () write (Growable ref) i val = do-  GVState len vec <- readMutVar ref+  GVState len vec pending <- readMutVar ref   case len `compare` i of     LT -> throwM $ IndexOutOfBounds $ show len <> " < " <> show i     EQ -> do       let amount = 1 `shiftL` (finiteBitSize i - countLeadingZeros i) - MV.length vec       vec' <- MV.unsafeGrow vec amount       MV.unsafeWrite vec' i val-      writeMutVar ref $ GVState (i + 1) vec'+      writeMutVar ref $ GVState (i + 1) vec' pending     GT -> MV.unsafeWrite vec i val {-# INLINE write #-}  modify :: (PrimMonad m, MVector v a, MonadThrow m) => Growable v (PrimState m) a -> (a -> a) -> Int -> m () modify (Growable ref) f i = do-  GVState len vec <- readMutVar ref+  GVState len vec _ <- readMutVar ref   if len <= i     then throwM $ IndexOutOfBounds $ show len <> " <= " <> show i     else MV.unsafeModify vec f i@@ -148,13 +166,14 @@ thaw :: (G.Vector v a, PrimMonad m) => v a -> m (Growable (G.Mutable v) (PrimState m) a) thaw v = do   vec <- G.thaw v-  Growable <$> newMutVar (GVState (G.length v) vec)+  pending <- newMutVar Complete+  Growable <$> newMutVar (GVState (G.length v) vec pending) {-# INLINE thaw #-}  -- | Take a snapshot of a 'Growable' vector. freeze :: (G.Vector v a, PrimMonad m) => Growable (G.Mutable v) (PrimState m) a -> m (v a) freeze (Growable ref) = do-  GVState len vec <- readMutVar ref+  GVState len vec _ <- readMutVar ref   v <- G.freeze vec   pure $! G.unsafeTake len v {-# INLINE freeze #-}@@ -162,7 +181,7 @@ -- | Take a snapshot of a 'Growable' vector. The original vector may not be used. unsafeFreeze :: (G.Vector v a, PrimMonad m) => Growable (G.Mutable v) (PrimState m) a -> m (v a) unsafeFreeze (Growable ref) = do-  GVState len vec <- readMutVar ref+  GVState len vec _ <- readMutVar ref   v <- G.unsafeFreeze vec   pure $! G.unsafeTake len v {-# INLINE unsafeFreeze #-}@@ -170,11 +189,76 @@ -- | Turn 'Growable' vector into a regular mutable vector. fromGrowable :: (PrimMonad m, MVector v a) => Growable v (PrimState m) a -> m (v (PrimState m) a) fromGrowable (Growable ref) = do-  GVState len vec <- readMutVar ref+  GVState len vec _ <- readMutVar ref   pure $! MV.unsafeTake len vec {-# INLINE fromGrowable #-}  -- | Create a 'Growable' vector from a mutable vector. toGrowable ::  (PrimMonad m, MVector v a) => v (PrimState m) a -> m (Growable v (PrimState m) a)-toGrowable vec = Growable <$> newMutVar (GVState (MV.length vec) vec)+toGrowable vec = do+    pending <- newMutVar Complete+    Growable <$> newMutVar (GVState (MV.length vec) vec pending) {-# INLINE toGrowable #-}++class MVector v a => CASVector v a where+  readVectorElem :: v RealWorld a -> Int -> IO (Ticket a)+  casVectorElem :: v RealWorld a -> Int -> Ticket a -> a -> IO (Bool, Ticket a)++instance CASVector V.MVector a where+  readVectorElem (V.MVector _ _ arr) i = readArrayElem arr i+  casVectorElem (V.MVector _ _ arr) i x y = casArrayElem arr i x y++instance CASVector P.MVector Int where+  readVectorElem vec i = forgeIntTicket <$> P.unsafeRead vec i+  casVectorElem (P.MVector _ _ arr) i x y = do+    let old = peekTicket x+    old' <- casByteArrayInt arr i old y+    pure (old == old', forgeIntTicket y)++forgeIntTicket :: Int -> Ticket Int+forgeIntTicket = unsafeCoerce++complete :: CASVector v a => v RealWorld a -> MutVar RealWorld (Pending a) -> IO ()+complete vec v = readMutVar v >>= \case+  Complete -> pure ()+  Pending i oldVal newVal -> do+    (_done, _) <- casVectorElem vec i oldVal newVal+    writeMutVar v Complete++-- | Atomically push a value to the end of the vector.+-- | Based on <https://www.stroustrup.com/lock-free-vector.pdf Damian Dechev, Peter Pirkelbauer, and Bjarne Stroustrup - Lock-free Dynamically Resizable Arrays>+atomicPush :: CASVector v a => Growable v RealWorld a -> a -> IO ()+atomicPush (Growable (MutVar mut)) val = go+  where+    go = do+      old <- readMutVarForCAS mut+      let GVState len vec pending = peekTicket old+      complete vec pending+      vec' <- if MV.length vec == len+        then MV.unsafeGrow vec (max 1 len)+        else pure vec+      oldVal <- readVectorElem vec' len+      pending' <- newMutVar $ Pending len oldVal val+      (success, _) <- casMutVar mut old $ GVState (len + 1) vec' pending'+      if success+        then complete vec' pending'+        else go++-- | Pop the last element. Returns 'Nothing' if the vector is empty.+atomicPop :: CASVector v a => Growable v RealWorld a -> IO (Maybe a)+atomicPop (Growable (MutVar mut)) = go+  where+    go = do+      old <- readMutVarForCAS mut+      let GVState len vec pending = peekTicket old+      complete vec pending+      if len == 0+        then pure Nothing+        else do+          result <- MV.unsafeRead vec (len - 1)+          pending' <- newMutVar Complete+          (success, _) <- casMutVar mut old $ GVState (len - 1) vec pending'+          if success+            then pure $ Just result+            else go+{-# INLINE atomicPop #-}

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

@@ -1,27 +1,38 @@-cabal-version:       2.2
-name:                data-vector-growable
-version:             0
-synopsis:            Dynamic growable resizable mutable generic vector
-description:         Dynamic, growable, resizable, mutable and generic vector implementation
-bug-reports:         https://github.com/fumieval/data-vector-growable
-license:             BSD-3-Clause
-license-file:        LICENSE
-author:              Fumiaki Kinoshita
-maintainer:          fumiexcel@gmail.com
-copyright:           Copyright (c) 2020 Fumiaki Kinoshita
-category:            Data, Data Structures
-build-type:          Simple
-extra-source-files:  CHANGELOG.md
-
-library
-  exposed-modules:     Data.Vector.Growable
-  build-depends:       base >= 4.10 && <5
-    , vector ^>= 0.12
-    , primitive ^>= 0.7
-    , exceptions ^>= 0.10
-  default-language:    Haskell2010
-  ghc-options: -Wall -Wcompat
-
-source-repository head
-  type: git
+cabal-version:       2.2+name:                data-vector-growable+version:             0.0.1+synopsis:            Dynamic growable resizable mutable generic vector+description:         Dynamic, growable, resizable, mutable and generic vector implementation+bug-reports:         https://github.com/fumieval/data-vector-growable+license:             BSD-3-Clause+license-file:        LICENSE+author:              Fumiaki Kinoshita+maintainer:          fumiexcel@gmail.com+copyright:           Copyright (c) 2020 Fumiaki Kinoshita+category:            Data, Data Structures+build-type:          Simple+extra-source-files:  CHANGELOG.md++library+  exposed-modules:     Data.Vector.Growable+  build-depends:       base >= 4.10 && <5+    , vector ^>= 0.12+    , primitive ^>= 0.7+    , exceptions ^>= 0.10+    , atomic-primops ^>= 0.8+  default-language:    Haskell2010+  ghc-options: -Wall -Wcompat+  default-extensions:+    LambdaCase++source-repository head+  type: git   location: https://github.com/fumieval/data-vector-growable++test-suite spec+  type: exitcode-stdio-1.0+  main-is: push.hs+  ghc-options: -Wall -Wcompat -O2 -threaded -with-rtsopts=-N2+  hs-source-dirs: tests+  build-depends: base, vector, data-vector-growable, async+  default-language: Haskell2010

@@ -0,0 +1,20 @@+{-# LANGUAGE LambdaCase #-}+import Data.Vector.Growable+import Control.Concurrent.Async (mapConcurrently_)+import Control.Concurrent (yield, threadDelay)+import Control.Monad (unless)++main :: IO ()+main = do+  vec <- new :: IO (GrowableIOVector Int)+  let step i = atomicPush vec i+  let popper count = atomicPop vec >>= \case+        Nothing -> yield >> popper count+        Just (-1) -> do+            putStrLn $ "Count: " <> show count+            unless (count == 5608) $ fail "this is not expected"+        Just _ -> popper $! count + 1+  mapConcurrently_ id+    $ popper (0 :: Int)+    : [ mapM_ step [0..i * 200] | i <- [0..7] ]+    ++ [ threadDelay 1000000 >> atomicPush vec (-1)]