pvar 0.1.1.0 → 0.2.0.0

raw patch · 6 files changed

+195/−65 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README.md +4/−4
• pvar.cabal +4/−3
• src/Data/Primitive/PVar.hs +101/−34
• src/Data/Primitive/PVar/Internal.hs +9/−2
• tests/Test/Primitive/PVarSpec.hs +69/−22

@@ -1,5 +1,13 @@ # Changelog for pvar +## 0.2.0.0++* Rename `modifyPVar` to `fetchModifyPVar` and `modifyPVarM` to `fetchModifyPVarM`. This+  is a breaking change in favor of consistency with other librarries.+* New implementation for `modifyPVar` and `modifyPVarM` that can return some artifact.+* Addition of `modifyFetchPVar` and `modifyFetchPVarM`+* Addition of `atomicModifyFetchIntPVar` and `atomicFetchModifyIntPVar`+ ## 0.1.1.0  * Addition of backwards compatible:

@@ -1,6 +1,6 @@ # pvar -Interface for a mutable veriable `PVar` that can hold values that have `Prim` instance.+Interface for a mutable variable `PVar` that can hold values that have `Prim` instance.  ## Status @@ -16,17 +16,17 @@  Main features include: -* Perfomance. There is practically no overhead when compared to operating on pure values,+* Performance. There is practically no overhead when compared to operating on pure values,   although there is a higher memory overhead, since `PVar` is backed by a   `MutableByteArray#` * Atomic operations for `PVar`s with `Int` values. This includes a unique function that is-  not availiable in `ghc-prim` out of the box:+  not available in `ghc-prim` out of the box:  ```haskell atomicModifyIntPVar :: PrimMonad m => PVar m Int -> (Int -> (Int, a)) -> m a ``` -* Works in `PrimMonad`, therfore usable with `ST`, `IO` and various transformer monads.+* Works in `PrimMonad`, therefore it is usable with `ST`, `IO` and various transformer monads. * Easy access to `PVar` contents with `Storable` * `isByteArrayPinned`, `isMutableByteArrayPinned` function that work on ghc-7.10 and   ghc-8.0 as well as all the newer ones.

@@ -1,14 +1,15 @@ cabal-version: 1.12  name:           pvar-version:        0.1.1.0+version:        0.2.0.0 synopsis:       Mutable variable with primitive values-description:    Please see the README on GitHub at <https://github.com/lehins/pvar#readme>+description:    Mutable variable `PVar` that is backed by a single value `MutableByteArray` homepage:       https://github.com/lehins/pvar#readme bug-reports:    https://github.com/lehins/pvar/issues author:         Alexey Kuleshevich maintainer:     alexey@kuleshevi.ch-copyright:      Alexey Kuleshevich+copyright:      2020 Alexey Kuleshevich+category:       Data license:        BSD3 license-file:   LICENSE build-type:     Simple

@@ -14,24 +14,28 @@ -- Portability : non-portable -- module Data.Primitive.PVar-  ( -- | `PVar` has significantly better performance characterisitcs over-    -- `Data.IORef.IORef`, `Data.STRef.STRef` and `Data.Primtive.MutVar.MutVar`. This is+  ( -- | `PVar` has significantly better performance characteristics over+    -- `Data.IORef.IORef`, `Data.STRef.STRef` and `Data.Primitive.MutVar.MutVar`. This is     -- because value is mutated directly in memory instead of following an extra     -- pointer. Besides better performance there is another consequence of direct-    -- mutation, namely that values are always evaluated to normal form when being written+    -- mutation, namely the value is always evaluated to normal form when being written     -- into a `PVar` -  -- * Primitive variable     PVar+  -- * Creation   , newPVar   , withPVarST-  -- * Generic Operations+  -- * Mutable Operations   , readPVar   , writePVar-  , modifyPVar_   , modifyPVar-  , modifyPVarM_+  , modifyPVar_+  , fetchModifyPVar+  , modifyFetchPVar   , modifyPVarM+  , modifyPVarM_+  , fetchModifyPVarM+  , modifyFetchPVarM   , swapPVars_   , swapPVars   , copyPVar@@ -55,9 +59,11 @@   -- , (=*)   -- , (=/)   -- , (=%)-  -- ** Atomic operations+  -- * Atomic operations   , atomicModifyIntPVar   , atomicModifyIntPVar_+  , atomicFetchModifyIntPVar+  , atomicModifyFetchIntPVar   , atomicReadIntPVar   , atomicWriteIntPVar   , casIntPVar@@ -68,7 +74,7 @@   , atomicOrIntPVar   , atomicXorIntPVar   , atomicNotIntPVar-  -- ** Re-exports+  -- * Re-exports   , Prim   , PrimMonad(PrimState)   , RealWorld@@ -85,7 +91,6 @@ import Control.Monad.ST (ST, runST) import Data.Primitive.PVar.Internal import Data.Primitive.PVar.Unsafe-import Data.Primitive (sizeOf, alignment) import Data.Primitive.Types import qualified Foreign.Storable as S import GHC.Exts@@ -93,7 +98,7 @@  -- $pinned -- In theory it is unsafe to mix `S.Storable` and `Prim` operations on the same chunk of--- memory, because some instances can have differnet memory layouts for the same+-- memory, because some instances can have different memory layouts for the same -- type. This is highly uncommon in practice and if you are intermixing the two concepts -- together you probably already know what you are doing. @@ -153,10 +158,11 @@   primitive_ (copyMutableByteArrayToAddr# mbas# 0# addr# (sizeOfPVar# pvar)) {-# INLINE copyPVarToPtr #-} --- | Apply a pure function to the contents of a mutable variable. Returns the old value.+-- | Apply a pure function to the contents of a mutable variable. Returns the artifact of+-- computation. ----- @since 0.1.0-modifyPVar :: (PrimMonad m, Prim a) => PVar m a -> (a -> a) -> m a+-- @since 0.2.0+modifyPVar :: (PrimMonad m, Prim a) => PVar m a -> (a -> (a, b)) -> m b modifyPVar pvar f = modifyPVarM pvar (return . f) {-# INLINE modifyPVar #-} @@ -167,17 +173,54 @@ modifyPVar_ pvar f = modifyPVarM_ pvar (return . f) {-# INLINE modifyPVar_ #-} --- | Apply a monadic action to the contents of a mutable variable. Returns the old value.++-- | Apply a pure function to the contents of a mutable variable. Returns the old value. ----- @since 0.1.0-modifyPVarM :: (PrimMonad m, Prim a) => PVar m a -> (a -> m a) -> m a+-- @since 0.2.0+fetchModifyPVar :: (PrimMonad m, Prim a) => PVar m a -> (a -> a) -> m a+fetchModifyPVar pvar f = fetchModifyPVarM pvar (return . f)+{-# INLINE fetchModifyPVar #-}++-- | Apply a pure function to the contents of a mutable variable. Returns the new value.+--+-- @since 0.2.0+modifyFetchPVar :: (PrimMonad m, Prim a) => PVar m a -> (a -> a) -> m a+modifyFetchPVar pvar f = modifyFetchPVarM pvar (return . f)+{-# INLINE modifyFetchPVar #-}+++-- | Apply a monadic action to the contents of a mutable variable. Returns the artifact of+-- computation.+--+-- @since 0.2.0+modifyPVarM :: (PrimMonad m, Prim a) => PVar m a -> (a -> m (a, b)) -> m b modifyPVarM pvar f = do   a <- readPVar pvar-  a' <- f a-  writePVar pvar a'-  return a+  (a', b) <- f a+  b <$ writePVar pvar a' {-# INLINE modifyPVarM #-} +-- | Apply a monadic action to the contents of a mutable variable. Returns the old value.+--+-- @since 0.2.0+fetchModifyPVarM :: (PrimMonad m, Prim a) => PVar m a -> (a -> m a) -> m a+fetchModifyPVarM pvar f = do+  a <- readPVar pvar+  a <$ (writePVar pvar =<< f a)+{-# INLINE fetchModifyPVarM #-}+++-- | Apply a monadic action to the contents of a mutable variable. Returns the new value.+--+-- @since 0.2.0+modifyFetchPVarM :: (PrimMonad m, Prim a) => PVar m a -> (a -> m a) -> m a+modifyFetchPVarM pvar f = do+  a <- readPVar pvar+  a' <- f a+  a' <$ writePVar pvar a'+{-# INLINE modifyFetchPVarM #-}++ -- | Apply a monadic action to the contents of a mutable variable. -- -- @since 0.1.0@@ -191,9 +234,8 @@ swapPVars :: (PrimMonad m, Prim a) => PVar m a -> PVar m a -> m (a, a) swapPVars pvar1 pvar2 = do   a1 <- readPVar pvar1-  a2 <- modifyPVar pvar2 (const a1)-  writePVar pvar1 a2-  return (a1, a2)+  a2 <- fetchModifyPVar pvar2 (const a1)+  (a1, a2) <$ writePVar pvar1 a2 {-# INLINE swapPVars #-}  -- | Swap contents of two mutable variables.@@ -232,7 +274,7 @@ -- it. Memory allocated with number of bytes specified by @`S.sizeOf` a@ is allocated and -- pinned, therefore it is safe to operate directly with the pointer as well as over -- FFI. Returning the pointer from the supplied action would be very unsafe, therefore--- return the `PVar` if you still need it afterwards, garbage colelctor will cleanup the+-- return the `PVar` if you still need it afterwards, garbage collector will cleanup the -- memory when it is no longer needed. -- -- @since 0.1.0@@ -279,9 +321,34 @@ {-# INLINE atomicWriteIntPVar #-}  --- | Compare and swap. This is a function that is used to implement `modifyIntPVar`. Implies a--- full memory barrier.+-- | Apply a function to an integer element of a `PVar` atomically. Implies a full memory+-- barrier. Returns the new value. --+-- @since 0.2.0+atomicFetchModifyIntPVar ::+     PrimMonad m => PVar m Int -> (Int -> Int) -> m Int+atomicFetchModifyIntPVar pvar f =+  atomicModifyIntPVar pvar $ \a ->+    let a' = f a+     in a' `seq` (a', a)+{-# INLINE atomicFetchModifyIntPVar #-}++-- | Apply a function to an integer element of a `PVar` atomically. Implies a full memory+-- barrier. Returns the new value.+--+-- @since 0.2.0+atomicModifyFetchIntPVar ::+     PrimMonad m => PVar m Int -> (Int -> Int) -> m Int+atomicModifyFetchIntPVar pvar f =+  atomicModifyIntPVar pvar $ \a ->+    let a' = f a+     in a' `seq` (a', a')+{-# INLINE atomicModifyFetchIntPVar #-}+++-- | Compare and swap. This is also a function that is used to implement+-- `atomicModifyIntPVar`. Implies a full memory barrier.+-- -- @since 0.1.0 casIntPVar ::      PrimMonad m@@ -297,7 +364,7 @@   --- | Add two numbers, corresponds to @`+`@ done atomically. Returns the previous value of+-- | Add two numbers, corresponds to @(`+`)@ done atomically. Returns the previous value of -- the mutable variable. Implies a full memory barrier. -- -- @since 0.1.0@@ -308,7 +375,7 @@       (# s'#, p# #) -> (# s'#, I# p# #) {-# INLINE atomicAddIntPVar #-} --- | Subtract two numbers, corresponds to @`subtract`@ done atomically. Returns the+-- | Subtract two numbers, corresponds to @(`-`)@ done atomically. Returns the -- previous value of the mutable variable. Implies a full memory barrier. -- -- @since 0.1.0@@ -320,7 +387,7 @@ {-# INLINE atomicSubIntPVar #-}  --- | Binary conjuction (AND), corresponds to @`and`@ done atomically. Returns the previous+-- | Binary conjuction (AND), corresponds to @(`Data.Bits..&.`)@ done atomically. Returns the previous -- value of the mutable variable. Implies a full memory barrier. -- -- @since 0.1.0@@ -332,8 +399,8 @@ {-# INLINE atomicAndIntPVar #-}  --- | Binary negation of conjuction (Not AND), corresponds to @\\x y -> `complement` (x--- `and` y)@ done atomically. Returns the previous value of the mutable variable. Implies+-- | Binary negation of conjuction (NAND), corresponds to @\\x y -> `Data.Bits.complement` (x+-- `Data.Bits..&.` y)@ done atomically. Returns the previous value of the mutable variable. Implies -- a full memory barrier. -- -- @since 0.1.0@@ -345,7 +412,7 @@ {-# INLINE atomicNandIntPVar #-}  --- | Binary disjunction (OR), corresponds to `or` done atomically. Returns the previous+-- | Binary disjunction (OR), corresponds to @(`Data.Bits..|.`)@ done atomically. Returns the previous -- value of the mutable variable. Implies a full memory barrier. -- -- @since 0.1.0@@ -357,7 +424,7 @@ {-# INLINE atomicOrIntPVar #-}  --- | Binary exclusive disjunction (XOR), corresponds to `xor` done atomically. Returns the+-- | Binary exclusive disjunction (XOR), corresponds to @`Data.Bits.xor`@ done atomically. Returns the -- previous value of the mutable variable. Implies a full memory barrier. -- -- @since 0.1.0@@ -369,7 +436,7 @@ {-# INLINE atomicXorIntPVar #-}  --- | Binary negation (NOT), corresponds to ones' `complement` done atomically. Returns the+-- | Binary negation (NOT), corresponds to ones' @`Data.Bits.complement`@ done atomically. Returns the -- previous value of the mutable variable. Implies a full memory barrier. -- -- @since 0.1.0

@@ -44,17 +44,22 @@   -- * Re-exports   , isByteArrayPinned#   , isMutableByteArrayPinned#+  , sizeOf+  , alignment   )   where  import Control.DeepSeq import Control.Monad.Primitive (PrimMonad(primitive), PrimState, primitive_,                                 touch, unsafePrimToPrim)-import Data.Primitive (sizeOf, alignment) import Data.Primitive.Types import qualified Foreign.Storable as S import GHC.Exts +#if !MIN_VERSION_primitive(0,6,3)+import Data.Primitive (sizeOf, alignment)+#endif+ -- | Mutable variable with primitive value. -- -- @since 0.1.0@@ -269,7 +274,9 @@ alignmentPVar pvar = I# (alignmentPVar# pvar) {-# INLINE alignmentPVar #-} -+-- | Unwrap the primitive `Int`+--+-- @since 0.1.0 unI# :: Int -> Int# unI# (I# i#) = i# {-# INLINE unI# #-}

@@ -131,25 +131,43 @@     propPVarIO "newAlignedPinnedPVar" gen $ \a var -> do       pinnedVar <- newAlignedPinnedPVar a       (===) <$> readPVar var <*> readPVar pinnedVar-    propPVarIO "modifyPVar" gen $ \a pvar ->+    propPVarIO "modifyPVar_" gen $ \a pvar ->       return $       forAll arbitrary $ \f -> do-        modifyPVar pvar (apply f) `shouldReturn` a+        modifyPVar_ pvar (apply f)         readPVar pvar `shouldReturn` apply f a-    propPVarIO "modifyPVar_" gen $ \a pvar ->+    propPVarIO "modifyPVar" gen $ \a pvar ->       return $       forAll arbitrary $ \f -> do-        modifyPVar_ pvar (apply f)+        let (a', b :: Int) = apply f a+        modifyPVar pvar (apply f) `shouldReturn` b+        readPVar pvar `shouldReturn` a'+    propPVarIO "fetchModifyPVar" gen $ \a pvar ->+      return $+      forAll arbitrary $ \f -> do+        fetchModifyPVar pvar (apply f) `shouldReturn` a         readPVar pvar `shouldReturn` apply f a-    propPVarIO "modifyPVarM" gen $ \a pvar ->+    propPVarIO "fetchModifyPVarM" gen $ \a pvar ->       return $       forAllIO arbitrary $ \f -> do         a' <--          modifyPVarM pvar $ \a' -> do+          fetchModifyPVarM pvar $ \a' -> do             a' `shouldBe` a             pure $ apply f a'         a' `shouldBe` a         readPVar pvar `shouldReturn` apply f a+    propPVarIO "modifyFetchPVar" gen $ \a pvar ->+      return $+      forAll arbitrary $ \f ->+        modifyFetchPVar pvar (apply f) `shouldReturn` apply f a+    propPVarIO "modifyFetchPVarM" gen $ \a pvar ->+      return $+      forAllIO arbitrary $ \f -> do+        a' <-+          modifyFetchPVarM pvar $ \a' -> do+            a' `shouldBe` a+            pure $ apply f a'+        a' `shouldBe` apply f a     propPVarIO "modifyPVarM_" gen $ \a pvar ->       return $       forAllIO arbitrary $ \f -> do@@ -190,36 +208,59 @@       propPVarIO "copyFromByteArrayPVar" gen $ \_ var ->         return $         forAllIO (genByteArrayNonEmpty gen) $ \(ByteArrayNonEmpty i ba) -> do-            copyFromByteArrayPVar ba i var-            readPVar var `shouldReturn` indexByteArray ba i+          copyFromByteArrayPVar ba i var+          readPVar var `shouldReturn` indexByteArray ba i       propPVarIO "copyFromMutableByteArrayPVar" gen $ \_ var ->         return $         forAllIO (genByteArrayNonEmpty gen) $ \(ByteArrayNonEmpty i ba) -> do-            mba <- unsafeThawByteArray ba-            copyFromMutableByteArrayPVar mba i var-            readPVar var `shouldReturn` indexByteArray ba i+          mba <- unsafeThawByteArray ba+          copyFromMutableByteArrayPVar mba i var+          readPVar var `shouldReturn` indexByteArray ba i       propPVarST "sizeOf" gen $ \_ var -> pure (toPtrPVar var === Nothing)     describe "Reset Memory" $       propPVarIO "zeroPVar" gen $ \_ var -> do         zeroPVar var         readPVar var `shouldReturn` defZero     describe "Pinned Memory" $ do-      it "isByteArrayPinned - Unpinned" $-        forAllIO arbitrary $ \(Positive n) -> do-          mba <- newByteArray n+      let mostThreshold = 3248+          leastThreshold = 3277+      -- Experimentally found the threshold to be 3249:+      --     mostThreshold = 3248+      --     leastThreshold = 3249+      -- Documented to be 3277, but seems to be different in practice.+      -- https://gitlab.haskell.org/ghc/ghc/-/blob/feb852e67e166f752c783978f5fecc3c28c966f9/docs/users_guide/ffi-chap.rst#L1008+      it "Small - Unpinned" $ do+        mba <- newByteArray mostThreshold+        isMutableByteArrayPinned mba `shouldBe` False+        ba <- unsafeFreezeByteArray mba+        isByteArrayPinned ba `shouldBe` False+      it "Large - Pinned" $+        forAllIO arbitrary $ \(NonNegative n) -> do+          let n' = n + leastThreshold+          mba <- newByteArray n'+          isMutableByteArrayPinned mba `shouldBe` True           ba <- unsafeFreezeByteArray mba-          return $ not $ isByteArrayPinned ba+          isByteArrayPinned ba `shouldBe` True+      it "isByteArrayPinned - Unpinned" $+        forAll arbitrary $ \(NonNegative n) ->+          (n <= mostThreshold) ==> monadicIO $+          run $ do+            mba <- newByteArray n+            ba <- unsafeFreezeByteArray mba+            return $ not $ isByteArrayPinned ba       it "isByteArrayPinned - Pinned" $-        forAllIO arbitrary $ \(Positive n) -> do+        forAllIO arbitrary $ \(NonNegative n) -> do           mba <- newPinnedByteArray n           ba <- unsafeFreezeByteArray mba           return $ isByteArrayPinned ba       it "isMutableByteArrayPinned - Unpinned" $-        forAllIO arbitrary $ \(Positive n) -> do-          mba <- newByteArray n-          return $ not $ isMutableByteArrayPinned mba+        forAll arbitrary $ \(NonNegative n) ->+          n <= mostThreshold ==> monadicIO $+          run $ do+            mba <- newByteArray n+            return $ not $ isMutableByteArrayPinned mba       it "isMutableByteArrayPinned - Pinned" $-        forAllIO arbitrary $ \(Positive n) -> do+        forAllIO arbitrary $ \(NonNegative n) -> do           mba <- newPinnedByteArray n           return $ isMutableByteArrayPinned mba     extraSpec gen@@ -375,7 +416,7 @@           yvar <- newPVar x           ys' <-             mapConcurrently-              (\_ -> atomicModifyIntPVar yvar (\y -> (complement y, y)))+              (\_ -> atomicFetchModifyIntPVar yvar complement)               [1..n]           y' <- atomicReadIntPVar yvar           x' `shouldBe` y'@@ -406,12 +447,18 @@           yvar <- newPVar x           ys' <-             mapConcurrently-              (\y' -> atomicModifyIntPVar yvar (\y -> (f y y', y)))+              (\y' -> atomicFetchModifyIntPVar yvar (`f` y'))               xs           y' <- atomicReadIntPVar yvar+          atomicWriteIntPVar yvar x+          ys'' <-+            mapConcurrently+              (\y'' -> atomicModifyFetchIntPVar yvar (`f` y''))+              xs           x' `shouldBe` y'           F.foldl' f x' xs' `shouldBe` F.foldl' f x xs           F.foldl' f y' ys' `shouldBe` F.foldl' f x xs+          F.foldl' f x ys'' `shouldBe` F.foldl' f x xs  spec :: Spec spec = do