primitive 0.7.2.0 → 0.7.3.0
raw patch · 25 files changed
+951/−947 lines, 25 filesdep +tasty-benchdep ~basedep ~deepseqdep ~transformerssetup-changed
Dependencies added: tasty-bench
Dependency ranges changed: base, deepseq, transformers
Files
- Control/Monad/Primitive.hs +9/−23
- Data/Primitive.hs +28/−26
- Data/Primitive/Array.hs +113/−178
- Data/Primitive/ByteArray.hs +84/−118
- Data/Primitive/Internal/Compat.hs +0/−25
- Data/Primitive/Internal/Operations.hs +1/−4
- Data/Primitive/MVar.hs +44/−50
- Data/Primitive/MachDeps.hs +2/−3
- Data/Primitive/MutVar.hs +32/−13
- Data/Primitive/PrimArray.hs +81/−107
- Data/Primitive/Ptr.hs +5/−15
- Data/Primitive/SmallArray.hs +85/−226
- Data/Primitive/Types.hs +64/−90
- Setup.hs +0/−3
- bench/Array/Traverse/Closure.hs +49/−0
- bench/Array/Traverse/Unsafe.hs +48/−0
- bench/ByteArray/Compare.hs +96/−0
- bench/PrimArray/Compare.hs +58/−0
- bench/PrimArray/Traverse.hs +23/−0
- bench/main.hs +69/−0
- cbits/primitive-memops.h +13/−14
- changelog.md +13/−1
- primitive.cabal +27/−14
- test/main.hs +7/−31
- test/src/PrimLaws.hs +0/−6
Control/Monad/Primitive.hs view
@@ -12,8 +12,7 @@ -- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> -- Portability : non-portable ----- Primitive state-transformer monads---+-- Primitive state-transformer monads. module Control.Monad.Primitive ( PrimMonad(..), RealWorld, primitive_,@@ -34,9 +33,6 @@ import qualified Control.Monad.ST.Lazy as L import Control.Monad.Trans.Class (lift)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid)-#endif import Control.Monad.Trans.Cont ( ContT ) import Control.Monad.Trans.Identity ( IdentityT (IdentityT) )@@ -51,9 +47,7 @@ import Control.Monad.Trans.Error ( ErrorT, Error) #endif -#if MIN_VERSION_transformers(0,4,0) import Control.Monad.Trans.Except ( ExceptT )-#endif #if MIN_VERSION_transformers(0,5,3) import Control.Monad.Trans.Accum ( AccumT )@@ -69,12 +63,12 @@ import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) --- | Class of monads which can perform primitive state-transformer actions+-- | Class of monads which can perform primitive state-transformer actions. class Monad m => PrimMonad m where- -- | State token type+ -- | State token type. type PrimState m - -- | Execute a primitive operation+ -- | Execute a primitive operation. primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a -- | Class of primitive monads for state-transformer actions.@@ -85,10 +79,10 @@ -- -- @since 0.6.0.0 class PrimMonad m => PrimBase m where- -- | Expose the internal structure of the monad+ -- | Expose the internal structure of the monad. internal :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #) --- | Execute a primitive operation with no result+-- | Execute a primitive operation with no result. primitive_ :: PrimMonad m => (State# (PrimState m) -> State# (PrimState m)) -> m () {-# INLINE primitive_ #-}@@ -100,6 +94,7 @@ type PrimState IO = RealWorld primitive = IO {-# INLINE primitive #-}+ instance PrimBase IO where internal (IO p) = p {-# INLINE internal #-}@@ -171,24 +166,20 @@ {-# INLINE primitive #-} #endif -#if MIN_VERSION_transformers(0,4,0) instance PrimMonad m => PrimMonad (ExceptT e m) where type PrimState (ExceptT e m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-}-#endif #if MIN_VERSION_transformers(0,5,3) -- | @since 0.6.3.0 instance ( Monoid w , PrimMonad m-# if !(MIN_VERSION_base(4,8,0))- , Functor m-# endif ) => PrimMonad (AccumT w m) where type PrimState (AccumT w m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-}+ instance PrimMonad m => PrimMonad (SelectT r m) where type PrimState (SelectT r m) = PrimState m primitive = lift . primitive@@ -214,6 +205,7 @@ type PrimState (ST s) = s primitive = ST {-# INLINE primitive #-}+ instance PrimBase (ST s) where internal (ST p) = p {-# INLINE internal #-}@@ -347,13 +339,7 @@ -- -- @since 0.6.2.0 evalPrim :: forall a m . PrimMonad m => a -> m a-#if MIN_VERSION_base(4,4,0) evalPrim a = primitive (\s -> seq# a s)-#else--- This may or may not work so well, but there's probably nothing better to do.-{-# NOINLINE evalPrim #-}-evalPrim a = unsafePrimToPrim (evaluate a :: IO a)-#endif noDuplicate :: PrimMonad m => m () #if __GLASGOW_HASKELL__ >= 802
Data/Primitive.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-}+ -- | -- Module : Data.Primitive -- Copyright : (c) Roman Leshchinskiy 2009-2012@@ -8,19 +9,19 @@ -- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> -- Portability : non-portable ----- Reexports all primitive operations----module Data.Primitive (- -- * Re-exports- module Data.Primitive.Types- ,module Data.Primitive.Array- ,module Data.Primitive.ByteArray- ,module Data.Primitive.SmallArray- ,module Data.Primitive.PrimArray- ,module Data.Primitive.MutVar+-- Reexports all primitive operations.++module Data.Primitive+ ( -- * Re-exports+ module Data.Primitive.Types+ , module Data.Primitive.Array+ , module Data.Primitive.ByteArray+ , module Data.Primitive.SmallArray+ , module Data.Primitive.PrimArray+ , module Data.Primitive.MutVar -- * Naming Conventions -- $namingConventions-) where+ ) where import Data.Primitive.Types import Data.Primitive.Array@@ -39,21 +40,22 @@ > indexPrimArray :: Prim a => PrimArray a -> Int -> a In a few places, where the language sounds more natural, the array type-is instead used as a prefix. For example, @Data.Primitive.SmallArray@-exports @smallArrayFromList@, which would sound unnatural if it used+is instead used as a prefix. For example, "Data.Primitive.SmallArray"+exports 'smallArrayFromList', which would sound unnatural if it used @SmallArray@ as a suffix instead. -This library provides several functions traversing, building, and filtering+This library provides several functions for traversing, building, and filtering arrays. These functions are suffixed with an additional character to-indicate their the nature of their effectfulness:+indicate the nature of their effectfulness: * No suffix: A non-effectful pass over the array.-* @-A@ suffix: An effectful pass over the array, where the effect is 'Applicative'.-* @-P@ suffix: An effectful pass over the array, where the effect is 'PrimMonad'.+* @A@ suffix: An effectful pass over the array, where the effect is 'Applicative'.+* @P@ suffix: An effectful pass over the array, where the effect is 'Control.Monad.Primitive.PrimMonad'. Additionally, an apostrophe can be used to indicate strictness in the elements.-The variants with an apostrophe are used in @Data.Primitive.Array@ but not-in @Data.Primitive.PrimArray@ since the array type it provides is always strict in the element.+The variants with an apostrophe are used in "Data.Primitive.Array" but not+in "Data.Primitive.PrimArray" since the array type it provides is always strict in the element anyway.+ For example, there are three variants of the function that filters elements from a primitive array. @@ -61,17 +63,17 @@ > filterPrimArrayA :: (Prim a, Applicative f) => (a -> f Bool) -> PrimArray a -> f (PrimArray a) > filterPrimArrayP :: (Prim a, PrimMonad m) => (a -> m Bool) -> PrimArray a -> m (PrimArray a) -As long as the effectful context is a monad that is sufficiently affine-the behaviors of the 'Applicative' and 'PrimMonad' variants produce the same results-and differ only in their strictness. Monads that are sufficiently affine-include:+As long as the effectful context is a monad that is sufficiently affine,+the behaviors of the 'Applicative' and 'Control.Monad.Primitive.PrimMonad'+variants produce the same results and differ only in their strictness.+Monads that are sufficiently affine include: * 'IO' and 'ST' * Any combination of 'MaybeT', 'ExceptT', 'StateT' and 'Writer' on top of another sufficiently affine monad.-* Any Monad which does not include backtracking or other mechanism where an effect can-happen more than once is an Affine Monad in the sense we care about. ContT, LogicT, ListT are all-examples of search/control monads which are NOT affine: they can run a sub computation more than once.+* Any Monad which does not include backtracking or other mechanisms where an effect can+ happen more than once is an affine Monad in the sense we care about. @ContT@, @LogicT@, @ListT@ are all+ examples of search/control monads which are NOT affine: they can run a sub computation more than once. There is one situation where the names deviate from effectful suffix convention described above. Throughout the haskell ecosystem, the 'Applicative' variant of
Data/Primitive/Array.hs view
@@ -11,17 +11,17 @@ -- Portability : non-portable -- -- Primitive arrays of boxed values.--- module Data.Primitive.Array ( Array(..), MutableArray(..), newArray, readArray, writeArray, indexArray, indexArrayM, indexArray##,- freezeArray, thawArray, runArray,+ freezeArray, thawArray, runArray, createArray, unsafeFreezeArray, unsafeThawArray, sameMutableArray, copyArray, copyMutableArray, cloneArray, cloneMutableArray, sizeofArray, sizeofMutableArray,+ emptyArray, fromListN, fromList, arrayFromListN, arrayFromList, mapArray',@@ -30,46 +30,29 @@ import Control.DeepSeq import Control.Monad.Primitive-import Data.Data (mkNoRepType) -import GHC.Base ( Int(..) )-import GHC.Exts-#if (MIN_VERSION_base(4,7,0))- hiding (toList)-#endif+import GHC.Exts hiding (toList) import qualified GHC.Exts as Exts-#if (MIN_VERSION_base(4,7,0))-import GHC.Exts (fromListN, fromList)-#endif import Data.Typeable ( Typeable ) import Data.Data- (Data(..), DataType, mkDataType, Constr, mkConstr, Fixity(..), constrIndex)-import Data.Primitive.Internal.Compat ( isTrue# )+ (Data(..), DataType, mkDataType, mkNoRepType, Constr, mkConstr, Fixity(..), constrIndex) -import Control.Monad.ST(ST,runST)+import Control.Monad.ST (ST, runST) import Control.Applicative-import Control.Monad (MonadPlus(..), when)+import Control.Monad (MonadPlus(..), when, liftM2) import qualified Control.Monad.Fail as Fail import Control.Monad.Fix import qualified Data.Foldable as Foldable-#if MIN_VERSION_base(4,4,0) import Control.Monad.Zip-#endif import Data.Foldable (Foldable(..), toList)-#if !(MIN_VERSION_base(4,8,0))-import Data.Traversable (Traversable(..))-import Data.Monoid-#endif #if MIN_VERSION_base(4,9,0) import qualified GHC.ST as GHCST import qualified Data.Foldable as F import Data.Semigroup #endif-#if MIN_VERSION_base(4,8,0) import Data.Functor.Identity-#endif #if MIN_VERSION_base(4,10,0) import GHC.Exts (runRW#) #elif MIN_VERSION_base(4,9,0)@@ -81,12 +64,9 @@ import qualified Text.ParserCombinators.ReadPrec as RdPrc import Text.ParserCombinators.ReadP -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)-import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..))-#endif-import Control.Monad (liftM2)+import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..), Read1(..)) --- | Boxed arrays+-- | Boxed arrays. data Array a = Array { array# :: Array# a } deriving ( Typeable )@@ -104,10 +84,12 @@ { marray# :: MutableArray# s a } deriving ( Typeable ) +-- | The number of elements in an immutable array. sizeofArray :: Array a -> Int sizeofArray a = I# (sizeofArray# (array# a)) {-# INLINE sizeofArray #-} +-- | The number of elements in a mutable array. sizeofMutableArray :: MutableArray s a -> Int sizeofMutableArray a = I# (sizeofMutableArray# (marray# a)) {-# INLINE sizeofMutableArray #-}@@ -163,7 +145,7 @@ -- > writeArray marr i (indexArray arr i) ... -- > ... ----- But since primitive arrays are lazy, the calls to 'indexArray' will not be+-- But since the arrays are lazy, the calls to 'indexArray' will not be -- evaluated. Rather, @marr@ will be filled with thunks each of which would -- retain a reference to @arr@. This is definitely not what we want! --@@ -187,6 +169,9 @@ -- -- This operation makes a copy of the specified section, so it is safe to -- continue using the mutable array afterward.+--+-- /Note:/ The provided array should contain the full subrange+-- specified by the two Ints, but this is not checked. freezeArray :: PrimMonad m => MutableArray (PrimState m) a -- ^ source@@ -212,6 +197,9 @@ -- -- This operation makes a copy of the specified slice, so it is safe to use the -- immutable array afterward.+--+-- /Note:/ The provided array should contain the full subrange+-- specified by the two Ints, but this is not checked. thawArray :: PrimMonad m => Array a -- ^ source@@ -250,26 +238,10 @@ -> Int -- ^ number of elements to copy -> m () {-# INLINE copyArray #-}-#if __GLASGOW_HASKELL__ > 706--- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier copyArray (MutableArray dst#) (I# doff#) (Array src#) (I# soff#) (I# len#) = primitive_ (copyArray# src# soff# dst# doff# len#)-#else-copyArray !dst !doff !src !soff !len = go 0- where- go i | i < len = do- x <- indexArrayM src (soff+i)- writeArray dst (doff+i) x- go (i+1)- | otherwise = return ()-#endif --- | Copy a slice of a mutable array to another array. The two arrays must--- not be the same when using this library with GHC versions 7.6 and older.--- In GHC 7.8 and newer, overlapping arrays will behave correctly.------ /Note:/ The order of arguments is different from that of 'copyMutableArray#'. The primop--- has the source first while this wrapper has the destination first.+-- | Copy a slice of a mutable array to another array. The two arrays may overlap. -- -- /Note:/ this function does not do bounds or overlap checking. copyMutableArray :: PrimMonad m@@ -280,25 +252,14 @@ -> Int -- ^ number of elements to copy -> m () {-# INLINE copyMutableArray #-}-#if __GLASGOW_HASKELL__ > 706--- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier copyMutableArray (MutableArray dst#) (I# doff#) (MutableArray src#) (I# soff#) (I# len#) = primitive_ (copyMutableArray# src# soff# dst# doff# len#)-#else-copyMutableArray !dst !doff !src !soff !len = go 0- where- go i | i < len = do- x <- readArray src (soff+i)- writeArray dst (doff+i) x- go (i+1)- | otherwise = return ()-#endif --- | Return a newly allocated Array with the specified subrange of the--- provided Array.+-- | Return a newly allocated 'Array' with the specified subrange of the+-- provided 'Array'. ----- /Note:/ The provided Array should contain the full subrange+-- /Note:/ The provided array should contain the full subrange -- specified by the two Ints, but this is not checked. cloneArray :: Array a -- ^ source array -> Int -- ^ offset into destination array@@ -308,11 +269,11 @@ cloneArray (Array arr#) (I# off#) (I# len#) = case cloneArray# arr# off# len# of arr'# -> Array arr'# --- | Return a newly allocated MutableArray. with the specified subrange of--- the provided MutableArray. The provided MutableArray should contain the+-- | Return a newly allocated 'MutableArray'. with the specified subrange of+-- the provided 'MutableArray'. The provided 'MutableArray' should contain the -- full subrange specified by the two Ints, but this is not checked. ----- /Note:/ The provided Array should contain the full subrange+-- /Note:/ The provided array should contain the full subrange -- specified by the two Ints, but this is not checked. cloneMutableArray :: PrimMonad m => MutableArray (PrimState m) a -- ^ source array@@ -324,53 +285,21 @@ (\s# -> case cloneMutableArray# arr# off# len# s# of (# s'#, arr'# #) -> (# s'#, MutableArray arr'# #)) +-- | The empty 'Array'. emptyArray :: Array a emptyArray = runST $ newArray 0 (die "emptyArray" "impossible") >>= unsafeFreezeArray {-# NOINLINE emptyArray #-} -#if !MIN_VERSION_base(4,9,0)-createArray- :: Int- -> a- -> (forall s. MutableArray s a -> ST s ())- -> Array a-createArray 0 _ _ = emptyArray-createArray n x f = runArray $ do- mary <- newArray n x- f mary- pure mary-+-- | Execute the monadic action and freeze the resulting array.+--+-- > runArray m = runST $ m >>= unsafeFreezeArray runArray :: (forall s. ST s (MutableArray s a)) -> Array a+#if !MIN_VERSION_base(4,9,0) runArray m = runST $ m >>= unsafeFreezeArray- #else /* Below, runRW# is available. */---- This low-level business is designed to work with GHC's worker-wrapper--- transformation. A lot of the time, we don't actually need an Array--- constructor. By putting it on the outside, and being careful about--- how we special-case the empty array, we can make GHC smarter about this.--- The only downside is that separately created 0-length arrays won't share--- their Array constructors, although they'll share their underlying--- Array#s.-createArray- :: Int- -> a- -> (forall s. MutableArray s a -> ST s ())- -> Array a-createArray 0 _ _ = Array (emptyArray# (# #))-createArray n x f = runArray $ do- mary <- newArray n x- f mary- pure mary---- |--- Execute the monadic action(s) and freeze the resulting array.-runArray- :: (forall s. ST s (MutableArray s a))- -> Array a runArray m = Array (runArray# m) runArray#@@ -388,7 +317,38 @@ {-# NOINLINE emptyArray# #-} #endif +-- | Create an array of the given size with a default value,+-- apply the monadic function and freeze the result. If the+-- size is 0, return 'emptyArray' (rather than a new copy thereof).+--+-- > createArray 0 _ _ = emptyArray+-- > createArray n x f = runArray $ do+-- > mary <- newArray n x+-- > f mary+-- > pure mary+createArray+ :: Int+ -> a+ -> (forall s. MutableArray s a -> ST s ())+ -> Array a+#if !MIN_VERSION_base(4,9,0)+createArray 0 _ _ = emptyArray+#else+-- This low-level business is designed to work with GHC's worker-wrapper+-- transformation. A lot of the time, we don't actually need an Array+-- constructor. By putting it on the outside, and being careful about+-- how we special-case the empty array, we can make GHC smarter about this.+-- The only downside is that separately created 0-length arrays won't share+-- their Array constructors, although they'll share their underlying+-- Array#s.+createArray 0 _ _ = Array (emptyArray# (# #))+#endif+createArray n x f = runArray $ do+ mary <- newArray n x+ f mary+ pure mary + die :: String -> String -> a die fun problem = error $ "Data.Primitive.Array." ++ fun ++ ": " ++ problem @@ -397,12 +357,11 @@ where loop i | i < 0 = True | (# x1 #) <- indexArray## a1 i , (# x2 #) <- indexArray## a2 i- , otherwise = p x1 x2 && loop (i-1)+ , otherwise = p x1 x2 && loop (i - 1) instance Eq a => Eq (Array a) where a1 == a2 = arrayLiftEq (==) a1 a2 -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Eq1 Array where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)@@ -410,7 +369,6 @@ #else eq1 = arrayLiftEq (==) #endif-#endif instance Eq (MutableArray s a) where ma1 == ma2 = isTrue# (sameMutableArray# (marray# ma1) (marray# ma2))@@ -423,14 +381,13 @@ | i < mn , (# x1 #) <- indexArray## a1 i , (# x2 #) <- indexArray## a2 i- = elemCompare x1 x2 `mappend` loop (i+1)+ = elemCompare x1 x2 `mappend` loop (i + 1) | otherwise = compare (sizeofArray a1) (sizeofArray a2) -- | Lexicographic ordering. Subject to change between major versions. instance Ord a => Ord (Array a) where compare a1 a2 = arrayLiftCompare compare a1 a2 -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Ord1 Array where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)@@ -438,7 +395,6 @@ #else compare1 = arrayLiftCompare compare #endif-#endif instance Foldable Array where -- Note: we perform the array lookups eagerly so we won't@@ -450,7 +406,7 @@ go i | i == sz = z | (# x #) <- indexArray## ary i- = f x (go (i+1))+ = f x (go (i + 1)) in go 0 {-# INLINE foldr #-} foldl f = \z !ary ->@@ -458,7 +414,7 @@ go i | i < 0 = z | (# x #) <- indexArray## ary i- = f (go (i-1)) x+ = f (go (i - 1)) x in go (sizeofArray ary - 1) {-# INLINE foldl #-} foldr1 f = \ !ary ->@@ -467,7 +423,7 @@ go i = case indexArray## ary i of (# x #) | i == sz -> x- | otherwise -> f x (go (i+1))+ | otherwise -> f x (go (i + 1)) in if sz < 0 then die "foldr1" "empty array" else go 0@@ -483,13 +439,12 @@ then die "foldl1" "empty array" else go sz {-# INLINE foldl1 #-}-#if MIN_VERSION_base(4,6,0) foldr' f = \z !ary -> let go i !acc | i == -1 = acc | (# x #) <- indexArray## ary i- = go (i-1) (f x acc)+ = go (i - 1) (f x acc) in go (sizeofArray ary - 1) z {-# INLINE foldr' #-} foldl' f = \z !ary ->@@ -498,11 +453,9 @@ go i !acc | i == sz = acc | (# x #) <- indexArray## ary i- = go (i+1) (f acc x)+ = go (i + 1) (f acc x) in go 0 z {-# INLINE foldl' #-}-#endif-#if MIN_VERSION_base(4,8,0) null a = sizeofArray a == 0 {-# INLINE null #-} length = sizeofArray@@ -515,7 +468,7 @@ go i !e | i == sz = e | (# x #) <- indexArray## ary i- = go (i+1) (max e x)+ = go (i + 1) (max e x) {-# INLINE maximum #-} minimum ary | sz == 0 = die "minimum" "empty array" | (# frst #) <- indexArray## ary 0@@ -524,15 +477,14 @@ go i !e | i == sz = e | (# x #) <- indexArray## ary i- = go (i+1) (min e x)+ = go (i + 1) (min e x) {-# INLINE minimum #-} sum = foldl' (+) 0 {-# INLINE sum #-} product = foldl' (*) 1 {-# INLINE product #-}-#endif -newtype STA a = STA {_runSTA :: forall s. MutableArray# s a -> ST s (Array a)}+newtype STA a = STA { _runSTA :: forall s. MutableArray# s a -> ST s (Array a) } runSTA :: Int -> STA a -> Array a runSTA !sz = \ (STA m) -> runST $ newArray_ sz >>= \ ar -> m (marray# ar)@@ -564,8 +516,8 @@ writeArray (MutableArray mary) i b >> m mary) (f x) (go (i + 1)) in if len == 0- then pure emptyArray- else runSTA len <$> go 0+ then pure emptyArray+ else runSTA len <$> go 0 {-# INLINE [1] traverseArray #-} {-# RULES@@ -573,19 +525,15 @@ traverseArrayP f "traverse/IO" forall (f :: a -> IO b). traverseArray f = traverseArrayP f- #-}-#if MIN_VERSION_base(4,8,0)-{-# RULES "traverse/Id" forall (f :: a -> Identity b). traverseArray f = (coerce :: (Array a -> Array (Identity b)) -> Array a -> Identity (Array b)) (fmap f) #-}-#endif -- | This is the fastest, most straightforward way to traverse -- an array, but it only works correctly with a sufficiently -- "affine" 'PrimMonad' instance. In particular, it must only produce--- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed+-- /one/ result array. 'Control.Monad.Trans.List.ListT'-transformed -- monads, for example, will not work right at all. traverseArrayP :: PrimMonad m@@ -620,12 +568,12 @@ -- We use indexArrayM here so that we will perform the -- indexing eagerly even if f is lazy. let !y = f x- writeArray mb i y >> go (i+1)+ writeArray mb i y >> go (i + 1) in go 0 {-# INLINE mapArray' #-} -- | Create an array from a list of a known length. If the length--- of the list does not match the given length, this throws an exception.+-- of the list does not match the given length, this throws an exception. arrayFromListN :: Int -> [a] -> Array a arrayFromListN n l = createArray n (die "fromListN" "uninitialized element") $ \sma ->@@ -643,20 +591,12 @@ arrayFromList :: [a] -> Array a arrayFromList l = arrayFromListN (length l) l -#if MIN_VERSION_base(4,7,0) instance Exts.IsList (Array a) where type Item (Array a) = a fromListN = arrayFromListN fromList = arrayFromList toList = toList-#else-fromListN :: Int -> [a] -> Array a-fromListN = arrayFromListN -fromList :: [a] -> Array a-fromList = arrayFromList-#endif- instance Functor Array where fmap f a = createArray (sizeofArray a) (die "fmap" "impossible") $ \mb ->@@ -664,47 +604,48 @@ = return () | otherwise = do x <- indexArrayM a i- writeArray mb i (f x) >> go (i+1)+ writeArray mb i (f x) >> go (i + 1) in go 0-#if MIN_VERSION_base(4,8,0) e <$ a = createArray (sizeofArray a) e (\ !_ -> pure ())-#endif instance Applicative Array where pure x = runArray $ newArray 1 x- ab <*> a = createArray (szab*sza) (die "<*>" "impossible") $ \mb ->++ ab <*> a = createArray (szab * sza) (die "<*>" "impossible") $ \mb -> let go1 i = when (i < szab) $ do f <- indexArrayM ab i- go2 (i*sza) f 0- go1 (i+1)+ go2 (i * sza) f 0+ go1 (i + 1) go2 off f j = when (j < sza) $ do x <- indexArrayM a j writeArray mb (off + j) (f x) go2 off f (j + 1) in go1 0- where szab = sizeofArray ab ; sza = sizeofArray a- a *> b = createArray (sza*szb) (die "*>" "impossible") $ \mb ->- let go i | i < sza = copyArray mb (i * szb) b 0 szb+ where szab = sizeofArray ab; sza = sizeofArray a++ a *> b = createArray (sza * szb) (die "*>" "impossible") $ \mb ->+ let go i | i < sza = copyArray mb (i * szb) b 0 szb *> go (i + 1) | otherwise = return ()- in go 0- where sza = sizeofArray a ; szb = sizeofArray b- a <* b = createArray (sza*szb) (die "<*" "impossible") $ \ma ->- let fill off i e | i < szb = writeArray ma (off+i) e >> fill off (i+1) e+ in go 0+ where sza = sizeofArray a; szb = sizeofArray b++ a <* b = createArray (sza * szb) (die "<*" "impossible") $ \ma ->+ let fill off i e | i < szb = writeArray ma (off + i) e >> fill off (i + 1) e | otherwise = return () go i | i < sza = do x <- indexArrayM a i- fill (i*szb) 0 x >> go (i+1)+ fill (i * szb) 0 x >> go (i + 1) | otherwise = return ()- in go 0- where sza = sizeofArray a ; szb = sizeofArray b+ in go 0+ where sza = sizeofArray a; szb = sizeofArray b instance Alternative Array where empty = emptyArray a1 <|> a2 = createArray (sza1 + sza2) (die "<|>" "impossible") $ \ma -> copyArray ma 0 a1 0 sza1 >> copyArray ma sza1 a2 0 sza2- where sza1 = sizeofArray a1 ; sza2 = sizeofArray a2+ where sza1 = sizeofArray a1; sza2 = sizeofArray a2 some a | sizeofArray a == 0 = emptyArray | otherwise = die "some" "infinite arrays are not well defined" many a | sizeofArray a == 0 = pure []@@ -719,26 +660,26 @@ return = pure (>>) = (*>) - ary >>= f = collect 0 EmptyStack (la-1)+ ary >>= f = collect 0 EmptyStack (la - 1) where- la = sizeofArray ary- collect sz stk i- | i < 0 = createArray sz (die ">>=" "impossible") $ fill 0 stk- | (# x #) <- indexArray## ary i- , let sb = f x- lsb = sizeofArray sb- -- If we don't perform this check, we could end up allocating- -- a stack full of empty arrays if someone is filtering most- -- things out. So we refrain from pushing empty arrays.- = if lsb == 0- then collect sz stk (i - 1)- else collect (sz + lsb) (PushArray sb stk) (i-1)+ la = sizeofArray ary+ collect sz stk i+ | i < 0 = createArray sz (die ">>=" "impossible") $ fill 0 stk+ | (# x #) <- indexArray## ary i+ , let sb = f x+ lsb = sizeofArray sb+ -- If we don't perform this check, we could end up allocating+ -- a stack full of empty arrays if someone is filtering most+ -- things out. So we refrain from pushing empty arrays.+ = if lsb == 0+ then collect sz stk (i - 1)+ else collect (sz + lsb) (PushArray sb stk) (i - 1) - fill _ EmptyStack _ = return ()- fill off (PushArray sb sbs) smb- | let lsb = sizeofArray sb- = copyArray smb off sb 0 (lsb)- *> fill (off + lsb) sbs smb+ fill _ EmptyStack _ = return ()+ fill off (PushArray sb sbs) smb+ | let lsb = sizeofArray sb+ = copyArray smb off sb 0 lsb+ *> fill (off + lsb) sbs smb #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail@@ -758,13 +699,12 @@ x <- indexArrayM aa i y <- indexArrayM ab i writeArray mc i (f x y)- go (i+1)+ go (i + 1) | otherwise = return () in go 0 where mn = sizeofArray aa `min` sizeofArray ab {-# INLINE zipW #-} -#if MIN_VERSION_base(4,4,0) instance MonadZip Array where mzip aa ab = zipW "mzip" (,) aa ab mzipWith f aa ab = zipW "mzipWith" f aa ab@@ -776,11 +716,10 @@ (a, b) <- indexArrayM aab i writeArray ma i a writeArray mb i b- go (i+1)+ go (i + 1) go _ = return () go 0 (,) <$> unsafeFreezeArray ma <*> unsafeFreezeArray mb-#endif instance MonadFix Array where mfix f = createArray (sizeofArray (f err))@@ -823,7 +762,6 @@ instance Show a => Show (Array a) where showsPrec p a = arrayLiftShowsPrec showsPrec showList p a -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Show1 Array where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)@@ -831,12 +769,10 @@ #else showsPrec1 = arrayLiftShowsPrec showsPrec showList #endif-#endif instance Read a => Read (Array a) where readPrec = arrayLiftReadPrec readPrec readListPrec -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Read1 Array where #if MIN_VERSION_base(4,10,0)@@ -845,7 +781,6 @@ liftReadsPrec = arrayLiftReadsPrec #else readsPrec1 = arrayLiftReadsPrec readsPrec readList-#endif #endif -- We're really forgiving here. We accept
Data/Primitive/ByteArray.hs view
@@ -24,14 +24,13 @@ -- * Allocation newByteArray, newPinnedByteArray, newAlignedPinnedByteArray, resizeMutableByteArray,-#if __GLASGOW_HASKELL__ >= 710 shrinkMutableByteArray,-#endif -- * Element access readByteArray, writeByteArray, indexByteArray, -- * Constructing+ emptyByteArray, byteArrayFromList, byteArrayFromListN, -- * Folding@@ -41,15 +40,13 @@ compareByteArrays, -- * Freezing and thawing- freezeByteArray, thawByteArray,+ freezeByteArray, thawByteArray, runByteArray, unsafeFreezeByteArray, unsafeThawByteArray, -- * Block operations copyByteArray, copyMutableByteArray,-#if __GLASGOW_HASKELL__ >= 708 copyByteArrayToPtr, copyMutableByteArrayToPtr, copyByteArrayToAddr, copyMutableByteArrayToAddr,-#endif moveByteArray, setByteArray, fillByteArray, cloneByteArray, cloneMutableByteArray,@@ -67,7 +64,6 @@ import Control.Monad.Primitive import Control.Monad.ST import Control.DeepSeq-import Data.Data (mkNoRepType) import Data.Primitive.Types import qualified GHC.ST as GHCST@@ -76,29 +72,17 @@ import Data.Word ( Word8 ) import Data.Bits ( (.&.), unsafeShiftR ) import GHC.Show ( intToDigit )-import GHC.Base ( Int(..) )-#if __GLASGOW_HASKELL__ >= 708 import qualified GHC.Exts as Exts ( IsList(..) )-#endif-import GHC.Exts-#if __GLASGOW_HASKELL__ >= 706- hiding (setByteArray#)-#endif+import GHC.Exts hiding (setByteArray#) import Data.Typeable ( Typeable )-import Data.Data ( Data(..) )-import Data.Primitive.Internal.Compat ( isTrue# )-import Numeric+import Data.Data ( Data(..), mkNoRepType ) #if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as SG import qualified Data.Foldable as F #endif -#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid (Monoid(..))-#endif- #if __GLASGOW_HASKELL__ >= 802 import GHC.Exts as Exts (isByteArrayPinned#,isMutableByteArrayPinned#) #endif@@ -109,12 +93,12 @@ import System.IO.Unsafe (unsafeDupablePerformIO) #endif --- | Byte arrays+-- | Byte arrays. data ByteArray = ByteArray ByteArray# deriving ( Typeable ) --- | Mutable byte arrays associated with a primitive state token+-- | Mutable byte arrays associated with a primitive state token. data MutableByteArray s = MutableByteArray (MutableByteArray# s)- deriving( Typeable )+ deriving ( Typeable ) instance NFData ByteArray where rnf (ByteArray _) = ()@@ -192,16 +176,9 @@ :: PrimMonad m => MutableByteArray (PrimState m) -> Int -> m (MutableByteArray (PrimState m)) {-# INLINE resizeMutableByteArray #-}-#if __GLASGOW_HASKELL__ >= 710 resizeMutableByteArray (MutableByteArray arr#) (I# n#) = primitive (\s# -> case resizeMutableByteArray# arr# n# s# of (# s'#, arr'# #) -> (# s'#, MutableByteArray arr'# #))-#else-resizeMutableByteArray arr n- = do arr' <- newByteArray n- copyMutableByteArray arr' 0 arr 0 (min (sizeofMutableByteArray arr) n)- return arr'-#endif -- | Get the size of a byte array in bytes. Unlike 'sizeofMutableByteArray', -- this function ensures sequencing in the presence of resizing.@@ -222,6 +199,9 @@ -- -- This operation makes a copy of the specified section, so it is safe to -- continue using the mutable array afterward.+--+-- /Note:/ The provided array should contain the full subrange+-- specified by the two Ints, but this is not checked. freezeByteArray :: PrimMonad m => MutableByteArray (PrimState m) -- ^ source@@ -240,6 +220,9 @@ -- This operation makes a copy of the specified slice, so it is safe to -- use the immutable array afterward. --+-- /Note:/ The provided array should contain the full subrange+-- specified by the two Ints, but this is not checked.+-- -- @since 0.7.2.0 thawByteArray :: PrimMonad m@@ -284,12 +267,8 @@ {-# INLINE sizeofMutableByteArray #-} sizeofMutableByteArray (MutableByteArray arr#) = I# (sizeofMutableByteArray# arr#) --- Although it is possible to shim resizeMutableByteArray for old GHCs, this--- is not the case with shrinkMutableByteArray.-#if __GLASGOW_HASKELL__ >= 710 -- | Shrink a mutable byte array. The new size is given in bytes. -- It must be smaller than the old size. The array will be resized in place.--- This function is only available when compiling with GHC 7.10 or newer. -- -- @since 0.7.1.0 shrinkMutableByteArray :: PrimMonad m@@ -299,23 +278,22 @@ {-# INLINE shrinkMutableByteArray #-} shrinkMutableByteArray (MutableByteArray arr#) (I# n#) = primitive_ (shrinkMutableByteArray# arr# n#)-#endif #if __GLASGOW_HASKELL__ >= 802 -- | Check whether or not the byte array is pinned. Pinned byte arrays cannot--- be moved by the garbage collector. It is safe to use 'byteArrayContents'--- on such byte arrays. This function is only available when compiling with--- GHC 8.2 or newer.+-- be moved by the garbage collector. It is safe to use 'byteArrayContents'+-- on such byte arrays. This function is only available when compiling with+-- GHC 8.2 or newer. ----- @since 0.6.4.0+-- @since 0.6.4.0 isByteArrayPinned :: ByteArray -> Bool {-# INLINE isByteArrayPinned #-} isByteArrayPinned (ByteArray arr#) = isTrue# (Exts.isByteArrayPinned# arr#) -- | Check whether or not the mutable byte array is pinned. This function is--- only available when compiling with GHC 8.2 or newer.+-- only available when compiling with GHC 8.2 or newer. ----- @since 0.6.4.0+-- @since 0.6.4.0 isMutableByteArrayPinned :: MutableByteArray s -> Bool {-# INLINE isMutableByteArrayPinned #-} isMutableByteArrayPinned (MutableByteArray marr#) = isTrue# (Exts.isMutableByteArrayPinned# marr#)@@ -355,7 +333,7 @@ foldrByteArray f z arr = go 0 where go i- | i < maxI = f (indexByteArray arr i) (go (i+1))+ | i < maxI = f (indexByteArray arr i) (go (i + 1)) | otherwise = z maxI = sizeofByteArray arr `quot` sizeOf (undefined :: a) @@ -366,7 +344,7 @@ byteArrayFromList xs = byteArrayFromListN (length xs) xs -- | Create a 'ByteArray' from a list of a known length. If the length--- of the list does not match the given length, this throws an exception.+-- of the list does not match the given length, this throws an exception. byteArrayFromListN :: Prim a => Int -> [a] -> ByteArray byteArrayFromListN n ys = runST $ do marr <- newByteArray (n * sizeOf (head ys))@@ -388,13 +366,13 @@ -- -- /Note:/ this function does not do bounds or overlap checking. copyByteArray- :: PrimMonad m => MutableByteArray (PrimState m)- -- ^ destination array- -> Int -- ^ offset into destination array- -> ByteArray -- ^ source array- -> Int -- ^ offset into source array- -> Int -- ^ number of bytes to copy- -> m ()+ :: PrimMonad m+ => MutableByteArray (PrimState m) -- ^ destination array+ -> Int -- ^ offset into destination array+ -> ByteArray -- ^ source array+ -> Int -- ^ offset into source array+ -> Int -- ^ number of bytes to copy+ -> m () {-# INLINE copyByteArray #-} copyByteArray (MutableByteArray dst#) doff (ByteArray src#) soff sz = primitive_ (copyByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz))@@ -404,27 +382,24 @@ -- -- /Note:/ this function does not do bounds or overlap checking. copyMutableByteArray- :: PrimMonad m => MutableByteArray (PrimState m)- -- ^ destination array- -> Int -- ^ offset into destination array- -> MutableByteArray (PrimState m)- -- ^ source array- -> Int -- ^ offset into source array- -> Int -- ^ number of bytes to copy- -> m ()+ :: PrimMonad m+ => MutableByteArray (PrimState m) -- ^ destination array+ -> Int -- ^ offset into destination array+ -> MutableByteArray (PrimState m) -- ^ source array+ -> Int -- ^ offset into source array+ -> Int -- ^ number of bytes to copy+ -> m () {-# INLINE copyMutableByteArray #-} copyMutableByteArray (MutableByteArray dst#) doff (MutableByteArray src#) soff sz = primitive_ (copyMutableByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz)) -#if __GLASGOW_HASKELL__ >= 708--- | Copy a slice of a byte array to an unmanaged Pointer Address. These must not--- overlap. The offset and length given in elements, not in bytes. This function--- is only available when compiling with GHC 7.8 or newer.+-- | Copy a slice of a byte array to an unmanaged pointer address. These must not+-- overlap. The offset and length are given in elements, not in bytes. ----- /Note:/ this function does not do bounds or overlap checking.+-- /Note:/ this function does not do bounds or overlap checking. ----- @since 0.7.1.0+-- @since 0.7.1.0 copyByteArrayToPtr :: forall m a. (PrimMonad m, Prim a) => Ptr a -- ^ destination@@ -438,14 +413,13 @@ where siz# = sizeOf# (undefined :: a) --- | Copy a slice of a mutable byte array to an unmanaged Pointer address.--- These must not overlap. The offset and length given in elements, not--- in bytes. This function is only available when compiling with GHC 7.8--- or newer.+-- | Copy a slice of a mutable byte array to an unmanaged pointer address.+-- These must not overlap. The offset and length are given in elements, not+-- in bytes. ----- /Note:/ this function does not do bounds or overlap checking.+-- /Note:/ this function does not do bounds or overlap checking. ----- @since 0.7.1.0+-- @since 0.7.1.0 copyMutableByteArrayToPtr :: forall m a. (PrimMonad m, Prim a) => Ptr a -- ^ destination@@ -464,12 +438,11 @@ ----- -- | Copy a slice of a byte array to an unmanaged address. These must not--- overlap. This function is only available when compiling with GHC 7.8--- or newer.+-- overlap. ----- Note: This function is just 'copyByteArrayToPtr' where @a@ is 'Word8'.+-- Note: This function is just 'copyByteArrayToPtr' where @a@ is 'Word8'. ----- @since 0.6.4.0+-- @since 0.6.4.0 copyByteArrayToAddr :: PrimMonad m => Ptr Word8 -- ^ destination@@ -482,12 +455,11 @@ = primitive_ (copyByteArrayToAddr# src# (unI# soff) dst# (unI# sz)) -- | Copy a slice of a mutable byte array to an unmanaged address. These must--- not overlap. This function is only available when compiling with GHC 7.8--- or newer.+-- not overlap. ----- Note: This function is just 'copyMutableByteArrayToPtr' where @a@ is 'Word8'.+-- Note: This function is just 'copyMutableByteArrayToPtr' where @a@ is 'Word8'. ----- @since 0.6.4.0+-- @since 0.6.4.0 copyMutableByteArrayToAddr :: PrimMonad m => Ptr Word8 -- ^ destination@@ -498,19 +470,17 @@ {-# INLINE copyMutableByteArrayToAddr #-} copyMutableByteArrayToAddr (Ptr dst#) (MutableByteArray src#) soff sz = primitive_ (copyMutableByteArrayToAddr# src# (unI# soff) dst# (unI# sz))-#endif -- | Copy a slice of a mutable byte array into another, potentially -- overlapping array. moveByteArray- :: PrimMonad m => MutableByteArray (PrimState m)- -- ^ destination array- -> Int -- ^ offset into destination array- -> MutableByteArray (PrimState m)- -- ^ source array- -> Int -- ^ offset into source array- -> Int -- ^ number of bytes to copy- -> m ()+ :: PrimMonad m+ => MutableByteArray (PrimState m) -- ^ destination array+ -> Int -- ^ offset into destination array+ -> MutableByteArray (PrimState m) -- ^ source array+ -> Int -- ^ offset into source array+ -> Int -- ^ number of bytes to copy+ -> m () {-# INLINE moveByteArray #-} moveByteArray (MutableByteArray dst#) doff (MutableByteArray src#) soff sz@@ -523,11 +493,12 @@ -- -- /Note:/ this function does not do bounds checking. setByteArray- :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -- ^ array to fill- -> Int -- ^ offset into array- -> Int -- ^ number of values to fill- -> a -- ^ value to fill with- -> m ()+ :: (Prim a, PrimMonad m)+ => MutableByteArray (PrimState m) -- ^ array to fill+ -> Int -- ^ offset into array+ -> Int -- ^ number of values to fill+ -> a -- ^ value to fill with+ -> m () {-# INLINE setByteArray #-} setByteArray (MutableByteArray dst#) (I# doff#) (I# sz#) x = primitive_ (setByteArray# dst# doff# sz# x)@@ -536,12 +507,12 @@ -- -- /Note:/ this function does not do bounds checking. fillByteArray- :: PrimMonad m => MutableByteArray (PrimState m)- -- ^ array to fill- -> Int -- ^ offset into array- -> Int -- ^ number of bytes to fill- -> Word8 -- ^ byte to fill with- -> m ()+ :: PrimMonad m+ => MutableByteArray (PrimState m) -- ^ array to fill+ -> Int -- ^ offset into array+ -> Int -- ^ number of bytes to fill+ -> Word8 -- ^ byte to fill with+ -> m () {-# INLINE fillByteArray #-} fillByteArray = setByteArray @@ -608,12 +579,12 @@ -- | Lexicographic comparison of equal-length slices into two byte arrays. -- This wraps the @compareByteArrays#@ primop, which wraps @memcmp@.-compareByteArrays ::- ByteArray -- ^ Array A- -> Int -- ^ Offset A, given in bytes- -> ByteArray -- ^ Array B- -> Int -- ^ Offset B, given in bytes- -> Int -- ^ Length of slice, given in bytes+compareByteArrays+ :: ByteArray -- ^ array A+ -> Int -- ^ offset A, given in bytes+ -> ByteArray -- ^ array B+ -> Int -- ^ offset B, given in bytes+ -> Int -- ^ length of the slice, given in bytes -> Ordering {-# INLINE compareByteArrays #-} #if __GLASGOW_HASKELL__ >= 804@@ -635,12 +606,7 @@ sameByteArray :: ByteArray# -> ByteArray# -> Bool sameByteArray ba1 ba2 = case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of-#if __GLASGOW_HASKELL__ >= 708 r -> isTrue# r-#else- 1# -> True- 0# -> False-#endif -- | @since 0.6.3.0 instance Eq ByteArray where@@ -696,7 +662,9 @@ calcLength [] !n = n calcLength (x : xs) !n = calcLength xs (sizeofByteArray x + n) +-- | The empty 'ByteArray'. emptyByteArray :: ByteArray+{-# NOINLINE emptyByteArray #-} emptyByteArray = runST (newByteArray 0 >>= unsafeFreezeByteArray) replicateByteArray :: Int -> ByteArray -> ByteArray@@ -716,7 +684,7 @@ sconcat = mconcat . F.toList stimes i arr | itgr < 1 = emptyByteArray- | itgr <= (fromIntegral (maxBound :: Int)) = replicateByteArray (fromIntegral itgr) arr+ | itgr <= fromIntegral (maxBound :: Int) = replicateByteArray (fromIntegral itgr) arr | otherwise = error "Data.Primitive.ByteArray#stimes: cannot allocate the requested amount of memory" where itgr = toInteger i :: Integer #endif@@ -728,7 +696,6 @@ #endif mconcat = concatByteArray -#if __GLASGOW_HASKELL__ >= 708 -- | @since 0.6.3.0 instance Exts.IsList ByteArray where type Item ByteArray = Word8@@ -736,7 +703,6 @@ toList = foldrByteArray (:) [] fromList xs = byteArrayFromListN (length xs) xs fromListN = byteArrayFromListN-#endif die :: String -> String -> a die fun problem = error $ "Data.Primitive.ByteArray." ++ fun ++ ": " ++ problem@@ -744,8 +710,8 @@ -- | Return a newly allocated array with the specified subrange of the -- provided array. The provided array should contain the full subrange -- specified by the two Ints, but this is not checked.-cloneByteArray ::- ByteArray -- ^ source array+cloneByteArray+ :: ByteArray -- ^ source array -> Int -- ^ offset into destination array -> Int -- ^ number of bytes to copy -> ByteArray@@ -769,10 +735,13 @@ copyMutableByteArray dst 0 src off n return dst -#if MIN_VERSION_base(4,10,0) /* In new GHCs, runRW# is available. */+-- | Execute the monadic action and freeze the resulting array.+--+-- > runByteArray m = runST $ m >>= unsafeFreezeByteArray runByteArray :: (forall s. ST s (MutableByteArray s)) -> ByteArray+#if MIN_VERSION_base(4,10,0) /* In new GHCs, runRW# is available. */ runByteArray m = ByteArray (runByteArray# m) runByteArray#@@ -785,8 +754,5 @@ unST :: ST s a -> State# s -> (# State# s, a #) unST (GHCST.ST f) = f #else /* In older GHCs, runRW# is not available. */-runByteArray- :: (forall s. ST s (MutableByteArray s))- -> ByteArray runByteArray m = runST $ m >>= unsafeFreezeByteArray #endif
− Data/Primitive/Internal/Compat.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE CPP, MagicHash #-}---- |--- Module : Data.Primitive.Internal.Compat--- Copyright : (c) Roman Leshchinskiy 2011-2012--- License : BSD-style------ Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au>--- Portability : non-portable------ Compatibility functions-----module Data.Primitive.Internal.Compat (- isTrue#- ) where--#if MIN_VERSION_base(4,7,0)-import GHC.Exts (isTrue#)-#endif--#if !MIN_VERSION_base(4,7,0)-isTrue# :: Bool -> Bool-isTrue# b = b-#endif
Data/Primitive/Internal/Operations.hs view
@@ -8,9 +8,7 @@ -- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> -- Portability : non-portable ----- Internal operations----+-- Internal operations. module Data.Primitive.Internal.Operations ( setWord8Array#, setWord16Array#, setWord32Array#,@@ -138,4 +136,3 @@ setDoubleOffAddr# :: Addr# -> CPtrdiff -> CSize -> Double# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" setWideCharOffAddr# :: Addr# -> CPtrdiff -> CSize -> Char# -> IO ()-
Data/Primitive/MVar.hs view
@@ -8,14 +8,17 @@ -- License : BSD2 -- Portability : non-portable ----- Primitive operations on @MVar@. This module provides a similar interface+-- Primitive operations on 'MVar'. This module provides a similar interface -- to "Control.Concurrent.MVar". However, the functions are generalized to -- work in any 'PrimMonad' instead of only working in 'IO'. Note that all -- of the functions here are completely deterministic. Users of 'MVar' are -- responsible for designing abstractions that guarantee determinism in -- the presence of multi-threading. --+-- For a more detailed explanation, see "Control.Concurrent.MVar".+-- -- @since 0.6.4.0+ module Data.Primitive.MVar ( MVar(..) , newMVar@@ -30,14 +33,12 @@ ) where import Control.Monad.Primitive-import Data.Primitive.Internal.Compat (isTrue#)-import GHC.Exts (MVar#,newMVar#,takeMVar#,sameMVar#,putMVar#,tryTakeMVar#,- isEmptyMVar#,tryPutMVar#,(/=#))--#if __GLASGOW_HASKELL__ >= 708-import GHC.Exts (readMVar#,tryReadMVar#)-#endif+import GHC.Exts+ ( MVar#, newMVar#, takeMVar#, sameMVar#, putMVar#, tryTakeMVar#, isEmptyMVar#, tryPutMVar#, (/=#)+ , readMVar#, tryReadMVar#, isTrue# ) +-- | A synchronizing variable, used for communication between concurrent threads.+-- It can be thought of as a box, which may be empty or full. data MVar s a = MVar (MVar# s a) instance Eq (MVar s a) where@@ -49,54 +50,62 @@ case newMVar# s# of (# s2#, svar# #) -> (# s2#, MVar svar# #) - -- | Create a new 'MVar' that holds the supplied argument. newMVar :: PrimMonad m => a -> m (MVar (PrimState m) a)-newMVar value =- newEmptyMVar >>= \ mvar ->- putMVar mvar value >>+newMVar value = do+ mvar <- newEmptyMVar+ putMVar mvar value return mvar --- | Return the contents of the 'MVar'. If the 'MVar' is currently--- empty, 'takeMVar' will wait until it is full. After a 'takeMVar',+-- | Return the contents of the 'MVar'. If the 'MVar' is currently+-- empty, 'takeMVar' will wait until it is full. After a 'takeMVar', -- the 'MVar' is left empty.+--+-- There are two further important properties of 'takeMVar':+--+-- * 'takeMVar' is single-wakeup. That is, if there are multiple+-- threads blocked in 'takeMVar', and the 'MVar' becomes full,+-- only one thread will be woken up. The runtime guarantees that+-- the woken thread completes its 'takeMVar' operation.+-- * When multiple threads are blocked on an 'MVar', they are+-- woken up in FIFO order. This is useful for providing+-- fairness properties of abstractions built using 'MVar's. takeMVar :: PrimMonad m => MVar (PrimState m) a -> m a takeMVar (MVar mvar#) = primitive $ \ s# -> takeMVar# mvar# s# --- | Atomically read the contents of an 'MVar'. If the 'MVar' is+-- | Atomically read the contents of an 'MVar'. If the 'MVar' is -- currently empty, 'readMVar' will wait until it is full. -- 'readMVar' is guaranteed to receive the next 'putMVar'. -- -- /Multiple Wakeup:/ 'readMVar' is multiple-wakeup, so when multiple readers -- are blocked on an 'MVar', all of them are woken up at the same time. ----- /Compatibility note:/ On GHCs prior to 7.8, 'readMVar' is a combination--- of 'takeMVar' and 'putMVar'. Consequently, its behavior differs in the--- following ways:--- -- * It is single-wakeup instead of multiple-wakeup. -- * It might not receive the value from the next call to 'putMVar' if -- there is already a pending thread blocked on 'takeMVar'. -- * If another thread puts a value in the 'MVar' in between the -- calls to 'takeMVar' and 'putMVar', that value may be overridden. readMVar :: PrimMonad m => MVar (PrimState m) a -> m a-#if __GLASGOW_HASKELL__ >= 708 readMVar (MVar mvar#) = primitive $ \ s# -> readMVar# mvar# s#-#else-readMVar mv = do- a <- takeMVar mv- putMVar mv a- return a-#endif --- |Put a value into an 'MVar'. If the 'MVar' is currently full,+-- | Put a value into an 'MVar'. If the 'MVar' is currently full, -- 'putMVar' will wait until it becomes empty.+--+-- There are two further important properties of 'putMVar':+--+-- * 'putMVar' is single-wakeup. That is, if there are multiple+-- threads blocked in 'putMVar', and the 'MVar' becomes empty,+-- only one thread will be woken up. The runtime guarantees that+-- the woken thread completes its 'putMVar' operation.+-- * When multiple threads are blocked on an 'MVar', they are+-- woken up in FIFO order. This is useful for providing+-- fairness properties of abstractions built using 'MVar's. putMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m () putMVar (MVar mvar#) x = primitive_ (putMVar# mvar# x) --- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function+-- | A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function -- returns immediately, with 'Nothing' if the 'MVar' was empty, or--- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar',+-- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar', -- the 'MVar' is left empty. tryTakeMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a) tryTakeMVar (MVar m) = primitive $ \ s ->@@ -104,8 +113,7 @@ (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty (# s', _, a #) -> (# s', Just a #) -- MVar is full ---- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function+-- | A non-blocking version of 'putMVar'. The 'tryPutMVar' function -- attempts to put the value @a@ into the 'MVar', returning 'True' if -- it was successful, or 'False' otherwise. tryPutMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m Bool@@ -114,41 +122,27 @@ (# s, 0# #) -> (# s, False #) (# s, _ #) -> (# s, True #) --- | A non-blocking version of 'readMVar'. The 'tryReadMVar' function+-- | A non-blocking version of 'readMVar'. The 'tryReadMVar' function -- returns immediately, with 'Nothing' if the 'MVar' was empty, or -- @'Just' a@ if the 'MVar' was full with contents @a@. ----- /Compatibility note:/ On GHCs prior to 7.8, 'tryReadMVar' is a combination--- of 'tryTakeMVar' and 'putMVar'. Consequently, its behavior differs in the--- following ways:--- -- * It is single-wakeup instead of multiple-wakeup. -- * In the presence of other threads calling 'putMVar', 'tryReadMVar' -- may block. -- * If another thread puts a value in the 'MVar' in between the -- calls to 'tryTakeMVar' and 'putMVar', that value may be overridden. tryReadMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a)-#if __GLASGOW_HASKELL__ >= 708 tryReadMVar (MVar m) = primitive $ \ s -> case tryReadMVar# m s of (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty (# s', _, a #) -> (# s', Just a #) -- MVar is full-#else-tryReadMVar mv = do- ma <- tryTakeMVar mv- case ma of- Just a -> do- putMVar mv a- return (Just a)- Nothing -> return Nothing-#endif -- | Check whether a given 'MVar' is empty. ----- Notice that the boolean value returned is just a snapshot of--- the state of the MVar. By the time you get to react on its result,--- the MVar may have been filled (or emptied) - so be extremely--- careful when using this operation. Use 'tryTakeMVar' instead if possible.+-- Notice that the boolean value returned is just a snapshot of+-- the state of the 'MVar'. By the time you get to react on its result,+-- the 'MVar' may have been filled (or emptied) - so be extremely+-- careful when using this operation. Use 'tryTakeMVar' instead if possible. isEmptyMVar :: PrimMonad m => MVar (PrimState m) a -> m Bool isEmptyMVar (MVar mv#) = primitive $ \ s# -> case isEmptyMVar# mv# s# of
Data/Primitive/MachDeps.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, MagicHash #-}+ -- | -- Module : Data.Primitive.MachDeps -- Copyright : (c) Roman Leshchinskiy 2009-2012@@ -7,8 +8,7 @@ -- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> -- Portability : non-portable ----- Machine-dependent constants---+-- Machine-dependent constants. module Data.Primitive.MachDeps where @@ -120,4 +120,3 @@ type Word64_# = Word# type Int64_# = Int# #endif-
Data/Primitive/MutVar.hs view
@@ -8,8 +8,9 @@ -- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> -- Portability : non-portable ----- Primitive boxed mutable variables---+-- Primitive boxed mutable variables. This is a generalization of+-- "Data.IORef", "Data.STRef" and "Data.STRef.Lazy" to work in+-- any 'PrimMonad'. module Data.Primitive.MutVar ( MutVar(..),@@ -25,9 +26,9 @@ ) where import Control.Monad.Primitive ( PrimMonad(..), primitive_ )-import GHC.Exts ( MutVar#, sameMutVar#, newMutVar#,- readMutVar#, writeMutVar#, atomicModifyMutVar# )-import Data.Primitive.Internal.Compat ( isTrue# )+import GHC.Exts ( MutVar#, sameMutVar#, newMutVar#+ , readMutVar#, writeMutVar#, atomicModifyMutVar#+ , isTrue# ) import Data.Typeable ( Typeable ) -- | A 'MutVar' behaves like a single-element mutable array associated@@ -38,25 +39,38 @@ instance Eq (MutVar s a) where MutVar mva# == MutVar mvb# = isTrue# (sameMutVar# mva# mvb#) --- | Create a new 'MutVar' with the specified initial value+-- | Create a new 'MutVar' with the specified initial value. newMutVar :: PrimMonad m => a -> m (MutVar (PrimState m) a) {-# INLINE newMutVar #-} newMutVar initialValue = primitive $ \s# -> case newMutVar# initialValue s# of (# s'#, mv# #) -> (# s'#, MutVar mv# #) --- | Read the value of a 'MutVar'+-- | Read the value of a 'MutVar'. readMutVar :: PrimMonad m => MutVar (PrimState m) a -> m a {-# INLINE readMutVar #-} readMutVar (MutVar mv#) = primitive (readMutVar# mv#) --- | Write a new value into a 'MutVar'+-- | Write a new value into a 'MutVar'. writeMutVar :: PrimMonad m => MutVar (PrimState m) a -> a -> m () {-# INLINE writeMutVar #-} writeMutVar (MutVar mv#) newValue = primitive_ (writeMutVar# mv# newValue) --- | Atomically mutate the contents of a 'MutVar'-atomicModifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a,b)) -> m b+-- | Atomically mutate the contents of a 'MutVar'.+--+-- This function is useful for using 'MutVar' in a safe way in a multithreaded program.+-- If you only have one 'MutVar', then using 'atomicModifyMutVar' to access and modify+-- it will prevent race conditions.+--+-- Extending the atomicity to multiple 'MutVar's is problematic,+-- so if you need to do anything more complicated,+-- using 'Data.Primitive.MVar.MVar' instead is a good idea.+--+-- 'atomicModifyMutVar' does not apply the function strictly. This means if a program+-- calls 'atomicModifyMutVar' many times, but seldom uses the value, thunks will pile up+-- in memory resulting in a space leak.+-- To avoid this problem, use 'atomicModifyMutVar'' instead.+atomicModifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a, b)) -> m b {-# INLINE atomicModifyMutVar #-} atomicModifyMutVar (MutVar mv#) f = primitive $ atomicModifyMutVar# mv# f @@ -69,16 +83,21 @@ b `seq` return b where force x = case f x of- v@(x',_) -> x' `seq` v+ v@(x', _) -> x' `seq` v --- | Mutate the contents of a 'MutVar'+-- | Mutate the contents of a 'MutVar'.+--+-- 'modifyMutVar' does not apply the function strictly. This means if a program+-- calls 'modifyMutVar' many times, but seldom uses the value, thunks will pile up+-- in memory resulting in a space leak.+-- To avoid this problem, use 'modifyMutVar'' instead. modifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m () {-# INLINE modifyMutVar #-} modifyMutVar (MutVar mv#) g = primitive_ $ \s# -> case readMutVar# mv# s# of (# s'#, a #) -> writeMutVar# mv# (g a) s'# --- | Strict version of 'modifyMutVar'+-- | Strict version of 'modifyMutVar'. modifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m () {-# INLINE modifyMutVar' #-} modifyMutVar' (MutVar mv#) g = primitive_ $ \s# ->
Data/Primitive/PrimArray.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} - -- | -- Module : Data.Primitive.PrimArray -- Copyright : (c) Roman Leshchinskiy 2009-2012@@ -15,16 +14,17 @@ -- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> -- Portability : non-portable ----- Arrays of unboxed primitive types. The function provided by this module--- match the behavior of those provided by @Data.Primitive.ByteArray@, and+-- Arrays of unboxed primitive types. The functions provided by this module+-- match the behavior of those provided by "Data.Primitive.ByteArray", and -- the underlying types and primops that back them are the same. -- However, the type constructors 'PrimArray' and 'MutablePrimArray' take one additional--- argument than their respective counterparts 'ByteArray' and 'MutableByteArray'.+-- argument compared to their respective counterparts 'ByteArray' and 'Data.Primitive.ByteArray.MutableByteArray'. -- This argument is used to designate the type of element in the array.--- Consequently, all function this modules accepts length and incides in+-- Consequently, all functions in this module accept length and incides in -- terms of elements, not bytes. -- -- @since 0.6.4.0+ module Data.Primitive.PrimArray ( -- * Types PrimArray(..)@@ -34,9 +34,7 @@ , newPinnedPrimArray , newAlignedPinnedPrimArray , resizeMutablePrimArray-#if __GLASGOW_HASKELL__ >= 710 , shrinkMutablePrimArray-#endif -- * Element Access , readPrimArray , writePrimArray@@ -44,15 +42,14 @@ -- * Freezing and Thawing , freezePrimArray , thawPrimArray+ , runPrimArray , unsafeFreezePrimArray , unsafeThawPrimArray -- * Block Operations , copyPrimArray , copyMutablePrimArray-#if __GLASGOW_HASKELL__ >= 708 , copyPrimArrayToPtr , copyMutablePrimArrayToPtr-#endif , clonePrimArray , cloneMutablePrimArray , setPrimArray@@ -81,6 +78,7 @@ , traversePrimArray_ , itraversePrimArray_ -- * Map/Create+ , emptyPrimArray , mapPrimArray , imapPrimArray , generatePrimArray@@ -89,6 +87,7 @@ , mapMaybePrimArray -- * Effectful Map/Create -- $effectfulMapCreate+ -- ** Lazy Applicative , traversePrimArray , itraversePrimArray@@ -106,11 +105,9 @@ ) where import GHC.Exts-import GHC.Base ( Int(..) )-import Data.Primitive.Internal.Compat (isTrue#) import Data.Primitive.Types import Data.Primitive.ByteArray (ByteArray(..))-import Data.Monoid (Monoid(..),(<>))+import Data.Monoid ((<>)) import Control.Applicative import Control.DeepSeq import Control.Monad.Primitive@@ -120,10 +117,6 @@ import qualified Data.Primitive.Types as PT import qualified GHC.ST as GHCST -#if MIN_VERSION_base(4,7,0)-import GHC.Exts (IsList(..))-#endif- #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup) import qualified Data.Semigroup as SG@@ -134,10 +127,10 @@ #endif -- | Arrays of unboxed elements. This accepts types like 'Double', 'Char',--- 'Int', and 'Word', as well as their fixed-length variants ('Word8',+-- 'Int' and 'Word', as well as their fixed-length variants ('Word8', -- 'Word16', etc.). Since the elements are unboxed, a 'PrimArray' is strict--- in its elements. This differs from the behavior of 'Array', which is lazy--- in its elements.+-- in its elements. This differs from the behavior of 'Data.Primitive.Array.Array',+-- which is lazy in its elements. data PrimArray a = PrimArray ByteArray# instance NFData (PrimArray a) where@@ -145,8 +138,8 @@ -- | Mutable primitive arrays associated with a primitive state token. -- These can be written to and read from in a monadic context that supports--- sequencing such as 'IO' or 'ST'. Typically, a mutable primitive array will--- be built and then convert to an immutable primitive array using+-- sequencing, such as 'IO' or 'ST'. Typically, a mutable primitive array will+-- be built and then converted to an immutable primitive array using -- 'unsafeFreezePrimArray'. However, it is also acceptable to simply discard -- a mutable primitive array since it lives in managed memory and will be -- garbage collected when no longer referenced.@@ -161,12 +154,7 @@ sameByteArray :: ByteArray# -> ByteArray# -> Bool sameByteArray ba1 ba2 = case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of-#if __GLASGOW_HASKELL__ >= 708 r -> isTrue# r-#else- 1# -> True- _ -> False-#endif -- | @since 0.6.4.0 instance (Eq a, Prim a) => Eq (PrimArray a) where@@ -182,12 +170,12 @@ sz2 = PB.sizeofByteArray (ByteArray ba2#) loop !i | i < 0 = True- | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i-1)+ | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i - 1) {-# INLINE (==) #-} -- | Lexicographic ordering. Subject to change between major versions. ----- @since 0.6.4.0+-- @since 0.6.4.0 instance (Ord a, Prim a) => Ord (PrimArray a) where compare a1@(PrimArray ba1#) a2@(PrimArray ba2#) | sameByteArray ba1# ba2# = EQ@@ -197,18 +185,16 @@ sz2 = PB.sizeofByteArray (ByteArray ba2#) sz = quot (min sz1 sz2) (sizeOf (undefined :: a)) loop !i- | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) <> loop (i+1)+ | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) <> loop (i + 1) | otherwise = compare sz1 sz2 {-# INLINE compare #-} -#if MIN_VERSION_base(4,7,0) -- | @since 0.6.4.0 instance Prim a => IsList (PrimArray a) where type Item (PrimArray a) = a fromList = primArrayFromList fromListN = primArrayFromListN toList = primArrayToList-#endif -- | @since 0.6.4.0 instance (Show a, Prim a) => Show (PrimArray a) where@@ -226,7 +212,7 @@ primArrayFromList vs = primArrayFromListN (L.length vs) vs -- | Create a 'PrimArray' from a list of a known length. If the length--- of the list does not match the given length, this throws an exception.+-- of the list does not match the given length, this throws an exception. primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a primArrayFromListN len vs = runST run where run :: forall s. ST s (PrimArray a)@@ -244,7 +230,7 @@ go vs 0 unsafeFreezePrimArray arr --- | Convert the primitive array to a list.+-- | Convert a 'PrimArray' to a list. {-# INLINE primArrayToList #-} primArrayToList :: forall a. Prim a => PrimArray a -> [a] primArrayToList xs = build (\c n -> foldrPrimArray c n xs)@@ -271,7 +257,7 @@ #endif mconcat = byteArrayToPrimArray . mconcat . map primArrayToByteArray --- | The empty primitive array.+-- | The empty 'PrimArray'. emptyPrimArray :: PrimArray a {-# NOINLINE emptyPrimArray #-} emptyPrimArray = runST $ primitive $ \s0# -> case newByteArray# 0# s0# of@@ -305,23 +291,12 @@ -> Int -- ^ new size -> m (MutablePrimArray (PrimState m) a) {-# INLINE resizeMutablePrimArray #-}-#if __GLASGOW_HASKELL__ >= 710 resizeMutablePrimArray (MutablePrimArray arr#) (I# n#) = primitive (\s# -> case resizeMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)) s# of (# s'#, arr'# #) -> (# s'#, MutablePrimArray arr'# #))-#else-resizeMutablePrimArray arr n- = do arr' <- newPrimArray n- copyMutablePrimArray arr' 0 arr 0 (min (sizeofMutablePrimArray arr) n)- return arr'-#endif --- Although it is possible to shim resizeMutableByteArray for old GHCs, this--- is not the case with shrinkMutablePrimArray.-#if __GLASGOW_HASKELL__ >= 710 -- | Shrink a mutable primitive array. The new size is given in elements. -- It must be smaller than the old size. The array will be resized in place.--- This function is only available when compiling with GHC 7.10 or newer. shrinkMutablePrimArray :: forall m a. (PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -> Int -- ^ new size@@ -329,7 +304,6 @@ {-# INLINE shrinkMutablePrimArray #-} shrinkMutablePrimArray (MutablePrimArray arr#) (I# n#) = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)))-#endif -- | Read a value from the array at the given index. --@@ -342,8 +316,8 @@ -- | Write an element to the given index. -- -- /Note:/ this function does not do bounds checking.-writePrimArray ::- (Prim a, PrimMonad m)+writePrimArray+ :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -- ^ array -> Int -- ^ index -> a -- ^ element@@ -353,8 +327,8 @@ = primitive_ (writeByteArray# arr# i# x) -- | Copy part of a mutable array into another mutable array.--- In the case that the destination and--- source arrays are the same, the regions may overlap.+-- In the case that the destination and+-- source arrays are the same, the regions may overlap. -- -- /Note:/ this function does not do bounds or overlap checking. copyMutablePrimArray :: forall m a.@@ -369,10 +343,10 @@ copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#) = primitive_ (copyMutableByteArray# src#- (soff# *# (sizeOf# (undefined :: a)))+ (soff# *# sizeOf# (undefined :: a)) dst#- (doff# *# (sizeOf# (undefined :: a)))- (n# *# (sizeOf# (undefined :: a)))+ (doff# *# sizeOf# (undefined :: a))+ (n# *# sizeOf# (undefined :: a)) ) -- | Copy part of an array into another mutable array.@@ -390,25 +364,23 @@ copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#) = primitive_ (copyByteArray# src#- (soff# *# (sizeOf# (undefined :: a)))+ (soff# *# sizeOf# (undefined :: a)) dst#- (doff# *# (sizeOf# (undefined :: a)))- (n# *# (sizeOf# (undefined :: a)))+ (doff# *# sizeOf# (undefined :: a))+ (n# *# sizeOf# (undefined :: a)) ) -#if __GLASGOW_HASKELL__ >= 708--- | Copy a slice of an immutable primitive array to an address.--- The offset and length are given in elements of type @a@.--- This function assumes that the 'Prim' instance of @a@--- agrees with the 'Storable' instance. This function is only--- available when building with GHC 7.8 or newer.+-- | Copy a slice of an immutable primitive array to a pointer.+-- The offset and length are given in elements of type @a@.+-- This function assumes that the 'Prim' instance of @a@+-- agrees with the 'Storable' instance. -- -- /Note:/ this function does not do bounds or overlap checking. copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) => Ptr a -- ^ destination pointer -> PrimArray a -- ^ source array -> Int -- ^ offset into source array- -> Int -- ^ number of prims to copy+ -> Int -- ^ number of elements to copy -> m () {-# INLINE copyPrimArrayToPtr #-} copyPrimArrayToPtr (Ptr addr#) (PrimArray ba#) (I# soff#) (I# n#) =@@ -417,18 +389,17 @@ in (# s'#, () #)) where siz# = sizeOf# (undefined :: a) --- | Copy a slice of an immutable primitive array to an address.--- The offset and length are given in elements of type @a@.--- This function assumes that the 'Prim' instance of @a@--- agrees with the 'Storable' instance. This function is only--- available when building with GHC 7.8 or newer.+-- | Copy a slice of a mutable primitive array to a pointer.+-- The offset and length are given in elements of type @a@.+-- This function assumes that the 'Prim' instance of @a@+-- agrees with the 'Storable' instance. -- -- /Note:/ this function does not do bounds or overlap checking. copyMutablePrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) => Ptr a -- ^ destination pointer -> MutablePrimArray (PrimState m) a -- ^ source array -> Int -- ^ offset into source array- -> Int -- ^ number of prims to copy+ -> Int -- ^ number of elements to copy -> m () {-# INLINE copyMutablePrimArrayToPtr #-} copyMutablePrimArrayToPtr (Ptr addr#) (MutablePrimArray mba#) (I# soff#) (I# n#) =@@ -436,7 +407,6 @@ let s'# = copyMutableByteArrayToAddr# mba# (soff# *# siz#) addr# (n# *# siz#) s# in (# s'#, () #)) where siz# = sizeOf# (undefined :: a)-#endif -- | Fill a slice of a mutable primitive array with a value. --@@ -473,8 +443,8 @@ #endif -- | Size of the mutable primitive array in elements. This function shall not--- be used on primitive arrays that are an argument to or a result of--- 'resizeMutablePrimArray' or 'shrinkMutablePrimArray'.+-- be used on primitive arrays that are an argument to or a result of+-- 'resizeMutablePrimArray' or 'shrinkMutablePrimArray'. sizeofMutablePrimArray :: forall s a. Prim a => MutablePrimArray s a -> Int {-# INLINE sizeofMutablePrimArray #-} sizeofMutablePrimArray (MutablePrimArray arr#) =@@ -491,6 +461,9 @@ -- -- This operation makes a copy of the specified section, so it is safe to -- continue using the mutable array afterward.+--+-- /Note:/ The provided array should contain the full subrange+-- specified by the two Ints, but this is not checked. freezePrimArray :: (PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -- ^ source@@ -509,6 +482,9 @@ -- This operation makes a copy of the specified slice, so it is safe to -- use the immutable array afterward. --+-- /Note:/ The provided array should contain the full subrange+-- specified by the two Ints, but this is not checked.+-- -- @since 0.7.2.0 thawPrimArray :: (PrimMonad m, Prim a)@@ -553,19 +529,19 @@ #if __GLASGOW_HASKELL__ >= 802 -- | Check whether or not the primitive array is pinned. Pinned primitive arrays cannot--- be moved by the garbage collector. It is safe to use 'primArrayContents'--- on such arrays. This function is only available when compiling with--- GHC 8.2 or newer.+-- be moved by the garbage collector. It is safe to use 'primArrayContents'+-- on such arrays. This function is only available when compiling with+-- GHC 8.2 or newer. ----- @since 0.7.1.0+-- @since 0.7.1.0 isPrimArrayPinned :: PrimArray a -> Bool {-# INLINE isPrimArrayPinned #-} isPrimArrayPinned (PrimArray arr#) = isTrue# (Exts.isByteArrayPinned# arr#) -- | Check whether or not the mutable primitive array is pinned. This function is--- only available when compiling with GHC 8.2 or newer.+-- only available when compiling with GHC 8.2 or newer. ----- @since 0.7.1.0+-- @since 0.7.1.0 isMutablePrimArrayPinned :: MutablePrimArray s a -> Bool {-# INLINE isMutablePrimArrayPinned #-} isMutablePrimArrayPinned (MutablePrimArray marr#) = isTrue# (Exts.isMutableByteArrayPinned# marr#)@@ -578,7 +554,7 @@ where !sz = sizeofPrimArray arr go !i- | sz > i = f (indexPrimArray arr i) (go (i+1))+ | i < sz = f (indexPrimArray arr i) (go (i + 1)) | otherwise = z -- | Strict right-associated fold over the elements of a 'PrimArray'.@@ -666,7 +642,7 @@ unsafeFreezePrimArray marr -- | Filter the primitive array, keeping the elements for which the monadic--- predicate evaluates true.+-- predicate evaluates to true. {-# INLINE filterPrimArrayP #-} filterPrimArrayP :: (PrimMonad m, Prim a) => (a -> m Bool)@@ -749,7 +725,6 @@ go 0 unsafeFreezePrimArray marr - -- | Map over the elements of a primitive array. {-# INLINE mapPrimArray #-} mapPrimArray :: (Prim a, Prim b)@@ -810,8 +785,8 @@ -- | Filter the primitive array, keeping the elements for which the monadic -- predicate evaluates true.-filterPrimArrayA ::- (Applicative f, Prim a)+filterPrimArrayA+ :: (Applicative f, Prim a) => (a -> f Bool) -- ^ mapping function -> PrimArray a -- ^ primitive array -> f (PrimArray a)@@ -834,8 +809,8 @@ -- | Map over the primitive array, keeping the elements for which the applicative -- predicate provides a 'Just'.-mapMaybePrimArrayA ::- (Applicative f, Prim a, Prim b)+mapMaybePrimArrayA+ :: (Applicative f, Prim a, Prim b) => (a -> f (Maybe b)) -- ^ mapping function -> PrimArray a -- ^ primitive array -> f (PrimArray b)@@ -879,7 +854,6 @@ marr' <- resizeMutablePrimArray marr dstLen unsafeFreezePrimArray marr' - -- | Traverse a primitive array. The traversal performs all of the applicative -- effects /before/ forcing the resulting values and writing them to the new -- primitive array. Consequently:@@ -893,8 +867,8 @@ -- The function 'traversePrimArrayP' always outperforms this function, but it -- requires a 'PrimMonad' constraint, and it forces the values as -- it performs the effects.-traversePrimArray ::- (Applicative f, Prim a, Prim b)+traversePrimArray+ :: (Applicative f, Prim a, Prim b) => (a -> f b) -- ^ mapping function -> PrimArray a -- ^ primitive array -> f (PrimArray b)@@ -912,8 +886,8 @@ else runSTA len <$> go 0 -- | Traverse a primitive array with the index of each element.-itraversePrimArray ::- (Applicative f, Prim a, Prim b)+itraversePrimArray+ :: (Applicative f, Prim a, Prim b) => (Int -> a -> f b) -> PrimArray a -> f (PrimArray b)@@ -980,8 +954,8 @@ -- | Generate a primitive array by evaluating the applicative generator -- function at each index. {-# INLINE generatePrimArrayA #-}-generatePrimArrayA ::- (Applicative f, Prim a)+generatePrimArrayA+ :: (Applicative f, Prim a) => Int -- ^ length -> (Int -> f a) -- ^ element from index -> f (PrimArray a)@@ -998,10 +972,10 @@ else runSTA len <$> go 0 -- | Execute the applicative action the given number of times and store the--- results in a vector.+-- results in a 'PrimArray'. {-# INLINE replicatePrimArrayA #-}-replicatePrimArrayA ::- (Applicative f, Prim a)+replicatePrimArrayA+ :: (Applicative f, Prim a) => Int -- ^ length -> f a -- ^ applicative element producer -> f (PrimArray a)@@ -1018,10 +992,10 @@ else runSTA len <$> go 0 -- | Traverse the primitive array, discarding the results. There--- is no 'PrimMonad' variant of this function since it would not provide+-- is no 'PrimMonad' variant of this function, since it would not provide -- any performance benefit.-traversePrimArray_ ::- (Applicative f, Prim a)+traversePrimArray_+ :: (Applicative f, Prim a) => (a -> f b) -> PrimArray a -> f ()@@ -1032,10 +1006,10 @@ else pure () -- | Traverse the primitive array with the indices, discarding the results.--- There is no 'PrimMonad' variant of this function since it would not+-- There is no 'PrimMonad' variant of this function, since it would not -- provide any performance benefit.-itraversePrimArray_ ::- (Applicative f, Prim a)+itraversePrimArray_+ :: (Applicative f, Prim a) => (Int -> a -> f b) -> PrimArray a -> f ()@@ -1072,7 +1046,7 @@ documentation of the @Data.Primitive@ module. -} --- | Create a /pinned/ primitive array of the specified size in elements. The garbage+-- | Create a /pinned/ primitive array of the specified size (in elements). The garbage -- collector is guaranteed not to move it. -- -- @since 0.7.1.0@@ -1083,7 +1057,7 @@ = primitive (\s# -> case newPinnedByteArray# (n# *# sizeOf# (undefined :: a)) s# of (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #)) --- | Create a /pinned/ primitive array of the specified size in elements and+-- | Create a /pinned/ primitive array of the specified size (in elements) and -- with the alignment given by its 'Prim' instance. The garbage collector is -- guaranteed not to move it. --@@ -1142,10 +1116,13 @@ copyMutablePrimArray dst 0 src off n return dst -#if MIN_VERSION_base(4,10,0) /* In new GHCs, runRW# is available. */+-- | Execute the monadic action and freeze the resulting array.+--+-- > runPrimArray m = runST $ m >>= unsafeFreezePrimArray runPrimArray :: (forall s. ST s (MutablePrimArray s a)) -> PrimArray a+#if MIN_VERSION_base(4,10,0) /* In new GHCs, runRW# is available. */ runPrimArray m = PrimArray (runPrimArray# m) runPrimArray#@@ -1158,8 +1135,5 @@ unST :: ST s a -> State# s -> (# State# s, a #) unST (GHCST.ST f) = f #else /* In older GHCs, runRW# is not available. */-runPrimArray- :: (forall s. ST s (MutablePrimArray s a))- -> PrimArray a runPrimArray m = runST $ m >>= unsafeFreezePrimArray #endif
Data/Primitive/Ptr.hs view
@@ -11,7 +11,7 @@ -- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> -- Portability : non-portable ----- Primitive operations on machine addresses+-- Primitive operations on machine addresses. -- -- @since 0.6.4.0 @@ -36,14 +36,10 @@ import Control.Monad.Primitive import Data.Primitive.Types-#if __GLASGOW_HASKELL__ >= 708 import Data.Primitive.PrimArray (MutablePrimArray(..)) import Data.Primitive.ByteArray (MutableByteArray(..))-#endif -import GHC.Base ( Int(..) ) import GHC.Exts- import GHC.Ptr import Foreign.Marshal.Utils @@ -54,8 +50,8 @@ advancePtr (Ptr a#) (I# i#) = Ptr (plusAddr# a# (i# *# sizeOf# (undefined :: a))) -- | Subtract a pointer from another pointer. The result represents--- the number of elements of type @a@ that fit in the contiguous--- memory range bounded by these two pointers.+-- the number of elements of type @a@ that fit in the contiguous+-- memory range bounded by these two pointers. subtractPtr :: forall a. Prim a => Ptr a -> Ptr a -> Int {-# INLINE subtractPtr #-} subtractPtr (Ptr a#) (Ptr b#) = I# (quotInt# (minusAddr# a# b#) (sizeOf# (undefined :: a)))@@ -93,8 +89,8 @@ -- | Copy the given number of elements from the second 'Ptr' to the first. The -- areas may overlap. movePtr :: forall m a. (PrimMonad m, Prim a)- => Ptr a -- ^ destination address- -> Ptr a -- ^ source address+ => Ptr a -- ^ destination pointer+ -> Ptr a -- ^ source pointer -> Int -- ^ number of elements -> m () {-# INLINE movePtr #-}@@ -108,11 +104,8 @@ setPtr (Ptr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x) -#if __GLASGOW_HASKELL__ >= 708 -- | Copy from a pointer to a mutable primitive array. -- The offset and length are given in elements of type @a@.--- This function is only available when building with GHC 7.8--- or newer. copyPtrToMutablePrimArray :: forall m a. (PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -- ^ destination array -> Int -- ^ destination offset@@ -127,8 +120,6 @@ -- | Copy from a pointer to a mutable byte array. -- The offset and length are given in elements of type @a@.--- This function is only available when building with GHC 7.8--- or newer. copyPtrToMutableByteArray :: forall m a. (PrimMonad m, Prim a) => MutableByteArray (PrimState m) -- ^ destination array -> Int -- ^ destination offset given in elements of type @a@@@ -140,4 +131,3 @@ primitive_ (copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#)) where siz# = sizeOf# (undefined :: a)-#endif
Data/Primitive/SmallArray.hs view
@@ -18,7 +18,7 @@ -- -- Small arrays are boxed (im)mutable arrays. ----- The underlying structure of the 'Array' type contains a card table, allowing+-- The underlying structure of the 'Data.Primitive.Array.Array' type contains a card table, allowing -- segments of the array to be marked as having been mutated. This allows the -- garbage collector to only re-traverse segments of the array that have been -- marked during certain phases, rather than having to traverse the entire@@ -30,11 +30,8 @@ -- entire array. These advantages make them suitable for use as arrays that are -- known to be small. ----- The card size is 128, so for uses much larger than that, 'Array' would likely--- be superior.------ The underlying type, 'SmallArray#', was introduced in GHC 7.10, so prior to--- that version, this module simply implements small arrays as 'Array'.+-- The card size is 128, so for uses much larger than that,+-- 'Data.Primitive.Array.Array' would likely be superior. module Data.Primitive.SmallArray ( SmallArray(..)@@ -52,28 +49,23 @@ , freezeSmallArray , unsafeFreezeSmallArray , thawSmallArray- , runSmallArray , unsafeThawSmallArray+ , runSmallArray+ , createSmallArray , sizeofSmallArray , sizeofSmallMutableArray #if MIN_VERSION_base(4,14,0) , shrinkSmallMutableArray #endif+ , emptySmallArray , smallArrayFromList , smallArrayFromListN , mapSmallArray' , traverseSmallArrayP ) where --#if (__GLASGOW_HASKELL__ >= 710)-#define HAVE_SMALL_ARRAY 1-#endif--#if MIN_VERSION_base(4,7,0) import GHC.Exts hiding (toList) import qualified GHC.Exts-#endif import Control.Applicative import Control.DeepSeq@@ -100,58 +92,11 @@ import GHC.Base (runRW#) #endif -#if !(HAVE_SMALL_ARRAY)-import Data.Primitive.Array-import Data.Traversable-import qualified Data.Primitive.Array as Array-#endif--#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)-import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..))-#endif+import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..), Read1(..)) -#if HAVE_SMALL_ARRAY data SmallArray a = SmallArray (SmallArray# a) deriving Typeable-#else-newtype SmallArray a = SmallArray (Array a) deriving- ( Eq- , Ord- , Show- , Read- , Foldable- , Traversable- , Functor- , Applicative- , Alternative- , Monad- , MonadPlus- , MonadZip- , MonadFix- , Monoid- , NFData-#if MIN_VERSION_deepseq(1,4,3)- , NFData1-#endif- , Typeable-#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)- , Eq1- , Ord1- , Show1- , Read1-#endif- ) -#if MIN_VERSION_base(4,7,0)-instance IsList (SmallArray a) where- type Item (SmallArray a) = a- fromListN n l = SmallArray (fromListN n l)- fromList l = SmallArray (fromList l)- toList a = Foldable.toList a-#endif-#endif--#if HAVE_SMALL_ARRAY #if MIN_VERSION_deepseq(1,4,3) instance NFData1 SmallArray where liftRnf r = foldl' (\_ -> r) ()@@ -159,15 +104,9 @@ instance NFData a => NFData (SmallArray a) where rnf = foldl' (\_ -> rnf) ()-#endif -#if HAVE_SMALL_ARRAY data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a) deriving Typeable-#else-newtype SmallMutableArray s a = SmallMutableArray (MutableArray s a)- deriving (Eq, Typeable)-#endif -- | Create a new small mutable array. --@@ -177,13 +116,9 @@ => Int -- ^ size -> a -- ^ initial contents -> m (SmallMutableArray (PrimState m) a)-#if HAVE_SMALL_ARRAY newSmallArray (I# i#) x = primitive $ \s -> case newSmallArray# i# x s of (# s', sma# #) -> (# s', SmallMutableArray sma# #)-#else-newSmallArray n e = SmallMutableArray `liftM` newArray n e-#endif {-# INLINE newSmallArray #-} -- | Read the element at a given index in a mutable array.@@ -194,12 +129,8 @@ => SmallMutableArray (PrimState m) a -- ^ array -> Int -- ^ index -> m a-#if HAVE_SMALL_ARRAY readSmallArray (SmallMutableArray sma#) (I# i#) = primitive $ readSmallArray# sma# i#-#else-readSmallArray (SmallMutableArray a) = readArray a-#endif {-# INLINE readSmallArray #-} -- | Write an element at the given idex in a mutable array.@@ -211,12 +142,8 @@ -> Int -- ^ index -> a -- ^ new element -> m ()-#if HAVE_SMALL_ARRAY writeSmallArray (SmallMutableArray sma#) (I# i#) x = primitive_ $ writeSmallArray# sma# i# x-#else-writeSmallArray (SmallMutableArray a) = writeArray a-#endif {-# INLINE writeSmallArray #-} -- | Look up an element in an immutable array.@@ -238,7 +165,7 @@ -- -- > let x = indexSmallArray sa 0 ----- And does not prevent 'sa' from being garbage collected.+-- It also does not prevent 'sa' from being garbage collected. -- -- Note that 'Identity' is not adequate for this use, as it is a newtype, and -- cannot be evaluated without evaluating the element.@@ -249,13 +176,9 @@ => SmallArray a -- ^ array -> Int -- ^ index -> m a-#if HAVE_SMALL_ARRAY indexSmallArrayM (SmallArray sa#) (I# i#) = case indexSmallArray# sa# i# of (# x #) -> pure x-#else-indexSmallArrayM (SmallArray a) = indexArrayM a-#endif {-# INLINE indexSmallArrayM #-} -- | Look up an element in an immutable array.@@ -265,44 +188,34 @@ :: SmallArray a -- ^ array -> Int -- ^ index -> a-#if HAVE_SMALL_ARRAY indexSmallArray sa i = runIdentity $ indexSmallArrayM sa i-#else-indexSmallArray (SmallArray a) = indexArray a-#endif {-# INLINE indexSmallArray #-} -- | Read a value from the immutable array at the given index, returning -- the result in an unboxed unary tuple. This is currently used to implement -- folds.+--+-- /Note:/ this function does not do bounds checking. indexSmallArray## :: SmallArray a -> Int -> (# a #)-#if HAVE_SMALL_ARRAY indexSmallArray## (SmallArray ary) (I# i) = indexSmallArray# ary i-#else-indexSmallArray## (SmallArray a) = indexArray## a-#endif {-# INLINE indexSmallArray## #-} -- | Create a copy of a slice of an immutable array. ----- /Note:/ The provided Array should contain the full subrange+-- /Note:/ The provided array should contain the full subrange -- specified by the two Ints, but this is not checked. cloneSmallArray :: SmallArray a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> SmallArray a-#if HAVE_SMALL_ARRAY cloneSmallArray (SmallArray sa#) (I# i#) (I# j#) = SmallArray (cloneSmallArray# sa# i# j#)-#else-cloneSmallArray (SmallArray a) i j = SmallArray $ cloneArray a i j-#endif {-# INLINE cloneSmallArray #-} -- | Create a copy of a slice of a mutable array. ----- /Note:/ The provided Array should contain the full subrange+-- /Note:/ The provided array should contain the full subrange -- specified by the two Ints, but this is not checked. cloneSmallMutableArray :: PrimMonad m@@ -310,33 +223,26 @@ -> Int -- ^ offset -> Int -- ^ length -> m (SmallMutableArray (PrimState m) a)-#if HAVE_SMALL_ARRAY cloneSmallMutableArray (SmallMutableArray sma#) (I# o#) (I# l#) = primitive $ \s -> case cloneSmallMutableArray# sma# o# l# s of (# s', smb# #) -> (# s', SmallMutableArray smb# #)-#else-cloneSmallMutableArray (SmallMutableArray ma) i j =- SmallMutableArray `liftM` cloneMutableArray ma i j-#endif {-# INLINE cloneSmallMutableArray #-} -- | Create an immutable array corresponding to a slice of a mutable array. -- -- This operation copies the portion of the array to be frozen.+--+-- /Note:/ The provided array should contain the full subrange+-- specified by the two Ints, but this is not checked. freezeSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (SmallArray a)-#if HAVE_SMALL_ARRAY freezeSmallArray (SmallMutableArray sma#) (I# i#) (I# j#) = primitive $ \s -> case freezeSmallArray# sma# i# j# s of (# s', sa# #) -> (# s', SmallArray sa# #)-#else-freezeSmallArray (SmallMutableArray ma) i j =- SmallArray `liftM` freezeArray ma i j-#endif {-# INLINE freezeSmallArray #-} -- | Render a mutable array immutable.@@ -345,33 +251,26 @@ -- input array after freezing. unsafeFreezeSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -> m (SmallArray a)-#if HAVE_SMALL_ARRAY unsafeFreezeSmallArray (SmallMutableArray sma#) = primitive $ \s -> case unsafeFreezeSmallArray# sma# s of (# s', sa# #) -> (# s', SmallArray sa# #)-#else-unsafeFreezeSmallArray (SmallMutableArray ma) =- SmallArray `liftM` unsafeFreezeArray ma-#endif {-# INLINE unsafeFreezeSmallArray #-} -- | Create a mutable array corresponding to a slice of an immutable array. -- -- This operation copies the portion of the array to be thawed.+--+-- /Note:/ The provided array should contain the full subrange+-- specified by the two Ints, but this is not checked. thawSmallArray :: PrimMonad m => SmallArray a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (SmallMutableArray (PrimState m) a)-#if HAVE_SMALL_ARRAY thawSmallArray (SmallArray sa#) (I# o#) (I# l#) = primitive $ \s -> case thawSmallArray# sa# o# l# s of (# s', sma# #) -> (# s', SmallMutableArray sma# #)-#else-thawSmallArray (SmallArray a) off len =- SmallMutableArray `liftM` thawArray a off len-#endif {-# INLINE thawSmallArray #-} -- | Render an immutable array mutable.@@ -379,13 +278,9 @@ -- This operation performs no copying, so care must be taken with its use. unsafeThawSmallArray :: PrimMonad m => SmallArray a -> m (SmallMutableArray (PrimState m) a)-#if HAVE_SMALL_ARRAY unsafeThawSmallArray (SmallArray sa#) = primitive $ \s -> case unsafeThawSmallArray# sa# s of (# s', sma# #) -> (# s', SmallMutableArray sma# #)-#else-unsafeThawSmallArray (SmallArray a) = SmallMutableArray `liftM` unsafeThawArray a-#endif {-# INLINE unsafeThawSmallArray #-} -- | Copy a slice of an immutable array into a mutable array.@@ -399,13 +294,9 @@ -> Int -- ^ source offset -> Int -- ^ length -> m ()-#if HAVE_SMALL_ARRAY copySmallArray (SmallMutableArray dst#) (I# do#) (SmallArray src#) (I# so#) (I# l#) = primitive_ $ copySmallArray# src# so# dst# do# l#-#else-copySmallArray (SmallMutableArray dst) i (SmallArray src) = copyArray dst i src-#endif {-# INLINE copySmallArray #-} -- | Copy a slice of one mutable array into another.@@ -419,46 +310,34 @@ -> Int -- ^ source offset -> Int -- ^ length -> m ()-#if HAVE_SMALL_ARRAY copySmallMutableArray (SmallMutableArray dst#) (I# do#) (SmallMutableArray src#) (I# so#) (I# l#) = primitive_ $ copySmallMutableArray# src# so# dst# do# l#-#else-copySmallMutableArray (SmallMutableArray dst) i (SmallMutableArray src) =- copyMutableArray dst i src-#endif {-# INLINE copySmallMutableArray #-} +-- | The number of elements in an immutable array. sizeofSmallArray :: SmallArray a -> Int-#if HAVE_SMALL_ARRAY sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#)-#else-sizeofSmallArray (SmallArray a) = sizeofArray a-#endif {-# INLINE sizeofSmallArray #-} +-- | The number of elements in a mutable array. sizeofSmallMutableArray :: SmallMutableArray s a -> Int-#if HAVE_SMALL_ARRAY sizeofSmallMutableArray (SmallMutableArray sa#) = I# (sizeofSmallMutableArray# sa#)-#else-sizeofSmallMutableArray (SmallMutableArray ma) = sizeofMutableArray ma-#endif {-# INLINE sizeofSmallMutableArray #-} -- | This is the fastest, most straightforward way to traverse -- an array, but it only works correctly with a sufficiently -- "affine" 'PrimMonad' instance. In particular, it must only produce--- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed+-- /one/ result array. 'Control.Monad.Trans.List.ListT'-transformed -- monads, for example, will not work right at all. traverseSmallArrayP :: PrimMonad m => (a -> m b) -> SmallArray a -> m (SmallArray b)-#if HAVE_SMALL_ARRAY traverseSmallArrayP f = \ !ary -> let !sz = sizeofSmallArray ary@@ -474,38 +353,26 @@ in do mary <- newSmallArray sz badTraverseValue go 0 mary-#else-traverseSmallArrayP f (SmallArray ar) = SmallArray `liftM` traverseArrayP f ar-#endif {-# INLINE traverseSmallArrayP #-} -- | Strict map over the elements of the array. mapSmallArray' :: (a -> b) -> SmallArray a -> SmallArray b-#if HAVE_SMALL_ARRAY mapSmallArray' f sa = createSmallArray (length sa) (die "mapSmallArray'" "impossible") $ \smb -> fix ? 0 $ \go i -> when (i < length sa) $ do x <- indexSmallArrayM sa i let !y = f x- writeSmallArray smb i y *> go (i+1)-#else-mapSmallArray' f (SmallArray ar) = SmallArray (mapArray' f ar)-#endif+ writeSmallArray smb i y *> go (i + 1) {-# INLINE mapSmallArray' #-} -#ifndef HAVE_SMALL_ARRAY-runSmallArray- :: (forall s. ST s (SmallMutableArray s a))- -> SmallArray a-runSmallArray m = SmallArray $ runArray $- m >>= \(SmallMutableArray mary) -> return mary--#elif !MIN_VERSION_base(4,9,0)+-- | Execute the monadic action and freeze the resulting array.+--+-- > runSmallArray m = runST $ m >>= unsafeFreezeSmallArray runSmallArray :: (forall s. ST s (SmallMutableArray s a)) -> SmallArray a+#if !MIN_VERSION_base(4,9,0) runSmallArray m = runST $ m >>= unsafeFreezeSmallArray- #else -- This low-level business is designed to work with GHC's worker-wrapper -- transformation. A lot of the time, we don't actually need an Array@@ -514,9 +381,6 @@ -- The only downside is that separately created 0-length arrays won't share -- their Array constructors, although they'll share their underlying -- Array#s.-runSmallArray- :: (forall s. ST s (SmallMutableArray s a))- -> SmallArray a runSmallArray m = SmallArray (runSmallArray# m) runSmallArray#@@ -528,16 +392,23 @@ unST :: ST s a -> State# s -> (# State# s, a #) unST (GHCST.ST f) = f- #endif -#if HAVE_SMALL_ARRAY--- See the comment on runSmallArray for why we use emptySmallArray#.+-- | Create an array of the given size with a default value,+-- apply the monadic function and freeze the result. If the+-- size is 0, return 'emptySmallArray' (rather than a new copy thereof).+--+-- > createSmallArray 0 _ _ = emptySmallArray+-- > createSmallArray n x f = runSmallArray $ do+-- > mary <- newSmallArray n x+-- > f mary+-- > pure mary createSmallArray :: Int -> a -> (forall s. SmallMutableArray s a -> ST s ()) -> SmallArray a+-- See the comment on runSmallArray for why we use emptySmallArray#. createSmallArray 0 _ _ = SmallArray (emptySmallArray# (# #)) createSmallArray n x f = runSmallArray $ do mary <- newSmallArray n x@@ -551,6 +422,7 @@ die :: String -> String -> a die fun problem = error $ "Data.Primitive.SmallArray." ++ fun ++ ": " ++ problem +-- | The empty 'SmallArray'. emptySmallArray :: SmallArray a emptySmallArray = runST $ newSmallArray 0 (die "emptySmallArray" "impossible")@@ -574,9 +446,8 @@ = True | (# x #) <- indexSmallArray## sa1 i , (# y #) <- indexSmallArray## sa2 i- = p x y && loop (i-1)+ = p x y && loop (i - 1) -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Eq1 SmallArray where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)@@ -584,7 +455,6 @@ #else eq1 = smallArrayLiftEq (==) #endif-#endif instance Eq a => Eq (SmallArray a) where sa1 == sa2 = smallArrayLiftEq (==) sa1 sa2@@ -601,10 +471,9 @@ | i < mn , (# x1 #) <- indexSmallArray## a1 i , (# x2 #) <- indexSmallArray## a2 i- = elemCompare x1 x2 `mappend` loop (i+1)+ = elemCompare x1 x2 `mappend` loop (i + 1) | otherwise = compare (length a1) (length a2) -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Ord1 SmallArray where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)@@ -612,7 +481,6 @@ #else compare1 = smallArrayLiftCompare compare #endif-#endif -- | Lexicographic ordering. Subject to change between major versions. instance Ord a => Ord (SmallArray a) where@@ -628,7 +496,7 @@ go i | i == sz = z | (# x #) <- indexSmallArray## ary i- = f x (go (i+1))+ = f x (go (i + 1)) in go 0 {-# INLINE foldr #-} foldl f = \z !ary ->@@ -636,7 +504,7 @@ go i | i < 0 = z | (# x #) <- indexSmallArray## ary i- = f (go (i-1)) x+ = f (go (i - 1)) x in go (sizeofSmallArray ary - 1) {-# INLINE foldl #-} foldr1 f = \ !ary ->@@ -645,7 +513,7 @@ go i = case indexSmallArray## ary i of (# x #) | i == sz -> x- | otherwise -> f x (go (i+1))+ | otherwise -> f x (go (i + 1)) in if sz < 0 then die "foldr1" "Empty SmallArray" else go 0@@ -666,7 +534,7 @@ go i !acc | i == -1 = acc | (# x #) <- indexSmallArray## ary i- = go (i-1) (f x acc)+ = go (i - 1) (f x acc) in go (sizeofSmallArray ary - 1) z {-# INLINE foldr' #-} foldl' f = \z !ary ->@@ -675,7 +543,7 @@ go i !acc | i == sz = acc | (# x #) <- indexSmallArray## ary i- = go (i+1) (f acc x)+ = go (i + 1) (f acc x) in go 0 z {-# INLINE foldl' #-} null a = sizeofSmallArray a == 0@@ -690,7 +558,7 @@ go i !e | i == sz = e | (# x #) <- indexSmallArray## ary i- = go (i+1) (max e x)+ = go (i + 1) (max e x) {-# INLINE maximum #-} minimum ary | sz == 0 = die "minimum" "Empty SmallArray" | (# frst #) <- indexSmallArray## ary 0@@ -699,14 +567,14 @@ go i !e | i == sz = e | (# x #) <- indexSmallArray## ary i- = go (i+1) (min e x)+ = go (i + 1) (min e x) {-# INLINE minimum #-} sum = foldl' (+) 0 {-# INLINE sum #-} product = foldl' (*) 1 {-# INLINE product #-} -newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (SmallArray a)}+newtype STA a = STA { _runSTA :: forall s. SmallMutableArray# s a -> ST s (SmallArray a) } runSTA :: Int -> STA a -> SmallArray a runSTA !sz = \ (STA m) -> runST $ newSmallArray_ sz >>=@@ -738,8 +606,8 @@ writeSmallArray (SmallMutableArray mary) i b >> m mary) (f x) (go (i + 1)) in if len == 0- then pure emptySmallArray- else runSTA len <$> go 0+ then pure emptySmallArray+ else runSTA len <$> go 0 {-# INLINE [1] traverseSmallArray #-} {-# RULES@@ -756,7 +624,7 @@ fix ? 0 $ \go i -> when (i < length sa) $ do x <- indexSmallArrayM sa i- writeSmallArray smb i (f x) *> go (i+1)+ writeSmallArray smb i (f x) *> go (i + 1) {-# INLINE fmap #-} x <$ sa = createSmallArray (length sa) x noOp@@ -764,36 +632,36 @@ instance Applicative SmallArray where pure x = createSmallArray 1 x noOp - sa *> sb = createSmallArray (la*lb) (die "*>" "impossible") $ \smb ->+ sa *> sb = createSmallArray (la * lb) (die "*>" "impossible") $ \smb -> fix ? 0 $ \go i -> when (i < la) $- copySmallArray smb 0 sb 0 lb *> go (i+1)+ copySmallArray smb (i * lb) sb 0 lb *> go (i + 1) where- la = length sa ; lb = length sb+ la = length sa; lb = length sb - a <* b = createSmallArray (sza*szb) (die "<*" "impossible") $ \ma ->+ a <* b = createSmallArray (sza * szb) (die "<*" "impossible") $ \ma -> let fill off i e = when (i < szb) $- writeSmallArray ma (off+i) e >> fill off (i+1) e+ writeSmallArray ma (off + i) e >> fill off (i + 1) e go i = when (i < sza) $ do x <- indexSmallArrayM a i- fill (i*szb) 0 x- go (i+1)+ fill (i * szb) 0 x+ go (i + 1) in go 0- where sza = sizeofSmallArray a ; szb = sizeofSmallArray b+ where sza = sizeofSmallArray a; szb = sizeofSmallArray b - ab <*> a = createSmallArray (szab*sza) (die "<*>" "impossible") $ \mb ->+ ab <*> a = createSmallArray (szab * sza) (die "<*>" "impossible") $ \mb -> let go1 i = when (i < szab) $ do f <- indexSmallArrayM ab i- go2 (i*sza) f 0- go1 (i+1)+ go2 (i * sza) f 0+ go1 (i + 1) go2 off f j = when (j < sza) $ do x <- indexSmallArrayM a j writeSmallArray mb (off + j) (f x) go2 off f (j + 1) in go1 0- where szab = sizeofSmallArray ab ; sza = sizeofSmallArray a+ where szab = sizeofSmallArray ab; sza = sizeofSmallArray a instance Alternative SmallArray where empty = emptySmallArray@@ -827,25 +695,25 @@ return = pure (>>) = (*>) - sa >>= f = collect 0 EmptyStack (la-1)+ sa >>= f = collect 0 EmptyStack (la - 1) where- la = length sa- collect sz stk i- | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk- | (# x #) <- indexSmallArray## sa i- , let sb = f x- lsb = length sb- -- If we don't perform this check, we could end up allocating- -- a stack full of empty arrays if someone is filtering most- -- things out. So we refrain from pushing empty arrays.- = if lsb == 0- then collect sz stk (i-1)- else collect (sz + lsb) (PushArray sb stk) (i-1)+ la = length sa+ collect sz stk i+ | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk+ | (# x #) <- indexSmallArray## sa i+ , let sb = f x+ lsb = length sb+ -- If we don't perform this check, we could end up allocating+ -- a stack full of empty arrays if someone is filtering most+ -- things out. So we refrain from pushing empty arrays.+ = if lsb == 0+ then collect sz stk (i - 1)+ else collect (sz + lsb) (PushArray sb stk) (i - 1) - fill _ EmptyStack _ = return ()- fill off (PushArray sb sbs) smb =- copySmallArray smb off sb 0 (length sb)- *> fill (off + length sb) sbs smb+ fill _ EmptyStack _ = return ()+ fill off (PushArray sb sbs) smb =+ copySmallArray smb off sb 0 (length sb)+ *> fill (off + length sb) sbs smb #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail@@ -865,7 +733,7 @@ x <- indexSmallArrayM sa i y <- indexSmallArrayM sb i writeSmallArray mc i (f x y)- go (i+1)+ go (i + 1) {-# INLINE zipW #-} instance MonadZip SmallArray where@@ -880,13 +748,13 @@ when (i < sz) $ case indexSmallArray sab i of (x, y) -> do writeSmallArray sma i x writeSmallArray smb i y- go $ i+1+ go (i + 1) (,) <$> unsafeFreezeSmallArray sma <*> unsafeFreezeSmallArray smb instance MonadFix SmallArray where mfix f = createSmallArray (sizeofSmallArray (f err))- (die "mfix" "impossible") $ flip fix 0 $+ (die "mfix" "impossible") $ fix ? 0 $ \r !i !mary -> when (i < sz) $ do writeSmallArray mary i (fix (\xi -> f xi `indexSmallArray` i)) r (i + 1) mary@@ -911,7 +779,7 @@ go off (a:as) = copySmallArray ma off a 0 (sizeofSmallArray a) >> go (off + sizeofSmallArray a) as in go 0 l- where n = sum . fmap length $ l+ where n = sum (fmap length l) instance IsList (SmallArray a) where type Item (SmallArray a) = a@@ -931,7 +799,6 @@ instance Show a => Show (SmallArray a) where showsPrec p sa = smallArrayLiftShowsPrec showsPrec showList p sa -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Show1 SmallArray where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)@@ -939,7 +806,6 @@ #else showsPrec1 = smallArrayLiftShowsPrec showsPrec showList #endif-#endif smallArrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (SmallArray a) smallArrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do@@ -953,7 +819,6 @@ instance Read a => Read (SmallArray a) where readsPrec = smallArrayLiftReadsPrec readsPrec readList -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Read1 SmallArray where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)@@ -961,7 +826,6 @@ #else readsPrec1 = smallArrayLiftReadsPrec readsPrec readList #endif-#endif @@ -984,12 +848,10 @@ toConstr _ = die "toConstr" "SmallMutableArray" gunfold _ _ = die "gunfold" "SmallMutableArray" dataTypeOf _ = mkNoRepType "Data.Primitive.SmallArray.SmallMutableArray"-#endif -- | Create a 'SmallArray' from a list of a known length. If the length--- of the list does not match the given length, this throws an exception.+-- of the list does not match the given length, this throws an exception. smallArrayFromListN :: Int -> [a] -> SmallArray a-#if HAVE_SMALL_ARRAY smallArrayFromListN n l = createSmallArray n (die "smallArrayFromListN" "uninitialized element") $ \sma ->@@ -999,12 +861,9 @@ go !ix (x : xs) = if ix < n then do writeSmallArray sma ix x- go (ix+1) xs+ go (ix + 1) xs else die "smallArrayFromListN" "list length greater than specified size" in go 0 l-#else-smallArrayFromListN n l = SmallArray (Array.fromListN n l)-#endif -- | Create a 'SmallArray' from a list. smallArrayFromList :: [a] -> SmallArray a
Data/Primitive/Types.hs view
@@ -16,72 +16,42 @@ -- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> -- Portability : non-portable ----- Basic types and classes for primitive array operations---+-- Basic types and classes for primitive array operations. -module Data.Primitive.Types (- Prim(..)- ,sizeOf, alignment, defaultSetByteArray#, defaultSetOffAddr#- ,PrimStorable(..)- ,Ptr(..)-) where+module Data.Primitive.Types+ ( Prim(..)+ , sizeOf, alignment, defaultSetByteArray#, defaultSetOffAddr#+ , PrimStorable(..)+ , Ptr(..)+ ) where import Control.Monad.Primitive import Data.Primitive.MachDeps import Data.Primitive.Internal.Operations-import Foreign.Ptr (IntPtr,intPtrToPtr,ptrToIntPtr)-import Foreign.Ptr (WordPtr,wordPtrToPtr,ptrToWordPtr)+import Foreign.Ptr (IntPtr, intPtrToPtr, ptrToIntPtr, WordPtr, wordPtrToPtr, ptrToWordPtr) import Foreign.C.Types import System.Posix.Types -import GHC.Base (- Int(..), Char(..),- )-import GHC.Float (- Float(..), Double(..)- )-import GHC.Word (- Word(..), Word8(..), Word16(..), Word32(..), Word64(..)- )-import GHC.Int (- Int8(..), Int16(..), Int32(..), Int64(..)- )--import GHC.Ptr (- Ptr(..), FunPtr(..)- )-import GHC.Stable (- StablePtr(..)- )+import GHC.Word (Word8(..), Word16(..), Word32(..), Word64(..))+import GHC.Int (Int8(..), Int16(..), Int32(..), Int64(..)) -import GHC.Exts-#if __GLASGOW_HASKELL__ >= 706- hiding (setByteArray#)-#endif+import GHC.Stable (StablePtr(..)) +import GHC.Exts hiding (setByteArray#) -import Data.Primitive.Internal.Compat ( isTrue# ) import Foreign.Storable (Storable) import qualified Foreign.Storable as FS -#if __GLASGOW_HASKELL__ >= 710 import GHC.IO (IO(..)) import qualified GHC.Exts-#endif import Control.Applicative (Const(..))-#if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity(..)) import qualified Data.Monoid as Monoid-#endif-#if MIN_VERSION_base(4,6,0) import Data.Ord (Down(..))-#else-import GHC.Exts (Down(..))-#endif #if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as Semigroup #endif@@ -91,9 +61,8 @@ -- and interfacing with unmanaged memory (functions suffixed with @Addr#@). -- Endianness is platform-dependent. class Prim a where- -- | Size of values of type @a@. The argument is not used.- sizeOf# :: a -> Int#+ sizeOf# :: a -> Int# -- | Alignment of values of type @a@. The argument is not used. alignment# :: a -> Int#@@ -112,7 +81,13 @@ -- | Fill a slice of the mutable array with a value. The offset and length -- of the chunk are in elements of type @a@ rather than in bytes.- setByteArray# :: MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s+ setByteArray#+ :: MutableByteArray# s+ -> Int# -- ^ offset+ -> Int# -- ^ length+ -> a+ -> State# s+ -> State# s -- | Read a value from a memory position given by an address and an offset. -- The memory block the address refers to must be immutable. The offset is in@@ -129,25 +104,31 @@ -- | Fill a memory block given by an address, an offset and a length. -- The offset and length are in elements of type @a@ rather than in bytes.- setOffAddr# :: Addr# -> Int# -> Int# -> a -> State# s -> State# s+ setOffAddr#+ :: Addr#+ -> Int# -- ^ offset+ -> Int# -- ^ length+ -> a+ -> State# s+ -> State# s -- | Size of values of type @a@. The argument is not used. -- -- This function has existed since 0.1, but was moved from 'Data.Primitive'--- to 'Data.Primitive.Types' in version 0.6.3.0+-- to 'Data.Primitive.Types' in version 0.6.3.0. sizeOf :: Prim a => a -> Int sizeOf x = I# (sizeOf# x) -- | Alignment of values of type @a@. The argument is not used. -- -- This function has existed since 0.1, but was moved from 'Data.Primitive'--- to 'Data.Primitive.Types' in version 0.6.3.0+-- to 'Data.Primitive.Types' in version 0.6.3.0. alignment :: Prim a => a -> Int alignment x = I# (alignment# x) -- | An implementation of 'setByteArray#' that calls 'writeByteArray#' -- to set each element. This is helpful when writing a 'Prim' instance--- for a multi-word data type for which there is no cpu-accelerated way+-- for a multi-word data type for which there is no CPU-accelerated way -- to broadcast a value to contiguous memory. It is typically used -- alongside 'defaultSetOffAddr#'. For example: --@@ -214,40 +195,40 @@ writeOffAddr# addr# i# a s# #define derivePrim(ty, ctr, sz, align, idx_arr, rd_arr, wr_arr, set_arr, idx_addr, rd_addr, wr_addr, set_addr) \-instance Prim (ty) where { \- sizeOf# _ = unI# sz \-; alignment# _ = unI# align \-; indexByteArray# arr# i# = ctr (idx_arr arr# i#) \-; readByteArray# arr# i# s# = case rd_arr arr# i# s# of \- { (# s1#, x# #) -> (# s1#, ctr x# #) } \-; writeByteArray# arr# i# (ctr x#) s# = wr_arr arr# i# x# s# \-; setByteArray# arr# i# n# (ctr x#) s# \- = let { i = fromIntegral (I# i#) \- ; n = fromIntegral (I# n#) \- } in \- case unsafeCoerce# (internal (set_arr arr# i n x#)) s# of \- { (# s1#, _ #) -> s1# } \- \-; indexOffAddr# addr# i# = ctr (idx_addr addr# i#) \-; readOffAddr# addr# i# s# = case rd_addr addr# i# s# of \- { (# s1#, x# #) -> (# s1#, ctr x# #) } \-; writeOffAddr# addr# i# (ctr x#) s# = wr_addr addr# i# x# s# \-; setOffAddr# addr# i# n# (ctr x#) s# \- = let { i = fromIntegral (I# i#) \- ; n = fromIntegral (I# n#) \- } in \+instance Prim (ty) where { \+ sizeOf# _ = unI# sz \+; alignment# _ = unI# align \+; indexByteArray# arr# i# = ctr (idx_arr arr# i#) \+; readByteArray# arr# i# s# = case rd_arr arr# i# s# of \+ { (# s1#, x# #) -> (# s1#, ctr x# #) } \+; writeByteArray# arr# i# (ctr x#) s# = wr_arr arr# i# x# s# \+; setByteArray# arr# i# n# (ctr x#) s# \+ = let { i = fromIntegral (I# i#) \+ ; n = fromIntegral (I# n#) \+ } in \+ case unsafeCoerce# (internal (set_arr arr# i n x#)) s# of \+ { (# s1#, _ #) -> s1# } \+ \+; indexOffAddr# addr# i# = ctr (idx_addr addr# i#) \+; readOffAddr# addr# i# s# = case rd_addr addr# i# s# of \+ { (# s1#, x# #) -> (# s1#, ctr x# #) } \+; writeOffAddr# addr# i# (ctr x#) s# = wr_addr addr# i# x# s# \+; setOffAddr# addr# i# n# (ctr x#) s# \+ = let { i = fromIntegral (I# i#) \+ ; n = fromIntegral (I# n#) \+ } in \ case unsafeCoerce# (internal (set_addr addr# i n x#)) s# of \- { (# s1#, _ #) -> s1# } \-; {-# INLINE sizeOf# #-} \-; {-# INLINE alignment# #-} \-; {-# INLINE indexByteArray# #-} \-; {-# INLINE readByteArray# #-} \-; {-# INLINE writeByteArray# #-} \-; {-# INLINE setByteArray# #-} \-; {-# INLINE indexOffAddr# #-} \-; {-# INLINE readOffAddr# #-} \-; {-# INLINE writeOffAddr# #-} \-; {-# INLINE setOffAddr# #-} \+ { (# s1#, _ #) -> s1# } \+; {-# INLINE sizeOf# #-} \+; {-# INLINE alignment# #-} \+; {-# INLINE indexByteArray# #-} \+; {-# INLINE readByteArray# #-} \+; {-# INLINE writeByteArray# #-} \+; {-# INLINE setByteArray# #-} \+; {-# INLINE indexOffAddr# #-} \+; {-# INLINE readOffAddr# #-} \+; {-# INLINE writeOffAddr# #-} \+; {-# INLINE setOffAddr# #-} \ } #if __GLASGOW_HASKELL__ >= 902@@ -257,18 +238,13 @@ shimmedSetWord8Array# m (I# off) (I# len) w = IO (\s -> (# liberate# (GHC.Exts.setByteArray# m off len (GHC.Exts.word2Int# (GHC.Exts.word8ToWord# w)) (liberate# s)), () #)) shimmedSetInt8Array# :: MutableByteArray# s -> Int -> Int -> Int8# -> IO () shimmedSetInt8Array# m (I# off) (I# len) i = IO (\s -> (# liberate# (GHC.Exts.setByteArray# m off len (GHC.Exts.int8ToInt# i) (liberate# s)), () #))-#elif __GLASGOW_HASKELL__ >= 710+#else liberate# :: State# s -> State# r liberate# = unsafeCoerce# shimmedSetWord8Array# :: MutableByteArray# s -> Int -> Int -> Word# -> IO () shimmedSetWord8Array# m (I# off) (I# len) w = IO (\s -> (# liberate# (GHC.Exts.setByteArray# m off len (GHC.Exts.word2Int# w) (liberate# s)), () #)) shimmedSetInt8Array# :: MutableByteArray# s -> Int -> Int -> Int# -> IO () shimmedSetInt8Array# m (I# off) (I# len) i = IO (\s -> (# liberate# (GHC.Exts.setByteArray# m off len i (liberate# s)), () #))-#else-shimmedSetWord8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO ()-shimmedSetWord8Array# = setWord8Array#-shimmedSetInt8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO ()-shimmedSetInt8Array# = setInt8Array# #endif unI# :: Int -> Int#@@ -460,7 +436,6 @@ deriving instance Prim a => Prim (Const a b) -- | @since 0.6.5.0 deriving instance Prim a => Prim (Down a)-#if MIN_VERSION_base(4,8,0) -- | @since 0.6.5.0 deriving instance Prim a => Prim (Identity a) -- | @since 0.6.5.0@@ -469,7 +444,6 @@ deriving instance Prim a => Prim (Monoid.Sum a) -- | @since 0.6.5.0 deriving instance Prim a => Prim (Monoid.Product a)-#endif #if MIN_VERSION_base(4,9,0) -- | @since 0.6.5.0 deriving instance Prim a => Prim (Semigroup.First a)
− Setup.hs
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
+ bench/Array/Traverse/Closure.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MagicHash #-}++module Array.Traverse.Closure+ ( traversePoly+ ) where++import Control.Applicative+import Control.Monad.ST+import Data.Primitive.Array+import GHC.Exts (Int(..),MutableArray#)++{-# INLINE traversePoly #-}+traversePoly+ :: Applicative f+ => (a -> f b)+ -> Array a+ -> f (Array b)+traversePoly f = \ !ary ->+ let+ !len = sizeofArray ary+ go !i+ | i == len = pure $ STA $ \mary -> unsafeFreezeArray (MutableArray mary)+ | (# x #) <- indexArray## ary i+ = liftA2 (\b (STA m) -> STA $ \mary ->+ writeArray (MutableArray mary) i b >> m mary)+ (f x) (go (i + 1))+ in if len == 0+ then pure mempty+ else runSTA len <$> go 0++badTraverseValue :: a+badTraverseValue = die "traversePoly" "bad indexing"+{-# NOINLINE badTraverseValue #-}++die :: String -> String -> a+die fun problem = error $ "Array.Traverse.Closure" ++ fun ++ ": " ++ problem++newtype STA a = STA {_runSTA :: forall s. MutableArray# s a -> ST s (Array a)}++runSTA :: Int -> STA a -> Array a+runSTA !sz = \ (STA m) -> runST $ newArray_ sz >>= \ ar -> m (marray# ar)+{-# INLINE runSTA #-}++newArray_ :: Int -> ST s (MutableArray s a)+newArray_ !n = newArray n badTraverseValue+
+ bench/Array/Traverse/Unsafe.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE BangPatterns #-}++module Array.Traverse.Unsafe+ ( traversePoly+ , traverseMono+ ) where++import Control.Monad.ST+import Control.Monad.Trans.State.Strict+import Control.Monad.Primitive+import Data.Primitive.Array++{-# INLINE traversePoly #-}+traversePoly+ :: PrimMonad m+ => (a -> m b)+ -> Array a+ -> m (Array b)+traversePoly f = \ !ary ->+ let+ !sz = sizeofArray ary+ go !i !mary+ | i == sz+ = unsafeFreezeArray mary+ | otherwise+ = do+ a <- indexArrayM ary i+ b <- f a+ writeArray mary i b+ go (i + 1) mary+ in do+ mary <- newArray sz badTraverseValue+ go 0 mary++badTraverseValue :: a+badTraverseValue = die "traversePoly" "bad indexing"+{-# NOINLINE badTraverseValue #-}++die :: String -> String -> a+die fun problem = error $ "Array.Traverse.Unsafe" ++ fun ++ ": " ++ problem++-- Included to make it easy to inspect GHC Core that results+-- from inlining traversePoly.+traverseMono :: + (Int -> StateT Word (ST s) Int)+ -> Array Int+ -> StateT Word (ST s) (Array Int)+traverseMono f x = traversePoly f x
+ bench/ByteArray/Compare.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++module ByteArray.Compare+ ( benchmark+ , argumentSmall+ , argumentMedium+ , argumentLarge+ ) where++import Data.Primitive+import Data.Word+import Control.Monad+import Control.Monad.ST (runST)+import GHC.Exts (fromList)++-- This takes the cross product of the argument with itself+-- and compares each pair of combined ByteArrays. In other words,+-- it compare every ByteArray to every other ByteArray (including+-- itself). This is does efficiently and should not allocate+-- any memory.+benchmark :: Array ByteArray -> Int+benchmark !uarr = outer 0+ where+ sz = sizeofArray uarr+ outer :: Int -> Int+ outer !v0 =+ let go !v !ix = if ix < sz+ then go (inner v (indexArray uarr ix)) (ix + 1)+ else v+ in go v0 0+ inner :: Int -> ByteArray -> Int+ inner !v0 !barr =+ let go !v !ix = if ix < sz+ then+ let !y = case compare barr (indexArray uarr ix) of+ LT -> (-1)+ EQ -> 0+ GT -> 1+ in go (v + y) (ix + 1)+ else v+ in go v0 0++-- This is an array of all byte arrays consistent of the bytes 0 and 1+-- bewteen length 0 and 7 inclusive:+--+-- []+-- [0]+-- [1]+-- [0,0]+-- [0,1]+-- ...+-- [1,1,1,1,1,1,0]+-- [1,1,1,1,1,1,1]+--+-- These are very small byte arrays. All of them are smaller than a+-- cache line. A comparison function that uses the FFI may perform+-- worse on such inputs than one that does not.+argumentSmall :: Array ByteArray+argumentSmall = runST $ do+ let (ys :: [[Word8]]) = foldMap (\n -> replicateM n [0,1]) (enumFromTo 0 7)+ marr <- newArray (length ys) undefined+ let go !_ [] = return ()+ go !ix (x : xs) = do+ writeArray marr ix (fromList x)+ go (ix + 1) xs+ go 0 ys+ unsafeFreezeArray marr+++-- This is an array of all byte arrays consistent of the bytes 0 and 1+-- bewteen length 0 and 7 inclusive. However, they are all padded on the+-- left by the same 256 bytes. Comparing any two of them will require+-- walking and comparing the first 256 bytes.+argumentMedium :: Array ByteArray+argumentMedium = runST $ do+ let (ys :: [[Word8]]) = foldMap (\n -> map (enumFromTo 0 255 ++) (replicateM n [0,1])) (enumFromTo 0 7)+ marr <- newArray (length ys) undefined+ let go !_ [] = return ()+ go !ix (x : xs) = do+ writeArray marr ix (fromList x)+ go (ix + 1) xs+ go 0 ys+ unsafeFreezeArray marr++-- Same thing but with left padding of 1024 bytes.+argumentLarge :: Array ByteArray+argumentLarge = runST $ do+ let (ys :: [[Word8]]) = foldMap (\n -> map (concat (replicate 4 (enumFromTo 0 255)) ++) (replicateM n [0,1])) (enumFromTo 0 7)+ marr <- newArray (length ys) undefined+ let go !_ [] = return ()+ go !ix (x : xs) = do+ writeArray marr ix (fromList x)+ go (ix + 1) xs+ go 0 ys+ unsafeFreezeArray marr
+ bench/PrimArray/Compare.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++module PrimArray.Compare+ ( benchmarkLt+ , benchmarkLtDef+ , benchmarkLte+ , benchmarkLteDef+ , argumentA+ , argumentB+ ) where++import Data.Primitive+import Data.Word+import Control.Monad+import Control.Monad.ST (runST)+import GHC.Exts (fromList)++benchmarkLtDef :: PrimArray Int -> PrimArray Int -> Bool+benchmarkLtDef a b = case compare a b of+ LT -> True+ _ -> False++benchmarkLteDef :: PrimArray Int -> PrimArray Int -> Bool+benchmarkLteDef a b = case compare a b of+ GT -> False+ _ -> True++benchmarkLt :: PrimArray Int -> PrimArray Int -> Bool+benchmarkLt a b =+ let !sz1 = sizeofPrimArray a+ !sz2 = sizeofPrimArray b+ !sz = min sz1 sz2+ loop !i+ | i < sz = if indexPrimArray a i < indexPrimArray b i+ then True+ else loop (i + 1)+ | otherwise = sz1 < sz2+ in loop 0++benchmarkLte :: PrimArray Int -> PrimArray Int -> Bool+benchmarkLte a b =+ let !sz1 = sizeofPrimArray a+ !sz2 = sizeofPrimArray b+ !sz = min sz1 sz2+ loop !i+ | i < sz = if indexPrimArray a i <= indexPrimArray b i+ then loop (i + 1)+ else False+ | otherwise = sz1 < sz2+ in loop 0++argumentA :: PrimArray Int+argumentA = fromList (enumFromTo 0 8000 ++ [55])++argumentB :: PrimArray Int+argumentB = fromList (enumFromTo 0 8000 ++ [56])+
+ bench/PrimArray/Traverse.hs view
@@ -0,0 +1,23 @@+module PrimArray.Traverse+ ( benchmarkApplicative+ , benchmarkPrimMonad+ , argument+ ) where++import Control.Monad.ST (runST)+import Control.Monad.Trans.Maybe (MaybeT(..))+import Data.Bool (bool)+import Data.Primitive.PrimArray+import GHC.Exts (fromList)++benchmarkApplicative :: PrimArray Int -> Maybe (PrimArray Int)+benchmarkApplicative xs = traversePrimArray (\x -> bool Nothing (Just (x + 1)) (x > 0)) xs++benchmarkPrimMonad :: PrimArray Int -> Maybe (PrimArray Int)+benchmarkPrimMonad xs = runST $ runMaybeT $ traversePrimArrayP+ (\x -> bool (MaybeT (return Nothing)) (MaybeT (return (Just (x + 1)))) (x > 0))+ xs++argument :: PrimArray Int+argument = fromList (enumFromTo 1 10000)+
+ bench/main.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++import Test.Tasty.Bench+import Control.Monad.ST+import Data.Primitive+import Control.Monad.Trans.State.Strict++-- These are fixed implementations of certain operations. In the event+-- that primitive changes its implementation of a function, these+-- implementations stay the same. They are helpful for ensuring that+-- something that is a performance win in one version of GHC doesn't+-- become a regression later. They are also helpful for evaluating+-- how well different implementation hold up in different scenarios.+import qualified Array.Traverse.Unsafe+import qualified Array.Traverse.Closure++-- These are particular scenarios that are tested against the+-- implementations actually used by primitive.+import qualified ByteArray.Compare+import qualified PrimArray.Compare+import qualified PrimArray.Traverse++main :: IO ()+main = defaultMain+ [ bgroup "Array"+ [ bgroup "implementations"+ [ bgroup "traverse"+ [ bench "closure" (nf (\x -> runST (runStateT (Array.Traverse.Closure.traversePoly cheap x) 0)) numbers)+ , bench "unsafe" (nf (\x -> runST (runStateT (Array.Traverse.Unsafe.traversePoly cheap x) 0)) numbers)+ ]+ ]+ ]+ , bgroup "ByteArray"+ [ bgroup "compare"+ [ bench "small" (whnf ByteArray.Compare.benchmark ByteArray.Compare.argumentSmall)+ , bench "medium" (whnf ByteArray.Compare.benchmark ByteArray.Compare.argumentMedium)+ , bench "large" (whnf ByteArray.Compare.benchmark ByteArray.Compare.argumentLarge)+ ]+ ]+ , bgroup "PrimArray"+ [ bgroup "traverse"+ [ bgroup "Maybe"+ [ bench "Applicative" (whnf PrimArray.Traverse.benchmarkApplicative PrimArray.Traverse.argument)+ , bench "PrimMonad" (whnf PrimArray.Traverse.benchmarkPrimMonad PrimArray.Traverse.argument)+ ]+ ]+ , bgroup "implementations"+ [ bgroup "less-than"+ [ bench "default" (whnf (PrimArray.Compare.benchmarkLtDef PrimArray.Compare.argumentA) PrimArray.Compare.argumentB)+ , bench "override" (whnf (PrimArray.Compare.benchmarkLt PrimArray.Compare.argumentA) PrimArray.Compare.argumentB)+ ]+ , bgroup "less-than-equal"+ [ bench "default" (whnf (PrimArray.Compare.benchmarkLteDef PrimArray.Compare.argumentA) PrimArray.Compare.argumentB)+ , bench "override" (whnf (PrimArray.Compare.benchmarkLte PrimArray.Compare.argumentA) PrimArray.Compare.argumentB)+ ]+ ]+ ]+ ]++cheap :: Int -> StateT Int (ST s) Int+cheap i = modify (\x -> x + i) >> return (i * i)++numbers :: Array Int+numbers = fromList (enumFromTo 0 10000)
cbits/primitive-memops.h view
@@ -7,20 +7,19 @@ #include <stdlib.h> #include <stddef.h> -void hsprimitive_memcpy( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len );-void hsprimitive_memmove( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len );-int hsprimitive_memcmp( HsWord8 *s1, HsWord8 *s2, size_t n );-int hsprimitive_memcmp_offset( HsWord8 *s1, HsInt off1, HsWord8 *s2, HsInt off2, size_t n );+void hsprimitive_memcpy(void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len);+void hsprimitive_memmove(void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len);+int hsprimitive_memcmp(HsWord8 *s1, HsWord8 *s2, size_t n);+int hsprimitive_memcmp_offset(HsWord8 *s1, HsInt off1, HsWord8 *s2, HsInt off2, size_t n); -void hsprimitive_memset_Word8 (HsWord8 *, ptrdiff_t, size_t, HsWord8);-void hsprimitive_memset_Word16 (HsWord16 *, ptrdiff_t, size_t, HsWord16);-void hsprimitive_memset_Word32 (HsWord32 *, ptrdiff_t, size_t, HsWord32);-void hsprimitive_memset_Word64 (HsWord64 *, ptrdiff_t, size_t, HsWord64);-void hsprimitive_memset_Word (HsWord *, ptrdiff_t, size_t, HsWord);-void hsprimitive_memset_Ptr (HsPtr *, ptrdiff_t, size_t, HsPtr);-void hsprimitive_memset_Float (HsFloat *, ptrdiff_t, size_t, HsFloat);-void hsprimitive_memset_Double (HsDouble *, ptrdiff_t, size_t, HsDouble);-void hsprimitive_memset_Char (HsChar *, ptrdiff_t, size_t, HsChar);+void hsprimitive_memset_Word8(HsWord8 *, ptrdiff_t, size_t, HsWord8);+void hsprimitive_memset_Word16(HsWord16 *, ptrdiff_t, size_t, HsWord16);+void hsprimitive_memset_Word32(HsWord32 *, ptrdiff_t, size_t, HsWord32);+void hsprimitive_memset_Word64(HsWord64 *, ptrdiff_t, size_t, HsWord64);+void hsprimitive_memset_Word(HsWord *, ptrdiff_t, size_t, HsWord);+void hsprimitive_memset_Ptr(HsPtr *, ptrdiff_t, size_t, HsPtr);+void hsprimitive_memset_Float(HsFloat *, ptrdiff_t, size_t, HsFloat);+void hsprimitive_memset_Double(HsDouble *, ptrdiff_t, size_t, HsDouble);+void hsprimitive_memset_Char(HsChar *, ptrdiff_t, size_t, HsChar); #endif-
changelog.md view
@@ -1,3 +1,15 @@+## Changes in version 0.7.3.0++ * Correct implementations of `*>` for `Array` and `SmallArray`.++ * Drop support for GHC < 7.10++ * Export `runByteArray` and `runPrimArray`.++ * Export `createArray` and `createSmallArray`.++ * Export `emptyByteArray`, `emptyPrimArray`, `emptyArray` and `emptySmallArray`.+ ## Changes in version 0.7.2.0 * Add `thawByteArray` and `thawPrimArray`.@@ -29,7 +41,7 @@ * Add `NFData` instances for `ByteArray`, `MutableByteArray`, `PrimArray` and `MutablePrimArray`. by Callan McGill- + * Add `shrinkSmallMutableArray`. * Add `clonePrimArray` and `cloneMutablePrimArray`.
primitive.cabal view
@@ -1,6 +1,6 @@-Cabal-Version: 2.2+Cabal-Version: 2.2 Name: primitive-Version: 0.7.2.0+Version: 0.7.3.0 License: BSD-3-Clause License-File: LICENSE @@ -19,16 +19,13 @@ test/LICENSE Tested-With:- GHC == 7.4.2,- GHC == 7.6.3,- GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5,- GHC == 8.8.3,- GHC == 8.10.1+ GHC == 8.8.4,+ GHC == 8.10.7 Library Default-Language: Haskell2010@@ -50,12 +47,11 @@ Data.Primitive.MVar Other-Modules:- Data.Primitive.Internal.Compat Data.Primitive.Internal.Operations - Build-Depends: base >= 4.5 && < 4.17+ Build-Depends: base >= 4.8 && < 4.17 , deepseq >= 1.1 && < 1.5- , transformers >= 0.2 && < 0.7+ , transformers >= 0.4.2 && < 0.7 if !impl(ghc >= 8.0) Build-Depends: fail == 4.9.* @@ -81,20 +77,37 @@ , base-orphans , ghc-prim , primitive- , quickcheck-classes-base >=0.6 && <0.7+ , quickcheck-classes-base >= 0.6 && <0.7 , QuickCheck >= 2.13 && < 2.15 , tasty ^>= 1.2 || ^>= 1.3 || ^>= 1.4 , tasty-quickcheck , tagged- , transformers >=0.4+ , transformers >= 0.4 , transformers-compat if !impl(ghc >= 8.0) build-depends: semigroups - cpp-options: -DHAVE_UNARY_LAWS+ cpp-options: -DHAVE_UNARY_LAWS ghc-options: -O2 -+benchmark bench+ Default-Language: Haskell2010+ hs-source-dirs: bench+ main-is: main.hs+ type: exitcode-stdio-1.0+ ghc-options: -O2+ other-modules:+ Array.Traverse.Closure+ Array.Traverse.Unsafe+ ByteArray.Compare+ PrimArray.Compare+ PrimArray.Traverse+ build-depends:+ base+ , primitive+ , deepseq+ , tasty-bench+ , transformers >= 0.3 source-repository head type: git
test/main.hs view
@@ -28,18 +28,9 @@ import Control.Applicative (Const(..)) import PrimLaws (primLaws) -#if !(MIN_VERSION_base(4,8,0))-import Data.Monoid (Monoid(..))-#endif-#if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity(..)) import qualified Data.Monoid as Monoid-#endif-#if MIN_VERSION_base(4,6,0) import Data.Ord (Down(..))-#else-import GHC.Exts (Down(..))-#endif #if MIN_VERSION_base(4,9,0) import Data.Semigroup (stimes) import qualified Data.Semigroup as Semigroup@@ -70,34 +61,30 @@ , lawsToTest (QCC.ordLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))-#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 Array)) , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 Array)) , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 Array)) , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 Array)) , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 Array))-#endif-#if MIN_VERSION_base(4,7,0) , lawsToTest (QCC.isListLaws (Proxy :: Proxy (Array Int))) , TQC.testProperty "mapArray'" (QCCL.mapProp int16 int32 mapArray')-#endif+ , TQC.testProperty "*>" $ \(xs :: Array Int) (ys :: Array Int) -> toList (xs *> ys) === (toList xs *> toList ys)+ , TQC.testProperty "<*" $ \(xs :: Array Int) (ys :: Array Int) -> toList (xs <* ys) === (toList xs <* toList ys) ] , testGroup "SmallArray" [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SmallArray Int))) , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SmallArray Int))) , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (SmallArray Int))) , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))-#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 SmallArray)) , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 SmallArray)) , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 SmallArray)) , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 SmallArray)) , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 SmallArray))-#endif-#if MIN_VERSION_base(4,7,0) , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SmallArray Int))) , TQC.testProperty "mapSmallArray'" (QCCL.mapProp int16 int32 mapSmallArray')-#endif+ , TQC.testProperty "*>" $ \(xs :: SmallArray Int) (ys :: SmallArray Int) -> toList (xs *> ys) === (toList xs *> toList ys)+ , TQC.testProperty "<*" $ \(xs :: SmallArray Int) (ys :: SmallArray Int) -> toList (xs <* ys) === (toList xs <* toList ys) ] , testGroup "ByteArray" [ testGroup "Ordering"@@ -123,16 +110,13 @@ , lawsToTest (QCC.eqLaws (Proxy :: Proxy ByteArray)) , lawsToTest (QCC.ordLaws (Proxy :: Proxy ByteArray)) , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))-#if MIN_VERSION_base(4,7,0) , lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray)) , TQC.testProperty "foldrByteArray" (QCCL.foldrProp word8 foldrByteArray)-#endif ] , testGroup "PrimArray" [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (PrimArray Word16))) , lawsToTest (QCC.ordLaws (Proxy :: Proxy (PrimArray Word16))) , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (PrimArray Word16)))-#if MIN_VERSION_base(4,7,0) , lawsToTest (QCC.isListLaws (Proxy :: Proxy (PrimArray Word16))) , TQC.testProperty "foldrPrimArray" (QCCL.foldrProp int16 foldrPrimArray) , TQC.testProperty "foldrPrimArray'" (QCCL.foldrProp int16 foldrPrimArray')@@ -157,20 +141,16 @@ , TQC.testProperty "mapMaybePrimArray" (QCCL.mapMaybeProp int16 int32 mapMaybePrimArray) , TQC.testProperty "mapMaybePrimArrayA" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayA) , TQC.testProperty "mapMaybePrimArrayP" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayP)-#endif ]---- ,testGroup "DefaultSetMethod"+ , testGroup "DefaultSetMethod" [ lawsToTest (primLaws (Proxy :: Proxy DefaultSetMethod)) ] #if __GLASGOW_HASKELL__ >= 805- ,testGroup "PrimStorable"+ , testGroup "PrimStorable" [ lawsToTest (QCC.storableLaws (Proxy :: Proxy Derived)) ] #endif- ,testGroup "Prim"+ , testGroup "Prim" [ renameLawsToTest "Word" (primLaws (Proxy :: Proxy Word)) , renameLawsToTest "Word8" (primLaws (Proxy :: Proxy Word8)) , renameLawsToTest "Word16" (primLaws (Proxy :: Proxy Word16))@@ -183,21 +163,17 @@ , renameLawsToTest "Int64" (primLaws (Proxy :: Proxy Int64)) , renameLawsToTest "Const" (primLaws (Proxy :: Proxy (Const Int16 Int16))) , renameLawsToTest "Down" (primLaws (Proxy :: Proxy (Down Int16)))-#if MIN_VERSION_base(4,8,0) , renameLawsToTest "Identity" (primLaws (Proxy :: Proxy (Identity Int16))) , renameLawsToTest "Dual" (primLaws (Proxy :: Proxy (Monoid.Dual Int16))) , renameLawsToTest "Sum" (primLaws (Proxy :: Proxy (Monoid.Sum Int16))) , renameLawsToTest "Product" (primLaws (Proxy :: Proxy (Monoid.Product Int16)))-#endif #if MIN_VERSION_base(4,9,0) , renameLawsToTest "First" (primLaws (Proxy :: Proxy (Semigroup.First Int16))) , renameLawsToTest "Last" (primLaws (Proxy :: Proxy (Semigroup.Last Int16))) , renameLawsToTest "Min" (primLaws (Proxy :: Proxy (Semigroup.Min Int16))) , renameLawsToTest "Max" (primLaws (Proxy :: Proxy (Semigroup.Max Int16))) #endif- ]- ] deriving instance Arbitrary a => Arbitrary (Down a)
test/src/PrimLaws.hs view
@@ -28,9 +28,7 @@ import Foreign.Marshal.Alloc import GHC.Exts (State#,Int#,Int(I#),(+#),(<#)) -#if MIN_VERSION_base(4,7,0) import GHC.Exts (IsList(fromList,toList))-#endif import System.IO.Unsafe import Test.QuickCheck hiding ((.&.))@@ -48,9 +46,7 @@ , ("ByteArray Get-Put (putting back what you got out has no effect)", primGetPutByteArray p) , ("ByteArray Put-Put (putting twice is same as putting once)", primPutPutByteArray p) , ("ByteArray Set Range", primSetByteArray p)-#if MIN_VERSION_base(4,7,0) , ("ByteArray List Conversion Roundtrips", primListByteArray p)-#endif , ("Ptr Put-Get (you get back what you put in)", primPutGetAddr p) , ("Ptr List Conversion Roundtrips", primListAddr p) ]@@ -142,11 +138,9 @@ arr3 <- unsafeFreezePrimArray marr3 return (arr2 == arr3) -#if MIN_VERSION_base(4,7,0) primListByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primListByteArray _ = property $ \(as :: [a]) -> as == toList (fromList as :: PrimArray a)-#endif internalDefaultSetPrimArray :: Prim a => MutablePrimArray s a -> Int -> Int -> a -> ST s ()