diff options
Diffstat (limited to 'third_party/bazel/rules_haskell/examples/primitive/Data')
14 files changed, 0 insertions, 5175 deletions
diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive.hs deleted file mode 100644 index db545ed815..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} --- | --- Module : Data.Primitive --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Reexports all primitive operations --- -module Data.Primitive ( - -- * Re-exports - module Data.Primitive.Types - ,module Data.Primitive.Array - ,module Data.Primitive.ByteArray - ,module Data.Primitive.Addr - ,module Data.Primitive.SmallArray - ,module Data.Primitive.UnliftedArray - ,module Data.Primitive.PrimArray - ,module Data.Primitive.MutVar - -- * Naming Conventions - -- $namingConventions -) where - -import Data.Primitive.Types -import Data.Primitive.Array -import Data.Primitive.ByteArray -import Data.Primitive.Addr -import Data.Primitive.SmallArray -import Data.Primitive.UnliftedArray -import Data.Primitive.PrimArray -import Data.Primitive.MutVar - -{- $namingConventions -For historical reasons, this library embraces the practice of suffixing -the name of a function with the type it operates on. For example, three -of the variants of the array indexing function are: - -> indexArray :: Array a -> Int -> a -> indexSmallArray :: SmallArray a -> Int -> a -> indexPrimArray :: Prim a => PrimArray a -> Int -> a - -In a few places, where the language sounds more natural, the array type -is instead used as a prefix. For example, @Data.Primitive.SmallArray@ -exports @smallArrayFromList@, which would sound unnatural if it used -@SmallArray@ as a suffix instead. - -This library provides several functions traversing, building, and filtering -arrays. These functions are suffixed with an additional character to -indicate their the nature of their effectfulness: - -* No suffix: A non-effectful pass over the array. -* @-A@ suffix: An effectful pass over the array, where the effect is 'Applicative'. -* @-P@ suffix: An effectful pass over the array, where the effect is 'PrimMonad'. - -Additionally, an apostrophe can be used to indicate strictness in the elements. -The variants with an apostrophe are used in @Data.Primitive.Array@ but not -in @Data.Primitive.PrimArray@ since the array type it provides is always strict in the element. -For example, there are three variants of the function that filters elements -from a primitive array. - -> filterPrimArray :: (Prim a ) => (a -> Bool) -> PrimArray a -> PrimArray a -> filterPrimArrayA :: (Prim a, Applicative f) => (a -> f Bool) -> PrimArray a -> f (PrimArray a) -> filterPrimArrayP :: (Prim a, PrimMonad m) => (a -> m Bool) -> PrimArray a -> m (PrimArray a) - -As long as the effectful context is a monad that is sufficiently affine -the behaviors of the 'Applicative' and 'PrimMonad' variants produce the same results -and differ only in their strictness. Monads that are sufficiently affine -include: - -* 'IO' and 'ST' -* Any combination of 'MaybeT', 'ExceptT', 'StateT' and 'Writer' on top - of another sufficiently affine monad. - -There is one situation where the names deviate from effectful suffix convention -described above. Throughout the haskell ecosystem, the 'Applicative' variant of -'map' is known as 'traverse', not @mapA@. Consequently, we adopt the following -naming convention for mapping: - -> mapPrimArray :: (Prim a, Prim b) => (a -> b) -> PrimArray a -> PrimArray b -> traversePrimArray :: (Applicative f, Prim a, Prim b) => (a -> f b) -> PrimArray a -> f (PrimArray b) -> traversePrimArrayP :: (PrimMonad m, Prim a, Prim b) => (a -> m b) -> PrimArray a -> m (PrimArray b) --} diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Addr.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Addr.hs deleted file mode 100644 index 2ff25005c6..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Addr.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples, CPP #-} - --- | --- Module : Data.Primitive.Addr --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Primitive operations on machine addresses --- - -module Data.Primitive.Addr ( - -- * Types - Addr(..), - - -- * Address arithmetic - nullAddr, plusAddr, minusAddr, remAddr, - - -- * Element access - indexOffAddr, readOffAddr, writeOffAddr, - - -- * Block operations - copyAddr, -#if __GLASGOW_HASKELL__ >= 708 - copyAddrToByteArray, -#endif - moveAddr, setAddr, - - -- * Conversion - addrToInt -) where - -import Control.Monad.Primitive -import Data.Primitive.Types -#if __GLASGOW_HASKELL__ >= 708 -import Data.Primitive.ByteArray -#endif - -import GHC.Base ( Int(..) ) -import GHC.Prim - -import GHC.Ptr -import Foreign.Marshal.Utils - - --- | The null address -nullAddr :: Addr -nullAddr = Addr nullAddr# - -infixl 6 `plusAddr`, `minusAddr` -infixl 7 `remAddr` - --- | Offset an address by the given number of bytes -plusAddr :: Addr -> Int -> Addr -plusAddr (Addr a#) (I# i#) = Addr (plusAddr# a# i#) - --- | Distance in bytes between two addresses. The result is only valid if the --- difference fits in an 'Int'. -minusAddr :: Addr -> Addr -> Int -minusAddr (Addr a#) (Addr b#) = I# (minusAddr# a# b#) - --- | The remainder of the address and the integer. -remAddr :: Addr -> Int -> Int -remAddr (Addr a#) (I# i#) = I# (remAddr# a# i#) - --- | 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 --- elements of type @a@ rather than in bytes. -indexOffAddr :: Prim a => Addr -> Int -> a -{-# INLINE indexOffAddr #-} -indexOffAddr (Addr addr#) (I# i#) = indexOffAddr# addr# i# - --- | Read a value from a memory position given by an address and an offset. --- The offset is in elements of type @a@ rather than in bytes. -readOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> m a -{-# INLINE readOffAddr #-} -readOffAddr (Addr addr#) (I# i#) = primitive (readOffAddr# addr# i#) - --- | Write a value to a memory position given by an address and an offset. --- The offset is in elements of type @a@ rather than in bytes. -writeOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m () -{-# INLINE writeOffAddr #-} -writeOffAddr (Addr addr#) (I# i#) x = primitive_ (writeOffAddr# addr# i# x) - --- | Copy the given number of bytes from the second 'Addr' to the first. The --- areas may not overlap. -copyAddr :: PrimMonad m => Addr -- ^ destination address - -> Addr -- ^ source address - -> Int -- ^ number of bytes - -> m () -{-# INLINE copyAddr #-} -copyAddr (Addr dst#) (Addr src#) n - = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) n - -#if __GLASGOW_HASKELL__ >= 708 --- | Copy the given number of bytes from the 'Addr' to the 'MutableByteArray'. --- The areas may not overlap. This function is only available when compiling --- with GHC 7.8 or newer. --- --- @since 0.6.4.0 -copyAddrToByteArray :: PrimMonad m - => MutableByteArray (PrimState m) -- ^ destination - -> Int -- ^ offset into the destination array - -> Addr -- ^ source - -> Int -- ^ number of bytes to copy - -> m () -{-# INLINE copyAddrToByteArray #-} -copyAddrToByteArray (MutableByteArray marr) (I# off) (Addr addr) (I# len) = - primitive_ $ copyAddrToByteArray# addr marr off len -#endif - --- | Copy the given number of bytes from the second 'Addr' to the first. The --- areas may overlap. -moveAddr :: PrimMonad m => Addr -- ^ destination address - -> Addr -- ^ source address - -> Int -- ^ number of bytes - -> m () -{-# INLINE moveAddr #-} -moveAddr (Addr dst#) (Addr src#) n - = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) n - --- | Fill a memory block of with the given value. The length is in --- elements of type @a@ rather than in bytes. -setAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m () -{-# INLINE setAddr #-} -setAddr (Addr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x) - --- | Convert an 'Addr' to an 'Int'. -addrToInt :: Addr -> Int -{-# INLINE addrToInt #-} -addrToInt (Addr addr#) = I# (addr2Int# addr#) diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Array.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Array.hs deleted file mode 100644 index 13352f6cb4..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Array.hs +++ /dev/null @@ -1,822 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, UnboxedTuples, DeriveDataTypeable, BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Data.Primitive.Array --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Primitive arrays of boxed values. --- - -module Data.Primitive.Array ( - Array(..), MutableArray(..), - - newArray, readArray, writeArray, indexArray, indexArrayM, indexArray##, - freezeArray, thawArray, runArray, - unsafeFreezeArray, unsafeThawArray, sameMutableArray, - copyArray, copyMutableArray, - cloneArray, cloneMutableArray, - sizeofArray, sizeofMutableArray, - fromListN, fromList, - mapArray', - traverseArrayP -) where - -import Control.Monad.Primitive - -import GHC.Base ( Int(..) ) -import GHC.Prim -import qualified GHC.Exts as Exts -#if (MIN_VERSION_base(4,7,0)) -import GHC.Exts (fromListN, fromList) -#endif - -import Data.Typeable ( Typeable ) -import Data.Data - (Data(..), DataType, mkDataType, Constr, mkConstr, Fixity(..), constrIndex) -import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) - -import Control.Monad.ST(ST,runST) - -import Control.Applicative -import Control.Monad (MonadPlus(..), when) -import Control.Monad.Fix -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip -#endif -import Data.Foldable (Foldable(..), toList) -#if !(MIN_VERSION_base(4,8,0)) -import Data.Traversable (Traversable(..)) -import Data.Monoid -#endif -#if MIN_VERSION_base(4,9,0) -import qualified GHC.ST as GHCST -import qualified Data.Foldable as F -import Data.Semigroup -#endif -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity -#endif -#if MIN_VERSION_base(4,10,0) -import GHC.Exts (runRW#) -#elif MIN_VERSION_base(4,9,0) -import GHC.Base (runRW#) -#endif - -import Text.ParserCombinators.ReadP - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..)) -#endif - --- | Boxed arrays -data Array a = Array - { array# :: Array# a } - deriving ( Typeable ) - --- | Mutable boxed arrays associated with a primitive state token. -data MutableArray s a = MutableArray - { marray# :: MutableArray# s a } - deriving ( Typeable ) - -sizeofArray :: Array a -> Int -sizeofArray a = I# (sizeofArray# (array# a)) -{-# INLINE sizeofArray #-} - -sizeofMutableArray :: MutableArray s a -> Int -sizeofMutableArray a = I# (sizeofMutableArray# (marray# a)) -{-# INLINE sizeofMutableArray #-} - --- | Create a new mutable array of the specified size and initialise all --- elements with the given value. -newArray :: PrimMonad m => Int -> a -> m (MutableArray (PrimState m) a) -{-# INLINE newArray #-} -newArray (I# n#) x = primitive - (\s# -> case newArray# n# x s# of - (# s'#, arr# #) -> - let ma = MutableArray arr# - in (# s'# , ma #)) - --- | Read a value from the array at the given index. -readArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> m a -{-# INLINE readArray #-} -readArray arr (I# i#) = primitive (readArray# (marray# arr) i#) - --- | Write a value to the array at the given index. -writeArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> a -> m () -{-# INLINE writeArray #-} -writeArray arr (I# i#) x = primitive_ (writeArray# (marray# arr) i# x) - --- | Read a value from the immutable array at the given index. -indexArray :: Array a -> Int -> a -{-# INLINE indexArray #-} -indexArray arr (I# i#) = case indexArray# (array# arr) i# of (# x #) -> x - --- | Read a value from the immutable array at the given index, returning --- the result in an unboxed unary tuple. This is currently used to implement --- folds. -indexArray## :: Array a -> Int -> (# a #) -indexArray## arr (I# i) = indexArray# (array# arr) i -{-# INLINE indexArray## #-} - --- | Monadically read a value from the immutable array at the given index. --- 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: --- --- > copy marr arr ... = do ... --- > writeArray marr i (indexArray arr i) ... --- > ... --- --- But since primitive arrays are lazy, the calls to 'indexArray' will not be --- evaluated. Rather, @marr@ will be filled with thunks each of which would --- retain a reference to @arr@. This is definitely not what we want! --- --- With 'indexArrayM', we can instead write --- --- > copy marr arr ... = do ... --- > x <- indexArrayM arr i --- > writeArray marr i x --- > ... --- --- Now, indexing is executed immediately although the returned element is --- still not evaluated. --- -indexArrayM :: Monad m => Array a -> Int -> m a -{-# INLINE indexArrayM #-} -indexArrayM arr (I# i#) - = case indexArray# (array# arr) i# of (# x #) -> return x - --- | Create an immutable copy of a slice of an array. --- --- This operation makes a copy of the specified section, so it is safe to --- continue using the mutable array afterward. -freezeArray - :: PrimMonad m - => MutableArray (PrimState m) a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (Array a) -{-# INLINE freezeArray #-} -freezeArray (MutableArray ma#) (I# off#) (I# len#) = - primitive $ \s -> case freezeArray# ma# off# len# s of - (# s', a# #) -> (# s', Array a# #) - --- | Convert a mutable array to an immutable one without copying. The --- array should not be modified after the conversion. -unsafeFreezeArray :: PrimMonad m => MutableArray (PrimState m) a -> m (Array a) -{-# INLINE unsafeFreezeArray #-} -unsafeFreezeArray arr - = primitive (\s# -> case unsafeFreezeArray# (marray# arr) s# of - (# s'#, arr'# #) -> - let a = Array arr'# - in (# s'#, a #)) - --- | Create a mutable array from a slice of an immutable array. --- --- This operation makes a copy of the specified slice, so it is safe to use the --- immutable array afterward. -thawArray - :: PrimMonad m - => Array a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (MutableArray (PrimState m) a) -{-# INLINE thawArray #-} -thawArray (Array a#) (I# off#) (I# len#) = - primitive $ \s -> case thawArray# a# off# len# s of - (# s', ma# #) -> (# s', MutableArray ma# #) - --- | Convert an immutable array to an mutable one without copying. The --- immutable array should not be used after the conversion. -unsafeThawArray :: PrimMonad m => Array a -> m (MutableArray (PrimState m) a) -{-# INLINE unsafeThawArray #-} -unsafeThawArray a - = primitive (\s# -> case unsafeThawArray# (array# a) s# of - (# s'#, arr'# #) -> - let ma = MutableArray arr'# - in (# s'#, ma #)) - --- | Check whether the two arrays refer to the same memory block. -sameMutableArray :: MutableArray s a -> MutableArray s a -> Bool -{-# INLINE sameMutableArray #-} -sameMutableArray arr brr - = isTrue# (sameMutableArray# (marray# arr) (marray# brr)) - --- | Copy a slice of an immutable array to a mutable array. -copyArray :: PrimMonad m - => MutableArray (PrimState m) a -- ^ destination array - -> Int -- ^ offset into destination array - -> Array a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of elements to copy - -> m () -{-# INLINE copyArray #-} -#if __GLASGOW_HASKELL__ > 706 --- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier -copyArray (MutableArray dst#) (I# doff#) (Array src#) (I# soff#) (I# len#) - = primitive_ (copyArray# src# soff# dst# doff# len#) -#else -copyArray !dst !doff !src !soff !len = go 0 - where - go i | i < len = do - x <- indexArrayM src (soff+i) - writeArray dst (doff+i) x - go (i+1) - | otherwise = return () -#endif - --- | Copy a slice of a mutable array to another array. The two arrays may --- not be the same. -copyMutableArray :: PrimMonad m - => MutableArray (PrimState m) a -- ^ destination array - -> Int -- ^ offset into destination array - -> MutableArray (PrimState m) a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of elements to copy - -> m () -{-# INLINE copyMutableArray #-} -#if __GLASGOW_HASKELL__ >= 706 --- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier -copyMutableArray (MutableArray dst#) (I# doff#) - (MutableArray src#) (I# soff#) (I# len#) - = primitive_ (copyMutableArray# src# soff# dst# doff# len#) -#else -copyMutableArray !dst !doff !src !soff !len = go 0 - where - go i | i < len = do - x <- readArray src (soff+i) - writeArray dst (doff+i) x - go (i+1) - | otherwise = return () -#endif - --- | Return a newly allocated Array with the specified subrange of the --- provided Array. The provided Array should contain the full subrange --- specified by the two Ints, but this is not checked. -cloneArray :: Array a -- ^ source array - -> Int -- ^ offset into destination array - -> Int -- ^ number of elements to copy - -> Array a -{-# INLINE cloneArray #-} -cloneArray (Array arr#) (I# off#) (I# len#) - = case cloneArray# arr# off# len# of arr'# -> Array arr'# - --- | Return a newly allocated MutableArray. with the specified subrange of --- the provided MutableArray. The provided MutableArray should contain the --- full subrange specified by the two Ints, but this is not checked. -cloneMutableArray :: PrimMonad m - => MutableArray (PrimState m) a -- ^ source array - -> Int -- ^ offset into destination array - -> Int -- ^ number of elements to copy - -> m (MutableArray (PrimState m) a) -{-# INLINE cloneMutableArray #-} -cloneMutableArray (MutableArray arr#) (I# off#) (I# len#) = primitive - (\s# -> case cloneMutableArray# arr# off# len# s# of - (# s'#, arr'# #) -> (# s'#, MutableArray arr'# #)) - -emptyArray :: Array a -emptyArray = - runST $ newArray 0 (die "emptyArray" "impossible") >>= unsafeFreezeArray -{-# NOINLINE emptyArray #-} - -#if !MIN_VERSION_base(4,9,0) -createArray - :: Int - -> a - -> (forall s. MutableArray s a -> ST s ()) - -> Array a -createArray 0 _ _ = emptyArray -createArray n x f = runArray $ do - mary <- newArray n x - f mary - pure mary - -runArray - :: (forall s. ST s (MutableArray s a)) - -> Array a -runArray m = runST $ m >>= unsafeFreezeArray - -#else /* Below, runRW# is available. */ - --- This low-level business is designed to work with GHC's worker-wrapper --- transformation. A lot of the time, we don't actually need an Array --- constructor. By putting it on the outside, and being careful about --- how we special-case the empty array, we can make GHC smarter about this. --- The only downside is that separately created 0-length arrays won't share --- their Array constructors, although they'll share their underlying --- Array#s. -createArray - :: Int - -> a - -> (forall s. MutableArray s a -> ST s ()) - -> Array a -createArray 0 _ _ = Array (emptyArray# (# #)) -createArray n x f = runArray $ do - mary <- newArray n x - f mary - pure mary - -runArray - :: (forall s. ST s (MutableArray s a)) - -> Array a -runArray m = Array (runArray# m) - -runArray# - :: (forall s. ST s (MutableArray s a)) - -> Array# a -runArray# m = case runRW# $ \s -> - case unST m s of { (# s', MutableArray mary# #) -> - unsafeFreezeArray# mary# s'} of (# _, ary# #) -> ary# - -unST :: ST s a -> State# s -> (# State# s, a #) -unST (GHCST.ST f) = f - -emptyArray# :: (# #) -> Array# a -emptyArray# _ = case emptyArray of Array ar -> ar -{-# NOINLINE emptyArray# #-} -#endif - - -die :: String -> String -> a -die fun problem = error $ "Data.Primitive.Array." ++ fun ++ ": " ++ problem - -arrayLiftEq :: (a -> b -> Bool) -> Array a -> Array b -> Bool -arrayLiftEq p a1 a2 = sizeofArray a1 == sizeofArray a2 && loop (sizeofArray a1 - 1) - where loop i | i < 0 = True - | (# x1 #) <- indexArray## a1 i - , (# x2 #) <- indexArray## a2 i - , otherwise = p x1 x2 && loop (i-1) - -instance Eq a => Eq (Array a) where - a1 == a2 = arrayLiftEq (==) a1 a2 - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Eq1 Array where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftEq = arrayLiftEq -#else - eq1 = arrayLiftEq (==) -#endif -#endif - -instance Eq (MutableArray s a) where - ma1 == ma2 = isTrue# (sameMutableArray# (marray# ma1) (marray# ma2)) - -arrayLiftCompare :: (a -> b -> Ordering) -> Array a -> Array b -> Ordering -arrayLiftCompare elemCompare a1 a2 = loop 0 - where - mn = sizeofArray a1 `min` sizeofArray a2 - loop i - | i < mn - , (# x1 #) <- indexArray## a1 i - , (# x2 #) <- indexArray## a2 i - = elemCompare x1 x2 `mappend` loop (i+1) - | otherwise = compare (sizeofArray a1) (sizeofArray a2) - --- | Lexicographic ordering. Subject to change between major versions. -instance Ord a => Ord (Array a) where - compare a1 a2 = arrayLiftCompare compare a1 a2 - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Ord1 Array where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftCompare = arrayLiftCompare -#else - compare1 = arrayLiftCompare compare -#endif -#endif - -instance Foldable Array where - -- Note: we perform the array lookups eagerly so we won't - -- create thunks to perform lookups even if GHC can't see - -- that the folding function is strict. - foldr f = \z !ary -> - let - !sz = sizeofArray ary - go i - | i == sz = z - | (# x #) <- indexArray## ary i - = f x (go (i+1)) - in go 0 - {-# INLINE foldr #-} - foldl f = \z !ary -> - let - go i - | i < 0 = z - | (# x #) <- indexArray## ary i - = f (go (i-1)) x - in go (sizeofArray ary - 1) - {-# INLINE foldl #-} - foldr1 f = \ !ary -> - let - !sz = sizeofArray ary - 1 - go i = - case indexArray## ary i of - (# x #) | i == sz -> x - | otherwise -> f x (go (i+1)) - in if sz < 0 - then die "foldr1" "empty array" - else go 0 - {-# INLINE foldr1 #-} - foldl1 f = \ !ary -> - let - !sz = sizeofArray ary - 1 - go i = - case indexArray## ary i of - (# x #) | i == 0 -> x - | otherwise -> f (go (i - 1)) x - in if sz < 0 - then die "foldl1" "empty array" - else go sz - {-# INLINE foldl1 #-} -#if MIN_VERSION_base(4,6,0) - foldr' f = \z !ary -> - let - go i !acc - | i == -1 = acc - | (# x #) <- indexArray## ary i - = go (i-1) (f x acc) - in go (sizeofArray ary - 1) z - {-# INLINE foldr' #-} - foldl' f = \z !ary -> - let - !sz = sizeofArray ary - go i !acc - | i == sz = acc - | (# x #) <- indexArray## ary i - = go (i+1) (f acc x) - in go 0 z - {-# INLINE foldl' #-} -#endif -#if MIN_VERSION_base(4,8,0) - null a = sizeofArray a == 0 - {-# INLINE null #-} - length = sizeofArray - {-# INLINE length #-} - maximum ary | sz == 0 = die "maximum" "empty array" - | (# frst #) <- indexArray## ary 0 - = go 1 frst - where - sz = sizeofArray ary - go i !e - | i == sz = e - | (# x #) <- indexArray## ary i - = go (i+1) (max e x) - {-# INLINE maximum #-} - minimum ary | sz == 0 = die "minimum" "empty array" - | (# frst #) <- indexArray## ary 0 - = go 1 frst - where sz = sizeofArray ary - go i !e - | i == sz = e - | (# x #) <- indexArray## ary i - = go (i+1) (min e x) - {-# INLINE minimum #-} - sum = foldl' (+) 0 - {-# INLINE sum #-} - product = foldl' (*) 1 - {-# INLINE product #-} -#endif - -newtype STA a = STA {_runSTA :: forall s. MutableArray# s a -> ST s (Array a)} - -runSTA :: Int -> STA a -> Array a -runSTA !sz = \ (STA m) -> runST $ newArray_ sz >>= \ ar -> m (marray# ar) -{-# INLINE runSTA #-} - -newArray_ :: Int -> ST s (MutableArray s a) -newArray_ !n = newArray n badTraverseValue - -badTraverseValue :: a -badTraverseValue = die "traverse" "bad indexing" -{-# NOINLINE badTraverseValue #-} - -instance Traversable Array where - traverse f = traverseArray f - {-# INLINE traverse #-} - -traverseArray - :: Applicative f - => (a -> f b) - -> Array a - -> f (Array b) -traverseArray f = \ !ary -> - let - !len = sizeofArray ary - go !i - | i == len = pure $ STA $ \mary -> unsafeFreezeArray (MutableArray mary) - | (# x #) <- indexArray## ary i - = liftA2 (\b (STA m) -> STA $ \mary -> - writeArray (MutableArray mary) i b >> m mary) - (f x) (go (i + 1)) - in if len == 0 - then pure emptyArray - else runSTA len <$> go 0 -{-# INLINE [1] traverseArray #-} - -{-# RULES -"traverse/ST" forall (f :: a -> ST s b). traverseArray f = - traverseArrayP f -"traverse/IO" forall (f :: a -> IO b). traverseArray f = - traverseArrayP f - #-} -#if MIN_VERSION_base(4,8,0) -{-# RULES -"traverse/Id" forall (f :: a -> Identity b). traverseArray f = - (coerce :: (Array a -> Array (Identity b)) - -> Array a -> Identity (Array b)) (fmap f) - #-} -#endif - --- | This is the fastest, most straightforward way to traverse --- an array, but it only works correctly with a sufficiently --- "affine" 'PrimMonad' instance. In particular, it must only produce --- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed --- monads, for example, will not work right at all. -traverseArrayP - :: PrimMonad m - => (a -> m b) - -> Array a - -> m (Array b) -traverseArrayP f = \ !ary -> - let - !sz = sizeofArray ary - go !i !mary - | i == sz - = unsafeFreezeArray mary - | otherwise - = do - a <- indexArrayM ary i - b <- f a - writeArray mary i b - go (i + 1) mary - in do - mary <- newArray sz badTraverseValue - go 0 mary -{-# INLINE traverseArrayP #-} - --- | Strict map over the elements of the array. -mapArray' :: (a -> b) -> Array a -> Array b -mapArray' f a = - createArray (sizeofArray a) (die "mapArray'" "impossible") $ \mb -> - let go i | i == sizeofArray a - = return () - | otherwise - = do x <- indexArrayM a i - -- We use indexArrayM here so that we will perform the - -- indexing eagerly even if f is lazy. - let !y = f x - writeArray mb i y >> go (i+1) - in go 0 -{-# INLINE mapArray' #-} - -arrayFromListN :: Int -> [a] -> Array a -arrayFromListN n l = - createArray n (die "fromListN" "uninitialized element") $ \sma -> - let go !ix [] = if ix == n - then return () - else die "fromListN" "list length less than specified size" - go !ix (x : xs) = if ix < n - then do - writeArray sma ix x - go (ix+1) xs - else die "fromListN" "list length greater than specified size" - in go 0 l - -arrayFromList :: [a] -> Array a -arrayFromList l = arrayFromListN (length l) l - -#if MIN_VERSION_base(4,7,0) -instance Exts.IsList (Array a) where - type Item (Array a) = a - fromListN = arrayFromListN - fromList = arrayFromList - toList = toList -#else -fromListN :: Int -> [a] -> Array a -fromListN = arrayFromListN - -fromList :: [a] -> Array a -fromList = arrayFromList -#endif - -instance Functor Array where - fmap f a = - createArray (sizeofArray a) (die "fmap" "impossible") $ \mb -> - let go i | i == sizeofArray a - = return () - | otherwise - = do x <- indexArrayM a i - writeArray mb i (f x) >> go (i+1) - in go 0 -#if MIN_VERSION_base(4,8,0) - e <$ a = createArray (sizeofArray a) e (\ !_ -> pure ()) -#endif - -instance Applicative Array where - pure x = runArray $ newArray 1 x - ab <*> a = createArray (szab*sza) (die "<*>" "impossible") $ \mb -> - let go1 i = when (i < szab) $ - do - f <- indexArrayM ab i - go2 (i*sza) f 0 - go1 (i+1) - go2 off f j = when (j < sza) $ - do - x <- indexArrayM a j - writeArray mb (off + j) (f x) - go2 off f (j + 1) - in go1 0 - where szab = sizeofArray ab ; sza = sizeofArray a - a *> b = createArray (sza*szb) (die "*>" "impossible") $ \mb -> - let go i | i < sza = copyArray mb (i * szb) b 0 szb - | otherwise = return () - in go 0 - where sza = sizeofArray a ; szb = sizeofArray b - a <* b = createArray (sza*szb) (die "<*" "impossible") $ \ma -> - let fill off i e | i < szb = writeArray ma (off+i) e >> fill off (i+1) e - | otherwise = return () - go i | i < sza - = do x <- indexArrayM a i - fill (i*szb) 0 x >> go (i+1) - | otherwise = return () - in go 0 - where sza = sizeofArray a ; szb = sizeofArray b - -instance Alternative Array where - empty = emptyArray - a1 <|> a2 = createArray (sza1 + sza2) (die "<|>" "impossible") $ \ma -> - copyArray ma 0 a1 0 sza1 >> copyArray ma sza1 a2 0 sza2 - where sza1 = sizeofArray a1 ; sza2 = sizeofArray a2 - some a | sizeofArray a == 0 = emptyArray - | otherwise = die "some" "infinite arrays are not well defined" - many a | sizeofArray a == 0 = pure [] - | otherwise = die "many" "infinite arrays are not well defined" - -data ArrayStack a - = PushArray !(Array a) !(ArrayStack a) - | EmptyStack --- See the note in SmallArray about how we might improve this. - -instance Monad Array where - return = pure - (>>) = (*>) - - ary >>= f = collect 0 EmptyStack (la-1) - where - la = sizeofArray ary - collect sz stk i - | i < 0 = createArray sz (die ">>=" "impossible") $ fill 0 stk - | (# x #) <- indexArray## ary i - , let sb = f x - lsb = sizeofArray sb - -- If we don't perform this check, we could end up allocating - -- a stack full of empty arrays if someone is filtering most - -- things out. So we refrain from pushing empty arrays. - = if lsb == 0 - then collect sz stk (i - 1) - else collect (sz + lsb) (PushArray sb stk) (i-1) - - fill _ EmptyStack _ = return () - fill off (PushArray sb sbs) smb - | let lsb = sizeofArray sb - = copyArray smb off sb 0 (lsb) - *> fill (off + lsb) sbs smb - - fail _ = empty - -instance MonadPlus Array where - mzero = empty - mplus = (<|>) - -zipW :: String -> (a -> b -> c) -> Array a -> Array b -> Array c -zipW s f aa ab = createArray mn (die s "impossible") $ \mc -> - let go i | i < mn - = do - x <- indexArrayM aa i - y <- indexArrayM ab i - writeArray mc i (f x y) - go (i+1) - | otherwise = return () - in go 0 - where mn = sizeofArray aa `min` sizeofArray ab -{-# INLINE zipW #-} - -#if MIN_VERSION_base(4,4,0) -instance MonadZip Array where - mzip aa ab = zipW "mzip" (,) aa ab - mzipWith f aa ab = zipW "mzipWith" f aa ab - munzip aab = runST $ do - let sz = sizeofArray aab - ma <- newArray sz (die "munzip" "impossible") - mb <- newArray sz (die "munzip" "impossible") - let go i | i < sz = do - (a, b) <- indexArrayM aab i - writeArray ma i a - writeArray mb i b - go (i+1) - go _ = return () - go 0 - (,) <$> unsafeFreezeArray ma <*> unsafeFreezeArray mb -#endif - -instance MonadFix Array where - mfix f = createArray (sizeofArray (f err)) - (die "mfix" "impossible") $ flip fix 0 $ - \r !i !mary -> when (i < sz) $ do - writeArray mary i (fix (\xi -> f xi `indexArray` i)) - r (i + 1) mary - where - sz = sizeofArray (f err) - err = error "mfix for Data.Primitive.Array applied to strict function." - -#if MIN_VERSION_base(4,9,0) --- | @since 0.6.3.0 -instance Semigroup (Array a) where - (<>) = (<|>) - sconcat = mconcat . F.toList -#endif - -instance Monoid (Array a) where - mempty = empty -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<|>) -#endif - mconcat l = createArray sz (die "mconcat" "impossible") $ \ma -> - let go !_ [ ] = return () - go off (a:as) = - copyArray ma off a 0 (sizeofArray a) >> go (off + sizeofArray a) as - in go 0 l - 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) - --- this need to be included for older ghcs -listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS -listLiftShowsPrec _ sl _ = sl - -instance Show a => Show (Array a) where - showsPrec p a = arrayLiftShowsPrec showsPrec showList p a - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Show1 Array where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftShowsPrec = arrayLiftShowsPrec -#else - showsPrec1 = arrayLiftShowsPrec showsPrec showList -#endif -#endif - -arrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Array a) -arrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do - () <$ string "fromListN" - skipSpaces - n <- readS_to_P reads - skipSpaces - l <- readS_to_P listReadsPrec - return $ arrayFromListN n l - -instance Read a => Read (Array a) where - readsPrec = arrayLiftReadsPrec readsPrec readList - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Read1 Array where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftReadsPrec = arrayLiftReadsPrec -#else - readsPrec1 = arrayLiftReadsPrec readsPrec readList -#endif -#endif - - -arrayDataType :: DataType -arrayDataType = mkDataType "Data.Primitive.Array.Array" [fromListConstr] - -fromListConstr :: Constr -fromListConstr = mkConstr arrayDataType "fromList" [] Prefix - -instance Data a => Data (Array a) where - toConstr _ = fromListConstr - dataTypeOf _ = arrayDataType - gunfold k z c = case constrIndex c of - 1 -> k (z fromList) - _ -> error "gunfold" - gfoldl f z m = z fromList `f` toList m - -instance (Typeable s, Typeable a) => Data (MutableArray s a) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Data.Primitive.Array.MutableArray" diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/ByteArray.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/ByteArray.hs deleted file mode 100644 index 527205330b..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/ByteArray.hs +++ /dev/null @@ -1,549 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Data.Primitive.ByteArray --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Primitive operations on ByteArrays --- - -module Data.Primitive.ByteArray ( - -- * Types - ByteArray(..), MutableByteArray(..), ByteArray#, MutableByteArray#, - - -- * Allocation - newByteArray, newPinnedByteArray, newAlignedPinnedByteArray, - resizeMutableByteArray, - - -- * Element access - readByteArray, writeByteArray, indexByteArray, - - -- * Constructing - byteArrayFromList, byteArrayFromListN, - - -- * Folding - foldrByteArray, - - -- * Freezing and thawing - unsafeFreezeByteArray, unsafeThawByteArray, - - -- * Block operations - copyByteArray, copyMutableByteArray, -#if __GLASGOW_HASKELL__ >= 708 - copyByteArrayToAddr, copyMutableByteArrayToAddr, -#endif - moveByteArray, - setByteArray, fillByteArray, - - -- * Information - sizeofByteArray, - sizeofMutableByteArray, getSizeofMutableByteArray, sameMutableByteArray, -#if __GLASGOW_HASKELL__ >= 802 - isByteArrayPinned, isMutableByteArrayPinned, -#endif - byteArrayContents, mutableByteArrayContents - -) where - -import Control.Monad.Primitive -import Control.Monad.ST -import Data.Primitive.Types - -import Foreign.C.Types -import Data.Word ( Word8 ) -import GHC.Base ( Int(..) ) -#if __GLASGOW_HASKELL__ >= 708 -import qualified GHC.Exts as Exts ( IsList(..) ) -#endif -import GHC.Prim -#if __GLASGOW_HASKELL__ >= 706 - hiding (setByteArray#) -#endif - -import Data.Typeable ( Typeable ) -import Data.Data ( Data(..) ) -import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) -import Numeric - -#if MIN_VERSION_base(4,9,0) -import qualified Data.Semigroup as SG -import qualified Data.Foldable as F -#endif - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid (Monoid(..)) -#endif - -#if __GLASGOW_HASKELL__ >= 802 -import GHC.Exts as Exts (isByteArrayPinned#,isMutableByteArrayPinned#) -#endif - -#if __GLASGOW_HASKELL__ >= 804 -import GHC.Exts (compareByteArrays#) -#else -import System.IO.Unsafe (unsafeDupablePerformIO) -#endif - --- | Byte arrays -data ByteArray = ByteArray ByteArray# deriving ( Typeable ) - --- | Mutable byte arrays associated with a primitive state token -data MutableByteArray s = MutableByteArray (MutableByteArray# s) - deriving( Typeable ) - --- | Create a new mutable byte array of the specified size in bytes. -newByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m)) -{-# INLINE newByteArray #-} -newByteArray (I# n#) - = primitive (\s# -> case newByteArray# n# s# of - (# 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. -newPinnedByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m)) -{-# INLINE newPinnedByteArray #-} -newPinnedByteArray (I# n#) - = primitive (\s# -> case newPinnedByteArray# n# s# of - (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) - --- | 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. -newAlignedPinnedByteArray - :: PrimMonad m - => Int -- ^ size - -> Int -- ^ alignment - -> m (MutableByteArray (PrimState m)) -{-# INLINE newAlignedPinnedByteArray #-} -newAlignedPinnedByteArray (I# n#) (I# k#) - = primitive (\s# -> case newAlignedPinnedByteArray# n# k# s# of - (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) - --- | Yield a pointer to the array's data. This operation is only safe on --- /pinned/ byte arrays allocated by 'newPinnedByteArray' or --- 'newAlignedPinnedByteArray'. -byteArrayContents :: ByteArray -> Addr -{-# INLINE byteArrayContents #-} -byteArrayContents (ByteArray arr#) = Addr (byteArrayContents# arr#) - --- | Yield a pointer to the array's data. This operation is only safe on --- /pinned/ byte arrays allocated by 'newPinnedByteArray' or --- 'newAlignedPinnedByteArray'. -mutableByteArrayContents :: MutableByteArray s -> Addr -{-# INLINE mutableByteArrayContents #-} -mutableByteArrayContents (MutableByteArray arr#) - = Addr (byteArrayContents# (unsafeCoerce# arr#)) - --- | Check if the two arrays refer to the same memory block. -sameMutableByteArray :: MutableByteArray s -> MutableByteArray s -> Bool -{-# INLINE sameMutableByteArray #-} -sameMutableByteArray (MutableByteArray arr#) (MutableByteArray brr#) - = isTrue# (sameMutableByteArray# arr# brr#) - --- | Resize a mutable byte array. The new size is given in bytes. --- --- This will either resize the array in-place or, if not possible, allocate the --- contents into a new, unpinned array and copy the original array's contents. --- --- To avoid undefined behaviour, the original 'MutableByteArray' shall not be --- accessed anymore after a 'resizeMutableByteArray' has been performed. --- Moreover, no reference to the old one should be kept in order to allow --- garbage collection of the original 'MutableByteArray' in case a new --- 'MutableByteArray' had to be allocated. --- --- @since 0.6.4.0 -resizeMutableByteArray - :: PrimMonad m => MutableByteArray (PrimState m) -> Int - -> m (MutableByteArray (PrimState m)) -{-# INLINE resizeMutableByteArray #-} -#if __GLASGOW_HASKELL__ >= 710 -resizeMutableByteArray (MutableByteArray arr#) (I# n#) - = primitive (\s# -> case resizeMutableByteArray# arr# n# s# of - (# s'#, arr'# #) -> (# s'#, MutableByteArray arr'# #)) -#else -resizeMutableByteArray arr n - = do arr' <- newByteArray n - copyMutableByteArray arr' 0 arr 0 (min (sizeofMutableByteArray arr) n) - return arr' -#endif - --- | Get the size of a byte array in bytes. Unlike 'sizeofMutableByteArray', --- this function ensures sequencing in the presence of resizing. -getSizeofMutableByteArray - :: PrimMonad m => MutableByteArray (PrimState m) -> m Int -{-# INLINE getSizeofMutableByteArray #-} -#if __GLASGOW_HASKELL__ >= 801 -getSizeofMutableByteArray (MutableByteArray arr#) - = primitive (\s# -> case getSizeofMutableByteArray# arr# s# of - (# s'#, n# #) -> (# s'#, I# n# #)) -#else -getSizeofMutableByteArray arr - = return (sizeofMutableByteArray arr) -#endif - --- | Convert a mutable byte array to an immutable one without copying. The --- array should not be modified after the conversion. -unsafeFreezeByteArray - :: PrimMonad m => MutableByteArray (PrimState m) -> m ByteArray -{-# INLINE unsafeFreezeByteArray #-} -unsafeFreezeByteArray (MutableByteArray arr#) - = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of - (# s'#, arr'# #) -> (# s'#, ByteArray arr'# #)) - --- | Convert an immutable byte array to a mutable one without copying. The --- original array should not be used after the conversion. -unsafeThawByteArray - :: PrimMonad m => ByteArray -> m (MutableByteArray (PrimState m)) -{-# INLINE unsafeThawByteArray #-} -unsafeThawByteArray (ByteArray arr#) - = primitive (\s# -> (# s#, MutableByteArray (unsafeCoerce# arr#) #)) - --- | Size of the byte array in bytes. -sizeofByteArray :: ByteArray -> Int -{-# INLINE sizeofByteArray #-} -sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#) - --- | Size of the mutable byte array in bytes. This function\'s 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. -sizeofMutableByteArray :: MutableByteArray s -> Int -{-# INLINE sizeofMutableByteArray #-} -sizeofMutableByteArray (MutableByteArray arr#) = I# (sizeofMutableByteArray# arr#) - -#if __GLASGOW_HASKELL__ >= 802 --- | Check whether or not the byte array is pinned. Pinned byte arrays cannot --- be moved by the garbage collector. It is safe to use 'byteArrayContents' --- on such byte arrays. This function is only available when compiling with --- GHC 8.2 or newer. --- --- @since 0.6.4.0 -isByteArrayPinned :: ByteArray -> Bool -{-# INLINE isByteArrayPinned #-} -isByteArrayPinned (ByteArray arr#) = isTrue# (Exts.isByteArrayPinned# arr#) - --- | Check whether or not the mutable byte array is pinned. This function is --- only available when compiling with GHC 8.2 or newer. --- --- @since 0.6.4.0 -isMutableByteArrayPinned :: MutableByteArray s -> Bool -{-# INLINE isMutableByteArrayPinned #-} -isMutableByteArrayPinned (MutableByteArray marr#) = isTrue# (Exts.isMutableByteArrayPinned# marr#) -#endif - --- | Read a primitive value from the byte array. The offset is given in --- elements of type @a@ rather than in bytes. -indexByteArray :: Prim a => ByteArray -> Int -> a -{-# INLINE indexByteArray #-} -indexByteArray (ByteArray arr#) (I# i#) = indexByteArray# arr# i# - --- | Read a primitive value from the byte array. The offset is given in --- elements of type @a@ rather than in bytes. -readByteArray - :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> m a -{-# INLINE readByteArray #-} -readByteArray (MutableByteArray arr#) (I# i#) - = primitive (readByteArray# arr# i#) - --- | Write a primitive value to the byte array. The offset is given in --- elements of type @a@ rather than in bytes. -writeByteArray - :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> a -> m () -{-# INLINE writeByteArray #-} -writeByteArray (MutableByteArray arr#) (I# i#) x - = primitive_ (writeByteArray# arr# i# x) - --- | Right-fold over the elements of a 'ByteArray'. -foldrByteArray :: forall a b. (Prim a) => (a -> b -> b) -> b -> ByteArray -> b -foldrByteArray f z arr = go 0 - where - go i - | sizeofByteArray arr > i * sz = f (indexByteArray arr i) (go (i+1)) - | otherwise = z - sz = sizeOf (undefined :: a) - -byteArrayFromList :: Prim a => [a] -> ByteArray -byteArrayFromList xs = byteArrayFromListN (length xs) xs - -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 - -unI# :: Int -> Int# -unI# (I# n#) = n# - --- | Copy a slice of an immutable byte array to a mutable byte array. -copyByteArray - :: PrimMonad m => MutableByteArray (PrimState m) - -- ^ destination array - -> Int -- ^ offset into destination array - -> ByteArray -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of bytes to copy - -> m () -{-# INLINE copyByteArray #-} -copyByteArray (MutableByteArray dst#) doff (ByteArray src#) soff sz - = primitive_ (copyByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz)) - --- | Copy a slice of a mutable byte array into another array. The two slices --- may not overlap. -copyMutableByteArray - :: PrimMonad m => MutableByteArray (PrimState m) - -- ^ destination array - -> Int -- ^ offset into destination array - -> MutableByteArray (PrimState m) - -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of bytes to copy - -> m () -{-# INLINE copyMutableByteArray #-} -copyMutableByteArray (MutableByteArray dst#) doff - (MutableByteArray src#) soff sz - = primitive_ (copyMutableByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz)) - -#if __GLASGOW_HASKELL__ >= 708 --- | Copy a slice of a byte array to an unmanaged address. These must not --- overlap. This function is only available when compiling with GHC 7.8 --- or newer. --- --- @since 0.6.4.0 -copyByteArrayToAddr - :: PrimMonad m - => Addr -- ^ destination - -> ByteArray -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of bytes to copy - -> m () -{-# INLINE copyByteArrayToAddr #-} -copyByteArrayToAddr (Addr dst#) (ByteArray src#) soff sz - = primitive_ (copyByteArrayToAddr# src# (unI# soff) dst# (unI# sz)) - --- | Copy a slice of a mutable byte array to an unmanaged address. These must --- not overlap. This function is only available when compiling with GHC 7.8 --- or newer. --- --- @since 0.6.4.0 -copyMutableByteArrayToAddr - :: PrimMonad m - => Addr -- ^ destination - -> MutableByteArray (PrimState m) -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of bytes to copy - -> m () -{-# INLINE copyMutableByteArrayToAddr #-} -copyMutableByteArrayToAddr (Addr dst#) (MutableByteArray src#) soff sz - = primitive_ (copyMutableByteArrayToAddr# src# (unI# soff) dst# (unI# sz)) -#endif - --- | Copy a slice of a mutable byte array into another, potentially --- overlapping array. -moveByteArray - :: PrimMonad m => MutableByteArray (PrimState m) - -- ^ destination array - -> Int -- ^ offset into destination array - -> MutableByteArray (PrimState m) - -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of bytes to copy - -> m () -{-# INLINE moveByteArray #-} -moveByteArray (MutableByteArray dst#) doff - (MutableByteArray src#) soff sz - = unsafePrimToPrim - $ memmove_mba dst# (fromIntegral doff) src# (fromIntegral soff) - (fromIntegral 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. -setByteArray - :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -- ^ array to fill - -> Int -- ^ offset into array - -> Int -- ^ number of values to fill - -> a -- ^ value to fill with - -> m () -{-# INLINE setByteArray #-} -setByteArray (MutableByteArray dst#) (I# doff#) (I# sz#) x - = primitive_ (setByteArray# dst# doff# sz# x) - --- | Fill a slice of a mutable byte array with a byte. -fillByteArray - :: PrimMonad m => MutableByteArray (PrimState m) - -- ^ array to fill - -> Int -- ^ offset into array - -> Int -- ^ number of bytes to fill - -> Word8 -- ^ byte to fill with - -> m () -{-# INLINE fillByteArray #-} -fillByteArray = setByteArray - -foreign import ccall unsafe "primitive-memops.h hsprimitive_memmove" - memmove_mba :: MutableByteArray# s -> CInt - -> MutableByteArray# s -> CInt - -> CSize -> IO () - -instance Data ByteArray where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.ByteArray" - -instance Typeable s => Data (MutableByteArray s) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.MutableByteArray" - --- | @since 0.6.3.0 -instance Show ByteArray where - showsPrec _ ba = - showString "[" . go 0 - where - go i - | i < sizeofByteArray ba = comma . showString "0x" . showHex (indexByteArray ba i :: Word8) . go (i+1) - | otherwise = showChar ']' - where - comma | i == 0 = id - | otherwise = showString ", " - - -compareByteArrays :: ByteArray -> ByteArray -> Int -> Ordering -{-# INLINE compareByteArrays #-} -#if __GLASGOW_HASKELL__ >= 804 -compareByteArrays (ByteArray ba1#) (ByteArray ba2#) (I# n#) = - compare (I# (compareByteArrays# ba1# 0# ba2# 0# n#)) 0 -#else --- Emulate GHC 8.4's 'GHC.Prim.compareByteArrays#' -compareByteArrays (ByteArray ba1#) (ByteArray ba2#) (I# n#) - = compare (fromCInt (unsafeDupablePerformIO (memcmp_ba ba1# ba2# n))) 0 - where - n = fromIntegral (I# n#) :: CSize - fromCInt = fromIntegral :: CInt -> Int - -foreign import ccall unsafe "primitive-memops.h hsprimitive_memcmp" - memcmp_ba :: ByteArray# -> ByteArray# -> CSize -> IO CInt -#endif - - -sameByteArray :: ByteArray# -> ByteArray# -> Bool -sameByteArray ba1 ba2 = - case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of -#if __GLASGOW_HASKELL__ >= 708 - r -> isTrue# r -#else - 1# -> True - 0# -> False -#endif - --- | @since 0.6.3.0 -instance Eq ByteArray where - ba1@(ByteArray ba1#) == ba2@(ByteArray ba2#) - | sameByteArray ba1# ba2# = True - | n1 /= n2 = False - | otherwise = compareByteArrays ba1 ba2 n1 == EQ - where - n1 = sizeofByteArray ba1 - n2 = sizeofByteArray ba2 - --- | Non-lexicographic ordering. This compares the lengths of --- the byte arrays first and uses a lexicographic ordering if --- the lengths are equal. Subject to change between major versions. --- --- @since 0.6.3.0 -instance Ord ByteArray where - ba1@(ByteArray ba1#) `compare` ba2@(ByteArray ba2#) - | sameByteArray ba1# ba2# = EQ - | n1 /= n2 = n1 `compare` n2 - | otherwise = compareByteArrays ba1 ba2 n1 - where - n1 = sizeofByteArray ba1 - n2 = sizeofByteArray ba2 --- Note: On GHC 8.4, the primop compareByteArrays# performs a check for pointer --- equality as a shortcut, so the check here is actually redundant. However, it --- is included here because it is likely better to check for pointer equality --- before checking for length equality. Getting the length requires deferencing --- the pointers, which could cause accesses to memory that is not in the cache. --- By contrast, a pointer equality check is always extremely cheap. - -appendByteArray :: ByteArray -> ByteArray -> ByteArray -appendByteArray a b = runST $ do - marr <- newByteArray (sizeofByteArray a + sizeofByteArray b) - copyByteArray marr 0 a 0 (sizeofByteArray a) - copyByteArray marr (sizeofByteArray a) b 0 (sizeofByteArray b) - unsafeFreezeByteArray marr - -concatByteArray :: [ByteArray] -> ByteArray -concatByteArray arrs = runST $ do - let len = calcLength arrs 0 - marr <- newByteArray len - pasteByteArrays marr 0 arrs - unsafeFreezeByteArray marr - -pasteByteArrays :: MutableByteArray s -> Int -> [ByteArray] -> ST s () -pasteByteArrays !_ !_ [] = return () -pasteByteArrays !marr !ix (x : xs) = do - copyByteArray marr ix x 0 (sizeofByteArray x) - pasteByteArrays marr (ix + sizeofByteArray x) xs - -calcLength :: [ByteArray] -> Int -> Int -calcLength [] !n = n -calcLength (x : xs) !n = calcLength xs (sizeofByteArray x + n) - -emptyByteArray :: ByteArray -emptyByteArray = runST (newByteArray 0 >>= unsafeFreezeByteArray) - -replicateByteArray :: Int -> ByteArray -> ByteArray -replicateByteArray n arr = runST $ do - marr <- newByteArray (n * sizeofByteArray arr) - let go i = if i < n - then do - copyByteArray marr (i * sizeofByteArray arr) arr 0 (sizeofByteArray arr) - go (i + 1) - else return () - go 0 - unsafeFreezeByteArray marr - -#if MIN_VERSION_base(4,9,0) -instance SG.Semigroup ByteArray where - (<>) = appendByteArray - sconcat = mconcat . F.toList - stimes i arr - | itgr < 1 = emptyByteArray - | itgr <= (fromIntegral (maxBound :: Int)) = replicateByteArray (fromIntegral itgr) arr - | otherwise = error "Data.Primitive.ByteArray#stimes: cannot allocate the requested amount of memory" - where itgr = toInteger i :: Integer -#endif - -instance Monoid ByteArray where - mempty = emptyByteArray -#if !(MIN_VERSION_base(4,11,0)) - mappend = appendByteArray -#endif - mconcat = concatByteArray - -#if __GLASGOW_HASKELL__ >= 708 --- | @since 0.6.3.0 -instance Exts.IsList ByteArray where - type Item ByteArray = Word8 - - toList = foldrByteArray (:) [] - fromList xs = byteArrayFromListN (length xs) xs - fromListN = byteArrayFromListN -#endif - -die :: String -> String -> a -die fun problem = error $ "Data.Primitive.ByteArray." ++ fun ++ ": " ++ problem - diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Compat.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Compat.hs deleted file mode 100644 index f6b8016ad9..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Compat.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} - --- | --- Module : Data.Primitive.Internal.Compat --- Copyright : (c) Roman Leshchinskiy 2011-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Compatibility functions --- - -module Data.Primitive.Internal.Compat ( - isTrue# - , mkNoRepType - ) where - -#if MIN_VERSION_base(4,2,0) -import Data.Data (mkNoRepType) -#else -import Data.Data (mkNorepType) -#endif - -#if MIN_VERSION_base(4,7,0) -import GHC.Exts (isTrue#) -#endif - - - -#if !MIN_VERSION_base(4,2,0) -mkNoRepType = mkNorepType -#endif - -#if !MIN_VERSION_base(4,7,0) -isTrue# :: Bool -> Bool -isTrue# b = b -#endif diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Operations.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Operations.hs deleted file mode 100644 index 091e11f5d6..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Operations.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE MagicHash, UnliftedFFITypes #-} - --- | --- Module : Data.Primitive.Internal.Operations --- Copyright : (c) Roman Leshchinskiy 2011-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Internal operations --- - - -module Data.Primitive.Internal.Operations ( - setWord8Array#, setWord16Array#, setWord32Array#, - setWord64Array#, setWordArray#, - setInt8Array#, setInt16Array#, setInt32Array#, - setInt64Array#, setIntArray#, - setAddrArray#, setFloatArray#, setDoubleArray#, setWideCharArray#, - - setWord8OffAddr#, setWord16OffAddr#, setWord32OffAddr#, - setWord64OffAddr#, setWordOffAddr#, - setInt8OffAddr#, setInt16OffAddr#, setInt32OffAddr#, - setInt64OffAddr#, setIntOffAddr#, - setAddrOffAddr#, setFloatOffAddr#, setDoubleOffAddr#, setWideCharOffAddr# -) where - -import Data.Primitive.MachDeps (Word64_#, Int64_#) -import Foreign.C.Types -import GHC.Prim - -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" - setWord8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" - setWord16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" - setWord32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" - setWord64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word64_# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" - setWordArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" - setInt8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" - setInt16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" - setInt32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" - setInt64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int64_# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" - setIntArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" - setAddrArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Addr# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float" - setFloatArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Float# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double" - setDoubleArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Double# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" - setWideCharArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Char# -> IO () - -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" - setWord8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" - setWord16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" - setWord32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" - setWord64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word64_# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" - setWordOffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" - setInt8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" - setInt16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" - setInt32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" - setInt64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int64_# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" - setIntOffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" - setAddrOffAddr# :: Addr# -> CPtrdiff -> CSize -> Addr# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float" - setFloatOffAddr# :: Addr# -> CPtrdiff -> CSize -> Float# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double" - setDoubleOffAddr# :: Addr# -> CPtrdiff -> CSize -> Double# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" - setWideCharOffAddr# :: Addr# -> CPtrdiff -> CSize -> Char# -> IO () - diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs deleted file mode 100644 index 3c7bfd1fa0..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} - --- | --- Module : Data.Primitive.MVar --- License : BSD2 --- Portability : non-portable --- --- Primitive operations on @MVar@. This module provides a similar interface --- to "Control.Concurrent.MVar". However, the functions are generalized to --- work in any 'PrimMonad' instead of only working in 'IO'. Note that all --- of the functions here are completely deterministic. Users of 'MVar' are --- responsible for designing abstractions that guarantee determinism in --- the presence of multi-threading. --- --- @since 0.6.4.0 -module Data.Primitive.MVar - ( MVar(..) - , newMVar - , isEmptyMVar - , newEmptyMVar - , putMVar - , readMVar - , takeMVar - , tryPutMVar - , tryReadMVar - , tryTakeMVar - ) where - -import Control.Monad.Primitive -import Data.Primitive.Internal.Compat (isTrue#) -import GHC.Exts (MVar#,newMVar#,takeMVar#,sameMVar#,putMVar#,tryTakeMVar#, - isEmptyMVar#,tryPutMVar#,(/=#)) - -#if __GLASGOW_HASKELL__ >= 708 -import GHC.Exts (readMVar#,tryReadMVar#) -#endif - -data MVar s a = MVar (MVar# s a) - -instance Eq (MVar s a) where - MVar mvar1# == MVar mvar2# = isTrue# (sameMVar# mvar1# mvar2#) - --- | Create a new 'MVar' that is initially empty. -newEmptyMVar :: PrimMonad m => m (MVar (PrimState m) a) -newEmptyMVar = primitive $ \ s# -> - case newMVar# s# of - (# s2#, svar# #) -> (# s2#, MVar svar# #) - - --- | Create a new 'MVar' that holds the supplied argument. -newMVar :: PrimMonad m => a -> m (MVar (PrimState m) a) -newMVar value = - newEmptyMVar >>= \ mvar -> - putMVar mvar value >> - return mvar - --- | Return the contents of the 'MVar'. If the 'MVar' is currently --- empty, 'takeMVar' will wait until it is full. After a 'takeMVar', --- the 'MVar' is left empty. -takeMVar :: PrimMonad m => MVar (PrimState m) a -> m a -takeMVar (MVar mvar#) = primitive $ \ s# -> takeMVar# mvar# s# - --- | Atomically read the contents of an 'MVar'. If the 'MVar' is --- currently empty, 'readMVar' will wait until it is full. --- 'readMVar' is guaranteed to receive the next 'putMVar'. --- --- /Multiple Wakeup:/ 'readMVar' is multiple-wakeup, so when multiple readers --- are blocked on an 'MVar', all of them are woken up at the same time. --- --- /Compatibility note:/ On GHCs prior to 7.8, 'readMVar' is a combination --- of 'takeMVar' and 'putMVar'. Consequently, its behavior differs in the --- following ways: --- --- * It is single-wakeup instead of multiple-wakeup. --- * It might not receive the value from the next call to 'putMVar' if --- there is already a pending thread blocked on 'takeMVar'. --- * If another thread puts a value in the 'MVar' in between the --- calls to 'takeMVar' and 'putMVar', that value may be overridden. -readMVar :: PrimMonad m => MVar (PrimState m) a -> m a -#if __GLASGOW_HASKELL__ >= 708 -readMVar (MVar mvar#) = primitive $ \ s# -> readMVar# mvar# s# -#else -readMVar mv = do - a <- takeMVar mv - putMVar mv a - return a -#endif - --- |Put a value into an 'MVar'. If the 'MVar' is currently full, --- 'putMVar' will wait until it becomes empty. -putMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m () -putMVar (MVar mvar#) x = primitive_ (putMVar# mvar# x) - --- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function --- returns immediately, with 'Nothing' if the 'MVar' was empty, or --- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar', --- the 'MVar' is left empty. -tryTakeMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a) -tryTakeMVar (MVar m) = primitive $ \ s -> - case tryTakeMVar# m s of - (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty - (# s', _, a #) -> (# s', Just a #) -- MVar is full - - --- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function --- attempts to put the value @a@ into the 'MVar', returning 'True' if --- it was successful, or 'False' otherwise. -tryPutMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m Bool -tryPutMVar (MVar mvar#) x = primitive $ \ s# -> - case tryPutMVar# mvar# x s# of - (# s, 0# #) -> (# s, False #) - (# s, _ #) -> (# s, True #) - --- | A non-blocking version of 'readMVar'. The 'tryReadMVar' function --- returns immediately, with 'Nothing' if the 'MVar' was empty, or --- @'Just' a@ if the 'MVar' was full with contents @a@. --- --- /Compatibility note:/ On GHCs prior to 7.8, 'tryReadMVar' is a combination --- of 'tryTakeMVar' and 'putMVar'. Consequently, its behavior differs in the --- following ways: --- --- * It is single-wakeup instead of multiple-wakeup. --- * In the presence of other threads calling 'putMVar', 'tryReadMVar' --- may block. --- * If another thread puts a value in the 'MVar' in between the --- calls to 'tryTakeMVar' and 'putMVar', that value may be overridden. -tryReadMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a) -#if __GLASGOW_HASKELL__ >= 708 -tryReadMVar (MVar m) = primitive $ \ s -> - case tryReadMVar# m s of - (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty - (# s', _, a #) -> (# s', Just a #) -- MVar is full -#else -tryReadMVar mv = do - ma <- tryTakeMVar mv - case ma of - Just a -> do - putMVar mv a - return (Just a) - Nothing -> return Nothing -#endif - --- | Check whether a given 'MVar' is empty. --- --- Notice that the boolean value returned is just a snapshot of --- the state of the MVar. By the time you get to react on its result, --- the MVar may have been filled (or emptied) - so be extremely --- careful when using this operation. Use 'tryTakeMVar' instead if possible. -isEmptyMVar :: PrimMonad m => MVar (PrimState m) a -> m Bool -isEmptyMVar (MVar mv#) = primitive $ \ s# -> - case isEmptyMVar# mv# s# of - (# s2#, flg #) -> (# s2#, isTrue# (flg /=# 0#) #) diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MachDeps.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MachDeps.hs deleted file mode 100644 index d36c252364..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MachDeps.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} --- | --- Module : Data.Primitive.MachDeps --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Machine-dependent constants --- - -module Data.Primitive.MachDeps where - -#include "MachDeps.h" - -import GHC.Prim - -sIZEOF_CHAR, - aLIGNMENT_CHAR, - - sIZEOF_INT, - aLIGNMENT_INT, - - sIZEOF_WORD, - aLIGNMENT_WORD, - - sIZEOF_DOUBLE, - aLIGNMENT_DOUBLE, - - sIZEOF_FLOAT, - aLIGNMENT_FLOAT, - - sIZEOF_PTR, - aLIGNMENT_PTR, - - sIZEOF_FUNPTR, - aLIGNMENT_FUNPTR, - - sIZEOF_STABLEPTR, - aLIGNMENT_STABLEPTR, - - sIZEOF_INT8, - aLIGNMENT_INT8, - - sIZEOF_WORD8, - aLIGNMENT_WORD8, - - sIZEOF_INT16, - aLIGNMENT_INT16, - - sIZEOF_WORD16, - aLIGNMENT_WORD16, - - sIZEOF_INT32, - aLIGNMENT_INT32, - - sIZEOF_WORD32, - aLIGNMENT_WORD32, - - sIZEOF_INT64, - aLIGNMENT_INT64, - - sIZEOF_WORD64, - aLIGNMENT_WORD64 :: Int - - -sIZEOF_CHAR = SIZEOF_HSCHAR -aLIGNMENT_CHAR = ALIGNMENT_HSCHAR - -sIZEOF_INT = SIZEOF_HSINT -aLIGNMENT_INT = ALIGNMENT_HSINT - -sIZEOF_WORD = SIZEOF_HSWORD -aLIGNMENT_WORD = ALIGNMENT_HSWORD - -sIZEOF_DOUBLE = SIZEOF_HSDOUBLE -aLIGNMENT_DOUBLE = ALIGNMENT_HSDOUBLE - -sIZEOF_FLOAT = SIZEOF_HSFLOAT -aLIGNMENT_FLOAT = ALIGNMENT_HSFLOAT - -sIZEOF_PTR = SIZEOF_HSPTR -aLIGNMENT_PTR = ALIGNMENT_HSPTR - -sIZEOF_FUNPTR = SIZEOF_HSFUNPTR -aLIGNMENT_FUNPTR = ALIGNMENT_HSFUNPTR - -sIZEOF_STABLEPTR = SIZEOF_HSSTABLEPTR -aLIGNMENT_STABLEPTR = ALIGNMENT_HSSTABLEPTR - -sIZEOF_INT8 = SIZEOF_INT8 -aLIGNMENT_INT8 = ALIGNMENT_INT8 - -sIZEOF_WORD8 = SIZEOF_WORD8 -aLIGNMENT_WORD8 = ALIGNMENT_WORD8 - -sIZEOF_INT16 = SIZEOF_INT16 -aLIGNMENT_INT16 = ALIGNMENT_INT16 - -sIZEOF_WORD16 = SIZEOF_WORD16 -aLIGNMENT_WORD16 = ALIGNMENT_WORD16 - -sIZEOF_INT32 = SIZEOF_INT32 -aLIGNMENT_INT32 = ALIGNMENT_INT32 - -sIZEOF_WORD32 = SIZEOF_WORD32 -aLIGNMENT_WORD32 = ALIGNMENT_WORD32 - -sIZEOF_INT64 = SIZEOF_INT64 -aLIGNMENT_INT64 = ALIGNMENT_INT64 - -sIZEOF_WORD64 = SIZEOF_WORD64 -aLIGNMENT_WORD64 = ALIGNMENT_WORD64 - -#if WORD_SIZE_IN_BITS == 32 -type Word64_# = Word64# -type Int64_# = Int64# -#else -type Word64_# = Word# -type Int64_# = Int# -#endif - diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MutVar.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MutVar.hs deleted file mode 100644 index f707bfb630..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MutVar.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable #-} - --- | --- Module : Data.Primitive.MutVar --- Copyright : (c) Justin Bonnar 2011, Roman Leshchinskiy 2011-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Primitive boxed mutable variables --- - -module Data.Primitive.MutVar ( - MutVar(..), - - newMutVar, - readMutVar, - writeMutVar, - - atomicModifyMutVar, - atomicModifyMutVar', - modifyMutVar, - modifyMutVar' -) where - -import Control.Monad.Primitive ( PrimMonad(..), primitive_ ) -import GHC.Prim ( MutVar#, sameMutVar#, newMutVar#, - readMutVar#, writeMutVar#, atomicModifyMutVar# ) -import Data.Primitive.Internal.Compat ( isTrue# ) -import Data.Typeable ( Typeable ) - --- | A 'MutVar' behaves like a single-element mutable array associated --- with a primitive state token. -data MutVar s a = MutVar (MutVar# s a) - deriving ( Typeable ) - -instance Eq (MutVar s a) where - MutVar mva# == MutVar mvb# = isTrue# (sameMutVar# mva# mvb#) - --- | Create a new 'MutVar' with the specified initial value -newMutVar :: PrimMonad m => a -> m (MutVar (PrimState m) a) -{-# INLINE newMutVar #-} -newMutVar initialValue = primitive $ \s# -> - case newMutVar# initialValue s# of - (# s'#, mv# #) -> (# s'#, MutVar mv# #) - --- | Read the value of a 'MutVar' -readMutVar :: PrimMonad m => MutVar (PrimState m) a -> m a -{-# INLINE readMutVar #-} -readMutVar (MutVar mv#) = primitive (readMutVar# mv#) - --- | Write a new value into a 'MutVar' -writeMutVar :: PrimMonad m => MutVar (PrimState m) a -> a -> m () -{-# INLINE writeMutVar #-} -writeMutVar (MutVar mv#) newValue = primitive_ (writeMutVar# mv# newValue) - --- | Atomically mutate the contents of a 'MutVar' -atomicModifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a,b)) -> m b -{-# INLINE atomicModifyMutVar #-} -atomicModifyMutVar (MutVar mv#) f = primitive $ atomicModifyMutVar# mv# f - --- | Strict version of 'atomicModifyMutVar'. This forces both the value stored --- in the 'MutVar' as well as the value returned. -atomicModifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a, b)) -> m b -{-# INLINE atomicModifyMutVar' #-} -atomicModifyMutVar' mv f = do - b <- atomicModifyMutVar mv force - b `seq` return b - where - force x = let (a, b) = f x in (a, a `seq` b) - --- | Mutate the contents of a 'MutVar' -modifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m () -{-# INLINE modifyMutVar #-} -modifyMutVar (MutVar mv#) g = primitive_ $ \s# -> - case readMutVar# mv# s# of - (# s'#, a #) -> writeMutVar# mv# (g a) s'# - --- | Strict version of 'modifyMutVar' -modifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m () -{-# INLINE modifyMutVar' #-} -modifyMutVar' (MutVar mv#) g = primitive_ $ \s# -> - case readMutVar# mv# s# of - (# s'#, a #) -> let a' = g a in a' `seq` writeMutVar# mv# a' s'# - diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/PrimArray.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/PrimArray.hs deleted file mode 100644 index 33d81c2092..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/PrimArray.hs +++ /dev/null @@ -1,969 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} - -{-# OPTIONS_GHC -Wall #-} - --- | --- Module : Data.Primitive.PrimArray --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Arrays of unboxed primitive types. The function provided by this module --- match the behavior of those provided by @Data.Primitive.ByteArray@, and --- the underlying types and primops that back them are the same. --- However, the type constructors 'PrimArray' and 'MutablePrimArray' take one additional --- argument than their respective counterparts 'ByteArray' and 'MutableByteArray'. --- This argument is used to designate the type of element in the array. --- Consequently, all function this modules accepts length and incides in --- terms of elements, not bytes. --- --- @since 0.6.4.0 -module Data.Primitive.PrimArray - ( -- * Types - PrimArray(..) - , MutablePrimArray(..) - -- * Allocation - , newPrimArray - , resizeMutablePrimArray -#if __GLASGOW_HASKELL__ >= 710 - , shrinkMutablePrimArray -#endif - -- * Element Access - , readPrimArray - , writePrimArray - , indexPrimArray - -- * Freezing and Thawing - , unsafeFreezePrimArray - , unsafeThawPrimArray - -- * Block Operations - , copyPrimArray - , copyMutablePrimArray -#if __GLASGOW_HASKELL__ >= 708 - , copyPrimArrayToPtr - , copyMutablePrimArrayToPtr -#endif - , setPrimArray - -- * Information - , sameMutablePrimArray - , getSizeofMutablePrimArray - , sizeofMutablePrimArray - , sizeofPrimArray - -- * List Conversion - , primArrayToList - , primArrayFromList - , primArrayFromListN - -- * Folding - , foldrPrimArray - , foldrPrimArray' - , foldlPrimArray - , foldlPrimArray' - , foldlPrimArrayM' - -- * Effectful Folding - , traversePrimArray_ - , itraversePrimArray_ - -- * Map/Create - , mapPrimArray - , imapPrimArray - , generatePrimArray - , replicatePrimArray - , filterPrimArray - , mapMaybePrimArray - -- * Effectful Map/Create - -- $effectfulMapCreate - -- ** Lazy Applicative - , traversePrimArray - , itraversePrimArray - , generatePrimArrayA - , replicatePrimArrayA - , filterPrimArrayA - , mapMaybePrimArrayA - -- ** Strict Primitive Monadic - , traversePrimArrayP - , itraversePrimArrayP - , generatePrimArrayP - , replicatePrimArrayP - , filterPrimArrayP - , mapMaybePrimArrayP - ) where - -import GHC.Prim -import GHC.Base ( Int(..) ) -import GHC.Exts (build) -import GHC.Ptr -import Data.Primitive.Internal.Compat (isTrue#) -import Data.Primitive.Types -import Data.Primitive.ByteArray (ByteArray(..)) -import Data.Monoid (Monoid(..),(<>)) -import Control.Applicative -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,7,0) -import GHC.Exts (IsList(..)) -#endif - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup) -import qualified Data.Semigroup as SG -#endif - --- | 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 'Array', which is lazy --- in its elements. -data PrimArray a = PrimArray ByteArray# - --- | Mutable primitive arrays associated with a primitive state token. --- These can be written to and read from in a monadic context that supports --- sequencing such as 'IO' or 'ST'. Typically, a mutable primitive array will --- be built and then convert to an immutable primitive array using --- 'unsafeFreezePrimArray'. However, it is also acceptable to simply discard --- a mutable primitive array since it lives in managed memory and will be --- garbage collected when no longer referenced. -data MutablePrimArray s a = MutablePrimArray (MutableByteArray# s) - -sameByteArray :: ByteArray# -> ByteArray# -> Bool -sameByteArray ba1 ba2 = - case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of -#if __GLASGOW_HASKELL__ >= 708 - r -> isTrue# r -#else - 1# -> True - _ -> False -#endif - --- | @since 0.6.4.0 -instance (Eq a, Prim a) => Eq (PrimArray a) where - a1@(PrimArray ba1#) == a2@(PrimArray ba2#) - | sameByteArray ba1# ba2# = True - | sz1 /= sz2 = False - | otherwise = loop (quot sz1 (sizeOf (undefined :: 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 - -- calculate the size in elements. - sz1 = PB.sizeofByteArray (ByteArray ba1#) - sz2 = PB.sizeofByteArray (ByteArray ba2#) - loop !i - | i < 0 = True - | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i-1) - --- | Lexicographic ordering. Subject to change between major versions. --- --- @since 0.6.4.0 -instance (Ord a, Prim a) => Ord (PrimArray a) where - compare a1@(PrimArray ba1#) a2@(PrimArray ba2#) - | sameByteArray ba1# ba2# = EQ - | otherwise = loop 0 - where - sz1 = PB.sizeofByteArray (ByteArray ba1#) - sz2 = PB.sizeofByteArray (ByteArray ba2#) - sz = quot (min sz1 sz2) (sizeOf (undefined :: a)) - loop !i - | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) <> loop (i+1) - | otherwise = compare sz1 sz2 - -#if MIN_VERSION_base(4,7,0) --- | @since 0.6.4.0 -instance Prim a => IsList (PrimArray a) where - type Item (PrimArray a) = a - fromList = primArrayFromList - fromListN = primArrayFromListN - toList = primArrayToList -#endif - --- | @since 0.6.4.0 -instance (Show a, Prim a) => Show (PrimArray a) where - showsPrec p a = showParen (p > 10) $ - showString "fromListN " . shows (sizeofPrimArray a) . showString " " - . shows (primArrayToList a) - -die :: String -> String -> a -die fun problem = error $ "Data.Primitive.PrimArray." ++ fun ++ ": " ++ problem - -primArrayFromList :: Prim a => [a] -> PrimArray a -primArrayFromList vs = primArrayFromListN (L.length vs) vs - -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 - --- | Convert the primitive array to a list. -{-# INLINE primArrayToList #-} -primArrayToList :: forall a. Prim a => PrimArray a -> [a] -primArrayToList xs = build (\c n -> foldrPrimArray c n xs) - -primArrayToByteArray :: PrimArray a -> PB.ByteArray -primArrayToByteArray (PrimArray x) = PB.ByteArray x - -byteArrayToPrimArray :: ByteArray -> PrimArray a -byteArrayToPrimArray (PB.ByteArray x) = PrimArray x - -#if MIN_VERSION_base(4,9,0) --- | @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)) -#endif - --- | @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)) -#endif - mconcat = byteArrayToPrimArray . mconcat . map primArrayToByteArray - --- | The empty primitive array. -emptyPrimArray :: PrimArray a -{-# NOINLINE emptyPrimArray #-} -emptyPrimArray = runST $ primitive $ \s0# -> case newByteArray# 0# s0# of - (# s1#, arr# #) -> case unsafeFreezeByteArray# arr# s1# of - (# s2#, arr'# #) -> (# s2#, PrimArray arr'# #) - --- | Create a new mutable primitive array of the given length. The --- underlying memory is left uninitialized. -newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a) -{-# INLINE newPrimArray #-} -newPrimArray (I# n#) - = primitive (\s# -> - case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of - (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #) - ) - --- | Resize a mutable primitive array. The new size is given in elements. --- --- This will either resize the array in-place or, if not possible, allocate the --- contents into a new, unpinned array and copy the original array\'s contents. --- --- To avoid undefined behaviour, the original 'MutablePrimArray' shall not be --- accessed anymore after a 'resizeMutablePrimArray' has been performed. --- Moreover, no reference to the old one should be kept in order to allow --- garbage collection of the original 'MutablePrimArray' in case a new --- 'MutablePrimArray' had to be allocated. -resizeMutablePrimArray :: forall m a. (PrimMonad m, Prim a) - => MutablePrimArray (PrimState m) a - -> Int -- ^ new size - -> m (MutablePrimArray (PrimState m) a) -{-# INLINE resizeMutablePrimArray #-} -#if __GLASGOW_HASKELL__ >= 710 -resizeMutablePrimArray (MutablePrimArray arr#) (I# n#) - = primitive (\s# -> case resizeMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)) s# of - (# s'#, arr'# #) -> (# s'#, MutablePrimArray arr'# #)) -#else -resizeMutablePrimArray arr n - = do arr' <- newPrimArray n - copyMutablePrimArray arr' 0 arr 0 (min (sizeofMutablePrimArray arr) n) - return arr' -#endif - --- Although it is possible to shim resizeMutableByteArray for old GHCs, this --- is not the case with shrinkMutablePrimArray. -#if __GLASGOW_HASKELL__ >= 710 --- | Shrink a mutable primitive array. The new size is given in elements. --- It must be smaller than the old size. The array will be resized in place. --- This function is only available when compiling with GHC 7.10 or newer. -shrinkMutablePrimArray :: forall m a. (PrimMonad m, Prim a) - => MutablePrimArray (PrimState m) a - -> Int -- ^ new size - -> m () -{-# INLINE shrinkMutablePrimArray #-} -shrinkMutablePrimArray (MutablePrimArray arr#) (I# n#) - = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOf# (undefined :: a))) -#endif - -readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a -{-# INLINE readPrimArray #-} -readPrimArray (MutablePrimArray arr#) (I# i#) - = primitive (readByteArray# arr# i#) - --- | Write an element to the given index. -writePrimArray :: - (Prim a, PrimMonad m) - => MutablePrimArray (PrimState m) a -- ^ array - -> Int -- ^ index - -> a -- ^ element - -> m () -{-# INLINE writePrimArray #-} -writePrimArray (MutablePrimArray arr#) (I# i#) x - = primitive_ (writeByteArray# arr# i# x) - --- | Copy part of a mutable array into another mutable array. --- In the case that the destination and --- source arrays are the same, the regions may overlap. -copyMutablePrimArray :: forall m a. - (PrimMonad m, Prim a) - => MutablePrimArray (PrimState m) a -- ^ destination array - -> Int -- ^ offset into destination array - -> MutablePrimArray (PrimState m) a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of elements to copy - -> m () -{-# INLINE copyMutablePrimArray #-} -copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#) - = primitive_ (copyMutableByteArray# - src# - (soff# *# (sizeOf# (undefined :: a))) - dst# - (doff# *# (sizeOf# (undefined :: a))) - (n# *# (sizeOf# (undefined :: a))) - ) - --- | Copy part of an array into another mutable array. -copyPrimArray :: forall m a. - (PrimMonad m, Prim a) - => MutablePrimArray (PrimState m) a -- ^ destination array - -> Int -- ^ offset into destination array - -> PrimArray a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of elements to copy - -> m () -{-# INLINE copyPrimArray #-} -copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#) - = primitive_ (copyByteArray# - src# - (soff# *# (sizeOf# (undefined :: a))) - dst# - (doff# *# (sizeOf# (undefined :: a))) - (n# *# (sizeOf# (undefined :: a))) - ) - -#if __GLASGOW_HASKELL__ >= 708 --- | Copy a slice of an immutable primitive array to an address. --- The offset and length are given in elements of type @a@. --- This function assumes that the 'Prim' instance of @a@ --- agrees with the 'Storable' instance. This function is only --- available when building with GHC 7.8 or newer. -copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) - => Ptr a -- ^ destination pointer - -> PrimArray a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of prims to copy - -> m () -{-# INLINE copyPrimArrayToPtr #-} -copyPrimArrayToPtr (Ptr addr#) (PrimArray ba#) (I# soff#) (I# n#) = - primitive (\ s# -> - let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s# - in (# s'#, () #)) - where siz# = sizeOf# (undefined :: a) - --- | Copy a slice of an immutable primitive array to an address. --- The offset and length are given in elements of type @a@. --- This function assumes that the 'Prim' instance of @a@ --- agrees with the 'Storable' instance. This function is only --- available when building with GHC 7.8 or newer. -copyMutablePrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) - => Ptr a -- ^ destination pointer - -> MutablePrimArray (PrimState m) a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of prims to copy - -> m () -{-# INLINE copyMutablePrimArrayToPtr #-} -copyMutablePrimArrayToPtr (Ptr addr#) (MutablePrimArray mba#) (I# soff#) (I# n#) = - primitive (\ s# -> - let s'# = copyMutableByteArrayToAddr# mba# (soff# *# siz#) addr# (n# *# siz#) s# - in (# s'#, () #)) - where siz# = sizeOf# (undefined :: a) -#endif - --- | Fill a slice of a mutable primitive array with a value. -setPrimArray - :: (Prim a, PrimMonad m) - => MutablePrimArray (PrimState m) a -- ^ array to fill - -> Int -- ^ offset into array - -> Int -- ^ number of values to fill - -> a -- ^ value to fill with - -> m () -{-# INLINE setPrimArray #-} -setPrimArray (MutablePrimArray dst#) (I# doff#) (I# sz#) x - = primitive_ (PT.setByteArray# dst# doff# sz# x) - --- | Get the size of a mutable primitive array in elements. Unlike 'sizeofMutablePrimArray', --- this function ensures sequencing in the presence of resizing. -getSizeofMutablePrimArray :: forall m a. (PrimMonad m, Prim a) - => MutablePrimArray (PrimState m) a -- ^ array - -> m Int -{-# INLINE getSizeofMutablePrimArray #-} -#if __GLASGOW_HASKELL__ >= 801 -getSizeofMutablePrimArray (MutablePrimArray arr#) - = primitive (\s# -> - case getSizeofMutableByteArray# arr# s# of - (# s'#, sz# #) -> (# s'#, I# (quotInt# sz# (sizeOf# (undefined :: a))) #) - ) -#else --- On older GHCs, it is not possible to resize a byte array, so --- this provides behavior consistent with the implementation for --- newer GHCs. -getSizeofMutablePrimArray arr - = return (sizeofMutablePrimArray arr) -#endif - --- | Size of the mutable primitive array in elements. This function shall not --- be used on primitive arrays that are an argument to or a result of --- 'resizeMutablePrimArray' or 'shrinkMutablePrimArray'. -sizeofMutablePrimArray :: forall s a. Prim a => MutablePrimArray s a -> Int -{-# INLINE sizeofMutablePrimArray #-} -sizeofMutablePrimArray (MutablePrimArray arr#) = - I# (quotInt# (sizeofMutableByteArray# arr#) (sizeOf# (undefined :: a))) - --- | Check if the two arrays refer to the same memory block. -sameMutablePrimArray :: MutablePrimArray s a -> MutablePrimArray s a -> Bool -{-# INLINE sameMutablePrimArray #-} -sameMutablePrimArray (MutablePrimArray arr#) (MutablePrimArray brr#) - = isTrue# (sameMutableByteArray# arr# brr#) - --- | Convert a mutable byte array to an immutable one without copying. The --- array should not be modified after the conversion. -unsafeFreezePrimArray - :: PrimMonad m => MutablePrimArray (PrimState m) a -> m (PrimArray a) -{-# INLINE unsafeFreezePrimArray #-} -unsafeFreezePrimArray (MutablePrimArray arr#) - = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of - (# s'#, arr'# #) -> (# s'#, PrimArray arr'# #)) - --- | Convert an immutable array to a mutable one without copying. The --- original array should not be used after the conversion. -unsafeThawPrimArray - :: PrimMonad m => PrimArray a -> m (MutablePrimArray (PrimState m) a) -{-# INLINE unsafeThawPrimArray #-} -unsafeThawPrimArray (PrimArray arr#) - = primitive (\s# -> (# s#, MutablePrimArray (unsafeCoerce# arr#) #)) - --- | Read a primitive value from the primitive array. -indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a -{-# INLINE indexPrimArray #-} -indexPrimArray (PrimArray arr#) (I# i#) = indexByteArray# arr# i# - --- | 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))) - --- | Lazy right-associated fold over the elements of a 'PrimArray'. -{-# INLINE foldrPrimArray #-} -foldrPrimArray :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b -foldrPrimArray f z arr = go 0 - where - !sz = sizeofPrimArray arr - go !i - | sz > i = f (indexPrimArray arr i) (go (i+1)) - | otherwise = z - --- | Strict right-associated fold over the elements of a 'PrimArray'. -{-# INLINE foldrPrimArray' #-} -foldrPrimArray' :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b -foldrPrimArray' f z0 arr = go (sizeofPrimArray arr - 1) z0 - where - go !i !acc - | i < 0 = acc - | otherwise = go (i - 1) (f (indexPrimArray arr i) acc) - --- | Lazy left-associated fold over the elements of a 'PrimArray'. -{-# INLINE foldlPrimArray #-} -foldlPrimArray :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b -foldlPrimArray f z arr = go (sizeofPrimArray arr - 1) - where - go !i - | i < 0 = z - | otherwise = f (go (i - 1)) (indexPrimArray arr i) - --- | Strict left-associated fold over the elements of a 'PrimArray'. -{-# INLINE foldlPrimArray' #-} -foldlPrimArray' :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b -foldlPrimArray' f z0 arr = go 0 z0 - where - !sz = sizeofPrimArray arr - go !i !acc - | i < sz = go (i + 1) (f acc (indexPrimArray arr i)) - | otherwise = acc - --- | Strict left-associated fold over the elements of a 'PrimArray'. -{-# INLINE foldlPrimArrayM' #-} -foldlPrimArrayM' :: (Prim a, Monad m) => (b -> a -> m b) -> b -> PrimArray a -> m b -foldlPrimArrayM' f z0 arr = go 0 z0 - where - !sz = sizeofPrimArray arr - go !i !acc1 - | i < sz = do - acc2 <- f acc1 (indexPrimArray arr i) - go (i + 1) acc2 - | otherwise = return acc1 - --- | Traverse a primitive array. The traversal forces the resulting values and --- writes them to the new primitive array as it performs the monadic effects. --- Consequently: --- --- >>> traversePrimArrayP (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int]) --- 1 --- 2 --- *** Exception: Prelude.undefined --- --- In many situations, 'traversePrimArrayP' can replace 'traversePrimArray', --- changing the strictness characteristics of the traversal but typically improving --- the performance. Consider the following short-circuiting traversal: --- --- > incrPositiveA :: PrimArray Int -> Maybe (PrimArray Int) --- > incrPositiveA xs = traversePrimArray (\x -> bool Nothing (Just (x + 1)) (x > 0)) xs --- --- This can be rewritten using 'traversePrimArrayP'. To do this, we must --- change the traversal context to @MaybeT (ST s)@, which has a 'PrimMonad' --- instance: --- --- > incrPositiveB :: PrimArray Int -> Maybe (PrimArray Int) --- > incrPositiveB xs = runST $ runMaybeT $ traversePrimArrayP --- > (\x -> bool (MaybeT (return Nothing)) (MaybeT (return (Just (x + 1)))) (x > 0)) --- > xs --- --- Benchmarks demonstrate that the second implementation runs 150 times --- faster than the first. It also results in fewer allocations. -{-# INLINE traversePrimArrayP #-} -traversePrimArrayP :: (PrimMonad m, Prim a, Prim b) - => (a -> m b) - -> PrimArray a - -> m (PrimArray b) -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 () - go 0 - unsafeFreezePrimArray marr - --- | Filter the primitive array, keeping the elements for which the monadic --- predicate evaluates true. -{-# INLINE filterPrimArrayP #-} -filterPrimArrayP :: (PrimMonad m, Prim a) - => (a -> m Bool) - -> PrimArray a - -> m (PrimArray a) -filterPrimArrayP f arr = do - let !sz = sizeofPrimArray arr - marr <- newPrimArray sz - let go !ixSrc !ixDst = if ixSrc < sz - then do - let a = indexPrimArray arr ixSrc - b <- f a - if b - then do - writePrimArray marr ixDst a - go (ixSrc + 1) (ixDst + 1) - else go (ixSrc + 1) ixDst - else return ixDst - lenDst <- go 0 0 - marr' <- resizeMutablePrimArray marr lenDst - unsafeFreezePrimArray marr' - --- | Map over the primitive array, keeping the elements for which the monadic --- predicate provides a 'Just'. -{-# INLINE mapMaybePrimArrayP #-} -mapMaybePrimArrayP :: (PrimMonad m, Prim a, Prim b) - => (a -> m (Maybe b)) - -> PrimArray a - -> m (PrimArray b) -mapMaybePrimArrayP f arr = do - let !sz = sizeofPrimArray arr - marr <- newPrimArray sz - let go !ixSrc !ixDst = if ixSrc < sz - then do - let a = indexPrimArray arr ixSrc - mb <- f a - case mb of - Just b -> do - writePrimArray marr ixDst b - go (ixSrc + 1) (ixDst + 1) - Nothing -> go (ixSrc + 1) ixDst - else return ixDst - lenDst <- go 0 0 - marr' <- resizeMutablePrimArray marr lenDst - unsafeFreezePrimArray marr' - --- | Generate a primitive array by evaluating the monadic generator function --- at each index. -{-# INLINE generatePrimArrayP #-} -generatePrimArrayP :: (PrimMonad m, Prim a) - => Int -- ^ length - -> (Int -> m a) -- ^ generator - -> 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 () - go 0 - unsafeFreezePrimArray marr - --- | Execute the monadic action the given number of times and store the --- results in a primitive array. -{-# INLINE replicatePrimArrayP #-} -replicatePrimArrayP :: (PrimMonad m, Prim a) - => Int - -> m a - -> 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 () - go 0 - unsafeFreezePrimArray marr - - --- | Map over the elements of a primitive array. -{-# INLINE mapPrimArray #-} -mapPrimArray :: (Prim a, Prim b) - => (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 - --- | Indexed map over the elements of a primitive array. -{-# INLINE imapPrimArray #-} -imapPrimArray :: (Prim a, Prim b) - => (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 - --- | Filter elements of a primitive array according to a predicate. -{-# INLINE filterPrimArray #-} -filterPrimArray :: Prim a - => (a -> Bool) - -> PrimArray a - -> PrimArray a -filterPrimArray p arr = runST $ do - let !sz = sizeofPrimArray arr - marr <- newPrimArray sz - let go !ixSrc !ixDst = if ixSrc < sz - then do - let !a = indexPrimArray arr ixSrc - if p a - then do - writePrimArray marr ixDst a - go (ixSrc + 1) (ixDst + 1) - else go (ixSrc + 1) ixDst - else return ixDst - dstLen <- go 0 0 - marr' <- resizeMutablePrimArray marr dstLen - unsafeFreezePrimArray marr' - --- | Filter the primitive array, keeping the elements for which the monadic --- predicate evaluates true. -filterPrimArrayA :: - (Applicative f, Prim a) - => (a -> f Bool) -- ^ mapping function - -> PrimArray a -- ^ primitive array - -> f (PrimArray a) -filterPrimArrayA f = \ !ary -> - let - !len = sizeofPrimArray ary - go !ixSrc - | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst - | otherwise = let x = indexPrimArray ary ixSrc in - liftA2 - (\keep (IxSTA m) -> IxSTA $ \ixDst mary -> if keep - then writePrimArray (MutablePrimArray mary) ixDst x >> m (ixDst + 1) mary - else m ixDst mary - ) - (f x) - (go (ixSrc + 1)) - in if len == 0 - then pure emptyPrimArray - else runIxSTA len <$> go 0 - --- | Map over the primitive array, keeping the elements for which the applicative --- predicate provides a 'Just'. -mapMaybePrimArrayA :: - (Applicative f, Prim a, Prim b) - => (a -> f (Maybe b)) -- ^ mapping function - -> PrimArray a -- ^ primitive array - -> f (PrimArray b) -mapMaybePrimArrayA f = \ !ary -> - let - !len = sizeofPrimArray ary - go !ixSrc - | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst - | otherwise = let x = indexPrimArray ary ixSrc in - liftA2 - (\mb (IxSTA m) -> IxSTA $ \ixDst mary -> case mb of - Just b -> writePrimArray (MutablePrimArray mary) ixDst b >> m (ixDst + 1) mary - Nothing -> m ixDst mary - ) - (f x) - (go (ixSrc + 1)) - in if len == 0 - then pure emptyPrimArray - else runIxSTA len <$> go 0 - --- | Map over a primitive array, optionally discarding some elements. This --- has the same behavior as @Data.Maybe.mapMaybe@. -{-# INLINE mapMaybePrimArray #-} -mapMaybePrimArray :: (Prim a, Prim b) - => (a -> Maybe b) - -> PrimArray a - -> PrimArray b -mapMaybePrimArray p arr = runST $ do - let !sz = sizeofPrimArray arr - marr <- newPrimArray sz - let go !ixSrc !ixDst = if ixSrc < sz - then do - let !a = indexPrimArray arr ixSrc - case p a of - Just b -> do - writePrimArray marr ixDst b - go (ixSrc + 1) (ixDst + 1) - Nothing -> go (ixSrc + 1) ixDst - else return ixDst - dstLen <- go 0 0 - marr' <- resizeMutablePrimArray marr dstLen - unsafeFreezePrimArray marr' - - --- | Traverse a primitive array. The traversal performs all of the applicative --- effects /before/ forcing the resulting values and writing them to the new --- primitive array. Consequently: --- --- >>> traversePrimArray (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int]) --- 1 --- 2 --- 3 --- *** Exception: Prelude.undefined --- --- The function 'traversePrimArrayP' always outperforms this function, but it --- requires a 'PrimAffineMonad' constraint, and it forces the values as --- it performs the effects. -traversePrimArray :: - (Applicative f, Prim a, Prim b) - => (a -> f b) -- ^ mapping function - -> PrimArray a -- ^ primitive array - -> f (PrimArray b) -traversePrimArray f = \ !ary -> - let - !len = sizeofPrimArray ary - go !i - | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) - | x <- indexPrimArray ary i - = liftA2 (\b (STA m) -> STA $ \mary -> - writePrimArray (MutablePrimArray mary) i b >> m mary) - (f x) (go (i + 1)) - in if len == 0 - then pure emptyPrimArray - else runSTA len <$> go 0 - --- | Traverse a primitive array with the index of each element. -itraversePrimArray :: - (Applicative f, Prim a, Prim b) - => (Int -> a -> f b) - -> PrimArray a - -> f (PrimArray b) -itraversePrimArray f = \ !ary -> - let - !len = sizeofPrimArray ary - go !i - | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) - | x <- indexPrimArray ary i - = liftA2 (\b (STA m) -> STA $ \mary -> - writePrimArray (MutablePrimArray mary) i b >> m mary) - (f i x) (go (i + 1)) - in if len == 0 - then pure emptyPrimArray - else runSTA len <$> go 0 - --- | Traverse a primitive array with the indices. The traversal forces the --- resulting values and writes them to the new primitive array as it performs --- the monadic effects. -{-# INLINE itraversePrimArrayP #-} -itraversePrimArrayP :: (Prim a, Prim b, PrimMonad m) - => (Int -> a -> m b) - -> PrimArray a - -> m (PrimArray b) -itraversePrimArrayP f arr = do - let !sz = sizeofPrimArray arr - marr <- newPrimArray sz - let go !ix - | ix < sz = do - writePrimArray marr ix =<< f ix (indexPrimArray arr ix) - go (ix + 1) - | otherwise = return () - go 0 - unsafeFreezePrimArray marr - --- | Generate a primitive array. -{-# INLINE generatePrimArray #-} -generatePrimArray :: Prim a - => 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 - --- | Create a primitive array by copying the element the given --- number of times. -{-# INLINE replicatePrimArray #-} -replicatePrimArray :: Prim a - => Int -- ^ length - -> a -- ^ element - -> PrimArray a -replicatePrimArray len a = runST $ do - marr <- newPrimArray len - setPrimArray marr 0 len a - unsafeFreezePrimArray marr - --- | Generate a primitive array by evaluating the applicative generator --- function at each index. -{-# INLINE generatePrimArrayA #-} -generatePrimArrayA :: - (Applicative f, Prim a) - => Int -- ^ length - -> (Int -> f a) -- ^ element from index - -> f (PrimArray a) -generatePrimArrayA len f = - let - go !i - | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) - | otherwise - = liftA2 (\b (STA m) -> STA $ \mary -> - writePrimArray (MutablePrimArray mary) i b >> m mary) - (f i) (go (i + 1)) - in if len == 0 - then pure emptyPrimArray - else runSTA len <$> go 0 - --- | Execute the applicative action the given number of times and store the --- results in a vector. -{-# INLINE replicatePrimArrayA #-} -replicatePrimArrayA :: - (Applicative f, Prim a) - => Int -- ^ length - -> f a -- ^ applicative element producer - -> f (PrimArray a) -replicatePrimArrayA len f = - let - go !i - | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) - | otherwise - = liftA2 (\b (STA m) -> STA $ \mary -> - writePrimArray (MutablePrimArray mary) i b >> m mary) - f (go (i + 1)) - in if len == 0 - then pure emptyPrimArray - else runSTA len <$> go 0 - --- | Traverse the primitive array, discarding the results. There --- is no 'PrimMonad' variant of this function since it would not provide --- any performance benefit. -traversePrimArray_ :: - (Applicative f, Prim a) - => (a -> f b) - -> PrimArray a - -> 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 () - --- | Traverse the primitive array with the indices, discarding the results. --- There is no 'PrimMonad' variant of this function since it would not --- provide any performance benefit. -itraversePrimArray_ :: - (Applicative f, Prim a) - => (Int -> a -> f b) - -> PrimArray a - -> 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 () - -newtype IxSTA a = IxSTA {_runIxSTA :: forall s. Int -> MutableByteArray# s -> ST s Int} - -runIxSTA :: forall a. Prim a - => Int -- maximum possible size - -> IxSTA a - -> PrimArray a -runIxSTA !szUpper = \ (IxSTA m) -> runST $ do - ar :: MutablePrimArray s a <- newPrimArray szUpper - sz <- m 0 (unMutablePrimArray ar) - ar' <- resizeMutablePrimArray ar sz - unsafeFreezePrimArray ar' -{-# INLINE runIxSTA #-} - -newtype STA a = STA {_runSTA :: forall s. MutableByteArray# s -> ST s (PrimArray a)} - -runSTA :: forall a. Prim a => Int -> STA a -> PrimArray a -runSTA !sz = \ (STA m) -> runST $ newPrimArray sz >>= \ (ar :: MutablePrimArray s a) -> m (unMutablePrimArray ar) -{-# INLINE runSTA #-} - -unMutablePrimArray :: MutablePrimArray s a -> MutableByteArray# s -unMutablePrimArray (MutablePrimArray m) = m - -{- $effectfulMapCreate -The naming conventions adopted in this section are explained in the -documentation of the @Data.Primitive@ module. --} - - diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Ptr.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Ptr.hs deleted file mode 100644 index d93ae9ac11..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Ptr.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Module : Data.Primitive.Ptr --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Primitive operations on machine addresses --- --- @since 0.6.4.0 - -module Data.Primitive.Ptr ( - -- * Types - Ptr(..), - - -- * Address arithmetic - nullPtr, advancePtr, subtractPtr, - - -- * Element access - indexOffPtr, readOffPtr, writeOffPtr, - - -- * Block operations - copyPtr, movePtr, setPtr - -#if __GLASGOW_HASKELL__ >= 708 - , copyPtrToMutablePrimArray -#endif -) where - -import Control.Monad.Primitive -import Data.Primitive.Types -#if __GLASGOW_HASKELL__ >= 708 -import Data.Primitive.PrimArray (MutablePrimArray(..)) -#endif - -import GHC.Base ( Int(..) ) -import GHC.Prim - -import GHC.Ptr -import Foreign.Marshal.Utils - - --- | 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))) - --- | 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))) - --- | 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 --- elements of type @a@ rather than in bytes. -indexOffPtr :: Prim a => Ptr a -> Int -> a -{-# INLINE indexOffPtr #-} -indexOffPtr (Ptr addr#) (I# i#) = indexOffAddr# addr# i# - --- | Read a value from a memory position given by an address and an offset. --- The offset is in elements of type @a@ rather than in bytes. -readOffPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> m a -{-# INLINE readOffPtr #-} -readOffPtr (Ptr addr#) (I# i#) = primitive (readOffAddr# addr# i#) - --- | Write a value to a memory position given by an address and an offset. --- The offset is in elements of type @a@ rather than in bytes. -writeOffPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> a -> m () -{-# INLINE writeOffPtr #-} -writeOffPtr (Ptr addr#) (I# i#) x = primitive_ (writeOffAddr# addr# i# x) - --- | Copy the given number of elements from the second 'Ptr' to the first. The --- areas may not overlap. -copyPtr :: forall m a. (PrimMonad m, Prim a) - => Ptr a -- ^ destination pointer - -> Ptr a -- ^ source pointer - -> Int -- ^ number of elements - -> m () -{-# INLINE copyPtr #-} -copyPtr (Ptr dst#) (Ptr src#) n - = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a)) - --- | Copy the given number of elements from the second 'Ptr' to the first. The --- areas may overlap. -movePtr :: forall m a. (PrimMonad m, Prim a) - => Ptr a -- ^ destination address - -> Ptr a -- ^ source address - -> Int -- ^ number of elements - -> m () -{-# INLINE movePtr #-} -movePtr (Ptr dst#) (Ptr src#) n - = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a)) - --- | Fill a memory block with the given value. The length is in --- elements of type @a@ rather than in bytes. -setPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> a -> m () -{-# INLINE setPtr #-} -setPtr (Ptr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x) - - -#if __GLASGOW_HASKELL__ >= 708 --- | Copy from a pointer to a mutable primitive array. --- The offset and length are given in elements of type @a@. --- This function is only available when building with GHC 7.8 --- or newer. -copyPtrToMutablePrimArray :: forall m a. (PrimMonad m, Prim a) - => MutablePrimArray (PrimState m) a -- ^ destination array - -> Int -- ^ destination offset - -> Ptr a -- ^ source pointer - -> Int -- ^ number of elements - -> m () -{-# INLINE copyPtrToMutablePrimArray #-} -copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) = - primitive_ (copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#)) - where - siz# = sizeOf# (undefined :: a) -#endif diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/SmallArray.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/SmallArray.hs deleted file mode 100644 index 3a50cf2183..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/SmallArray.hs +++ /dev/null @@ -1,967 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE BangPatterns #-} - --- | --- Module : Data.Primitive.SmallArray --- Copyright: (c) 2015 Dan Doel --- License: BSD3 --- --- Maintainer: libraries@haskell.org --- Portability: non-portable --- --- Small arrays are boxed (im)mutable arrays. --- --- The underlying structure of the 'Array' type contains a card table, allowing --- segments of the array to be marked as having been mutated. This allows the --- garbage collector to only re-traverse segments of the array that have been --- marked during certain phases, rather than having to traverse the entire --- array. --- --- 'SmallArray' lacks this table. This means that it takes up less memory and --- has slightly faster writes. It is also more efficient during garbage --- collection so long as the card table would have a single entry covering the --- entire array. These advantages make them suitable for use as arrays that are --- known to be small. --- --- The card size is 128, so for uses much larger than that, 'Array' would likely --- be superior. --- --- The underlying type, 'SmallArray#', was introduced in GHC 7.10, so prior to --- that version, this module simply implements small arrays as 'Array'. - -module Data.Primitive.SmallArray - ( SmallArray(..) - , SmallMutableArray(..) - , newSmallArray - , readSmallArray - , writeSmallArray - , copySmallArray - , copySmallMutableArray - , indexSmallArray - , indexSmallArrayM - , indexSmallArray## - , cloneSmallArray - , cloneSmallMutableArray - , freezeSmallArray - , unsafeFreezeSmallArray - , thawSmallArray - , runSmallArray - , unsafeThawSmallArray - , sizeofSmallArray - , sizeofSmallMutableArray - , smallArrayFromList - , smallArrayFromListN - , mapSmallArray' - , traverseSmallArrayP - ) where - - -#if (__GLASGOW_HASKELL__ >= 710) -#define HAVE_SMALL_ARRAY 1 -#endif - -#if MIN_VERSION_base(4,7,0) -import GHC.Exts hiding (toList) -import qualified GHC.Exts -#endif - -import Control.Applicative -import Control.Monad -import Control.Monad.Fix -import Control.Monad.Primitive -import Control.Monad.ST -import Control.Monad.Zip -import Data.Data -import Data.Foldable as Foldable -import Data.Functor.Identity -#if !(MIN_VERSION_base(4,10,0)) -import Data.Monoid -#endif -#if MIN_VERSION_base(4,9,0) -import qualified GHC.ST as GHCST -import qualified Data.Semigroup as Sem -#endif -import Text.ParserCombinators.ReadP -#if MIN_VERSION_base(4,10,0) -import GHC.Exts (runRW#) -#elif MIN_VERSION_base(4,9,0) -import GHC.Base (runRW#) -#endif - -#if !(HAVE_SMALL_ARRAY) -import Data.Primitive.Array -import Data.Traversable -import qualified Data.Primitive.Array as Array -#endif - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..)) -#endif - -#if HAVE_SMALL_ARRAY -data SmallArray a = SmallArray (SmallArray# a) - deriving Typeable -#else -newtype SmallArray a = SmallArray (Array a) deriving - ( Eq - , Ord - , Show - , Read - , Foldable - , Traversable - , Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MonadZip - , MonadFix - , Monoid - , Typeable -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) - , Eq1 - , Ord1 - , Show1 - , Read1 -#endif - ) - -#if MIN_VERSION_base(4,7,0) -instance IsList (SmallArray a) where - type Item (SmallArray a) = a - fromListN n l = SmallArray (fromListN n l) - fromList l = SmallArray (fromList l) - toList a = Foldable.toList a -#endif -#endif - -#if HAVE_SMALL_ARRAY -data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a) - deriving Typeable -#else -newtype SmallMutableArray s a = SmallMutableArray (MutableArray s a) - deriving (Eq, Typeable) -#endif - --- | Create a new small mutable array. -newSmallArray - :: PrimMonad m - => Int -- ^ size - -> a -- ^ initial contents - -> m (SmallMutableArray (PrimState m) a) -#if HAVE_SMALL_ARRAY -newSmallArray (I# i#) x = primitive $ \s -> - case newSmallArray# i# x s of - (# s', sma# #) -> (# s', SmallMutableArray sma# #) -#else -newSmallArray n e = SmallMutableArray `liftM` newArray n e -#endif -{-# INLINE newSmallArray #-} - --- | Read the element at a given index in a mutable array. -readSmallArray - :: PrimMonad m - => SmallMutableArray (PrimState m) a -- ^ array - -> Int -- ^ index - -> m a -#if HAVE_SMALL_ARRAY -readSmallArray (SmallMutableArray sma#) (I# i#) = - primitive $ readSmallArray# sma# i# -#else -readSmallArray (SmallMutableArray a) = readArray a -#endif -{-# INLINE readSmallArray #-} - --- | Write an element at the given idex in a mutable array. -writeSmallArray - :: PrimMonad m - => SmallMutableArray (PrimState m) a -- ^ array - -> Int -- ^ index - -> a -- ^ new element - -> m () -#if HAVE_SMALL_ARRAY -writeSmallArray (SmallMutableArray sma#) (I# i#) x = - primitive_ $ writeSmallArray# sma# i# x -#else -writeSmallArray (SmallMutableArray a) = writeArray a -#endif -{-# INLINE writeSmallArray #-} - --- | Look up an element in an immutable array. --- --- The purpose of returning a result using a monad 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 --- instance: --- --- > data Box a = Box a --- > ... --- > --- > f sa = case indexSmallArrayM sa 0 of --- > Box x -> ... --- --- 'x' is not a closure that references 'sa' as it would be if we instead --- wrote: --- --- > let x = indexSmallArray sa 0 --- --- And 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. -indexSmallArrayM - :: Monad m - => SmallArray a -- ^ array - -> Int -- ^ index - -> m a -#if HAVE_SMALL_ARRAY -indexSmallArrayM (SmallArray sa#) (I# i#) = - case indexSmallArray# sa# i# of - (# x #) -> pure x -#else -indexSmallArrayM (SmallArray a) = indexArrayM a -#endif -{-# INLINE indexSmallArrayM #-} - --- | Look up an element in an immutable array. -indexSmallArray - :: SmallArray a -- ^ array - -> Int -- ^ index - -> a -#if HAVE_SMALL_ARRAY -indexSmallArray sa i = runIdentity $ indexSmallArrayM sa i -#else -indexSmallArray (SmallArray a) = indexArray a -#endif -{-# INLINE indexSmallArray #-} - --- | Read a value from the immutable array at the given index, returning --- the result in an unboxed unary tuple. This is currently used to implement --- folds. -indexSmallArray## :: SmallArray a -> Int -> (# a #) -#if HAVE_SMALL_ARRAY -indexSmallArray## (SmallArray ary) (I# i) = indexSmallArray# ary i -#else -indexSmallArray## (SmallArray a) = indexArray## a -#endif -{-# INLINE indexSmallArray## #-} - --- | Create a copy of a slice of an immutable array. -cloneSmallArray - :: SmallArray a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> SmallArray a -#if HAVE_SMALL_ARRAY -cloneSmallArray (SmallArray sa#) (I# i#) (I# j#) = - SmallArray (cloneSmallArray# sa# i# j#) -#else -cloneSmallArray (SmallArray a) i j = SmallArray $ cloneArray a i j -#endif -{-# INLINE cloneSmallArray #-} - --- | Create a copy of a slice of a mutable array. -cloneSmallMutableArray - :: PrimMonad m - => SmallMutableArray (PrimState m) a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (SmallMutableArray (PrimState m) a) -#if HAVE_SMALL_ARRAY -cloneSmallMutableArray (SmallMutableArray sma#) (I# o#) (I# l#) = - primitive $ \s -> case cloneSmallMutableArray# sma# o# l# s of - (# s', smb# #) -> (# s', SmallMutableArray smb# #) -#else -cloneSmallMutableArray (SmallMutableArray ma) i j = - SmallMutableArray `liftM` cloneMutableArray ma i j -#endif -{-# INLINE cloneSmallMutableArray #-} - --- | Create an immutable array corresponding to a slice of a mutable array. --- --- This operation copies the portion of the array to be frozen. -freezeSmallArray - :: PrimMonad m - => SmallMutableArray (PrimState m) a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (SmallArray a) -#if HAVE_SMALL_ARRAY -freezeSmallArray (SmallMutableArray sma#) (I# i#) (I# j#) = - primitive $ \s -> case freezeSmallArray# sma# i# j# s of - (# s', sa# #) -> (# s', SmallArray sa# #) -#else -freezeSmallArray (SmallMutableArray ma) i j = - SmallArray `liftM` freezeArray ma i j -#endif -{-# INLINE freezeSmallArray #-} - --- | Render a mutable array immutable. --- --- This operation performs no copying, so care must be taken not to modify the --- input array after freezing. -unsafeFreezeSmallArray - :: PrimMonad m => SmallMutableArray (PrimState m) a -> m (SmallArray a) -#if HAVE_SMALL_ARRAY -unsafeFreezeSmallArray (SmallMutableArray sma#) = - primitive $ \s -> case unsafeFreezeSmallArray# sma# s of - (# s', sa# #) -> (# s', SmallArray sa# #) -#else -unsafeFreezeSmallArray (SmallMutableArray ma) = - SmallArray `liftM` unsafeFreezeArray ma -#endif -{-# INLINE unsafeFreezeSmallArray #-} - --- | Create a mutable array corresponding to a slice of an immutable array. --- --- This operation copies the portion of the array to be thawed. -thawSmallArray - :: PrimMonad m - => SmallArray a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (SmallMutableArray (PrimState m) a) -#if HAVE_SMALL_ARRAY -thawSmallArray (SmallArray sa#) (I# o#) (I# l#) = - primitive $ \s -> case thawSmallArray# sa# o# l# s of - (# s', sma# #) -> (# s', SmallMutableArray sma# #) -#else -thawSmallArray (SmallArray a) off len = - SmallMutableArray `liftM` thawArray a off len -#endif -{-# INLINE thawSmallArray #-} - --- | Render an immutable array mutable. --- --- This operation performs no copying, so care must be taken with its use. -unsafeThawSmallArray - :: PrimMonad m => SmallArray a -> m (SmallMutableArray (PrimState m) a) -#if HAVE_SMALL_ARRAY -unsafeThawSmallArray (SmallArray sa#) = - primitive $ \s -> case unsafeThawSmallArray# sa# s of - (# s', sma# #) -> (# s', SmallMutableArray sma# #) -#else -unsafeThawSmallArray (SmallArray a) = SmallMutableArray `liftM` unsafeThawArray a -#endif -{-# INLINE unsafeThawSmallArray #-} - --- | Copy a slice of an immutable array into a mutable array. -copySmallArray - :: PrimMonad m - => SmallMutableArray (PrimState m) a -- ^ destination - -> Int -- ^ destination offset - -> SmallArray a -- ^ source - -> Int -- ^ source offset - -> Int -- ^ length - -> m () -#if HAVE_SMALL_ARRAY -copySmallArray - (SmallMutableArray dst#) (I# do#) (SmallArray src#) (I# so#) (I# l#) = - primitive_ $ copySmallArray# src# so# dst# do# l# -#else -copySmallArray (SmallMutableArray dst) i (SmallArray src) = copyArray dst i src -#endif -{-# INLINE copySmallArray #-} - --- | Copy a slice of one mutable array into another. -copySmallMutableArray - :: PrimMonad m - => SmallMutableArray (PrimState m) a -- ^ destination - -> Int -- ^ destination offset - -> SmallMutableArray (PrimState m) a -- ^ source - -> Int -- ^ source offset - -> Int -- ^ length - -> m () -#if HAVE_SMALL_ARRAY -copySmallMutableArray - (SmallMutableArray dst#) (I# do#) - (SmallMutableArray src#) (I# so#) - (I# l#) = - primitive_ $ copySmallMutableArray# src# so# dst# do# l# -#else -copySmallMutableArray (SmallMutableArray dst) i (SmallMutableArray src) = - copyMutableArray dst i src -#endif -{-# INLINE copySmallMutableArray #-} - -sizeofSmallArray :: SmallArray a -> Int -#if HAVE_SMALL_ARRAY -sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#) -#else -sizeofSmallArray (SmallArray a) = sizeofArray a -#endif -{-# INLINE sizeofSmallArray #-} - -sizeofSmallMutableArray :: SmallMutableArray s a -> Int -#if HAVE_SMALL_ARRAY -sizeofSmallMutableArray (SmallMutableArray sa#) = - I# (sizeofSmallMutableArray# sa#) -#else -sizeofSmallMutableArray (SmallMutableArray ma) = sizeofMutableArray ma -#endif -{-# INLINE sizeofSmallMutableArray #-} - --- | This is the fastest, most straightforward way to traverse --- an array, but it only works correctly with a sufficiently --- "affine" 'PrimMonad' instance. In particular, it must only produce --- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed --- monads, for example, will not work right at all. -traverseSmallArrayP - :: PrimMonad m - => (a -> m b) - -> SmallArray a - -> m (SmallArray b) -#if HAVE_SMALL_ARRAY -traverseSmallArrayP f = \ !ary -> - let - !sz = sizeofSmallArray ary - go !i !mary - | i == sz - = unsafeFreezeSmallArray mary - | otherwise - = do - a <- indexSmallArrayM ary i - b <- f a - writeSmallArray mary i b - go (i + 1) mary - in do - mary <- newSmallArray sz badTraverseValue - go 0 mary -#else -traverseSmallArrayP f (SmallArray ar) = SmallArray `liftM` traverseArrayP f ar -#endif -{-# INLINE traverseSmallArrayP #-} - --- | Strict map over the elements of the array. -mapSmallArray' :: (a -> b) -> SmallArray a -> SmallArray b -#if HAVE_SMALL_ARRAY -mapSmallArray' f sa = createSmallArray (length sa) (die "mapSmallArray'" "impossible") $ \smb -> - fix ? 0 $ \go i -> - when (i < length sa) $ do - x <- indexSmallArrayM sa i - let !y = f x - writeSmallArray smb i y *> go (i+1) -#else -mapSmallArray' f (SmallArray ar) = SmallArray (mapArray' f ar) -#endif -{-# INLINE mapSmallArray' #-} - -#ifndef HAVE_SMALL_ARRAY -runSmallArray - :: (forall s. ST s (SmallMutableArray s a)) - -> SmallArray a -runSmallArray m = SmallArray $ runArray $ - m >>= \(SmallMutableArray mary) -> return mary - -#elif !MIN_VERSION_base(4,9,0) -runSmallArray - :: (forall s. ST s (SmallMutableArray s a)) - -> SmallArray a -runSmallArray m = runST $ m >>= unsafeFreezeSmallArray - -#else --- This low-level business is designed to work with GHC's worker-wrapper --- transformation. A lot of the time, we don't actually need an Array --- constructor. By putting it on the outside, and being careful about --- how we special-case the empty array, we can make GHC smarter about this. --- The only downside is that separately created 0-length arrays won't share --- their Array constructors, although they'll share their underlying --- Array#s. -runSmallArray - :: (forall s. ST s (SmallMutableArray s a)) - -> SmallArray a -runSmallArray m = SmallArray (runSmallArray# m) - -runSmallArray# - :: (forall s. ST s (SmallMutableArray s a)) - -> SmallArray# a -runSmallArray# m = case runRW# $ \s -> - case unST m s of { (# s', SmallMutableArray mary# #) -> - unsafeFreezeSmallArray# mary# s'} of (# _, ary# #) -> ary# - -unST :: ST s a -> State# s -> (# State# s, a #) -unST (GHCST.ST f) = f - -#endif - -#if HAVE_SMALL_ARRAY --- See the comment on runSmallArray for why we use emptySmallArray#. -createSmallArray - :: Int - -> a - -> (forall s. SmallMutableArray s a -> ST s ()) - -> SmallArray a -createSmallArray 0 _ _ = SmallArray (emptySmallArray# (# #)) -createSmallArray n x f = runSmallArray $ do - mary <- newSmallArray n x - f mary - pure mary - -emptySmallArray# :: (# #) -> SmallArray# a -emptySmallArray# _ = case emptySmallArray of SmallArray ar -> ar -{-# NOINLINE emptySmallArray# #-} - -die :: String -> String -> a -die fun problem = error $ "Data.Primitive.SmallArray." ++ fun ++ ": " ++ problem - -emptySmallArray :: SmallArray a -emptySmallArray = - runST $ newSmallArray 0 (die "emptySmallArray" "impossible") - >>= unsafeFreezeSmallArray -{-# NOINLINE emptySmallArray #-} - - -infixl 1 ? -(?) :: (a -> b -> c) -> (b -> a -> c) -(?) = flip -{-# INLINE (?) #-} - -noOp :: a -> ST s () -noOp = const $ pure () - -smallArrayLiftEq :: (a -> b -> Bool) -> SmallArray a -> SmallArray b -> Bool -smallArrayLiftEq p sa1 sa2 = length sa1 == length sa2 && loop (length sa1 - 1) - where - loop i - | i < 0 - = True - | (# x #) <- indexSmallArray## sa1 i - , (# y #) <- indexSmallArray## sa2 i - = p x y && loop (i-1) - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Eq1 SmallArray where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftEq = smallArrayLiftEq -#else - eq1 = smallArrayLiftEq (==) -#endif -#endif - -instance Eq a => Eq (SmallArray a) where - sa1 == sa2 = smallArrayLiftEq (==) sa1 sa2 - -instance Eq (SmallMutableArray s a) where - SmallMutableArray sma1# == SmallMutableArray sma2# = - isTrue# (sameSmallMutableArray# sma1# sma2#) - -smallArrayLiftCompare :: (a -> b -> Ordering) -> SmallArray a -> SmallArray b -> Ordering -smallArrayLiftCompare elemCompare a1 a2 = loop 0 - where - mn = length a1 `min` length a2 - loop i - | i < mn - , (# x1 #) <- indexSmallArray## a1 i - , (# x2 #) <- indexSmallArray## a2 i - = elemCompare x1 x2 `mappend` loop (i+1) - | otherwise = compare (length a1) (length a2) - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Ord1 SmallArray where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftCompare = smallArrayLiftCompare -#else - compare1 = smallArrayLiftCompare compare -#endif -#endif - --- | Lexicographic ordering. Subject to change between major versions. -instance Ord a => Ord (SmallArray a) where - compare sa1 sa2 = smallArrayLiftCompare compare sa1 sa2 - -instance Foldable SmallArray where - -- Note: we perform the array lookups eagerly so we won't - -- create thunks to perform lookups even if GHC can't see - -- that the folding function is strict. - foldr f = \z !ary -> - let - !sz = sizeofSmallArray ary - go i - | i == sz = z - | (# x #) <- indexSmallArray## ary i - = f x (go (i+1)) - in go 0 - {-# INLINE foldr #-} - foldl f = \z !ary -> - let - go i - | i < 0 = z - | (# x #) <- indexSmallArray## ary i - = f (go (i-1)) x - in go (sizeofSmallArray ary - 1) - {-# INLINE foldl #-} - foldr1 f = \ !ary -> - let - !sz = sizeofSmallArray ary - 1 - go i = - case indexSmallArray## ary i of - (# x #) | i == sz -> x - | otherwise -> f x (go (i+1)) - in if sz < 0 - then die "foldr1" "Empty SmallArray" - else go 0 - {-# INLINE foldr1 #-} - foldl1 f = \ !ary -> - let - !sz = sizeofSmallArray ary - 1 - go i = - case indexSmallArray## ary i of - (# x #) | i == 0 -> x - | otherwise -> f (go (i - 1)) x - in if sz < 0 - then die "foldl1" "Empty SmallArray" - else go sz - {-# INLINE foldl1 #-} - foldr' f = \z !ary -> - let - go i !acc - | i == -1 = acc - | (# x #) <- indexSmallArray## ary i - = go (i-1) (f x acc) - in go (sizeofSmallArray ary - 1) z - {-# INLINE foldr' #-} - foldl' f = \z !ary -> - let - !sz = sizeofSmallArray ary - go i !acc - | i == sz = acc - | (# x #) <- indexSmallArray## ary i - = go (i+1) (f acc x) - in go 0 z - {-# INLINE foldl' #-} - null a = sizeofSmallArray a == 0 - {-# INLINE null #-} - length = sizeofSmallArray - {-# INLINE length #-} - maximum ary | sz == 0 = die "maximum" "Empty SmallArray" - | (# frst #) <- indexSmallArray## ary 0 - = go 1 frst - where - sz = sizeofSmallArray ary - go i !e - | i == sz = e - | (# x #) <- indexSmallArray## ary i - = go (i+1) (max e x) - {-# INLINE maximum #-} - minimum ary | sz == 0 = die "minimum" "Empty SmallArray" - | (# frst #) <- indexSmallArray## ary 0 - = go 1 frst - where sz = sizeofSmallArray ary - go i !e - | i == sz = e - | (# x #) <- indexSmallArray## ary i - = go (i+1) (min e x) - {-# INLINE minimum #-} - sum = foldl' (+) 0 - {-# INLINE sum #-} - product = foldl' (*) 1 - {-# INLINE product #-} - -newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (SmallArray a)} - -runSTA :: Int -> STA a -> SmallArray a -runSTA !sz = \ (STA m) -> runST $ newSmallArray_ sz >>= - \ (SmallMutableArray ar#) -> m ar# -{-# INLINE runSTA #-} - -newSmallArray_ :: Int -> ST s (SmallMutableArray s a) -newSmallArray_ !n = newSmallArray n badTraverseValue - -badTraverseValue :: a -badTraverseValue = die "traverse" "bad indexing" -{-# NOINLINE badTraverseValue #-} - -instance Traversable SmallArray where - traverse f = traverseSmallArray f - {-# INLINE traverse #-} - -traverseSmallArray - :: Applicative f - => (a -> f b) -> SmallArray a -> f (SmallArray b) -traverseSmallArray f = \ !ary -> - let - !len = sizeofSmallArray ary - go !i - | i == len - = pure $ STA $ \mary -> unsafeFreezeSmallArray (SmallMutableArray mary) - | (# x #) <- indexSmallArray## ary i - = liftA2 (\b (STA m) -> STA $ \mary -> - writeSmallArray (SmallMutableArray mary) i b >> m mary) - (f x) (go (i + 1)) - in if len == 0 - then pure emptySmallArray - else runSTA len <$> go 0 -{-# INLINE [1] traverseSmallArray #-} - -{-# RULES -"traverse/ST" forall (f :: a -> ST s b). traverseSmallArray f = traverseSmallArrayP f -"traverse/IO" forall (f :: a -> IO b). traverseSmallArray f = traverseSmallArrayP f -"traverse/Id" forall (f :: a -> Identity b). traverseSmallArray f = - (coerce :: (SmallArray a -> SmallArray (Identity b)) - -> SmallArray a -> Identity (SmallArray b)) (fmap f) - #-} - - -instance Functor SmallArray where - fmap f sa = createSmallArray (length sa) (die "fmap" "impossible") $ \smb -> - fix ? 0 $ \go i -> - when (i < length sa) $ do - x <- indexSmallArrayM sa i - writeSmallArray smb i (f x) *> go (i+1) - {-# INLINE fmap #-} - - x <$ sa = createSmallArray (length sa) x noOp - -instance Applicative SmallArray where - pure x = createSmallArray 1 x noOp - - sa *> sb = createSmallArray (la*lb) (die "*>" "impossible") $ \smb -> - fix ? 0 $ \go i -> - when (i < la) $ - copySmallArray smb 0 sb 0 lb *> go (i+1) - where - la = length sa ; lb = length sb - - a <* b = createSmallArray (sza*szb) (die "<*" "impossible") $ \ma -> - let fill off i e = when (i < szb) $ - writeSmallArray ma (off+i) e >> fill off (i+1) e - go i = when (i < sza) $ do - x <- indexSmallArrayM a i - fill (i*szb) 0 x - go (i+1) - in go 0 - where sza = sizeofSmallArray a ; szb = sizeofSmallArray b - - ab <*> a = createSmallArray (szab*sza) (die "<*>" "impossible") $ \mb -> - let go1 i = when (i < szab) $ - do - f <- indexSmallArrayM ab i - go2 (i*sza) f 0 - go1 (i+1) - go2 off f j = when (j < sza) $ - do - x <- indexSmallArrayM a j - writeSmallArray mb (off + j) (f x) - go2 off f (j + 1) - in go1 0 - where szab = sizeofSmallArray ab ; sza = sizeofSmallArray a - -instance Alternative SmallArray where - empty = emptySmallArray - - sl <|> sr = - createSmallArray (length sl + length sr) (die "<|>" "impossible") $ \sma -> - copySmallArray sma 0 sl 0 (length sl) - *> copySmallArray sma (length sl) sr 0 (length sr) - - many sa | null sa = pure [] - | otherwise = die "many" "infinite arrays are not well defined" - - some sa | null sa = emptySmallArray - | otherwise = die "some" "infinite arrays are not well defined" - -data ArrayStack a - = PushArray !(SmallArray a) !(ArrayStack a) - | EmptyStack --- TODO: This isn't terribly efficient. It would be better to wrap --- ArrayStack with a type like --- --- data NES s a = NES !Int !(SmallMutableArray s a) !(ArrayStack a) --- --- We'd copy incoming arrays into the mutable array until we would --- overflow it. Then we'd freeze it, push it on the stack, and continue. --- Any sufficiently large incoming arrays would go straight on the stack. --- Such a scheme would make the stack much more compact in the case --- of many small arrays. - -instance Monad SmallArray where - return = pure - (>>) = (*>) - - sa >>= f = collect 0 EmptyStack (la-1) - where - la = length sa - collect sz stk i - | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk - | (# x #) <- indexSmallArray## sa i - , let sb = f x - lsb = length sb - -- If we don't perform this check, we could end up allocating - -- a stack full of empty arrays if someone is filtering most - -- things out. So we refrain from pushing empty arrays. - = if lsb == 0 - then collect sz stk (i-1) - else collect (sz + lsb) (PushArray sb stk) (i-1) - - fill _ EmptyStack _ = return () - fill off (PushArray sb sbs) smb = - copySmallArray smb off sb 0 (length sb) - *> fill (off + length sb) sbs smb - - fail _ = emptySmallArray - -instance MonadPlus SmallArray where - mzero = empty - mplus = (<|>) - -zipW :: String -> (a -> b -> c) -> SmallArray a -> SmallArray b -> SmallArray c -zipW nm = \f sa sb -> let mn = length sa `min` length sb in - createSmallArray mn (die nm "impossible") $ \mc -> - fix ? 0 $ \go i -> when (i < mn) $ do - x <- indexSmallArrayM sa i - y <- indexSmallArrayM sb i - writeSmallArray mc i (f x y) - go (i+1) -{-# INLINE zipW #-} - -instance MonadZip SmallArray where - mzip = zipW "mzip" (,) - mzipWith = zipW "mzipWith" - {-# INLINE mzipWith #-} - munzip sab = runST $ do - let sz = length sab - sma <- newSmallArray sz $ die "munzip" "impossible" - smb <- newSmallArray sz $ die "munzip" "impossible" - fix ? 0 $ \go i -> - when (i < sz) $ case indexSmallArray sab i of - (x, y) -> do writeSmallArray sma i x - writeSmallArray smb i y - go $ i+1 - (,) <$> unsafeFreezeSmallArray sma - <*> unsafeFreezeSmallArray smb - -instance MonadFix SmallArray where - mfix f = createSmallArray (sizeofSmallArray (f err)) - (die "mfix" "impossible") $ flip fix 0 $ - \r !i !mary -> when (i < sz) $ do - writeSmallArray mary i (fix (\xi -> f xi `indexSmallArray` i)) - r (i + 1) mary - where - sz = sizeofSmallArray (f err) - err = error "mfix for Data.Primitive.SmallArray applied to strict function." - -#if MIN_VERSION_base(4,9,0) --- | @since 0.6.3.0 -instance Sem.Semigroup (SmallArray a) where - (<>) = (<|>) - sconcat = mconcat . toList -#endif - -instance Monoid (SmallArray a) where - mempty = empty -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<|>) -#endif - mconcat l = createSmallArray n (die "mconcat" "impossible") $ \ma -> - let go !_ [ ] = return () - go off (a:as) = - copySmallArray ma off a 0 (sizeofSmallArray a) >> go (off + sizeofSmallArray a) as - in go 0 l - where n = sum . fmap length $ l - -instance IsList (SmallArray a) where - type Item (SmallArray a) = a - fromListN = smallArrayFromListN - fromList = smallArrayFromList - 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) - --- this need to be included for older ghcs -listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS -listLiftShowsPrec _ sl _ = sl - -instance Show a => Show (SmallArray a) where - showsPrec p sa = smallArrayLiftShowsPrec showsPrec showList p sa - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Show1 SmallArray where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftShowsPrec = smallArrayLiftShowsPrec -#else - showsPrec1 = smallArrayLiftShowsPrec showsPrec showList -#endif -#endif - -smallArrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (SmallArray a) -smallArrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do - () <$ string "fromListN" - skipSpaces - n <- readS_to_P reads - skipSpaces - l <- readS_to_P listReadsPrec - return $ smallArrayFromListN n l - -instance Read a => Read (SmallArray a) where - readsPrec = smallArrayLiftReadsPrec readsPrec readList - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Read1 SmallArray where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftReadsPrec = smallArrayLiftReadsPrec -#else - readsPrec1 = smallArrayLiftReadsPrec readsPrec readList -#endif -#endif - - - -smallArrayDataType :: DataType -smallArrayDataType = - mkDataType "Data.Primitive.SmallArray.SmallArray" [fromListConstr] - -fromListConstr :: Constr -fromListConstr = mkConstr smallArrayDataType "fromList" [] Prefix - -instance Data a => Data (SmallArray a) where - toConstr _ = fromListConstr - dataTypeOf _ = smallArrayDataType - gunfold k z c = case constrIndex c of - 1 -> k (z fromList) - _ -> die "gunfold" "SmallArray" - gfoldl f z m = z fromList `f` toList m - -instance (Typeable s, Typeable a) => Data (SmallMutableArray s a) where - toConstr _ = die "toConstr" "SmallMutableArray" - gunfold _ _ = die "gunfold" "SmallMutableArray" - dataTypeOf _ = mkNoRepType "Data.Primitive.SmallArray.SmallMutableArray" -#endif - --- | Create a 'SmallArray' from a list of a known length. If the length --- of the list does not match the given length, this throws an exception. -smallArrayFromListN :: Int -> [a] -> SmallArray a -#if HAVE_SMALL_ARRAY -smallArrayFromListN n l = - createSmallArray n - (die "smallArrayFromListN" "uninitialized element") $ \sma -> - let go !ix [] = if ix == n - then return () - else die "smallArrayFromListN" "list length less than specified size" - go !ix (x : xs) = if ix < n - then do - writeSmallArray sma ix x - go (ix+1) xs - else die "smallArrayFromListN" "list length greater than specified size" - in go 0 l -#else -smallArrayFromListN n l = SmallArray (Array.fromListN n l) -#endif - --- | Create a 'SmallArray' from a list. -smallArrayFromList :: [a] -> SmallArray a -smallArrayFromList l = smallArrayFromListN (length l) l diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Types.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Types.hs deleted file mode 100644 index fd36ea0c94..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Types.hs +++ /dev/null @@ -1,395 +0,0 @@ -{-# LANGUAGE CPP, UnboxedTuples, MagicHash, DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE TypeInType #-} -#endif - -#include "HsBaseConfig.h" - --- | --- Module : Data.Primitive.Types --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Basic types and classes for primitive array operations --- - -module Data.Primitive.Types ( - Prim(..), - sizeOf, alignment, defaultSetByteArray#, defaultSetOffAddr#, - - Addr(..), - PrimStorable(..) -) where - -import Control.Monad.Primitive -import Data.Primitive.MachDeps -import Data.Primitive.Internal.Operations -import Foreign.C.Types -import System.Posix.Types - -import GHC.Base ( - Int(..), Char(..), - ) -import GHC.Float ( - Float(..), Double(..) - ) -import GHC.Word ( - Word(..), Word8(..), Word16(..), Word32(..), Word64(..) - ) -import GHC.Int ( - Int8(..), Int16(..), Int32(..), Int64(..) - ) - -import GHC.Ptr ( - Ptr(..), FunPtr(..) - ) - -import GHC.Prim -#if __GLASGOW_HASKELL__ >= 706 - hiding (setByteArray#) -#endif - -import Data.Typeable ( Typeable ) -import Data.Data ( Data(..) ) -import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) -import Foreign.Storable (Storable) -import Numeric - -import qualified Foreign.Storable as FS - --- | A machine address -data Addr = Addr Addr# deriving ( Typeable ) - -instance Show Addr where - showsPrec _ (Addr a) = - showString "0x" . showHex (fromIntegral (I# (addr2Int# a)) :: Word) - -instance Eq Addr where - Addr a# == Addr b# = isTrue# (eqAddr# a# b#) - Addr a# /= Addr b# = isTrue# (neAddr# a# b#) - -instance Ord Addr where - Addr a# > Addr b# = isTrue# (gtAddr# a# b#) - Addr a# >= Addr b# = isTrue# (geAddr# a# b#) - Addr a# < Addr b# = isTrue# (ltAddr# a# b#) - Addr a# <= Addr b# = isTrue# (leAddr# a# b#) - -instance Data Addr where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Data.Primitive.Types.Addr" - - --- | Class of types supporting primitive array operations -class Prim a where - - -- | Size of values of type @a@. The argument is not used. - sizeOf# :: a -> Int# - - -- | Alignment of values of type @a@. The argument is not used. - alignment# :: a -> Int# - - -- | Read a value from the array. The offset is in elements of type - -- @a@ rather than in bytes. - indexByteArray# :: ByteArray# -> Int# -> a - - -- | Read a value from the mutable array. The offset is in elements of type - -- @a@ rather than in bytes. - readByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) - - -- | Write a value to the mutable array. The offset is in elements of type - -- @a@ rather than in bytes. - writeByteArray# :: MutableByteArray# s -> Int# -> a -> State# s -> State# s - - -- | Fill a slice of the mutable array with a value. The offset and length - -- of the chunk are in elements of type @a@ rather than in bytes. - setByteArray# :: MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s - - -- | 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 - -- elements of type @a@ rather than in bytes. - indexOffAddr# :: Addr# -> Int# -> a - - -- | Read a value from a memory position given by an address and an offset. - -- The offset is in elements of type @a@ rather than in bytes. - readOffAddr# :: Addr# -> Int# -> State# s -> (# State# s, a #) - - -- | Write a value to a memory position given by an address and an offset. - -- The offset is in elements of type @a@ rather than in bytes. - writeOffAddr# :: Addr# -> Int# -> a -> State# s -> State# s - - -- | Fill a memory block given by an address, an offset and a length. - -- The offset and length are in elements of type @a@ rather than in bytes. - setOffAddr# :: Addr# -> Int# -> Int# -> a -> State# s -> State# s - --- | Size of values of type @a@. The argument is not used. --- --- This function has existed since 0.1, but was moved from 'Data.Primitive' --- to 'Data.Primitive.Types' in version 0.6.3.0 -sizeOf :: Prim a => a -> Int -sizeOf x = I# (sizeOf# x) - --- | Alignment of values of type @a@. The argument is not used. --- --- This function has existed since 0.1, but was moved from 'Data.Primitive' --- to 'Data.Primitive.Types' in version 0.6.3.0 -alignment :: Prim a => a -> Int -alignment x = I# (alignment# x) - --- | An implementation of 'setByteArray#' that calls 'writeByteArray#' --- to set each element. This is helpful when writing a 'Prim' instance --- for a multi-word data type for which there is no cpu-accelerated way --- to broadcast a value to contiguous memory. It is typically used --- alongside 'defaultSetOffAddr#'. For example: --- --- > data Trip = Trip Int Int Int --- > --- > instance Prim Trip --- > sizeOf# _ = 3# *# sizeOf# (undefined :: Int) --- > alignment# _ = alignment# (undefined :: Int) --- > indexByteArray# arr# i# = ... --- > readByteArray# arr# i# = ... --- > writeByteArray# arr# i# (Trip a b c) = --- > \s0 -> case writeByteArray# arr# (3# *# i#) a s0 of --- > s1 -> case writeByteArray# arr# ((3# *# i#) +# 1#) b s1 of --- > s2 -> case writeByteArray# arr# ((3# *# i#) +# 2# ) c s2 of --- > s3 -> s3 --- > setByteArray# = defaultSetByteArray# --- > indexOffAddr# addr# i# = ... --- > readOffAddr# addr# i# = ... --- > writeOffAddr# addr# i# (Trip a b c) = --- > \s0 -> case writeOffAddr# addr# (3# *# i#) a s0 of --- > s1 -> case writeOffAddr# addr# ((3# *# i#) +# 1#) b s1 of --- > s2 -> case writeOffAddr# addr# ((3# *# i#) +# 2# ) c s2 of --- > s3 -> s3 --- > setOffAddr# = defaultSetOffAddr# -defaultSetByteArray# :: Prim a => MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s -defaultSetByteArray# arr# i# len# ident = go 0# - where - go ix# s0 = if isTrue# (ix# <# len#) - then case writeByteArray# arr# (i# +# ix#) ident s0 of - s1 -> go (ix# +# 1#) s1 - else s0 - --- | An implementation of 'setOffAddr#' that calls 'writeOffAddr#' --- to set each element. The documentation of 'defaultSetByteArray#' --- provides an example of how to use this. -defaultSetOffAddr# :: Prim a => Addr# -> Int# -> Int# -> a -> State# s -> State# s -defaultSetOffAddr# addr# i# len# ident = go 0# - where - go ix# s0 = if isTrue# (ix# <# len#) - then case writeOffAddr# addr# (i# +# ix#) ident s0 of - s1 -> go (ix# +# 1#) s1 - else s0 - --- | Newtype that uses a 'Prim' instance to give rise to a 'Storable' instance. --- This type is intended to be used with the @DerivingVia@ extension available --- in GHC 8.6 and up. For example, consider a user-defined 'Prim' instance for --- a multi-word data type. --- --- > data Uuid = Uuid Word64 Word64 --- > deriving Storable via (PrimStorable Uuid) --- > instance Prim Uuid where ... --- --- Writing the 'Prim' instance is tedious and unavoidable, but the 'Storable' --- instance comes for free once the 'Prim' instance is written. -newtype PrimStorable a = PrimStorable { getPrimStorable :: a } - -instance Prim a => Storable (PrimStorable a) where - sizeOf _ = sizeOf (undefined :: a) - alignment _ = alignment (undefined :: a) - peekElemOff (Ptr addr#) (I# i#) = - primitive $ \s0# -> case readOffAddr# addr# i# s0# of - (# s1, x #) -> (# s1, PrimStorable x #) - pokeElemOff (Ptr addr#) (I# i#) (PrimStorable a) = primitive_ $ \s# -> - writeOffAddr# addr# i# a s# - -#define derivePrim(ty, ctr, sz, align, idx_arr, rd_arr, wr_arr, set_arr, idx_addr, rd_addr, wr_addr, set_addr) \ -instance Prim (ty) where { \ - sizeOf# _ = unI# sz \ -; alignment# _ = unI# align \ -; indexByteArray# arr# i# = ctr (idx_arr arr# i#) \ -; readByteArray# arr# i# s# = case rd_arr arr# i# s# of \ - { (# s1#, x# #) -> (# s1#, ctr x# #) } \ -; writeByteArray# arr# i# (ctr x#) s# = wr_arr arr# i# x# s# \ -; setByteArray# arr# i# n# (ctr x#) s# \ - = let { i = fromIntegral (I# i#) \ - ; n = fromIntegral (I# n#) \ - } in \ - case unsafeCoerce# (internal (set_arr arr# i n x#)) s# of \ - { (# s1#, _ #) -> s1# } \ - \ -; indexOffAddr# addr# i# = ctr (idx_addr addr# i#) \ -; readOffAddr# addr# i# s# = case rd_addr addr# i# s# of \ - { (# s1#, x# #) -> (# s1#, ctr x# #) } \ -; writeOffAddr# addr# i# (ctr x#) s# = wr_addr addr# i# x# s# \ -; setOffAddr# addr# i# n# (ctr x#) s# \ - = let { i = fromIntegral (I# i#) \ - ; n = fromIntegral (I# n#) \ - } in \ - case unsafeCoerce# (internal (set_addr addr# i n x#)) s# of \ - { (# s1#, _ #) -> s1# } \ -; {-# INLINE sizeOf# #-} \ -; {-# INLINE alignment# #-} \ -; {-# INLINE indexByteArray# #-} \ -; {-# INLINE readByteArray# #-} \ -; {-# INLINE writeByteArray# #-} \ -; {-# INLINE setByteArray# #-} \ -; {-# INLINE indexOffAddr# #-} \ -; {-# INLINE readOffAddr# #-} \ -; {-# INLINE writeOffAddr# #-} \ -; {-# INLINE setOffAddr# #-} \ -} - -unI# :: Int -> Int# -unI# (I# n#) = n# - -derivePrim(Word, W#, sIZEOF_WORD, aLIGNMENT_WORD, - indexWordArray#, readWordArray#, writeWordArray#, setWordArray#, - indexWordOffAddr#, readWordOffAddr#, writeWordOffAddr#, setWordOffAddr#) -derivePrim(Word8, W8#, sIZEOF_WORD8, aLIGNMENT_WORD8, - indexWord8Array#, readWord8Array#, writeWord8Array#, setWord8Array#, - indexWord8OffAddr#, readWord8OffAddr#, writeWord8OffAddr#, setWord8OffAddr#) -derivePrim(Word16, W16#, sIZEOF_WORD16, aLIGNMENT_WORD16, - indexWord16Array#, readWord16Array#, writeWord16Array#, setWord16Array#, - indexWord16OffAddr#, readWord16OffAddr#, writeWord16OffAddr#, setWord16OffAddr#) -derivePrim(Word32, W32#, sIZEOF_WORD32, aLIGNMENT_WORD32, - indexWord32Array#, readWord32Array#, writeWord32Array#, setWord32Array#, - indexWord32OffAddr#, readWord32OffAddr#, writeWord32OffAddr#, setWord32OffAddr#) -derivePrim(Word64, W64#, sIZEOF_WORD64, aLIGNMENT_WORD64, - indexWord64Array#, readWord64Array#, writeWord64Array#, setWord64Array#, - indexWord64OffAddr#, readWord64OffAddr#, writeWord64OffAddr#, setWord64OffAddr#) -derivePrim(Int, I#, sIZEOF_INT, aLIGNMENT_INT, - indexIntArray#, readIntArray#, writeIntArray#, setIntArray#, - indexIntOffAddr#, readIntOffAddr#, writeIntOffAddr#, setIntOffAddr#) -derivePrim(Int8, I8#, sIZEOF_INT8, aLIGNMENT_INT8, - indexInt8Array#, readInt8Array#, writeInt8Array#, setInt8Array#, - indexInt8OffAddr#, readInt8OffAddr#, writeInt8OffAddr#, setInt8OffAddr#) -derivePrim(Int16, I16#, sIZEOF_INT16, aLIGNMENT_INT16, - indexInt16Array#, readInt16Array#, writeInt16Array#, setInt16Array#, - indexInt16OffAddr#, readInt16OffAddr#, writeInt16OffAddr#, setInt16OffAddr#) -derivePrim(Int32, I32#, sIZEOF_INT32, aLIGNMENT_INT32, - indexInt32Array#, readInt32Array#, writeInt32Array#, setInt32Array#, - indexInt32OffAddr#, readInt32OffAddr#, writeInt32OffAddr#, setInt32OffAddr#) -derivePrim(Int64, I64#, sIZEOF_INT64, aLIGNMENT_INT64, - indexInt64Array#, readInt64Array#, writeInt64Array#, setInt64Array#, - indexInt64OffAddr#, readInt64OffAddr#, writeInt64OffAddr#, setInt64OffAddr#) -derivePrim(Float, F#, sIZEOF_FLOAT, aLIGNMENT_FLOAT, - indexFloatArray#, readFloatArray#, writeFloatArray#, setFloatArray#, - indexFloatOffAddr#, readFloatOffAddr#, writeFloatOffAddr#, setFloatOffAddr#) -derivePrim(Double, D#, sIZEOF_DOUBLE, aLIGNMENT_DOUBLE, - indexDoubleArray#, readDoubleArray#, writeDoubleArray#, setDoubleArray#, - indexDoubleOffAddr#, readDoubleOffAddr#, writeDoubleOffAddr#, setDoubleOffAddr#) -derivePrim(Char, C#, sIZEOF_CHAR, aLIGNMENT_CHAR, - indexWideCharArray#, readWideCharArray#, writeWideCharArray#, setWideCharArray#, - indexWideCharOffAddr#, readWideCharOffAddr#, writeWideCharOffAddr#, setWideCharOffAddr#) -derivePrim(Addr, Addr, sIZEOF_PTR, aLIGNMENT_PTR, - indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, - indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) -derivePrim(Ptr a, Ptr, sIZEOF_PTR, aLIGNMENT_PTR, - indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, - indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) -derivePrim(FunPtr a, FunPtr, sIZEOF_PTR, aLIGNMENT_PTR, - indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, - indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) - --- Prim instances for newtypes in Foreign.C.Types -deriving instance Prim CChar -deriving instance Prim CSChar -deriving instance Prim CUChar -deriving instance Prim CShort -deriving instance Prim CUShort -deriving instance Prim CInt -deriving instance Prim CUInt -deriving instance Prim CLong -deriving instance Prim CULong -deriving instance Prim CPtrdiff -deriving instance Prim CSize -deriving instance Prim CWchar -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 -deriving instance Prim CUIntMax -deriving instance Prim CClock -deriving instance Prim CTime -deriving instance Prim CUSeconds -deriving instance Prim CSUSeconds -deriving instance Prim CFloat -deriving instance Prim CDouble - --- Prim instances for newtypes in System.Posix.Types -#if defined(HTYPE_DEV_T) -deriving instance Prim CDev -#endif -#if defined(HTYPE_INO_T) -deriving instance Prim CIno -#endif -#if defined(HTYPE_MODE_T) -deriving instance Prim CMode -#endif -#if defined(HTYPE_OFF_T) -deriving instance Prim COff -#endif -#if defined(HTYPE_PID_T) -deriving instance Prim CPid -#endif -#if defined(HTYPE_SSIZE_T) -deriving instance Prim CSsize -#endif -#if defined(HTYPE_GID_T) -deriving instance Prim CGid -#endif -#if defined(HTYPE_NLINK_T) -deriving instance Prim CNlink -#endif -#if defined(HTYPE_UID_T) -deriving instance Prim CUid -#endif -#if defined(HTYPE_CC_T) -deriving instance Prim CCc -#endif -#if defined(HTYPE_SPEED_T) -deriving instance Prim CSpeed -#endif -#if defined(HTYPE_TCFLAG_T) -deriving instance Prim CTcflag -#endif -#if defined(HTYPE_RLIM_T) -deriving instance Prim CRLim -#endif -#if defined(HTYPE_BLKSIZE_T) -deriving instance Prim CBlkSize -#endif -#if defined(HTYPE_BLKCNT_T) -deriving instance Prim CBlkCnt -#endif -#if defined(HTYPE_CLOCKID_T) -deriving instance Prim CClockId -#endif -#if defined(HTYPE_FSBLKCNT_T) -deriving instance Prim CFsBlkCnt -#endif -#if defined(HTYPE_FSFILCNT_T) -deriving instance Prim CFsFilCnt -#endif -#if defined(HTYPE_ID_T) -deriving instance Prim CId -#endif -#if defined(HTYPE_KEY_T) -deriving instance Prim CKey -#endif -#if defined(HTYPE_TIMER_T) -deriving instance Prim CTimer -#endif -deriving instance Prim Fd diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/UnliftedArray.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/UnliftedArray.hs deleted file mode 100644 index 75a4847364..0000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/UnliftedArray.hs +++ /dev/null @@ -1,638 +0,0 @@ -{-# Language BangPatterns #-} -{-# Language CPP #-} -{-# Language DeriveDataTypeable #-} -{-# Language MagicHash #-} -{-# Language RankNTypes #-} -{-# Language ScopedTypeVariables #-} -{-# Language TypeFamilies #-} -{-# Language UnboxedTuples #-} - --- | --- Module : Data.Primitive.UnliftedArray --- Copyright : (c) Dan Doel 2016 --- License : BSD-style --- --- Maintainer : Libraries <libraries@haskell.org> --- Portability : non-portable --- --- GHC contains three general classes of value types: --- --- 1. Unboxed types: values are machine values made up of fixed numbers of bytes --- 2. Unlifted types: values are pointers, but strictly evaluated --- 3. Lifted types: values are pointers, lazily evaluated --- --- The first category can be stored in a 'ByteArray', and this allows types in --- category 3 that are simple wrappers around category 1 types to be stored --- more efficiently using a 'ByteArray'. This module provides the same facility --- for category 2 types. --- --- GHC has two primitive types, 'ArrayArray#' and 'MutableArrayArray#'. These --- are arrays of pointers, but of category 2 values, so they are known to not --- be bottom. This allows types that are wrappers around such types to be stored --- in an array without an extra level of indirection. --- --- The way that the 'ArrayArray#' API works is that one can read and write --- 'ArrayArray#' values to the positions. This works because all category 2 --- types share a uniform representation, unlike unboxed values which are --- represented by varying (by type) numbers of bytes. However, using the --- this makes the internal API very unsafe to use, as one has to coerce values --- to and from 'ArrayArray#'. --- --- The API presented by this module is more type safe. 'UnliftedArray' and --- 'MutableUnliftedArray' are parameterized by the type of arrays they contain, and --- the coercions necessary are abstracted into a class, 'PrimUnlifted', of things --- that are eligible to be stored. - -module Data.Primitive.UnliftedArray - ( -- * Types - UnliftedArray(..) - , MutableUnliftedArray(..) - , PrimUnlifted(..) - -- * Operations - , unsafeNewUnliftedArray - , newUnliftedArray - , setUnliftedArray - , sizeofUnliftedArray - , sizeofMutableUnliftedArray - , readUnliftedArray - , writeUnliftedArray - , indexUnliftedArray - , indexUnliftedArrayM - , unsafeFreezeUnliftedArray - , freezeUnliftedArray - , thawUnliftedArray - , runUnliftedArray - , sameMutableUnliftedArray - , copyUnliftedArray - , copyMutableUnliftedArray - , cloneUnliftedArray - , cloneMutableUnliftedArray - -- * List Conversion - , unliftedArrayToList - , unliftedArrayFromList - , unliftedArrayFromListN - -- * Folding - , foldrUnliftedArray - , foldrUnliftedArray' - , foldlUnliftedArray - , foldlUnliftedArray' - -- * Mapping - , mapUnliftedArray --- Missing operations: --- , unsafeThawUnliftedArray - ) where - -import Data.Typeable -import Control.Applicative - -import GHC.Prim -import GHC.Base (Int(..),build) - -import Control.Monad.Primitive - -import Control.Monad.ST (runST,ST) - -import Data.Monoid (Monoid,mappend) -import Data.Primitive.Internal.Compat ( isTrue# ) - -import qualified Data.List as L -import Data.Primitive.Array (Array) -import qualified Data.Primitive.Array as A -import Data.Primitive.ByteArray (ByteArray) -import qualified Data.Primitive.ByteArray as BA -import qualified Data.Primitive.PrimArray as PA -import qualified Data.Primitive.SmallArray as SA -import qualified Data.Primitive.MutVar as MV -import qualified Data.Monoid -import qualified GHC.MVar as GM (MVar(..)) -import qualified GHC.Conc as GC (TVar(..)) -import qualified GHC.Stable as GSP (StablePtr(..)) -import qualified GHC.Weak as GW (Weak(..)) -import qualified GHC.Conc.Sync as GCS (ThreadId(..)) -import qualified GHC.Exts as E -import qualified GHC.ST as GHCST - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup) -import qualified Data.Semigroup -#endif - -#if MIN_VERSION_base(4,10,0) -import GHC.Exts (runRW#) -#elif MIN_VERSION_base(4,9,0) -import GHC.Base (runRW#) -#endif - --- | Immutable arrays that efficiently store types that are simple wrappers --- around unlifted primitive types. The values of the unlifted type are --- stored directly, eliminating a layer of indirection. -data UnliftedArray e = UnliftedArray ArrayArray# - deriving (Typeable) - --- | Mutable arrays that efficiently store types that are simple wrappers --- around unlifted primitive types. The values of the unlifted type are --- stored directly, eliminating a layer of indirection. -data MutableUnliftedArray s e = MutableUnliftedArray (MutableArrayArray# s) - deriving (Typeable) - --- | Classifies the types that are able to be stored in 'UnliftedArray' and --- 'MutableUnliftedArray'. These should be types that are just liftings of the --- unlifted pointer types, so that their internal contents can be safely coerced --- into an 'ArrayArray#'. -class PrimUnlifted a where - toArrayArray# :: a -> ArrayArray# - fromArrayArray# :: ArrayArray# -> a - -instance PrimUnlifted (UnliftedArray e) where - toArrayArray# (UnliftedArray aa#) = aa# - fromArrayArray# aa# = UnliftedArray aa# - -instance PrimUnlifted (MutableUnliftedArray s e) where - toArrayArray# (MutableUnliftedArray maa#) = unsafeCoerce# maa# - fromArrayArray# aa# = MutableUnliftedArray (unsafeCoerce# aa#) - -instance PrimUnlifted (Array a) where - toArrayArray# (A.Array a#) = unsafeCoerce# a# - fromArrayArray# aa# = A.Array (unsafeCoerce# aa#) - -instance PrimUnlifted (A.MutableArray s a) where - toArrayArray# (A.MutableArray ma#) = unsafeCoerce# ma# - fromArrayArray# aa# = A.MutableArray (unsafeCoerce# aa#) - -instance PrimUnlifted ByteArray where - toArrayArray# (BA.ByteArray ba#) = unsafeCoerce# ba# - fromArrayArray# aa# = BA.ByteArray (unsafeCoerce# aa#) - -instance PrimUnlifted (BA.MutableByteArray s) where - toArrayArray# (BA.MutableByteArray mba#) = unsafeCoerce# mba# - fromArrayArray# aa# = BA.MutableByteArray (unsafeCoerce# aa#) - --- | @since 0.6.4.0 -instance PrimUnlifted (PA.PrimArray a) where - toArrayArray# (PA.PrimArray ba#) = unsafeCoerce# ba# - fromArrayArray# aa# = PA.PrimArray (unsafeCoerce# aa#) - --- | @since 0.6.4.0 -instance PrimUnlifted (PA.MutablePrimArray s a) where - toArrayArray# (PA.MutablePrimArray mba#) = unsafeCoerce# mba# - fromArrayArray# aa# = PA.MutablePrimArray (unsafeCoerce# aa#) - -instance PrimUnlifted (SA.SmallArray a) where - toArrayArray# (SA.SmallArray sa#) = unsafeCoerce# sa# - fromArrayArray# aa# = SA.SmallArray (unsafeCoerce# aa#) - -instance PrimUnlifted (SA.SmallMutableArray s a) where - toArrayArray# (SA.SmallMutableArray sma#) = unsafeCoerce# sma# - fromArrayArray# aa# = SA.SmallMutableArray (unsafeCoerce# aa#) - -instance PrimUnlifted (MV.MutVar s a) where - toArrayArray# (MV.MutVar mv#) = unsafeCoerce# mv# - fromArrayArray# aa# = MV.MutVar (unsafeCoerce# aa#) - --- | @since 0.6.4.0 -instance PrimUnlifted (GM.MVar a) where - toArrayArray# (GM.MVar mv#) = unsafeCoerce# mv# - fromArrayArray# mv# = GM.MVar (unsafeCoerce# mv#) - --- | @since 0.6.4.0 -instance PrimUnlifted (GC.TVar a) where - toArrayArray# (GC.TVar tv#) = unsafeCoerce# tv# - fromArrayArray# tv# = GC.TVar (unsafeCoerce# tv#) - --- | @since 0.6.4.0 -instance PrimUnlifted (GSP.StablePtr a) where - toArrayArray# (GSP.StablePtr tv#) = unsafeCoerce# tv# - fromArrayArray# tv# = GSP.StablePtr (unsafeCoerce# tv#) - --- | @since 0.6.4.0 -instance PrimUnlifted (GW.Weak a) where - toArrayArray# (GW.Weak tv#) = unsafeCoerce# tv# - fromArrayArray# tv# = GW.Weak (unsafeCoerce# tv#) - --- | @since 0.6.4.0 -instance PrimUnlifted GCS.ThreadId where - toArrayArray# (GCS.ThreadId tv#) = unsafeCoerce# tv# - fromArrayArray# tv# = GCS.ThreadId (unsafeCoerce# tv#) - -die :: String -> String -> a -die fun problem = error $ "Data.Primitive.UnliftedArray." ++ fun ++ ": " ++ problem - --- | Creates a new 'MutableUnliftedArray'. This function is unsafe because it --- initializes all elements of the array as pointers to the array itself. Attempting --- to read one of these elements before writing to it is in effect an unsafe --- coercion from the @MutableUnliftedArray s a@ to the element type. -unsafeNewUnliftedArray - :: (PrimMonad m) - => Int -- ^ size - -> m (MutableUnliftedArray (PrimState m) a) -unsafeNewUnliftedArray (I# i#) = primitive $ \s -> case newArrayArray# i# s of - (# s', maa# #) -> (# s', MutableUnliftedArray maa# #) -{-# inline unsafeNewUnliftedArray #-} - --- | Sets all the positions in an unlifted array to the designated value. -setUnliftedArray - :: (PrimMonad m, PrimUnlifted a) - => MutableUnliftedArray (PrimState m) a -- ^ destination - -> a -- ^ value to fill with - -> m () -setUnliftedArray mua v = loop $ sizeofMutableUnliftedArray mua - 1 - where - loop i | i < 0 = return () - | otherwise = writeUnliftedArray mua i v >> loop (i-1) -{-# inline setUnliftedArray #-} - --- | Creates a new 'MutableUnliftedArray' with the specified value as initial --- contents. This is slower than 'unsafeNewUnliftedArray', but safer. -newUnliftedArray - :: (PrimMonad m, PrimUnlifted a) - => Int -- ^ size - -> a -- ^ initial value - -> m (MutableUnliftedArray (PrimState m) a) -newUnliftedArray len v = - unsafeNewUnliftedArray len >>= \mua -> setUnliftedArray mua v >> return mua -{-# inline newUnliftedArray #-} - --- | Yields the length of an 'UnliftedArray'. -sizeofUnliftedArray :: UnliftedArray e -> Int -sizeofUnliftedArray (UnliftedArray aa#) = I# (sizeofArrayArray# aa#) -{-# inline sizeofUnliftedArray #-} - --- | Yields the length of a 'MutableUnliftedArray'. -sizeofMutableUnliftedArray :: MutableUnliftedArray s e -> Int -sizeofMutableUnliftedArray (MutableUnliftedArray maa#) - = I# (sizeofMutableArrayArray# maa#) -{-# inline sizeofMutableUnliftedArray #-} - --- Internal indexing function. --- --- Note: ArrayArray# is strictly evaluated, so this should have similar --- consequences to indexArray#, where matching on the unboxed single causes the --- array access to happen. -indexUnliftedArrayU - :: PrimUnlifted a - => UnliftedArray a - -> Int - -> (# a #) -indexUnliftedArrayU (UnliftedArray src#) (I# i#) - = case indexArrayArrayArray# src# i# of - aa# -> (# fromArrayArray# aa# #) -{-# inline indexUnliftedArrayU #-} - --- | Gets the value at the specified position of an 'UnliftedArray'. -indexUnliftedArray - :: PrimUnlifted a - => UnliftedArray a -- ^ source - -> Int -- ^ index - -> a -indexUnliftedArray ua i - = case indexUnliftedArrayU ua i of (# v #) -> v -{-# inline indexUnliftedArray #-} - --- | Gets the value at the specified position of an 'UnliftedArray'. --- The purpose of the 'Monad' is to allow for being eager in the --- 'UnliftedArray' value without having to introduce a data dependency --- directly on the result value. --- --- It should be noted that this is not as much of a problem as with a normal --- 'Array', because elements of an 'UnliftedArray' are guaranteed to not --- be exceptional. This function is provided in case it is more desirable --- than being strict in the result value. -indexUnliftedArrayM - :: (PrimUnlifted a, Monad m) - => UnliftedArray a -- ^ source - -> Int -- ^ index - -> m a -indexUnliftedArrayM ua i - = case indexUnliftedArrayU ua i of - (# v #) -> return v -{-# inline indexUnliftedArrayM #-} - --- | Gets the value at the specified position of a 'MutableUnliftedArray'. -readUnliftedArray - :: (PrimMonad m, PrimUnlifted a) - => MutableUnliftedArray (PrimState m) a -- ^ source - -> Int -- ^ index - -> m a -readUnliftedArray (MutableUnliftedArray maa#) (I# i#) - = primitive $ \s -> case readArrayArrayArray# maa# i# s of - (# s', aa# #) -> (# s', fromArrayArray# aa# #) -{-# inline readUnliftedArray #-} - --- | Sets the value at the specified position of a 'MutableUnliftedArray'. -writeUnliftedArray - :: (PrimMonad m, PrimUnlifted a) - => MutableUnliftedArray (PrimState m) a -- ^ destination - -> Int -- ^ index - -> a -- ^ value - -> m () -writeUnliftedArray (MutableUnliftedArray maa#) (I# i#) a - = primitive_ (writeArrayArrayArray# maa# i# (toArrayArray# a)) -{-# inline writeUnliftedArray #-} - --- | Freezes a 'MutableUnliftedArray', yielding an 'UnliftedArray'. This simply --- marks the array as frozen in place, so it should only be used when no further --- modifications to the mutable array will be performed. -unsafeFreezeUnliftedArray - :: (PrimMonad m) - => MutableUnliftedArray (PrimState m) a - -> m (UnliftedArray a) -unsafeFreezeUnliftedArray (MutableUnliftedArray maa#) - = primitive $ \s -> case unsafeFreezeArrayArray# maa# s of - (# s', aa# #) -> (# s', UnliftedArray aa# #) -{-# inline unsafeFreezeUnliftedArray #-} - --- | Determines whether two 'MutableUnliftedArray' values are the same. This is --- object/pointer identity, not based on the contents. -sameMutableUnliftedArray - :: MutableUnliftedArray s a - -> MutableUnliftedArray s a - -> Bool -sameMutableUnliftedArray (MutableUnliftedArray maa1#) (MutableUnliftedArray maa2#) - = isTrue# (sameMutableArrayArray# maa1# maa2#) -{-# inline sameMutableUnliftedArray #-} - --- | Copies the contents of an immutable array into a mutable array. -copyUnliftedArray - :: (PrimMonad m) - => MutableUnliftedArray (PrimState m) a -- ^ destination - -> Int -- ^ offset into destination - -> UnliftedArray a -- ^ source - -> Int -- ^ offset into source - -> Int -- ^ number of elements to copy - -> m () -copyUnliftedArray - (MutableUnliftedArray dst) (I# doff) - (UnliftedArray src) (I# soff) (I# ln) = - primitive_ $ copyArrayArray# src soff dst doff ln -{-# inline copyUnliftedArray #-} - --- | Copies the contents of one mutable array into another. -copyMutableUnliftedArray - :: (PrimMonad m) - => MutableUnliftedArray (PrimState m) a -- ^ destination - -> Int -- ^ offset into destination - -> MutableUnliftedArray (PrimState m) a -- ^ source - -> Int -- ^ offset into source - -> Int -- ^ number of elements to copy - -> m () -copyMutableUnliftedArray - (MutableUnliftedArray dst) (I# doff) - (MutableUnliftedArray src) (I# soff) (I# ln) = - primitive_ $ copyMutableArrayArray# src soff dst doff ln -{-# inline copyMutableUnliftedArray #-} - --- | Freezes a portion of a 'MutableUnliftedArray', yielding an 'UnliftedArray'. --- This operation is safe, in that it copies the frozen portion, and the --- existing mutable array may still be used afterward. -freezeUnliftedArray - :: (PrimMonad m) - => MutableUnliftedArray (PrimState m) a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (UnliftedArray a) -freezeUnliftedArray src off len = do - dst <- unsafeNewUnliftedArray len - copyMutableUnliftedArray dst 0 src off len - unsafeFreezeUnliftedArray dst -{-# inline freezeUnliftedArray #-} - --- | Thaws a portion of an 'UnliftedArray', yielding a 'MutableUnliftedArray'. --- This copies the thawed portion, so mutations will not affect the original --- array. -thawUnliftedArray - :: (PrimMonad m) - => UnliftedArray a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (MutableUnliftedArray (PrimState m) a) -thawUnliftedArray src off len = do - dst <- unsafeNewUnliftedArray len - copyUnliftedArray dst 0 src off len - return dst -{-# inline thawUnliftedArray #-} - -#if !MIN_VERSION_base(4,9,0) -unsafeCreateUnliftedArray - :: Int - -> (forall s. MutableUnliftedArray s a -> ST s ()) - -> UnliftedArray a -unsafeCreateUnliftedArray 0 _ = emptyUnliftedArray -unsafeCreateUnliftedArray n f = runUnliftedArray $ do - mary <- unsafeNewUnliftedArray n - f mary - pure mary - --- | Execute a stateful computation and freeze the resulting array. -runUnliftedArray - :: (forall s. ST s (MutableUnliftedArray s a)) - -> UnliftedArray a -runUnliftedArray m = runST $ m >>= unsafeFreezeUnliftedArray - -#else /* Below, runRW# is available. */ - --- This low-level business is designed to work with GHC's worker-wrapper --- transformation. A lot of the time, we don't actually need an Array --- constructor. By putting it on the outside, and being careful about --- how we special-case the empty array, we can make GHC smarter about this. --- The only downside is that separately created 0-length arrays won't share --- their Array constructors, although they'll share their underlying --- Array#s. -unsafeCreateUnliftedArray - :: Int - -> (forall s. MutableUnliftedArray s a -> ST s ()) - -> UnliftedArray a -unsafeCreateUnliftedArray 0 _ = UnliftedArray (emptyArrayArray# (# #)) -unsafeCreateUnliftedArray n f = runUnliftedArray $ do - mary <- unsafeNewUnliftedArray n - f mary - pure mary - --- | Execute a stateful computation and freeze the resulting array. -runUnliftedArray - :: (forall s. ST s (MutableUnliftedArray s a)) - -> UnliftedArray a -runUnliftedArray m = UnliftedArray (runUnliftedArray# m) - -runUnliftedArray# - :: (forall s. ST s (MutableUnliftedArray s a)) - -> ArrayArray# -runUnliftedArray# m = case runRW# $ \s -> - case unST m s of { (# s', MutableUnliftedArray mary# #) -> - unsafeFreezeArrayArray# mary# s'} of (# _, ary# #) -> ary# - -unST :: ST s a -> State# s -> (# State# s, a #) -unST (GHCST.ST f) = f - -emptyArrayArray# :: (# #) -> ArrayArray# -emptyArrayArray# _ = case emptyUnliftedArray of UnliftedArray ar -> ar -{-# NOINLINE emptyArrayArray# #-} -#endif - --- | Creates a copy of a portion of an 'UnliftedArray' -cloneUnliftedArray - :: UnliftedArray a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> UnliftedArray a -cloneUnliftedArray src off len = - runUnliftedArray (thawUnliftedArray src off len) -{-# inline cloneUnliftedArray #-} - --- | Creates a new 'MutableUnliftedArray' containing a copy of a portion of --- another mutable array. -cloneMutableUnliftedArray - :: (PrimMonad m) - => MutableUnliftedArray (PrimState m) a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (MutableUnliftedArray (PrimState m) a) -cloneMutableUnliftedArray src off len = do - dst <- unsafeNewUnliftedArray len - copyMutableUnliftedArray dst 0 src off len - return dst -{-# inline cloneMutableUnliftedArray #-} - -instance Eq (MutableUnliftedArray s a) where - (==) = sameMutableUnliftedArray - -instance (Eq a, PrimUnlifted a) => Eq (UnliftedArray a) where - aa1 == aa2 = sizeofUnliftedArray aa1 == sizeofUnliftedArray aa2 - && loop (sizeofUnliftedArray aa1 - 1) - where - loop i - | i < 0 = True - | otherwise = indexUnliftedArray aa1 i == indexUnliftedArray aa2 i && loop (i-1) - --- | Lexicographic ordering. Subject to change between major versions. --- --- @since 0.6.4.0 -instance (Ord a, PrimUnlifted a) => Ord (UnliftedArray a) where - compare a1 a2 = loop 0 - where - mn = sizeofUnliftedArray a1 `min` sizeofUnliftedArray a2 - loop i - | i < mn - , x1 <- indexUnliftedArray a1 i - , x2 <- indexUnliftedArray a2 i - = compare x1 x2 `mappend` loop (i+1) - | otherwise = compare (sizeofUnliftedArray a1) (sizeofUnliftedArray a2) - --- | @since 0.6.4.0 -instance (Show a, PrimUnlifted a) => Show (UnliftedArray a) where - showsPrec p a = showParen (p > 10) $ - showString "fromListN " . shows (sizeofUnliftedArray a) . showString " " - . shows (unliftedArrayToList a) - -#if MIN_VERSION_base(4,9,0) --- | @since 0.6.4.0 -instance PrimUnlifted a => Semigroup (UnliftedArray a) where - (<>) = concatUnliftedArray -#endif - --- | @since 0.6.4.0 -instance PrimUnlifted a => Monoid (UnliftedArray a) where - mempty = emptyUnliftedArray -#if !(MIN_VERSION_base(4,11,0)) - mappend = concatUnliftedArray -#endif - -emptyUnliftedArray :: UnliftedArray a -emptyUnliftedArray = runUnliftedArray (unsafeNewUnliftedArray 0) -{-# NOINLINE emptyUnliftedArray #-} - -concatUnliftedArray :: UnliftedArray a -> UnliftedArray a -> UnliftedArray a -concatUnliftedArray x y = unsafeCreateUnliftedArray (sizeofUnliftedArray x + sizeofUnliftedArray y) $ \m -> do - copyUnliftedArray m 0 x 0 (sizeofUnliftedArray x) - copyUnliftedArray m (sizeofUnliftedArray x) y 0 (sizeofUnliftedArray y) - --- | Lazy right-associated fold over the elements of an 'UnliftedArray'. -{-# INLINE foldrUnliftedArray #-} -foldrUnliftedArray :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b -foldrUnliftedArray f z arr = go 0 - where - !sz = sizeofUnliftedArray arr - go !i - | sz > i = f (indexUnliftedArray arr i) (go (i+1)) - | otherwise = z - --- | Strict right-associated fold over the elements of an 'UnliftedArray. -{-# INLINE foldrUnliftedArray' #-} -foldrUnliftedArray' :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b -foldrUnliftedArray' f z0 arr = go (sizeofUnliftedArray arr - 1) z0 - where - go !i !acc - | i < 0 = acc - | otherwise = go (i - 1) (f (indexUnliftedArray arr i) acc) - --- | Lazy left-associated fold over the elements of an 'UnliftedArray'. -{-# INLINE foldlUnliftedArray #-} -foldlUnliftedArray :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b -foldlUnliftedArray f z arr = go (sizeofUnliftedArray arr - 1) - where - go !i - | i < 0 = z - | otherwise = f (go (i - 1)) (indexUnliftedArray arr i) - --- | Strict left-associated fold over the elements of an 'UnliftedArray'. -{-# INLINE foldlUnliftedArray' #-} -foldlUnliftedArray' :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b -foldlUnliftedArray' f z0 arr = go 0 z0 - where - !sz = sizeofUnliftedArray arr - go !i !acc - | i < sz = go (i + 1) (f acc (indexUnliftedArray arr i)) - | otherwise = acc - --- | Map over the elements of an 'UnliftedArray'. -{-# INLINE mapUnliftedArray #-} -mapUnliftedArray :: (PrimUnlifted a, PrimUnlifted b) - => (a -> b) - -> UnliftedArray a - -> UnliftedArray b -mapUnliftedArray f arr = unsafeCreateUnliftedArray sz $ \marr -> do - let go !ix = if ix < sz - then do - let b = f (indexUnliftedArray arr ix) - writeUnliftedArray marr ix b - go (ix + 1) - else return () - go 0 - where - !sz = sizeofUnliftedArray arr - --- | Convert the unlifted array to a list. -{-# INLINE unliftedArrayToList #-} -unliftedArrayToList :: PrimUnlifted a => UnliftedArray a -> [a] -unliftedArrayToList xs = build (\c n -> foldrUnliftedArray c n xs) - -unliftedArrayFromList :: PrimUnlifted a => [a] -> UnliftedArray a -unliftedArrayFromList xs = unliftedArrayFromListN (L.length xs) xs - -unliftedArrayFromListN :: forall a. PrimUnlifted a => Int -> [a] -> UnliftedArray a -unliftedArrayFromListN len vs = unsafeCreateUnliftedArray len run where - run :: forall s. MutableUnliftedArray s a -> ST s () - run arr = do - let go :: [a] -> Int -> ST s () - go [] !ix = if ix == len - -- The size check is mandatory since failure to initialize all elements - -- introduces the possibility of a segfault happening when someone attempts - -- to read the unitialized element. See the docs for unsafeNewUnliftedArray. - then return () - else die "unliftedArrayFromListN" "list length less than specified size" - go (a : as) !ix = if ix < len - then do - writeUnliftedArray arr ix a - go as (ix + 1) - else die "unliftedArrayFromListN" "list length greater than specified size" - go vs 0 - - -#if MIN_VERSION_base(4,7,0) --- | @since 0.6.4.0 -instance PrimUnlifted a => E.IsList (UnliftedArray a) where - type Item (UnliftedArray a) = a - fromList = unliftedArrayFromList - fromListN = unliftedArrayFromListN - toList = unliftedArrayToList -#endif - |