pvar 0.1.0.0 → 0.1.1.0
raw patch · 8 files changed
+199/−89 lines, 8 filesdep −wide-worddep ~basedep ~primitivePVP ok
version bump matches the API change (PVP)
Dependencies removed: wide-word
Dependency ranges changed: base, primitive
API changes (from Hackage documentation)
+ Data.Primitive.PVar: alignment :: Prim a => a -> Int
+ Data.Primitive.PVar: sizeOf :: Prim a => a -> Int
+ Data.Primitive.PVar.Unsafe: isByteArrayPinned :: ByteArray -> Bool
+ Data.Primitive.PVar.Unsafe: isByteArrayPinned# :: ByteArray# -> Int#
+ Data.Primitive.PVar.Unsafe: isMutableByteArrayPinned :: MutableByteArray s -> Bool
+ Data.Primitive.PVar.Unsafe: isMutableByteArrayPinned# :: () => MutableByteArray# d -> Int#
Files
- CHANGELOG.md +12/−1
- README.md +11/−5
- cbits/pvar.c +22/−0
- pvar.cabal +19/−5
- src/Data/Primitive/PVar.hs +8/−1
- src/Data/Primitive/PVar/Internal.hs +26/−8
- src/Data/Primitive/PVar/Unsafe.hs +30/−6
- tests/Test/Primitive/PVarSpec.hs +71/−63
CHANGELOG.md view
@@ -1,3 +1,14 @@ # Changelog for pvar -## Unreleased changes+## 0.1.1.0++* Addition of backwards compatible:+ * `isByteArrayPinned`, `isMutableByteArrayPinned` (that work on ghc-7.10 and ghc-8.0)+ * Primitive versions `isByteArrayPinned#`, `isMutableByteArrayPinned#`+* Support for GHC 7.10 and GHC 8.0+* Re-export `sizeOf` and `alignment` for easier compatibility with older primitive versions.+++## 0.1.0.0++* Initial release
README.md view
@@ -6,7 +6,7 @@ | Language | Travis | Azure | Coveralls | |:--------:|:------:|:-----:|:---------:|-|  | [](https://travis-ci.org/lehins/pvar) | [](https://dev.azure.com/kuleshevich/pvar/_build/latest?definitionId=1?branchName=master) | [](https://coveralls.io/github/lehins/pvar?branch=master)+|  | [](https://travis-ci.org/lehins/pvar) | [](https://dev.azure.com/kuleshevich/pvar/_build/latest?definitionId=1?branchName=master) | [](https://coveralls.io/github/lehins/pvar?branch=master) | Package | Hackage | Nightly | LTS | |:-------------------|:-------:|:-------:|:---:|@@ -17,10 +17,16 @@ Main features include: * Perfomance. There is practically no overhead when compared to operating on pure values,- wlthough there is a higher memory overhead, since `PVar` is backed by a+ 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- `atomicModifyIntPVar :: PrimMonad m => PVar (PrimState m) Int -> (Int -> (Int, a)) -> m a`- function that is not availiable in `ghc-prim` out of the box.+* Atomic operations for `PVar`s with `Int` values. This includes a unique function that is+ not availiable 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. * 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.
+ cbits/pvar.c view
@@ -0,0 +1,22 @@+#include "Rts.h"++/**+ * Rewrite of some Cmm in C. It is not in Cmm because `bdescr_flags` is not available+ * until this commit:+ * https://gitlab.haskell.org/ghc/ghc/commit/310371ff2d5b73cdcb2439b67170ca5e613541c0+ *+ * Cmm version can be found here:+ * https://gitlab.haskell.org/ghc/ghc/blob/4e8a71c1138b587dfbab8a1823b3f7fa6f0166bd/rts/PrimOps.cmm#L157-174+ *+ * Its types in Haskell are:+ * - `ByteArray# s -> Int#`+ * - `MutableByteArray# s -> Int#`+ *+ */+long pvar_is_byte_array_pinned(StgPtr ba)+{+ bdescr *bd = Bdescr(ba);+ // All of BF_PINNED, BF_LARGE and BF_COMPACT are considered immovable. Although+ // BF_COMPACT is only available in ghc-8.2, so we don't care about it.+ return ((bd->flags & (BF_PINNED | BF_LARGE)) != 0);+}
pvar.cabal view
@@ -1,7 +1,7 @@ cabal-version: 1.12 name: pvar-version: 0.1.0.0+version: 0.1.1.0 synopsis: Mutable variable with primitive values description: Please see the README on GitHub at <https://github.com/lehins/pvar#readme> homepage: https://github.com/lehins/pvar#readme@@ -12,6 +12,18 @@ license: BSD3 license-file: LICENSE build-type: Simple+tested-with: GHC == 7.10.2+ , GHC == 7.10.3+ , GHC == 8.0.1+ , GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.3+ , GHC == 8.4.4+ , GHC == 8.6.3+ , GHC == 8.6.4+ , GHC == 8.6.5+ , GHC == 8.8.2+ , GHC == 8.8.3 extra-source-files: README.md , CHANGELOG.md @@ -24,10 +36,13 @@ , Data.Primitive.PVar.Unsafe other-modules: Data.Primitive.PVar.Internal hs-source-dirs: src- build-depends: base >=4.7 && <5+ build-depends: base >=4.8 && <6 , deepseq- , primitive >= 0.3.1+ , primitive >= 0.5.4.0 default-language: Haskell2010+ ghc-options: -Wall+ if impl(ghc < 8.2)+ c-sources: cbits/pvar.c test-suite tests type: exitcode-stdio-1.0@@ -35,7 +50,7 @@ other-modules: Spec , Test.Primitive.PVarSpec hs-source-dirs: tests- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 , async , deepseq@@ -44,5 +59,4 @@ , hspec , QuickCheck , genvalidity- , wide-word default-language: Haskell2010
src/Data/Primitive/PVar.hs view
@@ -1,6 +1,10 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif -- | -- Module : Data.Primitive.PVar -- Copyright : (c) Alexey Kuleshevich 2020@@ -68,6 +72,8 @@ , Prim , PrimMonad(PrimState) , RealWorld+ , sizeOf+ , alignment , ST , runST , S.Storable(peek, poke)@@ -75,10 +81,11 @@ import Control.Monad (void) import Control.Monad.Primitive (PrimMonad(primitive), PrimState, primitive_,- touch, primToPrim)+ touch) 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
src/Data/Primitive/PVar/Internal.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-}-{-# OPTIONS_GHC -Wno-redundant-constraints -fobject-code #-} -- | -- Module : Data.Primitive.PVar.Internal -- Copyright : (c) Alexey Kuleshevich 2020@@ -40,12 +41,16 @@ , atomicModifyIntPVar , atomicModifyIntArray_# , atomicModifyIntPVar_+ -- * Re-exports+ , isByteArrayPinned#+ , isMutableByteArrayPinned# ) 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@@ -156,8 +161,9 @@ forall a m. (PrimMonad m, S.Storable a) => m (PVar m a) rawStorablePVar =- let I# size# = S.sizeOf (undefined :: a)- in primitive $ \s# ->+ case S.sizeOf (undefined :: a) of+ I# size# ->+ primitive $ \s# -> case newPinnedByteArray# size# s# of (# s'#, mba# #) -> (# s'#, PVar mba# #) {-# INLINE rawStorablePVar #-}@@ -171,11 +177,13 @@ => m (PVar m a) rawAlignedStorablePVar = let dummy = undefined :: a- I# size# = S.sizeOf dummy- I# align# = S.alignment dummy- in primitive $ \s# ->- case newAlignedPinnedByteArray# size# align# s# of- (# s'#, mba# #) -> (# s'#, PVar mba# #)+ in case S.sizeOf dummy of+ I# size# ->+ case S.alignment dummy of+ I# align# ->+ primitive $ \s# ->+ case newAlignedPinnedByteArray# size# align# s# of+ (# s'#, mba# #) -> (# s'#, PVar mba# #) {-# INLINE rawAlignedStorablePVar #-} @@ -347,3 +355,13 @@ atomicModifyIntPVar_ (PVar mba#) f = primitive_ (atomicModifyIntArray_# mba# 0# (\i# -> unI# (f (I# i#)))) {-# INLINE atomicModifyIntPVar_ #-}+++-- ghc-8.2 (i.e. 802 version) introduced these two functions, for versions before those+-- use their reimplementations in C:+# if __GLASGOW_HASKELL__ < 802+foreign import ccall unsafe "pvar.c pvar_is_byte_array_pinned"+ isByteArrayPinned# :: ByteArray# -> Int#+foreign import ccall unsafe "pvar.c pvar_is_byte_array_pinned"+ isMutableByteArrayPinned# :: MutableByteArray# s -> Int#+#endif
src/Data/Primitive/PVar/Unsafe.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Primitive.PVar.Unsafe@@ -39,17 +37,22 @@ , copyFromByteArrayPVar , copyFromMutableByteArrayPVar , copyPVarToMutableByteArray+ -- ** Check if memory is pinned+ , isByteArrayPinned+ , isMutableByteArrayPinned+ -- *** Primitive versions+ , isByteArrayPinned#+ , isMutableByteArrayPinned# -- * Helpers , showsType , unI# ) where -import Control.Monad.Primitive (PrimMonad(primitive), PrimState, touch, primitive_)+import Control.Monad.Primitive (PrimMonad, PrimState, primitive_) import Data.Primitive.PVar.Internal-import Data.Primitive.ByteArray+import Data.Primitive.ByteArray (ByteArray(..), MutableByteArray(..)) import Data.Primitive.Types-import qualified Foreign.Storable as S import GHC.Exts as Exts import GHC.ForeignPtr import Data.Typeable@@ -73,7 +76,7 @@ -- -- @since 0.1.0 toPtrPVar :: PVar m a -> Maybe (Ptr a)-toPtrPVar pvar@(PVar mba#)+toPtrPVar pvar | isPinnedPVar pvar = Just $ unsafeToPtrPVar pvar | otherwise = Nothing {-# INLINE toPtrPVar #-}@@ -193,3 +196,24 @@ -- | Show the type name showsType :: Typeable t => proxy t -> ShowS showsType = showsTypeRep . typeRep+++-- | Check whether or not the `ByteArray` is pinned.+--+-- /__Note__/ - This function uses GHC built-in functions for GHC 8.2 and newer, but for older+-- versions it fallsback onto custom implementation.+--+-- @since 0.1.1+isByteArrayPinned :: ByteArray -> Bool+isByteArrayPinned (ByteArray arr#) = isTrue# (isByteArrayPinned# arr#)+{-# INLINE isByteArrayPinned #-}++-- | Check whether or not the `MutableByteArray` is pinned.+--+-- /__Note__/ - This function uses GHC built-in functions for GHC 8.2 and newer, but for older+-- versions it fallsback onto custom implementation.+--+-- @since 0.1.1+isMutableByteArrayPinned :: MutableByteArray s -> Bool+isMutableByteArrayPinned (MutableByteArray marr#) = isTrue# (isMutableByteArrayPinned# marr#)+{-# INLINE isMutableByteArrayPinned #-}
tests/Test/Primitive/PVarSpec.hs view
@@ -1,22 +1,22 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-+{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Primitive.PVarSpec (spec) where -import Control.Monad import Control.Concurrent.Async import Control.DeepSeq-import Data.GenValidity-import Data.Int+import Control.Monad import Data.Bits-import Data.List (partition) import Data.Foldable as F-import Data.Maybe-import Data.WideWord-import Data.Primitive.ByteArray+import Data.GenValidity+import Data.Int+import Data.List (intercalate, partition)+import Data.Primitive.ByteArray (ByteArray, indexByteArray, newByteArray,+ newPinnedByteArray, readByteArray,+ sizeofByteArray, unsafeFreezeByteArray,+ unsafeThawByteArray, writeByteArray) import Data.Primitive.PVar import Data.Primitive.PVar.Unsafe as Unsafe-import Data.Primitive.Types (sizeOf, alignment) import Data.Typeable import Data.Word import Foreign.ForeignPtr@@ -25,6 +25,7 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Function (apply) import Test.QuickCheck.Monadic forAllIO :: (Show p, Testable t) => Gen p -> (p -> IO t) -> Property@@ -68,11 +69,28 @@ -- @a@. Also contains a valid index in number of elements into the array data ByteArrayNonEmpty a = ByteArrayNonEmpty Int ByteArray- deriving (Show, Eq) +-- For testing with older primitive can't derive Show and Eq+instance (Prim a, Show a) => Show (ByteArrayNonEmpty a) where+ show (ByteArrayNonEmpty i ba) =+ "(ByteArrayNonEmpty " +++ show i +++ "[" +++ intercalate "," (map show (byteArrayToList undefined ba :: [a])) ++ "]"++instance (Prim a, Eq a) => Eq (ByteArrayNonEmpty a) where+ (ByteArrayNonEmpty i1 ba1) == (ByteArrayNonEmpty i2 ba2) =+ i1 == i2 && byteArrayToList (undefined :: a) ba1 == byteArrayToList (undefined :: a) ba2++byteArrayToList :: forall a. Prim a => a -> ByteArray -> [a]+byteArrayToList dummy ba = map (indexByteArray ba :: Int -> a) [0 .. n - 1]+ where+ n = sizeofByteArray ba `div` sizeOf dummy+ instance (Arbitrary a, Prim a) => Arbitrary (ByteArrayNonEmpty a) where arbitrary = genByteArrayNonEmpty (arbitrary :: Gen a) +genByteArrayNonEmpty :: Prim a => Gen a -> Gen (ByteArrayNonEmpty a) genByteArrayNonEmpty gen = do Positive n <- arbitrary xs <- vectorOf n gen@@ -116,29 +134,29 @@ propPVarIO "modifyPVar" gen $ \a pvar -> return $ forAll arbitrary $ \f -> do- modifyPVar pvar (applyFun f) `shouldReturn` a- readPVar pvar `shouldReturn` applyFun f a+ modifyPVar pvar (apply f) `shouldReturn` a+ readPVar pvar `shouldReturn` apply f a propPVarIO "modifyPVar_" gen $ \a pvar -> return $ forAll arbitrary $ \f -> do- modifyPVar_ pvar (applyFun f)- readPVar pvar `shouldReturn` applyFun f a+ modifyPVar_ pvar (apply f)+ readPVar pvar `shouldReturn` apply f a propPVarIO "modifyPVarM" gen $ \a pvar -> return $ forAllIO arbitrary $ \f -> do a' <- modifyPVarM pvar $ \a' -> do a' `shouldBe` a- pure $ applyFun f a'+ pure $ apply f a' a' `shouldBe` a- readPVar pvar `shouldReturn` applyFun f a+ readPVar pvar `shouldReturn` apply f a propPVarIO "modifyPVarM_" gen $ \a pvar -> return $ forAllIO arbitrary $ \f -> do modifyPVarM_ pvar $ \a' -> do a' `shouldBe` a- pure $ applyFun f a'- readPVar pvar `shouldReturn` applyFun f a+ pure $ apply f a'+ readPVar pvar `shouldReturn` apply f a propPVarIO "swapPVars" gen $ \a avar -> return $ forAllPVarIO gen $ \b bvar -> do@@ -171,24 +189,39 @@ (===) <$> readByteArray mba i <*> readPVar var propPVarIO "copyFromByteArrayPVar" gen $ \_ var -> return $- forAll (genByteArrayNonEmpty gen) $ \(ByteArrayNonEmpty i ba) ->- monadicIO $- run $ do+ forAllIO (genByteArrayNonEmpty gen) $ \(ByteArrayNonEmpty i ba) -> do copyFromByteArrayPVar ba i var readPVar var `shouldReturn` indexByteArray ba i propPVarIO "copyFromMutableByteArrayPVar" gen $ \_ var -> return $- forAll (genByteArrayNonEmpty gen) $ \(ByteArrayNonEmpty i ba) ->- monadicIO $- run $ do+ forAllIO (genByteArrayNonEmpty gen) $ \(ByteArrayNonEmpty i ba) -> do mba <- unsafeThawByteArray ba copyFromMutableByteArrayPVar mba i var readPVar var `shouldReturn` indexByteArray ba i- propPVarST "sizeOf" gen $ \a var -> pure (toPtrPVar var === Nothing)+ 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+ ba <- unsafeFreezeByteArray mba+ return $ not $ isByteArrayPinned ba+ it "isByteArrayPinned - Pinned" $+ forAllIO arbitrary $ \(Positive 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+ it "isMutableByteArrayPinned - Pinned" $+ forAllIO arbitrary $ \(Positive n) -> do+ mba <- newPinnedByteArray n+ return $ isMutableByteArrayPinned mba extraSpec gen specStorable ::@@ -197,17 +230,19 @@ -> Spec specStorable gen = describe "Storable" $ do- propPVarIO "withPVarPtr (newPVar)" gen $ \a var ->+ propPVarIO "withPVarPtr (newPVar)" gen $ \_ var -> withPtrPVar var pure `shouldReturn` Nothing prop "withPVarPtr (newPinnedPVar)" $ forAllIO gen $ \a -> do var <- newPinnedPVar a- fmap fromJust $ withPtrPVar var $ \ptr -> peek ptr `shouldReturn` a+ maybe (error "Expected to get a Just Ptr") pure =<<+ withPtrPVar var (\ptr -> peek ptr `shouldReturn` a) prop "withPVarPtr (newAlignedPinnedPVar)" $ forAllIO gen $ \a -> do var <- newAlignedPinnedPVar a- fmap fromJust $ withPtrPVar var $ \ptr -> peek ptr `shouldReturn` a- propPVarIO "toForeignPtr (newPVar)" gen $ \a var ->+ maybe (error "Expected to get a Just Ptr") pure =<<+ withPtrPVar var (\ptr -> peek ptr `shouldReturn` a)+ propPVarIO "toForeignPtr (newPVar)" gen $ \_ var -> toForeignPtrPVar var `shouldBe` Nothing prop "toForeignPtr (newPinnedPVar)" $ forAllIO gen $ \a -> do@@ -335,13 +370,13 @@ propPVarIO "atomicNotIntPVar" gen $ \x xvar -> return $ forAllIO arbitrary $ \(Positive n) -> do- xs' <- replicateConcurrently n (atomicNotIntPVar xvar)+ xs' <- mapConcurrently (\_ -> atomicNotIntPVar xvar) [1 :: Int .. n] x' <- atomicReadIntPVar xvar yvar <- newPVar x ys' <-- replicateConcurrently- n- (atomicModifyIntPVar yvar (\y -> (complement y, y)))+ mapConcurrently+ (\_ -> atomicModifyIntPVar yvar (\y -> (complement y, y)))+ [1..n] y' <- atomicReadIntPVar yvar x' `shouldBe` y' -- binary negation of N times results in two values, both of which happen N/2@@ -356,11 +391,10 @@ propPVarIO name gen $ \x xvar -> return $ forAllIO (genListOf gen) $ \xs -> do- mapConcurrently_ (af xvar) xs+ void $ mapConcurrently (af xvar) xs x' <- atomicReadIntPVar xvar yvar <- newPVar x- mapConcurrently_ (\y' -> atomicModifyIntPVar_ yvar (f y')) xs- -- mapConcurrently_ (atomicModifyIntPVar_ yvar . f) xs+ void $ mapConcurrently (atomicModifyIntPVar_ yvar . f) xs y' <- atomicReadIntPVar yvar x' `shouldBe` y' casProp gen name f af =@@ -377,30 +411,7 @@ y' <- atomicReadIntPVar yvar x' `shouldBe` y' F.foldl' f x' xs' `shouldBe` F.foldl' f x xs--instance Arbitrary Int128 where- arbitrary = Int128 <$> arbitrary <*> arbitrary-instance Arbitrary Word128 where- arbitrary = Word128 <$> arbitrary <*> arbitrary-instance Arbitrary Word256 where- arbitrary = Word256 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary-instance CoArbitrary Int128 where- coarbitrary (Int128 a b) = coarbitrary a- . coarbitrary b-instance CoArbitrary Word128 where- coarbitrary (Word128 a b) = coarbitrary a- . coarbitrary b-instance CoArbitrary Word256 where- coarbitrary (Word256 a b c d) = coarbitrary a- . coarbitrary b- . coarbitrary c- . coarbitrary d-instance Function Int128 where- function = functionIntegral-instance Function Word128 where- function = functionIntegral-instance Function Word256 where- function = functionIntegral+ F.foldl' f y' ys' `shouldBe` F.foldl' f x xs spec :: Spec spec = do@@ -417,6 +428,3 @@ specPrim '\0' (genValid :: Gen Char) specStorable specPrim 0 (arbitrary :: Gen Float) specStorable specPrim 0 (arbitrary :: Gen Double) specStorable- specPrim 0 (arbitrary :: Gen Int128) specStorable- specPrim 0 (arbitrary :: Gen Word128) specStorable- --specPrim 0 (arbitrary :: Gen Word256) specStorable -- https://github.com/erikd/wide-word/issues/40