pvar (empty) → 0.1.0.0
raw patch · 11 files changed
+1466/−0 lines, 11 filesdep +QuickCheckdep +asyncdep +basesetup-changed
Dependencies added: QuickCheck, async, base, deepseq, genvalidity, hspec, primitive, pvar, wide-word
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- README.md +26/−0
- Setup.hs +2/−0
- pvar.cabal +48/−0
- src/Data/Primitive/PVar.hs +379/−0
- src/Data/Primitive/PVar/Internal.hs +349/−0
- src/Data/Primitive/PVar/Unsafe.hs +195/−0
- tests/Main.hs +11/−0
- tests/Spec.hs +1/−0
- tests/Test/Primitive/PVarSpec.hs +422/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# Changelog for pvar++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Alexey Kuleshevich (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Alexey Kuleshevich nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,26 @@+# pvar++Interface for a mutable veriable `PVar` that can hold values that have `Prim` instance.++## Status++| 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)++| Package | Hackage | Nightly | LTS |+|:-------------------|:-------:|:-------:|:---:|+| [`pvar`](https://github.com/lehins/pvar)| [](https://hackage.haskell.org/package/pvar)| [](https://www.stackage.org/nightly/package/pvar)| [](https://www.stackage.org/lts/package/pvar)++# Overview++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+ `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.+* Works in `PrimMonad`, therfore usable with `ST`, `IO` and various transformer monads.+* Easy access to `PVar` contents with `Storable`
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pvar.cabal view
@@ -0,0 +1,48 @@+cabal-version: 1.12++name: pvar+version: 0.1.0.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+bug-reports: https://github.com/lehins/pvar/issues+author: Alexey Kuleshevich+maintainer: alexey@kuleshevi.ch+copyright: Alexey Kuleshevich+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files: README.md+ , CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/lehins/pvar++library+ exposed-modules: Data.Primitive.PVar+ , Data.Primitive.PVar.Unsafe+ other-modules: Data.Primitive.PVar.Internal+ hs-source-dirs: src+ build-depends: base >=4.7 && <5+ , deepseq+ , primitive >= 0.3.1+ default-language: Haskell2010++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: Spec+ , Test.Primitive.PVarSpec+ hs-source-dirs: tests+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: base >=4.7 && <5+ , async+ , deepseq+ , pvar+ , primitive+ , hspec+ , QuickCheck+ , genvalidity+ , wide-word+ default-language: Haskell2010
+ src/Data/Primitive/PVar.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UnboxedTuples #-}+-- |+-- Module : Data.Primitive.PVar+-- Copyright : (c) Alexey Kuleshevich 2020+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- 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+ -- 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+ -- into a `PVar`++ -- * Primitive variable+ PVar+ , newPVar+ , withPVarST+ -- * Generic Operations+ , readPVar+ , writePVar+ , modifyPVar_+ , modifyPVar+ , modifyPVarM_+ , modifyPVarM+ , swapPVars_+ , swapPVars+ , copyPVar+ , sizeOfPVar+ , alignmentPVar+ -- * Pinned memory+ --+ -- $pinned+ , newPinnedPVar+ , newAlignedPinnedPVar+ , withPtrPVar+ , withStorablePVar+ , withAlignedStorablePVar+ , copyPVarToPtr+ , toForeignPtrPVar+ , isPinnedPVar+ , peekPrim, pokePrim+ -- -- * Numeric infix operations+ -- , (=+)+ -- , (=-)+ -- , (=*)+ -- , (=/)+ -- , (=%)+ -- ** Atomic operations+ , atomicModifyIntPVar+ , atomicModifyIntPVar_+ , atomicReadIntPVar+ , atomicWriteIntPVar+ , casIntPVar+ , atomicAddIntPVar+ , atomicSubIntPVar+ , atomicAndIntPVar+ , atomicNandIntPVar+ , atomicOrIntPVar+ , atomicXorIntPVar+ , atomicNotIntPVar+ -- ** Re-exports+ , Prim+ , PrimMonad(PrimState)+ , RealWorld+ , ST+ , runST+ , S.Storable(peek, poke)+ ) where++import Control.Monad (void)+import Control.Monad.Primitive (PrimMonad(primitive), PrimState, primitive_,+ touch, primToPrim)+import Control.Monad.ST (ST, runST)+import Data.Primitive.PVar.Internal+import Data.Primitive.PVar.Unsafe+import Data.Primitive.Types+import qualified Foreign.Storable as S+import GHC.Exts+import GHC.ForeignPtr++-- $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+-- type. This is highly uncommon in practice and if you are intermixing the two concepts+-- together you probably already know what you are doing.++++-- | Run an `ST` action on a mutable variable.+--+-- @since 0.1.0+withPVarST ::+ Prim p+ => p -- ^ Initial value assigned to the mutable variable+ -> (forall s. PVar (ST s) p -> ST s a) -- ^ Action to run+ -> a -- ^ Result produced by the `ST` action+withPVarST x st = runST (newPVar x >>= st)+{-# INLINE withPVarST #-}++-- | Apply an action to the `Ptr` that references the mutable variable, but only if it is+-- backed by pinned memory, cause otherwise it would be unsafe.+--+-- @since 0.1.0+withPtrPVar :: (PrimMonad m, Prim a) => PVar n a -> (Ptr a -> m b) -> m (Maybe b)+withPtrPVar pvar f =+ case toPtrPVar pvar of+ Nothing -> return Nothing+ Just ptr -> do+ r <- f ptr+ touch pvar+ return $ Just r+{-# INLINE withPtrPVar #-}++-- | Convert `PVar` into a `ForeignPtr`, but only if it is backed by pinned memory.+--+-- @since 0.1.0+toForeignPtrPVar :: PVar IO a -> Maybe (ForeignPtr a)+toForeignPtrPVar pvar+ | isPinnedPVar pvar = Just $ unsafeToForeignPtrPVar pvar+ | otherwise = Nothing+{-# INLINE toForeignPtrPVar #-}++-- | Copy contents of one mutable variable `PVar` into another+--+-- @since 0.1.0+copyPVar ::+ (PrimMonad m, Prim a)+ => PVar m a -- ^ Source variable+ -> PVar m a -- ^ Destination variable+ -> m ()+copyPVar pvar@(PVar mbas#) (PVar mbad#) =+ primitive_ (copyMutableByteArray# mbas# 0# mbad# 0# (sizeOfPVar# pvar))+{-# INLINE copyPVar #-}++-- | Copy contents of a mutable variable `PVar` into a pointer `Ptr`+--+-- @since 0.1.0+copyPVarToPtr :: (PrimMonad m, Prim a) => PVar m a -> Ptr a -> m ()+copyPVarToPtr pvar@(PVar mbas#) (Ptr addr#) =+ primitive_ (copyMutableByteArrayToAddr# mbas# 0# addr# (sizeOfPVar# pvar))+{-# INLINE copyPVarToPtr #-}++-- | Apply a pure function to the contents of a mutable variable. Returns the old value.+--+-- @since 0.1.0+modifyPVar :: (PrimMonad m, Prim a) => PVar m a -> (a -> a) -> m a+modifyPVar pvar f = modifyPVarM pvar (return . f)+{-# INLINE modifyPVar #-}++-- | Apply a pure function to the contents of a mutable variable.+--+-- @since 0.1.0+modifyPVar_ :: (PrimMonad m, Prim a) => PVar m a -> (a -> a) -> m ()+modifyPVar_ pvar f = modifyPVarM_ pvar (return . f)+{-# INLINE modifyPVar_ #-}++-- | Apply a monadic action 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+modifyPVarM pvar f = do+ a <- readPVar pvar+ a' <- f a+ writePVar pvar a'+ return a+{-# INLINE modifyPVarM #-}++-- | Apply a monadic action to the contents of a mutable variable.+--+-- @since 0.1.0+modifyPVarM_ :: (PrimMonad m, Prim a) => PVar m a -> (a -> m a) -> m ()+modifyPVarM_ pvar f = readPVar pvar >>= f >>= writePVar pvar+{-# INLINE modifyPVarM_ #-}++-- | Swap contents of two mutable variables. Returns their old values.+--+-- @since 0.1.0+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)+{-# INLINE swapPVars #-}++-- | Swap contents of two mutable variables.+--+-- @since 0.1.0+swapPVars_ :: (PrimMonad m, Prim a) => PVar m a -> PVar m a -> m ()+swapPVars_ pvar1 pvar2 = void $ swapPVars pvar1 pvar2+{-# INLINE swapPVars_ #-}++-- TODO: Come up with a concrete interface for numerics+-- (=+) :: (PrimMonad m, Prim a, Num a) => PVar (PrimState m) a -> a -> m ()+-- (=+) pvar a = modifyPVar_ pvar (+ a)+-- {-# INLINE (=+) #-}++-- (=-) :: (PrimMonad m, Prim a, Num a) => PVar (PrimState m) a -> a -> m ()+-- (=-) pvar a = modifyPVar_ pvar (subtract a)+-- {-# INLINE (=-) #-}++-- (=*) :: (PrimMonad m, Prim a, Num a) => PVar (PrimState m) a -> a -> m ()+-- (=*) pvar a = modifyPVar_ pvar (* a)+-- {-# INLINE (=*) #-}++-- (=/) :: (PrimMonad m, Prim a, Fractional a) => PVar (PrimState m) a -> a -> m ()+-- (=/) pvar a = modifyPVar_ pvar (/ a)+-- {-# INLINE (=/) #-}++-- -- | C like modulo operator+-- (=%) :: (PrimMonad m, Prim a, Integral a) => PVar (PrimState m) a -> a -> m ()+-- (=%) pvar a = modifyPVar_ pvar (`mod` a)+-- {-# INLINE (=%) #-}+++++-- | Apply an action to the newly allocated `PVar` and to the `Ptr` that references+-- 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+-- memory when it is no longer needed.+--+-- @since 0.1.0+withStorablePVar ::+ (PrimMonad m, S.Storable a)+ => a -- ^ Initial value+ -> (PVar m a -> Ptr a -> m b) -- ^ Action to run+ -> m b+withStorablePVar a f = do+ pvar <- rawStorablePVar+ runWithPokedPtr pvar a f+{-# INLINE withStorablePVar #-}++-- | Same `withStorablePVar`, except memory is aligned according to `S.alignment`.+--+-- @since 0.1.0+withAlignedStorablePVar ::+ (PrimMonad m, S.Storable a)+ => a -- ^ Initial value+ -> (PVar m a -> Ptr a -> m b) -- ^ Action to run+ -> m b+withAlignedStorablePVar a f = do+ pvar <- rawAlignedStorablePVar+ runWithPokedPtr pvar a f+{-# INLINE withAlignedStorablePVar #-}+++-- | Create a new `PVar` in pinned memory with an initial value in it aligned on the size of+-- an `Int`. Implies a full memory barrier.+--+-- @since 0.1.0+atomicReadIntPVar :: PrimMonad m => PVar m Int -> m Int+atomicReadIntPVar (PVar mba#) =+ primitive $ \s# ->+ case atomicReadIntArray# mba# 0# s# of+ (# s'#, i# #) -> (# s'#, I# i# #)+{-# INLINE atomicReadIntPVar #-}++-- | Write a value into an `PVar` atomically. Implies a full memory barrier.+--+-- @since 0.1.0+atomicWriteIntPVar :: PrimMonad m => PVar m Int -> Int -> m ()+atomicWriteIntPVar (PVar mba#) a = primitive_ (atomicWriteIntArray# mba# 0# (unI# a))+{-# INLINE atomicWriteIntPVar #-}+++-- | Compare and swap. This is a function that is used to implement `modifyIntPVar`. Implies a+-- full memory barrier.+--+-- @since 0.1.0+casIntPVar ::+ PrimMonad m+ => PVar m Int -- ^ Variable to mutate+ -> Int -- ^ Old expected value+ -> Int -- ^ New value+ -> m Int -- ^ Old actual value+casIntPVar (PVar mba#) old new =+ primitive $ \s# ->+ case casIntArray# mba# 0# (unI# old) (unI# new) s# of+ (# s'#, i'# #) -> (# s'#, I# i'# #)+{-# INLINE casIntPVar #-}++++-- | Add two numbers, corresponds to @`+`@ done atomically. Returns the previous value of+-- the mutable variable. Implies a full memory barrier.+--+-- @since 0.1.0+atomicAddIntPVar :: PrimMonad m => PVar m Int -> Int -> m Int+atomicAddIntPVar (PVar mba#) a =+ primitive $ \s# ->+ case fetchAddIntArray# mba# 0# (unI# a) s# of+ (# s'#, p# #) -> (# s'#, I# p# #)+{-# INLINE atomicAddIntPVar #-}++-- | Subtract two numbers, corresponds to @`subtract`@ done atomically. Returns the+-- previous value of the mutable variable. Implies a full memory barrier.+--+-- @since 0.1.0+atomicSubIntPVar :: PrimMonad m => PVar m Int -> Int -> m Int+atomicSubIntPVar (PVar mba#) a =+ primitive $ \s# ->+ case fetchSubIntArray# mba# 0# (unI# a) s# of+ (# s'#, p# #) -> (# s'#, I# p# #)+{-# INLINE atomicSubIntPVar #-}+++-- | Binary conjuction (AND), corresponds to @`and`@ done atomically. Returns the previous+-- value of the mutable variable. Implies a full memory barrier.+--+-- @since 0.1.0+atomicAndIntPVar :: PrimMonad m => PVar m Int -> Int -> m Int+atomicAndIntPVar (PVar mba#) a =+ primitive $ \s# ->+ case fetchAndIntArray# mba# 0# (unI# a) s# of+ (# s'#, p# #) -> (# s'#, I# p# #)+{-# 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+-- a full memory barrier.+--+-- @since 0.1.0+atomicNandIntPVar :: PrimMonad m => PVar m Int -> Int -> m Int+atomicNandIntPVar (PVar mba#) a =+ primitive $ \s# ->+ case fetchNandIntArray# mba# 0# (unI# a) s# of+ (# s'#, p# #) -> (# s'#, I# p# #)+{-# INLINE atomicNandIntPVar #-}+++-- | Binary disjunction (OR), corresponds to `or` done atomically. Returns the previous+-- value of the mutable variable. Implies a full memory barrier.+--+-- @since 0.1.0+atomicOrIntPVar :: PrimMonad m => PVar m Int -> Int -> m Int+atomicOrIntPVar (PVar mba#) a =+ primitive $ \s# ->+ case fetchOrIntArray# mba# 0# (unI# a) s# of+ (# s'#, p# #) -> (# s'#, I# p# #)+{-# INLINE atomicOrIntPVar #-}+++-- | Binary exclusive disjunction (XOR), corresponds to `xor` done atomically. Returns the+-- previous value of the mutable variable. Implies a full memory barrier.+--+-- @since 0.1.0+atomicXorIntPVar :: PrimMonad m => PVar m Int -> Int -> m Int+atomicXorIntPVar (PVar mba#) a =+ primitive $ \s# ->+ case fetchXorIntArray# mba# 0# (unI# a) s# of+ (# s'#, p# #) -> (# s'#, I# p# #)+{-# INLINE atomicXorIntPVar #-}+++-- | Binary negation (NOT), corresponds to ones' `complement` done atomically. Returns the+-- previous value of the mutable variable. Implies a full memory barrier.+--+-- @since 0.1.0+atomicNotIntPVar :: PrimMonad m => PVar m Int -> m Int+atomicNotIntPVar (PVar mba#) =+ primitive $ \s# ->+ case fetchXorIntArray# mba# 0# fullInt# s# of+ (# s'#, p# #) -> (# s'#, I# p# #)+ where+ fullInt# =+ case maxBound :: Word of+ W# w# -> word2Int# w#+{-# INLINE atomicNotIntPVar #-}+
+ src/Data/Primitive/PVar/Internal.hs view
@@ -0,0 +1,349 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# 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+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Primitive.PVar.Internal+ ( PVar(..)+ , newPVar+ , newPinnedPVar+ , newAlignedPinnedPVar+ , rawPVar+ , rawPinnedPVar+ , rawAlignedPinnedPVar+ , rawStorablePVar+ , rawAlignedStorablePVar+ , unsafeToPtrPVar+ , runWithPokedPtr+ , peekPrim+ , pokePrim+ , readPVar+ , writePVar+ , isPinnedPVar+ , sizeOfPVar+ , sizeOfPVar#+ , alignmentPVar+ , alignmentPVar#+ , unI#+ -- * Atomic operations+ , atomicModifyIntArray#+ , atomicModifyIntPVar+ , atomicModifyIntArray_#+ , atomicModifyIntPVar_+ )+ where++import Control.DeepSeq+import Control.Monad.Primitive (PrimMonad(primitive), PrimState, primitive_,+ touch, unsafePrimToPrim)+import Data.Primitive.Types+import qualified Foreign.Storable as S+import GHC.Exts++-- | Mutable variable with primitive value.+--+-- @since 0.1.0+data PVar m a = PVar (MutableByteArray# (PrimState m))++-- | @`S.poke`+`S.peek`@ will result in a new copy of a `PVar`+instance Prim a => S.Storable (PVar IO a) where+ sizeOf _ = sizeOf (undefined :: a)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined :: a)+ {-# INLINE alignment #-}+ peekElemOff (Ptr addr#) (I# i#) = do+ a <- primitive (readOffAddr# addr# i#)+ newAlignedPinnedPVar a+ {-# INLINE peekElemOff #-}+ pokeElemOff (Ptr addr#) (I# i#) pvar = do+ a <- readPVar pvar+ primitive_ (writeOffAddr# addr# i# a)+ {-# INLINE pokeElemOff #-}++-- | Values are already written into `PVar` in NF, this instance is trivial.+instance NFData (PVar m a) where+ rnf (PVar _) = ()++-- | Create a mutable variable in unpinned memory (i.e. GC can move it) with an initial+-- value. This is a prefered way to create a mutable variable, since it will not+-- contribute to memory fragmentation. For pinned memory versions see `newPinnedPVar` and+-- `newAlignedPinnedPVar`+--+-- @since 0.1.0+newPVar :: (PrimMonad m, Prim a) => a -> m (PVar m a)+newPVar v = do+ pvar <- rawPVar+ writePVar pvar v+ return pvar+{-# INLINE newPVar #-}++-- | Create a mutable variable in unpinned and unititialized memory+--+-- @since 0.1.0+rawPVar ::+ forall a m. (PrimMonad m, Prim a)+ => m (PVar m a)+rawPVar =+ primitive $ \s# ->+ case newByteArray# (sizeOf# (undefined :: a)) s# of+ (# s'#, mba# #) -> (# s'#, PVar mba# #)+{-# INLINE rawPVar #-}+++-- | Create a mutable variable in pinned memory with an initial value.+--+-- @since 0.1.0+newPinnedPVar :: (PrimMonad m, Prim a) => a -> m (PVar m a)+newPinnedPVar v = do+ pvar <- rawPinnedPVar+ writePVar pvar v+ return pvar+{-# INLINE newPinnedPVar #-}++-- | Create a mutable variable in pinned memory with uninitialized memory.+--+-- @since 0.1.0+rawPinnedPVar ::+ forall a m. (PrimMonad m, Prim a)+ => m (PVar m a)+rawPinnedPVar =+ primitive $ \s# ->+ case newPinnedByteArray# (sizeOf# (undefined :: a)) s# of+ (# s'#, mba# #) -> (# s'#, PVar mba# #)+{-# INLINE rawPinnedPVar #-}+++-- | Create a mutable variable in pinned memory with an initial value and aligned+-- according to its `Data.Primitive.Types.alignment`+--+-- @since 0.1.0+newAlignedPinnedPVar :: (PrimMonad m, Prim a) => a -> m (PVar m a)+newAlignedPinnedPVar v = do+ pvar <- rawAlignedPinnedPVar+ writePVar pvar v+ return pvar+{-# INLINE newAlignedPinnedPVar #-}+++-- | Create a mutable variable in pinned uninitialized memory.+--+-- @since 0.1.0+rawAlignedPinnedPVar ::+ forall a m. (PrimMonad m, Prim a)+ => m (PVar m a)+rawAlignedPinnedPVar =+ let dummy = undefined :: a+ in primitive $ \s# ->+ case newAlignedPinnedByteArray# (sizeOf# dummy) (alignment# dummy) s# of+ (# s'#, mba# #) -> (# s'#, PVar mba# #)+{-# INLINE rawAlignedPinnedPVar #-}++-- | Create a mutable variable in pinned uninitialized memory using Storable interface for+-- getting the number of bytes for memory allocation.+--+-- @since 0.1.0+rawStorablePVar ::+ forall a m. (PrimMonad m, S.Storable a)+ => m (PVar m a)+rawStorablePVar =+ let I# size# = S.sizeOf (undefined :: a)+ in primitive $ \s# ->+ case newPinnedByteArray# size# s# of+ (# s'#, mba# #) -> (# s'#, PVar mba# #)+{-# INLINE rawStorablePVar #-}++-- | Create a mutable variable in pinned uninitialized memory using Storable interface for+-- getting the number of bytes for memory allocation and alignement.+--+-- @since 0.1.0+rawAlignedStorablePVar ::+ forall a m. (PrimMonad m, S.Storable a)+ => 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# #)+{-# INLINE rawAlignedStorablePVar #-}+++-- | Get the address to the contents. This is highly unsafe, espcially if memory is not pinned+--+-- @since 0.1.0+unsafeToPtrPVar :: PVar m a -> Ptr a+unsafeToPtrPVar (PVar mba#) = Ptr (byteArrayContents# (unsafeCoerce# mba#))+{-# INLINE unsafeToPtrPVar #-}++-- helper that filles the PVar before running the action+runWithPokedPtr ::+ (S.Storable a, PrimMonad m)+ => PVar m a+ -> a+ -> (PVar m a -> Ptr a -> m b)+ -> m b+runWithPokedPtr pvar a f = do+ let ptr = unsafeToPtrPVar pvar+ pokePrim ptr a+ r <- f pvar ptr+ touch pvar+ return r+{-# INLINE runWithPokedPtr #-}+++-- | Use `S.Storable` reading functionality inside the `PrimMonad`.+--+-- @since 0.1.0+peekPrim :: (S.Storable a, PrimMonad m) => Ptr a -> m a+peekPrim = unsafePrimToPrim . S.peek+{-# INLINE peekPrim #-}++-- | Use `S.Storable` wrting functionality inside the `PrimMonad`.+--+-- @since 0.1.0+pokePrim :: (S.Storable a, PrimMonad m) => Ptr a -> a -> m ()+pokePrim ptr = unsafePrimToPrim . S.poke ptr+{-# INLINE pokePrim #-}++-- | Read a value from a mutable variable+--+-- @since 0.1.0+readPVar :: (PrimMonad m, Prim a) => PVar m a -> m a+readPVar (PVar mba#) = primitive (readByteArray# mba# 0#)+{-# INLINE readPVar #-}++-- | Write a value into a mutable variable+--+-- @since 0.1.0+writePVar :: (PrimMonad m, Prim a) => PVar m a -> a -> m ()+writePVar (PVar mba#) v = primitive_ (writeByteArray# mba# 0# v)+{-# INLINE writePVar #-}++-- | Get the size of the mutable variable in bytes as an unpacked integer+--+-- @since 0.1.0+sizeOfPVar# :: forall m a. Prim a => PVar m a -> Int#+sizeOfPVar# _ = sizeOf# (undefined :: a)+{-# INLINE sizeOfPVar# #-}++-- | Get the alignment of the mutable variable in bytes as an unpacked integer+--+-- @since 0.1.0+alignmentPVar# :: forall m a. Prim a => PVar m a -> Int#+alignmentPVar# _ = alignment# (undefined :: a)+{-# INLINE alignmentPVar# #-}+++-- | Size in bytes of a value stored inside the mutable variable. `PVar` itself is neither+-- accessed nor evaluated.+--+-- @since 0.1.0+sizeOfPVar :: Prim a => PVar m a -> Int+sizeOfPVar pvar = I# (sizeOfPVar# pvar)+{-# INLINE sizeOfPVar #-}++-- | Alignment in bytes of the value stored inside of the mutable variable. `PVar` itself is+-- neither accessed nor evaluated.+--+-- @since 0.1.0+alignmentPVar :: Prim a => PVar m a -> Int+alignmentPVar pvar = I# (alignmentPVar# pvar)+{-# INLINE alignmentPVar #-}+++unI# :: Int -> Int#+unI# (I# i#) = i#+{-# INLINE unI# #-}++++-- | Check if `PVar` is backed by pinned memory or not+--+-- @since 0.1.0+isPinnedPVar :: PVar m a -> Bool+isPinnedPVar (PVar mba#) = isTrue# (isMutableByteArrayPinned# mba#)+{-# INLINE isPinnedPVar #-}+++-- | Using `casIntArray#` perform atomic modification of an integer element in a+-- `MutableByteArray#`. Implies a full memory barrier.+--+-- @since 0.1.0+atomicModifyIntArray# ::+ MutableByteArray# d -- ^ Array to be mutated+ -> Int# -- ^ Index in number of `Int#` elements into the `MutableByteArray#`+ -> (Int# -> (# Int#, b #)) -- ^ Function to be applied atomically to the element+ -> State# d -- ^ Starting state+ -> (# State# d, b #)+atomicModifyIntArray# mba# i# f s0# =+ let go s# o# =+ case f o# of+ (# n#, artifact #) ->+ case casIntArray# mba# i# o# n# s# of+ (# s'#, o'# #) ->+ case o# ==# o'# of+ 0# -> go s# o'#+ _ -> seq# artifact s'#+ in case atomicReadIntArray# mba# i# s0# of+ (# s'#, o# #) -> go s'# o#+{-# INLINE atomicModifyIntArray# #-}++++-- | Apply a function to an integer element of a `PVar` atomically. Implies a full memory+-- barrier.+--+-- @since 0.1.0+atomicModifyIntPVar ::+ PrimMonad m => PVar m Int -> (Int -> (Int, a)) -> m a+atomicModifyIntPVar (PVar mba#) f = primitive (atomicModifyIntArray# mba# 0# g)+ where+ g i# =+ case f (I# i#) of+ (I# o#, a) -> (# o#, a #)+ {-# INLINE g #-}+{-# INLINE atomicModifyIntPVar #-}+++-- | Uses `casIntArray#` to perform atomic modification of an integer element in a+-- `MutableByteArray#`. Implies a full memory barrier.+--+-- @since 0.1.0+atomicModifyIntArray_# ::+ MutableByteArray# d -- ^ Array to be mutated+ -> Int# -- ^ Index in number of `Int#` elements into the `MutableByteArray#`+ -> (Int# -> Int#) -- ^ Function to be applied atomically to the element+ -> State# d -- ^ Starting state+ -> State# d+atomicModifyIntArray_# mba# i# f s0# =+ let go s# o# =+ case casIntArray# mba# i# o# (f o#) s# of+ (# s'#, o'# #) ->+ case o# ==# o'# of+ 0# -> go s# o'#+ _ -> s'#+ in case atomicReadIntArray# mba# i# s0# of+ (# s'#, o# #) -> go s'# o#+{-# INLINE atomicModifyIntArray_# #-}+++-- | Apply a function to an integer element of a `PVar` atomically. Returns the old+-- value. Implies a full memory barrier.+--+-- @since 0.1.0+atomicModifyIntPVar_ ::+ PrimMonad m => PVar m Int -> (Int -> Int) -> m ()+atomicModifyIntPVar_ (PVar mba#) f =+ primitive_ (atomicModifyIntArray_# mba# 0# (\i# -> unI# (f (I# i#))))+{-# INLINE atomicModifyIntPVar_ #-}
+ src/Data/Primitive/PVar/Unsafe.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module : Data.Primitive.PVar.Unsafe+-- Copyright : (c) Alexey Kuleshevich 2020+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Primitive.PVar.Unsafe+ ( PVar(..)+ -- * Creation+ , rawPVar+ , rawPinnedPVar+ , rawAlignedPinnedPVar+ , rawStorablePVar+ , rawAlignedStorablePVar+ -- * Access+ , peekPrim+ , pokePrim+ -- * Conversion+ , toPtrPVar+ , unsafeToPtrPVar+ , unsafeToForeignPtrPVar+ -- * Reset+ , zeroPVar+ -- * Unpacked opartions+ , sizeOfPVar#+ , alignmentPVar#+ , setPVar#+ -- * ByteArray+ -- ** Atomic operations+ , atomicModifyIntArray#+ , atomicModifyIntArray_#+ -- ** Memory copying+ , copyFromByteArrayPVar+ , copyFromMutableByteArrayPVar+ , copyPVarToMutableByteArray+ -- * Helpers+ , showsType+ , unI#+ )+ where++import Control.Monad.Primitive (PrimMonad(primitive), PrimState, touch, primitive_)+import Data.Primitive.PVar.Internal+import Data.Primitive.ByteArray+import Data.Primitive.Types+import qualified Foreign.Storable as S+import GHC.Exts as Exts+import GHC.ForeignPtr+import Data.Typeable+++-- | Convert `PVar` into a `ForeignPtr`, very unsafe if not backed by pinned memory.+--+-- @since 0.1.0+unsafeToForeignPtrPVar :: PVar IO a -> ForeignPtr a+unsafeToForeignPtrPVar pvar@(PVar mba#) =+ case unsafeToPtrPVar pvar of+ Ptr addr# -> ForeignPtr addr# (PlainPtr mba#)+{-# INLINE unsafeToForeignPtrPVar #-}++++-- | Extract the address to the mutable variable, but only if it is backed by pinned+-- memory. It is unsafe because even for pinned memory memory can be deallocated if+-- associated `PVar` goes out of scope. Use `Data.Primitive.PVar.withPtrPVar` or+-- `Data.Primitive.PVar.toForeignPtr` instead.+--+-- @since 0.1.0+toPtrPVar :: PVar m a -> Maybe (Ptr a)+toPtrPVar pvar@(PVar mba#)+ | isPinnedPVar pvar = Just $ unsafeToPtrPVar pvar+ | otherwise = Nothing+{-# INLINE toPtrPVar #-}++-- | Fill the contents of mutable variable with byte @c@+--+-- @since 0.1.0+setPVar# ::+ (PrimMonad m, Prim a)+ => PVar m a+ -> Int# -- ^ Byte value to fill the `PVar` with+ -> m ()+setPVar# pvar@(PVar mba#) a# =+ primitive_ (Exts.setByteArray# mba# 0# (sizeOfPVar# pvar) a#)+{-# INLINE setPVar# #-}++-- | Reset contents of a mutable variable to zero.+--+-- @since 0.1.0+zeroPVar :: (PrimMonad m, Prim a) => PVar m a -> m ()+zeroPVar pvar = setPVar# pvar 0#+{-# INLINE zeroPVar #-}++-- | Copy the value from a mutable variable into a mutable array at the specified index. Index+-- of array is not checked and can result in an unchecked exception when incorrect+--+-- @since 0.1.0+copyPVarToMutableByteArray ::+ (PrimMonad m, Prim a)+ => PVar m a+ -> MutableByteArray (PrimState m)+ -> Int -- ^ Offset in number of elements into the array+ -> m ()+copyPVarToMutableByteArray pvar mba offset =+ copyBytesPVarToMutableByteArray pvar mba (offset * sizeOfPVar pvar)+{-# INLINE copyPVarToMutableByteArray #-}+++-- | Copy the value from a frozen `ByteArray` into a mutable variable at specified+-- index. Index of array is not checked and can result in an unchecked exception when+-- incorrect+--+-- @since 0.1.0+copyFromByteArrayPVar ::+ (PrimMonad m, Prim a)+ => ByteArray -- ^ Source array+ -> Int -- ^ Offset in number of elements into the array+ -> PVar m a+ -> m ()+copyFromByteArrayPVar ba offset pvar =+ copyBytesFromByteArrayPVar ba (offset * sizeOfPVar pvar) pvar+{-# INLINE copyFromByteArrayPVar #-}++-- | Copy the value from MutableByteArray at specified index into the mutable+-- variable. Index of array is not checked and can result in an unchecked exception when+-- incorrect+--+-- @since 0.1.0+copyFromMutableByteArrayPVar ::+ (PrimMonad m, Prim a)+ => MutableByteArray (PrimState m)+ -> Int -- ^ Offset in number of elements into the array+ -> PVar m a+ -> m ()+copyFromMutableByteArrayPVar mba offset pvar =+ copyBytesFromMutableByteArrayPVar mba (offset * sizeOfPVar pvar) pvar+{-# INLINE copyFromMutableByteArrayPVar #-}+++-- | Copy the value from a mutable variable into a `MutableByteArray` at the specified+-- offset in number of bytes. Offset into the array is not checked and can result in an+-- unchecked exception when incorrect+--+-- @since 0.1.0+copyBytesPVarToMutableByteArray ::+ (PrimMonad m, Prim a)+ => PVar m a+ -> MutableByteArray (PrimState m)+ -> Int -- ^ Offset in bytes into the array+ -> m ()+copyBytesPVarToMutableByteArray pvar@(PVar mbas#) (MutableByteArray mbad#) (I# offset#) =+ primitive_ (copyMutableByteArray# mbas# 0# mbad# offset# (sizeOfPVar# pvar))+{-# INLINE copyBytesPVarToMutableByteArray #-}+++-- | Copy the value from a frozen `ByteArray` at the specified offset in number of bytes+-- into a mutable variable. Offset into the array is not checked and can result in an+-- unchecked exception when incorrect+--+-- @since 0.1.0+copyBytesFromByteArrayPVar ::+ (PrimMonad m, Prim a)+ => ByteArray -- ^ Source array+ -> Int -- ^ Offset in bytes into the array+ -> PVar m a+ -> m ()+copyBytesFromByteArrayPVar (ByteArray ba#) (I# offset#) pvar@(PVar mba#) =+ primitive_ (copyByteArray# ba# offset# mba# 0# (sizeOfPVar# pvar))+{-# INLINE copyBytesFromByteArrayPVar #-}++-- | Copy the value from a `MutableByteArray` at an offset in bytes into the mutable+-- variable. Offset into the array is not checked and can result in an unchecked exception+-- when incorrect+--+-- @since 0.1.0+copyBytesFromMutableByteArrayPVar ::+ (PrimMonad m, Prim a)+ => MutableByteArray (PrimState m)+ -> Int -- ^ Offset in bytes into the array+ -> PVar m a+ -> m ()+copyBytesFromMutableByteArrayPVar (MutableByteArray mbas#) (I# offset#) pvar@(PVar mbad#) =+ primitive_ (copyMutableByteArray# mbas# offset# mbad# 0# (sizeOfPVar# pvar))+{-# INLINE copyBytesFromMutableByteArrayPVar #-}+++-- | Show the type name+showsType :: Typeable t => proxy t -> ShowS+showsType = showsTypeRep . typeRep
+ tests/Main.hs view
@@ -0,0 +1,11 @@+module Main where++import Spec+import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8)+import Test.Hspec++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hSetEncoding stdout utf8+ hspec spec
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
+ tests/Test/Primitive/PVarSpec.hs view
@@ -0,0 +1,422 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Primitive.PVarSpec (spec) where++import Control.Monad+import Control.Concurrent.Async+import Control.DeepSeq+import Data.GenValidity+import Data.Int+import Data.Bits+import Data.List (partition)+import Data.Foldable as F+import Data.Maybe+import Data.WideWord+import Data.Primitive.ByteArray+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+import Foreign.Marshal.Alloc+import qualified Foreign.Storable as Storable+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Monadic++forAllIO :: (Show p, Testable t) => Gen p -> (p -> IO t) -> Property+forAllIO g propM = forAll g $ \v -> monadicIO $ run $ propM v++forAllST :: (Show p, Testable t) => Gen p -> (forall s. p -> ST s t) -> Property+forAllST g propM = forAll g $ \v -> monadicST $ run $ propM v+++forAllPVarST ::+ (Show p, Prim p, Testable t)+ => Gen p+ -> (forall s. p -> PVar (ST s) p -> ST s t)+ -> Property+forAllPVarST g propM = forAllST g $ \v -> newPVar v >>= propM v++forAllPVarIO ::+ (Show p, Prim p, Testable t)+ => Gen p+ -> (p -> PVar IO p -> IO t)+ -> Property+forAllPVarIO g propM = forAllIO g $ \v -> newPVar v >>= propM v++propPVarST ::+ (Show p, Prim p, Testable t)+ => String+ -> Gen p+ -> (forall s. p -> PVar (ST s) p -> ST s t)+ -> Spec+propPVarST name gen action = prop name $ forAllPVarST gen action++propPVarIO ::+ (Show p, Prim p, Testable t)+ => String+ -> Gen p+ -> (p -> PVar IO p -> IO t)+ -> Spec+propPVarIO name gen action = prop name $ forAllPVarIO gen action++-- | Generator for a non empty byte array that holds at least one element of type+-- @a@. Also contains a valid index in number of elements into the array+data ByteArrayNonEmpty a =+ ByteArrayNonEmpty Int ByteArray+ deriving (Show, Eq)++instance (Arbitrary a, Prim a) => Arbitrary (ByteArrayNonEmpty a) where+ arbitrary = genByteArrayNonEmpty (arbitrary :: Gen a)++genByteArrayNonEmpty gen = do+ Positive n <- arbitrary+ xs <- vectorOf n gen+ NonNegative i <- arbitrary+ pure $+ ByteArrayNonEmpty (i `mod` n) $+ runST $ do+ mba <- newByteArray (n * sizeOf (head xs))+ zipWithM_ (writeByteArray mba) [0 ..] xs+ unsafeFreezeByteArray mba++specPrim ::+ (Show p, Eq p, Prim p, Typeable p, Arbitrary p, CoArbitrary p, Function p)+ => p -- ^ Zero value+ -> Gen p+ -> (Gen p -> Spec)+ -> Spec+specPrim defZero gen extraSpec =+ describe ("PVar s " ++ showsType gen "") $ do+ propPVarIO "readPVar" gen $ \v pvar -- deepseq is used for coverage only+ -> pvar `deepseq` readPVar pvar `shouldReturn` v+ propPVarIO "writePVar/readPVar" gen $ \_ pvar ->+ return $+ forAll gen $ \v -> do+ writePVar pvar v+ readPVar pvar `shouldReturn` v+ prop "withPVarST" $+ forAll gen $ \a ->+ forAll gen $ \b ->+ withPVarST a $ \var -> do+ a' <- readPVar var+ writePVar var b+ b' <- readPVar var+ pure (a === a' .&&. b === b')+ propPVarIO "newPinnedPVar" gen $ \a var -> do+ pinnedVar <- newPinnedPVar a+ (===) <$> readPVar var <*> readPVar pinnedVar+ propPVarIO "newAlignedPinnedPVar" gen $ \a var -> do+ pinnedVar <- newAlignedPinnedPVar a+ (===) <$> readPVar var <*> readPVar pinnedVar+ propPVarIO "modifyPVar" gen $ \a pvar ->+ return $+ forAll arbitrary $ \f -> do+ modifyPVar pvar (applyFun f) `shouldReturn` a+ readPVar pvar `shouldReturn` applyFun f a+ propPVarIO "modifyPVar_" gen $ \a pvar ->+ return $+ forAll arbitrary $ \f -> do+ modifyPVar_ pvar (applyFun f)+ readPVar pvar `shouldReturn` applyFun f a+ propPVarIO "modifyPVarM" gen $ \a pvar ->+ return $+ forAllIO arbitrary $ \f -> do+ a' <-+ modifyPVarM pvar $ \a' -> do+ a' `shouldBe` a+ pure $ applyFun f a'+ a' `shouldBe` a+ readPVar pvar `shouldReturn` applyFun 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+ propPVarIO "swapPVars" gen $ \a avar ->+ return $+ forAllPVarIO gen $ \b bvar -> do+ swapPVars avar bvar `shouldReturn` (a, b)+ readPVar avar `shouldReturn` b+ readPVar bvar `shouldReturn` a+ propPVarIO "swapPVars_" gen $ \a avar ->+ return $+ forAllPVarIO gen $ \b bvar -> do+ swapPVars_ avar bvar+ readPVar avar `shouldReturn` b+ readPVar bvar `shouldReturn` a+ propPVarIO "copyPVar" gen $ \a avar ->+ return $+ forAllPVarIO gen $ \_ bvar -> do+ copyPVar avar bvar+ readPVar bvar `shouldReturn` a+ propPVarST "sizeOfPVar" gen $ \a avar -> pure (sizeOfPVar avar === sizeOf a)+ propPVarST "alignmentPVar" gen $ \a avar ->+ pure (alignmentPVar avar === alignment a)+ describe "Unsafe" $ do+ propPVarIO "copyPVarToMutableByteArray" gen $ \a var ->+ return $+ forAll (genByteArrayNonEmpty gen) $ \(ByteArrayNonEmpty i ba) ->+ monadicIO $+ run $ do+ mba <- unsafeThawByteArray ba+ copyPVarToMutableByteArray var mba i+ readByteArray mba i `shouldReturn` a+ (===) <$> readByteArray mba i <*> readPVar var+ propPVarIO "copyFromByteArrayPVar" gen $ \_ var ->+ return $+ forAll (genByteArrayNonEmpty gen) $ \(ByteArrayNonEmpty i ba) ->+ monadicIO $+ run $ 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+ mba <- unsafeThawByteArray ba+ copyFromMutableByteArrayPVar mba i var+ readPVar var `shouldReturn` indexByteArray ba i+ propPVarST "sizeOf" gen $ \a var -> pure (toPtrPVar var === Nothing)+ describe "Reset Memory" $+ propPVarIO "zeroPVar" gen $ \_ var -> do+ zeroPVar var+ readPVar var `shouldReturn` defZero+ extraSpec gen++specStorable ::+ (Show p, Eq p, Prim p, Storable p, Arbitrary p, CoArbitrary p, Function p)+ => Gen p+ -> Spec+specStorable gen =+ describe "Storable" $ do+ propPVarIO "withPVarPtr (newPVar)" gen $ \a 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+ 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 ->+ toForeignPtrPVar var `shouldBe` Nothing+ prop "toForeignPtr (newPinnedPVar)" $+ forAllIO gen $ \a -> do+ var <- newPinnedPVar a+ fPtr <-+ maybe (error "Expected to get a Just ForeignPtr") pure $+ toForeignPtrPVar var+ withForeignPtr fPtr $ \ptr -> peek ptr `shouldReturn` a+ prop "toForeignPtr (newAlignedPinnedPVar)" $+ forAllIO gen $ \a -> do+ var <- newAlignedPinnedPVar a+ fPtr <-+ maybe (error "Expected to get a Just ForeignPtr") pure $+ toForeignPtrPVar var+ withForeignPtr fPtr $ \ptr -> peek ptr `shouldReturn` a+ propPVarIO "poke/peek/ (Ptr PVar)" gen $ \a var ->+ alloca $ \ptr -> do+ Storable.poke ptr var+ var' <- Storable.peek ptr+ readPVar var' `shouldReturn` a+ Storable.sizeOf var `shouldBe` sizeOfPVar var+ Storable.alignment var `shouldBe` alignmentPVar var+ propPVarIO "copyPVarToPtr" gen $ \a var ->+ alloca $ \ptr -> do+ copyPVarToPtr var ptr+ peek ptr `shouldReturn` a+ prop "withStorablePVarPtr" $+ forAllIO gen $ \a ->+ return $+ forAllIO gen $ \b ->+ withStorablePVar a $ \pvar ptr -> do+ sizeOfPVar pvar `shouldBe` Storable.sizeOf a+ a' <- peekPrim ptr+ a' `shouldBe` a+ pokePrim ptr b+ b' <- readPVar pvar+ b' `shouldBe` b+ prop "withAlignedStorablePVarPtr" $+ forAllIO gen $ \a ->+ return $+ forAllIO gen $ \b ->+ withAlignedStorablePVar a $ \pvar ptr -> do+ alignmentPVar pvar `shouldBe` Storable.alignment a+ a' <- peekPrim ptr+ a' `shouldBe` a+ pokePrim ptr b+ b' <- readPVar pvar+ b' `shouldBe` b+++specAtomic :: Spec+specAtomic = do+ let gen = genValid :: Gen Int+ describe "Atomic (basic)" $ do+ describe "Basic" $ do+ propPVarIO "atomicAddIntPVar" gen $ \x var ->+ return $+ forAllIO gen $ \y -> do+ x' <- atomicAddIntPVar var y+ x' `shouldBe` x+ atomicReadIntPVar var `shouldReturn` (x + y)+ propPVarIO "atomicSubIntPVar" gen $ \x var ->+ return $+ forAllIO gen $ \y -> do+ x' <- atomicSubIntPVar var y+ x' `shouldBe` x+ atomicReadIntPVar var `shouldReturn` (x - y)+ propPVarIO "atomicAndIntPVar" gen $ \x var ->+ return $+ forAllIO gen $ \y -> do+ x' <- atomicAndIntPVar var y+ x' `shouldBe` x+ atomicReadIntPVar var `shouldReturn` (x .&. y)+ propPVarIO "atomicNandIntPVar" gen $ \x var ->+ return $+ forAllIO gen $ \y -> do+ x' <- atomicNandIntPVar var y+ x' `shouldBe` x+ atomicReadIntPVar var `shouldReturn` complement (x .&. y)+ propPVarIO "atomicOrIntPVar" gen $ \x var ->+ return $+ forAllIO gen $ \y -> do+ x' <- atomicOrIntPVar var y+ x' `shouldBe` x+ atomicReadIntPVar var `shouldReturn` (x .|. y)+ propPVarIO "atomicXorIntPVar" gen $ \x var ->+ return $+ forAllIO gen $ \y -> do+ x' <- atomicXorIntPVar var y+ x' `shouldBe` x+ atomicReadIntPVar var `shouldReturn` (x `xor` y)+ propPVarIO "atomicNotIntPVar" gen $ \x var -> do+ x' <- atomicNotIntPVar var+ x' `shouldBe` x+ atomicReadIntPVar var `shouldReturn` complement x+ describe "Concurrent" $ do+ propPVarIO "atomicAndIntPVar" gen $ \x var ->+ return $+ forAllIO (genListOf gen) $ \xs -> do+ xs' <- mapConcurrently (atomicAndIntPVar var) xs+ x' <- atomicReadIntPVar var+ F.foldl' (.&.) x' xs' `shouldBe` F.foldl' (.&.) x xs+ propPVarIO "atomicOrIntPVar" gen $ \x var ->+ return $+ forAllIO (genListOf gen) $ \xs -> do+ xs' <- mapConcurrently (atomicOrIntPVar var) xs+ x' <- atomicReadIntPVar var+ F.foldl' (.|.) x' xs' `shouldBe` F.foldl' (.|.) x xs+ describe "CAS-Concurrent" $ do+ propPVarIO "casIntPVar" gen $ \x var ->+ return $+ forAllIO ((,) <$> gen <*> gen) $ \(y, z) -> do+ x' <- casIntPVar var x y+ x' `shouldBe` x+ y' <- atomicReadIntPVar var+ atomicWriteIntPVar var z+ y' `shouldBe` y+ z' <- atomicReadIntPVar var+ z' `shouldBe` z+ casProp_ gen "atomicAddIntPVar" (+) atomicAddIntPVar+ casProp_ gen "atomicSubIntPVar" subtract atomicSubIntPVar+ casProp gen "atomicAndIntPVar" (.&.) atomicAndIntPVar+ casProp gen "atomicOrIntPVar" (.|.) atomicOrIntPVar+ casProp_ gen "atomicXorIntPVar" xor atomicXorIntPVar+ propPVarIO "atomicNotIntPVar" gen $ \x xvar ->+ return $+ forAllIO arbitrary $ \(Positive n) -> do+ xs' <- replicateConcurrently n (atomicNotIntPVar xvar)+ x' <- atomicReadIntPVar xvar+ yvar <- newPVar x+ ys' <-+ replicateConcurrently+ n+ (atomicModifyIntPVar yvar (\y -> (complement y, y)))+ y' <- atomicReadIntPVar yvar+ x' `shouldBe` y'+ -- binary negation of N times results in two values, both of which happen N/2+ -- times+ let sxs@(l, r) = partition (== x) (x' : xs')+ lenr = length r+ sys = partition (== x) (y' : ys')+ sxs `shouldBe` sys+ length l `shouldSatisfy` (\len -> len == lenr || len == lenr + 1)+ where+ casProp_ gen name f af =+ propPVarIO name gen $ \x xvar ->+ return $+ forAllIO (genListOf gen) $ \xs -> do+ mapConcurrently_ (af xvar) xs+ x' <- atomicReadIntPVar xvar+ yvar <- newPVar x+ mapConcurrently_ (\y' -> atomicModifyIntPVar_ yvar (f y')) xs+ -- mapConcurrently_ (atomicModifyIntPVar_ yvar . f) xs+ y' <- atomicReadIntPVar yvar+ x' `shouldBe` y'+ casProp gen name f af =+ propPVarIO name gen $ \x xvar ->+ return $+ forAllIO (genListOf gen) $ \xs -> do+ xs' <- mapConcurrently (af xvar) xs+ x' <- atomicReadIntPVar xvar+ yvar <- newPVar x+ ys' <-+ mapConcurrently+ (\y' -> atomicModifyIntPVar yvar (\y -> (f y y', y)))+ xs+ 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++spec :: Spec+spec = do+ specPrim 0 (genValid :: Gen Int) (\gen -> specStorable gen >> specAtomic)+ specPrim 0 (genValid :: Gen Int8) specStorable+ specPrim 0 (genValid :: Gen Int16) specStorable+ specPrim 0 (genValid :: Gen Int32) specStorable+ specPrim 0 (genValid :: Gen Int64) specStorable+ specPrim 0 (genValid :: Gen Word) specStorable+ specPrim 0 (genValid :: Gen Word8) specStorable+ specPrim 0 (genValid :: Gen Word16) specStorable+ specPrim 0 (genValid :: Gen Word32) specStorable+ specPrim 0 (genValid :: Gen Word64) specStorable+ 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