diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ | Language | Travis | Azure | Coveralls | |:--------:|:------:|:-----:|:---------:| -| ![GitHub top language](https://img.shields.io/github/languages/top/lehins/pvar.svg) | [![Travis](https://img.shields.io/travis/lehins/pvar/master.svg?label=Linux%20%26%20OS%20X)](https://travis-ci.org/lehins/pvar) | [![Build Status](https://dev.azure.com/kuleshevich/pvar/_apis/build/status/pvar?branchName=master)](https://dev.azure.com/kuleshevich/pvar/_build/latest?definitionId=1?branchName=master) | [![Coverage Status](https://coveralls.io/repos/github/lehins/pvar/badge.svg?branch=master)](https://coveralls.io/github/lehins/pvar?branch=master) +| ![GitHub top language](https://img.shields.io/github/languages/top/lehins/pvar.svg) | [![Travis](https://img.shields.io/travis/lehins/pvar/master.svg?label=Linux%20%26%20OS%20X)](https://travis-ci.org/lehins/pvar) | [![Build Status](https://dev.azure.com/kuleshevich/pvar/_apis/build/status/lehins.pvar?branchName=master)](https://dev.azure.com/kuleshevich/pvar/_build/latest?definitionId=1?branchName=master) | [![Coverage Status](https://coveralls.io/repos/github/lehins/pvar/badge.svg?branch=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. diff --git a/cbits/pvar.c b/cbits/pvar.c new file mode 100644 --- /dev/null +++ b/cbits/pvar.c @@ -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); +} diff --git a/pvar.cabal b/pvar.cabal --- a/pvar.cabal +++ b/pvar.cabal @@ -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 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 diff --git a/src/Data/Primitive/PVar.hs b/src/Data/Primitive/PVar.hs --- a/src/Data/Primitive/PVar.hs +++ b/src/Data/Primitive/PVar.hs @@ -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 diff --git a/src/Data/Primitive/PVar/Internal.hs b/src/Data/Primitive/PVar/Internal.hs --- a/src/Data/Primitive/PVar/Internal.hs +++ b/src/Data/Primitive/PVar/Internal.hs @@ -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 diff --git a/src/Data/Primitive/PVar/Unsafe.hs b/src/Data/Primitive/PVar/Unsafe.hs --- a/src/Data/Primitive/PVar/Unsafe.hs +++ b/src/Data/Primitive/PVar/Unsafe.hs @@ -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 #-} diff --git a/tests/Test/Primitive/PVarSpec.hs b/tests/Test/Primitive/PVarSpec.hs --- a/tests/Test/Primitive/PVarSpec.hs +++ b/tests/Test/Primitive/PVarSpec.hs @@ -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