diff options
Diffstat (limited to 'third_party/bazel/rules_haskell/examples/primitive/Data')
14 files changed, 5175 insertions, 0 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 new file mode 100644 index 0000000000..db545ed815 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive.hs @@ -0,0 +1,85 @@ +{-# 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 new file mode 100644 index 0000000000..2ff25005c6 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Addr.hs @@ -0,0 +1,133 @@ +{-# 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 new file mode 100644 index 0000000000..13352f6cb4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Array.hs @@ -0,0 +1,822 @@ +{-# 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 new file mode 100644 index 0000000000..527205330b --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/ByteArray.hs @@ -0,0 +1,549 @@ +{-# 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 new file mode 100644 index 0000000000..f6b8016ad9 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Compat.hs @@ -0,0 +1,38 @@ +{-# 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 new file mode 100644 index 0000000000..091e11f5d6 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Operations.hs @@ -0,0 +1,90 @@ +{-# 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 new file mode 100644 index 0000000000..3c7bfd1fa0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs @@ -0,0 +1,155 @@ +{-# 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 new file mode 100644 index 0000000000..d36c252364 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MachDeps.hs @@ -0,0 +1,123 @@ +{-# 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 new file mode 100644 index 0000000000..f707bfb630 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MutVar.hs @@ -0,0 +1,86 @@ +{-# 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 new file mode 100644 index 0000000000..33d81c2092 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/PrimArray.hs @@ -0,0 +1,969 @@ +{-# 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 new file mode 100644 index 0000000000..d93ae9ac11 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Ptr.hs @@ -0,0 +1,125 @@ +{-# 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 new file mode 100644 index 0000000000..3a50cf2183 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/SmallArray.hs @@ -0,0 +1,967 @@ +{-# 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 new file mode 100644 index 0000000000..fd36ea0c94 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Types.hs @@ -0,0 +1,395 @@ +{-# 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 new file mode 100644 index 0000000000..75a4847364 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/UnliftedArray.hs @@ -0,0 +1,638 @@ +{-# 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 + |