primitive 0.8.0.0 → 0.9.1.0
raw patch · 18 files changed
Files
- Control/Monad/Primitive.hs +49/−8
- Data/Primitive.hs +5/−6
- Data/Primitive/Array.hs +37/−60
- Data/Primitive/ByteArray.hs +120/−51
- Data/Primitive/Internal/Operations.hs +68/−1
- Data/Primitive/Internal/Read.hs +27/−0
- Data/Primitive/MVar.hs +0/−1
- Data/Primitive/MutVar.hs +30/−2
- Data/Primitive/PrimArray.hs +146/−130
- Data/Primitive/Ptr.hs +6/−5
- Data/Primitive/SmallArray.hs +84/−36
- Data/Primitive/Types.hs +109/−24
- bench/main.hs +17/−1
- changelog.md +51/−0
- primitive.cabal +13/−11
- test/Main.hs +439/−0
- test/main.hs +0/−434
- test/src/PrimLaws.hs +4/−7
Control/Monad/Primitive.hs view
@@ -2,6 +2,10 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif {-# OPTIONS_GHC -fno-warn-deprecations #-} -- |@@ -22,14 +26,19 @@ liftPrim, primToPrim, primToIO, primToST, ioToPrim, stToPrim, unsafePrimToPrim, unsafePrimToIO, unsafePrimToST, unsafeIOToPrim, unsafeSTToPrim, unsafeInlinePrim, unsafeInlineIO, unsafeInlineST,- touch, keepAlive, evalPrim, unsafeInterleave, unsafeDupableInterleave, noDuplicate+ touch, touchUnlifted,+ keepAlive, keepAliveUnlifted,+ evalPrim, unsafeInterleave, unsafeDupableInterleave, noDuplicate ) where +import Data.Kind (Type)+ import GHC.Exts ( State#, RealWorld, noDuplicate#, touch#+ , unsafeCoerce#, realWorld#, seq# )+import Data.Primitive.Internal.Operations (UnliftedType) #if defined(HAVE_KEEPALIVE)- , keepAlive#+import Data.Primitive.Internal.Operations (keepAliveLiftedLifted#,keepAliveUnliftedLifted#) #endif- , unsafeCoerce#, realWorld#, seq# ) import GHC.IO ( IO(..) ) import GHC.ST ( ST(..) ) @@ -230,14 +239,14 @@ {-# INLINE internal #-} #endif --- | 'PrimMonad''s state token type can be annoying to handle+-- | 'PrimMonad'\'s state token type can be annoying to handle -- in constraints. This typeclass lets users (visually) notice -- 'PrimState' equality constraints less, by witnessing that -- @s ~ 'PrimState' m@. class (PrimMonad m, s ~ PrimState m) => MonadPrim s m instance (PrimMonad m, s ~ PrimState m) => MonadPrim s m --- | 'PrimBase''s state token type can be annoying to handle+-- | 'PrimBase'\'s state token type can be annoying to handle -- in constraints. This typeclass lets users (visually) notice -- 'PrimState' equality constraints less, by witnessing that -- @s ~ 'PrimState' m@.@@ -335,18 +344,50 @@ {-# INLINE unsafeInlineST #-} unsafeInlineST = unsafeInlinePrim +-- | Ensure that the value is considered alive by the garbage collection.+-- Warning: GHC has optimization passes that can erase @touch@ if it is+-- certain that an exception is thrown afterward. Prefer 'keepAlive'. touch :: PrimMonad m => a -> m () {-# INLINE touch #-} touch x = unsafePrimToPrim $ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ()) -keepAlive :: PrimBase m => a -> (a -> m r) -> m r+-- | Variant of 'touch' that keeps a value of an unlifted type+-- (e.g. @MutableByteArray#@) alive.+touchUnlifted :: forall (m :: Type -> Type) (a :: UnliftedType). PrimMonad m => a -> m ()+{-# INLINE touchUnlifted #-}+touchUnlifted x = unsafePrimToPrim+ $ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ())++-- | Keep value @x@ alive until computation @k@ completes.+-- Warning: This primop exists for completeness, but it is difficult to use+-- correctly. Prefer 'keepAliveUnlifted' if the value to keep alive is simply+-- a wrapper around an unlifted type (e.g. @ByteArray@).+keepAlive :: PrimBase m+ => a -- ^ Value @x@ to keep alive while computation @k@ runs.+ -> m r -- ^ Computation @k@+ -> m r #if defined(HAVE_KEEPALIVE) {-# INLINE keepAlive #-}-keepAlive x k = unsafeIOToPrim $ primitive $ \s0 -> keepAlive# x s0 $ internal $ unsafePrimToIO $ k x+keepAlive x k =+ primitive $ \s0 -> keepAliveLiftedLifted# x s0 (internal k)+ #else {-# NOINLINE keepAlive #-}-keepAlive x k = k x <* touch x+keepAlive x k = k <* touch x+#endif++-- | Variant of 'keepAlive' in which the value kept alive is of an unlifted+-- boxed type.+keepAliveUnlifted :: forall (m :: Type -> Type) (a :: UnliftedType) (r :: Type). PrimBase m => a -> m r -> m r+#if defined(HAVE_KEEPALIVE)+{-# INLINE keepAliveUnlifted #-}+keepAliveUnlifted x k =+ primitive $ \s0 -> keepAliveUnliftedLifted# x s0 (internal k)++#else+{-# NOINLINE keepAliveUnlifted #-}+keepAliveUnlifted x k = k <* touchUnlifted x #endif -- | Create an action to force a value; generalizes 'Control.Exception.evaluate'
Data/Primitive.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE MagicHash #-}-{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}- -- | -- Module : Data.Primitive -- Copyright : (c) Roman Leshchinskiy 2009-2012@@ -68,9 +65,11 @@ 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.+* 'IO' and 'Control.Monad.ST'+* Any combination of 'Control.Monad.Trans.Maybe.MaybeT',+ 'Control.Monad.Trans.Except.ExceptT', 'Control.Monad.Trans.State.Lazy.StateT'+ and 'Control.Monad.Trans.Writer.Lazy.WriterT' on top of another sufficiently+ affine monad. * 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.
Data/Primitive/Array.hs view
@@ -23,7 +23,6 @@ cloneArray, cloneMutableArray, sizeofArray, sizeofMutableArray, emptyArray,- fromListN, fromList, arrayFromListN, arrayFromList, mapArray', traverseArrayP@@ -31,6 +30,7 @@ import Control.DeepSeq import Control.Monad.Primitive+import Data.Primitive.Internal.Read (Tag(..),lexTag) import GHC.Exts hiding (toList) import qualified GHC.Exts as Exts@@ -52,9 +52,6 @@ import qualified Data.Foldable as F import Data.Semigroup import Data.Functor.Identity-#if !MIN_VERSION_base(4,10,0)-import GHC.Base (runRW#)-#endif import Text.Read (Read (..), parens, prec) import Text.ParserCombinators.ReadPrec (ReadPrec)@@ -164,7 +161,7 @@ indexArray## arr (I# i) = indexArray# (array# arr) i {-# INLINE indexArray## #-} --- | Monadically read a value from the immutable array at the given index.+-- | Read a value from the immutable array at the given index using an applicative. -- This allows us to be strict in the array while remaining lazy in the read -- element which is very useful for collective operations. Suppose we want to -- copy an array. We could do something like this:@@ -188,10 +185,10 @@ -- still not evaluated. -- -- /Note:/ this function does not do bounds checking.-indexArrayM :: Monad m => Array a -> Int -> m a+indexArrayM :: Applicative m => Array a -> Int -> m a {-# INLINE indexArrayM #-} indexArrayM arr (I# i#)- = case indexArray# (array# arr) i# of (# x #) -> return x+ = case indexArray# (array# arr) i# of (# x #) -> pure x -- | Create an immutable copy of a slice of an array. --@@ -586,18 +583,28 @@ -- | 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.++-- Note [fromListN]+-- ~~~~~~~~~~~~~~~~+-- We want arrayFromListN to be a "good consumer" in list fusion, so we define+-- the function using foldr and inline it to help fire fusion rules.+-- If fusion occurs with a "good producer", it may reduce to a fold on some+-- structure. In certain cases (such as for Data.Set) GHC is not be able to+-- optimize the index to an unboxed Int# (see GHC #24628), so we explicitly use+-- an Int# here. arrayFromListN :: Int -> [a] -> Array a+{-# INLINE arrayFromListN #-} arrayFromListN n l = createArray n (die "fromListN" "uninitialized element") $ \sma ->- let go !ix [] = if ix == n+ let z ix# = if I# ix# == n then return () else die "fromListN" "list length less than specified size"- go !ix (x : xs) = if ix < n+ f x k = GHC.Exts.oneShot $ \ix# -> if I# ix# < n then do- writeArray sma ix x- go (ix+1) xs+ writeArray sma (I# ix#) x+ k (ix# +# 1#) else die "fromListN" "list length greater than specified size"- in go 0 l+ in foldr f z l 0# -- | Create an array from a list. arrayFromList :: [a] -> Array a@@ -751,11 +758,9 @@ LT -> die "stimes" "negative multiplier" EQ -> empty GT -> createArray (n' * sizeofArray arr) (die "stimes" "impossible") $ \ma ->- let go i = if i < n'- then do- copyArray ma (i * sizeofArray arr) arr 0 (sizeofArray arr)- go (i + 1)- else return ()+ let go i = when (i < n') $ do+ copyArray ma (i * sizeofArray arr) arr 0 (sizeofArray arr)+ go (i + 1) in go 0 where n' = fromIntegral n :: Int @@ -772,9 +777,8 @@ where sz = sum . fmap sizeofArray $ l arrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Array a -> ShowS-arrayLiftShowsPrec elemShowsPrec elemListShowsPrec p a = showParen (p > 10) $- showString "fromListN " . shows (sizeofArray a) . showString " "- . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList a)+arrayLiftShowsPrec elemShowsPrec elemListShowsPrec _ a =+ listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList a) -- this need to be included for older ghcs listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS@@ -792,54 +796,27 @@ -- | @since 0.6.4.0 instance Read1 Array where-#if MIN_VERSION_base(4,10,0) liftReadPrec = arrayLiftReadPrec-#else- liftReadsPrec = arrayLiftReadsPrec-#endif +-- Note [Forgiving Array Read Instance] -- We're really forgiving here. We accept -- "[1,2,3]", "fromList [1,2,3]", and "fromListN 3 [1,2,3]". -- We consider fromListN with an invalid length to be an -- error, rather than a parse failure, because doing otherwise -- seems weird and likely to make debugging difficult. arrayLiftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (Array a)-arrayLiftReadPrec _ read_list = parens $ prec app_prec $ RdPrc.lift skipSpaces >>- ((fromList <$> read_list) RdPrc.+++- do- tag <- RdPrc.lift lexTag- case tag of- FromListTag -> fromList <$> read_list- FromListNTag -> liftM2 fromListN readPrec read_list)- where- app_prec = 10--data Tag = FromListTag | FromListNTag---- Why don't we just use lexP? The general problem with lexP is that--- it doesn't always fail as fast as we might like. It will--- happily read to the end of an absurdly long lexeme (e.g., a 200MB string--- literal) before returning, at which point we'll immediately discard--- the result because it's not an identifier. Doing the job ourselves, we--- can see very quickly when we've run into a problem. We should also get--- a slight efficiency boost by going through the string just once.-lexTag :: ReadP Tag-lexTag = do- _ <- string "fromList"- s <- look- case s of- 'N':c:_- | '0' <= c && c <= '9'- -> fail "" -- We have fromListN3 or similar- | otherwise -> FromListNTag <$ get -- Skip the 'N'- _ -> return FromListTag--#if !MIN_VERSION_base(4,10,0)-arrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Array a)-arrayLiftReadsPrec reads_prec list_reads_prec = RdPrc.readPrec_to_S $- arrayLiftReadPrec (RdPrc.readS_to_Prec reads_prec) (RdPrc.readS_to_Prec (const list_reads_prec))-#endif-+arrayLiftReadPrec _ read_list =+ ( RdPrc.lift skipSpaces >> fmap fromList read_list )+ RdPrc.++++ ( parens $ prec app_prec $ do+ RdPrc.lift skipSpaces+ tag <- RdPrc.lift lexTag+ case tag of+ FromListTag -> fromList <$> read_list+ FromListNTag -> liftM2 fromListN readPrec read_list+ )+ where+ app_prec = 10 arrayDataType :: DataType arrayDataType = mkDataType "Data.Primitive.Array.Array" [fromListConstr]
Data/Primitive/ByteArray.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, UnliftedFFITypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskellQuotes #-} -- | -- Module : Data.Primitive.ByteArray@@ -44,7 +44,7 @@ compareByteArrays, -- * Freezing and thawing- freezeByteArray, thawByteArray, runByteArray,+ freezeByteArray, thawByteArray, runByteArray, createByteArray, unsafeFreezeByteArray, unsafeThawByteArray, -- * Block operations@@ -62,32 +62,40 @@ #if __GLASGOW_HASKELL__ >= 802 isByteArrayPinned, isMutableByteArrayPinned, #endif- byteArrayContents, mutableByteArrayContents+ byteArrayAsForeignPtr,+ mutableByteArrayAsForeignPtr,+ byteArrayContents,+ withByteArrayContents,+ mutableByteArrayContents,+ withMutableByteArrayContents ) where import Control.Monad.Primitive import Control.Monad.ST import Data.Primitive.Types+import Data.Proxy -#if MIN_VERSION_base(4,10,0) import qualified GHC.ST as GHCST-#endif -import Foreign.C.Types import Data.Word ( Word8 ) #if __GLASGOW_HASKELL__ >= 802 import qualified GHC.Exts as Exts #endif import GHC.Exts hiding (setByteArray#)+import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..)) #if __GLASGOW_HASKELL__ < 804+import Foreign.C.Types import System.IO.Unsafe (unsafeDupablePerformIO) #endif import Data.Array.Byte (ByteArray(..), MutableByteArray(..)) +import Data.Primitive.Internal.Operations (mutableByteArrayContentsShim)+ -- | Create a new mutable byte array of the specified size in bytes.+-- The underlying memory is left uninitialized. -- -- /Note:/ this function does not check if the input is non-negative. newByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m))@@ -97,7 +105,7 @@ (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) -- | Create a /pinned/ byte array of the specified size in bytes. The garbage--- collector is guaranteed not to move it.+-- collector is guaranteed not to move it. The underlying memory is left uninitialized. -- -- /Note:/ this function does not check if the input is non-negative. newPinnedByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m))@@ -108,6 +116,7 @@ -- | Create a /pinned/ byte array of the specified size in bytes and with the -- given alignment. The garbage collector is guaranteed not to move it.+-- The underlying memory is left uninitialized. -- -- /Note:/ this function does not check if the input is non-negative. newAlignedPinnedByteArray@@ -120,21 +129,67 @@ = primitive (\s# -> case newAlignedPinnedByteArray# n# k# s# of (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) +-- | Create a foreign pointer that points to the array's data. This operation+-- is only safe on /pinned/ byte arrays. The array's data is not garbage+-- collected while references to the foreign pointer exist. Writing to the+-- array through the foreign pointer results in undefined behavior.+byteArrayAsForeignPtr :: ByteArray -> ForeignPtr Word8+{-# INLINE byteArrayAsForeignPtr #-}+byteArrayAsForeignPtr (ByteArray arr#) = ForeignPtr (byteArrayContents# arr#) (PlainPtr (unsafeCoerce# arr#))+++-- | Variant of 'byteArrayAsForeignPtr' for mutable byte arrays. Similarly, this+-- is only safe on /pinned/ mutable byte arrays. This function differs from the+-- variant for immutable arrays in that it is safe to write to the array though+-- the foreign pointer.+mutableByteArrayAsForeignPtr :: MutableByteArray RealWorld -> ForeignPtr Word8+{-# INLINE mutableByteArrayAsForeignPtr #-}+mutableByteArrayAsForeignPtr (MutableByteArray arr#) = ForeignPtr (mutableByteArrayContentsShim arr#) (PlainPtr arr#)+ -- | Yield a pointer to the array's data. This operation is only safe on--- /pinned/ byte arrays allocated by 'newPinnedByteArray' or--- 'newAlignedPinnedByteArray'.+-- /pinned/ byte arrays. Byte arrays allocated by 'newPinnedByteArray' and+-- 'newAlignedPinnedByteArray' are guaranteed to be pinned. Byte arrays+-- allocated by 'newByteArray' may or may not be pinned (use+-- 'isByteArrayPinned' to figure out).+--+-- Prefer 'withByteArrayContents', which ensures that the array is not+-- garbage collected while the pointer is being used. byteArrayContents :: ByteArray -> Ptr Word8 {-# INLINE byteArrayContents #-} byteArrayContents (ByteArray arr#) = Ptr (byteArrayContents# arr#) +-- | A composition of 'byteArrayContents' and 'keepAliveUnlifted'.+-- The callback function must not return the pointer. The argument byte+-- array must be /pinned/. See 'byteArrayContents' for an explanation+-- of which byte arrays are pinned.+--+-- Note: This could be implemented with 'keepAlive' instead of+-- 'keepAliveUnlifted', but 'keepAlive' here would cause GHC to materialize+-- the wrapper data constructor on the heap.+withByteArrayContents :: PrimBase m => ByteArray -> (Ptr Word8 -> m a) -> m a+{-# INLINE withByteArrayContents #-}+withByteArrayContents (ByteArray arr#) f =+ keepAliveUnlifted arr# (f (Ptr (byteArrayContents# arr#)))+ -- | Yield a pointer to the array's data. This operation is only safe on--- /pinned/ byte arrays allocated by 'newPinnedByteArray' or--- 'newAlignedPinnedByteArray'.+-- /pinned/ byte arrays. See 'byteArrayContents' for an explanation+-- of which byte arrays are pinned.+--+-- Prefer 'withByteArrayContents', which ensures that the array is not+-- garbage collected while the pointer is being used. mutableByteArrayContents :: MutableByteArray s -> Ptr Word8 {-# INLINE mutableByteArrayContents #-}-mutableByteArrayContents (MutableByteArray arr#)- = Ptr (byteArrayContents# (unsafeCoerce# arr#))+mutableByteArrayContents (MutableByteArray arr#) = Ptr (mutableByteArrayContentsShim arr#) +-- | A composition of 'mutableByteArrayContents' and 'keepAliveUnlifted'.+-- The callback function must not return the pointer. The argument byte+-- array must be /pinned/. See 'byteArrayContents' for an explanation+-- of which byte arrays are pinned.+withMutableByteArrayContents :: PrimBase m => MutableByteArray (PrimState m) -> (Ptr Word8 -> m a) -> m a+{-# INLINE withMutableByteArrayContents #-}+withMutableByteArrayContents (MutableByteArray arr#) f =+ keepAliveUnlifted arr# (f (Ptr (mutableByteArrayContentsShim arr#)))+ -- | Check if the two arrays refer to the same memory block. sameMutableByteArray :: MutableByteArray s -> MutableByteArray s -> Bool {-# INLINE sameMutableByteArray #-}@@ -239,13 +294,15 @@ {-# INLINE sizeofByteArray #-} sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#) --- | Size of the mutable byte array in bytes. This function\'s behavior+-- | Size of the mutable byte array in bytes.+--+-- This function is deprecated and will be removed. Its behavior -- is undefined if 'resizeMutableByteArray' is ever called on the mutable--- byte array given as the argument. Consequently, use of this function--- is discouraged. Prefer 'getSizeofMutableByteArray', which ensures correct--- sequencing in the presence of resizing.+-- byte array given as the argument. Prefer 'getSizeofMutableByteArray',+-- which ensures correct sequencing in the presence of resizing. sizeofMutableByteArray :: MutableByteArray s -> Int {-# INLINE sizeofMutableByteArray #-}+{-# DEPRECATED sizeofMutableByteArray "use getSizeofMutableByteArray instead" #-} sizeofMutableByteArray (MutableByteArray arr#) = I# (sizeofMutableByteArray# arr#) -- | Shrink a mutable byte array. The new size is given in bytes.@@ -320,7 +377,7 @@ go i | i < maxI = f (indexByteArray arr i) (go (i + 1)) | otherwise = z- maxI = sizeofByteArray arr `quot` sizeOf (undefined :: a)+ maxI = sizeofByteArray arr `quot` sizeOfType @a -- | Create a 'ByteArray' from a list. --@@ -330,20 +387,21 @@ -- | 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.-byteArrayFromListN :: Prim a => Int -> [a] -> ByteArray-byteArrayFromListN n ys = runST $ do- marr <- newByteArray (n * sizeOf (head ys))- let go !ix [] = if ix == n- then return ()- else die "byteArrayFromListN" "list length less than specified size"- go !ix (x : xs) = if ix < n- then do- writeByteArray marr ix x- go (ix + 1) xs- else die "byteArrayFromListN" "list length greater than specified size"- go 0 ys- unsafeFreezeByteArray marr +-- See Note [fromListN] in Data.Primitive.Array+byteArrayFromListN :: forall a. Prim a => Int -> [a] -> ByteArray+{-# INLINE byteArrayFromListN #-}+byteArrayFromListN n ys = createByteArray (n * sizeOfType @a) $ \marr ->+ let z ix# = if I# ix# == n+ then return ()+ else die "byteArrayFromListN" "list length less than specified size"+ f x k = GHC.Exts.oneShot $ \ix# -> if I# ix# < n+ then do+ writeByteArray marr (I# ix#) x+ k (ix# +# 1#)+ else die "byteArrayFromListN" "list length greater than specified size"+ in foldr f z ys 0#+ unI# :: Int -> Int# unI# (I# n#) = n# @@ -377,7 +435,13 @@ {-# INLINE copyMutableByteArray #-} copyMutableByteArray (MutableByteArray dst#) doff (MutableByteArray src#) soff sz- = primitive_ (copyMutableByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz))+ = primitive_ (op src# (unI# soff) dst# (unI# doff) (unI# sz))+ where+#if MIN_VERSION_base(4,19,0)+ op = copyMutableByteArrayNonOverlapping#+#else+ op = copyMutableByteArray#+#endif -- | 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.@@ -396,7 +460,7 @@ copyByteArrayToPtr (Ptr dst#) (ByteArray src#) soff sz = primitive_ (copyByteArrayToAddr# src# (unI# soff *# siz#) dst# (unI# sz *# siz#)) where- siz# = sizeOf# (undefined :: a)+ siz# = sizeOfType# (Proxy :: Proxy a) -- | Copy from an unmanaged pointer address to a byte array. These must not -- overlap. The offset and length are given in elements, not in bytes.@@ -412,7 +476,7 @@ copyPtrToMutableByteArray (MutableByteArray ba#) (I# doff#) (Ptr addr#) (I# n#) = primitive_ (copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#)) where- siz# = sizeOf# (undefined :: a)+ siz# = sizeOfType# (Proxy :: Proxy a) -- | Copy a slice of a mutable byte array to an unmanaged pointer address.@@ -433,7 +497,7 @@ copyMutableByteArrayToPtr (Ptr dst#) (MutableByteArray src#) soff sz = primitive_ (copyMutableByteArrayToAddr# src# (unI# soff *# siz#) dst# (unI# sz *# siz#)) where- siz# = sizeOf# (undefined :: a)+ siz# = sizeOfType# (Proxy :: Proxy a) ------ --- These latter two should be DEPRECATED@@ -486,9 +550,7 @@ {-# INLINE moveByteArray #-} moveByteArray (MutableByteArray dst#) doff (MutableByteArray src#) soff sz- = unsafePrimToPrim- $ memmove_mba dst# (fromIntegral doff) src# (fromIntegral soff)- (fromIntegral sz)+ = primitive_ (copyMutableByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz)) -- | Fill a slice of a mutable byte array with a value. The offset and length -- are given in elements of type @a@ rather than in bytes.@@ -518,11 +580,6 @@ {-# INLINE fillByteArray #-} fillByteArray = setByteArray -foreign import ccall unsafe "primitive-memops.h hsprimitive_memmove"- memmove_mba :: MutableByteArray# s -> CPtrdiff- -> MutableByteArray# s -> CPtrdiff- -> CSize -> IO ()- -- | Lexicographic comparison of equal-length slices into two byte arrays. -- This wraps the @compareByteArrays#@ primop, which wraps @memcmp@. compareByteArrays@@ -553,6 +610,10 @@ {-# NOINLINE emptyByteArray #-} emptyByteArray = runST (newByteArray 0 >>= unsafeFreezeByteArray) +emptyByteArray# :: (# #) -> ByteArray#+{-# NOINLINE emptyByteArray# #-}+emptyByteArray# _ = case emptyByteArray of ByteArray arr# -> arr#+ die :: String -> String -> a die fun problem = error $ "Data.Primitive.ByteArray." ++ fun ++ ": " ++ problem @@ -565,10 +626,8 @@ -> Int -- ^ number of bytes to copy -> ByteArray {-# INLINE cloneByteArray #-}-cloneByteArray src off n = runByteArray $ do- dst <- newByteArray n+cloneByteArray src off n = createByteArray n $ \dst -> copyByteArray dst 0 src off n- return dst -- | Return a newly allocated mutable array with the specified subrange of -- the provided mutable array. The provided mutable array should contain the@@ -590,7 +649,6 @@ 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#@@ -602,9 +660,20 @@ unST :: ST s a -> State# s -> (# State# s, a #) unST (GHCST.ST f) = f-#else /* In older GHCs, runRW# is not available. */-runByteArray m = runST $ m >>= unsafeFreezeByteArray-#endif++-- Create an uninitialized array of the given size in bytes, apply the function+-- to it, and freeze the result.+--+-- /Note:/ this function does not check if the input is non-negative.+--+-- @since FIXME+createByteArray :: Int -> (forall s. MutableByteArray s -> ST s ()) -> ByteArray+{-# INLINE createByteArray #-}+createByteArray 0 _ = ByteArray (emptyByteArray# (# #))+createByteArray n f = runByteArray $ do+ marr <- newByteArray n+ f marr+ pure marr {- $charElementAccess GHC provides two sets of element accessors for 'Char'. One set faithfully
Data/Primitive/Internal/Operations.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE CPP, MagicHash, UnliftedFFITypes #-}+{-# LANGUAGE CPP, MagicHash, UnliftedFFITypes, UnboxedTuples #-}+{-# LANGUAGE RankNTypes, KindSignatures, ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-}+#endif -- | -- Module : Data.Primitive.Internal.Operations@@ -24,13 +29,25 @@ setInt64OffAddr#, setIntOffAddr#, setAddrOffAddr#, setFloatOffAddr#, setDoubleOffAddr#, setWideCharOffAddr#, setStablePtrOffAddr#+++#if defined(HAVE_KEEPALIVE)+ , keepAliveLiftedLifted#+ , keepAliveUnliftedLifted#+#endif+ , mutableByteArrayContentsShim+ , UnliftedType ) where import Data.Primitive.MachDeps (Word64_#, Int64_#) import Foreign.C.Types import GHC.Exts +#if defined(HAVE_KEEPALIVE)+import Data.Kind (Type)+#endif + #if __GLASGOW_HASKELL__ >= 902 foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" setWord8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word8# -> IO ()@@ -136,3 +153,53 @@ setDoubleOffAddr# :: Addr# -> CPtrdiff -> CSize -> Double# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" setWideCharOffAddr# :: Addr# -> CPtrdiff -> CSize -> Char# -> IO ()++#if defined(HAVE_KEEPALIVE)+keepAliveLiftedLifted# :: forall (s :: Type) (a :: Type) (b :: Type).+ a+ -> State# s+ -> (State# s -> (# State# s, b #))+ -> (# State# s, b #)+{-# inline keepAliveLiftedLifted# #-}+keepAliveLiftedLifted# x s0 f =+ (unsafeCoerce# :: (# State# RealWorld, b #) -> (# State# s, b #))+ ( keepAlive# x+ ((unsafeCoerce# :: State# s -> State# RealWorld) s0)+ ((unsafeCoerce# ::+ (State# s -> (# State# s, b #)) ->+ (State# RealWorld -> (# State# RealWorld, b #))+ ) f)+ )++keepAliveUnliftedLifted# :: forall (s :: Type) (a :: UnliftedType) (b :: Type).+ a+ -> State# s+ -> (State# s -> (# State# s, b #))+ -> (# State# s, b #)+{-# inline keepAliveUnliftedLifted# #-}+keepAliveUnliftedLifted# x s0 f =+ (unsafeCoerce# :: (# State# RealWorld, b #) -> (# State# s, b #))+ ( keepAlive# x+ ((unsafeCoerce# :: State# s -> State# RealWorld) s0)+ ((unsafeCoerce# ::+ (State# s -> (# State# s, b #)) ->+ (State# RealWorld -> (# State# RealWorld, b #))+ ) f)+ )+#endif++#if __GLASGOW_HASKELL__ < 802+type UnliftedType = TYPE 'PtrRepUnlifted+#elif __GLASGOW_HASKELL__ < 902+type UnliftedType = TYPE 'UnliftedRep+#endif++mutableByteArrayContentsShim :: MutableByteArray# s -> Addr#+{-# INLINE mutableByteArrayContentsShim #-}+mutableByteArrayContentsShim x =+#if __GLASGOW_HASKELL__ >= 902+ mutableByteArrayContents# x+#else+ byteArrayContents# (unsafeCoerce# x)+#endif+
+ Data/Primitive/Internal/Read.hs view
@@ -0,0 +1,27 @@+module Data.Primitive.Internal.Read+ ( Tag(..)+ , lexTag+ ) where++import Data.Char (isDigit)+import Text.ParserCombinators.ReadP++data Tag = FromListTag | FromListNTag++-- Why don't we just use lexP? The general problem with lexP is that+-- it doesn't always fail as fast as we might like. It will+-- happily read to the end of an absurdly long lexeme (e.g., a 200MB string+-- literal) before returning, at which point we'll immediately discard+-- the result because it's not an identifier. Doing the job ourselves, we+-- can see very quickly when we've run into a problem. We should also get+-- a slight efficiency boost by going through the string just once.+lexTag :: ReadP Tag+lexTag = do+ _ <- string "fromList"+ s <- look+ case s of+ 'N':c:_+ | isDigit c+ -> fail "" -- We have fromListN3 or similar+ | otherwise -> FromListNTag <$ get -- Skip the 'N'+ _ -> return FromListTag
Data/Primitive/MVar.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}
Data/Primitive/MutVar.hs view
@@ -19,16 +19,24 @@ readMutVar, writeMutVar, + -- * Modify atomicModifyMutVar, atomicModifyMutVar', modifyMutVar,- modifyMutVar'+ modifyMutVar',+ -- * Interop with STRef and IORef+ mutVarFromIORef,+ mutVarToIORef,+ mutVarFromSTRef,+ mutVarToSTRef ) where import Control.Monad.Primitive ( PrimMonad(..), primitive_ )+import GHC.IORef (IORef(IORef))+import GHC.STRef (STRef(STRef)) import GHC.Exts ( MutVar#, sameMutVar#, newMutVar# , readMutVar#, writeMutVar#, atomicModifyMutVar#- , isTrue# )+ , isTrue#, RealWorld) import Data.Typeable ( Typeable ) -- | A 'MutVar' behaves like a single-element mutable array associated@@ -103,3 +111,23 @@ modifyMutVar' (MutVar mv#) g = primitive_ $ \s# -> case readMutVar# mv# s# of (# s'#, a #) -> let a' = g a in a' `seq` writeMutVar# mv# a' s'#++-- | Convert 'MutVar' to 'IORef'+mutVarToIORef :: MutVar RealWorld a -> IORef a+{-# INLINE mutVarToIORef #-}+mutVarToIORef (MutVar mv#) = IORef (STRef mv#)++-- | Convert 'MutVar' to 'IORef'+mutVarFromIORef :: IORef a -> MutVar RealWorld a+{-# INLINE mutVarFromIORef #-}+mutVarFromIORef (IORef (STRef mv#)) = MutVar mv#++-- | Convert 'MutVar' to 'STRef'+mutVarToSTRef :: MutVar s a -> STRef s a+{-# INLINE mutVarToSTRef #-}+mutVarToSTRef (MutVar mv#) = STRef mv#++-- | Convert 'MutVar' to 'STRef'+mutVarFromSTRef :: STRef s a -> MutVar s a+{-# INLINE mutVarFromSTRef #-}+mutVarFromSTRef (STRef mv#) = MutVar mv#
Data/Primitive/PrimArray.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE RoleAnnotations #-}@@ -45,6 +46,7 @@ , freezePrimArray , thawPrimArray , runPrimArray+ , createPrimArray , unsafeFreezePrimArray , unsafeThawPrimArray -- * Block Operations@@ -62,7 +64,9 @@ , sizeofMutablePrimArray , sizeofPrimArray , primArrayContents+ , withPrimArrayContents , mutablePrimArrayContents+ , withMutablePrimArrayContents #if __GLASGOW_HASKELL__ >= 802 , isPrimArrayPinned , isMutablePrimArrayPinned@@ -110,37 +114,33 @@ import GHC.Exts import Data.Primitive.Types import Data.Primitive.ByteArray (ByteArray(..))-#if !MIN_VERSION_base(4,11,0)-import Data.Monoid ((<>))-#endif+import Data.Proxy #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) #endif import Control.DeepSeq+import Control.Monad (when) import Control.Monad.Primitive import Control.Monad.ST import qualified Data.List as L import qualified Data.Primitive.ByteArray as PB import qualified Data.Primitive.Types as PT-#if MIN_VERSION_base(4,10,0) import qualified GHC.ST as GHCST-#endif import Language.Haskell.TH.Syntax (Lift (..)) -#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup (Semigroup)-#endif-import qualified Data.Semigroup as SG+import Data.Semigroup #if __GLASGOW_HASKELL__ >= 802 import qualified GHC.Exts as Exts #endif +import Data.Primitive.Internal.Operations (mutableByteArrayContentsShim)+ -- | Arrays of unboxed elements. This accepts types like 'Double', 'Char',--- '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 'Data.Primitive.Array.Array',--- which is lazy in its elements.+-- 'Int' and 'Word', as well as their fixed-length variants ('Data.Word.Word8',+-- 'Data.Word.Word16', etc.). Since the elements are unboxed, a 'PrimArray' is+-- strict in its elements. This differs from the behavior of+-- 'Data.Primitive.Array.Array', which is lazy in its elements. data PrimArray a = PrimArray ByteArray# type role PrimArray nominal@@ -182,7 +182,7 @@ a1@(PrimArray ba1#) == a2@(PrimArray ba2#) | sameByteArray ba1# ba2# = True | sz1 /= sz2 = False- | otherwise = loop (quot sz1 (sizeOf (undefined :: a)) - 1)+ | otherwise = loop (quot sz1 (sizeOfType @a) - 1) where -- Here, we take the size in bytes, not in elements. We do this -- since it allows us to defer performing the division to@@ -204,7 +204,7 @@ where sz1 = PB.sizeofByteArray (ByteArray ba1#) sz2 = PB.sizeofByteArray (ByteArray ba2#)- sz = quot (min sz1 sz2) (sizeOf (undefined :: a))+ sz = quot (min sz1 sz2) (sizeOfType @a) loop !i | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) <> loop (i + 1) | otherwise = compare sz1 sz2@@ -219,9 +219,7 @@ -- | @since 0.6.4.0 instance (Show a, Prim a) => Show (PrimArray a) where- showsPrec p a = showParen (p > 10) $- showString "fromListN " . shows (sizeofPrimArray a) . showString " "- . shows (primArrayToList a)+ showsPrec _ a = shows (primArrayToList a) die :: String -> String -> a die fun problem = error $ "Data.Primitive.PrimArray." ++ fun ++ ": " ++ problem@@ -234,22 +232,20 @@ -- | 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.++-- See Note [fromListN] in Data.Primitive.Array primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a-primArrayFromListN len vs = runST run where- run :: forall s. ST s (PrimArray a)- run = do- arr <- newPrimArray len- let go :: [a] -> Int -> ST s ()- go [] !ix = if ix == len- then return ()- else die "fromListN" "list length less than specified size"- go (a : as) !ix = if ix < len- then do- writePrimArray arr ix a- go as (ix + 1)- else die "fromListN" "list length greater than specified size"- go vs 0- unsafeFreezePrimArray arr+{-# INLINE primArrayFromListN #-}+primArrayFromListN len vs = createPrimArray len $ \arr ->+ let z ix# = if I# ix# == len+ then return ()+ else die "fromListN" "list length less than specified size"+ f a k = GHC.Exts.oneShot $ \ix# -> if I# ix# < len+ then do+ writePrimArray arr (I# ix#) a+ k (ix# +# 1#)+ else die "fromListN" "list length greater than specified size"+ in foldr f z vs 0# -- | Convert a 'PrimArray' to a list. {-# INLINE primArrayToList #-}@@ -264,15 +260,15 @@ -- | @since 0.6.4.0 instance Semigroup (PrimArray a) where- x <> y = byteArrayToPrimArray (primArrayToByteArray x SG.<> primArrayToByteArray y)- sconcat = byteArrayToPrimArray . SG.sconcat . fmap primArrayToByteArray- stimes i arr = byteArrayToPrimArray (SG.stimes i (primArrayToByteArray arr))+ x <> y = byteArrayToPrimArray (primArrayToByteArray x <> primArrayToByteArray y)+ sconcat = byteArrayToPrimArray . sconcat . fmap primArrayToByteArray+ stimes i arr = byteArrayToPrimArray (stimes i (primArrayToByteArray arr)) -- | @since 0.6.4.0 instance Monoid (PrimArray a) where mempty = emptyPrimArray #if !(MIN_VERSION_base(4,11,0))- mappend x y = byteArrayToPrimArray (mappend (primArrayToByteArray x) (primArrayToByteArray y))+ mappend = (<>) #endif mconcat = byteArrayToPrimArray . mconcat . map primArrayToByteArray @@ -283,6 +279,10 @@ (# s1#, arr# #) -> case unsafeFreezeByteArray# arr# s1# of (# s2#, arr'# #) -> (# s2#, PrimArray arr'# #) +emptyPrimArray# :: (# #) -> ByteArray#+{-# NOINLINE emptyPrimArray# #-}+emptyPrimArray# _ = case emptyPrimArray of PrimArray arr# -> arr#+ -- | Create a new mutable primitive array of the given length. The -- underlying memory is left uninitialized. --@@ -291,7 +291,7 @@ {-# INLINE newPrimArray #-} newPrimArray (I# n#) = primitive (\s# ->- case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of+ case newByteArray# (n# *# sizeOfType# (Proxy :: Proxy a)) s# of (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #) ) @@ -311,7 +311,7 @@ -> m (MutablePrimArray (PrimState m) a) {-# INLINE resizeMutablePrimArray #-} resizeMutablePrimArray (MutablePrimArray arr#) (I# n#)- = primitive (\s# -> case resizeMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)) s# of+ = primitive (\s# -> case resizeMutableByteArray# arr# (n# *# sizeOfType# (Proxy :: Proxy a)) s# of (# s'#, arr'# #) -> (# s'#, MutablePrimArray arr'# #)) -- | Shrink a mutable primitive array. The new size is given in elements.@@ -322,7 +322,7 @@ -> m () {-# INLINE shrinkMutablePrimArray #-} shrinkMutablePrimArray (MutablePrimArray arr#) (I# n#)- = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)))+ = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOfType# (Proxy :: Proxy a))) -- | Read a value from the array at the given index. --@@ -362,10 +362,10 @@ copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#) = primitive_ (copyMutableByteArray# src#- (soff# *# sizeOf# (undefined :: a))+ (soff# *# sizeOfType# (Proxy :: Proxy a)) dst#- (doff# *# sizeOf# (undefined :: a))- (n# *# sizeOf# (undefined :: a))+ (doff# *# sizeOfType# (Proxy :: Proxy a))+ (n# *# sizeOfType# (Proxy :: Proxy a)) ) -- | Copy part of an array into another mutable array.@@ -383,16 +383,16 @@ copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#) = primitive_ (copyByteArray# src#- (soff# *# sizeOf# (undefined :: a))+ (soff# *# sizeOfType# (Proxy :: Proxy a)) dst#- (doff# *# sizeOf# (undefined :: a))- (n# *# sizeOf# (undefined :: a))+ (doff# *# sizeOfType# (Proxy :: Proxy a))+ (n# *# sizeOfType# (Proxy :: Proxy a)) ) -- | 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.+-- agrees with the 'Foreign.Storable.Storable' instance. -- -- /Note:/ this function does not do bounds or overlap checking. copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a)@@ -406,12 +406,12 @@ primitive (\ s# -> let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s# in (# s'#, () #))- where siz# = sizeOf# (undefined :: a)+ where siz# = sizeOfType# (Proxy :: Proxy a) -- | 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.+-- agrees with the 'Foreign.Storable.Storable' instance. -- -- /Note:/ this function does not do bounds or overlap checking. copyMutablePrimArrayToPtr :: forall m a. (PrimMonad m, Prim a)@@ -425,12 +425,12 @@ primitive (\ s# -> let s'# = copyMutableByteArrayToAddr# mba# (soff# *# siz#) addr# (n# *# siz#) s# in (# s'#, () #))- where siz# = sizeOf# (undefined :: a)+ where siz# = sizeOfType# (Proxy :: Proxy a) -- | Copy from a pointer to a mutable primitive array. -- 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.+-- agrees with the 'Foreign.Storable.Storable' instance. -- -- /Note:/ this function does not do bounds or overlap checking. copyPtrToMutablePrimArray :: forall m a. (PrimMonad m, Prim a)@@ -443,7 +443,7 @@ copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) = primitive_ (copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#)) where- siz# = sizeOf# (undefined :: a)+ siz# = sizeOfType# (Proxy :: Proxy a) -- | Fill a slice of a mutable primitive array with a value. --@@ -469,7 +469,7 @@ getSizeofMutablePrimArray (MutablePrimArray arr#) = primitive (\s# -> case getSizeofMutableByteArray# arr# s# of- (# s'#, sz# #) -> (# s'#, I# (quotInt# sz# (sizeOf# (undefined :: a))) #)+ (# s'#, sz# #) -> (# s'#, I# (quotInt# sz# (sizeOfType# (Proxy :: Proxy a))) #) ) #else -- On older GHCs, it is not possible to resize a byte array, so@@ -482,10 +482,13 @@ -- | 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'.+--+-- This function is deprecated and will be removed. sizeofMutablePrimArray :: forall s a. Prim a => MutablePrimArray s a -> Int {-# INLINE sizeofMutablePrimArray #-}+{-# DEPRECATED sizeofMutablePrimArray "use getSizeofMutablePrimArray instead" #-} sizeofMutablePrimArray (MutablePrimArray arr#) =- I# (quotInt# (sizeofMutableByteArray# arr#) (sizeOf# (undefined :: a)))+ I# (quotInt# (sizeofMutableByteArray# arr#) (sizeOfType# (Proxy :: Proxy a))) -- | Check if the two arrays refer to the same memory block. sameMutablePrimArray :: MutablePrimArray s a -> MutablePrimArray s a -> Bool@@ -562,7 +565,7 @@ -- | Get the size, in elements, of the primitive array. sizeofPrimArray :: forall a. Prim a => PrimArray a -> Int {-# INLINE sizeofPrimArray #-}-sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (sizeOf# (undefined :: a)))+sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (sizeOfType# (Proxy :: Proxy a))) #if __GLASGOW_HASKELL__ >= 802 -- | Check whether or not the primitive array is pinned. Pinned primitive arrays cannot@@ -669,12 +672,10 @@ traversePrimArrayP f arr = do let !sz = sizeofPrimArray arr marr <- newPrimArray sz- let go !ix = if ix < sz- then do- b <- f (indexPrimArray arr ix)- writePrimArray marr ix b- go (ix + 1)- else return ()+ let go !ix = when (ix < sz) $ do+ b <- f (indexPrimArray arr ix)+ writePrimArray marr ix b+ go (ix + 1) go 0 unsafeFreezePrimArray marr @@ -735,12 +736,10 @@ -> m (PrimArray a) generatePrimArrayP sz f = do marr <- newPrimArray sz- let go !ix = if ix < sz- then do- b <- f ix- writePrimArray marr ix b- go (ix + 1)- else return ()+ let go !ix = when (ix < sz) $ do+ b <- f ix+ writePrimArray marr ix b+ go (ix + 1) go 0 unsafeFreezePrimArray marr @@ -753,12 +752,10 @@ -> m (PrimArray a) replicatePrimArrayP sz f = do marr <- newPrimArray sz- let go !ix = if ix < sz- then do- b <- f- writePrimArray marr ix b- go (ix + 1)- else return ()+ let go !ix = when (ix < sz) $ do+ b <- f+ writePrimArray marr ix b+ go (ix + 1) go 0 unsafeFreezePrimArray marr @@ -768,17 +765,14 @@ => (a -> b) -> PrimArray a -> PrimArray b-mapPrimArray f arr = runST $ do- let !sz = sizeofPrimArray arr- marr <- newPrimArray sz- let go !ix = if ix < sz- then do- let b = f (indexPrimArray arr ix)- writePrimArray marr ix b- go (ix + 1)- else return ()- go 0- unsafeFreezePrimArray marr+mapPrimArray f arr = createPrimArray sz $ \marr ->+ let go !ix = when (ix < sz) $ do+ let b = f (indexPrimArray arr ix)+ writePrimArray marr ix b+ go (ix + 1)+ in go 0+ where+ !sz = sizeofPrimArray arr -- | Indexed map over the elements of a primitive array. {-# INLINE imapPrimArray #-}@@ -786,17 +780,14 @@ => (Int -> a -> b) -> PrimArray a -> PrimArray b-imapPrimArray f arr = runST $ do- let !sz = sizeofPrimArray arr- marr <- newPrimArray sz- let go !ix = if ix < sz- then do- let b = f ix (indexPrimArray arr ix)- writePrimArray marr ix b- go (ix + 1)- else return ()- go 0- unsafeFreezePrimArray marr+imapPrimArray f arr = createPrimArray sz $ \marr ->+ let go !ix = when (ix < sz) $ do+ let b = f ix (indexPrimArray arr ix)+ writePrimArray marr ix b+ go (ix + 1)+ in go 0+ where+ !sz = sizeofPrimArray arr -- | Filter elements of a primitive array according to a predicate. {-# INLINE filterPrimArray #-}@@ -966,15 +957,11 @@ => Int -- ^ length -> (Int -> a) -- ^ element from index -> PrimArray a-generatePrimArray len f = runST $ do- marr <- newPrimArray len- let go !ix = if ix < len- then do- writePrimArray marr ix (f ix)- go (ix + 1)- else return ()- go 0- unsafeFreezePrimArray marr+generatePrimArray len f = createPrimArray len $ \marr ->+ let go !ix = when (ix < len) $ do+ writePrimArray marr ix (f ix)+ go (ix + 1)+ in go 0 -- | Create a primitive array by copying the element the given -- number of times.@@ -983,10 +970,8 @@ => Int -- ^ length -> a -- ^ element -> PrimArray a-replicatePrimArray len a = runST $ do- marr <- newPrimArray len+replicatePrimArray len a = createPrimArray len $ \marr -> setPrimArray marr 0 len a- unsafeFreezePrimArray marr -- | Generate a primitive array by evaluating the applicative generator -- function at each index.@@ -1038,9 +1023,8 @@ -> f () traversePrimArray_ f a = go 0 where !sz = sizeofPrimArray a- go !ix = if ix < sz- then f (indexPrimArray a ix) *> go (ix + 1)- else pure ()+ go !ix = when (ix < sz) $+ f (indexPrimArray a ix) *> go (ix + 1) -- | Traverse the primitive array with the indices, discarding the results. -- There is no 'PrimMonad' variant of this function, since it would not@@ -1052,9 +1036,8 @@ -> f () itraversePrimArray_ f a = go 0 where !sz = sizeofPrimArray a- go !ix = if ix < sz- then f ix (indexPrimArray a ix) *> go (ix + 1)- else pure ()+ go !ix = when (ix < sz) $+ f ix (indexPrimArray a ix) *> go (ix + 1) newtype IxSTA a = IxSTA {_runIxSTA :: forall s. Int -> MutableByteArray# s -> ST s Int} @@ -1084,31 +1067,32 @@ -} -- | Create a /pinned/ primitive array of the specified size (in elements). The garbage--- collector is guaranteed not to move it.+-- collector is guaranteed not to move it. The underlying memory is left uninitialized. -- -- @since 0.7.1.0 newPinnedPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a) {-# INLINE newPinnedPrimArray #-} newPinnedPrimArray (I# n#)- = primitive (\s# -> case newPinnedByteArray# (n# *# sizeOf# (undefined :: a)) s# of+ = primitive (\s# -> case newPinnedByteArray# (n# *# sizeOfType# (Proxy :: Proxy a)) s# of (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #)) -- | 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.+-- guaranteed not to move it. The underlying memory is left uninitialized. -- -- @since 0.7.0.0 newAlignedPinnedPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a) {-# INLINE newAlignedPinnedPrimArray #-} newAlignedPinnedPrimArray (I# n#)- = primitive (\s# -> case newAlignedPinnedByteArray# (n# *# sizeOf# (undefined :: a)) (alignment# (undefined :: a)) s# of+ = primitive (\s# -> case newAlignedPinnedByteArray# (n# *# sizeOfType# (Proxy :: Proxy a)) (alignmentOfType# (Proxy :: Proxy a)) s# of (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #)) -- | Yield a pointer to the array's data. This operation is only safe on--- /pinned/ prim arrays allocated by 'newPinnedByteArray' or--- 'newAlignedPinnedByteArray'.+-- /pinned/ prim arrays allocated by+-- 'Data.Primitive.ByteArray.newPinnedByteArray' or+-- 'Data.Primitive.ByteArray.newAlignedPinnedByteArray'. -- -- @since 0.7.1.0 primArrayContents :: PrimArray a -> Ptr a@@ -1116,14 +1100,15 @@ primArrayContents (PrimArray arr#) = Ptr (byteArrayContents# arr#) -- | Yield a pointer to the array's data. This operation is only safe on--- /pinned/ byte arrays allocated by 'newPinnedByteArray' or--- 'newAlignedPinnedByteArray'.+-- /pinned/ byte arrays allocated by+-- 'Data.Primitive.ByteArray.newPinnedByteArray' or+-- 'Data.Primitive.ByteArray.newAlignedPinnedByteArray'. -- -- @since 0.7.1.0 mutablePrimArrayContents :: MutablePrimArray s a -> Ptr a {-# INLINE mutablePrimArrayContents #-}-mutablePrimArrayContents (MutablePrimArray arr#)- = Ptr (byteArrayContents# (unsafeCoerce# arr#))+mutablePrimArrayContents (MutablePrimArray arr#) =+ Ptr (mutableByteArrayContentsShim arr#) -- | Return a newly allocated array with the specified subrange of the -- provided array. The provided array should contain the full subrange@@ -1134,10 +1119,8 @@ -> Int -- ^ number of elements to copy -> PrimArray a {-# INLINE clonePrimArray #-}-clonePrimArray src off n = runPrimArray $ do- dst <- newPrimArray n+clonePrimArray src off n = createPrimArray n $ \dst -> copyPrimArray dst 0 src off n- return dst -- | Return a newly allocated mutable array with the specified subrange of -- the provided mutable array. The provided mutable array should contain the@@ -1159,7 +1142,6 @@ 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#@@ -1171,6 +1153,40 @@ unST :: ST s a -> State# s -> (# State# s, a #) unST (GHCST.ST f) = f-#else /* In older GHCs, runRW# is not available. */-runPrimArray m = runST $ m >>= unsafeFreezePrimArray-#endif++-- | Create an uninitialized array of the given length, apply the function to+-- it, and freeze the result.+--+-- /Note:/ this function does not check if the input is non-negative.+--+-- @since FIXME+createPrimArray+ :: Prim a => Int -> (forall s. MutablePrimArray s a -> ST s ()) -> PrimArray a+{-# INLINE createPrimArray #-}+createPrimArray 0 _ = PrimArray (emptyPrimArray# (# #))+createPrimArray n f = runPrimArray $ do+ marr <- newPrimArray n+ f marr+ pure marr++-- | A composition of 'primArrayContents' and 'keepAliveUnlifted'.+-- The callback function must not return the pointer. The argument+-- array must be /pinned/. See 'primArrayContents' for an explanation+-- of which primitive arrays are pinned.+--+-- Note: This could be implemented with 'keepAlive' instead of+-- 'keepAliveUnlifted', but 'keepAlive' here would cause GHC to materialize+-- the wrapper data constructor on the heap.+withPrimArrayContents :: PrimBase m => PrimArray a -> (Ptr a -> m a) -> m a+{-# INLINE withPrimArrayContents #-}+withPrimArrayContents (PrimArray arr#) f =+ keepAliveUnlifted arr# (f (Ptr (byteArrayContents# arr#)))++-- | A composition of 'mutablePrimArrayContents' and 'keepAliveUnlifted'.+-- The callback function must not return the pointer. The argument+-- array must be /pinned/. See 'primArrayContents' for an explanation+-- of which primitive arrays are pinned.+withMutablePrimArrayContents :: PrimBase m => MutablePrimArray (PrimState m) a -> (Ptr a -> m a) -> m a+{-# INLINE withMutablePrimArrayContents #-}+withMutablePrimArrayContents (MutablePrimArray arr#) f =+ keepAliveUnlifted arr# (f (Ptr (mutableByteArrayContentsShim arr#)))
Data/Primitive/Ptr.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.Primitive.Ptr@@ -37,6 +37,7 @@ import Data.Primitive.PrimArray (copyPtrToMutablePrimArray) import Data.Primitive.ByteArray (copyPtrToMutableByteArray) +import Data.Proxy import GHC.Exts import GHC.Ptr import Foreign.Marshal.Utils@@ -45,14 +46,14 @@ -- | Offset a pointer by the given number of elements. advancePtr :: forall a. Prim a => Ptr a -> Int -> Ptr a {-# INLINE advancePtr #-}-advancePtr (Ptr a#) (I# i#) = Ptr (plusAddr# a# (i# *# sizeOf# (undefined :: a)))+advancePtr (Ptr a#) (I# i#) = Ptr (plusAddr# a# (i# *# sizeOfType# (Proxy :: Proxy 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. 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)))+subtractPtr (Ptr a#) (Ptr b#) = I# (quotInt# (minusAddr# a# b#) (sizeOfType# (Proxy :: Proxy a))) -- | Read a value from a memory position given by a pointer and an offset. -- The memory block the address refers to must be immutable. The offset is in@@ -82,7 +83,7 @@ -> m () {-# INLINE copyPtr #-} copyPtr (Ptr dst#) (Ptr src#) n- = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a))+ = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) (n * sizeOfType @a) -- | Copy the given number of elements from the second 'Ptr' to the first. The -- areas may overlap.@@ -93,7 +94,7 @@ -> m () {-# INLINE movePtr #-} movePtr (Ptr dst#) (Ptr src#) n- = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a))+ = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) (n * sizeOfType @a) -- | Fill a memory block with the given value. The length is in -- elements of type @a@ rather than in bytes.
Data/Primitive/SmallArray.hs view
@@ -54,6 +54,7 @@ , runSmallArray , createSmallArray , sizeofSmallArray+ , getSizeofSmallMutableArray , sizeofSmallMutableArray #if MIN_VERSION_base(4,14,0) , shrinkSmallMutableArray@@ -80,12 +81,13 @@ import Data.Data import Data.Foldable as Foldable import Data.Functor.Identity+import Data.Primitive.Internal.Read (Tag(..),lexTag)+import Text.Read (Read (..), parens, prec) import qualified GHC.ST as GHCST-import qualified Data.Semigroup as Sem+import Data.Semigroup import Text.ParserCombinators.ReadP-#if !MIN_VERSION_base(4,10,0)-import GHC.Base (runRW#)-#endif+import Text.ParserCombinators.ReadPrec (ReadPrec)+import qualified Text.ParserCombinators.ReadPrec as RdPrc import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..), Read1(..)) import Language.Haskell.TH.Syntax (Lift(..))@@ -174,7 +176,7 @@ -- | Look up an element in an immutable array. ----- The purpose of returning a result using a monad is to allow the caller to+-- The purpose of returning a result using an applicative is to allow the caller to -- avoid retaining references to the array. Evaluating the return value will -- cause the array lookup to be performed, even though it may not require the -- element of the array to be evaluated (which could throw an exception). For@@ -186,19 +188,19 @@ -- > f sa = case indexSmallArrayM sa 0 of -- > Box x -> ... ----- 'x' is not a closure that references 'sa' as it would be if we instead+-- @x@ is not a closure that references @sa@ as it would be if we instead -- wrote: -- -- > let x = indexSmallArray sa 0 ----- It also 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. -- -- /Note:/ this function does not do bounds checking. indexSmallArrayM- :: Monad m+ :: Applicative m => SmallArray a -- ^ array -> Int -- ^ index -> m a@@ -348,10 +350,54 @@ sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#) {-# INLINE sizeofSmallArray #-} --- | The number of elements in a mutable array.+-- | Get the number of elements in a mutable array. Unlike+-- 'sizeofSmallMutableArray', this function will be sure to produce the correct+-- result if 'SmallMutableArray' has been shrunk in place. Consider the following:+--+-- @+-- do+-- sa <- 'newSmallArray' 10 x+-- print $ 'sizeofSmallMutableArray' sa+-- 'shrinkSmallMutableArray' sa 5+-- print $ sizeofSmallMutableArray sa+-- @+--+-- The compiler is well within its rights to eliminate the second size check+-- and print @10@ twice. However, 'getSizeofSmallMutableArray' will check+-- the size each time it's /executed/ (not /evaluated/), so it won't have this+-- problem:+--+-- @+-- do+-- sa <- 'newSmallArray' 10 x+-- print =<< getSizeofSmallMutableArray sa+-- 'shrinkSmallMutableArray' sa 5+-- print =<< getSizeofSmallMutableArray sa+-- @+--+-- will certainly print @10@ and then @5@.+getSizeofSmallMutableArray+ :: PrimMonad m+ => SmallMutableArray (PrimState m) a+ -> m Int+#if MIN_VERSION_base(4,14,0)+getSizeofSmallMutableArray (SmallMutableArray sa#) = primitive $ \s ->+ case getSizeofSmallMutableArray# sa# s of+ (# s', sz# #) -> (# s', I# sz# #)+#else+getSizeofSmallMutableArray sa = pure $! sizeofSmallMutableArray sa+#endif+{-# INLINE getSizeofSmallMutableArray #-}++-- | The number of elements in a mutable array. This should only be used+-- for arrays that are not shrunk in place.+--+-- This is deprecated and will be removed in a future release. Use+-- 'getSizeofSmallMutableArray' instead. sizeofSmallMutableArray :: SmallMutableArray s a -> Int sizeofSmallMutableArray (SmallMutableArray sa#) = I# (sizeofSmallMutableArray# sa#)+{-# DEPRECATED sizeofSmallMutableArray "use getSizeofSmallMutableArray instead" #-} {-# INLINE sizeofSmallMutableArray #-} -- | This is the fastest, most straightforward way to traverse@@ -777,25 +823,23 @@ err = error "mfix for Data.Primitive.SmallArray applied to strict function." -- | @since 0.6.3.0-instance Sem.Semigroup (SmallArray a) where+instance Semigroup (SmallArray a) where (<>) = (<|>) sconcat = mconcat . toList stimes n arr = case compare n 0 of LT -> die "stimes" "negative multiplier" EQ -> empty GT -> createSmallArray (n' * sizeofSmallArray arr) (die "stimes" "impossible") $ \sma ->- let go i = if i < n'- then do- copySmallArray sma (i * sizeofSmallArray arr) arr 0 (sizeofSmallArray arr)- go (i + 1)- else return ()+ let go i = when (i < n') $ do+ copySmallArray sma (i * sizeofSmallArray arr) arr 0 (sizeofSmallArray arr)+ go (i + 1) in go 0 where n' = fromIntegral n :: Int instance Monoid (SmallArray a) where mempty = empty #if !(MIN_VERSION_base(4,11,0))- mappend = (Sem.<>)+ mappend = (<>) #endif mconcat l = createSmallArray n (die "mconcat" "impossible") $ \ma -> let go !_ [ ] = return ()@@ -811,9 +855,8 @@ toList = Foldable.toList smallArrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> SmallArray a -> ShowS-smallArrayLiftShowsPrec elemShowsPrec elemListShowsPrec p sa = showParen (p > 10) $- showString "fromListN " . shows (length sa) . showString " "- . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList sa)+smallArrayLiftShowsPrec elemShowsPrec elemListShowsPrec _ sa =+ listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList sa) -- this need to be included for older ghcs listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS@@ -826,23 +869,27 @@ instance Show1 SmallArray where liftShowsPrec = smallArrayLiftShowsPrec -smallArrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (SmallArray a)-smallArrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do- () <$ string "fromListN"- skipSpaces- n <- readS_to_P reads- skipSpaces- l <- readS_to_P listReadsPrec- return $ smallArrayFromListN n l+-- See Note [Forgiving Array Read Instance]+smallArrayLiftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (SmallArray a)+smallArrayLiftReadPrec _ read_list =+ ( RdPrc.lift skipSpaces >> fmap fromList read_list )+ RdPrc.++++ ( parens $ prec app_prec $ do+ RdPrc.lift skipSpaces+ tag <- RdPrc.lift lexTag+ case tag of+ FromListTag -> fromList <$> read_list+ FromListNTag -> liftM2 fromListN readPrec read_list+ )+ where+ app_prec = 10 instance Read a => Read (SmallArray a) where- readsPrec = smallArrayLiftReadsPrec readsPrec readList+ readPrec = smallArrayLiftReadPrec readPrec readListPrec -- | @since 0.6.4.0 instance Read1 SmallArray where- liftReadsPrec = smallArrayLiftReadsPrec--+ liftReadPrec = smallArrayLiftReadPrec smallArrayDataType :: DataType smallArrayDataType =@@ -867,18 +914,19 @@ -- | 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. smallArrayFromListN :: Int -> [a] -> SmallArray a+{-# INLINE smallArrayFromListN #-} smallArrayFromListN n l = createSmallArray n (die "smallArrayFromListN" "uninitialized element") $ \sma ->- let go !ix [] = if ix == n+ let z ix# = if I# ix# == n then return () else die "smallArrayFromListN" "list length less than specified size"- go !ix (x : xs) = if ix < n+ f x k = GHC.Exts.oneShot $ \ix# -> if I# ix# < n then do- writeSmallArray sma ix x- go (ix + 1) xs+ writeSmallArray sma (I# ix#) x+ k (ix# +# 1#) else die "smallArrayFromListN" "list length greater than specified size"- in go 0 l+ in foldr f z l 0# -- | Create a 'SmallArray' from a list. smallArrayFromList :: [a] -> SmallArray a
Data/Primitive/Types.hs view
@@ -1,13 +1,11 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE MagicHash #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeApplications #-} #if __GLASGOW_HASKELL__ < 906 {-# LANGUAGE TypeInType #-}@@ -27,7 +25,7 @@ module Data.Primitive.Types ( Prim(..)- , sizeOf, alignment, defaultSetByteArray#, defaultSetOffAddr#+ , sizeOf, sizeOfType, alignment, alignmentOfType, defaultSetByteArray#, defaultSetOffAddr# , PrimStorable(..) , Ptr(..) ) where@@ -38,6 +36,7 @@ import Foreign.Ptr (IntPtr, intPtrToPtr, ptrToIntPtr, WordPtr, wordPtrToPtr, ptrToWordPtr) import Foreign.C.Types import System.Posix.Types+import Data.Complex import GHC.Word (Word8(..), Word16(..), Word32(..), Word64(..)) import GHC.Int (Int8(..), Int16(..), Int32(..), Int64(..))@@ -54,11 +53,11 @@ import GHC.IO (IO(..)) import qualified GHC.Exts - import Control.Applicative (Const(..)) import Data.Functor.Identity (Identity(..)) import qualified Data.Monoid as Monoid import qualified Data.Semigroup as Semigroup+import Data.Proxy #if !MIN_VERSION_base(4,13,0) import Data.Ord (Down(..))@@ -69,11 +68,31 @@ -- 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.+ -- We use `Proxy` instead of `Proxy#`, since the latter doesn't work with GND for GHC <= 8.8.++ -- | The size of values of type @a@ in bytes. This has to be used with TypeApplications: @sizeOfType \@a@.+ --+ -- @since 0.9.0.0+ sizeOfType# :: Proxy a -> Int#+ sizeOfType# _ = sizeOf# (dummy :: a)++ -- | The size of values of type @a@ in bytes. The argument is not used.+ --+ -- It is recommended to use 'sizeOfType#' instead. sizeOf# :: a -> Int#+ sizeOf# _ = sizeOfType# (Proxy :: Proxy a) - -- | Alignment of values of type @a@. The argument is not used.+ -- | The alignment of values of type @a@ in bytes. This has to be used with TypeApplications: @alignmentOfType \@a@.+ --+ -- @since 0.9.0.0+ alignmentOfType# :: Proxy a -> Int#+ alignmentOfType# _ = alignment# (dummy :: a)++ -- | The alignment of values of type @a@ in bytes. The argument is not used.+ --+ -- It is recommended to use 'alignmentOfType#' instead. alignment# :: a -> Int#+ alignment# _ = alignmentOfType# (Proxy :: Proxy a) -- | Read a value from the array. The offset is in elements of type -- @a@ rather than in bytes.@@ -96,6 +115,7 @@ -> a -> State# s -> State# s+ setByteArray# = defaultSetByteArray# -- | 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@@ -119,21 +139,88 @@ -> a -> State# s -> State# s+ setOffAddr# = defaultSetOffAddr# --- | Size of values of type @a@. The argument is not used.+ {-# MINIMAL (sizeOfType# | sizeOf#), (alignmentOfType# | alignment#), indexByteArray#, readByteArray#, writeByteArray#,+ indexOffAddr#, readOffAddr#, writeOffAddr# #-}++-- | A dummy value of type @a@.+dummy :: a+dummy = errorWithoutStackTrace "Data.Primitive.Types: implementation mistake in `Prim` instance"+{-# NOINLINE dummy #-}++-- | The size of values of type @a@ in bytes. This has to be used with TypeApplications: @sizeOfType \@a@. --+-- >>> :set -XTypeApplications+-- >>> import Data.Int (Int32)+-- >>> sizeOfType @Int32+-- 4+--+-- @since 0.9.0.0+sizeOfType :: forall a. Prim a => Int+sizeOfType = I# (sizeOfType# (Proxy :: Proxy a))++-- | The size of values of type @a@ in bytes. The argument is not used.+--+-- It is recommended to use 'sizeOfType' instead.+-- -- This function has existed since 0.1, but was moved from 'Data.Primitive' -- 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.+-- | The alignment of values of type @a@ in bytes. This has to be used with TypeApplications: @alignmentOfType \@a@. --+-- @since 0.9.0.0+alignmentOfType :: forall a. Prim a => Int+alignmentOfType = I# (alignmentOfType# (Proxy :: Proxy a))++-- | The alignment of values of type @a@ in bytes. The argument is not used.+--+-- It is recommended to use 'alignmentOfType' instead.+-- -- This function has existed since 0.1, but was moved from 'Data.Primitive' -- to 'Data.Primitive.Types' in version 0.6.3.0. alignment :: Prim a => a -> Int alignment x = I# (alignment# x) +-- | @since 0.9.0.0+instance Prim a => Prim (Complex a) where+ sizeOf# _ = 2# *# sizeOf# (undefined :: a)+ alignment# _ = alignment# (undefined :: a)+ indexByteArray# arr# i# =+ let x = indexByteArray# arr# (2# *# i#)+ y = indexByteArray# arr# (2# *# i# +# 1#)+ in x :+ y+ readByteArray# arr# i# =+ \s0 -> case readByteArray# arr# (2# *# i#) s0 of+ (# s1#, x #) -> case readByteArray# arr# (2# *# i# +# 1#) s1# of+ (# s2#, y #) -> (# s2#, x :+ y #)+ writeByteArray# arr# i# (a :+ b) =+ \s0 -> case writeByteArray# arr# (2# *# i#) a s0 of+ s1 -> case writeByteArray# arr# (2# *# i# +# 1#) b s1 of+ s2 -> s2+ indexOffAddr# addr# i# =+ let x = indexOffAddr# addr# (2# *# i#)+ y = indexOffAddr# addr# (2# *# i# +# 1#)+ in x :+ y+ readOffAddr# addr# i# =+ \s0 -> case readOffAddr# addr# (2# *# i#) s0 of+ (# s1, x #) -> case readOffAddr# addr# (2# *# i# +# 1#) s1 of+ (# s2, y #) -> (# s2, x :+ y #)+ writeOffAddr# addr# i# (a :+ b) =+ \s0 -> case writeOffAddr# addr# (2# *# i#) a s0 of+ s1 -> case writeOffAddr# addr# (2# *# i# +# 1#) b s1 of+ s2 -> s2+ {-# INLINE sizeOf# #-}+ {-# INLINE alignment# #-}+ {-# INLINE indexByteArray# #-}+ {-# INLINE readByteArray# #-}+ {-# INLINE writeByteArray# #-}+ {-# INLINE indexOffAddr# #-}+ {-# INLINE readOffAddr# #-}+ {-# INLINE writeOffAddr# #-}+ -- | 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@@ -143,8 +230,8 @@ -- > data Trip = Trip Int Int Int -- > -- > instance Prim Trip--- > sizeOf# _ = 3# *# sizeOf# (undefined :: Int)--- > alignment# _ = alignment# (undefined :: Int)+-- > sizeOfType# _ = 3# *# sizeOfType# (proxy# :: Proxy# Int)+-- > alignmentOfType# _ = alignmentOfType# (proxy# :: Proxy# Int) -- > indexByteArray# arr# i# = ... -- > readByteArray# arr# i# = ... -- > writeByteArray# arr# i# (Trip a b c) =@@ -194,8 +281,8 @@ newtype PrimStorable a = PrimStorable { getPrimStorable :: a } instance Prim a => Storable (PrimStorable a) where- sizeOf _ = sizeOf (undefined :: a)- alignment _ = alignment (undefined :: a)+ sizeOf _ = sizeOfType @a+ alignment _ = alignmentOfType @a peekElemOff (Ptr addr#) (I# i#) = primitive $ \s0# -> case readOffAddr# addr# i# s0# of (# s1, x #) -> (# s1, PrimStorable x #)@@ -204,8 +291,8 @@ #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 \+ sizeOfType# _ = unI# sz \+; alignmentOfType# _ = 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# #) } \@@ -227,8 +314,8 @@ } in \ case unsafeCoerce# (internal (set_addr addr# i n x#)) s# of \ { (# s1#, _ #) -> s1# } \-; {-# INLINE sizeOf# #-} \-; {-# INLINE alignment# #-} \+; {-# INLINE sizeOfType# #-} \+; {-# INLINE alignmentOfType# #-} \ ; {-# INLINE indexByteArray# #-} \ ; {-# INLINE readByteArray# #-} \ ; {-# INLINE writeByteArray# #-} \@@ -323,9 +410,7 @@ deriving instance Prim CSigAtomic deriving instance Prim CLLong deriving instance Prim CULLong-#if MIN_VERSION_base(4,10,0) deriving instance Prim CBool-#endif deriving instance Prim CIntPtr deriving instance Prim CUIntPtr deriving instance Prim CIntMax@@ -412,8 +497,8 @@ -- | @since 0.7.1.0 instance Prim WordPtr where- sizeOf# _ = sizeOf# (undefined :: Ptr ())- alignment# _ = alignment# (undefined :: Ptr ())+ sizeOfType# _ = sizeOfType# (Proxy :: Proxy (Ptr ()))+ alignmentOfType# _ = alignmentOfType# (Proxy :: Proxy (Ptr ())) indexByteArray# a i = ptrToWordPtr (indexByteArray# a i) readByteArray# a i s0 = case readByteArray# a i s0 of (# s1, p #) -> (# s1, ptrToWordPtr p #)@@ -427,8 +512,8 @@ -- | @since 0.7.1.0 instance Prim IntPtr where- sizeOf# _ = sizeOf# (undefined :: Ptr ())- alignment# _ = alignment# (undefined :: Ptr ())+ sizeOfType# _ = sizeOfType# (Proxy :: Proxy (Ptr ()))+ alignmentOfType# _ = alignmentOfType# (Proxy :: Proxy (Ptr ())) indexByteArray# a i = ptrToIntPtr (indexByteArray# a i) readByteArray# a i s0 = case readByteArray# a i s0 of (# s1, p #) -> (# s1, ptrToIntPtr p #)
bench/main.hs view
@@ -9,6 +9,7 @@ import Control.Monad.ST import Data.Primitive import Control.Monad.Trans.State.Strict+import Data.Set (Set) -- These are fixed implementations of certain operations. In the event -- that primitive changes its implementation of a function, these@@ -25,6 +26,8 @@ import qualified PrimArray.Compare import qualified PrimArray.Traverse +import qualified Data.Set as Set+ main :: IO () main = defaultMain [ bgroup "Array"@@ -34,6 +37,9 @@ , bench "unsafe" (nf (\x -> runST (runStateT (Array.Traverse.Unsafe.traversePoly cheap x) 0)) numbers) ] ]+ , bgroup "arrayFromListN"+ [ bench "set-to-list-to-array" (whnf arrayFromSet setOfIntegers1024)+ ] ] , bgroup "ByteArray" [ bgroup "compare"@@ -62,8 +68,18 @@ ] ] +setOfIntegers1024 :: Set Integer+{-# noinline setOfIntegers1024 #-}+setOfIntegers1024 = Set.fromList [1..1024]++-- The performance of this is used to confirm whether or not arrayFromListN is+-- actining as a good consumer for list fusion.+arrayFromSet :: Set Integer -> Array Integer+{-# noinline arrayFromSet #-}+arrayFromSet s = arrayFromListN (Set.size s) (Set.toList s)+ cheap :: Int -> StateT Int (ST s) Int cheap i = modify (\x -> x + i) >> return (i * i) numbers :: Array Int-numbers = fromList (enumFromTo 0 10000)+numbers = arrayFromList (enumFromTo 0 10000)
changelog.md view
@@ -1,3 +1,54 @@+## Changes in version 0.9.1.0++ * Make fromListN functions good consumers for list fusion.++ * Add functions to improve `MutVar`'s interoperability with `IORef` and `STRef`.++ * Add `createPrimArray` and `createByteArray`.++ * Add `byteArrayAsForeignPtr` and `mutableByteArrayAsForeignPtr`.++ * Use `copyMutableByteArrayNonOverlapping#` in the implementation of `copyMutableByteArray`+ on sufficiently new GHCs. This does not change the contract for `copyMutableByteArray`.+ This function has always been documented as having undefined behavior when the slices+ overlap. However, overlaps previously were handled gracefully (with the semantics+ of C's `memmove`). Going forward, users who do not uphold `copyMutableByteArray`'s+ precondition will be met with unpredictable results.++ * Drop support for GHC 8.0.++## Changes in version 0.9.0.0++ * Add `withByteArrayContents`, `withMutableByteArrayContents`,+ `withPrimArrayContents`, `withMutablePrimArrayContents`.++ * Fix signature of `keepAlive`.++ * Remove re-export of `fromList` and `fromListN` from `Data.Primitive.Array`.++ * Use `mutableByteArrayContents#` in GHC 9.2+++ * Add `Prim` instance for `Complex`.++ * Add `getSizeofSmallMutableArray` that wraps `getSizeofSmallMutableArray#`+ from `GHC.Exts`.++ * Add default definitions for the `setByteArray#` and `setOffAddr#` methods,+ so they don't need to be defined explicitly anymore.++ * Add standalone `sizeOfType`/`alignmentOfType` (recommended over `sizeOf`/`alignment`)+ and `Prim` class methods `sizeOfType#`/`alignmentOfType#` (recommended over `sizeOf#`/`alignment#`)++ * Change `Show` instances of `PrimArray`, `Array`, and `SmallArray`. These+ previously used the `fromListN n [...]` form, but they now used the more+ terse `[...]` form.++ * Correct the `Read` instances of `Array` and `SmallArray`. These instances+ are supposed to be able to handle all three of these forms: `fromList [...]`,+ `fromListN n [...]`, and `[...]`. They had been rejected the last form, but+ this mistake was discovered by the test suite when the Show instances were+ changed.+ ## Changes in version 0.8.0.0 * Add `resizeSmallMutableArray` that wraps `resizeSmallMutableArray#` from
primitive.cabal view
@@ -1,6 +1,6 @@ Cabal-Version: 2.0 Name: primitive-Version: 0.8.0.0+Version: 0.9.1.0 License: BSD3 License-File: LICENSE @@ -19,15 +19,17 @@ test/LICENSE Tested-With:- GHC == 8.0.2 GHC == 8.2.2 GHC == 8.4.4 GHC == 8.6.5 GHC == 8.8.4 GHC == 8.10.7 GHC == 9.0.2- GHC == 9.2.5- GHC == 9.4.4+ GHC == 9.2.8+ GHC == 9.4.8+ GHC == 9.6.6+ GHC == 9.8.2+ GHC == 9.10.1 Library Default-Language: Haskell2010@@ -53,9 +55,10 @@ Other-Modules: Data.Primitive.Internal.Operations+ Data.Primitive.Internal.Read - Build-Depends: base >= 4.9 && < 4.19- , deepseq >= 1.1 && < 1.5+ Build-Depends: base >= 4.10 && < 4.22+ , deepseq >= 1.1 && < 1.6 , transformers >= 0.5 && < 0.7 , template-haskell >= 2.11 @@ -69,7 +72,6 @@ Include-Dirs: cbits Install-Includes: primitive-memops.h- includes: primitive-memops.h c-sources: cbits/primitive-memops.c if !os(solaris) cc-options: -ftree-vectorize@@ -80,16 +82,15 @@ Default-Language: Haskell2010 hs-source-dirs: test test/src- main-is: main.hs+ main-is: Main.hs Other-Modules: PrimLaws type: exitcode-stdio-1.0 build-depends: base , base-orphans- , ghc-prim , primitive , quickcheck-classes-base >= 0.6 && <0.7- , QuickCheck >= 2.13 && < 2.15- , tasty ^>= 1.2 || ^>= 1.3 || ^>= 1.4+ , QuickCheck >= 2.13 && < 2.16+ , tasty >= 1.2 && < 1.6 , tasty-quickcheck , tagged , transformers >= 0.5@@ -112,6 +113,7 @@ PrimArray.Traverse build-depends: base+ , containers , primitive , deepseq , tasty-bench
+ test/Main.hs view
@@ -0,0 +1,439 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++#if __GLASGOW_HASKELL__ >= 805+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TypeInType #-}+#endif++import Control.Monad+import Control.Monad.ST+import Data.Complex+import Data.Primitive+import Data.Word+import Data.Proxy (Proxy(..))+import GHC.Int+import GHC.IO+import GHC.Exts+import Data.Function (on)+import Control.Applicative (Const(..))+import PrimLaws (primLaws)++import Data.Functor.Identity (Identity(..))+import qualified Data.Monoid as Monoid+import Data.Semigroup (stimes, stimesMonoid)+import qualified Data.Semigroup as Semigroup+#if !(MIN_VERSION_base(4,11,0))+import Data.Monoid ((<>))+#endif+#if __GLASGOW_HASKELL__ >= 805+import Foreign.Storable (Storable)+#endif+import Data.Orphans ()++import Test.Tasty (defaultMain,testGroup,TestTree)+import Test.QuickCheck (Arbitrary,Arbitrary1,Gen,CoArbitrary,Function,(===),(==>))+import qualified Test.Tasty.QuickCheck as TQC+import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck.Classes.Base as QCC+import qualified Test.QuickCheck.Classes.Base.IsList as QCCL+import qualified Data.List as L++main :: IO ()+main = do+ testArray+ testByteArray+ defaultMain $ testGroup "properties"+ [ testGroup "Array"+ [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (Array Int)))+ , lawsToTest (QCC.ordLaws (Proxy :: Proxy (Array Int)))+ , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Array Int)))+ , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))+ , lawsToTest (QCC.functorLaws (Proxy :: Proxy Array))+ , lawsToTest (QCC.applicativeLaws (Proxy :: Proxy Array))+ , lawsToTest (QCC.alternativeLaws (Proxy :: Proxy Array))+ , lawsToTest (QCC.monadLaws (Proxy :: Proxy Array))+ , lawsToTest (QCC.monadZipLaws (Proxy :: Proxy Array))+ , lawsToTest (QCC.monadPlusLaws (Proxy :: Proxy Array))+ , lawsToTest (QCC.foldableLaws (Proxy :: Proxy Array))+ , lawsToTest (QCC.traversableLaws (Proxy :: Proxy Array))+ , lawsToTest (QCC.isListLaws (Proxy :: Proxy (Array Int)))+ , TQC.testProperty "mapArray'" (QCCL.mapProp int16 int32 mapArray')+ , 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)+ , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (Array Int)))+ , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: Array Int) -> stimes n xs == stimesMonoid n xs+ ]+ , 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)))+ , lawsToTest (QCC.functorLaws (Proxy :: Proxy SmallArray))+ , lawsToTest (QCC.applicativeLaws (Proxy :: Proxy SmallArray))+ , lawsToTest (QCC.alternativeLaws (Proxy :: Proxy SmallArray))+ , lawsToTest (QCC.monadLaws (Proxy :: Proxy SmallArray))+ , lawsToTest (QCC.monadZipLaws (Proxy :: Proxy SmallArray))+ , lawsToTest (QCC.monadPlusLaws (Proxy :: Proxy SmallArray))+ , lawsToTest (QCC.foldableLaws (Proxy :: Proxy SmallArray))+ , lawsToTest (QCC.traversableLaws (Proxy :: Proxy SmallArray))+ , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SmallArray Int)))+ , TQC.testProperty "mapSmallArray'" (QCCL.mapProp int16 int32 mapSmallArray')+ , 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)+ , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (SmallArray Int)))+ , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: SmallArray Int) -> stimes n xs == stimesMonoid n xs+ ]+ , testGroup "ByteArray"+ [ testGroup "Ordering"+ [ TQC.testProperty "equality" byteArrayEqProp+ , TQC.testProperty "compare" byteArrayCompareProp+ , testGroup "Filling"+ [ TQC.testProperty "Int8" (setByteArrayProp (Proxy :: Proxy Int8))+ , TQC.testProperty "Int16" (setByteArrayProp (Proxy :: Proxy Int16))+ , TQC.testProperty "Int32" (setByteArrayProp (Proxy :: Proxy Int32))+ , TQC.testProperty "Int64" (setByteArrayProp (Proxy :: Proxy Int64))+ , TQC.testProperty "Int" (setByteArrayProp (Proxy :: Proxy Int))+ , TQC.testProperty "Word8" (setByteArrayProp (Proxy :: Proxy Word8))+ , TQC.testProperty "Word16" (setByteArrayProp (Proxy :: Proxy Word16))+ , TQC.testProperty "Word32" (setByteArrayProp (Proxy :: Proxy Word32))+ , TQC.testProperty "Word64" (setByteArrayProp (Proxy :: Proxy Word64))+ , TQC.testProperty "Word" (setByteArrayProp (Proxy :: Proxy Word))+ ]+ ]+ , testGroup "Resize"+ [ TQC.testProperty "shrink" byteArrayShrinkProp+ , TQC.testProperty "grow" byteArrayGrowProp+ ]+ , lawsToTest (QCC.eqLaws (Proxy :: Proxy ByteArray))+ , lawsToTest (QCC.ordLaws (Proxy :: Proxy ByteArray))+ , lawsToTest (QCC.monoidLaws (Proxy :: Proxy ByteArray))+ , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))+ , lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray))+ , TQC.testProperty "foldrByteArray" (QCCL.foldrProp word8 foldrByteArray)+ , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy ByteArray))+ , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: ByteArray) -> stimes n xs == stimesMonoid n xs+ ]+ , testGroup "PrimArray"+ [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (PrimArray Word16)))+ , lawsToTest (QCC.ordLaws (Proxy :: Proxy (PrimArray Word16)))+ , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (PrimArray Word16)))+ , lawsToTest (QCC.isListLaws (Proxy :: Proxy (PrimArray Word16)))+ , TQC.testProperty "foldrPrimArray" (QCCL.foldrProp int16 foldrPrimArray)+ , TQC.testProperty "foldrPrimArray'" (QCCL.foldrProp int16 foldrPrimArray')+ , TQC.testProperty "foldlPrimArray" (QCCL.foldlProp int16 foldlPrimArray)+ , TQC.testProperty "foldlPrimArray'" (QCCL.foldlProp int16 foldlPrimArray')+ , TQC.testProperty "foldlPrimArrayM'" (QCCL.foldlMProp int16 foldlPrimArrayM')+ , TQC.testProperty "mapPrimArray" (QCCL.mapProp int16 int32 mapPrimArray)+ , TQC.testProperty "traversePrimArray" (QCCL.traverseProp int16 int32 traversePrimArray)+ , TQC.testProperty "traversePrimArrayP" (QCCL.traverseProp int16 int32 traversePrimArrayP)+ , TQC.testProperty "imapPrimArray" (QCCL.imapProp int16 int32 imapPrimArray)+ , TQC.testProperty "itraversePrimArray" (QCCL.imapMProp int16 int32 itraversePrimArray)+ , TQC.testProperty "itraversePrimArrayP" (QCCL.imapMProp int16 int32 itraversePrimArrayP)+ , TQC.testProperty "generatePrimArray" (QCCL.generateProp int16 generatePrimArray)+ , TQC.testProperty "generatePrimArrayA" (QCCL.generateMProp int16 generatePrimArrayA)+ , TQC.testProperty "generatePrimArrayP" (QCCL.generateMProp int16 generatePrimArrayP)+ , TQC.testProperty "replicatePrimArray" (QCCL.replicateProp int16 replicatePrimArray)+ , TQC.testProperty "replicatePrimArrayA" (QCCL.replicateMProp int16 replicatePrimArrayA)+ , TQC.testProperty "replicatePrimArrayP" (QCCL.replicateMProp int16 replicatePrimArrayP)+ , TQC.testProperty "filterPrimArray" (QCCL.filterProp int16 filterPrimArray)+ , TQC.testProperty "filterPrimArrayA" (QCCL.filterMProp int16 filterPrimArrayA)+ , TQC.testProperty "filterPrimArrayP" (QCCL.filterMProp int16 filterPrimArrayP)+ , TQC.testProperty "mapMaybePrimArray" (QCCL.mapMaybeProp int16 int32 mapMaybePrimArray)+ , TQC.testProperty "mapMaybePrimArrayA" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayA)+ , TQC.testProperty "mapMaybePrimArrayP" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayP)+ , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (PrimArray Word16)))+ , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: PrimArray Word16) -> stimes n xs == stimesMonoid n xs+ ]+ , testGroup "DefaultSetMethod"+ [ lawsToTest (primLaws (Proxy :: Proxy DefaultSetMethod))+ ]+#if __GLASGOW_HASKELL__ >= 805+ , testGroup "PrimStorable"+ [ lawsToTest (QCC.storableLaws (Proxy :: Proxy Derived))+ ]+#endif+ , testGroup "Prim"+ [ renameLawsToTest "Word" (primLaws (Proxy :: Proxy Word))+ , renameLawsToTest "Word8" (primLaws (Proxy :: Proxy Word8))+ , renameLawsToTest "Word16" (primLaws (Proxy :: Proxy Word16))+ , renameLawsToTest "Word32" (primLaws (Proxy :: Proxy Word32))+ , renameLawsToTest "Word64" (primLaws (Proxy :: Proxy Word64))+ , renameLawsToTest "Int" (primLaws (Proxy :: Proxy Int))+ , renameLawsToTest "Int8" (primLaws (Proxy :: Proxy Int8))+ , renameLawsToTest "Int16" (primLaws (Proxy :: Proxy Int16))+ , renameLawsToTest "Int32" (primLaws (Proxy :: Proxy Int32))+ , renameLawsToTest "Int64" (primLaws (Proxy :: Proxy Int64))+ , renameLawsToTest "Const" (primLaws (Proxy :: Proxy (Const Int16 Int16)))+ , renameLawsToTest "Down" (primLaws (Proxy :: Proxy (Down Int16)))+ , 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)))+ , 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)))+ , renameLawsToTest "Complex" (primLaws (Proxy :: Proxy (Complex Double)))+ ]+ ]++deriving instance Arbitrary a => Arbitrary (Down a)+-- Const, Dual, Sum, Product: all have Arbitrary instances defined+-- in QuickCheck itself+deriving instance Arbitrary a => Arbitrary (Semigroup.First a)+deriving instance Arbitrary a => Arbitrary (Semigroup.Last a)+deriving instance Arbitrary a => Arbitrary (Semigroup.Min a)+deriving instance Arbitrary a => Arbitrary (Semigroup.Max a)++word8 :: Proxy Word8+word8 = Proxy++int16 :: Proxy Int16+int16 = Proxy++int32 :: Proxy Int32+int32 = Proxy+++setByteArrayProp :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> QC.Property+setByteArrayProp _ = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (off :: Int)) (QC.NonNegative (len :: Int)) (x :: a) (y :: a) ->+ (off < n && off + len <= n) ==>+ -- We use PrimArray in this test because it makes it easier to+ -- get the element-vs-byte distinction right.+ let actual = runST $ do+ m <- newPrimArray n+ forM_ (enumFromTo 0 (n - 1)) $ \ix -> writePrimArray m ix x+ setPrimArray m off len y+ unsafeFreezePrimArray m+ expected = runST $ do+ m <- newPrimArray n+ forM_ (enumFromTo 0 (n - 1)) $ \ix -> writePrimArray m ix x+ forM_ (enumFromTo off (off + len - 1)) $ \ix -> writePrimArray m ix y+ unsafeFreezePrimArray m+ in expected === actual+++-- Tests that using resizeByteArray to shrink a byte array produces+-- the same results as calling Data.List.take on the list that the+-- byte array corresponds to.+byteArrayShrinkProp :: QC.Property+byteArrayShrinkProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) ->+ let large = max n m+ small = min n m+ xs = intsLessThan large+ ys = byteArrayFromList xs+ largeBytes = large * sizeOfType @Int+ smallBytes = small * sizeOfType @Int+ expected = byteArrayFromList (L.take small xs)+ actual = runST $ do+ mzs0 <- newByteArray largeBytes+ copyByteArray mzs0 0 ys 0 largeBytes+ mzs1 <- resizeMutableByteArray mzs0 smallBytes+ unsafeFreezeByteArray mzs1+ in expected === actual++-- Tests that using resizeByteArray with copyByteArray (to fill in the+-- new empty space) to grow a byte array produces the same results as+-- calling Data.List.++ on the lists corresponding to the original+-- byte array and the appended byte array.+byteArrayGrowProp :: QC.Property+byteArrayGrowProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) ->+ let large = max n m+ small = min n m+ xs1 = intsLessThan small+ xs2 = intsLessThan (large - small)+ ys1 = byteArrayFromList xs1+ ys2 = byteArrayFromList xs2+ largeBytes = large * sizeOfType @Int+ smallBytes = small * sizeOfType @Int+ expected = byteArrayFromList (xs1 ++ xs2)+ actual = runST $ do+ mzs0 <- newByteArray smallBytes+ copyByteArray mzs0 0 ys1 0 smallBytes+ mzs1 <- resizeMutableByteArray mzs0 largeBytes+ copyByteArray mzs1 smallBytes ys2 0 ((large - small) * sizeOfType @Int)+ unsafeFreezeByteArray mzs1+ in expected === actual++-- Tests that writing stable ptrs to a PrimArray, reading them back+-- out, and then dereferencing them gives correct results.+--stablePtrPrimProp :: QC.Property+--stablePtrPrimProp = QC.property $ \(xs :: [Integer]) -> unsafePerformIO $ do+-- ptrs <- mapM newStablePtr xs+-- let ptrs' = primArrayToList (primArrayFromList ptrs)+-- ys <- mapM deRefStablePtr ptrs'+-- mapM_ freeStablePtr ptrs'+-- return (xs === ys)++--stablePtrPrimBlockProp :: QC.Property+--stablePtrPrimBlockProp = QC.property $ \(x :: Word) (QC.NonNegative (len :: Int)) -> unsafePerformIO $ do+-- ptr <- newStablePtr x+-- let ptrs' = replicatePrimArray len ptr+-- let go ix = if ix < len+-- then do+-- n <- deRefStablePtr (indexPrimArray ptrs' ix)+-- ns <- go (ix + 1)+-- return (n : ns)+-- else return []+-- ys <- go 0+-- freeStablePtr ptr+-- return (L.replicate len x === ys)++++-- Provide the non-negative integers up to the bound. For example:+--+-- >>> intsLessThan 5+-- [0,1,2,3,4]+intsLessThan :: Int -> [Int]+intsLessThan i = if i < 1+ then []+ else (i - 1) : intsLessThan (i - 1)++byteArrayCompareProp :: QC.Property+byteArrayCompareProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) ->+ compareLengthFirst xs ys === compare (byteArrayFromList xs) (byteArrayFromList ys)++byteArrayEqProp :: QC.Property+byteArrayEqProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) ->+ (compareLengthFirst xs ys == EQ) === (byteArrayFromList xs == byteArrayFromList ys)++compareLengthFirst :: [Word8] -> [Word8] -> Ordering+compareLengthFirst xs ys = (compare `on` length) xs ys <> compare xs ys++lawsToTest :: QCC.Laws -> TestTree+lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)++renameLawsToTest :: String -> QCC.Laws -> TestTree+renameLawsToTest name (QCC.Laws _ pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)++testArray :: IO ()+testArray = do+ arr <- newArray 1 'A'+ let unit =+ case writeArray arr 0 'B' of+ IO f ->+ case f realWorld# of+ (# _, _ #) -> ()+ c1 <- readArray arr 0+ return $! unit+ c2 <- readArray arr 0+ if c1 == 'A' && c2 == 'B'+ then return ()+ else error $ "Expected AB, got: " ++ show (c1, c2)++testByteArray :: IO ()+testByteArray = do+ let arr1 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])+ arr2 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])+ arr3 = mkByteArray ([0xde, 0xad, 0xbe, 0xee] :: [Word8])+ arr4 = mkByteArray ([0xde, 0xad, 0xbe, 0xdd] :: [Word8])+ arr5 = mkByteArray ([0xde, 0xad, 0xbe, 0xef, 0xde, 0xad, 0xbe, 0xdd] :: [Word8])+ arr6 = mkByteArray ([0xde, 0xad, 0x00, 0x01, 0xb0] :: [Word8])+ when (show arr1 /= "[0xde, 0xad, 0xbe, 0xef]") $+ fail $ "ByteArray Show incorrect: "++show arr1+ when (show arr6 /= "[0xde, 0xad, 0x00, 0x01, 0xb0]") $+ fail $ "ByteArray Show incorrect: "++ show arr6+ when (compareByteArrays arr3 1 arr4 1 3 /= GT) $+ fail $ "arr3[1,3] should be greater than arr4[1,3]"+ when (compareByteArrays arr3 0 arr4 1 3 /= GT) $+ fail $ "arr3[0,3] should be greater than arr4[1,3]"+ when (compareByteArrays arr5 1 arr2 1 3 /= EQ) $+ fail $ "arr3[1,3] should be equal to than arr4[1,3]"+ unless (arr1 > arr3) $+ fail $ "ByteArray Ord incorrect"+ unless (arr1 == arr2) $+ fail $ "ByteArray Eq incorrect"+ unless (mappend arr1 arr4 == arr5) $+ fail $ "ByteArray Monoid mappend incorrect"+ unless (mappend arr1 (mappend arr3 arr4) == mappend (mappend arr1 arr3) arr4) $+ fail $ "ByteArray Monoid mappend not associative"+ unless (mconcat [arr1,arr2,arr3,arr4,arr5] == (arr1 <> arr2 <> arr3 <> arr4 <> arr5)) $+ fail $ "ByteArray Monoid mconcat incorrect"+ unless (stimes (3 :: Int) arr4 == (arr4 <> arr4 <> arr4)) $+ fail $ "ByteArray Semigroup stimes incorrect"++mkByteArray :: forall a. Prim a => [a] -> ByteArray+mkByteArray xs = runST $ do+ marr <- newByteArray (length xs * sizeOfType @a)+ sequence_ $ zipWith (writeByteArray marr) [0..] xs+ unsafeFreezeByteArray marr++instance Arbitrary1 Array where+ liftArbitrary elemGen = fmap fromList (QC.liftArbitrary elemGen)++instance Arbitrary a => Arbitrary (Array a) where+ arbitrary = fmap fromList QC.arbitrary++instance Arbitrary1 SmallArray where+ liftArbitrary elemGen = fmap smallArrayFromList (QC.liftArbitrary elemGen)++instance Arbitrary a => Arbitrary (SmallArray a) where+ arbitrary = fmap smallArrayFromList QC.arbitrary++instance Arbitrary ByteArray where+ arbitrary = do+ xs <- QC.arbitrary :: Gen [Word8]+ return $ runST $ do+ a <- newByteArray (L.length xs)+ iforM_ xs $ \ix x -> do+ writeByteArray a ix x+ unsafeFreezeByteArray a++instance (Arbitrary a, Prim a) => Arbitrary (PrimArray a) where+ arbitrary = do+ xs <- QC.arbitrary :: Gen [a]+ return $ runST $ do+ a <- newPrimArray (L.length xs)+ iforM_ xs $ \ix x -> do+ writePrimArray a ix x+ unsafeFreezePrimArray a++++instance (Prim a, CoArbitrary a) => CoArbitrary (PrimArray a) where+ coarbitrary x = QC.coarbitrary (primArrayToList x)++instance (Prim a, Function a) => Function (PrimArray a) where+ function = QC.functionMap primArrayToList primArrayFromList++iforM_ :: Monad m => [a] -> (Int -> a -> m b) -> m ()+iforM_ xs0 f = go 0 xs0 where+ go !_ [] = return ()+ go !ix (x : xs) = f ix x >> go (ix + 1) xs++newtype DefaultSetMethod = DefaultSetMethod Int16+ deriving (Eq,Show,Arbitrary)++instance Prim DefaultSetMethod where+ sizeOfType# _ = sizeOfType# (Proxy :: Proxy Int16)+ alignmentOfType# _ = alignmentOfType# (Proxy :: Proxy Int16)+ indexByteArray# arr ix = DefaultSetMethod (indexByteArray# arr ix)+ readByteArray# arr ix s0 = case readByteArray# arr ix s0 of+ (# s1, n #) -> (# s1, DefaultSetMethod n #)+ writeByteArray# arr ix (DefaultSetMethod n) s0 = writeByteArray# arr ix n s0+ setByteArray# = defaultSetByteArray#+ indexOffAddr# addr off = DefaultSetMethod (indexOffAddr# addr off)+ readOffAddr# addr off s0 = case readOffAddr# addr off s0 of+ (# s1, n #) -> (# s1, DefaultSetMethod n #)+ writeOffAddr# addr off (DefaultSetMethod n) s0 = writeOffAddr# addr off n s0+ setOffAddr# = defaultSetOffAddr#++#if __GLASGOW_HASKELL__ >= 805+newtype Derived = Derived Int16+ deriving stock (Eq, Show)+ deriving newtype (Arbitrary, Prim)+ deriving Storable via (PrimStorable Derived)+#endif
− test/main.hs
@@ -1,434 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--#if __GLASGOW_HASKELL__ >= 805-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE TypeInType #-}-#endif--import Control.Monad-import Control.Monad.ST-import Data.Primitive-import Data.Word-import Data.Proxy (Proxy(..))-import GHC.Int-import GHC.IO-import GHC.Exts-import Data.Function (on)-import Control.Applicative (Const(..))-import PrimLaws (primLaws)--import Data.Functor.Identity (Identity(..))-import qualified Data.Monoid as Monoid-import Data.Ord (Down(..))-import Data.Semigroup (stimes, stimesMonoid)-import qualified Data.Semigroup as Semigroup-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid ((<>))-#endif-#if __GLASGOW_HASKELL__ >= 805-import Foreign.Storable (Storable)-#endif-import Data.Orphans ()--import Test.Tasty (defaultMain,testGroup,TestTree)-import Test.QuickCheck (Arbitrary,Arbitrary1,Gen,CoArbitrary,Function,(===),(==>))-import qualified Test.Tasty.QuickCheck as TQC-import qualified Test.QuickCheck as QC-import qualified Test.QuickCheck.Classes.Base as QCC-import qualified Test.QuickCheck.Classes.Base.IsList as QCCL-import qualified Data.List as L--main :: IO ()-main = do- testArray- testByteArray- defaultMain $ testGroup "properties"- [ testGroup "Array"- [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (Array Int)))- , lawsToTest (QCC.ordLaws (Proxy :: Proxy (Array Int)))- , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Array Int)))- , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))- , 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))- , lawsToTest (QCC.isListLaws (Proxy :: Proxy (Array Int)))- , TQC.testProperty "mapArray'" (QCCL.mapProp int16 int32 mapArray')- , 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)- , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (Array Int)))- , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: Array Int) -> stimes n xs == stimesMonoid n xs- ]- , 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)))- , 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))- , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SmallArray Int)))- , TQC.testProperty "mapSmallArray'" (QCCL.mapProp int16 int32 mapSmallArray')- , 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)- , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (SmallArray Int)))- , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: SmallArray Int) -> stimes n xs == stimesMonoid n xs- ]- , testGroup "ByteArray"- [ testGroup "Ordering"- [ TQC.testProperty "equality" byteArrayEqProp- , TQC.testProperty "compare" byteArrayCompareProp- , testGroup "Filling"- [ TQC.testProperty "Int8" (setByteArrayProp (Proxy :: Proxy Int8))- , TQC.testProperty "Int16" (setByteArrayProp (Proxy :: Proxy Int16))- , TQC.testProperty "Int32" (setByteArrayProp (Proxy :: Proxy Int32))- , TQC.testProperty "Int64" (setByteArrayProp (Proxy :: Proxy Int64))- , TQC.testProperty "Int" (setByteArrayProp (Proxy :: Proxy Int))- , TQC.testProperty "Word8" (setByteArrayProp (Proxy :: Proxy Word8))- , TQC.testProperty "Word16" (setByteArrayProp (Proxy :: Proxy Word16))- , TQC.testProperty "Word32" (setByteArrayProp (Proxy :: Proxy Word32))- , TQC.testProperty "Word64" (setByteArrayProp (Proxy :: Proxy Word64))- , TQC.testProperty "Word" (setByteArrayProp (Proxy :: Proxy Word))- ]- ]- , testGroup "Resize"- [ TQC.testProperty "shrink" byteArrayShrinkProp- , TQC.testProperty "grow" byteArrayGrowProp- ]- , lawsToTest (QCC.eqLaws (Proxy :: Proxy ByteArray))- , lawsToTest (QCC.ordLaws (Proxy :: Proxy ByteArray))- , lawsToTest (QCC.monoidLaws (Proxy :: Proxy ByteArray))- , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int)))- , lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray))- , TQC.testProperty "foldrByteArray" (QCCL.foldrProp word8 foldrByteArray)- , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy ByteArray))- , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: ByteArray) -> stimes n xs == stimesMonoid n xs- ]- , testGroup "PrimArray"- [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (PrimArray Word16)))- , lawsToTest (QCC.ordLaws (Proxy :: Proxy (PrimArray Word16)))- , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (PrimArray Word16)))- , lawsToTest (QCC.isListLaws (Proxy :: Proxy (PrimArray Word16)))- , TQC.testProperty "foldrPrimArray" (QCCL.foldrProp int16 foldrPrimArray)- , TQC.testProperty "foldrPrimArray'" (QCCL.foldrProp int16 foldrPrimArray')- , TQC.testProperty "foldlPrimArray" (QCCL.foldlProp int16 foldlPrimArray)- , TQC.testProperty "foldlPrimArray'" (QCCL.foldlProp int16 foldlPrimArray')- , TQC.testProperty "foldlPrimArrayM'" (QCCL.foldlMProp int16 foldlPrimArrayM')- , TQC.testProperty "mapPrimArray" (QCCL.mapProp int16 int32 mapPrimArray)- , TQC.testProperty "traversePrimArray" (QCCL.traverseProp int16 int32 traversePrimArray)- , TQC.testProperty "traversePrimArrayP" (QCCL.traverseProp int16 int32 traversePrimArrayP)- , TQC.testProperty "imapPrimArray" (QCCL.imapProp int16 int32 imapPrimArray)- , TQC.testProperty "itraversePrimArray" (QCCL.imapMProp int16 int32 itraversePrimArray)- , TQC.testProperty "itraversePrimArrayP" (QCCL.imapMProp int16 int32 itraversePrimArrayP)- , TQC.testProperty "generatePrimArray" (QCCL.generateProp int16 generatePrimArray)- , TQC.testProperty "generatePrimArrayA" (QCCL.generateMProp int16 generatePrimArrayA)- , TQC.testProperty "generatePrimArrayP" (QCCL.generateMProp int16 generatePrimArrayP)- , TQC.testProperty "replicatePrimArray" (QCCL.replicateProp int16 replicatePrimArray)- , TQC.testProperty "replicatePrimArrayA" (QCCL.replicateMProp int16 replicatePrimArrayA)- , TQC.testProperty "replicatePrimArrayP" (QCCL.replicateMProp int16 replicatePrimArrayP)- , TQC.testProperty "filterPrimArray" (QCCL.filterProp int16 filterPrimArray)- , TQC.testProperty "filterPrimArrayA" (QCCL.filterMProp int16 filterPrimArrayA)- , TQC.testProperty "filterPrimArrayP" (QCCL.filterMProp int16 filterPrimArrayP)- , TQC.testProperty "mapMaybePrimArray" (QCCL.mapMaybeProp int16 int32 mapMaybePrimArray)- , TQC.testProperty "mapMaybePrimArrayA" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayA)- , TQC.testProperty "mapMaybePrimArrayP" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayP)- , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (PrimArray Word16)))- , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: PrimArray Word16) -> stimes n xs == stimesMonoid n xs- ]- , testGroup "DefaultSetMethod"- [ lawsToTest (primLaws (Proxy :: Proxy DefaultSetMethod))- ]-#if __GLASGOW_HASKELL__ >= 805- , testGroup "PrimStorable"- [ lawsToTest (QCC.storableLaws (Proxy :: Proxy Derived))- ]-#endif- , testGroup "Prim"- [ renameLawsToTest "Word" (primLaws (Proxy :: Proxy Word))- , renameLawsToTest "Word8" (primLaws (Proxy :: Proxy Word8))- , renameLawsToTest "Word16" (primLaws (Proxy :: Proxy Word16))- , renameLawsToTest "Word32" (primLaws (Proxy :: Proxy Word32))- , renameLawsToTest "Word64" (primLaws (Proxy :: Proxy Word64))- , renameLawsToTest "Int" (primLaws (Proxy :: Proxy Int))- , renameLawsToTest "Int8" (primLaws (Proxy :: Proxy Int8))- , renameLawsToTest "Int16" (primLaws (Proxy :: Proxy Int16))- , renameLawsToTest "Int32" (primLaws (Proxy :: Proxy Int32))- , renameLawsToTest "Int64" (primLaws (Proxy :: Proxy Int64))- , renameLawsToTest "Const" (primLaws (Proxy :: Proxy (Const Int16 Int16)))- , renameLawsToTest "Down" (primLaws (Proxy :: Proxy (Down Int16)))- , 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)))- , 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)))- ]- ]--deriving instance Arbitrary a => Arbitrary (Down a)--- Const, Dual, Sum, Product: all have Arbitrary instances defined--- in QuickCheck itself-deriving instance Arbitrary a => Arbitrary (Semigroup.First a)-deriving instance Arbitrary a => Arbitrary (Semigroup.Last a)-deriving instance Arbitrary a => Arbitrary (Semigroup.Min a)-deriving instance Arbitrary a => Arbitrary (Semigroup.Max a)--word8 :: Proxy Word8-word8 = Proxy--int16 :: Proxy Int16-int16 = Proxy--int32 :: Proxy Int32-int32 = Proxy---setByteArrayProp :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> QC.Property-setByteArrayProp _ = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (off :: Int)) (QC.NonNegative (len :: Int)) (x :: a) (y :: a) ->- (off < n && off + len <= n) ==>- -- We use PrimArray in this test because it makes it easier to- -- get the element-vs-byte distinction right.- let actual = runST $ do- m <- newPrimArray n- forM_ (enumFromTo 0 (n - 1)) $ \ix -> writePrimArray m ix x- setPrimArray m off len y- unsafeFreezePrimArray m- expected = runST $ do- m <- newPrimArray n- forM_ (enumFromTo 0 (n - 1)) $ \ix -> writePrimArray m ix x- forM_ (enumFromTo off (off + len - 1)) $ \ix -> writePrimArray m ix y- unsafeFreezePrimArray m- in expected === actual----- Tests that using resizeByteArray to shrink a byte array produces--- the same results as calling Data.List.take on the list that the--- byte array corresponds to.-byteArrayShrinkProp :: QC.Property-byteArrayShrinkProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) ->- let large = max n m- small = min n m- xs = intsLessThan large- ys = byteArrayFromList xs- largeBytes = large * sizeOf (undefined :: Int)- smallBytes = small * sizeOf (undefined :: Int)- expected = byteArrayFromList (L.take small xs)- actual = runST $ do- mzs0 <- newByteArray largeBytes- copyByteArray mzs0 0 ys 0 largeBytes- mzs1 <- resizeMutableByteArray mzs0 smallBytes- unsafeFreezeByteArray mzs1- in expected === actual---- Tests that using resizeByteArray with copyByteArray (to fill in the--- new empty space) to grow a byte array produces the same results as--- calling Data.List.++ on the lists corresponding to the original--- byte array and the appended byte array.-byteArrayGrowProp :: QC.Property-byteArrayGrowProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) ->- let large = max n m- small = min n m- xs1 = intsLessThan small- xs2 = intsLessThan (large - small)- ys1 = byteArrayFromList xs1- ys2 = byteArrayFromList xs2- largeBytes = large * sizeOf (undefined :: Int)- smallBytes = small * sizeOf (undefined :: Int)- expected = byteArrayFromList (xs1 ++ xs2)- actual = runST $ do- mzs0 <- newByteArray smallBytes- copyByteArray mzs0 0 ys1 0 smallBytes- mzs1 <- resizeMutableByteArray mzs0 largeBytes- copyByteArray mzs1 smallBytes ys2 0 ((large - small) * sizeOf (undefined :: Int))- unsafeFreezeByteArray mzs1- in expected === actual---- Tests that writing stable ptrs to a PrimArray, reading them back--- out, and then dereferencing them gives correct results.---stablePtrPrimProp :: QC.Property---stablePtrPrimProp = QC.property $ \(xs :: [Integer]) -> unsafePerformIO $ do--- ptrs <- mapM newStablePtr xs--- let ptrs' = primArrayToList (primArrayFromList ptrs)--- ys <- mapM deRefStablePtr ptrs'--- mapM_ freeStablePtr ptrs'--- return (xs === ys)----stablePtrPrimBlockProp :: QC.Property---stablePtrPrimBlockProp = QC.property $ \(x :: Word) (QC.NonNegative (len :: Int)) -> unsafePerformIO $ do--- ptr <- newStablePtr x--- let ptrs' = replicatePrimArray len ptr--- let go ix = if ix < len--- then do--- n <- deRefStablePtr (indexPrimArray ptrs' ix)--- ns <- go (ix + 1)--- return (n : ns)--- else return []--- ys <- go 0--- freeStablePtr ptr--- return (L.replicate len x === ys)------ Provide the non-negative integers up to the bound. For example:------ >>> intsLessThan 5--- [0,1,2,3,4]-intsLessThan :: Int -> [Int]-intsLessThan i = if i < 1- then []- else (i - 1) : intsLessThan (i - 1)--byteArrayCompareProp :: QC.Property-byteArrayCompareProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) ->- compareLengthFirst xs ys === compare (byteArrayFromList xs) (byteArrayFromList ys)--byteArrayEqProp :: QC.Property-byteArrayEqProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) ->- (compareLengthFirst xs ys == EQ) === (byteArrayFromList xs == byteArrayFromList ys)--compareLengthFirst :: [Word8] -> [Word8] -> Ordering-compareLengthFirst xs ys = (compare `on` length) xs ys <> compare xs ys---- on GHC 7.4, Proxy is not polykinded, so we need this instead.-data Proxy1 (f :: * -> *) = Proxy1--lawsToTest :: QCC.Laws -> TestTree-lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)--renameLawsToTest :: String -> QCC.Laws -> TestTree-renameLawsToTest name (QCC.Laws _ pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)--testArray :: IO ()-testArray = do- arr <- newArray 1 'A'- let unit =- case writeArray arr 0 'B' of- IO f ->- case f realWorld# of- (# _, _ #) -> ()- c1 <- readArray arr 0- return $! unit- c2 <- readArray arr 0- if c1 == 'A' && c2 == 'B'- then return ()- else error $ "Expected AB, got: " ++ show (c1, c2)--testByteArray :: IO ()-testByteArray = do- let arr1 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])- arr2 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])- arr3 = mkByteArray ([0xde, 0xad, 0xbe, 0xee] :: [Word8])- arr4 = mkByteArray ([0xde, 0xad, 0xbe, 0xdd] :: [Word8])- arr5 = mkByteArray ([0xde, 0xad, 0xbe, 0xef, 0xde, 0xad, 0xbe, 0xdd] :: [Word8])- arr6 = mkByteArray ([0xde, 0xad, 0x00, 0x01, 0xb0] :: [Word8])- when (show arr1 /= "[0xde, 0xad, 0xbe, 0xef]") $- fail $ "ByteArray Show incorrect: "++show arr1- when (show arr6 /= "[0xde, 0xad, 0x00, 0x01, 0xb0]") $- fail $ "ByteArray Show incorrect: "++ show arr6- when (compareByteArrays arr3 1 arr4 1 3 /= GT) $- fail $ "arr3[1,3] should be greater than arr4[1,3]"- when (compareByteArrays arr3 0 arr4 1 3 /= GT) $- fail $ "arr3[0,3] should be greater than arr4[1,3]"- when (compareByteArrays arr5 1 arr2 1 3 /= EQ) $- fail $ "arr3[1,3] should be equal to than arr4[1,3]"- unless (arr1 > arr3) $- fail $ "ByteArray Ord incorrect"- unless (arr1 == arr2) $- fail $ "ByteArray Eq incorrect"- unless (mappend arr1 arr4 == arr5) $- fail $ "ByteArray Monoid mappend incorrect"- unless (mappend arr1 (mappend arr3 arr4) == mappend (mappend arr1 arr3) arr4) $- fail $ "ByteArray Monoid mappend not associative"- unless (mconcat [arr1,arr2,arr3,arr4,arr5] == (arr1 <> arr2 <> arr3 <> arr4 <> arr5)) $- fail $ "ByteArray Monoid mconcat incorrect"- unless (stimes (3 :: Int) arr4 == (arr4 <> arr4 <> arr4)) $- fail $ "ByteArray Semigroup stimes incorrect"--mkByteArray :: Prim a => [a] -> ByteArray-mkByteArray xs = runST $ do- marr <- newByteArray (length xs * sizeOf (head xs))- sequence_ $ zipWith (writeByteArray marr) [0..] xs- unsafeFreezeByteArray marr--instance Arbitrary1 Array where- liftArbitrary elemGen = fmap fromList (QC.liftArbitrary elemGen)--instance Arbitrary a => Arbitrary (Array a) where- arbitrary = fmap fromList QC.arbitrary--instance Arbitrary1 SmallArray where- liftArbitrary elemGen = fmap smallArrayFromList (QC.liftArbitrary elemGen)--instance Arbitrary a => Arbitrary (SmallArray a) where- arbitrary = fmap smallArrayFromList QC.arbitrary--instance Arbitrary ByteArray where- arbitrary = do- xs <- QC.arbitrary :: Gen [Word8]- return $ runST $ do- a <- newByteArray (L.length xs)- iforM_ xs $ \ix x -> do- writeByteArray a ix x- unsafeFreezeByteArray a--instance (Arbitrary a, Prim a) => Arbitrary (PrimArray a) where- arbitrary = do- xs <- QC.arbitrary :: Gen [a]- return $ runST $ do- a <- newPrimArray (L.length xs)- iforM_ xs $ \ix x -> do- writePrimArray a ix x- unsafeFreezePrimArray a----instance (Prim a, CoArbitrary a) => CoArbitrary (PrimArray a) where- coarbitrary x = QC.coarbitrary (primArrayToList x)--instance (Prim a, Function a) => Function (PrimArray a) where- function = QC.functionMap primArrayToList primArrayFromList--iforM_ :: Monad m => [a] -> (Int -> a -> m b) -> m ()-iforM_ xs0 f = go 0 xs0 where- go !_ [] = return ()- go !ix (x : xs) = f ix x >> go (ix + 1) xs--newtype DefaultSetMethod = DefaultSetMethod Int16- deriving (Eq,Show,Arbitrary)--instance Prim DefaultSetMethod where- sizeOf# _ = sizeOf# (undefined :: Int16)- alignment# _ = alignment# (undefined :: Int16)- indexByteArray# arr ix = DefaultSetMethod (indexByteArray# arr ix)- readByteArray# arr ix s0 = case readByteArray# arr ix s0 of- (# s1, n #) -> (# s1, DefaultSetMethod n #)- writeByteArray# arr ix (DefaultSetMethod n) s0 = writeByteArray# arr ix n s0- setByteArray# = defaultSetByteArray#- indexOffAddr# addr off = DefaultSetMethod (indexOffAddr# addr off)- readOffAddr# addr off s0 = case readOffAddr# addr off s0 of- (# s1, n #) -> (# s1, DefaultSetMethod n #)- writeOffAddr# addr off (DefaultSetMethod n) s0 = writeOffAddr# addr off n s0- setOffAddr# = defaultSetOffAddr#--#if __GLASGOW_HASKELL__ >= 805-newtype Derived = Derived Int16- deriving stock (Eq, Show)- deriving newtype (Arbitrary, Prim)- deriving Storable via (PrimStorable Derived)-#endif
test/src/PrimLaws.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wall #-} @@ -17,7 +17,6 @@ ( primLaws ) where -import Control.Applicative import Control.Monad.Primitive (primitive_) import Control.Monad.ST import Data.Proxy (Proxy)@@ -26,9 +25,7 @@ import Data.Primitive.Types import Data.Primitive.Ptr import Foreign.Marshal.Alloc-import GHC.Exts (State#,Int#,Int(I#),(+#),(<#))--import GHC.Exts (IsList(fromList,toList))+import GHC.Exts (State#, Int#, Int(I#), (+#), (<#), IsList(fromList,toList)) import System.IO.Unsafe import Test.QuickCheck hiding ((.&.))@@ -54,7 +51,7 @@ primListAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primListAddr _ = property $ \(as :: [a]) -> unsafePerformIO $ do let len = L.length as- ptr :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))+ ptr :: Ptr a <- mallocBytes (len * P.sizeOfType @a) let go :: Int -> [a] -> IO () go !ix xs = case xs of [] -> return ()@@ -113,7 +110,7 @@ primPutGetAddr _ = property $ \(a :: a) len -> (len > 0) ==> do ix <- choose (0,len - 1) return $ unsafePerformIO $ do- ptr :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a))+ ptr :: Ptr a <- mallocBytes (len * P.sizeOfType @a) writeOffPtr ptr ix a a' <- readOffPtr ptr ix free ptr