diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,17 @@ # Revision history for Z-Data +## 1.0.0.0 -- 2021-07-05 + +* Clean up various `RULES` and `INLINE` pragmas, improve building time a little. +* Simplify `Z.Data.PrimRef` to use `PrimMonad`. +* Add `encodeXXX/encodeXXXLE/encodeXXXBE`(where `XXX` is a primitive type) to `Z.Data.Builder`. +* Add `check-array-bound` build flag to enable bound check in `Z.Data.Array` module, `Z.Data.Array.Checked` is removed. +* Add `concatR` to `Z.Data.Vector` and `Z.Data.Text`, which is useful to concat the result of an accumulator style recursive function. +* Improve date builder and parser by introducing faster common case path. + ## 0.9.0.0 -- 2021-07-01 -* Add `decodeXXX/deocodeXXXLE/deodeXXXBE`(where `XXX` is a primitive type) to `Z.Data.Parser`. +* Add `decodeXXX/deocodeXXXLE/decodeXXXBE`(where `XXX` is a primitive type) to `Z.Data.Parser`. * Rename `replicateMVec/traveseVec/traveseVec_` tp `replicateM/travese/travese_`, fix related `PrimMonad` rules not firing issue. * Add a faster `sciToDouble` based on https://github.com/lemire/fast_double_parser, improve `double/double'` parser. diff --git a/Z-Data.cabal b/Z-Data.cabal --- a/Z-Data.cabal +++ b/Z-Data.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: Z-Data -version: 0.9.0.0 +version: 1.0.0.0 synopsis: Array, vector and text description: This package provides array, slice and text operations license: BSD-3-Clause @@ -105,6 +105,13 @@ type: git location: git://github.com/haskell-Z/z-data.git +flag check-array-bound + description: + Add bound check to operations in Z.Data.Array module. + + default: False + manual: True + flag integer-simple description: Use the [simple integer library](http://hackage.haskell.org/package/integer-simple) @@ -131,8 +138,8 @@ library exposed-modules: Z.Data.Array + Z.Data.Array.Base Z.Data.Array.Cast - Z.Data.Array.Checked Z.Data.Array.QQ Z.Data.Array.Unaligned Z.Data.Array.UnliftedArray @@ -154,8 +161,6 @@ Z.Data.Parser.Numeric Z.Data.Parser.Time Z.Data.PrimRef - Z.Data.PrimRef.PrimIORef - Z.Data.PrimRef.PrimSTRef Z.Data.Text Z.Data.Text.Base Z.Data.Text.Extra @@ -278,6 +283,8 @@ build-tool-depends: hsc2hs:hsc2hs -any cc-options: -std=c11 -Wall -Wno-pointer-to-int-cast -Wno-unused-function + -- currently it's ignored, see https://github.com/haskell/cabal/pull/6226 + -- we work around this issue using Setup.hs cxx-options: -std=c++11 if os(osx) cxx-options: -stdlib=libc++ @@ -315,9 +322,10 @@ else cpp-options: -DINTEGER_GMP build-depends: integer-gmp >=0.2 && <1.2 - -- currently it's ignored, see https://github.com/haskell/cabal/pull/6226 - -- we work around this issue using Setup.hs + if flag(check-array-bound) + cpp-options: -DCHECK_ARRAY_BOUND + ghc-options: -Wall -Wno-unticked-promoted-constructors -Wno-incomplete-patterns @@ -414,3 +422,6 @@ else cpp-options: -DINTEGER_GMP build-depends: integer-gmp >=0.2 && <1.2 + + if flag(check-array-bound) + cpp-options: -DCHECK_ARRAY_BOUND diff --git a/Z/Data/Array.hs b/Z/Data/Array.hs --- a/Z/Data/Array.hs +++ b/Z/Data/Array.hs @@ -1,689 +1,503 @@ {-| -Module : Z.Data.Array -Description : Fast boxed and unboxed arrays -Copyright : (c) Dong Han, 2017 -License : BSD -Maintainer : winterland1989@gmail.com -Stability : experimental -Portability : non-portable - -Unified unboxed and boxed array operations using type family. - -NONE of the operations are bound checked, if you need checked operations please use "Z.Data.Array.Checked" instead. -It exports the exact same APIs ,so it requires no extra effort to switch between them. - -Some mnemonics: - - * 'newArr' and 'newArrWith' return mutable array. - 'readArr' and 'writeArr' perform read and write actions on mutable arrays. - 'setArr' fills the elements with offset and length. - - * 'indexArr' can only work on immutable Array. - Use 'indexArr'' to avoid thunks building up in the heap. - - * The order of arguements of 'copyArr', 'copyMutableArr' and 'moveArr' are always target and its offset - come first, and source and source offset follow, copying length comes last. --} - -module Z.Data.Array ( - -- * Arr typeclass - Arr(..) - , emptyArr, singletonArr, doubletonArr - , modifyIndexArr, insertIndexArr, deleteIndexArr - , RealWorld - -- * Boxed array type - , Array(..) - , MutableArray(..) - , SmallArray(..) - , SmallMutableArray(..) - , uninitialized - -- * Primitive array type - , PrimArray(..) - , MutablePrimArray(..) - , Prim(..) - -- * Primitive array operations - , newPinnedPrimArray, newAlignedPinnedPrimArray - , copyPrimArrayToPtr, copyMutablePrimArrayToPtr, copyPtrToMutablePrimArray - , primArrayContents, mutablePrimArrayContents, withPrimArrayContents, withMutablePrimArrayContents - , isPrimArrayPinned, isMutablePrimArrayPinned - -- * Unlifted array type - , UnliftedArray(..) - , MutableUnliftedArray(..) - , PrimUnlifted(..) - -- * The 'ArrayException' type - , ArrayException(..) - -- * Cast between primitive arrays - , Cast - , castArray - , castMutableArray - -- * Re-export - , sizeOf - ) where - -import Control.Exception (ArrayException (..), throw) -import Control.Monad -import Control.Monad.Primitive -import Control.Monad.ST -import Data.Kind (Type) -import Data.Primitive.Array -import Data.Primitive.ByteArray -import Data.Primitive.PrimArray -import Data.Primitive.Ptr (copyPtrToMutablePrimArray) -import Data.Primitive.SmallArray -import Data.Primitive.Types -import GHC.Exts -import Z.Data.Array.Cast -import Z.Data.Array.UnliftedArray - - --- | Bottom value (@throw ('UndefinedElement' 'Data.Array.uninitialized')@) --- for new boxed array('Array', 'SmallArray'..) initialization. --- -uninitialized :: a -uninitialized = throw (UndefinedElement "Data.Array.uninitialized") - - --- | The typeclass that unifies box & unboxed and mutable & immutable array operations. --- --- Most of these functions simply wrap their primitive counterpart. --- When there are no primitive ones, we fulfilled the semantic with other operations. --- --- One exception is 'shrinkMutableArr' which only performs closure resizing on 'PrimArray', because --- currently, RTS only supports that. 'shrinkMutableArr' won't do anything on other array types. --- --- It's reasonable to trust GHC to specialize & inline these polymorphic functions. --- They are used across this package and perform identically to their monomorphic counterpart. --- -class Arr (arr :: Type -> Type) a where - - - -- | The mutable version of this array type. - -- - type MArr arr = (mar :: Type -> Type -> Type) | mar -> arr - - - -- | Make a new array with a given size. - -- - -- For boxed arrays, all elements are 'uninitialized' , which shall not be accessed. - -- For primitive arrays, elements are just random garbage. - newArr :: (PrimMonad m, PrimState m ~ s) => Int -> m (MArr arr s a) - - - -- | Make a new array and fill it with an initial value. - newArrWith :: (PrimMonad m, PrimState m ~ s) => Int -> a -> m (MArr arr s a) - - - -- | Read from specified index of mutable array in a primitive monad. - readArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m a - - - -- | Write to specified index of mutable array in a primitive monad. - writeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> a -> m () - - - -- | Fill the mutable array with a given value. - setArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> a -> m () - - - -- | Read from the specified index of an immutable array. It's pure and often - -- results in an indexing thunk for lifted arrays, use 'indexArr\'' or 'indexArrM' to avoid this. - indexArr :: arr a -> Int -> a - - - -- | Read from the specified index of an immutable array. The result is packaged into an unboxed unary tuple; the result itself is not yet evaluated. - -- Pattern matching on the tuple forces the indexing of the array to happen but does not evaluate the element itself. - -- Evaluating the thunk prevents additional thunks from building up on the heap. - -- Avoiding these thunks, in turn, reduces references to the argument array, allowing it to be garbage collected more promptly. - indexArr' :: arr a -> Int -> (# a #) - - - -- | 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. - -- - -- /Note:/ this function does not do bounds checking. - indexArrM :: (Monad m) => arr a -> Int -> m a - - - -- | 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. - freezeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> m (arr 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. - thawArr :: (PrimMonad m, PrimState m ~ s) => arr a -> Int -> Int -> m (MArr arr s a) - - - -- | Convert a mutable array to an immutable one without copying. - -- The array should not be modified after the conversion. - unsafeFreezeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> m (arr a) - - - - -- | Convert a mutable array to an immutable one without copying. The - -- array should not be modified after the conversion. - unsafeThawArr :: (PrimMonad m, PrimState m ~ s) => arr a -> m (MArr arr s a) - - - -- | Copy a slice of an immutable array to a mutable array at given offset. - copyArr :: (PrimMonad m, PrimState m ~ s) - => MArr arr s a -- ^ target - -> Int -- ^ offset into target array - -> arr a -- ^ source - -> Int -- ^ offset into source array - -> Int -- ^ number of elements to copy - -> m () - - - -- | Copy a slice of a mutable array to another mutable array at given offset. - -- The two mutable arrays must not be the same. - copyMutableArr :: (PrimMonad m, PrimState m ~ s) - => MArr arr s a -- ^ target - -> Int -- ^ offset into target array - -> MArr arr s a -- ^ source - -> Int -- ^ offset into source array - -> Int -- ^ number of elements to copy - -> m () - - - -- | Copy a slice of a mutable array to a mutable array at given offset. - -- The two mutable arrays can be the same. - moveArr :: (PrimMonad m, PrimState m ~ s) - => MArr arr s a -- ^ target - -> Int -- ^ offset into target array - -> MArr arr s a -- ^ source - -> Int -- ^ offset into source array - -> Int -- ^ number of elements to copy - -> m () - - - -- | Create an immutable copy with the given subrange of the original array. - cloneArr :: arr a -> Int -> Int -> arr a - - - -- | Create a mutable copy the given subrange of the original array. - cloneMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> m (MArr arr s a) - - - -- | Resize a mutable array to the given size. - resizeMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m (MArr arr s a) - - - -- | Shrink a mutable array to the given size. This operation only works on primitive arrays. - -- For some array types, this is a no-op, e.g. 'sizeOfMutableArr' will not change. - shrinkMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m () - - - -- | Is two mutable array are reference equal. - sameMutableArr :: MArr arr s a -> MArr arr s a -> Bool - - - -- | Size of the immutable array. - sizeofArr :: arr a -> Int - - - -- | Size of the mutable array. - sizeofMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> m Int - - - -- | Check whether the two immutable arrays refer to the same memory block - -- - -- Note that the result of 'sameArr' may change depending on compiler's optimizations, for example, - -- @let arr = runST ... in arr `sameArr` arr@ may return false if compiler decides to - -- inline it. - -- - -- See https://ghc.haskell.org/trac/ghc/ticket/13908 for more context. - -- - sameArr :: arr a -> arr a -> Bool - -instance Arr Array a where - type MArr Array = MutableArray - newArr n = newArray n uninitialized - {-# INLINE newArr #-} - newArrWith = newArray - {-# INLINE newArrWith #-} - readArr = readArray - {-# INLINE readArr #-} - writeArr = writeArray - {-# INLINE writeArr #-} - setArr marr s l x = go s - where - !sl = s + l - go !i | i >= sl = return () - | otherwise = writeArray marr i x >> go (i+1) - {-# INLINE setArr #-} - indexArr = indexArray - {-# INLINE indexArr #-} - indexArr' (Array arr#) (I# i#) = indexArray# arr# i# - {-# INLINE indexArr' #-} - indexArrM = indexArrayM - {-# INLINE indexArrM #-} - freezeArr = freezeArray - {-# INLINE freezeArr #-} - thawArr = thawArray - {-# INLINE thawArr #-} - unsafeFreezeArr = unsafeFreezeArray - {-# INLINE unsafeFreezeArr #-} - unsafeThawArr = unsafeThawArray - {-# INLINE unsafeThawArr #-} - - copyArr = copyArray - {-# INLINE copyArr #-} - copyMutableArr = copyMutableArray - {-# INLINE copyMutableArr #-} - - moveArr marr1 s1 marr2 s2 l - | l <= 0 = return () - | sameMutableArray marr1 marr2 = - case compare s1 s2 of - LT -> - let !d = s2 - s1 - !s2l = s2 + l - go !i | i >= s2l = return () - | otherwise = do x <- readArray marr2 i - writeArray marr1 (i-d) x - go (i+1) - in go s2 - - EQ -> return () - - GT -> - let !d = s1 - s2 - go !i | i < s2 = return () - | otherwise = do x <- readArray marr2 i - writeArray marr1 (i+d) x - go (i-1) - in go (s2+l-1) - | otherwise = copyMutableArray marr1 s1 marr2 s2 l - {-# INLINE moveArr #-} - - cloneArr = cloneArray - {-# INLINE cloneArr #-} - cloneMutableArr = cloneMutableArray - {-# INLINE cloneMutableArr #-} - - resizeMutableArr marr n = do - marr' <- newArray n uninitialized - copyMutableArray marr' 0 marr 0 (sizeofMutableArray marr) - return marr' - {-# INLINE resizeMutableArr #-} - shrinkMutableArr _ _ = return () - {-# INLINE shrinkMutableArr #-} - - sameMutableArr = sameMutableArray - {-# INLINE sameMutableArr #-} - sizeofArr = sizeofArray - {-# INLINE sizeofArr #-} - sizeofMutableArr = return . sizeofMutableArray - {-# INLINE sizeofMutableArr #-} - - sameArr (Array arr1#) (Array arr2#) = isTrue# ( - sameMutableArray# (unsafeCoerce# arr1#) (unsafeCoerce# arr2#)) - {-# INLINE sameArr #-} - -instance Arr SmallArray a where - type MArr SmallArray = SmallMutableArray - newArr n = newSmallArray n uninitialized - {-# INLINE newArr #-} - newArrWith = newSmallArray - {-# INLINE newArrWith #-} - readArr = readSmallArray - {-# INLINE readArr #-} - writeArr = writeSmallArray - {-# INLINE writeArr #-} - setArr marr s l x = go s - where - !sl = s + l - go !i | i >= sl = return () - | otherwise = writeSmallArray marr i x >> go (i+1) - {-# INLINE setArr #-} - indexArr = indexSmallArray - {-# INLINE indexArr #-} - indexArr' (SmallArray arr#) (I# i#) = indexSmallArray# arr# i# - {-# INLINE indexArr' #-} - indexArrM = indexSmallArrayM - {-# INLINE indexArrM #-} - freezeArr = freezeSmallArray - {-# INLINE freezeArr #-} - thawArr = thawSmallArray - {-# INLINE thawArr #-} - unsafeFreezeArr = unsafeFreezeSmallArray - {-# INLINE unsafeFreezeArr #-} - unsafeThawArr = unsafeThawSmallArray - {-# INLINE unsafeThawArr #-} - - copyArr = copySmallArray - {-# INLINE copyArr #-} - copyMutableArr = copySmallMutableArray - {-# INLINE copyMutableArr #-} - - moveArr marr1 s1 marr2 s2 l - | l <= 0 = return () - | sameMutableArr marr1 marr2 = - case compare s1 s2 of - LT -> - let !d = s2 - s1 - !s2l = s2 + l - go !i | i >= s2l = return () - | otherwise = do x <- readSmallArray marr2 i - writeSmallArray marr1 (i-d) x - go (i+1) - in go s2 - - EQ -> return () - - GT -> - let !d = s1 - s2 - go !i | i < s2 = return () - | otherwise = do x <- readSmallArray marr2 i - writeSmallArray marr1 (i+d) x - go (i-1) - in go (s2+l-1) - | otherwise = copySmallMutableArray marr1 s1 marr2 s2 l - {-# INLINE moveArr #-} - - cloneArr = cloneSmallArray - {-# INLINE cloneArr #-} - cloneMutableArr = cloneSmallMutableArray - {-# INLINE cloneMutableArr #-} - - resizeMutableArr marr n = do - marr' <- newSmallArray n uninitialized - copySmallMutableArray marr' 0 marr 0 (sizeofSmallMutableArray marr) - return marr' - {-# INLINE resizeMutableArr #-} -#if MIN_VERSION_base(4,14,0) - shrinkMutableArr = shrinkSmallMutableArray -#else - shrinkMutableArr _ _ = return () -#endif - {-# INLINE shrinkMutableArr #-} - - sameMutableArr (SmallMutableArray smarr1#) (SmallMutableArray smarr2#) = - isTrue# (sameSmallMutableArray# smarr1# smarr2#) - {-# INLINE sameMutableArr #-} - sizeofArr = sizeofSmallArray - {-# INLINE sizeofArr #-} - sizeofMutableArr = return . sizeofSmallMutableArray - {-# INLINE sizeofMutableArr #-} - - sameArr (SmallArray arr1#) (SmallArray arr2#) = isTrue# ( - sameSmallMutableArray# (unsafeCoerce# arr1#) (unsafeCoerce# arr2#)) - {-# INLINE sameArr #-} - -instance Prim a => Arr PrimArray a where - type MArr PrimArray = MutablePrimArray - newArr = newPrimArray - {-# INLINE newArr #-} - newArrWith n x = do - marr <- newPrimArray n - when (n > 0) (setPrimArray marr 0 n x) - return marr - {-# INLINE newArrWith #-} - readArr = readPrimArray - {-# INLINE readArr #-} - writeArr = writePrimArray - {-# INLINE writeArr #-} - setArr = setPrimArray - {-# INLINE setArr #-} - indexArr = indexPrimArray - {-# INLINE indexArr #-} - indexArr' arr i = (# indexPrimArray arr i #) - {-# INLINE indexArr' #-} - indexArrM arr i = return (indexPrimArray arr i) - {-# INLINE indexArrM #-} - freezeArr = freezePrimArray - {-# INLINE freezeArr #-} - thawArr arr s l = do - marr' <- newPrimArray l - copyPrimArray marr' 0 arr s l - return marr' - {-# INLINE thawArr #-} - unsafeFreezeArr = unsafeFreezePrimArray - {-# INLINE unsafeFreezeArr #-} - unsafeThawArr = unsafeThawPrimArray - {-# INLINE unsafeThawArr #-} - - copyArr = copyPrimArray - {-# INLINE copyArr #-} - copyMutableArr = copyMutablePrimArray - {-# INLINE copyMutableArr #-} - - moveArr (MutablePrimArray dst) doff (MutablePrimArray src) soff n = - moveByteArray (MutableByteArray dst) (doff*siz) (MutableByteArray src) (soff*siz) (n*siz) - where siz = sizeOf (undefined :: a) - {-# INLINE moveArr #-} - - cloneArr = clonePrimArray - {-# INLINE cloneArr #-} - cloneMutableArr = cloneMutablePrimArray - {-# INLINE cloneMutableArr #-} - - resizeMutableArr = resizeMutablePrimArray - {-# INLINE resizeMutableArr #-} - shrinkMutableArr = shrinkMutablePrimArray - {-# INLINE shrinkMutableArr #-} - - sameMutableArr = sameMutablePrimArray - {-# INLINE sameMutableArr #-} - sizeofArr = sizeofPrimArray - {-# INLINE sizeofArr #-} - sizeofMutableArr = getSizeofMutablePrimArray - {-# INLINE sizeofMutableArr #-} - - sameArr (PrimArray ba1#) (PrimArray ba2#) = - isTrue# (sameMutableByteArray# (unsafeCoerce# ba1#) (unsafeCoerce# ba2#)) - {-# INLINE sameArr #-} - -instance PrimUnlifted a => Arr UnliftedArray a where - type MArr UnliftedArray = MutableUnliftedArray - newArr = unsafeNewUnliftedArray - {-# INLINE newArr #-} - newArrWith = newUnliftedArray - {-# INLINE newArrWith #-} - readArr = readUnliftedArray - {-# INLINE readArr #-} - writeArr = writeUnliftedArray - {-# INLINE writeArr #-} - setArr = setUnliftedArray - {-# INLINE setArr #-} - indexArr = indexUnliftedArray - {-# INLINE indexArr #-} - indexArr' arr i = (# indexUnliftedArray arr i #) - {-# INLINE indexArr' #-} - indexArrM arr i = return (indexUnliftedArray arr i) - {-# INLINE indexArrM #-} - freezeArr = freezeUnliftedArray - {-# INLINE freezeArr #-} - thawArr = thawUnliftedArray - {-# INLINE thawArr #-} - unsafeFreezeArr = unsafeFreezeUnliftedArray - {-# INLINE unsafeFreezeArr #-} - unsafeThawArr (UnliftedArray arr#) = primitive ( \ s0# -> - let !(# s1#, marr# #) = unsafeThawArray# (unsafeCoerce# arr#) s0# - -- ArrayArray# and Array# use the same representation - in (# s1#, MutableUnliftedArray (unsafeCoerce# marr#) #) -- so this works - ) - {-# INLINE unsafeThawArr #-} - - copyArr = copyUnliftedArray - {-# INLINE copyArr #-} - copyMutableArr = copyMutableUnliftedArray - {-# INLINE copyMutableArr #-} - - moveArr marr1 s1 marr2 s2 l - | l <= 0 = return () - | sameMutableUnliftedArray marr1 marr2 = - case compare s1 s2 of - LT -> - let !d = s2 - s1 - !s2l = s2 + l - go !i | i >= s2l = return () - | otherwise = do x <- readUnliftedArray marr2 i - writeUnliftedArray marr1 (i-d) x - go (i+1) - in go s2 - - EQ -> return () - - GT -> - let !d = s1 - s2 - go !i | i < s2 = return () - | otherwise = do x <- readUnliftedArray marr2 i - writeUnliftedArray marr1 (i+d) x - go (i-1) - in go (s2+l-1) - | otherwise = copyMutableUnliftedArray marr1 s1 marr2 s2 l - {-# INLINE moveArr #-} - - cloneArr = cloneUnliftedArray - {-# INLINE cloneArr #-} - cloneMutableArr = cloneMutableUnliftedArray - {-# INLINE cloneMutableArr #-} - - resizeMutableArr marr n = do - marr' <- newUnliftedArray n uninitialized - copyMutableUnliftedArray marr' 0 marr 0 (sizeofMutableUnliftedArray marr) - return marr' - {-# INLINE resizeMutableArr #-} - shrinkMutableArr _ _ = return () - {-# INLINE shrinkMutableArr #-} - - sameMutableArr = sameMutableUnliftedArray - {-# INLINE sameMutableArr #-} - sizeofArr = sizeofUnliftedArray - {-# INLINE sizeofArr #-} - sizeofMutableArr = return . sizeofMutableUnliftedArray - {-# INLINE sizeofMutableArr #-} - - sameArr (UnliftedArray arr1#) (UnliftedArray arr2#) = isTrue# ( - sameMutableArrayArray# (unsafeCoerce# arr1#) (unsafeCoerce# arr2#)) - {-# INLINE sameArr #-} - --------------------------------------------------------------------------------- - --- | Obtain the pointer to the content of an array, and the pointer should only be used during the IO action. --- --- This operation is only safe on /pinned/ primitive arrays (Arrays allocated by 'newPinnedPrimArray' or --- 'newAlignedPinnedPrimArray'). --- --- Don't pass a forever loop to this function, see . -withPrimArrayContents :: PrimArray a -> (Ptr a -> IO b) -> IO b -{-# INLINE withPrimArrayContents #-} -withPrimArrayContents (PrimArray ba#) f = do - let addr# = byteArrayContents# ba# - ptr = Ptr addr# - b <- f ptr - primitive_ (touch# ba#) - return b - --- | Obtain the pointer to the content of an mutable array, and the pointer should only be used during the IO action. --- --- This operation is only safe on /pinned/ primitive arrays (Arrays allocated by 'newPinnedPrimArray' or --- 'newAlignedPinnedPrimArray'). --- --- Don't pass a forever loop to this function, see . -withMutablePrimArrayContents :: MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b -{-# INLINE withMutablePrimArrayContents #-} -withMutablePrimArrayContents (MutablePrimArray mba#) f = do - let addr# = byteArrayContents# (unsafeCoerce# mba#) - ptr = Ptr addr# - b <- f ptr - primitive_ (touch# mba#) - return b - - --- | Cast between arrays -castArray :: (Arr arr a, Cast a b) => arr a -> arr b -castArray = unsafeCoerce# - - --- | Cast between mutable arrays -castMutableArray :: (Arr arr a, Cast a b) => MArr arr s a -> MArr arr s b -castMutableArray = unsafeCoerce# - --------------------------------------------------------------------------------- - -emptyArr :: Arr arr a => arr a -emptyArr = runST $ do - marr <- newArrWith 0 uninitialized - unsafeFreezeArr marr - -singletonArr :: Arr arr a => a -> arr a -{-# INLINE singletonArr #-} -singletonArr x = runST $ do - marr <- newArrWith 1 x - unsafeFreezeArr marr - -doubletonArr :: Arr arr a => a -> a -> arr a -{-# INLINE doubletonArr #-} -doubletonArr x y = runST $ do - marr <- newArrWith 2 x - writeArr marr 1 y - unsafeFreezeArr marr - --- | Modify(strictly) an immutable some elements of an array with specified subrange. --- This function will produce a new array. -modifyIndexArr :: Arr arr a - => arr a - -> Int -- ^ offset - -> Int -- ^ length - -> Int -- ^ index in new array - -> (a -> a) -- ^ modify function - -> arr a -{-# INLINE modifyIndexArr #-} -modifyIndexArr arr off len ix f = runST $ do - marr <- unsafeThawArr (cloneArr arr off len) - !v <- f <$> readArr marr ix - writeArr marr ix v - unsafeFreezeArr marr - --- | Insert a value to an immutable array at given index. This function will produce a new array. -insertIndexArr :: Arr arr a - => arr a - -> Int -- ^ offset - -> Int -- ^ length - -> Int -- ^ insert index in new array - -> a -- ^ value to be inserted - -> arr a -{-# INLINE insertIndexArr #-} -insertIndexArr arr s l i x = runST $ do - marr <- newArrWith (l+1) x - when (i>0) $ copyArr marr 0 arr s i - when (i arr a - -> Int -- ^ offset - -> Int -- ^ length - -> Int -- ^ the index of the element to delete - -> arr a -{-# INLINE deleteIndexArr #-} -deleteIndexArr arr s l i = runST $ do - marr <- newArr (l-1) - when (i>0) $ copyArr marr 0 arr s i - let i' = i+1 - when (i' Bool -> a -> a +{-# INLINE check #-} +check True x = x +check False _ = throw (IndexOutOfBounds $ show callStack) +#endif + +-- | Make a new array with a given size. +-- +-- For boxed arrays, all elements are 'uninitialized' , which shall not be accessed. +-- For primitive arrays, elements are just random garbage. +newArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => Int -> m (MArr arr s a) +newArr n = +#ifdef CHECK_ARRAY_BOUND + check (n>=0) (A.newArr n) +#else + A.newArr n +#endif +{-# INLINE newArr #-} + +-- | Make a new array and fill it with an initial value. +newArrWith :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => Int -> a -> m (MArr arr s a) +newArrWith n x = +#ifdef CHECK_ARRAY_BOUND + check (n>=0) (A.newArrWith n x) +#else + (A.newArrWith n x) +#endif +{-# INLINE newArrWith #-} + +-- | Read from specified index of mutable array in a primitive monad. +readArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> m a +readArr marr i = do +#ifdef CHECK_ARRAY_BOUND + siz <- A.sizeofMutableArr marr + check + (i>=0 && i MArr arr s a -> Int -> a -> m () +writeArr marr i x = do +#ifdef CHECK_ARRAY_BOUND + siz <- A.sizeofMutableArr marr + check + (i>=0 && i MArr arr s a -> Int -> Int -> a -> m () +setArr marr s l x = do +#ifdef CHECK_ARRAY_BOUND + siz <- A.sizeofMutableArr marr + check + (s>=0 && l>=0 && (s+l)<=siz) + (A.setArr marr s l x) +#else + (A.setArr marr s l x) +#endif +{-# INLINE setArr #-} + +-- | Read from the specified index of an immutable array. It's pure and often +-- results in an indexing thunk for lifted arrays, use 'indexArr\'' or 'indexArrM' to avoid this. +indexArr :: (Arr arr a, HasCallStack) + => arr a -> Int -> a +indexArr arr i = +#ifdef CHECK_ARRAY_BOUND + check (i>=0 && i arr a -> Int -> (# a #) +indexArr' arr i = +#ifdef CHECK_ARRAY_BOUND + if (i>=0 && i 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. +-- +-- /Note:/ this function does not do bounds checking. +indexArrM :: (Arr arr a, Monad m, HasCallStack) + => arr a -> Int -> m a +indexArrM arr i = +#ifdef CHECK_ARRAY_BOUND + check + (i>=0 && i MArr arr s a -> Int -> Int -> m (arr a) +freezeArr marr s l = do +#ifdef CHECK_ARRAY_BOUND + siz <- A.sizeofMutableArr marr + check + (s>=0 && l>=0 && (s+l)<=siz) + (A.freezeArr marr s l) +#else + (A.freezeArr marr s l) +#endif +{-# INLINE freezeArr #-} + +-- | 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. +thawArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => arr a -> Int -> Int -> m (MArr arr s a) +thawArr arr s l = +#ifdef CHECK_ARRAY_BOUND + check + (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr) + (A.thawArr arr s l) +#else + (A.thawArr arr s l) +#endif +{-# INLINE thawArr #-} + +-- | Copy a slice of an immutable array to a mutable array at given offset. +copyArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> arr a -> Int -> Int -> m () +copyArr marr s1 arr s2 l = do +#ifdef CHECK_ARRAY_BOUND + siz <- A.sizeofMutableArr marr + check + (s1>=0 && s2>=0 && l>=0 && (s2+l)<=A.sizeofArr arr && (s1+l)<=siz) + (A.copyArr marr s1 arr s2 l) +#else + (A.copyArr marr s1 arr s2 l) +#endif +{-# INLINE copyArr #-} + +-- | Copy a slice of a mutable array to another mutable array at given offset. +-- The two mutable arrays must not be the same. +copyMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> MArr arr s a -> Int -> Int -> m () +copyMutableArr marr1 s1 marr2 s2 l = do +#ifdef CHECK_ARRAY_BOUND + siz1 <- A.sizeofMutableArr marr1 + siz2 <- A.sizeofMutableArr marr2 + check + (s1>=0 && s2>=0 && l>=0 && (s2+l)<=siz2 && (s1+l)<=siz1) + (A.copyMutableArr marr1 s1 marr2 s2 l) +#else + (A.copyMutableArr marr1 s1 marr2 s2 l) +#endif +{-# INLINE copyMutableArr #-} + +-- | Copy a slice of a mutable array to a mutable array at given offset. +-- The two mutable arrays can be the same. +moveArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> MArr arr s a -> Int -> Int -> m () +moveArr marr1 s1 marr2 s2 l = do +#ifdef CHECK_ARRAY_BOUND + siz1 <- A.sizeofMutableArr marr1 + siz2 <- A.sizeofMutableArr marr2 + check + (s1>=0 && s2>=0 && l>=0 && (s2+l)<=siz2 && (s1+l)<=siz1) + (A.moveArr marr1 s1 marr2 s2 l) +#else + (A.moveArr marr1 s1 marr2 s2 l) +#endif +{-# INLINE moveArr #-} + +-- | Create an immutable copy with the given subrange of the original array. +cloneArr :: (Arr arr a, HasCallStack) + => arr a -> Int -> Int -> arr a +cloneArr arr s l = +#ifdef CHECK_ARRAY_BOUND + check + (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr) + (A.cloneArr arr s l) +#else + (A.cloneArr arr s l) +#endif +{-# INLINE cloneArr #-} + +-- | Create a mutable copy the given subrange of the original array. +cloneMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> Int -> m (MArr arr s a) +cloneMutableArr marr s l = do +#ifdef CHECK_ARRAY_BOUND + siz <- A.sizeofMutableArr marr + check + (s>=0 && l>=0 && (s+l)<=siz) + (A.cloneMutableArr marr s l) +#else + (A.cloneMutableArr marr s l) +#endif +{-# INLINE cloneMutableArr #-} + +-- | Resize a mutable array to the given size. +resizeMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> m (MArr arr s a) +resizeMutableArr marr n = +#ifdef CHECK_ARRAY_BOUND + check (n>=0) (A.resizeMutableArr marr n) +#else + (A.resizeMutableArr marr n) +#endif +{-# INLINE resizeMutableArr #-} + +-- | Shrink a mutable array to the given size. This operation only works on primitive arrays. +-- For some array types, this is a no-op, e.g. 'sizeOfMutableArr' will not change. +-- +-- New size should be >= 0, and <= original size. +shrinkMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> m () +shrinkMutableArr marr n = do +#ifdef CHECK_ARRAY_BOUND + siz <- A.sizeofMutableArr marr + check + (n>=0 && n<=siz) + (A.shrinkMutableArr marr n) +#else + (A.shrinkMutableArr marr n) +#endif +{-# INLINE shrinkMutableArr #-} + +-------------------------------------------------------------------------------- + +-- | Create a /pinned/ byte array of the specified size, +-- The garbage collector is guaranteed not to move it. +newPinnedPrimArray :: (PrimMonad m, Prim a, HasCallStack) + => Int -> m (A.MutablePrimArray (PrimState m) a) +{-# INLINE newPinnedPrimArray #-} +newPinnedPrimArray n = +#ifdef CHECK_ARRAY_BOUND + check (n>=0) (A.newPinnedPrimArray n) +#else + (A.newPinnedPrimArray n) +#endif + +-- | Create a /pinned/ primitive array of the specified size and respect given primitive type's +-- alignment. The garbage collector is guaranteed not to move it. +-- +newAlignedPinnedPrimArray :: (PrimMonad m, Prim a, HasCallStack) + => Int -> m (A.MutablePrimArray (PrimState m) a) +{-# INLINE newAlignedPinnedPrimArray #-} +newAlignedPinnedPrimArray n = +#ifdef CHECK_ARRAY_BOUND + check (n>=0) (A.newAlignedPinnedPrimArray n) +#else + (A.newAlignedPinnedPrimArray n) +#endif + +copyPrimArrayToPtr :: (PrimMonad m, Prim a, HasCallStack) + => Ptr a + -> A.PrimArray a + -> Int + -> Int + -> m () +{-# INLINE copyPrimArrayToPtr #-} +copyPrimArrayToPtr ptr arr s l = +#ifdef CHECK_ARRAY_BOUND + check + (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr) + (A.copyPrimArrayToPtr ptr arr s l) +#else + (A.copyPrimArrayToPtr ptr arr s l) +#endif + +copyMutablePrimArrayToPtr :: (PrimMonad m, Prim a, HasCallStack) + => Ptr a + -> A.MutablePrimArray (PrimState m) a + -> Int + -> Int + -> m () +{-# INLINE copyMutablePrimArrayToPtr #-} +copyMutablePrimArrayToPtr ptr marr s l = do +#ifdef CHECK_ARRAY_BOUND + siz <- A.sizeofMutableArr marr + check + (s>=0 && l>=0 && (s+l)<=siz) + (A.copyMutablePrimArrayToPtr ptr marr s l) +#else + (A.copyMutablePrimArrayToPtr ptr marr s l) +#endif + +copyPtrToMutablePrimArray :: (PrimMonad m, Prim a, HasCallStack) + => A.MutablePrimArray (PrimState m) a + -> Int + -> Ptr a + -> Int + -> m () +{-# INLINE copyPtrToMutablePrimArray #-} +copyPtrToMutablePrimArray marr s ptr l = do +#ifdef CHECK_ARRAY_BOUND + siz <- A.sizeofMutableArr marr + check + (s>=0 && l>=0 && (s+l)<=siz) + (A.copyPtrToMutablePrimArray marr s ptr l) +#else + (A.copyPtrToMutablePrimArray marr s ptr l) +#endif + +-------------------------------------------------------------------------------- + +modifyIndexArr :: (Arr arr a, HasCallStack) => arr a + -> Int -- ^ offset + -> Int -- ^ length + -> Int -- ^ index in new array + -> (a -> a) -- ^ modify function + -> arr a +{-# INLINE modifyIndexArr #-} +modifyIndexArr arr off len ix f = +#ifdef CHECK_ARRAY_BOUND + runST $ do + marr <- A.unsafeThawArr (cloneArr arr off len) + !v <- f <$> readArr marr ix + writeArr marr ix v + A.unsafeFreezeArr marr +#else + A.modifyIndexArr arr off len ix f +#endif + +-- | Insert an immutable array's element at given index to produce a new array. +insertIndexArr :: Arr arr a + => arr a + -> Int -- ^ offset + -> Int -- ^ length + -> Int -- ^ insert index in new array + -> a -- ^ element to be inserted + -> arr a +{-# INLINE insertIndexArr #-} +insertIndexArr arr s l i x = +#ifdef CHECK_ARRAY_BOUND + runST $ do + marr <- newArrWith (l+1) x + when (i>0) $ copyArr marr 0 arr s i + when (i arr a + -> Int -- ^ offset + -> Int -- ^ length + -> Int -- ^ drop index in new array + -> arr a +{-# INLINE deleteIndexArr #-} +deleteIndexArr arr s l i = +#ifdef CHECK_ARRAY_BOUND + runST $ do + marr <- newArr (l-1) + when (i>0) $ copyArr marr 0 arr s i + let i' = i+1 + when (i' Type) a where + + + -- | The mutable version of this array type. + -- + type MArr arr = (mar :: Type -> Type -> Type) | mar -> arr + + + -- | Make a new array with a given size. + -- + -- For boxed arrays, all elements are 'uninitialized' , which shall not be accessed. + -- For primitive arrays, elements are just random garbage. + newArr :: (PrimMonad m, PrimState m ~ s) => Int -> m (MArr arr s a) + + + -- | Make a new array and fill it with an initial value. + newArrWith :: (PrimMonad m, PrimState m ~ s) => Int -> a -> m (MArr arr s a) + + + -- | Read from specified index of mutable array in a primitive monad. + readArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m a + + + -- | Write to specified index of mutable array in a primitive monad. + writeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> a -> m () + + + -- | Fill the mutable array with a given value. + setArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> a -> m () + + + -- | Read from the specified index of an immutable array. It's pure and often + -- results in an indexing thunk for lifted arrays, use 'indexArr\'' or 'indexArrM' to avoid this. + indexArr :: arr a -> Int -> a + + + -- | Read from the specified index of an immutable array. The result is packaged into an unboxed unary tuple; the result itself is not yet evaluated. + -- Pattern matching on the tuple forces the indexing of the array to happen but does not evaluate the element itself. + -- Evaluating the thunk prevents additional thunks from building up on the heap. + -- Avoiding these thunks, in turn, reduces references to the argument array, allowing it to be garbage collected more promptly. + indexArr' :: arr a -> Int -> (# a #) + + + -- | 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. + -- + -- /Note:/ this function does not do bounds checking. + indexArrM :: (Monad m) => arr a -> Int -> m a + + + -- | 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. + freezeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> m (arr 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. + thawArr :: (PrimMonad m, PrimState m ~ s) => arr a -> Int -> Int -> m (MArr arr s a) + + + -- | Convert a mutable array to an immutable one without copying. + -- The array should not be modified after the conversion. + unsafeFreezeArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> m (arr a) + + + + -- | Convert a mutable array to an immutable one without copying. The + -- array should not be modified after the conversion. + unsafeThawArr :: (PrimMonad m, PrimState m ~ s) => arr a -> m (MArr arr s a) + + + -- | Copy a slice of an immutable array to a mutable array at given offset. + copyArr :: (PrimMonad m, PrimState m ~ s) + => MArr arr s a -- ^ target + -> Int -- ^ offset into target array + -> arr a -- ^ source + -> Int -- ^ offset into source array + -> Int -- ^ number of elements to copy + -> m () + + + -- | Copy a slice of a mutable array to another mutable array at given offset. + -- The two mutable arrays must not be the same. + copyMutableArr :: (PrimMonad m, PrimState m ~ s) + => MArr arr s a -- ^ target + -> Int -- ^ offset into target array + -> MArr arr s a -- ^ source + -> Int -- ^ offset into source array + -> Int -- ^ number of elements to copy + -> m () + + + -- | Copy a slice of a mutable array to a mutable array at given offset. + -- The two mutable arrays can be the same. + moveArr :: (PrimMonad m, PrimState m ~ s) + => MArr arr s a -- ^ target + -> Int -- ^ offset into target array + -> MArr arr s a -- ^ source + -> Int -- ^ offset into source array + -> Int -- ^ number of elements to copy + -> m () + + + -- | Create an immutable copy with the given subrange of the original array. + cloneArr :: arr a -> Int -> Int -> arr a + + + -- | Create a mutable copy the given subrange of the original array. + cloneMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> Int -> m (MArr arr s a) + + + -- | Resize a mutable array to the given size. + resizeMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m (MArr arr s a) + + + -- | Shrink a mutable array to the given size. This operation only works on primitive arrays. + -- For some array types, this is a no-op, e.g. 'sizeOfMutableArr' will not change. + shrinkMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m () + + + -- | Is two mutable array are reference equal. + sameMutableArr :: MArr arr s a -> MArr arr s a -> Bool + + + -- | Size of the immutable array. + sizeofArr :: arr a -> Int + + + -- | Size of the mutable array. + sizeofMutableArr :: (PrimMonad m, PrimState m ~ s) => MArr arr s a -> m Int + + + -- | Check whether the two immutable arrays refer to the same memory block + -- + -- Note that the result of 'sameArr' may change depending on compiler's optimizations, for example, + -- @let arr = runST ... in arr `sameArr` arr@ may return false if compiler decides to + -- inline it. + -- + -- See https://ghc.haskell.org/trac/ghc/ticket/13908 for more context. + -- + sameArr :: arr a -> arr a -> Bool + +instance Arr Array a where + type MArr Array = MutableArray + newArr n = newArray n uninitialized + {-# INLINE newArr #-} + newArrWith = newArray + {-# INLINE newArrWith #-} + readArr = readArray + {-# INLINE readArr #-} + writeArr = writeArray + {-# INLINE writeArr #-} + setArr marr s l x = go s + where + !sl = s + l + go !i | i >= sl = return () + | otherwise = writeArray marr i x >> go (i+1) + {-# INLINE setArr #-} + indexArr = indexArray + {-# INLINE indexArr #-} + indexArr' (Array arr#) (I# i#) = indexArray# arr# i# + {-# INLINE indexArr' #-} + indexArrM = indexArrayM + {-# INLINE indexArrM #-} + freezeArr = freezeArray + {-# INLINE freezeArr #-} + thawArr = thawArray + {-# INLINE thawArr #-} + unsafeFreezeArr = unsafeFreezeArray + {-# INLINE unsafeFreezeArr #-} + unsafeThawArr = unsafeThawArray + {-# INLINE unsafeThawArr #-} + + copyArr = copyArray + {-# INLINE copyArr #-} + copyMutableArr = copyMutableArray + {-# INLINE copyMutableArr #-} + + moveArr marr1 s1 marr2 s2 l + | l <= 0 = return () + | sameMutableArray marr1 marr2 = + case compare s1 s2 of + LT -> + let !d = s2 - s1 + !s2l = s2 + l + go !i | i >= s2l = return () + | otherwise = do x <- readArray marr2 i + writeArray marr1 (i-d) x + go (i+1) + in go s2 + + EQ -> return () + + GT -> + let !d = s1 - s2 + go !i | i < s2 = return () + | otherwise = do x <- readArray marr2 i + writeArray marr1 (i+d) x + go (i-1) + in go (s2+l-1) + | otherwise = copyMutableArray marr1 s1 marr2 s2 l + {-# INLINE moveArr #-} + + cloneArr = cloneArray + {-# INLINE cloneArr #-} + cloneMutableArr = cloneMutableArray + {-# INLINE cloneMutableArr #-} + + resizeMutableArr marr n = do + marr' <- newArray n uninitialized + copyMutableArray marr' 0 marr 0 (sizeofMutableArray marr) + return marr' + {-# INLINE resizeMutableArr #-} + shrinkMutableArr _ _ = return () + {-# INLINE shrinkMutableArr #-} + + sameMutableArr = sameMutableArray + {-# INLINE sameMutableArr #-} + sizeofArr = sizeofArray + {-# INLINE sizeofArr #-} + sizeofMutableArr = return . sizeofMutableArray + {-# INLINE sizeofMutableArr #-} + + sameArr (Array arr1#) (Array arr2#) = isTrue# ( + sameMutableArray# (unsafeCoerce# arr1#) (unsafeCoerce# arr2#)) + {-# INLINE sameArr #-} + +instance Arr SmallArray a where + type MArr SmallArray = SmallMutableArray + newArr n = newSmallArray n uninitialized + {-# INLINE newArr #-} + newArrWith = newSmallArray + {-# INLINE newArrWith #-} + readArr = readSmallArray + {-# INLINE readArr #-} + writeArr = writeSmallArray + {-# INLINE writeArr #-} + setArr marr s l x = go s + where + !sl = s + l + go !i | i >= sl = return () + | otherwise = writeSmallArray marr i x >> go (i+1) + {-# INLINE setArr #-} + indexArr = indexSmallArray + {-# INLINE indexArr #-} + indexArr' (SmallArray arr#) (I# i#) = indexSmallArray# arr# i# + {-# INLINE indexArr' #-} + indexArrM = indexSmallArrayM + {-# INLINE indexArrM #-} + freezeArr = freezeSmallArray + {-# INLINE freezeArr #-} + thawArr = thawSmallArray + {-# INLINE thawArr #-} + unsafeFreezeArr = unsafeFreezeSmallArray + {-# INLINE unsafeFreezeArr #-} + unsafeThawArr = unsafeThawSmallArray + {-# INLINE unsafeThawArr #-} + + copyArr = copySmallArray + {-# INLINE copyArr #-} + copyMutableArr = copySmallMutableArray + {-# INLINE copyMutableArr #-} + + moveArr marr1 s1 marr2 s2 l + | l <= 0 = return () + | sameMutableArr marr1 marr2 = + case compare s1 s2 of + LT -> + let !d = s2 - s1 + !s2l = s2 + l + go !i | i >= s2l = return () + | otherwise = do x <- readSmallArray marr2 i + writeSmallArray marr1 (i-d) x + go (i+1) + in go s2 + + EQ -> return () + + GT -> + let !d = s1 - s2 + go !i | i < s2 = return () + | otherwise = do x <- readSmallArray marr2 i + writeSmallArray marr1 (i+d) x + go (i-1) + in go (s2+l-1) + | otherwise = copySmallMutableArray marr1 s1 marr2 s2 l + {-# INLINE moveArr #-} + + cloneArr = cloneSmallArray + {-# INLINE cloneArr #-} + cloneMutableArr = cloneSmallMutableArray + {-# INLINE cloneMutableArr #-} + + resizeMutableArr marr n = do + marr' <- newSmallArray n uninitialized + copySmallMutableArray marr' 0 marr 0 (sizeofSmallMutableArray marr) + return marr' + {-# INLINE resizeMutableArr #-} +#if MIN_VERSION_base(4,14,0) + shrinkMutableArr = shrinkSmallMutableArray +#else + shrinkMutableArr _ _ = return () +#endif + {-# INLINE shrinkMutableArr #-} + + sameMutableArr (SmallMutableArray smarr1#) (SmallMutableArray smarr2#) = + isTrue# (sameSmallMutableArray# smarr1# smarr2#) + {-# INLINE sameMutableArr #-} + sizeofArr = sizeofSmallArray + {-# INLINE sizeofArr #-} + sizeofMutableArr = return . sizeofSmallMutableArray + {-# INLINE sizeofMutableArr #-} + + sameArr (SmallArray arr1#) (SmallArray arr2#) = isTrue# ( + sameSmallMutableArray# (unsafeCoerce# arr1#) (unsafeCoerce# arr2#)) + {-# INLINE sameArr #-} + +instance Prim a => Arr PrimArray a where + type MArr PrimArray = MutablePrimArray + newArr = newPrimArray + {-# INLINE newArr #-} + newArrWith n x = do + marr <- newPrimArray n + when (n > 0) (setPrimArray marr 0 n x) + return marr + {-# INLINE newArrWith #-} + readArr = readPrimArray + {-# INLINE readArr #-} + writeArr = writePrimArray + {-# INLINE writeArr #-} + setArr = setPrimArray + {-# INLINE setArr #-} + indexArr = indexPrimArray + {-# INLINE indexArr #-} + indexArr' arr i = (# indexPrimArray arr i #) + {-# INLINE indexArr' #-} + indexArrM arr i = return (indexPrimArray arr i) + {-# INLINE indexArrM #-} + freezeArr = freezePrimArray + {-# INLINE freezeArr #-} + thawArr arr s l = do + marr' <- newPrimArray l + copyPrimArray marr' 0 arr s l + return marr' + {-# INLINE thawArr #-} + unsafeFreezeArr = unsafeFreezePrimArray + {-# INLINE unsafeFreezeArr #-} + unsafeThawArr = unsafeThawPrimArray + {-# INLINE unsafeThawArr #-} + + copyArr = copyPrimArray + {-# INLINE copyArr #-} + copyMutableArr = copyMutablePrimArray + {-# INLINE copyMutableArr #-} + + moveArr (MutablePrimArray dst) doff (MutablePrimArray src) soff n = + moveByteArray (MutableByteArray dst) (doff*siz) (MutableByteArray src) (soff*siz) (n*siz) + where siz = sizeOf (undefined :: a) + {-# INLINE moveArr #-} + + cloneArr = clonePrimArray + {-# INLINE cloneArr #-} + cloneMutableArr = cloneMutablePrimArray + {-# INLINE cloneMutableArr #-} + + resizeMutableArr = resizeMutablePrimArray + {-# INLINE resizeMutableArr #-} + shrinkMutableArr = shrinkMutablePrimArray + {-# INLINE shrinkMutableArr #-} + + sameMutableArr = sameMutablePrimArray + {-# INLINE sameMutableArr #-} + sizeofArr = sizeofPrimArray + {-# INLINE sizeofArr #-} + sizeofMutableArr = getSizeofMutablePrimArray + {-# INLINE sizeofMutableArr #-} + + sameArr (PrimArray ba1#) (PrimArray ba2#) = + isTrue# (sameMutableByteArray# (unsafeCoerce# ba1#) (unsafeCoerce# ba2#)) + {-# INLINE sameArr #-} + +instance PrimUnlifted a => Arr UnliftedArray a where + type MArr UnliftedArray = MutableUnliftedArray + newArr = unsafeNewUnliftedArray + {-# INLINE newArr #-} + newArrWith = newUnliftedArray + {-# INLINE newArrWith #-} + readArr = readUnliftedArray + {-# INLINE readArr #-} + writeArr = writeUnliftedArray + {-# INLINE writeArr #-} + setArr = setUnliftedArray + {-# INLINE setArr #-} + indexArr = indexUnliftedArray + {-# INLINE indexArr #-} + indexArr' arr i = (# indexUnliftedArray arr i #) + {-# INLINE indexArr' #-} + indexArrM arr i = return (indexUnliftedArray arr i) + {-# INLINE indexArrM #-} + freezeArr = freezeUnliftedArray + {-# INLINE freezeArr #-} + thawArr = thawUnliftedArray + {-# INLINE thawArr #-} + unsafeFreezeArr = unsafeFreezeUnliftedArray + {-# INLINE unsafeFreezeArr #-} + unsafeThawArr (UnliftedArray arr#) = primitive ( \ s0# -> + let !(# s1#, marr# #) = unsafeThawArray# (unsafeCoerce# arr#) s0# + -- ArrayArray# and Array# use the same representation + in (# s1#, MutableUnliftedArray (unsafeCoerce# marr#) #) -- so this works + ) + {-# INLINE unsafeThawArr #-} + + copyArr = copyUnliftedArray + {-# INLINE copyArr #-} + copyMutableArr = copyMutableUnliftedArray + {-# INLINE copyMutableArr #-} + + moveArr marr1 s1 marr2 s2 l + | l <= 0 = return () + | sameMutableUnliftedArray marr1 marr2 = + case compare s1 s2 of + LT -> + let !d = s2 - s1 + !s2l = s2 + l + go !i | i >= s2l = return () + | otherwise = do x <- readUnliftedArray marr2 i + writeUnliftedArray marr1 (i-d) x + go (i+1) + in go s2 + + EQ -> return () + + GT -> + let !d = s1 - s2 + go !i | i < s2 = return () + | otherwise = do x <- readUnliftedArray marr2 i + writeUnliftedArray marr1 (i+d) x + go (i-1) + in go (s2+l-1) + | otherwise = copyMutableUnliftedArray marr1 s1 marr2 s2 l + {-# INLINE moveArr #-} + + cloneArr = cloneUnliftedArray + {-# INLINE cloneArr #-} + cloneMutableArr = cloneMutableUnliftedArray + {-# INLINE cloneMutableArr #-} + + resizeMutableArr marr n = do + marr' <- newUnliftedArray n uninitialized + copyMutableUnliftedArray marr' 0 marr 0 (sizeofMutableUnliftedArray marr) + return marr' + {-# INLINE resizeMutableArr #-} + shrinkMutableArr _ _ = return () + {-# INLINE shrinkMutableArr #-} + + sameMutableArr = sameMutableUnliftedArray + {-# INLINE sameMutableArr #-} + sizeofArr = sizeofUnliftedArray + {-# INLINE sizeofArr #-} + sizeofMutableArr = return . sizeofMutableUnliftedArray + {-# INLINE sizeofMutableArr #-} + + sameArr (UnliftedArray arr1#) (UnliftedArray arr2#) = isTrue# ( + sameMutableArrayArray# (unsafeCoerce# arr1#) (unsafeCoerce# arr2#)) + {-# INLINE sameArr #-} + +-------------------------------------------------------------------------------- + +-- | Obtain the pointer to the content of an array, and the pointer should only be used during the IO action. +-- +-- This operation is only safe on /pinned/ primitive arrays (Arrays allocated by 'newPinnedPrimArray' or +-- 'newAlignedPinnedPrimArray'). +-- +-- Don't pass a forever loop to this function, see . +withPrimArrayContents :: PrimArray a -> (Ptr a -> IO b) -> IO b +{-# INLINE withPrimArrayContents #-} +withPrimArrayContents (PrimArray ba#) f = do + let addr# = byteArrayContents# ba# + ptr = Ptr addr# + b <- f ptr + primitive_ (touch# ba#) + return b + +-- | Obtain the pointer to the content of an mutable array, and the pointer should only be used during the IO action. +-- +-- This operation is only safe on /pinned/ primitive arrays (Arrays allocated by 'newPinnedPrimArray' or +-- 'newAlignedPinnedPrimArray'). +-- +-- Don't pass a forever loop to this function, see . +withMutablePrimArrayContents :: MutablePrimArray RealWorld a -> (Ptr a -> IO b) -> IO b +{-# INLINE withMutablePrimArrayContents #-} +withMutablePrimArrayContents (MutablePrimArray mba#) f = do + let addr# = byteArrayContents# (unsafeCoerce# mba#) + ptr = Ptr addr# + b <- f ptr + primitive_ (touch# mba#) + return b + +-- | Cast between arrays +castArray :: (Arr arr a, Cast a b) => arr a -> arr b +{-# INLINE castArray #-} +castArray = unsafeCoerce# + + +-- | Cast between mutable arrays +castMutableArray :: (Arr arr a, Cast a b) => MArr arr s a -> MArr arr s b +{-# INLINE castMutableArray #-} +castMutableArray = unsafeCoerce# + +-------------------------------------------------------------------------------- + +emptyArr :: Arr arr a => arr a +{-# NOINLINE emptyArr #-} +emptyArr = runST $ do + marr <- newArrWith 0 uninitialized + unsafeFreezeArr marr + +singletonArr :: Arr arr a => a -> arr a +{-# INLINE singletonArr #-} +singletonArr x = runST $ do + marr <- newArrWith 1 x + unsafeFreezeArr marr + +doubletonArr :: Arr arr a => a -> a -> arr a +{-# INLINE doubletonArr #-} +doubletonArr x y = runST $ do + marr <- newArrWith 2 x + writeArr marr 1 y + unsafeFreezeArr marr + +-- | Modify(strictly) an immutable some elements of an array with specified subrange. +-- This function will produce a new array. +modifyIndexArr :: Arr arr a + => arr a + -> Int -- ^ offset + -> Int -- ^ length + -> Int -- ^ index in new array + -> (a -> a) -- ^ modify function + -> arr a +{-# INLINE modifyIndexArr #-} +modifyIndexArr arr off len ix f = runST $ do + marr <- unsafeThawArr (cloneArr arr off len) + !v <- f <$> readArr marr ix + writeArr marr ix v + unsafeFreezeArr marr + +-- | Insert a value to an immutable array at given index. This function will produce a new array. +insertIndexArr :: Arr arr a + => arr a + -> Int -- ^ offset + -> Int -- ^ length + -> Int -- ^ insert index in new array + -> a -- ^ value to be inserted + -> arr a +{-# INLINE insertIndexArr #-} +insertIndexArr arr s l i x = runST $ do + marr <- newArrWith (l+1) x + when (i>0) $ copyArr marr 0 arr s i + when (i arr a + -> Int -- ^ offset + -> Int -- ^ length + -> Int -- ^ the index of the element to delete + -> arr a +{-# INLINE deleteIndexArr #-} +deleteIndexArr arr s l i = runST $ do + marr <- newArr (l-1) + when (i>0) $ copyArr marr 0 arr s i + let i' = i+1 + when (i' Bool -> a -> a -{-# INLINE check #-} -check True x = x -check False _ = throw (IndexOutOfBounds $ show callStack) - -newArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => Int -> m (MArr arr s a) -newArr n = check (n>=0) (A.newArr n) -{-# INLINE newArr #-} - -newArrWith :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => Int -> a -> m (MArr arr s a) -newArrWith n x = check (n>=0) (A.newArrWith n x) -{-# INLINE newArrWith #-} - -readArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => MArr arr s a -> Int -> m a -readArr marr i = do - siz <- A.sizeofMutableArr marr - check - (i>=0 && i MArr arr s a -> Int -> a -> m () -writeArr marr i x = do - siz <- A.sizeofMutableArr marr - check - (i>=0 && i MArr arr s a -> Int -> Int -> a -> m () -setArr marr s l x = do - siz <- A.sizeofMutableArr marr - check - (s>=0 && l>=0 && (s+l)<=siz) - (A.setArr marr s l x) -{-# INLINE setArr #-} - -indexArr :: (Arr arr a, HasCallStack) - => arr a -> Int -> a -indexArr arr i = check - (i>=0 && i arr a -> Int -> (# a #) -indexArr' arr i = - if (i>=0 && i arr a -> Int -> m a -indexArrM arr i = check - (i>=0 && i MArr arr s a -> Int -> Int -> m (arr a) -freezeArr marr s l = do - siz <- A.sizeofMutableArr marr - check - (s>=0 && l>=0 && (s+l)<=siz) - (A.freezeArr marr s l) -{-# INLINE freezeArr #-} - -thawArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => arr a -> Int -> Int -> m (MArr arr s a) -thawArr arr s l = check - (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr) - (A.thawArr arr s l) -{-# INLINE thawArr #-} - -copyArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => MArr arr s a -> Int -> arr a -> Int -> Int -> m () -copyArr marr s1 arr s2 l = do - siz <- A.sizeofMutableArr marr - check - (s1>=0 && s2>=0 && l>=0 && (s2+l)<=A.sizeofArr arr && (s1+l)<=siz) - (A.copyArr marr s1 arr s2 l) -{-# INLINE copyArr #-} - -copyMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => MArr arr s a -> Int -> MArr arr s a -> Int -> Int -> m () -copyMutableArr marr1 s1 marr2 s2 l = do - siz1 <- A.sizeofMutableArr marr1 - siz2 <- A.sizeofMutableArr marr2 - check - (s1>=0 && s2>=0 && l>=0 && (s2+l)<=siz2 && (s1+l)<=siz1) - (A.copyMutableArr marr1 s1 marr2 s2 l) -{-# INLINE copyMutableArr #-} - -moveArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => MArr arr s a -> Int -> MArr arr s a -> Int -> Int -> m () -moveArr marr1 s1 marr2 s2 l = do - siz1 <- A.sizeofMutableArr marr1 - siz2 <- A.sizeofMutableArr marr2 - check - (s1>=0 && s2>=0 && l>=0 && (s2+l)<=siz2 && (s1+l)<=siz1) - (A.copyMutableArr marr1 s1 marr2 s2 l) -{-# INLINE moveArr #-} - -cloneArr :: (Arr arr a, HasCallStack) - => arr a -> Int -> Int -> arr a -cloneArr arr s l = check - (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr) - (A.cloneArr arr s l) -{-# INLINE cloneArr #-} - -cloneMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => MArr arr s a -> Int -> Int -> m (MArr arr s a) -cloneMutableArr marr s l = do - siz <- A.sizeofMutableArr marr - check - (s>=0 && l>=0 && (s+l)<=siz) - (A.cloneMutableArr marr s l) -{-# INLINE cloneMutableArr #-} - -resizeMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => MArr arr s a -> Int -> m (MArr arr s a) -resizeMutableArr marr n = check - (n>=0) - (A.resizeMutableArr marr n) -{-# INLINE resizeMutableArr #-} - --- | New size should be >= 0, and <= original size. --- -shrinkMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => MArr arr s a -> Int -> m () -shrinkMutableArr marr n = do - siz <- A.sizeofMutableArr marr - check - (n>=0 && n<=siz) - (A.shrinkMutableArr marr n) -{-# INLINE shrinkMutableArr #-} - --------------------------------------------------------------------------------- - --- | Create a /pinned/ byte array of the specified size, --- The garbage collector is guaranteed not to move it. -newPinnedPrimArray :: (PrimMonad m, Prim a, HasCallStack) - => Int -> m (A.MutablePrimArray (PrimState m) a) -{-# INLINE newPinnedPrimArray #-} -newPinnedPrimArray n = - check (n>=0) (A.newPinnedPrimArray n) - --- | Create a /pinned/ primitive array of the specified size and respect given primitive type's --- alignment. The garbage collector is guaranteed not to move it. --- -newAlignedPinnedPrimArray :: (PrimMonad m, Prim a, HasCallStack) - => Int -> m (A.MutablePrimArray (PrimState m) a) -{-# INLINE newAlignedPinnedPrimArray #-} -newAlignedPinnedPrimArray n = - check (n>=0) (A.newAlignedPinnedPrimArray n) - -copyPrimArrayToPtr :: (PrimMonad m, Prim a, HasCallStack) - => Ptr a - -> A.PrimArray a - -> Int - -> Int - -> m () -{-# INLINE copyPrimArrayToPtr #-} -copyPrimArrayToPtr ptr arr s l = check - (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr) - (A.copyPrimArrayToPtr ptr arr s l) - -copyMutablePrimArrayToPtr :: (PrimMonad m, Prim a, HasCallStack) - => Ptr a - -> A.MutablePrimArray (PrimState m) a - -> Int - -> Int - -> m () -{-# INLINE copyMutablePrimArrayToPtr #-} -copyMutablePrimArrayToPtr ptr marr s l = do - siz <- A.sizeofMutableArr marr - check - (s>=0 && l>=0 && (s+l)<=siz) - (A.copyMutablePrimArrayToPtr ptr marr s l) - -copyPtrToMutablePrimArray :: (PrimMonad m, Prim a, HasCallStack) - => A.MutablePrimArray (PrimState m) a - -> Int - -> Ptr a - -> Int - -> m () -{-# INLINE copyPtrToMutablePrimArray #-} -copyPtrToMutablePrimArray marr s ptr l = do - siz <- A.sizeofMutableArr marr - check - (s>=0 && l>=0 && (s+l)<=siz) - (A.copyPtrToMutablePrimArray marr s ptr l) - --------------------------------------------------------------------------------- - -modifyIndexArr :: (Arr arr a, HasCallStack) => arr a - -> Int -- ^ offset - -> Int -- ^ length - -> Int -- ^ index in new array - -> (a -> a) -- ^ modify function - -> arr a -{-# INLINE modifyIndexArr #-} -modifyIndexArr arr off len ix f = runST $ do - marr <- A.unsafeThawArr (cloneArr arr off len) - !v <- f <$> readArr marr ix - writeArr marr ix v - A.unsafeFreezeArr marr - --- | Insert an immutable array's element at given index to produce a new array. -insertIndexArr :: Arr arr a - => arr a - -> Int -- ^ offset - -> Int -- ^ length - -> Int -- ^ insert index in new array - -> a -- ^ element to be inserted - -> arr a -{-# INLINE insertIndexArr #-} -insertIndexArr arr s l i x = runST $ do - marr <- newArrWith (l+1) x - when (i>0) $ copyArr marr 0 arr s i - when (i arr a - -> Int -- ^ offset - -> Int -- ^ length - -> Int -- ^ drop index in new array - -> arr a -{-# INLINE deleteIndexArr #-} -deleteIndexArr arr s l i = runST $ do - marr <- newArr (l-1) - when (i>0) $ copyArr marr 0 arr s i - let i' = i+1 - when (i' Addr# -> PrimArray Word8 -{-# INLINE word8ArrayFromAddr #-} +{-# INLINABLE word8ArrayFromAddr #-} word8ArrayFromAddr l addr# = runST $ do mba <- newPrimArray l copyPtrToMutablePrimArray mba 0 (Ptr addr#) l unsafeFreezePrimArray mba int8ArrayFromAddr :: Int -> Addr# -> PrimArray Int8 +{-# INLINE int8ArrayFromAddr #-} int8ArrayFromAddr l addr# = castArray (word8ArrayFromAddr l addr#) @@ -266,6 +267,7 @@ unsafeFreezePrimArray mba int16ArrayFromAddr :: Int -> Addr# -> PrimArray Int16 +{-# INLINE int16ArrayFromAddr #-} int16ArrayFromAddr l addr# = castArray (word16ArrayFromAddr l addr#) ARRAY_LITERAL_DOC(Int16) @@ -331,6 +333,7 @@ unsafeFreezePrimArray mba int32ArrayFromAddr :: Int -> Addr# -> PrimArray Int32 +{-# INLINE int32ArrayFromAddr #-} int32ArrayFromAddr l addr# = castArray (word32ArrayFromAddr l addr#) ARRAY_LITERAL_DOC(Int32) @@ -396,13 +399,14 @@ (error "Cannot use arrW64 as a dec") word64ArrayFromAddr :: Int -> Addr# -> PrimArray Word64 -{-# INLINE word64ArrayFromAddr #-} +{-# INLINABLE word64ArrayFromAddr #-} word64ArrayFromAddr l addr# = runST $ do mba <- newArr l copyPtrToMutablePrimArray mba 0 (Ptr addr#) l unsafeFreezePrimArray mba int64ArrayFromAddr :: Int -> Addr# -> PrimArray Int64 +{-# INLINE int64ArrayFromAddr #-} int64ArrayFromAddr l addr# = castArray (word64ArrayFromAddr l addr#) ARRAY_LITERAL_DOC(Int64) @@ -440,6 +444,7 @@ -------------------------------------------------------------------------------- wordArrayFromAddr :: Int -> Addr# -> PrimArray Word +{-# INLINE wordArrayFromAddr #-} wordArrayFromAddr l addr# = #if SIZEOF_HSWORD == 8 unsafeCoerce# (word64ArrayFromAddr l addr#) @@ -448,6 +453,7 @@ #endif intArrayFromAddr :: Int -> Addr# -> PrimArray Int +{-# INLINE intArrayFromAddr #-} intArrayFromAddr l addr# = #if SIZEOF_HSWORD == 8 unsafeCoerce# (int64ArrayFromAddr l addr#) diff --git a/Z/Data/Array/Unaligned.hs b/Z/Data/Array/Unaligned.hs --- a/Z/Data/Array/Unaligned.hs +++ b/Z/Data/Array/Unaligned.hs @@ -186,7 +186,6 @@ -- newtype BE a = BE { getBE :: a } deriving (Show, Eq) - #define USE_HOST_IMPL(END) \ {-# INLINE writeWord8ArrayAs# #-}; \ writeWord8ArrayAs# mba# i# (END x) = writeWord8ArrayAs# mba# i# x; \ diff --git a/Z/Data/Array/UnliftedArray.hs b/Z/Data/Array/UnliftedArray.hs --- a/Z/Data/Array/UnliftedArray.hs +++ b/Z/Data/Array/UnliftedArray.hs @@ -54,18 +54,18 @@ indexUnliftedArray# :: ArrayArray# -> Int# -> a instance PrimUnlifted (PrimArray a) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} writeUnliftedArray# a i (PrimArray x) = writeByteArrayArray# a i x readUnliftedArray# a i s0 = case readByteArrayArray# a i s0 of (# s1, x #) -> (# s1, PrimArray x #) indexUnliftedArray# a i = PrimArray (indexByteArrayArray# a i) instance PrimUnlifted ByteArray where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} writeUnliftedArray# a i (ByteArray x) = writeByteArrayArray# a i x readUnliftedArray# a i s0 = case readByteArrayArray# a i s0 of (# s1, x #) -> (# s1, ByteArray x #) @@ -78,9 +78,9 @@ -- This also uses unsafeCoerce# to relax the constraints on the -- state token. The primitives in GHC.Prim are too restrictive. instance PrimUnlifted (MutableByteArray s) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} writeUnliftedArray# a i (MutableByteArray x) = writeMutableByteArrayArray# a i (unsafeCoerce# x) readUnliftedArray# a i s0 = case readMutableByteArrayArray# a i s0 of @@ -90,9 +90,9 @@ -- See the note on the PrimUnlifted instance for MutableByteArray. -- The same uses of unsafeCoerce# happen here. instance PrimUnlifted (MutablePrimArray s a) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} writeUnliftedArray# a i (MutablePrimArray x) = writeMutableByteArrayArray# a i (unsafeCoerce# x) readUnliftedArray# a i s0 = case readMutableByteArrayArray# a i s0 of @@ -100,9 +100,9 @@ indexUnliftedArray# a i = MutablePrimArray (unsafeCoerce# (indexByteArrayArray# a i)) instance PrimUnlifted (MVar a) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} writeUnliftedArray# a i (MVar x) = writeArrayArrayArray# a i (unsafeCoerce# x) readUnliftedArray# a i s0 = case readArrayArrayArray# a i s0 of @@ -110,9 +110,9 @@ indexUnliftedArray# a i = MVar (unsafeCoerce# (indexArrayArrayArray# a i)) instance PrimUnlifted (TVar a) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} writeUnliftedArray# a i (TVar x) = writeArrayArrayArray# a i (unsafeCoerce# x) readUnliftedArray# a i s0 = case readArrayArrayArray# a i s0 of @@ -120,9 +120,9 @@ indexUnliftedArray# a i = TVar (unsafeCoerce# (indexArrayArrayArray# a i)) instance PrimUnlifted (STRef s a) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} writeUnliftedArray# a i (STRef x) = writeArrayArrayArray# a i (unsafeCoerce# x) readUnliftedArray# a i s0 = case readArrayArrayArray# a i s0 of @@ -131,9 +131,9 @@ STRef (unsafeCoerce# (indexArrayArrayArray# a i)) instance PrimUnlifted (IORef a) where - {-# inline writeUnliftedArray# #-} - {-# inline readUnliftedArray# #-} - {-# inline indexUnliftedArray# #-} + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} writeUnliftedArray# a i (IORef v) = writeUnliftedArray# a i v readUnliftedArray# a i s0 = case readUnliftedArray# a i s0 of (# s1, v #) -> (# s1, IORef v #) @@ -157,7 +157,7 @@ :: (PrimMonad m) => Int -- ^ size -> m (MutableUnliftedArray (PrimState m) a) -{-# inline unsafeNewUnliftedArray #-} +{-# INLINE unsafeNewUnliftedArray #-} unsafeNewUnliftedArray (I# i#) = primitive $ \s -> case newArrayArray# i# s of (# s', maa# #) -> (# s', MutableUnliftedArray maa# #) @@ -172,7 +172,7 @@ mua <- unsafeNewUnliftedArray len setUnliftedArray mua 0 len v pure mua -{-# inline newUnliftedArray #-} +{-# INLINE newUnliftedArray #-} setUnliftedArray :: (PrimMonad m, PrimUnlifted a) @@ -181,7 +181,7 @@ -> Int -- ^ length -> a -- ^ value to fill with -> m () -{-# inline setUnliftedArray #-} +{-# INLINE setUnliftedArray #-} setUnliftedArray mua off len v = loop (len + off - 1) where loop i @@ -190,12 +190,12 @@ -- | Yields the length of an 'UnliftedArray'. sizeofUnliftedArray :: UnliftedArray e -> Int -{-# inline sizeofUnliftedArray #-} +{-# INLINE sizeofUnliftedArray #-} sizeofUnliftedArray (UnliftedArray aa#) = I# (sizeofArrayArray# aa#) -- | Yields the length of a 'MutableUnliftedArray'. sizeofMutableUnliftedArray :: MutableUnliftedArray s e -> Int -{-# inline sizeofMutableUnliftedArray #-} +{-# INLINE sizeofMutableUnliftedArray #-} sizeofMutableUnliftedArray (MutableUnliftedArray maa#) = I# (sizeofMutableArrayArray# maa#) @@ -204,7 +204,7 @@ -> Int -> a -> m () -{-# inline writeUnliftedArray #-} +{-# INLINE writeUnliftedArray #-} writeUnliftedArray (MutableUnliftedArray arr) (I# ix) a = primitive_ (writeUnliftedArray# arr ix a) @@ -212,7 +212,7 @@ => MutableUnliftedArray (PrimState m) a -> Int -> m a -{-# inline readUnliftedArray #-} +{-# INLINE readUnliftedArray #-} readUnliftedArray (MutableUnliftedArray arr) (I# ix) = primitive (readUnliftedArray# arr ix) @@ -220,7 +220,7 @@ => UnliftedArray a -> Int -> a -{-# inline indexUnliftedArray #-} +{-# INLINE indexUnliftedArray #-} indexUnliftedArray (UnliftedArray arr) (I# ix) = indexUnliftedArray# arr ix @@ -234,7 +234,7 @@ unsafeFreezeUnliftedArray (MutableUnliftedArray maa#) = primitive $ \s -> case unsafeFreezeArrayArray# maa# s of (# s', aa# #) -> (# s', UnliftedArray aa# #) -{-# inline unsafeFreezeUnliftedArray #-} +{-# INLINE unsafeFreezeUnliftedArray #-} -- | Determines whether two 'MutableUnliftedArray' values are the same. This is -- object/pointer identity, not based on the contents. @@ -244,7 +244,7 @@ -> Bool sameMutableUnliftedArray (MutableUnliftedArray maa1#) (MutableUnliftedArray maa2#) = isTrue# (sameMutableArrayArray# maa1# maa2#) -{-# inline sameMutableUnliftedArray #-} +{-# INLINE sameMutableUnliftedArray #-} -- | Copies the contents of an immutable array into a mutable array. copyUnliftedArray @@ -255,7 +255,7 @@ -> Int -- ^ offset into source -> Int -- ^ number of elements to copy -> m () -{-# inline copyUnliftedArray #-} +{-# INLINE copyUnliftedArray #-} copyUnliftedArray (MutableUnliftedArray dst) (I# doff) (UnliftedArray src) (I# soff) (I# ln) = @@ -271,7 +271,7 @@ -> Int -- ^ offset into source -> Int -- ^ number of elements to copy -> m () -{-# inline copyMutableUnliftedArray #-} +{-# INLINE copyMutableUnliftedArray #-} copyMutableUnliftedArray (MutableUnliftedArray dst) (I# doff) (MutableUnliftedArray src) (I# soff) (I# ln) = @@ -291,7 +291,7 @@ dst <- unsafeNewUnliftedArray len copyMutableUnliftedArray dst 0 src off len unsafeFreezeUnliftedArray dst -{-# inline freezeUnliftedArray #-} +{-# INLINE freezeUnliftedArray #-} -- | Thaws a portion of an 'UnliftedArray', yielding a 'MutableUnliftedArray'. @@ -303,7 +303,7 @@ -> Int -- ^ offset -> Int -- ^ length -> m (MutableUnliftedArray (PrimState m) a) -{-# inline thawUnliftedArray #-} +{-# INLINE thawUnliftedArray #-} thawUnliftedArray src off len = do dst <- unsafeNewUnliftedArray len copyUnliftedArray dst 0 src off len @@ -315,7 +315,7 @@ -> Int -- ^ offset -> Int -- ^ length -> UnliftedArray a -{-# inline cloneUnliftedArray #-} +{-# INLINE cloneUnliftedArray #-} cloneUnliftedArray src off len = unsafeDupablePerformIO $ do dst <- unsafeNewUnliftedArray len copyUnliftedArray dst 0 src off len @@ -329,7 +329,7 @@ -> Int -- ^ offset -> Int -- ^ length -> m (MutableUnliftedArray (PrimState m) a) -{-# inline cloneMutableUnliftedArray #-} +{-# INLINE cloneMutableUnliftedArray #-} cloneMutableUnliftedArray src off len = do dst <- unsafeNewUnliftedArray len copyMutableUnliftedArray dst 0 src off len diff --git a/Z/Data/Builder.hs b/Z/Data/Builder.hs --- a/Z/Data/Builder.hs +++ b/Z/Data/Builder.hs @@ -64,8 +64,16 @@ , utcTime , localTime , zonedTime + -- * Specialized primitive parser + , encodeWord , encodeWord64, encodeWord32, encodeWord16, encodeWord8 + , encodeInt , encodeInt64 , encodeInt32 , encodeInt16 , encodeInt8 , encodeDouble, encodeFloat + , encodeWordLE , encodeWord64LE , encodeWord32LE , encodeWord16LE + , encodeIntLE , encodeInt64LE , encodeInt32LE , encodeInt16LE , encodeDoubleLE , encodeFloatLE + , encodeWordBE , encodeWord64BE , encodeWord32BE , encodeWord16BE + , encodeIntBE , encodeInt64BE , encodeInt32BE , encodeInt16BE , encodeDoubleBE , encodeFloatBE ) where import Z.Data.Builder.Base import Z.Data.Builder.Numeric import Z.Data.Builder.Time +import Prelude () diff --git a/Z/Data/Builder/Base.hs b/Z/Data/Builder/Base.hs --- a/Z/Data/Builder/Base.hs +++ b/Z/Data/Builder/Base.hs @@ -50,6 +50,13 @@ , charUTF8, string7, char7, word7, string8, char8, word8, word8N, text -- * Builder helpers , paren, parenWhen, curly, square, angle, quotes, squotes, colon, comma, intercalateVec, intercalateList + -- * Specialized primitive parser + , encodeWord , encodeWord64, encodeWord32, encodeWord16, encodeWord8 + , encodeInt , encodeInt64 , encodeInt32 , encodeInt16 , encodeInt8 , encodeDouble, encodeFloat + , encodeWordLE , encodeWord64LE , encodeWord32LE , encodeWord16LE + , encodeIntLE , encodeInt64LE , encodeInt32LE , encodeInt16LE , encodeDoubleLE , encodeFloatLE + , encodeWordBE , encodeWord64BE , encodeWord32BE , encodeWord16BE + , encodeIntBE , encodeInt64BE , encodeInt32BE , encodeInt16BE , encodeDoubleBE , encodeFloatBE ) where import Control.Monad @@ -64,10 +71,11 @@ import Data.Primitive.PrimArray import Z.Data.Array.Unaligned import Z.Data.ASCII -import qualified Z.Data.Text.Base as T -import qualified Z.Data.Text.UTF8Codec as T -import qualified Z.Data.Vector.Base as V -import qualified Z.Data.Array as A +import qualified Z.Data.Text.Base as T +import qualified Z.Data.Text.UTF8Codec as T +import qualified Z.Data.Vector.Base as V +import qualified Z.Data.Array as A +import Prelude hiding (encodeFloat) import System.IO.Unsafe import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) @@ -206,12 +214,12 @@ -- | Shortcut to 'buildWith' 'V.defaultInitSize'. build :: Builder a -> V.Bytes -{-# INLINE build #-} +{-# INLINABLE build #-} build = buildWith V.defaultInitSize -- | Build some bytes and validate if it's UTF8 bytes. buildText :: HasCallStack => Builder a -> T.Text -{-# INLINE buildText #-} +{-# INLINABLE buildText #-} buildText = T.validate . buildWith V.defaultInitSize -- | Build some bytes assuming it's UTF8 encoding. @@ -220,13 +228,13 @@ -- Check 'Z.Data.Text.ShowT' for UTF8 encoding builders. This functions is intended to -- be used in debug only. unsafeBuildText :: Builder a -> T.Text -{-# INLINE unsafeBuildText #-} +{-# INLINABLE unsafeBuildText #-} unsafeBuildText = T.Text . buildWith V.defaultInitSize -- | Run Builder with doubling buffer strategy, which is suitable -- for building short bytes. buildWith :: Int -> Builder a -> V.Bytes -{-# INLINABLE buildWith #-} +{-# INLINE buildWith #-} buildWith initSiz (Builder b) = unsafePerformIO $ do buf <- newPrimArray initSiz loop =<< b (\ _ -> return . Done) (Buffer buf 0) @@ -249,7 +257,7 @@ -- | Shortcut to 'buildChunksWith' 'V.defaultChunkSize'. buildChunks :: Builder a -> [V.Bytes] -{-# INLINE buildChunks #-} +{-# INLINABLE buildChunks #-} buildChunks = buildChunksWith V.smallChunkSize V.defaultChunkSize -- | Run Builder with inserting chunk strategy, which is suitable @@ -257,7 +265,7 @@ -- -- Note the building process is lazy, building happens when list chunks are consumed. buildChunksWith :: Int -> Int -> Builder a -> [V.Bytes] -{-# INLINABLE buildChunksWith #-} +{-# INLINE buildChunksWith #-} buildChunksWith initSiz chunkSiz (Builder b) = unsafePerformIO $ do buf <- newPrimArray initSiz loop =<< b (\ _ -> return . Done) (Buffer buf 0) @@ -313,11 +321,19 @@ {-# INLINE writeN #-} writeN !n f = Builder (\ k buffer@(Buffer buf offset) -> do siz <- getSizeofMutablePrimArray buf - if n + offset <= siz - then f buf offset >> k () (Buffer buf (offset+n)) + let n' = n + offset + if n' <= siz + then f buf offset >> k () (Buffer buf n') else return (BufferFull buffer n (\ (Buffer buf' offset') -> do f buf' offset' >> k () (Buffer buf' (offset'+n))))) +{- These rules are bascially what inliner do so no need to mess up with them +{-# RULES + "ensureN/merge" forall n1 f1 n2 f2. append (ensureN n1 f1) (ensureN n2 f2) = ensureN (n1 + n2) (\ mba i -> f1 mba i >>= \ i' -> f2 mba i') #-} +{-# RULES + "writeN/merge" forall n1 f1 n2 f2. append (writeN n1 f1) (writeN n2 f2) = writeN (n1 + n2) (\ mba i -> f1 mba i >> f2 mba (i+n1)) #-} +-} + -- | Write a primitive type in host byte order. -- -- @ @@ -326,53 +342,68 @@ -- @ encodePrim :: forall a. Unaligned a => a -> Builder () {-# INLINE encodePrim #-} -{-# SPECIALIZE INLINE encodePrim :: Word -> Builder () #-} -{-# SPECIALIZE INLINE encodePrim :: Word64 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrim :: Word32 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrim :: Word16 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrim :: Word8 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrim :: Int -> Builder () #-} -{-# SPECIALIZE INLINE encodePrim :: Int64 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrim :: Int32 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrim :: Int16 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrim :: Int8 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrim :: Double -> Builder () #-} -{-# SPECIALIZE INLINE encodePrim :: Float -> Builder () #-} encodePrim x = do writeN n (\ mpa i -> writePrimWord8ArrayAs mpa i x) where n = getUnalignedSize (unalignedSize @a) +#define ENCODE_HOST(f, type) \ + f :: type -> Builder (); {-# INLINE f #-}; f = encodePrim; \ + -- ^ Encode type in host endian order. + +ENCODE_HOST(encodeWord , Word ) +ENCODE_HOST(encodeWord64, Word64 ) +ENCODE_HOST(encodeWord32, Word32 ) +ENCODE_HOST(encodeWord16, Word16 ) +ENCODE_HOST(encodeWord8 , Word8 ) +ENCODE_HOST(encodeInt , Int ) +ENCODE_HOST(encodeInt64 , Int64 ) +ENCODE_HOST(encodeInt32 , Int32 ) +ENCODE_HOST(encodeInt16 , Int16 ) +ENCODE_HOST(encodeInt8 , Int8 ) +ENCODE_HOST(encodeDouble, Double ) +ENCODE_HOST(encodeFloat , Float ) + -- | Write a primitive type with little endianess. encodePrimLE :: forall a. Unaligned (LE a) => a -> Builder () {-# INLINE encodePrimLE #-} -{-# SPECIALIZE INLINE encodePrimLE :: Word -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimLE :: Word64 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimLE :: Word32 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimLE :: Word16 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimLE :: Int -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimLE :: Int64 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimLE :: Int32 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimLE :: Int16 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimLE :: Double -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimLE :: Float -> Builder () #-} encodePrimLE = encodePrim . LE +#define ENCODE_LE(f, type) \ + f :: type -> Builder (); {-# INLINE f #-}; f = encodePrimLE; \ + -- ^ Encode type in little endian order. + +ENCODE_LE(encodeWordLE , Word ) +ENCODE_LE(encodeWord64LE, Word64 ) +ENCODE_LE(encodeWord32LE, Word32 ) +ENCODE_LE(encodeWord16LE, Word16 ) +ENCODE_LE(encodeIntLE , Int ) +ENCODE_LE(encodeInt64LE , Int64 ) +ENCODE_LE(encodeInt32LE , Int32 ) +ENCODE_LE(encodeInt16LE , Int16 ) +ENCODE_LE(encodeDoubleLE, Double ) +ENCODE_LE(encodeFloatLE , Float ) + -- | Write a primitive type with big endianess. encodePrimBE :: forall a. Unaligned (BE a) => a -> Builder () {-# INLINE encodePrimBE #-} -{-# SPECIALIZE INLINE encodePrimBE :: Word -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimBE :: Word64 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimBE :: Word32 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimBE :: Word16 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimBE :: Int -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimBE :: Int64 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimBE :: Int32 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimBE :: Int16 -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimBE :: Double -> Builder () #-} -{-# SPECIALIZE INLINE encodePrimBE :: Float -> Builder () #-} encodePrimBE = encodePrim . BE +#define ENCODE_BE(f, type) \ + f :: type -> Builder (); {-# INLINE f #-}; f = encodePrimBE; \ + -- ^ Encode type in little endian order. + +ENCODE_BE(encodeWordBE , Word ) +ENCODE_BE(encodeWord64BE, Word64 ) +ENCODE_BE(encodeWord32BE, Word32 ) +ENCODE_BE(encodeWord16BE, Word16 ) +ENCODE_BE(encodeIntBE , Int ) +ENCODE_BE(encodeInt64BE , Int64 ) +ENCODE_BE(encodeInt32BE , Int32 ) +ENCODE_BE(encodeInt16BE , Int16 ) +ENCODE_BE(encodeDoubleBE, Double ) +ENCODE_BE(encodeFloatBE , Float ) + -------------------------------------------------------------------------------- -- | Turn 'String' into 'Builder' with UTF8 encoding @@ -403,7 +434,7 @@ writeN len (\ mba i -> copyPtrToMutablePrimArray mba i (Ptr addr#) len) packUTF8Addr :: Addr# -> Builder () -{-# INLINE packUTF8Addr #-} +{-# INLINABLE packUTF8Addr #-} packUTF8Addr addr0# = validateAndCopy addr0# where len = fromIntegral . unsafeDupablePerformIO $ V.c_strlen addr0# @@ -433,8 +464,7 @@ -- Codepoints beyond @'\x7F'@ will be chopped. char7 :: Char -> Builder () {-# INLINE char7 #-} -char7 chr = - writeN 1 (\ mpa i -> writePrimWord8ArrayAs mpa i (c2w chr .&. 0x7F)) +char7 chr = writeN 1 (\ mpa i -> writePrimWord8ArrayAs mpa i (c2w chr .&. 0x7F)) -- | Turn 'Word8' into 'Builder' with ASCII7 encoding -- @@ -475,8 +505,7 @@ -- by this builder may not be legal UTF8 encoding bytes. word8N :: Int -> Word8 -> Builder () {-# INLINE word8N #-} -word8N x w8 = do - writeN x (\ mpa i -> setPrimArray mpa i x w8) +word8N x w8 = writeN x (\ mpa i -> setPrimArray mpa i x w8) -- | Write UTF8 encoded 'Text' using 'Builder'. -- diff --git a/Z/Data/Builder/Numeric.hs b/Z/Data/Builder/Numeric.hs --- a/Z/Data/Builder/Numeric.hs +++ b/Z/Data/Builder/Numeric.hs @@ -84,6 +84,7 @@ {-# INLINE defaultIFormat #-} defaultIFormat = IFormat 0 NoPadding False +-- | Padding format. data Padding = NoPadding | RightSpacePadding | LeftSpacePadding | ZeroPadding deriving (Show, Eq, Ord, Enum) instance Arbitrary Padding where @@ -147,7 +148,7 @@ pad = case padding of NoPadding -> 0 RightSpacePadding -> 1 LeftSpacePadding -> 2 - ZeroPadding -> 3 + _ -> 3 -- | Internal formatting in haskell, it can be used with any bounded integral type. -- @@ -463,13 +464,13 @@ -- | Decimal digit to ASCII digit. i2wDec :: (Integral a) => a -> Word8 -{-# INLINE i2wDec #-} +{-# INLINABLE i2wDec #-} {-# SPECIALIZE INLINE i2wDec :: Int -> Word8 #-} i2wDec v = DIGIT_0 + fromIntegral v -- | Hexadecimal digit to ASCII char. i2wHex :: (Integral a) => a -> Word8 -{-# INLINE i2wHex #-} +{-# INLINABLE i2wHex #-} {-# SPECIALIZE INLINE i2wHex :: Int -> Word8 #-} i2wHex v | v <= 9 = DIGIT_0 + fromIntegral v @@ -477,7 +478,7 @@ -- | Hexadecimal digit to UPPERCASED ASCII char. i2wHexUpper :: (Integral a) => a -> Word8 -{-# INLINE i2wHexUpper #-} +{-# INLINABLE i2wHexUpper #-} {-# SPECIALIZE INLINE i2wHexUpper :: Int -> Word8 #-} i2wHexUpper v | v <= 9 = DIGIT_0 + fromIntegral v @@ -502,7 +503,17 @@ -- @ -- hex :: forall a. (FiniteBits a, Integral a) => a -> Builder () -{-# INLINE hex #-} +{-# INLINABLE hex #-} +{-# SPECIALIZE INLINE hex :: Int -> Builder () #-} +{-# SPECIALIZE INLINE hex :: Int8 -> Builder () #-} +{-# SPECIALIZE INLINE hex :: Int16 -> Builder () #-} +{-# SPECIALIZE INLINE hex :: Int32 -> Builder () #-} +{-# SPECIALIZE INLINE hex :: Int64 -> Builder () #-} +{-# SPECIALIZE INLINE hex :: Word -> Builder () #-} +{-# SPECIALIZE INLINE hex :: Word8 -> Builder () #-} +{-# SPECIALIZE INLINE hex :: Word16 -> Builder () #-} +{-# SPECIALIZE INLINE hex :: Word32 -> Builder () #-} +{-# SPECIALIZE INLINE hex :: Word64 -> Builder () #-} hex w = writeN hexSiz (go w (hexSiz-2)) where bitSiz = finiteBitSize (undefined :: a) @@ -524,7 +535,17 @@ -- | The UPPERCASED version of 'hex'. hexUpper :: forall a. (FiniteBits a, Integral a) => a -> Builder () -{-# INLINE hexUpper #-} +{-# INLINABLE hexUpper #-} +{-# SPECIALIZE INLINE hexUpper :: Int -> Builder () #-} +{-# SPECIALIZE INLINE hexUpper :: Int8 -> Builder () #-} +{-# SPECIALIZE INLINE hexUpper :: Int16 -> Builder () #-} +{-# SPECIALIZE INLINE hexUpper :: Int32 -> Builder () #-} +{-# SPECIALIZE INLINE hexUpper :: Int64 -> Builder () #-} +{-# SPECIALIZE INLINE hexUpper :: Word -> Builder () #-} +{-# SPECIALIZE INLINE hexUpper :: Word8 -> Builder () #-} +{-# SPECIALIZE INLINE hexUpper :: Word16 -> Builder () #-} +{-# SPECIALIZE INLINE hexUpper :: Word32 -> Builder () #-} +{-# SPECIALIZE INLINE hexUpper :: Word64 -> Builder () #-} hexUpper w = writeN hexSiz (go w (hexSiz-2)) where bitSiz = finiteBitSize (undefined :: a) @@ -725,7 +746,7 @@ -- | Decimal encoding of a 'Double', note grisu only handles strictly positive finite numbers. grisu3 :: Double -> ([Int], Int) -{-# INLINE grisu3 #-} +{-# INLINABLE grisu3 #-} grisu3 d = unsafePerformIO $ do (MutableByteArray pBuf) <- newByteArray GRISU3_DOUBLE_BUF_LEN (len, (e, success)) <- allocPrimUnsafe $ \ pLen -> @@ -749,7 +770,7 @@ -- | Decimal encoding of a 'Float', note grisu3_sp only handles strictly positive finite numbers. grisu3_sp :: Float -> ([Int], Int) -{-# INLINE grisu3_sp #-} +{-# INLINABLE grisu3_sp #-} grisu3_sp d = unsafePerformIO $ do (MutableByteArray pBuf) <- newByteArray GRISU3_SINGLE_BUF_LEN (len, (e, success)) <- allocPrimUnsafe $ \ pLen -> diff --git a/Z/Data/Builder/Numeric/DigitTable.hs b/Z/Data/Builder/Numeric/DigitTable.hs --- a/Z/Data/Builder/Numeric/DigitTable.hs +++ b/Z/Data/Builder/Numeric/DigitTable.hs @@ -17,6 +17,7 @@ import GHC.Word decDigitTable :: Ptr Word16 +{-# INLINABLE decDigitTable #-} decDigitTable = Ptr "0001020304050607080910111213141516171819\ \2021222324252627282930313233343536373839\ \4041424344454647484950515253545556575859\ @@ -24,6 +25,7 @@ \8081828384858687888990919293949596979899"# hexDigitTable :: Ptr Word8 +{-# INLINABLE hexDigitTable #-} hexDigitTable = Ptr "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f\ \202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f\ \404142434445464748494a4b4c4d4e4f505152535455565758595a5b5c5d5e5f\ @@ -34,6 +36,7 @@ \e0e1e2e3e4e5e6e7e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfeff"# hexDigitTableUpper :: Ptr Word8 +{-# INLINABLE hexDigitTableUpper #-} hexDigitTableUpper = Ptr "000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F\ \202122232425262728292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F\ \404142434445464748494A4B4C4D4E4F505152535455565758595A5B5C5D5E5F\ diff --git a/Z/Data/Builder/Time.hs b/Z/Data/Builder/Time.hs --- a/Z/Data/Builder/Time.hs +++ b/Z/Data/Builder/Time.hs @@ -18,6 +18,10 @@ , utcTime , localTime , zonedTime + -- * internal + , twoDigits + , toGregorian' + , toGregorianInt64 ) where import Control.Monad @@ -32,23 +36,63 @@ import Z.Data.ASCII -- | @YYYY-mm-dd@. +-- day :: Day -> Builder () {-# INLINE day #-} -day dd = encodeYear yr <> - B.encodePrim (HYPHEN, mh, ml, HYPHEN, dh, dl) - where (yr, m, d) = toGregorian dd - (mh, ml) = twoDigits m - (dh, dl) = twoDigits d - encodeYear y - | y >= 1000 = B.integer y - | y >= 0 = B.encodePrim (padYear y) - | y >= -999 = B.encodePrim (MINUS, padYear y) - | otherwise = B.integer y - padYear y = - let (ab,c) = (fromIntegral y :: Int) `quotRem` 10 - (a, b) = ab `quotRem` 10 - in (DIGIT_0, i2wDec a, i2wDec b, i2wDec c) +day dd = encodeYear yr <> B.encodePrim (HYPHEN, mh, ml, HYPHEN, dh, dl) + where + (yr, m, d) = toGregorian' dd + (mh, ml) = twoDigits m + (dh, dl) = twoDigits d + encodeYear y + | y >= 1000 = B.integer y + | y >= 0 = B.encodePrim (padYear y) + | y >= -999 = B.encodePrim (MINUS, padYear y) + | otherwise = B.integer y + padYear y = + let (ab,c) = (fromIntegral y :: Int) `quotRem` 10 + (a, b) = ab `quotRem` 10 + in (DIGIT_0, i2wDec a, i2wDec b, i2wDec c) +-- | Faster 'toGregorian' with 'toGregorianInt64' as the common case path. +toGregorian' :: Day -> (Integer, Int, Int) +{-# INLINE toGregorian' #-} +toGregorian' dd@(ModifiedJulianDay mjd) + | -9223372036854775808 <= mjd && mjd <= 9223372036854097232 = toGregorianInt64 (fromIntegral mjd) + | otherwise = toGregorian dd + +-- | Faster common case for small days (-9223372036854775808 ~ 9223372036854097232). +-- +toGregorianInt64 :: Int64 -> (Integer, Int, Int) +{-# INLINABLE toGregorianInt64 #-} +toGregorianInt64 mjd = year' `seq` month `seq` day_ `seq` (year', month, day_) + where + a = mjd + 678575 + quadcent = div a 146097 + b = mod a 146097 + cent = min (div b 36524) 3 + c = b - (cent * 36524) + quad = div c 1461 + d = mod c 1461 + y = min (div d 365) 3 + yd = fromIntegral (d - (y * 365) + 1) + year = quadcent * 400 + cent * 100 + quad * 4 + y + 1 + year' = fromIntegral year + isLeap = (rem year 4 == 0) && ((rem year 400 == 0) || not (rem year 100 == 0)) + (month, day_) = findMonthDay (if isLeap then monthListLeap else monthList) yd 1 + + findMonthDay :: [Int] -> Int -> Int -> (Int, Int) + findMonthDay (n : ns) !yd_ !m | yd_ > n = findMonthDay ns (yd_ - n) (m + 1) + findMonthDay _ !yd_ !m = (m, yd_) + +monthList :: [Int] +{-# NOINLINE monthList #-} +monthList = [ 31 , 28 , 31 , 30 , 31 , 30 , 31 , 31 , 30 , 31 , 30 , 31 ] + +monthListLeap :: [Int] +{-# NOINLINE monthListLeap #-} +monthListLeap = [ 31 , 29 , 31 , 30 , 31 , 30 , 31 , 31 , 30 , 31 , 30 , 31 ] + -- | @HH-MM-SS@. timeOfDay :: TimeOfDay -> Builder () {-# INLINE timeOfDay #-} @@ -103,7 +147,7 @@ dayTime d t = day d >> B.word8 LETTER_T >> timeOfDay64 t timeOfDay64 :: TimeOfDay64 -> Builder () -{-# INLINE timeOfDay64 #-} +{-# INLINABLE timeOfDay64 #-} timeOfDay64 (!h, !m, !s) = do B.encodePrim (hh, hl, COLON, mh, ml, COLON, sh, sl) when (frac /= 0) $ do @@ -138,4 +182,3 @@ {-# INLINE twoDigits #-} twoDigits a = (i2wDec hi, i2wDec lo) where (hi,lo) = a `quotRem` 10 - diff --git a/Z/Data/CBytes.hs b/Z/Data/CBytes.hs --- a/Z/Data/CBytes.hs +++ b/Z/Data/CBytes.hs @@ -40,7 +40,6 @@ import Data.Foldable (foldlM) import Data.Hashable (Hashable (..)) import qualified Data.List as List -import Data.Primitive.PrimArray import Data.Word import Foreign.C.String import GHC.CString @@ -61,7 +60,6 @@ import System.IO.Unsafe (unsafeDupablePerformIO) import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..)) import Text.Read (Read (..)) -import Z.Data.Array import qualified Z.Data.Builder as B import Z.Data.JSON.Base ((.!), (.:), (.=)) import qualified Z.Data.JSON.Base as JSON @@ -103,7 +101,7 @@ -- | Construct a 'CBytes' from arbitrary array, result will be trimmed down to first @\\NUL@ byte if there's any. fromPrimArray :: PrimArray Word8 -> CBytes -{-# INLINE fromPrimArray #-} +{-# INLINABLE fromPrimArray #-} fromPrimArray arr = runST (do let l = case V.elemIndex 0 arr of Just i -> i @@ -130,7 +128,7 @@ :: PrimMonad m => MutablePrimArray (PrimState m) Word8 -> m CBytes -{-# INLINE fromMutablePrimArray #-} +{-# INLINABLE fromMutablePrimArray #-} fromMutablePrimArray marr = do let l = sizeofMutablePrimArray marr arr <- unsafeFreezePrimArray marr @@ -213,6 +211,7 @@ let l = sizeofPrimArray pa copyPrimArray (MutablePrimArray mba# :: MutablePrimArray RealWorld Word8) i pa 0 l +-- | Index a 'CBytes' until a \\NUL terminator(or to the end of the array if there's none). indexBACBytes :: BA# Word8 -> Int -> CBytes {-# INLINE indexBACBytes #-} indexBACBytes ba# i = runST (do @@ -257,7 +256,7 @@ -- | Concatenate two 'CBytes'. append :: CBytes -> CBytes -> CBytes -{-# INLINABLE append #-} +{-# INLINE append #-} append strA@(CBytes pa) strB@(CBytes pb) | lenA == 0 = strB | lenB == 0 = strA @@ -461,12 +460,12 @@ -- | /O(1)/, convert to 'V.Bytes', which can be processed by vector combinators. toBytes :: CBytes -> V.Bytes -{-# INLINABLE toBytes #-} +{-# INLINE toBytes #-} toBytes (CBytes arr) = V.PrimVector arr 0 (sizeofPrimArray arr - 1) -- | /O(1)/, convert to 'V.Bytes' with its NULL terminator. toBytes' :: CBytes -> V.Bytes -{-# INLINABLE toBytes' #-} +{-# INLINE toBytes' #-} toBytes' (CBytes arr) = V.PrimVector arr 0 (sizeofPrimArray arr) -- | /O(n)/, convert from 'V.Bytes' @@ -492,21 +491,21 @@ -- -- Throw 'T.InvalidUTF8Exception' in case of invalid codepoint. toText :: HasCallStack => CBytes -> T.Text -{-# INLINABLE toText #-} +{-# INLINE toText #-} toText = T.validate . toBytes -- | /O(n)/, convert to 'T.Text' using UTF8 encoding assumption. -- -- Return 'Nothing' in case of invalid codepoint. toTextMaybe :: CBytes -> Maybe T.Text -{-# INLINABLE toTextMaybe #-} +{-# INLINE toTextMaybe #-} toTextMaybe = T.validateMaybe . toBytes -- | /O(n)/, convert from 'T.Text', -- -- Result will be trimmed down to first @\\NUL@ byte if there's any. fromText :: T.Text -> CBytes -{-# INLINABLE fromText #-} +{-# INLINE fromText #-} fromText = fromBytes . T.getUTF8Bytes -- | Write 'CBytes' \'s byte sequence to buffer. @@ -514,19 +513,19 @@ -- This function is different from 'T.Print' instance in that it directly write byte sequence without -- checking if it's UTF8 encoded. toBuilder :: CBytes -> B.Builder () -{-# INLINABLE toBuilder #-} +{-# INLINE toBuilder #-} toBuilder = B.bytes . toBytes -- | Write 'CBytes' \'s byte sequence to buffer, with its NULL terminator. -- toBuilder' :: CBytes -> B.Builder () -{-# INLINABLE toBuilder' #-} +{-# INLINE toBuilder' #-} toBuilder' = B.bytes . toBytes' -- | Build a 'CBytes' with builder, will automatically be trimmed down to first @\\NUL@ byte if there's any, -- or append with one if there's none. buildCBytes :: B.Builder a -> CBytes -{-# INLINABLE buildCBytes #-} +{-# INLINE buildCBytes #-} buildCBytes b = fromBytes (B.build (b >> B.word8 0)) -------------------------------------------------------------------------------- diff --git a/Z/Data/JSON.hs b/Z/Data/JSON.hs --- a/Z/Data/JSON.hs +++ b/Z/Data/JSON.hs @@ -206,7 +206,7 @@ -------------------------------------------------------------------------------- symbCase :: Char -> String -> T.Text -{-# INLINE symbCase #-} +{-# INLINABLE symbCase #-} symbCase sym = T.pack . go . applyFirst toLower where go [] = [] diff --git a/Z/Data/JSON/Base.hs b/Z/Data/JSON/Base.hs --- a/Z/Data/JSON/Base.hs +++ b/Z/Data/JSON/Base.hs @@ -200,7 +200,7 @@ -> T.Text -- ^ The JSON value type you expecting to meet. -> Value -- ^ The actual value encountered. -> Converter a -{-# INLINE typeMismatch #-} +{-# INLINABLE typeMismatch #-} typeMismatch name expected v = fail' $ T.concat ["converting ", name, " failed, expected ", expected, ", encountered ", actual] where @@ -324,7 +324,7 @@ withEmbeddedJSON :: T.Text -- ^ data type name -> (Value -> Converter a) -- ^ a inner converter which will get the converted 'Value'. -> Value -> Converter a -- a converter take a JSON String -{-# INLINE withEmbeddedJSON #-} +{-# INLINABLE withEmbeddedJSON #-} withEmbeddedJSON _ innerConverter (String txt) = Converter (\ kf k -> case decode' (T.getUTF8Bytes txt) of Right v -> runConverter (innerConverter v) (\ paths msg -> kf (Embedded:paths) msg) k @@ -441,6 +441,7 @@ -- | @Settings T.pack T.pack False@ defaultSettings :: Settings +{-# INLINE defaultSettings #-} defaultSettings = Settings T.pack T.pack False -------------------------------------------------------------------------------- diff --git a/Z/Data/JSON/Builder.hs b/Z/Data/JSON/Builder.hs --- a/Z/Data/JSON/Builder.hs +++ b/Z/Data/JSON/Builder.hs @@ -37,12 +37,12 @@ -- -- Don't use chars which need escaped in label. kv :: T.Text -> B.Builder () -> B.Builder () -{-# INLINE kv #-} +{-# INLINABLE kv #-} l `kv` b = B.quotes (B.text l) >> B.colon >> b -- | Use @:@ as separator to connect a label(escape the label and add quotes) with field builders. kv' :: T.Text -> B.Builder () -> B.Builder () -{-# INLINE kv' #-} +{-# INLINABLE kv' #-} l `kv'` b = string l >> B.colon >> b -- | Encode a 'Value', you can use this function with 'toValue' to get 'encodeJSON' with a small overhead. @@ -57,19 +57,19 @@ value _ = "null" array :: V.Vector Value -> B.Builder () -{-# INLINE array #-} +{-# INLINABLE array #-} array = B.square . B.intercalateVec B.comma value array' :: (a -> B.Builder ()) -> V.Vector a -> B.Builder () -{-# INLINE array' #-} +{-# INLINABLE array' #-} array' f = B.square . B.intercalateVec B.comma f object :: V.Vector (T.Text, Value) -> B.Builder () -{-# INLINE object #-} +{-# INLINABLE object #-} object = B.curly . B.intercalateVec B.comma (\ (k, v) -> k `kv'` value v) object' :: (a -> B.Builder ()) -> V.Vector (T.Text, a) -> B.Builder () -{-# INLINE object' #-} +{-# INLINABLE object' #-} object' f = B.curly . B.intercalateVec B.comma (\ (k, v) -> k `kv'` f v) -- | Escape text into JSON string and add double quotes, escaping rules: @@ -87,7 +87,7 @@ -- @ -- string :: T.Text -> B.Builder () -{-# INLINE string #-} +{-# INLINABLE string #-} string = T.escapeTextJSON -------------------------------------------------------------------------------- @@ -132,6 +132,7 @@ -- @ -- prettyValue :: Value -> B.Builder () +{-# INLINABLE prettyValue #-} prettyValue = prettyValue' 4 0 @@ -149,7 +150,7 @@ prettyValue' _ !ind _ = B.word8N ind SPACE >> "null" arrayPretty :: Int -> Int -> V.Vector Value -> B.Builder () -{-# INLINE arrayPretty #-} +{-# INLINABLE arrayPretty #-} arrayPretty idpl ind vs | V.null vs = B.word8N ind SPACE >> B.square (return ()) | otherwise = do @@ -166,7 +167,7 @@ ind' = ind + idpl objectPretty :: Int -> Int -> V.Vector (T.Text, Value) -> B.Builder () -{-# INLINE objectPretty #-} +{-# INLINABLE objectPretty #-} objectPretty idpl ind kvs | V.null kvs = B.word8N ind SPACE >> B.curly (return ()) | otherwise = do diff --git a/Z/Data/JSON/Converter.hs b/Z/Data/JSON/Converter.hs --- a/Z/Data/JSON/Converter.hs +++ b/Z/Data/JSON/Converter.hs @@ -47,6 +47,7 @@ show = T.toString instance T.Print ConvertError where + {-# INLINABLE toUTF8BuilderP #-} toUTF8BuilderP _ (ConvertError [] msg) = T.toUTF8Builder msg toUTF8BuilderP _ (ConvertError paths msg) = do mapM_ renderPath (reverse paths) diff --git a/Z/Data/JSON/Value.hs b/Z/Data/JSON/Value.hs --- a/Z/Data/JSON/Value.hs +++ b/Z/Data/JSON/Value.hs @@ -154,7 +154,7 @@ -- carriage pure, and tab. skipSpaces :: P.Parser () {-# INLINE skipSpaces #-} -skipSpaces = P.skipWhile (\ w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09) +skipSpaces = P.skipWhile (\ w -> w <= 0x20 && (w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09)) -- | JSON 'Value' parser. value :: P.Parser Value @@ -174,12 +174,12 @@ -- | parse json array with leading SQUARE_LEFT. array :: P.Parser (V.Vector Value) -{-# INLINE array #-} +{-# INLINABLE array #-} array = P.word8 SQUARE_LEFT *> array_ -- | parse json array without leading SQUARE_LEFT. array_ :: P.Parser (V.Vector Value) -{-# INLINABLE array_ #-} +{-# INLINE array_ #-} array_ = do skipSpaces w <- P.peek @@ -199,12 +199,12 @@ -- | parse json array with leading 'CURLY_LEFT'. object :: P.Parser (V.Vector (T.Text, Value)) -{-# INLINE object #-} +{-# INLINABLE object #-} object = P.word8 CURLY_LEFT *> object_ -- | parse json object without leading 'CURLY_LEFT'. object_ :: P.Parser (V.Vector (T.Text, Value)) -{-# INLINABLE object_ #-} +{-# INLINE object_ #-} object_ = do skipSpaces w <- P.peek @@ -228,7 +228,7 @@ -------------------------------------------------------------------------------- string :: P.Parser T.Text -{-# INLINE string #-} +{-# INLINABLE string #-} string = P.word8 DOUBLE_QUOTE *> string_ string_ :: P.Parser T.Text @@ -268,20 +268,20 @@ -- | Convert IEEE float to scientific notition. floatToScientific :: Float -> Scientific -{-# INLINE floatToScientific #-} +{-# INLINABLE floatToScientific #-} floatToScientific rf | rf < 0 = -(fromFloatingDigits (B.grisu3_sp (-rf))) | rf == 0 = 0 | otherwise = fromFloatingDigits (B.grisu3_sp rf) -- | Convert IEEE double to scientific notition. doubleToScientific :: Double -> Scientific -{-# INLINE doubleToScientific #-} +{-# INLINABLE doubleToScientific #-} doubleToScientific rf | rf < 0 = -(fromFloatingDigits (B.grisu3 (-rf))) | rf == 0 = 0 | otherwise = fromFloatingDigits (B.grisu3 rf) fromFloatingDigits :: ([Int], Int) -> Scientific -{-# INLINE fromFloatingDigits #-} +{-# INLINABLE fromFloatingDigits #-} fromFloatingDigits (digits, e) = go digits 0 0 where -- There's no way a float or double has more digits a 'Int64' can't handle diff --git a/Z/Data/Parser.hs b/Z/Data/Parser.hs --- a/Z/Data/Parser.hs +++ b/Z/Data/Parser.hs @@ -30,7 +30,7 @@ , Parser , () -- * Running a parser - , parse, parse', parseChunk, ParseChunks, parseChunks, finishParsing + , parse, parse', parseChunk, parseChunkList, ParseChunks, parseChunks, finishParsing , runAndKeepTrack, match -- * Basic parsers , ensureN, endOfInput, atEnd, currentChunk @@ -41,7 +41,7 @@ , scan, scanChunks, peekMaybe, peek, satisfy, satisfyWith , anyWord8, word8, char8, anyChar8, anyCharUTF8, charUTF8, char7, anyChar7 , skipWord8, endOfLine, skip, skipWhile, skipSpaces - , take, takeN, takeTill, takeWhile, takeWhile1, takeRemaining, bytes, bytesCI + , take, takeN, takeTill, takeWhile, takeWhile1, takeRemaining, takeUTF8, bytes, bytesCI , text -- * Numeric parsers -- ** Decimal diff --git a/Z/Data/Parser/Base.hs b/Z/Data/Parser/Base.hs --- a/Z/Data/Parser/Base.hs +++ b/Z/Data/Parser/Base.hs @@ -19,7 +19,7 @@ , Parser(..) , () -- * Running a parser - , parse, parse', parseChunk, ParseChunks, parseChunks, finishParsing + , parse, parse', parseChunk, parseChunkList, ParseChunks, parseChunks, finishParsing , runAndKeepTrack, match -- * Basic parsers , ensureN, endOfInput, currentChunk, atEnd @@ -30,7 +30,7 @@ , scan, scanChunks, peekMaybe, peek, satisfy, satisfyWith , anyWord8, word8, char8, anyChar8, anyCharUTF8, charUTF8, char7, anyChar7 , skipWord8, endOfLine, skip, skipWhile, skipSpaces - , take, takeN, takeTill, takeWhile, takeWhile1, takeRemaining, bytes, bytesCI + , take, takeN, takeTill, takeWhile, takeWhile1, takeRemaining, takeUTF8, bytes, bytesCI , text -- * Error reporting , fail', failWithInput, unsafeLiftIO @@ -44,6 +44,7 @@ ) where import Control.Applicative +import Control.Exception (assert) import Control.Monad import Control.Monad.Primitive import qualified Control.Monad.Fail as Fail @@ -117,21 +118,29 @@ -- It seems eta-expand all params to ensure parsers are saturated is helpful instance Functor Parser where - fmap f (Parser pa) = Parser (\ kf k s inp -> pa kf (\ s' -> k s' . f) s inp) + fmap = fmapParser {-# INLINE fmap #-} a <$ Parser pb = Parser (\ kf k s inp -> pb kf (\ s' _ -> k s' a) s inp) {-# INLINE (<$) #-} +fmapParser :: (a -> b) -> Parser a -> Parser b +{-# INLINE fmapParser #-} +fmapParser f (Parser pa) = Parser (\ kf k s inp -> pa kf (\ s' -> k s' . f) s inp) + instance Applicative Parser where pure x = Parser (\ _ k s inp -> k s x inp) {-# INLINE pure #-} - Parser pf <*> Parser pa = Parser (\ kf k s inp -> pf kf (\ s' f -> pa kf (\ s'' -> k s'' . f) s') s inp) + (<*>) = apParser {-# INLINE (<*>) #-} Parser pa *> Parser pb = Parser (\ kf k s inp -> pa kf (\ s' _ -> pb kf k s') s inp) {-# INLINE (*>) #-} Parser pa <* Parser pb = Parser (\ kf k s inp -> pa kf (\ s' x -> pb kf (\ s'' _ -> k s'' x) s') s inp) {-# INLINE (<*) #-} +apParser :: Parser (a -> b) -> Parser a -> Parser b +{-# INLINE apParser #-} +apParser (Parser pf) (Parser pa) = Parser (\ kf k s inp -> pf kf (\ s' f -> pa kf (\ s'' -> k s'' . f) s') s inp) + instance Monad Parser where return = pure {-# INLINE return #-} @@ -175,11 +184,10 @@ empty = fail' "Z.Data.Parser.Base(Alternative).empty" {-# INLINE empty #-} f <|> g = do - (r, bss) <- runAndKeepTrack f + (r, consumed) <- runAndKeepTrack f case r of Success x inp -> Parser (\ _ k s _ -> k s x inp) - Failure _ _ -> let !bs = V.concat (reverse bss) - in Parser (\ kf k s _ -> runParser g kf k s bs) + Failure _ _ -> Parser (\ kf k s _ -> runParser g kf k s consumed) _ -> error "Z.Data.Parser.Base: impossible" {-# INLINE (<|>) #-} @@ -195,16 +203,34 @@ -- | Parse the complete input, without resupplying parse' :: Parser a -> V.Bytes -> Either ParseError a -{-# INLINE parse' #-} -parse' (Parser p) inp = snd $ finishParsing (runRW# (\ s -> - unsafeCoerce# (p Failure (\ _ r -> Success r) (unsafeCoerce# s) inp))) +{-# INLINABLE parse' #-} +parse' p = snd . parse p -- | Parse the complete input, without resupplying, return the rest bytes parse :: Parser a -> V.Bytes -> (V.Bytes, Either ParseError a) {-# INLINE parse #-} -parse (Parser p) inp = finishParsing (runRW# ( \ s -> - unsafeCoerce# (p Failure (\ _ r -> Success r) (unsafeCoerce# s) inp))) +parse (Parser p) = \ inp -> + case (runRW# ( \ s -> unsafeCoerce# (p Failure (\ _ r -> Success r) (unsafeCoerce# s) inp))) of + Success a rest -> (rest, Right a) + Failure errs rest -> (rest, Left errs) + Partial f -> finishParsing (f V.empty) +-- | Parse the complete input list, without resupplying, return the rest bytes list. +-- +-- Parsers in "Z.Data.Parser" will take 'V.empty' as EOF, so please make sure there are no 'V.empty's +-- mixed into the chunk list. +parseChunkList :: Parser a -> [V.Bytes] -> ([V.Bytes], Either ParseError a) +{-# INLINABLE parseChunkList #-} +parseChunkList p (inp:inps) = go (parseChunk p inp) inps + where + go r is = case r of + Partial f -> case is of + (i:is') -> go (f i) is' + _ -> let (rest, r') = finishParsing r + in (if V.null rest then [] else [rest], r') + Success a rest -> (if V.null rest then is else rest:is, Right a) + Failure errs rest -> (if V.null rest then is else rest:is, Left errs) + -- | Parse an input chunk parseChunk :: Parser a -> V.Bytes -> Result ParseError a {-# INLINE parseChunk #-} @@ -227,7 +253,7 @@ -- that can supply more input if needed. -- parseChunks :: Monad m => (V.Bytes -> Result e a) -> ParseChunks m e a -{-# INLINABLE parseChunks #-} +{-# INLINE parseChunks #-} parseChunks pc m inp = go (pc inp) where go r = case r of @@ -244,13 +270,13 @@ -- Once it's finished, return the final result (always 'Success' or 'Failure') and -- all consumed chunks. -- -runAndKeepTrack :: Parser a -> Parser (Result ParseError a, [V.Bytes]) +runAndKeepTrack :: Parser a -> Parser (Result ParseError a, V.Bytes) {-# INLINE runAndKeepTrack #-} runAndKeepTrack (Parser pa) = Parser $ \ _ k0 st0 inp -> let go !acc r k (st :: State# ParserState) = case r of Partial k' -> Partial (\ inp' -> go (inp':acc) (k' inp') k st) - Success _ inp' -> k st (r, reverse acc) inp' - Failure _ inp' -> k st (r, reverse acc) inp' + Success _ inp' -> let consumed = V.concatR acc in consumed `seq` k st (r, consumed) inp' + Failure _ inp' -> let consumed = V.concatR acc in consumed `seq` k st (r, consumed) inp' r0 = runRW# (\ s -> unsafeCoerce# (pa Failure (\ _ r -> Success r) (unsafeCoerce# s) inp)) in go [inp] r0 k0 st0 @@ -260,11 +286,10 @@ match :: Parser a -> Parser (V.Bytes, a) {-# INLINE match #-} match p = do - (r, bss) <- runAndKeepTrack p + (r, consumed) <- runAndKeepTrack p Parser (\ _ k s _ -> case r of - Success r' inp' -> let !consumed = V.dropR (V.length inp') (V.concat (reverse bss)) - in k s (consumed , r') inp' + Success r' inp' -> k s (consumed , r') inp' Failure err inp' -> Failure err inp' Partial _ -> error "Z.Data.Parser.Base.match: impossible") @@ -279,24 +304,61 @@ let l = V.length inp if n0 <= l then k s () inp - else Partial (ensureNPartial err (n0-l) inp kf k s) + else Partial (ensureNPartial (n0-l) inp kf k s) where + ensureNPartial :: forall r. Int -> V.PrimVector Word8 -> (ParseError -> ParseStep ParseError r) + -> (State# ParserState -> () -> ParseStep ParseError r) + -> State# ParserState -> ParseStep ParseError r + ensureNPartial !l0 inp0 kf k s0 = + let go acc !l s = \ inp -> do + let l' = V.length inp + if l' == 0 + then kf [err] (V.concatR (inp:acc)) + else do + if l <= l' + then let !inp' = V.concatR (inp:acc) in k s () inp' + else Partial (go (inp:acc) (l - l') s) + in go [inp0] l0 s0 -ensureNPartial :: forall r. T.Text -> Int -> V.PrimVector Word8 -> (ParseError -> ParseStep ParseError r) - -> (State# ParserState -> () -> ParseStep ParseError r) - -> State# ParserState -> ParseStep ParseError r -{-# INLINE ensureNPartial #-} -ensureNPartial err !l0 inp0 kf k s0 = - let go acc !l s = \ inp -> do - let l' = V.length inp - if l' == 0 - then kf [err] (V.concat (reverse (inp:acc))) - else do - if l <= l' - then let !inp' = V.concat (reverse (inp:acc)) in k s () inp' - else Partial (go (inp:acc) (l - l') s) - in go [inp0] l0 s0 +-- | Ensure that there are at least @n@ bytes available. If not, the +-- computation will escape with 'Partial'. +-- +-- Since this parser is used in many other parsers, an extra error param is provide +-- to attach custom error info. +readN :: forall a. Int -> T.Text -> (V.Bytes -> a) -> Parser a +{-# INLINE readN #-} +readN n0 err f = Parser $ \ kf k s inp -> do + let l = V.length inp + if n0 <= l + then let !r = f inp + !inp' = V.unsafeDrop n0 inp + in k s r inp' + else Partial (readNPartial (n0-l) inp kf k s) + where + readNPartial :: forall r. Int -> V.PrimVector Word8 -> (ParseError -> ParseStep ParseError r) + -> (State# ParserState -> a -> ParseStep ParseError r) + -> State# ParserState -> ParseStep ParseError r + readNPartial !l0 inp0 kf k s0 = + let go acc !l s = \ inp -> do + let l' = V.length inp + if l' == 0 + then kf [err] (V.concatR (inp:acc)) + else do + if l <= l' + then let !inp' = V.concatR (inp:acc) + !r = f inp' + !inp'' = V.unsafeDrop n0 inp' + in k s r inp'' + else Partial (go (inp:acc) (l - l') s) + in go [inp0] l0 s0 +{- These rules are bascially what inliner do so no need to mess up with them +{-# RULES "readN/fmap" + forall n f g e. fmapParser f (readN n e g) = readN n e (f . g) #-} +{-# RULES "readN/merge" + forall n1 n2 e1 e2 f1 f2. apParser (readN n1 e1 f1) (readN n2 e2 f2) = readN (n1 + n2) (T.concat [e1, ", ", e2]) (\ inp -> f1 inp $! f2 (V.unsafeDrop n1 inp)) #-} +-} + -- | Get current input chunk, draw new chunk if neccessary. 'V.null' means EOF. -- -- Note this is different from 'takeRemaining', 'currentChunk' only return what's @@ -332,23 +394,8 @@ -- | Decode a primitive type in host byte order. decodePrim :: forall a. (Unaligned a) => Parser a {-# INLINE decodePrim #-} -{-# SPECIALIZE INLINE decodePrim :: Parser Word #-} -{-# SPECIALIZE INLINE decodePrim :: Parser Word64 #-} -{-# SPECIALIZE INLINE decodePrim :: Parser Word32 #-} -{-# SPECIALIZE INLINE decodePrim :: Parser Word16 #-} -{-# SPECIALIZE INLINE decodePrim :: Parser Word8 #-} -{-# SPECIALIZE INLINE decodePrim :: Parser Int #-} -{-# SPECIALIZE INLINE decodePrim :: Parser Int64 #-} -{-# SPECIALIZE INLINE decodePrim :: Parser Int32 #-} -{-# SPECIALIZE INLINE decodePrim :: Parser Int16 #-} -{-# SPECIALIZE INLINE decodePrim :: Parser Int8 #-} -{-# SPECIALIZE INLINE decodePrim :: Parser Double #-} -{-# SPECIALIZE INLINE decodePrim :: Parser Float #-} decodePrim = do - ensureN n "Z.Data.Parser.Base.decodePrim: not enough bytes" - Parser (\ _ k s (V.PrimVector ba i len) -> - let !r = indexPrimWord8ArrayAs ba i - in k s r (V.PrimVector ba (i+n) (len-n))) + readN n "Z.Data.Parser.Base.decodePrim: not enough bytes" (\ (V.PrimVector ba i _) -> indexPrimWord8ArrayAs ba i) where n = getUnalignedSize (unalignedSize @a) @@ -372,21 +419,8 @@ -- | Decode a primitive type in little endian. decodePrimLE :: forall a. (Unaligned (LE a)) => Parser a {-# INLINE decodePrimLE #-} -{-# SPECIALIZE INLINE decodePrimLE :: Parser Word #-} -{-# SPECIALIZE INLINE decodePrimLE :: Parser Word64 #-} -{-# SPECIALIZE INLINE decodePrimLE :: Parser Word32 #-} -{-# SPECIALIZE INLINE decodePrimLE :: Parser Word16 #-} -{-# SPECIALIZE INLINE decodePrimLE :: Parser Int #-} -{-# SPECIALIZE INLINE decodePrimLE :: Parser Int64 #-} -{-# SPECIALIZE INLINE decodePrimLE :: Parser Int32 #-} -{-# SPECIALIZE INLINE decodePrimLE :: Parser Int16 #-} -{-# SPECIALIZE INLINE decodePrimLE :: Parser Double #-} -{-# SPECIALIZE INLINE decodePrimLE :: Parser Float #-} decodePrimLE = do - ensureN n "Z.Data.Parser.Base.decodePrimLE: not enough bytes" - Parser (\ _ k s (V.PrimVector ba i len) -> - let !r = indexPrimWord8ArrayAs ba i - in k s (getLE r) (V.PrimVector ba (i+n) (len-n))) + readN n "Z.Data.Parser.Base.decodePrimLE: not enough bytes" (\ (V.PrimVector ba i _) -> getLE (indexPrimWord8ArrayAs ba i)) where n = getUnalignedSize (unalignedSize @(LE a)) @@ -408,21 +442,8 @@ -- | Decode a primitive type in big endian. decodePrimBE :: forall a. (Unaligned (BE a)) => Parser a {-# INLINE decodePrimBE #-} -{-# SPECIALIZE INLINE decodePrimBE :: Parser Word #-} -{-# SPECIALIZE INLINE decodePrimBE :: Parser Word64 #-} -{-# SPECIALIZE INLINE decodePrimBE :: Parser Word32 #-} -{-# SPECIALIZE INLINE decodePrimBE :: Parser Word16 #-} -{-# SPECIALIZE INLINE decodePrimBE :: Parser Int #-} -{-# SPECIALIZE INLINE decodePrimBE :: Parser Int64 #-} -{-# SPECIALIZE INLINE decodePrimBE :: Parser Int32 #-} -{-# SPECIALIZE INLINE decodePrimBE :: Parser Int16 #-} -{-# SPECIALIZE INLINE decodePrimBE :: Parser Double #-} -{-# SPECIALIZE INLINE decodePrimBE :: Parser Float #-} decodePrimBE = do - ensureN n "Z.Data.Parser.Base.decodePrimBE: not enough bytes" - Parser (\ _ k s (V.PrimVector ba i len) -> - let !r = indexPrimWord8ArrayAs ba i - in k s (getBE r) (V.PrimVector ba (i+n) (len-n))) + readN n "Z.Data.Parser.Base.decodePrimBE: not enough bytes" (\ (V.PrimVector ba i _) -> getBE (indexPrimWord8ArrayAs ba i)) where n = getUnalignedSize (unalignedSize @(BE a)) @@ -473,6 +494,9 @@ -- the predicate on each chunk of the input until one chunk got splited to -- @Right (V.Bytes, V.Bytes)@ or the input ends. -- +-- Note the fields of result triple will not be forced by 'scanChunks', you may need to add `seq` or strict annotation to +-- avoid thunks and unintentional references to buffer. +-- scanChunks :: forall s. s -> (s -> V.Bytes -> Either s (V.Bytes, V.Bytes, s)) -> Parser (V.Bytes, s) {-# INLINE scanChunks #-} scanChunks s0 consume = Parser (\ _ k st inp -> @@ -481,19 +505,19 @@ Left s' -> Partial (scanChunksPartial s' k st inp)) where -- we want to inline consume if possible - {-# INLINABLE scanChunksPartial #-} + {-# INLINE scanChunksPartial #-} scanChunksPartial :: forall r. s -> (State# ParserState -> (V.PrimVector Word8, s) -> ParseStep ParseError r) -> State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r scanChunksPartial s0' k st0 inp0 = let go s acc st = \ inp -> if V.null inp - then k st (V.concat (reverse acc), s) inp + then k st (V.concatR acc, s) inp else case consume s inp of Left s' -> do let acc' = inp : acc Partial (go s' acc' st) Right (want,rest,s') -> - let !r = V.concat (reverse (want:acc)) in k st (r, s') rest + let !r = V.concatR (want:acc) in k st (r, s') rest in go s0' [inp0] st0 -------------------------------------------------------------------------------- @@ -620,7 +644,7 @@ -- -- Don't use this method as UTF8 decoder, it's slower than 'T.validate'. anyCharUTF8 :: Parser Char -{-# INLINABLE anyCharUTF8 #-} +{-# INLINE anyCharUTF8 #-} anyCharUTF8 = do r <- Parser $ \ kf k st inp@(V.PrimVector arr s l) -> do if l > 0 @@ -663,27 +687,25 @@ -- skip :: Int -> Parser () {-# INLINE skip #-} -skip n = +skip n = assert (n > 0) $ Parser (\ kf k s inp -> let l = V.length inp - !n' = max n 0 - in if l >= n' - then k s () $! V.unsafeDrop n' inp - else Partial (skipPartial (n'-l) kf k s)) - -skipPartial :: Int -> (ParseError -> ParseStep ParseError r) - -> (State# ParserState -> () -> ParseStep ParseError r) - -> State# ParserState -> ParseStep ParseError r -{-# INLINABLE skipPartial #-} -skipPartial n kf k s0 = - let go !n' s = \ inp -> - let l = V.length inp - in if l >= n' - then k s () $! V.unsafeDrop n' inp - else if l == 0 - then kf ["Z.Data.Parser.Base.skip: not enough bytes"] inp - else Partial (go (n'-l) s) - in go n s0 + in if l >= n + then k s () $! V.unsafeDrop n inp + else Partial (skipPartial (n-l) kf k s)) + where + skipPartial :: Int -> (ParseError -> ParseStep ParseError r) + -> (State# ParserState -> () -> ParseStep ParseError r) + -> State# ParserState -> ParseStep ParseError r + skipPartial n0 kf k s0 = + let go !n' s = \ inp -> + let l = V.length inp + in if l >= n' + then k s () $! V.unsafeDrop n' inp + else if l == 0 + then kf ["Z.Data.Parser.Base.skip: not enough bytes"] inp + else Partial (go (n'-l) s) + in go n0 s0 -- | Skip a byte. -- @@ -704,13 +726,11 @@ {-# INLINE skipWhile #-} skipWhile p = Parser (\ _ k s inp -> - let rest = V.dropWhile p inp + let !rest = V.dropWhile p inp in if V.null rest then Partial (skipWhilePartial k s) else k s () rest) where - -- we want to inline p if possible - {-# INLINABLE skipWhilePartial #-} skipWhilePartial :: forall r. (State# ParserState -> () -> ParseStep ParseError r) -> State# ParserState -> ParseStep ParseError r skipWhilePartial k s0 = @@ -728,16 +748,10 @@ {-# INLINE skipSpaces #-} skipSpaces = skipWhile isSpace +-- | Take N bytes. take :: Int -> Parser V.Bytes {-# INLINE take #-} -take n = do - -- we use unsafe slice, guard negative n here - ensureN n' "Z.Data.Parser.Base.take: not enough bytes" - Parser (\ _ k s inp -> - let !r = V.unsafeTake n' inp - !inp' = V.unsafeDrop n' inp - in k s r inp') - where !n' = max 0 n +take n = assert (n > 0) $ readN n "Z.Data.Parser.Base.take: not enough bytes" (V.unsafeTake n) -- | Consume input as long as the predicate returns 'False' or reach the end of input, -- and return the consumed input. @@ -745,24 +759,23 @@ takeTill :: (Word8 -> Bool) -> Parser V.Bytes {-# INLINE takeTill #-} takeTill p = Parser (\ _ k s inp -> - let (want, rest) = V.break p inp + let (!want, !rest) = V.break p inp in if V.null rest then Partial (takeTillPartial k s want) else k s want rest) where - {-# INLINABLE takeTillPartial #-} takeTillPartial :: forall r. (State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r) -> State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r takeTillPartial k s0 want = let go acc s = \ inp -> if V.null inp - then let !r = V.concat (reverse acc) in k s r inp + then let !r = V.concatR acc in k s r inp else - let (want', rest) = V.break p inp + let (!want', !rest) = V.break p inp acc' = want' : acc in if V.null rest then Partial (go acc' s) - else let !r = V.concat (reverse acc') in k s r rest + else let !r = V.concatR acc' in k s r rest in go [want] s0 -- | Consume input as long as the predicate returns 'True' or reach the end of input, @@ -771,25 +784,23 @@ takeWhile :: (Word8 -> Bool) -> Parser V.Bytes {-# INLINE takeWhile #-} takeWhile p = Parser (\ _ k s inp -> - let (want, rest) = V.span p inp + let (!want, !rest) = V.span p inp in if V.null rest then Partial (takeWhilePartial k s want) else k s want rest) where - -- we want to inline p if possible - {-# INLINABLE takeWhilePartial #-} takeWhilePartial :: forall r. (State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r) -> State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r takeWhilePartial k s0 want = let go acc s = \ inp -> if V.null inp - then let !r = V.concat (reverse acc) in k s r inp + then let !r = V.concatR acc in k s r inp else - let (want', rest) = V.span p inp + let (!want', !rest) = V.span p inp acc' = want' : acc in if V.null rest then Partial (go acc' s) - else let !r = V.concat (reverse acc') in k s r rest + else let !r = V.concatR acc' in k s r rest in go [want] s0 -- | Similar to 'takeWhile', but requires the predicate to succeed on at least one byte @@ -810,16 +821,23 @@ {-# INLINE takeRemaining #-} takeRemaining = Parser (\ _ k s inp -> Partial (takeRemainingPartial k s inp)) where - {-# INLINABLE takeRemainingPartial #-} takeRemainingPartial :: forall r. (State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r) -> State# ParserState -> V.PrimVector Word8 -> ParseStep ParseError r takeRemainingPartial k s0 want = let go acc s = \ inp -> if V.null inp - then let !r = V.concat (reverse acc) in k s r inp - else let acc' = inp : acc in Partial (go acc' s) + then let !r = V.concatR acc in k s r inp + else Partial (go (inp:acc) s) in go [want] s0 +-- | Take N bytes and validate as UTF8, failed if not UTF8 encoded. +takeUTF8 :: Int -> Parser T.Text +{-# INLINE takeUTF8 #-} +takeUTF8 n = do + bs <- take n + case T.validateMaybe bs of Just t -> pure t + _ -> fail' $ "Z.Data.Parser.Base.takeUTF8: illegal UTF8 bytes: " <> T.toText bs + -- | Similar to 'take', but requires the predicate to succeed on next N bytes -- of input, and take N bytes(no matter if N+1 byte satisfy predicate or not). -- @@ -870,7 +888,7 @@ "Z.Data.Parser.Base.bytesCI: mismatch bytes, expected " , T.toText bs , "(case insensitive), meet " - , T.toText (V.take n inp) + , T.toText (V.unsafeTake n inp) ] ] inp) where diff --git a/Z/Data/Parser/Numeric.hs b/Z/Data/Parser/Numeric.hs --- a/Z/Data/Parser/Numeric.hs +++ b/Z/Data/Parser/Numeric.hs @@ -70,7 +70,17 @@ -- >>> parse' hex "7FF" == Left ["Z.Data.Parser.Numeric.hex","hex numeric number overflow"] -- hex :: forall a.(Integral a, FiniteBits a) => Parser a -{-# INLINE hex #-} +{-# INLINABLE hex #-} +{-# SPECIALIZE INLINE hex :: Parser Int #-} +{-# SPECIALIZE INLINE hex :: Parser Int8 #-} +{-# SPECIALIZE INLINE hex :: Parser Int16 #-} +{-# SPECIALIZE INLINE hex :: Parser Int32 #-} +{-# SPECIALIZE INLINE hex :: Parser Int64 #-} +{-# SPECIALIZE INLINE hex :: Parser Word #-} +{-# SPECIALIZE INLINE hex :: Parser Word8 #-} +{-# SPECIALIZE INLINE hex :: Parser Word16 #-} +{-# SPECIALIZE INLINE hex :: Parser Word32 #-} +{-# SPECIALIZE INLINE hex :: Parser Word64 #-} hex = "Z.Data.Parser.Numeric.hex" do bs <- P.takeWhile1 isHexDigit if V.length bs <= finiteBitSize (undefined :: a) `unsafeShiftR` 2 @@ -84,7 +94,17 @@ -- >>> parse' hex "7Ft" == Right (127 :: Int8) -- >>> parse' hex "7FF" == Right (127 :: Int8) hex' :: forall a.(Integral a, FiniteBits a) => Parser a -{-# INLINE hex' #-} +{-# INLINABLE hex' #-} +{-# SPECIALIZE INLINE hex' :: Parser Int #-} +{-# SPECIALIZE INLINE hex' :: Parser Int8 #-} +{-# SPECIALIZE INLINE hex' :: Parser Int16 #-} +{-# SPECIALIZE INLINE hex' :: Parser Int32 #-} +{-# SPECIALIZE INLINE hex' :: Parser Int64 #-} +{-# SPECIALIZE INLINE hex' :: Parser Word #-} +{-# SPECIALIZE INLINE hex' :: Parser Word8 #-} +{-# SPECIALIZE INLINE hex' :: Parser Word16 #-} +{-# SPECIALIZE INLINE hex' :: Parser Word32 #-} +{-# SPECIALIZE INLINE hex' :: Parser Word64 #-} hex' = "Z.Data.Parser.Numeric.hex'" do hexLoop 0 <$> P.takeN isHexDigit (finiteBitSize (undefined :: a) `unsafeShiftR` 2) @@ -97,7 +117,17 @@ -- >>> parse' hex "7Ft" == Right (127 :: Int8) -- >>> parse' hex "7FF" == Right (-1 :: Int8) hex_ :: (Integral a, Bits a) => Parser a -{-# INLINE hex_ #-} +{-# INLINABLE hex_ #-} +{-# SPECIALIZE INLINE hex_ :: Parser Int #-} +{-# SPECIALIZE INLINE hex_ :: Parser Int8 #-} +{-# SPECIALIZE INLINE hex_ :: Parser Int16 #-} +{-# SPECIALIZE INLINE hex_ :: Parser Int32 #-} +{-# SPECIALIZE INLINE hex_ :: Parser Int64 #-} +{-# SPECIALIZE INLINE hex_ :: Parser Word #-} +{-# SPECIALIZE INLINE hex_ :: Parser Word8 #-} +{-# SPECIALIZE INLINE hex_ :: Parser Word16 #-} +{-# SPECIALIZE INLINE hex_ :: Parser Word32 #-} +{-# SPECIALIZE INLINE hex_ :: Parser Word64 #-} hex_ = "Z.Data.Parser.Numeric.hex_" hexLoop 0 <$> P.takeWhile1 isHexDigit -- | decode hex digits sequence within an array. @@ -120,14 +150,34 @@ -- | Same with 'uint', but sliently cast in case of overflow. uint_ :: forall a. (Integral a, Bounded a) => Parser a -{-# INLINE uint_ #-} +{-# INLINABLE uint_ #-} +{-# SPECIALIZE INLINE uint_ :: Parser Int #-} +{-# SPECIALIZE INLINE uint_ :: Parser Int8 #-} +{-# SPECIALIZE INLINE uint_ :: Parser Int16 #-} +{-# SPECIALIZE INLINE uint_ :: Parser Int32 #-} +{-# SPECIALIZE INLINE uint_ :: Parser Int64 #-} +{-# SPECIALIZE INLINE uint_ :: Parser Word #-} +{-# SPECIALIZE INLINE uint_ :: Parser Word8 #-} +{-# SPECIALIZE INLINE uint_ :: Parser Word16 #-} +{-# SPECIALIZE INLINE uint_ :: Parser Word32 #-} +{-# SPECIALIZE INLINE uint_ :: Parser Word64 #-} uint_ = "Z.Data.Parser.Numeric.uint_" decLoop 0 <$> P.takeWhile1 isDigit -- | Parse and decode an unsigned decimal number. -- -- Will fail in case of overflow. uint :: forall a. (Integral a, Bounded a) => Parser a -{-# INLINE uint #-} +{-# INLINABLE uint #-} +{-# SPECIALIZE INLINE uint :: Parser Int #-} +{-# SPECIALIZE INLINE uint :: Parser Int8 #-} +{-# SPECIALIZE INLINE uint :: Parser Int16 #-} +{-# SPECIALIZE INLINE uint :: Parser Int32 #-} +{-# SPECIALIZE INLINE uint :: Parser Int64 #-} +{-# SPECIALIZE INLINE uint :: Parser Word #-} +{-# SPECIALIZE INLINE uint :: Parser Word8 #-} +{-# SPECIALIZE INLINE uint :: Parser Word16 #-} +{-# SPECIALIZE INLINE uint :: Parser Word32 #-} +{-# SPECIALIZE INLINE uint :: Parser Word64 #-} uint = "Z.Data.Parser.Numeric.uint" do bs <- P.takeWhile1 isDigit if V.length bs <= WORD64_SAFE_DIGITS_LEN @@ -173,6 +223,7 @@ -- | Take a single decimal digit and return as 'Int'. -- digit :: Parser Int +{-# INLINE digit #-} digit = do d <- P.satisfy isDigit return $! w2iDec d @@ -182,7 +233,17 @@ -- -- This parser will fail if overflow happens. int :: forall a. (Integral a, Bounded a) => Parser a -{-# INLINE int #-} +{-# INLINABLE int #-} +{-# SPECIALIZE INLINE int :: Parser Int #-} +{-# SPECIALIZE INLINE int :: Parser Int8 #-} +{-# SPECIALIZE INLINE int :: Parser Int16 #-} +{-# SPECIALIZE INLINE int :: Parser Int32 #-} +{-# SPECIALIZE INLINE int :: Parser Int64 #-} +{-# SPECIALIZE INLINE int :: Parser Word #-} +{-# SPECIALIZE INLINE int :: Parser Word8 #-} +{-# SPECIALIZE INLINE int :: Parser Word16 #-} +{-# SPECIALIZE INLINE int :: Parser Word32 #-} +{-# SPECIALIZE INLINE int :: Parser Word64 #-} int = "Z.Data.Parser.Numeric.int" do w <- P.peek if w == MINUS @@ -218,7 +279,17 @@ -- | Same with 'int', but sliently cast if overflow happens. int_ :: (Integral a, Bounded a) => Parser a -{-# INLINE int_ #-} +{-# INLINABLE int_ #-} +{-# SPECIALIZE INLINE int_ :: Parser Int #-} +{-# SPECIALIZE INLINE int_ :: Parser Int8 #-} +{-# SPECIALIZE INLINE int_ :: Parser Int16 #-} +{-# SPECIALIZE INLINE int_ :: Parser Int32 #-} +{-# SPECIALIZE INLINE int_ :: Parser Int64 #-} +{-# SPECIALIZE INLINE int_ :: Parser Word #-} +{-# SPECIALIZE INLINE int_ :: Parser Word8 #-} +{-# SPECIALIZE INLINE int_ :: Parser Word16 #-} +{-# SPECIALIZE INLINE int_ :: Parser Word32 #-} +{-# SPECIALIZE INLINE int_ :: Parser Word64 #-} int_ = "Z.Data.Parser.Numeric.int_" do w <- P.peek if w == MINUS @@ -230,7 +301,7 @@ -- | Parser specifically optimized for 'Integer'. -- integer :: Parser Integer -{-# INLINE integer #-} +{-# INLINABLE integer #-} integer = "Z.Data.Parser.Numeric.integer" do w <- P.peek if w == MINUS @@ -253,7 +324,7 @@ -- instead. -- rational :: (Fractional a) => Parser a -{-# INLINE rational #-} +{-# INLINABLE rational #-} rational = "Z.Data.Parser.Numeric.rational" scientificallyInternal realToFrac -- | Parse a rational number and round to 'Double'. @@ -283,14 +354,14 @@ -- \"Infinity\". -- double :: Parser Double -{-# INLINE double #-} +{-# INLINABLE double #-} double = "Z.Data.Parser.Numeric.double" scientificallyInternal sciToDouble -- | Parse a rational number and round to 'Float'. -- -- Single precision version of 'double'. float :: Parser Float -{-# INLINE float #-} +{-# INLINABLE float #-} float = "Z.Data.Parser.Numeric.float" scientificallyInternal Sci.toRealFloat -- | Parse a scientific number. @@ -298,14 +369,14 @@ -- The syntax accepted by this parser is the same as for 'double'. -- scientific :: Parser Sci.Scientific -{-# INLINE scientific #-} +{-# INLINABLE scientific #-} scientific = "Z.Data.Parser.Numeric.scientific" scientificallyInternal id -- | Parse a scientific number and convert to result using a user supply function. -- -- The syntax accepted by this parser is the same as for 'double'. scientifically :: (Sci.Scientific -> a) -> Parser a -{-# INLINE scientifically #-} +{-# INLINABLE scientifically #-} scientifically h = "Z.Data.Parser.Numeric.scientifically" scientificallyInternal h -- | Strip message version. @@ -331,10 +402,10 @@ f = decLoopIntegerFast fracPart in i * (expt 10 flen) + f parseE base flen) <|> (parseE (decLoopIntegerFast intPart) 0) - - pure $! if sign /= MINUS then h sci else h (negate sci) + -- intentionally lazy return here, we have done the grammar check, and h could potentially be very expensive, e.g. sciToDouble + -- retained references are sign and sci, which are already in NF + pure (if sign /= MINUS then h sci else h (negate sci)) where - {-# INLINE parseE #-} parseE c e = (do _ <- P.satisfy (\w -> w == LETTER_e || w == LETTER_E) e' <- int @@ -355,7 +426,7 @@ -- instead. -- rational' :: (Fractional a) => Parser a -{-# INLINE rational' #-} +{-# INLINABLE rational' #-} rational' = "Z.Data.Parser.Numeric.rational'" scientificallyInternal' realToFrac -- | More strict number parsing(rfc8259). @@ -388,14 +459,20 @@ -- \"Infinity\". -- reference: https://tools.ietf.org/html/rfc8259#section-6 double' :: Parser Double -{-# INLINE double' #-} +{-# INLINABLE double' #-} double' = "Z.Data.Parser.Numeric.double'" scientificallyInternal' sciToDouble +#define FASTFLOAT_SMALLEST_POWER -325 +#define FASTFLOAT_LARGEST_POWER 308 + -- | Faster scientific to double conversion using . +-- +-- See @cbits/compute_float_64.c@. sciToDouble :: Sci.Scientific -> Double +{-# INLINABLE sciToDouble #-} sciToDouble sci = case c of #ifdef INTEGER_GMP - (S# i#) -> unsafeDupablePerformIO $ do + (S# i#) | (e >= FASTFLOAT_SMALLEST_POWER && e <= FASTFLOAT_LARGEST_POWER) -> unsafeDupablePerformIO $ do let i = (I# i#) s = if i >= 0 then 0 else 1 i' = fromIntegral $ if i >= 0 then i else (0-i) @@ -413,21 +490,21 @@ -- -- Single precision version of 'double''. float' :: Parser Float -{-# INLINE float' #-} +{-# INLINABLE float' #-} float' = "Z.Data.Parser.Numeric.float'" scientificallyInternal' Sci.toRealFloat -- | Parse a scientific number. -- -- The syntax accepted by this parser is the same as for 'double''. scientific' :: Parser Sci.Scientific -{-# INLINE scientific' #-} +{-# INLINABLE scientific' #-} scientific' = "Z.Data.Parser.Numeric.scientific'" scientificallyInternal' id -- | Parse a scientific number and convert to result using a user supply function. -- -- The syntax accepted by this parser is the same as for 'double''. scientifically' :: (Sci.Scientific -> a) -> P.Parser a -{-# INLINE scientifically' #-} +{-# INLINABLE scientifically' #-} scientifically' h = "Z.Data.Parser.Numeric.scientifically'" scientificallyInternal' h -- | Strip message version of scientifically'. @@ -455,9 +532,10 @@ in i * (expt 10 flen) + f parseE base flen _ -> parseE (decLoopIntegerFast intPart) 0 - pure $! if sign /= MINUS then h sci else h (negate sci) + -- intentionally lazy return here, we have done the grammar check, and h could potentially be very expensive, e.g. sciToDouble + -- retained references are sign and sci, which are already in NF + pure (if sign /= MINUS then h sci else h (negate sci)) where - {-# INLINE parseE #-} parseE !c !e = do me <- P.peekMaybe e' <- case me of diff --git a/Z/Data/Parser/Time.hs b/Z/Data/Parser/Time.hs --- a/Z/Data/Parser/Time.hs +++ b/Z/Data/Parser/Time.hs @@ -18,32 +18,78 @@ , timeZone , utcTime , zonedTime + -- * internal + , fromGregorianValid' + , fromGregorianValidInt64 ) where import Control.Applicative ((<|>)) import Data.Fixed (Fixed (..), Pico) import Data.Int (Int64) import Data.Maybe (fromMaybe) -import Data.Time.Calendar (Day, fromGregorianValid) +import Data.Time.Calendar (Day(..), fromGregorianValid) import Data.Time.Clock (UTCTime (..)) import Data.Time.LocalTime hiding (utc) import Z.Data.ASCII +import qualified Z.Data.Array as A import Z.Data.Parser.Base (Parser) import qualified Z.Data.Parser.Base as P import qualified Z.Data.Parser.Numeric as P import qualified Z.Data.Vector as V +import qualified Z.Data.Text as T -- | Parse a date of the form @[+,-]YYYY-MM-DD@. +-- +-- Invalid date(leap year rule violation, etc.) will be rejected. day :: Parser Day -day = "date must be of form [+,-]YYYY-MM-DD" P. do - absOrNeg <- negate <$ P.word8 MINUS <|> id <$ P.word8 PLUS <|> pure id +{-# INLINE day #-} +day = "Date must be of form [+,-]YYYY-MM-DD" P. do y <- (P.integer <* P.word8 HYPHEN) m <- (twoDigits <* P.word8 HYPHEN) d <- twoDigits - maybe (P.fail' "invalid date") return $! fromGregorianValid (absOrNeg y) m d + case fromGregorianValid' y m d of + Just d' -> pure d' + _ -> P.fail' $ T.concat ["Z.Data.Parser.Time.day: invalid date: ", T.toText y, "-", T.toText m, "-", T.toText d] +-- | Faster 'fromGregorianValid' with 'fromGregorianValidInt64' as the common case path. +-- +fromGregorianValid' :: Integer -> Int -> Int -> Maybe Day +{-# INLINE fromGregorianValid' #-} +fromGregorianValid' y m d + | -18000000000000000 < y && y < 18000000000000000 = fromGregorianValidInt64 (fromIntegral y) m d + | otherwise = fromGregorianValid y m d + +-- | Faster common case for small years(around -18000000000000000 ~ 18000000000000000). +-- +fromGregorianValidInt64 :: Int64 -> Int -> Int -> Maybe Day +{-# INLINABLE fromGregorianValidInt64 #-} +fromGregorianValidInt64 year month day_ = + if (1 <= month && month <= 12) && (1 <= day_ && day_ <= monthLength) + -- intentionally not to force with outer 'Just' here, we have done the grammar check, and calculating mjd is expensive, + -- retained references are year, month and day, which are already in NF + then Just (ModifiedJulianDay $! fromIntegral mjd) + else Nothing + where + isLeap = (rem year 4 == 0) && ((rem year 400 == 0) || not (rem year 100 == 0)) + dayOfYear = + let k = if month <= 2 then 0 else if isLeap then -1 else -2 + in ((367 * month - 362) `div` 12) + k + day_ + mjd = + let y = year - 1 + in (fromIntegral dayOfYear) + (365 * y) + (div y 4) - (div y 100) + (div y 400) - 678576 + monthLength = A.indexArr (if isLeap then monthListLeap else monthList) (month-1) + +monthList :: A.PrimArray Int +{-# NOINLINE monthList #-} +monthList = V.packN 12 [ 31 , 28 , 31 , 30 , 31 , 30 , 31 , 31 , 30 , 31 , 30 , 31 ] + +monthListLeap :: A.PrimArray Int +{-# NOINLINE monthListLeap #-} +monthListLeap = V.packN 12 [ 31 , 29 , 31 , 30 , 31 , 30 , 31 , 31 , 30 , 31 , 30 , 31 ] + -- | Parse a two-digit integer (e.g. day of month, hour). twoDigits :: Parser Int +{-# INLINE twoDigits #-} twoDigits = do a <- P.digit b <- P.digit @@ -51,6 +97,7 @@ -- | Parse a time of the form @HH:MM[:SS[.SSS]]@. timeOfDay :: Parser TimeOfDay +{-# INLINE timeOfDay #-} timeOfDay = do h <- twoDigits m <- P.char8 ':' *> twoDigits @@ -59,9 +106,9 @@ then return (TimeOfDay h m s) else P.fail' "invalid time" - -- | Parse a count of seconds, with the integer part being two digits -- long. seconds :: Parser Pico +{-# INLINE seconds #-} seconds = do real <- twoDigits mw <- P.peekMaybe @@ -81,6 +128,7 @@ -- | Parse a time zone, and return 'Nothing' if the offset from UTC is -- zero. (This makes some speedups possible.) timeZone :: Parser (Maybe TimeZone) +{-# INLINE timeZone #-} timeZone = do P.skipWhile (== SPACE) w <- P.satisfy $ \ w -> w == LETTER_Z || w == PLUS || w == MINUS @@ -109,11 +157,13 @@ -- The space may be replaced with a @T@. The number of seconds is optional -- and may be followed by a fractional component. localTime :: Parser LocalTime +{-# INLINE localTime #-} localTime = LocalTime <$> day <* daySep <*> timeOfDay where daySep = P.satisfy (\ w -> w == LETTER_T || w == SPACE) -- | Behaves as 'zonedTime', but converts any time zone offset into a -- UTC time. utcTime :: Parser UTCTime +{-# INLINE utcTime #-} utcTime = do lt@(LocalTime d t) <- localTime mtz <- timeZone @@ -136,7 +186,9 @@ -- two digits are hours, the @:@ is optional and the second two digits -- (also optional) are minutes. zonedTime :: Parser ZonedTime +{-# INLINE zonedTime #-} zonedTime = ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone) utc :: TimeZone +{-# INLINE utc #-} utc = TimeZone 0 False "" diff --git a/Z/Data/PrimRef.hs b/Z/Data/PrimRef.hs --- a/Z/Data/PrimRef.hs +++ b/Z/Data/PrimRef.hs @@ -1,31 +1,38 @@ {-| -Module : Z.Data.PrimRef +Module : Z.Data.PrimRef.PrimRef +Description : Primitive references Copyright : (c) Dong Han 2017~2019 License : BSD-style + Maintainer : winterland1989@gmail.com Stability : experimental Portability : portable -This module provide fast unboxed references for ST and IO monad, and atomic operations for 'Counter' type. Unboxed reference is implemented using single cell MutableByteArray s to eliminate indirection overhead which MutVar# s a carry, on the otherhand unboxed reference only support limited type(instances of Prim class). - +This package provide fast primitive references for primitive monad, such as ST or IO. Unboxed reference is implemented using single cell @MutableByteArray\/MutableUnliftedArray@ s to eliminate indirection overhead which MutVar# s a carry, on the otherhand primitive reference only support limited type(instances of 'Prim\/PrimUnlifted' class). -} + module Z.Data.PrimRef - ( -- * Unboxed ST references - PrimSTRef - , newPrimSTRef - , readPrimSTRef - , writePrimSTRef - , modifyPrimSTRef - , -- * Unboxed IO references - PrimIORef - , newPrimIORef - , readPrimIORef - , writePrimIORef - , modifyPrimIORef + ( -- * Prim references + PrimRef(..), PrimIORef + , newPrimRef + , readPrimRef + , writePrimRef + , modifyPrimRef + , Prim(..) + -- * Unlifted references + , UnliftedRef(..) + , newUnliftedRef + , readUnliftedRef + , writeUnliftedRef + , modifyUnliftedRef + , PrimUnlifted(..) -- * Atomic operations for @PrimIORef Int@ , Counter , newCounter + , readCounter + , writeCounter + , modifyCounter -- ** return value BEFORE atomic operation , atomicAddCounter , atomicSubCounter @@ -49,5 +56,209 @@ , atomicXorCounter_ ) where -import Z.Data.PrimRef.PrimSTRef -import Z.Data.PrimRef.PrimIORef +import Control.Monad.Primitive +import Data.Primitive.Types +import Data.Primitive.ByteArray +import GHC.Exts +import GHC.IO +import Z.Data.Array.UnliftedArray + +-- | A mutable variable in the 'PrimMonad' which can hold an instance of 'Prim'. +-- +newtype PrimRef s a = PrimRef (MutableByteArray s) + +-- | Type alias for 'PrimRef' in IO. +type PrimIORef a = PrimRef RealWorld a + +-- | Build a new 'PrimRef' +-- +newPrimRef :: (Prim a, PrimMonad m) => a -> m (PrimRef (PrimState m) a) +newPrimRef x = do + mba <- newByteArray (I# (sizeOf# x)) + writeByteArray mba 0 x + return (PrimRef mba) +{-# INLINE newPrimRef #-} + +-- | Read the value of an 'PrimRef' +-- +readPrimRef :: (Prim a, PrimMonad m) => PrimRef (PrimState m) a -> m a +readPrimRef (PrimRef mba) = readByteArray mba 0 +{-# INLINE readPrimRef #-} + +-- | Write a new value into an 'PrimRef' +-- +writePrimRef :: (Prim a, PrimMonad m) => PrimRef (PrimState m) a -> a -> m () +writePrimRef (PrimRef mba) x = writeByteArray mba 0 x +{-# INLINE writePrimRef #-} + +-- | Mutate the contents of an 'PrimRef'. +-- +-- Unboxed reference is always strict on the value it hold. +-- +modifyPrimRef :: (Prim a, PrimMonad m) => PrimRef (PrimState m) a -> (a -> a) -> m () +modifyPrimRef ref f = readPrimRef ref >>= writePrimRef ref . f +{-# INLINE modifyPrimRef #-} + +-- | Alias for 'PrimIORef Int' which support several atomic operations. +type Counter = PrimRef RealWorld Int + +-- | Build a new 'Counter' +newCounter :: Int -> IO Counter +newCounter = newPrimRef +{-# INLINE newCounter #-} + +-- | Read the value of an 'Counter'. +readCounter :: Counter -> IO Int +readCounter = readPrimRef +{-# INLINE readCounter #-} + +-- | Write a new value into an 'Counter'(non-atomically). +writeCounter :: Counter -> Int -> IO () +writeCounter = writePrimRef +{-# INLINE writeCounter #-} + +-- | Mutate the contents of an 'Counter'(non-atomically). +modifyCounter :: Counter -> (Int -> Int) -> IO () +modifyCounter = modifyPrimRef +{-# INLINE modifyCounter #-} + +-- | Atomically add a 'Counter', return the value AFTER added. +atomicAddCounter' :: Counter -> Int -> IO Int +{-# INLINE atomicAddCounter' #-} +atomicAddCounter' (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, res# #) = fetchAddIntArray# mba# 0# x# s1# in (# s2#, (I# (res# +# x#)) #) + +-- | Atomically add a 'Counter', return the value BEFORE added. +atomicAddCounter :: Counter -> Int -> IO Int +{-# INLINE atomicAddCounter #-} +atomicAddCounter (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, res# #) = fetchAddIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #) + +-- | Atomically add a 'Counter'. +atomicAddCounter_ :: Counter -> Int -> IO () +atomicAddCounter_ (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, _ #) = fetchAddIntArray# mba# 0# x# s1# in (# s2#, () #) +{-# INLINE atomicAddCounter_ #-} + + +-- | Atomically sub a 'Counter', return the value AFTER subbed. +atomicSubCounter' :: Counter -> Int -> IO Int +{-# INLINE atomicSubCounter' #-} +atomicSubCounter' (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, res# #) = fetchSubIntArray# mba# 0# x# s1# in (# s2#, (I# (res# -# x#)) #) + +-- | Atomically sub a 'Counter', return the value BEFORE subbed. +atomicSubCounter :: Counter -> Int -> IO Int +{-# INLINE atomicSubCounter #-} +atomicSubCounter (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, res# #) = fetchSubIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #) + +-- | Atomically sub a 'Counter' +atomicSubCounter_ :: Counter -> Int -> IO () +atomicSubCounter_ (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, _ #) = fetchSubIntArray# mba# 0# x# s1# in (# s2#, () #) +{-# INLINE atomicSubCounter_ #-} + +-- | Atomically and a 'Counter', return the value AFTER anded. +atomicAndCounter' :: Counter -> Int -> IO Int +atomicAndCounter' (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, res# #) = fetchAndIntArray# mba# 0# x# s1# in (# s2#, (I# (res# `andI#` x#)) #) +{-# INLINE atomicAndCounter' #-} + +-- | Atomically and a 'Counter', return the value BEFORE anded. +atomicAndCounter :: Counter -> Int -> IO Int +atomicAndCounter (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, res# #) = fetchAndIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #) +{-# INLINE atomicAndCounter #-} + +-- | Atomically and a 'Counter' +atomicAndCounter_ :: Counter -> Int -> IO () +atomicAndCounter_ (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, _ #) = fetchAndIntArray# mba# 0# x# s1# in (# s2#, () #) +{-# INLINE atomicAndCounter_ #-} + +-- | Atomically nand a 'Counter', return the value AFTER nanded. +atomicNandCounter' :: Counter -> Int -> IO Int +atomicNandCounter' (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, res# #) = fetchNandIntArray# mba# 0# x# s1# in (# s2#, (I# (notI# (res# `andI#` x#))) #) +{-# INLINE atomicNandCounter' #-} + +-- | Atomically nand a 'Counter', return the value BEFORE nanded. +atomicNandCounter :: Counter -> Int -> IO Int +atomicNandCounter (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, res# #) = fetchNandIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #) +{-# INLINE atomicNandCounter #-} + +-- | Atomically nand a 'Counter' +atomicNandCounter_ :: Counter -> Int -> IO () +atomicNandCounter_ (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, _ #) = fetchNandIntArray# mba# 0# x# s1# in (# s2#, () #) +{-# INLINE atomicNandCounter_ #-} + +-- | Atomically or a 'Counter', return the value AFTER ored. +atomicOrCounter' :: Counter -> Int -> IO Int +atomicOrCounter' (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, res# #) = fetchOrIntArray# mba# 0# x# s1# in (# s2#, (I# (res# `orI#` x#)) #) +{-# INLINE atomicOrCounter' #-} + +-- | Atomically or a 'Counter', return the value BEFORE ored. +atomicOrCounter :: Counter -> Int -> IO Int +atomicOrCounter (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, res# #) = fetchOrIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #) +{-# INLINE atomicOrCounter #-} + +-- | Atomically or a 'Counter' +atomicOrCounter_ :: Counter -> Int -> IO () +atomicOrCounter_ (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, _ #) = fetchOrIntArray# mba# 0# x# s1# in (# s2#, () #) +{-# INLINE atomicOrCounter_ #-} + +-- | Atomically xor a 'Counter', return the value AFTER xored. +atomicXorCounter' :: Counter -> Int -> IO Int +atomicXorCounter' (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, res# #) = fetchXorIntArray# mba# 0# x# s1# in (# s2#, (I# (res# `xorI#` x#)) #) +{-# INLINE atomicXorCounter' #-} + +-- | Atomically xor a 'Counter', return the value BEFORE xored. +atomicXorCounter :: Counter -> Int -> IO Int +atomicXorCounter (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, res# #) = fetchXorIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #) +{-# INLINE atomicXorCounter #-} + +-- | Atomically xor a 'Counter' +atomicXorCounter_ :: Counter -> Int -> IO () +atomicXorCounter_ (PrimRef (MutableByteArray mba#)) (I# x#) = IO $ \ s1# -> + let !(# s2#, _ #) = fetchXorIntArray# mba# 0# x# s1# in (# s2#, () #) +{-# INLINE atomicXorCounter_ #-} + +-- | A mutable variable in the 'PrimMonad' which can hold an instance of 'PrimUnlifted'. +-- +newtype UnliftedRef s a = UnliftedRef (MutableUnliftedArray s a) + +-- | Build a new 'UnliftedRef' +-- +newUnliftedRef :: (PrimUnlifted a, PrimMonad m) => a -> m (UnliftedRef (PrimState m) a) +newUnliftedRef x = do + mba <- newUnliftedArray 1 x + return (UnliftedRef mba) +{-# INLINE newUnliftedRef #-} + +-- | Read the value of an 'UnliftedRef' +-- +readUnliftedRef :: (PrimUnlifted a, PrimMonad m) => UnliftedRef (PrimState m) a -> m a +readUnliftedRef (UnliftedRef mba) = readUnliftedArray mba 0 +{-# INLINE readUnliftedRef #-} + +-- | Write a new value into an 'UnliftedRef' +-- +writeUnliftedRef :: (PrimUnlifted a, PrimMonad m) => UnliftedRef (PrimState m) a -> a -> m () +writeUnliftedRef (UnliftedRef mba) x = writeUnliftedArray mba 0 x +{-# INLINE writeUnliftedRef #-} + +-- | Mutate the contents of an 'UnliftedRef'. +-- +-- Unlifted reference is always strict on the value it hold. +-- +modifyUnliftedRef :: (PrimUnlifted a, PrimMonad m) => UnliftedRef (PrimState m) a -> (a -> a) -> m () +modifyUnliftedRef ref f = readUnliftedRef ref >>= writeUnliftedRef ref . f +{-# INLINE modifyUnliftedRef #-} diff --git a/Z/Data/PrimRef/PrimIORef.hs b/Z/Data/PrimRef/PrimIORef.hs deleted file mode 100644 --- a/Z/Data/PrimRef/PrimIORef.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-| -Module : Z.Data.PrimIORef -Description : Primitive IO Reference -Copyright : (c) Dong Han 2017~2019 -License : BSD-style - -Maintainer : winterland1989@gmail.com -Stability : experimental -Portability : portable - -This package provide fast unboxed references for IO monad and atomic operations for 'Counter' type. Unboxed reference is implemented using single cell MutableByteArray s to eliminate indirection overhead which MutVar# s a carry, on the otherhand unboxed reference only support limited type(instances of Prim class). - -Atomic operations on 'Counter' type are implemented using fetch-and-add primitives, which is much faster than a CAS loop(@atomicModifyIORef@). Beside basic atomic counter usage, you can also leverage idempotence of @and 0@, @or (-1)@ to make a concurrent flag. --} - - - -module Z.Data.PrimRef.PrimIORef - ( -- * Unboxed IO references - PrimIORef - , newPrimIORef - , readPrimIORef - , writePrimIORef - , modifyPrimIORef - -- * Atomic operations for @PrimIORef Int@ - , Counter - , newCounter - -- ** return value BEFORE atomic operation - , atomicAddCounter - , atomicSubCounter - , atomicAndCounter - , atomicNandCounter - , atomicOrCounter - , atomicXorCounter - -- ** return value AFTER atomic operation - , atomicAddCounter' - , atomicSubCounter' - , atomicAndCounter' - , atomicNandCounter' - , atomicOrCounter' - , atomicXorCounter' - -- ** without returning - , atomicAddCounter_ - , atomicSubCounter_ - , atomicAndCounter_ - , atomicNandCounter_ - , atomicOrCounter_ - , atomicXorCounter_ - ) where - -import Data.Primitive.Types -import Data.Primitive.ByteArray -import GHC.Exts -import GHC.IO -import Z.Data.PrimRef.PrimSTRef - --- | A mutable variable in the IO monad which can hold an instance of 'Prim'. -newtype PrimIORef a = PrimIORef (PrimSTRef RealWorld a) - --- | Build a new 'PrimIORef' -newPrimIORef :: Prim a => a -> IO (PrimIORef a) -newPrimIORef x = PrimIORef `fmap` stToIO (newPrimSTRef x) -{-# INLINE newPrimIORef #-} - --- | Read the value of an 'PrimIORef' -readPrimIORef :: Prim a => PrimIORef a -> IO a -readPrimIORef (PrimIORef ref) = stToIO (readPrimSTRef ref) -{-# INLINE readPrimIORef #-} - --- | Write a new value into an 'PrimIORef' -writePrimIORef :: Prim a => PrimIORef a -> a -> IO () -writePrimIORef (PrimIORef ref) x = stToIO (writePrimSTRef ref x) -{-# INLINE writePrimIORef #-} - --- | Mutate the contents of an 'IORef'. --- --- Unboxed reference is always strict on the value it hold. -modifyPrimIORef :: Prim a => PrimIORef a -> (a -> a) -> IO () -modifyPrimIORef ref f = readPrimIORef ref >>= writePrimIORef ref . f -{-# INLINE modifyPrimIORef #-} - --- | Alias for 'PrimIORef Int' which support several atomic operations. -type Counter = PrimIORef Int - --- | Build a new 'Counter' -newCounter :: Int -> IO Counter -newCounter = newPrimIORef -{-# INLINE newCounter #-} - --- | Atomically add a 'Counter', return the value AFTER added. -atomicAddCounter' :: Counter -> Int -> IO Int -atomicAddCounter' (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, res# #) = fetchAddIntArray# mba# 0# x# s1# in (# s2#, (I# (res# +# x#)) #) - --- | Atomically add a 'Counter', return the value BEFORE added. -atomicAddCounter :: Counter -> Int -> IO Int -atomicAddCounter (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, res# #) = fetchAddIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #) - --- | Atomically add a 'Counter'. -atomicAddCounter_ :: Counter -> Int -> IO () -atomicAddCounter_ (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, _ #) = fetchAddIntArray# mba# 0# x# s1# in (# s2#, () #) -{-# INLINE atomicAddCounter_ #-} - - --- | Atomically sub a 'Counter', return the value AFTER subbed. -atomicSubCounter' :: Counter -> Int -> IO Int -atomicSubCounter' (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, res# #) = fetchSubIntArray# mba# 0# x# s1# in (# s2#, (I# (res# -# x#)) #) - --- | Atomically sub a 'Counter', return the value BEFORE subbed. -atomicSubCounter :: Counter -> Int -> IO Int -atomicSubCounter (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, res# #) = fetchSubIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #) - --- | Atomically sub a 'Counter' -atomicSubCounter_ :: Counter -> Int -> IO () -atomicSubCounter_ (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, _ #) = fetchSubIntArray# mba# 0# x# s1# in (# s2#, () #) -{-# INLINE atomicSubCounter_ #-} - --- | Atomically and a 'Counter', return the value AFTER anded. -atomicAndCounter' :: Counter -> Int -> IO Int -atomicAndCounter' (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, res# #) = fetchAndIntArray# mba# 0# x# s1# in (# s2#, (I# (res# `andI#` x#)) #) -{-# INLINE atomicAndCounter' #-} - --- | Atomically and a 'Counter', return the value BEFORE anded. -atomicAndCounter :: Counter -> Int -> IO Int -atomicAndCounter (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, res# #) = fetchAndIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #) -{-# INLINE atomicAndCounter #-} - --- | Atomically and a 'Counter' -atomicAndCounter_ :: Counter -> Int -> IO () -atomicAndCounter_ (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, _ #) = fetchAndIntArray# mba# 0# x# s1# in (# s2#, () #) -{-# INLINE atomicAndCounter_ #-} - --- | Atomically nand a 'Counter', return the value AFTER nanded. -atomicNandCounter' :: Counter -> Int -> IO Int -atomicNandCounter' (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, res# #) = fetchNandIntArray# mba# 0# x# s1# in (# s2#, (I# (notI# (res# `andI#` x#))) #) -{-# INLINE atomicNandCounter' #-} - --- | Atomically nand a 'Counter', return the value BEFORE nanded. -atomicNandCounter :: Counter -> Int -> IO Int -atomicNandCounter (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, res# #) = fetchNandIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #) -{-# INLINE atomicNandCounter #-} - --- | Atomically nand a 'Counter' -atomicNandCounter_ :: Counter -> Int -> IO () -atomicNandCounter_ (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, _ #) = fetchNandIntArray# mba# 0# x# s1# in (# s2#, () #) -{-# INLINE atomicNandCounter_ #-} - --- | Atomically or a 'Counter', return the value AFTER ored. -atomicOrCounter' :: Counter -> Int -> IO Int -atomicOrCounter' (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, res# #) = fetchOrIntArray# mba# 0# x# s1# in (# s2#, (I# (res# `orI#` x#)) #) -{-# INLINE atomicOrCounter' #-} - --- | Atomically or a 'Counter', return the value BEFORE ored. -atomicOrCounter :: Counter -> Int -> IO Int -atomicOrCounter (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, res# #) = fetchOrIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #) -{-# INLINE atomicOrCounter #-} - --- | Atomically or a 'Counter' -atomicOrCounter_ :: Counter -> Int -> IO () -atomicOrCounter_ (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, _ #) = fetchOrIntArray# mba# 0# x# s1# in (# s2#, () #) -{-# INLINE atomicOrCounter_ #-} - --- | Atomically xor a 'Counter', return the value AFTER xored. -atomicXorCounter' :: Counter -> Int -> IO Int -atomicXorCounter' (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, res# #) = fetchXorIntArray# mba# 0# x# s1# in (# s2#, (I# (res# `xorI#` x#)) #) -{-# INLINE atomicXorCounter' #-} - --- | Atomically xor a 'Counter', return the value BEFORE xored. -atomicXorCounter :: Counter -> Int -> IO Int -atomicXorCounter (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, res# #) = fetchXorIntArray# mba# 0# x# s1# in (# s2#, (I# res#) #) -{-# INLINE atomicXorCounter #-} - --- | Atomically xor a 'Counter' -atomicXorCounter_ :: Counter -> Int -> IO () -atomicXorCounter_ (PrimIORef (PrimSTRef (MutableByteArray mba#))) (I# x#) = IO $ \ s1# -> - let !(# s2#, _ #) = fetchXorIntArray# mba# 0# x# s1# in (# s2#, () #) -{-# INLINE atomicXorCounter_ #-} diff --git a/Z/Data/PrimRef/PrimSTRef.hs b/Z/Data/PrimRef/PrimSTRef.hs deleted file mode 100644 --- a/Z/Data/PrimRef/PrimSTRef.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-| -Module : Z.Data.PrimRef.PrimSTRef -Description : Primitive ST Reference -Copyright : (c) Dong Han 2017~2019 -License : BSD-style - -Maintainer : winterland1989@gmail.com -Stability : experimental -Portability : portable - -This package provide fast unboxed references for ST monad. Unboxed reference is implemented using single cell MutableByteArray s to eliminate indirection overhead which MutVar# s a carry, on the otherhand unboxed reference only support limited type(instances of 'Prim' class). --} - - -module Z.Data.PrimRef.PrimSTRef - ( -- * Unboxed ST references - PrimSTRef(..) - , newPrimSTRef - , readPrimSTRef - , writePrimSTRef - , modifyPrimSTRef - ) where - -import Data.Primitive.Types -import Data.Primitive.ByteArray -import GHC.ST -import GHC.Exts - --- | A mutable variable in the ST monad which can hold an instance of 'Prim'. --- -newtype PrimSTRef s a = PrimSTRef (MutableByteArray s) - --- | Build a new 'PrimSTRef' --- -newPrimSTRef :: Prim a => a -> ST s (PrimSTRef s a) -newPrimSTRef x = do - mba <- newByteArray (I# (sizeOf# x)) - writeByteArray mba 0 x - return (PrimSTRef mba) -{-# INLINE newPrimSTRef #-} - --- | Read the value of an 'PrimSTRef' --- -readPrimSTRef :: Prim a => PrimSTRef s a -> ST s a -readPrimSTRef (PrimSTRef mba) = readByteArray mba 0 -{-# INLINE readPrimSTRef #-} - --- | Write a new value into an 'PrimSTRef' --- -writePrimSTRef :: Prim a => PrimSTRef s a -> a -> ST s () -writePrimSTRef (PrimSTRef mba) x = writeByteArray mba 0 x -{-# INLINE writePrimSTRef #-} - --- | Mutate the contents of an 'PrimSTRef'. --- --- Unboxed reference is always strict on the value it hold. --- -modifyPrimSTRef :: Prim a => PrimSTRef s a -> (a -> a) -> ST s () -modifyPrimSTRef ref f = readPrimSTRef ref >>= writePrimSTRef ref . f -{-# INLINE modifyPrimSTRef #-} diff --git a/Z/Data/Text.hs b/Z/Data/Text.hs --- a/Z/Data/Text.hs +++ b/Z/Data/Text.hs @@ -39,7 +39,7 @@ , map', imap' , foldl', ifoldl' , foldr', ifoldr' - , concat, concatMap + , concat, concatR, concatMap -- ** Special folds , count, all, any -- ** Text display width diff --git a/Z/Data/Text/Base.hs b/Z/Data/Text/Base.hs --- a/Z/Data/Text/Base.hs +++ b/Z/Data/Text/Base.hs @@ -34,7 +34,7 @@ , map', imap' , foldl', ifoldl' , foldr', ifoldr' - , concat, concatMap + , concat, concatR, concatMap -- ** Special folds , count, all, any -- ** Text display width @@ -232,13 +232,13 @@ -- | /O(n)/ Get the nth codepoint from 'Text', throw 'IndexOutOfTextRange' -- when out of bound. index :: HasCallStack => Text -> Int -> Char -{-# INLINABLE index #-} +{-# INLINE index #-} index t n = case t `indexMaybe` n of Nothing -> throw (IndexOutOfTextRange n callStack) Just x -> x -- | /O(n)/ Get the nth codepoint from 'Text'. indexMaybe :: Text -> Int -> Maybe Char -{-# INLINABLE indexMaybe #-} +{-# INLINE indexMaybe #-} indexMaybe (Text (V.PrimVector ba s l)) n | n < 0 = Nothing | otherwise = go s 0 @@ -254,7 +254,7 @@ -- The index is only meaningful to the whole byte slice, if there's less than n codepoints, -- the index will point to next byte after the end. charByteIndex :: Text -> Int -> Int -{-# INLINABLE charByteIndex #-} +{-# INLINE charByteIndex #-} charByteIndex (Text (V.PrimVector ba s l)) n | n < 0 = s | otherwise = go s 0 @@ -268,13 +268,13 @@ -- | /O(n)/ Get the nth codepoint from 'Text' counting from the end, -- throw @IndexOutOfVectorRange n callStack@ when out of bound. indexR :: HasCallStack => Text -> Int -> Char -{-# INLINABLE indexR #-} +{-# INLINE indexR #-} indexR t n = case t `indexMaybeR` n of Nothing -> throw (V.IndexOutOfVectorRange n callStack) Just x -> x -- | /O(n)/ Get the nth codepoint from 'Text' counting from the end. indexMaybeR :: Text -> Int -> Maybe Char -{-# INLINABLE indexMaybeR #-} +{-# INLINE indexMaybeR #-} indexMaybeR (Text (V.PrimVector ba s l)) n | n < 0 = Nothing | otherwise = go (s+l-1) 0 @@ -290,7 +290,7 @@ -- The index is only meaningful to the whole byte slice, if there's less than n codepoints, -- the index will point to previous byte before the start. charByteIndexR :: Text -> Int -> Int -{-# INLINABLE charByteIndexR #-} +{-# INLINE charByteIndexR #-} charByteIndexR (Text (V.PrimVector ba s l)) n | n < 0 = s+l | otherwise = go (s+l-1) 0 @@ -519,12 +519,12 @@ -- | /O(1)/. Single char text. singleton :: Char -> Text -{-# INLINABLE singleton #-} +{-# INLINE singleton #-} singleton c = Text $ V.createN 4 $ \ marr -> encodeChar marr 0 c -- | /O(1)/. Empty text. empty :: Text -{-# INLINABLE empty #-} +{-# NOINLINE empty #-} empty = Text V.empty -- | /O(n)/. Copy a text from slice. @@ -545,12 +545,12 @@ -- | /O(1)/ Test whether a text is empty. null :: Text -> Bool -{-# INLINABLE null #-} +{-# INLINE null #-} null (Text bs) = V.null bs -- | /O(n)/ The char length of a text. length :: Text -> Int -{-# INLINABLE length #-} +{-# INLINE length #-} length (Text (V.PrimVector ba s l)) = go s 0 where !end = s + l @@ -665,6 +665,14 @@ concat = Text . V.concat . coerce {-# INLINE concat #-} +-- | /O(n)/ Concatenate a list of text in reverse order, e.g. @concat ["hello, world"] == "worldhello"@ +-- +-- Note: 'concat' have to force the entire list to filter out empty text and calculate +-- the length for allocation. +concatR :: [Text] -> Text +concatR = Text . V.concatR . coerce +{-# INLINE concatR #-} + -- | Map a function over a text and concatenate the results concatMap :: (Char -> Text) -> Text -> Text {-# INLINE concatMap #-} @@ -716,8 +724,8 @@ -- replicate :: Int -> Char -> Text {-# INLINE replicate #-} -replicate 0 _ = empty -replicate n c = Text (V.create siz (go 0)) +replicate n c | n <= 0 = empty + | otherwise = Text (V.create siz (go 0)) where !csiz = encodeCharLength c !siz = n * csiz diff --git a/Z/Data/Text/Extra.hs b/Z/Data/Text/Extra.hs --- a/Z/Data/Text/Extra.hs +++ b/Z/Data/Text/Extra.hs @@ -69,7 +69,7 @@ -- | /O(n)/ 'cons' is analogous to (:) for lists, but of different -- complexity, as it requires making a copy. cons :: Char -> Text -> Text -{-# INLINABLE cons #-} +{-# INLINE cons #-} cons c (Text (V.PrimVector ba s l)) = Text (V.createN (4 + l) (\ mba -> do i <- encodeChar mba 0 c copyPrimArray mba i ba s l @@ -77,7 +77,7 @@ -- | /O(n)/ Append a char to the end of a text. snoc :: Text -> Char -> Text -{-# INLINABLE snoc #-} +{-# INLINE snoc #-} snoc (Text (V.PrimVector ba s l)) c = Text (V.createN (4 + l) (\ mba -> do copyPrimArray mba 0 ba s l encodeChar mba l c)) @@ -106,71 +106,71 @@ -- -- Throw 'EmptyText' if text is empty. head :: Text -> Char -{-# INLINABLE head #-} +{-# INLINE head #-} head t = case uncons t of { Just (c, _) -> c; _ -> errorEmptyText } -- | /O(1)/ Extract the chars after the head of a text. -- -- Throw 'EmptyText' if text is empty. tail :: Text -> Text -{-# INLINABLE tail #-} +{-# INLINE tail #-} tail t = case uncons t of { Nothing -> errorEmptyText; Just (_, t') -> t' } -- | /O(1)/ Extract the last char of a text. -- -- Throw 'EmptyText' if text is empty. last :: Text -> Char -{-# INLINABLE last #-} +{-# INLINE last #-} last t = case unsnoc t of { Just (_, c) -> c; _ -> errorEmptyText } -- | /O(1)/ Extract the chars before of the last one. -- -- Throw 'EmptyText' if text is empty. init :: Text -> Text -{-# INLINABLE init #-} +{-# INLINE init #-} init t = case unsnoc t of { Just (t', _) -> t'; _ -> errorEmptyText } -- | /O(1)/ Extract the first char of a text. headMaybe :: Text -> Maybe Char -{-# INLINABLE headMaybe #-} +{-# INLINE headMaybe #-} headMaybe t = case uncons t of { Just (c, _) -> Just c; _ -> Nothing } -- | /O(1)/ Extract the chars after the head of a text. -- -- NOTE: 'tailMayEmpty' return empty text in the case of an empty text. tailMayEmpty :: Text -> Text -{-# INLINABLE tailMayEmpty #-} +{-# INLINE tailMayEmpty #-} tailMayEmpty t = case uncons t of { Nothing -> empty; Just (_, t') -> t' } -- | /O(1)/ Extract the last char of a text. lastMaybe :: Text -> Maybe Char -{-# INLINABLE lastMaybe #-} +{-# INLINE lastMaybe #-} lastMaybe t = case unsnoc t of { Just (_, c) -> Just c; _ -> Nothing } -- | /O(1)/ Extract the chars before of the last one. -- -- NOTE: 'initMayEmpty' return empty text in the case of an empty text. initMayEmpty :: Text -> Text -{-# INLINABLE initMayEmpty #-} +{-# INLINE initMayEmpty #-} initMayEmpty t = case unsnoc t of { Just (t', _) -> t'; _ -> empty } -- | /O(n)/ Return all initial segments of the given text, empty first. inits :: Text -> [Text] -{-# INLINABLE inits #-} +{-# INLINE inits #-} inits t0 = go t0 [t0] where go t acc = case unsnoc t of Just (t', _) -> go t' (t':acc) Nothing -> acc -- | /O(n)/ Return all final segments of the given text, whole text first. tails :: Text -> [Text] -{-# INLINABLE tails #-} +{-# INLINE tails #-} tails t = t : case uncons t of Just (_, t') -> tails t' Nothing -> [] -- | /O(1)/ 'take' @n@, applied to a text @xs@, returns the prefix -- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. take :: Int -> Text -> Text -{-# INLINABLE take #-} +{-# INLINE take #-} take n t@(Text (V.PrimVector ba s _)) | n <= 0 = empty | otherwise = case charByteIndex t n of i -> Text (V.PrimVector ba s (i-s)) @@ -178,7 +178,7 @@ -- | /O(1)/ 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ -- char, or @[]@ if @n > 'length' xs@. drop :: Int -> Text -> Text -{-# INLINABLE drop #-} +{-# INLINE drop #-} drop n t@(Text (V.PrimVector ba s l)) | n <= 0 = t | otherwise = case charByteIndex t n of i -> Text (V.PrimVector ba i (l+s-i)) @@ -186,7 +186,7 @@ -- | /O(1)/ 'takeR' @n@, applied to a text @xs@, returns the suffix -- of @xs@ of length @n@, or @xs@ itself if @n > 'length' xs@. takeR :: Int -> Text -> Text -{-# INLINABLE takeR #-} +{-# INLINE takeR #-} takeR n t@(Text (V.PrimVector ba s l)) | n <= 0 = empty | otherwise = case charByteIndexR t n of i -> Text (V.PrimVector ba (i+1) (s+l-1-i)) @@ -194,7 +194,7 @@ -- | /O(1)/ 'dropR' @n xs@ returns the prefix of @xs@ before the last @n@ -- char, or @[]@ if @n > 'length' xs@. dropR :: Int -> Text -> Text -{-# INLINABLE dropR #-} +{-# INLINE dropR #-} dropR n t@(Text (V.PrimVector ba s _)) | n <= 0 = t | otherwise = case charByteIndexR t n of i -> Text (V.PrimVector ba s (i-s+1)) @@ -338,7 +338,7 @@ -- | The 'groupBy' function is the non-overloaded version of 'group'. groupBy :: (Char -> Char -> Bool) -> Text -> [Text] -{-# INLINE groupBy #-} +{-# INLINABLE groupBy #-} groupBy f (Text (V.PrimVector arr s l)) | l == 0 = [] | otherwise = Text (V.PrimVector arr s (s'-s)) : groupBy f (Text (V.PrimVector arr s' (l+s-s'))) @@ -356,13 +356,13 @@ -- 'Nothing'. -- stripPrefix :: Text -> Text -> Maybe Text -{-# INLINE stripPrefix #-} +{-# INLINABLE stripPrefix #-} stripPrefix = coerce (V.stripPrefix @V.PrimVector @Word8) -- | O(n) The 'stripSuffix' function takes two texts and returns Just the remainder of the second iff the first is its suffix, and otherwise Nothing. stripSuffix :: Text -> Text -> Maybe Text -{-# INLINE stripSuffix #-} +{-# INLINABLE stripSuffix #-} stripSuffix = coerce (V.stripSuffix @V.PrimVector @Word8) -- | /O(n)/ Break a text into pieces separated by the delimiter element @@ -380,7 +380,7 @@ -- NOTE, this function behavior different with bytestring's. see -- . split :: Char -> Text -> [Text] -{-# INLINE split #-} +{-# INLINABLE split #-} split x = splitWith (==x) -- | /O(n)/ Splits a text into components delimited by @@ -392,7 +392,7 @@ -- > splitWith (=='a') [] == [""] -- splitWith :: (Char -> Bool) -> Text -> [Text] -{-# INLINE splitWith #-} +{-# INLINABLE splitWith #-} splitWith f (Text (V.PrimVector arr s l)) = go s s where !end = s + l @@ -422,25 +422,25 @@ -- > intercalate s . splitOn s == id -- > splitOn (singleton c) == split (==c) splitOn :: Text -> Text -> [Text] -{-# INLINE splitOn #-} +{-# INLINABLE splitOn #-} splitOn = coerce (V.splitOn @V.PrimVector @Word8) -- | The 'isPrefix' function returns 'True' if the first argument is a prefix of the second. isPrefixOf :: Text -> Text -> Bool -{-# INLINE isPrefixOf #-} +{-# INLINABLE isPrefixOf #-} isPrefixOf = coerce (V.isPrefixOf @V.PrimVector @Word8) -- | /O(n)/ The 'isSuffixOf' function takes two text and returns 'True' -- if the first is a suffix of the second. isSuffixOf :: Text -> Text -> Bool -{-# INLINE isSuffixOf #-} +{-# INLINABLE isSuffixOf #-} isSuffixOf = coerce (V.isSuffixOf @V.PrimVector @Word8) -- | Check whether one text is a subtext of another. -- -- @needle `isInfixOf` haystack === null haystack || indices needle haystake /= []@. isInfixOf :: Text -> Text -> Bool -{-# INLINE isInfixOf #-} +{-# INLINABLE isInfixOf #-} isInfixOf = coerce (V.isInfixOf @V.PrimVector @Word8) -- | /O(n)/ Find the longest non-empty common prefix of two strings @@ -453,12 +453,12 @@ -- >>> commonPrefix "veeble" "fetzer" -- ("","veeble","fetzer") commonPrefix :: Text -> Text -> (Text, Text, Text) -{-# INLINE commonPrefix #-} +{-# INLINABLE commonPrefix #-} commonPrefix = coerce (V.commonPrefix @V.PrimVector @Word8) -- | /O(n)/ Breaks a 'Bytes' up into a list of words, delimited by unicode space. words :: Text -> [Text] -{-# INLINE words #-} +{-# INLINABLE words #-} words (Text (V.PrimVector arr s l)) = go s s where !end = s + l @@ -476,24 +476,24 @@ -- | /O(n)/ Breaks a text up into a list of lines, delimited by ascii @\n@. lines :: Text -> [Text] -{-# INLINE lines #-} +{-# INLINABLE lines #-} lines = coerce V.lines -- | /O(n)/ Joins words with ascii space. unwords :: [Text] -> Text -{-# INLINE unwords #-} +{-# INLINABLE unwords #-} unwords = coerce V.unwords -- | /O(n)/ Joins lines with ascii @\n@. -- -- NOTE: This functions is different from 'Prelude.unlines', it DOES NOT add a trailing @\n@. unlines :: [Text] -> Text -{-# INLINE unlines #-} +{-# INLINABLE unlines #-} unlines = coerce V.unlines -- | Add padding to the left so that the whole text's length is at least n. padLeft :: Int -> Char -> Text -> Text -{-# INLINE padLeft #-} +{-# INLINABLE padLeft #-} padLeft n c t@(Text (V.PrimVector arr s l)) | n <= tsiz = t | otherwise = @@ -513,7 +513,7 @@ -- | Add padding to the right so that the whole text's length is at least n. padRight :: Int -> Char -> Text -> Text -{-# INLINE padRight #-} +{-# INLINABLE padRight #-} padRight n c t@(Text (V.PrimVector arr s l)) | n <= tsiz = t | otherwise = @@ -539,7 +539,7 @@ -- between the characters of a 'Text'. Performs replacement on invalid scalar values. -- intersperse :: Char -> Text -> Text -{-# INLINE intersperse #-} +{-# INLINABLE intersperse #-} intersperse c = \ t@(Text (V.PrimVector ba s l)) -> let tlen = length t in if length t < 2 @@ -575,7 +575,7 @@ -- | /O(n)/ Reverse the characters of a string. reverse :: Text -> Text -{-# INLINE reverse #-} +{-# INLINABLE reverse #-} reverse = \ (Text (V.PrimVector ba s l)) -> Text $ V.create l (go ba s l (s+l)) where go :: PrimArray Word8 -> Int -> Int -> Int -> MutablePrimArray s Word8 -> ST s () @@ -591,17 +591,17 @@ -- 'Text's and concatenates the list after interspersing the first -- argument between each element of the list. intercalate :: Text -> [Text] -> Text -{-# INLINE intercalate #-} +{-# INLINABLE intercalate #-} intercalate s = concat . List.intersperse s intercalateElem :: Char -> [Text] -> Text -{-# INLINE intercalateElem #-} +{-# INLINABLE intercalateElem #-} intercalateElem c = concat . List.intersperse (singleton c) -- | The 'transpose' function transposes the rows and columns of its -- text argument. -- transpose :: [Text] -> [Text] -{-# INLINE transpose #-} +{-# INLINABLE transpose #-} transpose ts = List.map pack . List.transpose . List.map unpack $ ts diff --git a/Z/Data/Text/Print.hs b/Z/Data/Text/Print.hs --- a/Z/Data/Text/Print.hs +++ b/Z/Data/Text/Print.hs @@ -137,22 +137,22 @@ -- | Convert data to 'B.Builder'. toUTF8Builder :: Print a => a -> B.Builder () -{-# INLINE toUTF8Builder #-} +{-# INLINABLE toUTF8Builder #-} toUTF8Builder = toUTF8BuilderP 0 -- | Convert data to 'V.Bytes' in UTF8 encoding. toUTF8Bytes :: Print a => a -> V.Bytes -{-# INLINE toUTF8Bytes #-} +{-# INLINABLE toUTF8Bytes #-} toUTF8Bytes = B.build . toUTF8BuilderP 0 -- | Convert data to 'Text'. toText :: Print a => a -> Text -{-# INLINE toText #-} +{-# INLINABLE toText #-} toText = Text . toUTF8Bytes -- | Convert data to 'String', faster 'show' replacement. toString :: Print a => a -> String -{-# INLINE toString #-} +{-# INLINABLE toString #-} toString = T.unpack . toText class GToText f where @@ -284,7 +284,7 @@ -- @ -- escapeTextJSON :: T.Text -> B.Builder () -{-# INLINE escapeTextJSON #-} +{-# INLINABLE escapeTextJSON #-} escapeTextJSON (T.Text (V.PrimVector ba@(PrimArray ba#) s l)) = do let !siz = escape_json_string_length ba# s l B.writeN siz (\ mba@(MutablePrimArray mba#) i -> do diff --git a/Z/Data/Text/Search.hs b/Z/Data/Text/Search.hs --- a/Z/Data/Text/Search.hs +++ b/Z/Data/Text/Search.hs @@ -34,7 +34,7 @@ -- | find all char index matching the predicate. findIndices :: (Char -> Bool) -> Text -> [Int] -{-# INLINE findIndices #-} +{-# INLINABLE findIndices #-} findIndices f (Text (V.PrimVector arr s l)) = go 0 s where !end = s + l @@ -45,7 +45,7 @@ -- | find all char's byte index matching the predicate. findBytesIndices :: (Char -> Bool) -> Text -> [Int] -{-# INLINE findBytesIndices #-} +{-# INLINABLE findBytesIndices #-} findBytesIndices f (Text (V.PrimVector arr s l)) = go s where !end = s + l @@ -59,7 +59,7 @@ find :: (Char -> Bool) -> Text -> (Int, Maybe Char) -- ^ (char index, matching char) -{-# INLINE find #-} +{-# INLINABLE find #-} find f (Text (V.PrimVector arr s l)) = go 0 s where !end = s + l @@ -76,7 +76,7 @@ findR :: (Char -> Bool) -> Text -> (Int, Maybe Char) -- ^ (char index(counting backwards), matching char) -{-# INLINE findR #-} +{-# INLINABLE findR #-} findR f (Text (V.PrimVector arr s l)) = go 0 (s+l-1) where go !i !j | j < s = (i, Nothing) @@ -90,17 +90,17 @@ -- | /O(n)/ find the char index. findIndex :: (Char -> Bool) -> Text -> Int -{-# INLINE findIndex #-} +{-# INLINABLE findIndex #-} findIndex f t = case find f t of (i, _) -> i -- | /O(n)/ find the char index in reverse order. findIndexR :: (Char -> Bool) -> Text -> Int -{-# INLINE findIndexR #-} +{-# INLINABLE findIndexR #-} findIndexR f t = case findR f t of (i, _) -> i -- | /O(n)/ find the char's byte slice index. findBytesIndex :: (Char -> Bool) -> Text -> Int -{-# INLINE findBytesIndex #-} +{-# INLINABLE findBytesIndex #-} findBytesIndex f (Text (V.PrimVector arr s l)) = go s where !end = s + l @@ -113,7 +113,7 @@ -- | /O(n)/ find the char's byte slice index in reverse order(pointing to the right char's first byte). findBytesIndexR :: (Char -> Bool) -> Text -> Int -{-# INLINE findBytesIndexR #-} +{-# INLINABLE findBytesIndexR #-} findBytesIndexR f (Text (V.PrimVector arr s l)) = go (s+l-1) where go !j | j < s = j-s+1 @@ -127,7 +127,7 @@ -- returns a text containing those chars that satisfy the -- predicate. filter :: (Char -> Bool) -> Text -> Text -{-# INLINE filter #-} +{-# INLINABLE filter #-} filter f (Text (V.PrimVector arr s l)) = Text (V.createN l (go s 0)) where !end = s + l @@ -148,7 +148,7 @@ -- -- > partition p txt == (filter p txt, filter (not . p) txt) partition :: (Char -> Bool) -> Text -> (Text, Text) -{-# INLINE partition #-} +{-# INLINABLE partition #-} partition f (Text (V.PrimVector arr s l)) | l == 0 = (empty, empty) | otherwise = let !(bs1, bs2) = V.createN2 l l (go 0 0 s) in (Text bs1, Text bs2) @@ -168,11 +168,11 @@ -- | /O(n)/ 'elem' test if given char is in given text. elem :: Char -> Text -> Bool -{-# INLINE elem #-} +{-# INLINABLE elem #-} elem x t = case find (x==) t of (_,Nothing) -> False _ -> True -- | /O(n)/ @not . elem@ notElem :: Char -> Text -> Bool -{-# INLINE notElem #-} +{-# INLINABLE notElem #-} notElem x = not . elem x diff --git a/Z/Data/Vector.hs b/Z/Data/Vector.hs --- a/Z/Data/Vector.hs +++ b/Z/Data/Vector.hs @@ -81,10 +81,11 @@ , length , append , map, map', imap', traverse, traverseWithIndex, traverse_, traverseWithIndex_ + , mapM, mapM_, forM, forM_ , foldl', ifoldl', foldl1', foldl1Maybe' , foldr', ifoldr', foldr1', foldr1Maybe' -- ** Special folds - , concat, concatMap + , concat, concatR, concatMap , maximum, minimum, maximumMaybe, minimumMaybe , sum , count diff --git a/Z/Data/Vector/Base.hs b/Z/Data/Vector/Base.hs --- a/Z/Data/Vector/Base.hs +++ b/Z/Data/Vector/Base.hs @@ -41,10 +41,11 @@ , length , append , map, map', imap', traverse, traverseWithIndex, traverse_, traverseWithIndex_ + , mapM, mapM_, forM, forM_ , foldl', ifoldl', foldl1', foldl1Maybe' , foldr', ifoldr', foldr1', foldr1Maybe' -- ** Special folds - , concat, concatMap + , concat, concatR, concatMap , maximum, minimum, maximumMaybe, minimumMaybe , sum , count, countBytes @@ -86,8 +87,7 @@ import Control.DeepSeq import Control.Exception -import Control.Monad hiding (replicateM) -import qualified Control.Monad as M (replicateM) +import qualified Control.Monad as M import Control.Monad.ST import Control.Monad.Primitive import Data.Bits @@ -101,7 +101,6 @@ import Data.Maybe import qualified Data.CaseInsensitive as CI import Data.Primitive -import Data.Primitive.Ptr import Data.Semigroup (Semigroup (..)) import qualified Data.Traversable as T import Foreign.C @@ -109,7 +108,7 @@ import GHC.Stack import GHC.CString import GHC.Word -import Prelude hiding (concat, concatMap, +import Prelude hiding (concat, concatMap, mapM, mapM_, elem, notElem, null, length, map, foldl, foldl1, foldr, foldr1, maximum, minimum, product, sum, @@ -220,7 +219,7 @@ fromListN = packN instance Eq a => Eq (Vector a) where - {-# INLINABLE (==) #-} + {-# INLINE (==) #-} v1 == v2 = eqVector v1 v2 eqVector :: Eq a => Vector a -> Vector a -> Bool @@ -237,7 +236,7 @@ (indexSmallArray baA i == indexSmallArray baB j) && go (i+1) (j+1) instance Ord a => Ord (Vector a) where - {-# INLINABLE compare #-} + {-# INLINE compare #-} compare = compareVector compareVector :: Ord a => Vector a -> Vector a -> Ordering @@ -358,23 +357,33 @@ {-# INLINE [1] traverseWithIndex #-} {-# RULES "traverseWithIndex/IO" forall (f :: Int -> a -> IO b). traverseWithIndex f = traverseWithIndexPM f #-} {-# RULES "traverseWithIndex/ST" forall (f :: Int -> a -> ST s b). traverseWithIndex f = traverseWithIndexPM f #-} -traverseWithIndex f v = packN (length v) <$> zipWithM f [0..] (unpack v) +traverseWithIndex f v = packN (length v) <$> M.zipWithM f [0..] (unpack v) +-- | 'PrimMonad' specialzied version of 'traverseWithIndex'. +-- +-- You can add rules to rewrite 'traverse' and 'traverseWithIndex' to this function in your own 'PrimMonad' instance, e.g. +-- +-- @ +-- instance PrimMonad YourMonad where ... +-- +-- {-# RULES "traverse\/YourMonad" forall (f :: a -> YourMonad b). traverse\' f = traverseWithIndexPM (const f) #-} +-- {-# RULES "traverseWithIndex\/YourMonad" forall (f :: Int -> a -> YourMonad b). traverseWithIndex f = traverseWithIndexPM f #-} +-- @ +-- traverseWithIndexPM :: forall m v u a b. (PrimMonad m, Vec v a, Vec u b) => (Int -> a -> m b) -> v a -> m (u b) {-# INLINE traverseWithIndexPM #-} traverseWithIndexPM f (Vec arr s l) | l == 0 = return empty | otherwise = do - marr <- newArr l + !marr <- newArr l ba <- go marr 0 return $! fromArr ba 0 l where go :: MArr (IArray u) (PrimState m) b -> Int -> m (IArray u b) - go !marr !i + go marr !i | i >= l = unsafeFreezeArr marr | otherwise = do - x <- indexArrM arr (i+s) - writeArr marr i =<< f i x + writeArr marr i =<< f i (indexArr arr (i+s)) go marr (i+1) -- | Traverse vector without gathering result. @@ -397,6 +406,27 @@ | i >= end = pure () | otherwise = f (i-s) (indexArr arr i) *> go (i+1) +-- | Alias for 'traverse'. +mapM :: (Vec v a, Vec u b, Applicative f) => (a -> f b) -> v a -> f (u b) +{-# INLINE mapM #-} +mapM = traverse + +-- | Alias for 'traverse_'. +mapM_ :: (Vec v a, Applicative f) => (a -> f b) -> v a -> f () +{-# INLINE mapM_ #-} +mapM_ = traverse_ + +-- | Flipped version of 'traverse'. +forM :: (Vec v a, Vec u b, Applicative f) => v a -> (a -> f b) -> f (u b) +{-# INLINE forM #-} +forM v f = traverse f v + +-- | Flipped version of 'traverse_'. +forM_ :: (Vec v a, Applicative f) => v a -> (a -> f b) -> f () +{-# INLINE forM_ #-} +forM_ v f = traverse_ f v + + -------------------------------------------------------------------------------- -- | Primitive vector -- @@ -577,8 +607,7 @@ -> (forall s. MArr (IArray v) s a -> ST s ()) -- ^ initialization function -> v a {-# INLINE create #-} -create n0 fill = runST (do - let n = max 0 n0 +create n fill = assert (n >= 0) $ runST (do marr <- newArr n fill marr ba <- unsafeFreezeArr marr @@ -593,8 +622,7 @@ -- ^ initialization function return a result size and array, the result must start from index 0 -> v a {-# INLINE create' #-} -create' n0 fill = runST (do - let n = max 0 n0 +create' n fill = assert (n >= 0) $ runST (do marr <- newArr n IPair n' marr' <- fill marr shrinkMutableArr marr' n' @@ -611,8 +639,7 @@ -> (forall s. MArr (IArray v) s a -> ST s b) -- ^ initialization function -> (b, v a) {-# INLINE creating #-} -creating n0 fill = runST (do - let n = max 0 n0 +creating n fill = assert (n >= 0) $ runST (do marr <- newArr n b <- fill marr ba <- unsafeFreezeArr marr @@ -629,8 +656,7 @@ -> (forall s. MArr (IArray v) s a -> ST s (b, (IPair (MArr (IArray v) s a)))) -- ^ initialization function -> (b, v a) {-# INLINE creating' #-} -creating' n0 fill = runST (do - let n = max 0 n0 +creating' n fill = assert (n >= 0) $ runST (do marr <- newArr n (b, IPair n' marr') <- fill marr shrinkMutableArr marr' n' @@ -690,6 +716,7 @@ -- | /O(1)/. The empty vector. -- empty :: Vec v a => v a +{-# NOINLINE empty #-} empty = Vec emptyArr 0 0 -- | /O(1)/. Single element vector. @@ -725,7 +752,7 @@ {-# INLINE [1] packN #-} packN n0 = \ ws0 -> runST (do let n = max 4 n0 marr <- newArr n - (IPair i marr') <- foldM go (IPair 0 marr) ws0 + (IPair i marr') <- M.foldM go (IPair 0 marr) ws0 shrinkMutableArr marr' i ba <- unsafeFreezeArr marr' return $! fromArr ba 0 i) @@ -754,15 +781,24 @@ {-# RULES "replicateM/ST" forall n (x :: ST s a). replicateM n x = replicatePM n x #-} replicateM n f = packN n <$> M.replicateM n f --- | A version of 'replicateM' which works on 'PrimMonad' and 'Vec'. +-- | 'PrimMonad' specialzied version of 'replicateM'. +-- +-- You can add rules to rewrite 'replicateM' to this function in your own 'PrimMonad' instance, e.g. +-- +-- @ +-- instance PrimMonad YourMonad where ... +-- +-- {-# RULES "replicateM\/YourMonad" forall n (f :: YourMonad a). replicateM n f = replicatePM n f #-} +-- @ +-- replicatePM :: (PrimMonad m, Vec v a) => Int -> m a -> m (v a) {-# INLINE replicatePM #-} replicatePM n f = do - marr <- newArr n + !marr <- newArr n ba <- go marr 0 - (return $! fromArr ba 0 n) + return $! fromArr ba 0 n where - go marr i + go marr !i | i >= n = unsafeFreezeArr marr | otherwise = do x <- f @@ -778,7 +814,7 @@ packN' :: forall v a. Vec v a => Int -> [a] -> v a {-# INLINE packN' #-} packN' n = \ ws0 -> runST (do marr <- newArr n - (IPair i marr') <- foldM go (IPair 0 marr) ws0 + (IPair i marr') <- M.foldM go (IPair 0 marr) ws0 shrinkMutableArr marr' i ba <- unsafeFreezeArr marr' return $! fromArr ba 0 i) @@ -806,7 +842,7 @@ {-# INLINE packRN #-} packRN n0 = \ ws0 -> runST (do let n = max 4 n0 marr <- newArr n - (IPair i marr') <- foldM go (IPair (n-1) marr) ws0 + (IPair i marr') <- M.foldM go (IPair (n-1) marr) ws0 ba <- unsafeFreezeArr marr' let i' = i + 1 n' = sizeofArr ba @@ -834,7 +870,7 @@ packRN' :: forall v a. Vec v a => Int -> [a] -> v a {-# INLINE packRN' #-} packRN' n = \ ws0 -> runST (do marr <- newArr n - (IPair i marr') <- foldM go (IPair (n-1) marr) ws0 + (IPair i marr') <- M.foldM go (IPair (n-1) marr) ws0 ba <- unsafeFreezeArr marr' let i' = i + 1 n' = sizeofArr ba @@ -1070,25 +1106,43 @@ -- Note: 'concat' have to force the entire list to filter out empty vector and calculate -- the length for allocation. concat :: forall v a . Vec v a => [v a] -> v a -{-# INLINE concat #-} +{-# INLINABLE concat #-} concat [v] = v -- shortcut common case in Parser -concat vs = case pre 0 0 vs of +concat vs = case preConcat 0 0 vs of (1, _) -> let Just v = List.find (not . null) vs in v -- there must be a not null vector (_, l) -> create l (go vs 0) where - -- pre scan to decide if we really need to copy and calculate total length - -- we don't accumulate another result list, since it's rare to got empty - pre :: Int -> Int -> [v a] -> (Int, Int) - pre !nacc !lacc [] = (nacc, lacc) - pre !nacc !lacc (Vec _ _ l:vs') - | l <= 0 = pre nacc lacc vs' - | otherwise = pre (nacc+1) (l+lacc) vs' - go :: [v a] -> Int -> MArr (IArray v) s a -> ST s () go [] !_ !_ = return () - go (Vec ba s l:vs') !i !marr = do when (l /= 0) (copyArr marr i ba s l) + go (Vec ba s l:vs') !i !marr = do M.when (l /= 0) (copyArr marr i ba s l) go vs' (i+l) marr +-- | /O(n)/ Concatenate a list of vector in reverse order, e.g. @concat ["hello, world"] == "worldhello"@ +-- +-- Note: 'concatR' have to force the entire list to filter out empty vector and calculate +-- the length for allocation. +concatR :: forall v a . Vec v a => [v a] -> v a +{-# INLINABLE concatR #-} +concatR [v] = v -- shortcut common case in Parser +concatR vs = case preConcat 0 0 vs of + (1, _) -> let Just v = List.find (not . null) vs in v -- there must be a not null vector + (_, l) -> create l (go vs l) + where + go :: [v a] -> Int -> MArr (IArray v) s a -> ST s () + go [] !_ !_ = return () + go (Vec ba s l:vs') !i !marr = do M.when (l /= 0) (copyArr marr (i-l) ba s l) + go vs' (i-l) marr + +-- pre scan to decide if we really need to copy and calculate total length +-- we don't accumulate another result list, since it's rare to got empty +preConcat :: Vec v a => Int -> Int -> [v a] -> (Int, Int) +{-# INLINE preConcat #-} +preConcat !nacc !lacc [] = (nacc, lacc) +preConcat !nacc !lacc (Vec _ _ l:vs') + | l <= 0 = preConcat nacc lacc vs' + | otherwise = preConcat (nacc+1) (l+lacc) vs' + + -- | Map a function over a vector and concatenate the results concatMap :: Vec v a => (a -> v a) -> v a -> v a {-# INLINE concatMap #-} @@ -1416,6 +1470,7 @@ -- | Cast between vectors castVector :: (Vec v a, Cast a b) => v a -> v b +{-# INLINE castVector #-} castVector = unsafeCoerce# -------------------------------------------------------------------------------- diff --git a/Z/Data/Vector/Base64.hs b/Z/Data/Vector/Base64.hs --- a/Z/Data/Vector/Base64.hs +++ b/Z/Data/Vector/Base64.hs @@ -45,12 +45,12 @@ -- | Return the encoded length of a given input length, always a multipler of 4. base64EncodeLength :: Int -> Int -{-# INLINABLE base64EncodeLength #-} +{-# INLINE base64EncodeLength #-} base64EncodeLength n = ((n+2) `quot` 3) `unsafeShiftL` 2 -- | 'B.Builder' version of 'base64Encode'. base64EncodeBuilder :: V.Bytes -> B.Builder () -{-# INLINABLE base64EncodeBuilder #-} +{-# INLINE base64EncodeBuilder #-} base64EncodeBuilder (V.PrimVector arr s l) = B.writeN (base64EncodeLength l) (\ (MutablePrimArray mba#) i -> do withPrimArrayUnsafe arr $ \ parr _ -> @@ -94,7 +94,7 @@ -- | Return the upper bound of decoded length of a given input length -- , return -1 if illegal(not a multipler of 4). base64DecodeLength :: Int -> Int -{-# INLINABLE base64DecodeLength #-} +{-# INLINE base64DecodeLength #-} base64DecodeLength n | n .&. 3 == 1 = -1 | otherwise = (n `unsafeShiftR` 2) * 3 + 2 diff --git a/Z/Data/Vector/Extra.hs b/Z/Data/Vector/Extra.hs --- a/Z/Data/Vector/Extra.hs +++ b/Z/Data/Vector/Extra.hs @@ -227,7 +227,9 @@ -- returns the longest prefix (possibly empty) of @vs@ of elements that -- satisfy @p@. takeWhile :: Vec v a => (a -> Bool) -> v a -> v a -{-# INLINE takeWhile #-} +{-# INLINE [1] takeWhile #-} +{-# RULES "takeWhile/breakEq1" forall w. takeWhile (w `neWord8`) = fst . break (w `eqWord8`) #-} +{-# RULES "takeWhile/breakEq2" forall w. takeWhile (`neWord8` w) = fst . break (`eqWord8` w) #-} takeWhile f v@(Vec arr s _) = case findIndex (not . f) v of 0 -> empty @@ -237,7 +239,9 @@ -- returns the longest suffix (possibly empty) of @vs@ of elements that -- satisfy @p@. takeWhileR :: Vec v a => (a -> Bool) -> v a -> v a -{-# INLINE takeWhileR #-} +{-# INLINE [1] takeWhileR #-} +{-# RULES "takeWhileR/breakREq1" forall w. takeWhileR (w `neWord8`) = snd . breakR (w `eqWord8`) #-} +{-# RULES "takeWhileR/breakREq2" forall w. takeWhileR (`neWord8` w) = snd . breakR (`eqWord8` w) #-} takeWhileR f v@(Vec arr s l) = case findIndexR (not . f) v of -1 -> v @@ -246,7 +250,9 @@ -- | /O(n)/ Applied to a predicate @p@ and a vector @vs@, -- returns the suffix (possibly empty) remaining after 'takeWhile' @p vs@. dropWhile :: Vec v a => (a -> Bool) -> v a -> v a -{-# INLINE dropWhile #-} +{-# INLINE [1] dropWhile #-} +{-# RULES "dropWhile/breakEq1" forall w. dropWhile (w `neWord8`) = snd . break (w `eqWord8`) #-} +{-# RULES "dropWhile/breakEq2" forall w. dropWhile (`neWord8` w) = snd . break (`eqWord8` w) #-} dropWhile f v@(Vec arr s l) = case findIndex (not . f) v of i | i == l -> empty @@ -255,7 +261,9 @@ -- | /O(n)/ Applied to a predicate @p@ and a vector @vs@, -- returns the prefix (possibly empty) remaining before 'takeWhileR' @p vs@. dropWhileR :: Vec v a => (a -> Bool) -> v a -> v a -{-# INLINE dropWhileR #-} +{-# INLINE [1] dropWhileR #-} +{-# RULES "dropWhileR/breakEq1" forall w. dropWhileR (w `neWord8`) = fst . breakR (w `eqWord8`) #-} +{-# RULES "dropWhileR/breakEq2" forall w. dropWhileR (`neWord8` w) = fst . breakR (`eqWord8` w) #-} dropWhileR f v@(Vec arr s _) = case findIndexR (not . f) v of -1 -> empty @@ -283,11 +291,11 @@ -- @span (/=x)@ will be rewritten using a @memchr@. span :: Vec v a => (a -> Bool) -> v a -> (v a, v a) {-# INLINE [1] span #-} -span f = break (not . f) {-# RULES "spanNEq/breakEq1" forall w. span (w `neWord8`) = break (w `eqWord8`) #-} {-# RULES "spanNEq/breakEq2" forall w. span (`neWord8` w) = break (`eqWord8` w) #-} +span f = break (not . f) --- | 'breakR' behaves like 'break' but from the end of the vector. +-- | 'breakR' behaves like 'break' but apply predictor from the end of the vector. -- -- @breakR p == spanR (not.p)@ breakR :: Vec v a => (a -> Bool) -> v a -> (v a, v a) @@ -300,7 +308,9 @@ -- | 'spanR' behaves like 'span' but from the end of the vector. spanR :: Vec v a => (a -> Bool) -> v a -> (v a, v a) -{-# INLINE spanR #-} +{-# INLINE [1] spanR #-} +{-# RULES "spanNEq/breakREq1" forall w. spanR (w `neWord8`) = breakR (w `eqWord8`) #-} +{-# RULES "spanNEq/breakREq2" forall w. spanR (`neWord8` w) = breakR (`eqWord8` w) #-} spanR f = breakR (not . f) -- | Break a vector on a subvector, returning a pair of the part of the @@ -309,7 +319,7 @@ -- > break "wor" "hello, world" = ("hello, ", "world") -- breakOn :: (Vec v a, Eq a) => v a -> v a -> (v a, v a) -{-# INLINE breakOn #-} +{-# INLINABLE breakOn #-} breakOn needle = \ haystack@(Vec arr s l) -> case search haystack False of (i:_) -> let !v1 = Vec arr s i @@ -320,11 +330,11 @@ group :: (Vec v a, Eq a) => v a -> [v a] -{-# INLINE group #-} +{-# INLINABLE group #-} group = groupBy (==) groupBy :: forall v a. Vec v a => (a -> a -> Bool) -> v a -> [v a] -{-# INLINE groupBy #-} +{-# INLINABLE groupBy #-} groupBy f (Vec arr s l) | l == 0 = [] | otherwise = Vec arr s n : groupBy f (Vec arr (s+n) (l-n)) @@ -339,7 +349,7 @@ stripPrefix :: (Vec v a, Eq (v a)) => v a -- ^ the prefix to be tested -> v a -> Maybe (v a) -{-# INLINE stripPrefix #-} +{-# INLINABLE stripPrefix #-} stripPrefix v1@(Vec _ _ l1) v2@(Vec arr s l2) | v1 `isPrefixOf` v2 = Just (Vec arr (s+l1) (l2-l1)) | otherwise = Nothing @@ -348,7 +358,7 @@ isPrefixOf :: forall v a. (Vec v a, Eq (v a)) => v a -- ^ the prefix to be tested -> v a -> Bool -{-# INLINE isPrefixOf #-} +{-# INLINABLE isPrefixOf #-} isPrefixOf (Vec arrA sA lA) (Vec arrB sB lB) | lA == 0 = True | lA > lB = False @@ -364,7 +374,7 @@ -- >>> commonPrefix "veeble" "fetzer" -- ("","veeble","fetzer") commonPrefix :: (Vec v a, Eq a) => v a -> v a -> (v a, v a, v a) -{-# INLINE commonPrefix #-} +{-# INLINABLE commonPrefix #-} commonPrefix vA@(Vec arrA sA lA) vB@(Vec arrB sB lB) = go sA sB where !endA = sA + lA @@ -380,7 +390,7 @@ -- | O(n) The 'stripSuffix' function takes two vectors and returns Just the remainder of the second iff the first is its suffix, and otherwise Nothing. stripSuffix :: (Vec v a, Eq (v a)) => v a -> v a -> Maybe (v a) -{-# INLINE stripSuffix #-} +{-# INLINABLE stripSuffix #-} stripSuffix v1@(Vec _ _ l1) v2@(Vec arr s l2) | v1 `isSuffixOf` v2 = Just (Vec arr s (l2-l1)) | otherwise = Nothing @@ -388,7 +398,7 @@ -- | /O(n)/ The 'isSuffixOf' function takes two vectors and returns 'True' -- if the first is a suffix of the second. isSuffixOf :: forall v a. (Vec v a, Eq (v a)) => v a -> v a -> Bool -{-# INLINE isSuffixOf #-} +{-# INLINABLE isSuffixOf #-} isSuffixOf (Vec arrA sA lA) (Vec arrB sB lB) | lA == 0 = True | lA > lB = False @@ -398,7 +408,7 @@ -- -- @needle `isInfixOf` haystack === null haystack || indices needle haystake /= []@. isInfixOf :: (Vec v a, Eq a) => v a -> v a -> Bool -{-# INLINE isInfixOf #-} +{-# INLINABLE isInfixOf #-} isInfixOf needle = \ haystack -> null haystack || search haystack False /= [] where search = indices needle @@ -417,7 +427,7 @@ -- NOTE, this function behavior different with bytestring's. see -- . split :: (Vec v a, Eq a) => a -> v a -> [v a] -{-# INLINE split #-} +{-# INLINABLE split #-} split x = splitWith (==x) -- | /O(m+n)/ Break haystack into pieces separated by needle. @@ -441,7 +451,7 @@ -- > intercalate s . splitOn s == id -- > splitOn (singleton c) == split (==c) splitOn :: (Vec v a, Eq a) => v a -> v a -> [v a] -{-# INLINE splitOn #-} +{-# INLINABLE splitOn #-} splitOn needle = splitBySearch where splitBySearch haystack@(Vec arr s l) = go s (search haystack False) @@ -464,7 +474,7 @@ -- NOTE, this function behavior different with bytestring's. see -- . splitWith :: Vec v a => (a -> Bool) -> v a -> [v a] -{-# INLINE splitWith #-} +{-# INLINABLE splitWith #-} splitWith f = go where go v@(Vec _ _ l) @@ -477,7 +487,7 @@ -- | /O(n)/ Breaks a 'Bytes' up into a list of words, delimited by ascii space. words :: Bytes -> [Bytes] -{-# INLINE words #-} +{-# INLINABLE words #-} words (Vec arr s l) = go s s where !end = s + l @@ -498,7 +508,7 @@ -- -- Note that it __does not__ regard CR (@'\\r'@) as a newline character. lines :: Bytes -> [Bytes] -{-# INLINE lines #-} +{-# INLINABLE lines #-} lines v | null v = [] | otherwise = case elemIndex 10 v of @@ -507,19 +517,19 @@ -- | /O(n)/ Joins words with ascii space. unwords :: [Bytes] -> Bytes -{-# INLINE unwords #-} +{-# INLINABLE unwords #-} unwords = intercalateElem 32 -- | /O(n)/ Joins lines with ascii @\n@. -- -- NOTE: This functions is different from 'Prelude.unlines', it DOES NOT add a trailing @\n@. unlines :: [Bytes] -> Bytes -{-# INLINE unlines #-} +{-# INLINABLE unlines #-} unlines = intercalateElem 10 -- | Add padding to the left so that the whole vector's length is at least n. padLeft :: Vec v a => Int -> a -> v a -> v a -{-# INLINE padLeft #-} +{-# INLINABLE padLeft #-} padLeft n x v@(Vec arr s l) | n <= l = v | otherwise = create n (\ marr -> do setArr marr 0 (n-l) x @@ -527,7 +537,7 @@ -- | Add padding to the right so that the whole vector's length is at least n. padRight :: Vec v a => Int -> a -> v a -> v a -{-# INLINE padRight #-} +{-# INLINABLE padRight #-} padRight n x v@(Vec arr s l) | n <= l = v | otherwise = create n (\ marr -> do copyArr marr 0 arr s l @@ -539,7 +549,7 @@ -- | /O(n)/ 'reverse' @vs@ efficiently returns the elements of @xs@ in reverse order. -- reverse :: forall v a. (Vec v a) => v a -> v a -{-# INLINE reverse #-} +{-# INLINABLE reverse #-} reverse (Vec arr s l) = create l (go s (l-1)) where go :: Int -> Int -> MArr (IArray v) s a -> ST s () @@ -560,7 +570,7 @@ -- Lists. -- intersperse :: forall v a. Vec v a => a -> v a -> v a -{-# INLINE[1] intersperse #-} +{-# INLINE [1] intersperse #-} {-# RULES "intersperse/Bytes" intersperse = intersperseBytes #-} intersperse x v@(Vec arr s l) | l <= 1 = v | otherwise = create (2*l-1) (go s 0) @@ -589,7 +599,7 @@ -- | /O(n)/ Special 'intersperse' for 'Bytes' using SIMD intersperseBytes :: Word8 -> Bytes -> Bytes -{-# INLINE intersperseBytes #-} +{-# INLINABLE intersperseBytes #-} intersperseBytes c v@(PrimVector (PrimArray ba#) offset l) | l <= 1 = v | otherwise = unsafeDupablePerformIO $ do @@ -606,13 +616,13 @@ -- Note: 'intercalate' will force the entire vector list. -- intercalate :: Vec v a => v a -> [v a] -> v a -{-# INLINE intercalate #-} +{-# INLINABLE intercalate #-} intercalate s = concat . List.intersperse s -- | /O(n)/ An efficient way to join vector with an element. -- intercalateElem :: forall v a. Vec v a => a -> [v a] -> v a -{-# INLINE intercalateElem #-} +{-# INLINABLE intercalateElem #-} intercalateElem _ [] = empty intercalateElem _ [v] = v intercalateElem w vs = create (len vs 0) (go 0 vs) @@ -633,7 +643,7 @@ -- vector argument. -- transpose :: Vec v a => [v a] -> [v a] -{-# INLINE transpose #-} +{-# INLINABLE transpose #-} transpose vs = List.map (packN n) . List.transpose . List.map unpack $ vs where n = List.length vs @@ -647,7 +657,7 @@ -- a vector of corresponding sums, the result will be evaluated strictly. zipWith' :: forall v a u b w c. (Vec v a, Vec u b, Vec w c) => (a -> b -> c) -> v a -> u b -> w c -{-# INLINE zipWith' #-} +{-# INLINABLE zipWith' #-} zipWith' f (Vec arrA sA lA) (Vec arrB sB lB) = create len (go 0) where !len = min lA lB @@ -664,7 +674,7 @@ -- The results inside tuple will be evaluated strictly. unzipWith' :: forall v a u b w c. (Vec v a, Vec u b, Vec w c) => (a -> (b, c)) -> v a -> (u b, w c) -{-# INLINE unzipWith' #-} +{-# INLINABLE unzipWith' #-} unzipWith' f (Vec arr s l) = createN2 l l (go 0) where go :: forall s. Int -> MArr (IArray u) s b -> MArr (IArray w) s c -> ST s (Int, Int) @@ -689,7 +699,7 @@ -- > lastM (scanl' f z xs) == Just (foldl f z xs). -- scanl' :: forall v u a b. (Vec v a, Vec u b) => (b -> a -> b) -> b -> v a -> u b -{-# INLINE scanl' #-} +{-# INLINABLE scanl' #-} scanl' f z (Vec arr s l) = create (l+1) (\ marr -> writeArr marr 0 z >> go z s 1 marr) where @@ -708,7 +718,7 @@ -- > scanl1' f [] == [] -- scanl1' :: forall v a. Vec v a => (a -> a -> a) -> v a -> v a -{-# INLINE scanl1' #-} +{-# INLINABLE scanl1' #-} scanl1' f (Vec arr s l) | l <= 0 = empty | otherwise = case indexArr' arr s of @@ -717,7 +727,7 @@ -- | scanr' is the right-to-left dual of scanl'. -- scanr' :: forall v u a b. (Vec v a, Vec u b) => (a -> b -> b) -> b -> v a -> u b -{-# INLINE scanr' #-} +{-# INLINABLE scanr' #-} scanr' f z (Vec arr s l) = create (l+1) (\ marr -> writeArr marr l z >> go z (s+l-1) (l-1) marr) where @@ -732,7 +742,7 @@ -- | 'scanr1'' is a variant of 'scanr' that has no starting value argument. scanr1' :: forall v a. Vec v a => (a -> a -> a) -> v a -> v a -{-# INLINE scanr1' #-} +{-# INLINABLE scanr1' #-} scanr1' f (Vec arr s l) | l <= 0 = empty | otherwise = case indexArr' arr (s+l-1) of @@ -743,7 +753,7 @@ -- | @x' = rangeCut x min max@ limit @x'@ 's range to @min@ ~ @max@. rangeCut :: Int -> Int -> Int -> Int -{-# INLINE rangeCut #-} +{-# INLINABLE rangeCut #-} rangeCut !r !min' !max' | r < min' = min' | r > max' = max' | otherwise = r diff --git a/Z/Data/Vector/FlatIntMap.hs b/Z/Data/Vector/FlatIntMap.hs --- a/Z/Data/Vector/FlatIntMap.hs +++ b/Z/Data/Vector/FlatIntMap.hs @@ -126,27 +126,27 @@ -- | /O(1)/ empty flat map. empty :: FlatIntMap v -{-# INLINE empty #-} +{-# NOINLINE empty #-} empty = FlatIntMap V.empty -- | /O(N*logN)/ Pack list of key values, on key duplication prefer left one. pack :: [V.IPair v] -> FlatIntMap v -{-# INLINE pack #-} +{-# INLINABLE pack #-} pack kvs = FlatIntMap (V.mergeDupAdjacentLeft ((==) `on` V.ifst) (V.mergeSortBy (compare `on` V.ifst) (V.pack kvs))) -- | /O(N*logN)/ Pack list of key values with suggested size, on key duplication prefer left one. packN :: Int -> [V.IPair v] -> FlatIntMap v -{-# INLINE packN #-} +{-# INLINABLE packN #-} packN n kvs = FlatIntMap (V.mergeDupAdjacentLeft ((==) `on` V.ifst) (V.mergeSortBy (compare `on` V.ifst) (V.packN n kvs))) -- | /O(N*logN)/ Pack list of key values, on key duplication prefer right one. packR :: [V.IPair v] -> FlatIntMap v -{-# INLINE packR #-} +{-# INLINABLE packR #-} packR kvs = FlatIntMap (V.mergeDupAdjacentRight ((==) `on` V.ifst) (V.mergeSortBy (compare `on` V.ifst) (V.pack kvs))) -- | /O(N*logN)/ Pack list of key values with suggested size, on key duplication prefer right one. packRN :: Int -> [V.IPair v] -> FlatIntMap v -{-# INLINE packRN #-} +{-# INLINABLE packRN #-} packRN n kvs = FlatIntMap (V.mergeDupAdjacentRight ((==) `on` V.ifst) (V.mergeSortBy (compare `on` V.ifst) (V.packN n kvs))) -- | /O(N)/ Unpack key value pairs to a list sorted by keys in ascending order. @@ -165,12 +165,12 @@ -- | /O(N*logN)/ Pack vector of key values, on key duplication prefer left one. packVector :: V.Vector (V.IPair v) -> FlatIntMap v -{-# INLINE packVector #-} +{-# INLINABLE packVector #-} packVector kvs = FlatIntMap (V.mergeDupAdjacentLeft ((==) `on` V.ifst) (V.mergeSortBy (compare `on` V.ifst) kvs)) -- | /O(N*logN)/ Pack vector of key values, on key duplication prefer right one. packVectorR :: V.Vector (V.IPair v) -> FlatIntMap v -{-# INLINE packVectorR #-} +{-# INLINABLE packVectorR #-} packVectorR kvs = FlatIntMap (V.mergeDupAdjacentRight ((==) `on` V.ifst) (V.mergeSortBy (compare `on` V.ifst) kvs)) -- | /O(logN)/ Binary search on flat map. @@ -193,7 +193,7 @@ -- | /O(N)/ Insert new key value into map, replace old one if key exists. insert :: Int -> v -> FlatIntMap v -> FlatIntMap v -{-# INLINE insert #-} +{-# INLINABLE insert #-} insert k v (FlatIntMap vec) = case binarySearch vec k of Left i -> FlatIntMap (V.unsafeInsertIndex vec i (V.IPair k v)) @@ -201,7 +201,7 @@ -- | /O(N)/ Delete a key value pair by key. delete :: Int -> FlatIntMap v -> FlatIntMap v -{-# INLINE delete #-} +{-# INLINABLE delete #-} delete k m@(FlatIntMap vec) = case binarySearch vec k of Left _ -> m @@ -211,7 +211,7 @@ -- -- The value is evaluated to WHNF before writing into map. adjust' :: (v -> v) -> Int -> FlatIntMap v -> FlatIntMap v -{-# INLINE adjust' #-} +{-# INLINABLE adjust' #-} adjust' f k m@(FlatIntMap vec) = case binarySearch vec k of Left _ -> m @@ -318,7 +318,7 @@ -- function also has access to the key associated with a value. traverseWithKey :: Applicative t => (Int -> a -> t b) -> FlatIntMap a -> t (FlatIntMap b) {-# INLINE traverseWithKey #-} -traverseWithKey f (FlatIntMap vs) = FlatIntMap <$> traverse (\ (V.IPair k v) -> V.IPair k <$> f k v) vs +traverseWithKey f (FlatIntMap vs) = FlatIntMap <$> V.traverse (\ (V.IPair k v) -> V.IPair k <$> f k v) vs -------------------------------------------------------------------------------- diff --git a/Z/Data/Vector/FlatIntSet.hs b/Z/Data/Vector/FlatIntSet.hs --- a/Z/Data/Vector/FlatIntSet.hs +++ b/Z/Data/Vector/FlatIntSet.hs @@ -91,27 +91,27 @@ -- | /O(1)/ empty flat set. empty :: FlatIntSet -{-# INLINE empty #-} +{-# NOINLINE empty #-} empty = FlatIntSet V.empty -- | /O(N*logN)/ Pack list of values, on duplication prefer left one. pack :: [Int] -> FlatIntSet -{-# INLINE pack #-} +{-# INLINABLE pack #-} pack vs = FlatIntSet (V.mergeDupAdjacentLeft (==) (V.mergeSort (V.pack vs))) -- | /O(N*logN)/ Pack list of values with suggested size, on duplication prefer left one. packN :: Int -> [Int] -> FlatIntSet -{-# INLINE packN #-} +{-# INLINABLE packN #-} packN n vs = FlatIntSet (V.mergeDupAdjacentLeft (==) (V.mergeSort (V.packN n vs))) -- | /O(N*logN)/ Pack list of values, on duplication prefer right one. packR :: [Int] -> FlatIntSet -{-# INLINE packR #-} +{-# INLINABLE packR #-} packR vs = FlatIntSet (V.mergeDupAdjacentRight (==) (V.mergeSort (V.pack vs))) -- | /O(N*logN)/ Pack list of values with suggested size, on duplication prefer right one. packRN :: Int -> [Int] -> FlatIntSet -{-# INLINE packRN #-} +{-# INLINABLE packRN #-} packRN n vs = FlatIntSet (V.mergeDupAdjacentRight (==) (V.mergeSort (V.packN n vs))) -- | /O(N)/ Unpack a set of values to a list s in ascending order. @@ -130,23 +130,23 @@ -- | /O(N*logN)/ Pack vector of values, on duplication prefer left one. packVector :: V.PrimVector Int -> FlatIntSet -{-# INLINE packVector #-} +{-# INLINABLE packVector #-} packVector vs = FlatIntSet (V.mergeDupAdjacentLeft (==) (V.mergeSort vs)) -- | /O(N*logN)/ Pack vector of values, on duplication prefer right one. packVectorR :: V.PrimVector Int -> FlatIntSet -{-# INLINE packVectorR #-} +{-# INLINABLE packVectorR #-} packVectorR vs = FlatIntSet (V.mergeDupAdjacentRight (==) (V.mergeSort vs)) -- | /O(logN)/ Binary search on flat set. elem :: Int -> FlatIntSet -> Bool -{-# INLINE elem #-} +{-# INLINABLE elem #-} elem v (FlatIntSet vec) = case binarySearch vec v of Left _ -> False _ -> True -- | /O(N)/ Insert new value into set. insert :: Int -> FlatIntSet -> FlatIntSet -{-# INLINE insert #-} +{-# INLINABLE insert #-} insert v m@(FlatIntSet vec) = case binarySearch vec v of Left i -> FlatIntSet (V.unsafeInsertIndex vec i v) @@ -154,7 +154,7 @@ -- | /O(N)/ Delete a value. delete :: Int -> FlatIntSet -> FlatIntSet -{-# INLINE delete #-} +{-# INLINABLE delete #-} delete v m@(FlatIntSet vec) = case binarySearch vec v of Left _ -> m diff --git a/Z/Data/Vector/FlatMap.hs b/Z/Data/Vector/FlatMap.hs --- a/Z/Data/Vector/FlatMap.hs +++ b/Z/Data/Vector/FlatMap.hs @@ -126,27 +126,27 @@ -- | /O(1)/ empty flat map. empty :: FlatMap k v -{-# INLINE empty #-} +{-# NOINLINE empty #-} empty = FlatMap V.empty -- | /O(N*logN)/ Pack list of key values, on key duplication prefer left one. pack :: Ord k => [(k, v)] -> FlatMap k v -{-# INLINE pack #-} +{-# INLINABLE pack #-} pack kvs = FlatMap (V.mergeDupAdjacentLeft ((==) `on` fst) (V.mergeSortBy (compare `on` fst) (V.pack kvs))) -- | /O(N*logN)/ Pack list of key values with suggested size, on key duplication prefer left one. packN :: Ord k => Int -> [(k, v)] -> FlatMap k v -{-# INLINE packN #-} +{-# INLINABLE packN #-} packN n kvs = FlatMap (V.mergeDupAdjacentLeft ((==) `on` fst) (V.mergeSortBy (compare `on` fst) (V.packN n kvs))) -- | /O(N*logN)/ Pack list of key values, on key duplication prefer right one. packR :: Ord k => [(k, v)] -> FlatMap k v -{-# INLINE packR #-} +{-# INLINABLE packR #-} packR kvs = FlatMap (V.mergeDupAdjacentRight ((==) `on` fst) (V.mergeSortBy (compare `on` fst) (V.pack kvs))) -- | /O(N*logN)/ Pack list of key values with suggested size, on key duplication prefer right one. packRN :: Ord k => Int -> [(k, v)] -> FlatMap k v -{-# INLINE packRN #-} +{-# INLINABLE packRN #-} packRN n kvs = FlatMap (V.mergeDupAdjacentRight ((==) `on` fst) (V.mergeSortBy (compare `on` fst) (V.packN n kvs))) -- | /O(N)/ Unpack key value pairs to a list sorted by keys in ascending order. @@ -165,12 +165,12 @@ -- | /O(N*logN)/ Pack vector of key values, on key duplication prefer left one. packVector :: Ord k => V.Vector (k, v) -> FlatMap k v -{-# INLINE packVector #-} +{-# INLINABLE packVector #-} packVector kvs = FlatMap (V.mergeDupAdjacentLeft ((==) `on` fst) (V.mergeSortBy (compare `on` fst) kvs)) -- | /O(N*logN)/ Pack vector of key values, on key duplication prefer right one. packVectorR :: Ord k => V.Vector (k, v) -> FlatMap k v -{-# INLINE packVectorR #-} +{-# INLINABLE packVectorR #-} packVectorR kvs = FlatMap (V.mergeDupAdjacentRight ((==) `on` fst) (V.mergeSortBy (compare `on` fst) kvs)) -- | /O(logN)/ Binary search on flat map. @@ -193,7 +193,7 @@ -- | /O(N)/ Insert new key value into map, replace old one if key exists. insert :: Ord k => k -> v -> FlatMap k v -> FlatMap k v -{-# INLINE insert #-} +{-# INLINABLE insert #-} insert k v (FlatMap vec) = case binarySearch vec k of Left i -> FlatMap (V.unsafeInsertIndex vec i (k, v)) @@ -201,7 +201,7 @@ -- | /O(N)/ Delete a key value pair by key. delete :: Ord k => k -> FlatMap k v -> FlatMap k v -{-# INLINE delete #-} +{-# INLINABLE delete #-} delete k m@(FlatMap vec) = case binarySearch vec k of Left _ -> m @@ -211,7 +211,7 @@ -- -- The value is evaluated to WHNF before writing into map. adjust' :: Ord k => (v -> v) -> k -> FlatMap k v -> FlatMap k v -{-# INLINE adjust' #-} +{-# INLINABLE adjust' #-} adjust' f k m@(FlatMap vec) = case binarySearch vec k of Left _ -> m @@ -319,7 +319,7 @@ -- function also has access to the key associated with a value. traverseWithKey :: Applicative t => (k -> a -> t b) -> FlatMap k a -> t (FlatMap k b) {-# INLINE traverseWithKey #-} -traverseWithKey f (FlatMap vs) = FlatMap <$> traverse (\ (k,v) -> (k,) <$> f k v) vs +traverseWithKey f (FlatMap vs) = FlatMap <$> V.traverse (\ (k,v) -> (k,) <$> f k v) vs -------------------------------------------------------------------------------- diff --git a/Z/Data/Vector/FlatSet.hs b/Z/Data/Vector/FlatSet.hs --- a/Z/Data/Vector/FlatSet.hs +++ b/Z/Data/Vector/FlatSet.hs @@ -91,27 +91,27 @@ -- | /O(1)/ empty flat set. empty :: FlatSet v -{-# INLINE empty #-} +{-# NOINLINE empty #-} empty = FlatSet V.empty -- | /O(N*logN)/ Pack list of values, on duplication prefer left one. pack :: Ord v => [v] -> FlatSet v -{-# INLINE pack #-} +{-# INLINABLE pack #-} pack vs = FlatSet (V.mergeDupAdjacentLeft (==) (V.mergeSort (V.pack vs))) -- | /O(N*logN)/ Pack list of values with suggested size, on duplication prefer left one. packN :: Ord v => Int -> [v] -> FlatSet v -{-# INLINE packN #-} +{-# INLINABLE packN #-} packN n vs = FlatSet (V.mergeDupAdjacentLeft (==) (V.mergeSort (V.packN n vs))) -- | /O(N*logN)/ Pack list of values, on duplication prefer right one. packR :: Ord v => [v] -> FlatSet v -{-# INLINE packR #-} +{-# INLINABLE packR #-} packR vs = FlatSet (V.mergeDupAdjacentRight (==) (V.mergeSort (V.pack vs))) -- | /O(N*logN)/ Pack list of values with suggested size, on duplication prefer right one. packRN :: Ord v => Int -> [v] -> FlatSet v -{-# INLINE packRN #-} +{-# INLINABLE packRN #-} packRN n vs = FlatSet (V.mergeDupAdjacentRight (==) (V.mergeSort (V.packN n vs))) -- | /O(N)/ Unpack a set of values to a list s in ascending order. @@ -130,22 +130,22 @@ -- | /O(N*logN)/ Pack vector of values, on duplication prefer left one. packVector :: Ord v => V.Vector v -> FlatSet v -{-# INLINE packVector #-} +{-# INLINABLE packVector #-} packVector vs = FlatSet (V.mergeDupAdjacentLeft (==) (V.mergeSort vs)) -- | /O(N*logN)/ Pack vector of values, on duplication prefer right one. packVectorR :: Ord v => V.Vector v -> FlatSet v -{-# INLINE packVectorR #-} +{-# INLINABLE packVectorR #-} packVectorR vs = FlatSet (V.mergeDupAdjacentRight (==) (V.mergeSort vs)) -- | /O(logN)/ Binary search on flat set. elem :: Ord v => v -> FlatSet v -> Bool -{-# INLINE elem #-} +{-# INLINABLE elem #-} elem v (FlatSet vec) = case binarySearch vec v of Left _ -> False _ -> True -- | /O(N)/ Insert new value into set. insert :: Ord v => v -> FlatSet v -> FlatSet v -{-# INLINE insert #-} +{-# INLINABLE insert #-} insert v m@(FlatSet vec) = case binarySearch vec v of Left i -> FlatSet (V.unsafeInsertIndex vec i v) @@ -153,7 +153,7 @@ -- | /O(N)/ Delete a value from set. delete :: Ord v => v -> FlatSet v -> FlatSet v -{-# INLINE delete #-} +{-# INLINABLE delete #-} delete v m@(FlatSet vec) = case binarySearch vec v of Left _ -> m diff --git a/Z/Data/Vector/Hex.hs b/Z/Data/Vector/Hex.hs --- a/Z/Data/Vector/Hex.hs +++ b/Z/Data/Vector/Hex.hs @@ -66,7 +66,7 @@ -- | Encode 'V.Bytes' using hex(base16) encoding. hexEncode :: Bool -- ^ uppercase? -> V.Bytes -> V.Bytes -{-# INLINE hexEncode #-} +{-# INLINABLE hexEncode #-} hexEncode upper (V.PrimVector arr s l) = fst . unsafeDupablePerformIO $ do allocPrimVectorUnsafe (l `unsafeShiftL` 1) $ \ buf# -> withPrimArrayUnsafe arr $ \ parr _ -> @@ -88,7 +88,7 @@ -- | Text version of 'hexEncode'. hexEncodeText :: Bool -- ^ uppercase? -> V.Bytes -> T.Text -{-# INLINE hexEncodeText #-} +{-# INLINABLE hexEncodeText #-} hexEncodeText upper = T.Text . hexEncode upper -- | Decode a hex encoding string, return Nothing on illegal bytes or incomplete input. @@ -134,14 +134,14 @@ -- | Decode a hex encoding string, throw 'HexDecodeException' on error. hexDecode' :: HasCallStack => V.Bytes -> V.Bytes -{-# INLINABLE hexDecode' #-} +{-# INLINE hexDecode' #-} hexDecode' ba = case hexDecode ba of Just r -> r _ -> throw (IllegalHexBytes ba callStack) -- | Decode a hex encoding string, ignore ASCII whitespace(space, tab, newline, vertical tab, form feed, carriage return), throw 'HexDecodeException' on error. hexDecodeWS' :: HasCallStack => V.Bytes -> V.Bytes -{-# INLINABLE hexDecodeWS' #-} +{-# INLINE hexDecodeWS' #-} hexDecodeWS' ba = case hexDecodeWS ba of Just r -> r _ -> throw (IllegalHexBytes ba callStack) diff --git a/Z/Data/Vector/Search.hs b/Z/Data/Vector/Search.hs --- a/Z/Data/Vector/Search.hs +++ b/Z/Data/Vector/Search.hs @@ -78,7 +78,7 @@ -- | /O(n)/ Special 'elemIndices' for 'Bytes' using @memchr(3)@ elemIndicesBytes :: Word8 -> Bytes -> [Int] -{-# INLINE elemIndicesBytes #-} +{-# INLINABLE elemIndicesBytes #-} elemIndicesBytes w (PrimVector (PrimArray ba#) s l) = go s where !end = s + l @@ -91,12 +91,12 @@ -- | @findIndex f v = fst (find f v)@ findIndex :: Vec v a => (a -> Bool) -> v a -> Int -{-# INLINE findIndex #-} +{-# INLINABLE findIndex #-} findIndex f v = fst (find f v) -- | @findIndexR f v = fst (findR f v)@ findIndexR :: Vec v a => (a -> Bool) -> v a -> Int -{-# INLINE findIndexR #-} +{-# INLINABLE findIndexR #-} findIndexR f v = fst (findR f v) -- | /O(n)/ find the first index and element matching the predicate in a vector @@ -116,7 +116,7 @@ -- | /O(n)/ Special 'findByte' for 'Word8' using @memchr(3)@ findByte :: Word8 -> Bytes -> (Int, Maybe Word8) -{-# INLINE findByte #-} +{-# INLINABLE findByte #-} findByte w (PrimVector (PrimArray ba#) s l) = case c_memchr ba# s w l of -1 -> (l, Nothing) @@ -138,7 +138,7 @@ -- | /O(n)/ Special 'findR' for 'Bytes' with @memrchr@. findByteR :: Word8 -> Bytes -> (Int, Maybe Word8) -{-# INLINE findByteR #-} +{-# INLINABLE findByteR #-} findByteR w (PrimVector (PrimArray ba#) s l) = case c_memrchr ba# s w l of -1 -> (-1, Nothing) @@ -148,7 +148,7 @@ -- returns a vector containing those elements that satisfy the -- predicate. filter :: forall v a. Vec v a => (a -> Bool) -> v a -> v a -{-# INLINE filter #-} +{-# INLINABLE filter #-} filter g (Vec arr s l) | l == 0 = empty | otherwise = createN l (go g 0 s) @@ -167,7 +167,7 @@ -- -- > partition p vs == (filter p vs, filter (not . p) vs) partition :: forall v a. Vec v a => (a -> Bool) -> v a -> (v a, v a) -{-# INLINE partition #-} +{-# INLINABLE partition #-} partition g (Vec arr s l) | l == 0 = (empty, empty) | otherwise = createN2 l l (go g 0 0 s) @@ -211,7 +211,7 @@ -> v a -- ^ vector to search in (@haystack@) -> Bool -- ^ report partial match at the end of haystack -> [Int] -{-# INLINABLE[1] indicesOverlapping #-} +{-# INLINE [1] indicesOverlapping #-} {-# RULES "indicesOverlapping/Bytes" indicesOverlapping = indicesOverlappingBytes #-} indicesOverlapping needle@(Vec narr noff nlen) = search where @@ -321,7 +321,7 @@ -- -- > indicesOverlapping "" "abc" = [0,1,2] indices :: (Vec v a, Eq a) => v a -> v a -> Bool -> [Int] -{-# INLINABLE[1] indices #-} +{-# INLINE [1] indices #-} {-# RULES "indices/Bytes" indices = indicesBytes #-} indices needle@(Vec narr noff nlen) = search where @@ -407,7 +407,7 @@ -- is found, check if @next[j] == -1@, if so next search continue with @needle[0]@ -- and @haystack[i+1]@, otherwise continue with @needle[next[j]]@ and @haystack[i]@. kmpNextTable :: (Vec v a, Eq a) => v a -> PrimArray Int -{-# INLINE kmpNextTable #-} +{-# INLINABLE kmpNextTable #-} kmpNextTable (Vec arr s l) = runST (do ma <- newArr (l+1) writeArr ma 0 (-1) @@ -438,7 +438,7 @@ -- This's particularly suitable for search UTF-8 bytes since the significant bits -- of a beginning byte is usually the same. sundayBloom :: Bytes -> Word64 -{-# INLINE sundayBloom #-} +{-# INLINABLE sundayBloom #-} sundayBloom (Vec arr s l) = go 0x00000000 s where !end = s+l @@ -452,5 +452,5 @@ -- | O(1) Test if a bloom filter contain a certain 'Word8'. -- elemSundayBloom :: Word64 -> Word8 -> Bool -{-# INLINE elemSundayBloom #-} +{-# INLINABLE elemSundayBloom #-} elemSundayBloom b w = b .&. (0x01 `unsafeShiftL` (fromIntegral w .&. 0x3f)) /= 0 diff --git a/Z/Data/Vector/Sort.hs b/Z/Data/Vector/Sort.hs --- a/Z/Data/Vector/Sort.hs +++ b/Z/Data/Vector/Sort.hs @@ -76,7 +76,7 @@ mergeSort = mergeSortBy compare mergeSortBy :: forall v a. Vec v a => (a -> a -> Ordering) -> v a -> v a -{-# INLINE mergeSortBy #-} +{-# INLINABLE mergeSortBy #-} mergeSortBy cmp vec@(Vec _ _ l) | l <= mergeTileSize = insertSortBy cmp vec | otherwise = runST (do @@ -139,7 +139,7 @@ -- | The mergesort tile size, @mergeTileSize = 8@. mergeTileSize :: Int -{-# INLINE mergeTileSize #-} +{-# INLINABLE mergeTileSize #-} mergeTileSize = 8 -- | /O(n^2)/ Sort vector based on element's 'Ord' instance with simple @@ -148,11 +148,11 @@ -- This is a stable sort. O(n) extra space are needed, -- which will be freezed into result vector. insertSort :: (Vec v a, Ord a) => v a -> v a -{-# INLINE insertSort #-} +{-# INLINABLE insertSort #-} insertSort = insertSortBy compare insertSortBy :: Vec v a => (a -> a -> Ordering) -> v a -> v a -{-# INLINE insertSortBy #-} +{-# INLINABLE insertSortBy #-} insertSortBy cmp v@(Vec _ _ l) | l <= 1 = v | otherwise = create l (insertSortToMArr cmp v 0) @@ -162,7 +162,7 @@ -> Int -- writing offset in the mutable array -> MArr (IArray v) s a -- writing mutable array, must have enough space! -> ST s () -{-# INLINE insertSortToMArr #-} +{-# INLINABLE insertSortToMArr #-} insertSortToMArr cmp (Vec arr s l) moff marr = go s where !end = s + l @@ -457,7 +457,7 @@ -- -- Use this function on a sorted vector will have the same effects as 'nub'. mergeDupAdjacent :: forall v a. (Vec v a, Eq a) => v a -> v a -{-# INLINE mergeDupAdjacent #-} +{-# INLINABLE mergeDupAdjacent #-} mergeDupAdjacent = mergeDupAdjacentBy (==) const -- | Merge duplicated adjacent element, prefer left element. @@ -466,14 +466,14 @@ -> v a -> v a mergeDupAdjacentLeft eq = mergeDupAdjacentBy eq const -{-# INLINE mergeDupAdjacentLeft #-} +{-# INLINABLE mergeDupAdjacentLeft #-} -- | Merge duplicated adjacent element, prefer right element. mergeDupAdjacentRight :: forall v a. Vec v a => (a -> a -> Bool) -- ^ equality tester, @\ left right -> eq left right@ -> v a -> v a -{-# INLINE mergeDupAdjacentRight #-} +{-# INLINABLE mergeDupAdjacentRight #-} mergeDupAdjacentRight eq = mergeDupAdjacentBy eq (\ _ x -> x) -- | Merge duplicated adjacent element, based on a equality tester and a merger function. diff --git a/Z/Foreign.hs b/Z/Foreign.hs --- a/Z/Foreign.hs +++ b/Z/Foreign.hs @@ -93,6 +93,7 @@ , module Foreign.C.Types , module Data.Primitive.Ptr , module Z.Data.Array.Unaligned + , withMutablePrimArrayContents, withPrimArrayContents -- ** Internal helpers , hs_std_string_size , hs_copy_std_string @@ -111,7 +112,7 @@ import Foreign.C.Types import GHC.Ptr import GHC.Exts -import Z.Data.Array +import Z.Data.Array.Base (withMutablePrimArrayContents, withPrimArrayContents) import Z.Data.Array.Unaligned import Z.Data.Array.UnliftedArray import Z.Data.Vector.Base @@ -183,6 +184,7 @@ clearMBA :: MBA# a -> Int -- ^ in bytes -> IO () +{-# INLINE clearMBA #-} clearMBA mba# len = do let mba = (MutableByteArray mba#) setByteArray mba 0 len (0 :: Word8) @@ -209,6 +211,7 @@ -- -- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY. withPrimArrayListUnsafe :: [PrimArray a] -> (BAArray# a -> Int -> IO b) -> IO b +{-# INLINE withPrimArrayListUnsafe #-} withPrimArrayListUnsafe pas f = do let l = List.length pas mla <- unsafeNewUnliftedArray l @@ -301,7 +304,7 @@ -- -- Don't pass a forever loop to this function, see . withPrimArraySafe :: (Prim a) => PrimArray a -> (Ptr a -> Int -> IO b) -> IO b -{-# INLINE withPrimArraySafe #-} +{-# INLINABLE withPrimArraySafe #-} withPrimArraySafe arr f | isPrimArrayPinned arr = do let siz = sizeofPrimArray arr @@ -340,7 +343,7 @@ => Int -- ^ in elements -> (Ptr a -> IO b) -> IO (PrimArray a, b) -{-# INLINE allocPrimArraySafe #-} +{-# INLINABLE allocPrimArraySafe #-} allocPrimArraySafe len f = do mpa <- newAlignedPinnedPrimArray len !r <- withMutablePrimArrayContents mpa f @@ -354,7 +357,7 @@ -- -- Don't pass a forever loop to this function, see . withPrimVectorSafe :: forall a b. Prim a => PrimVector a -> (Ptr a -> Int -> IO b) -> IO b -{-# INLINE withPrimVectorSafe #-} +{-# INLINABLE withPrimVectorSafe #-} withPrimVectorSafe (PrimVector arr s l) f | isPrimArrayPinned arr = withPrimArrayContents arr $ \ ptr -> @@ -370,7 +373,7 @@ -- -- Don't pass a forever loop to this function, see . withPrimSafe :: forall a b. Prim a => a -> (Ptr a -> IO b) -> IO (a, b) -{-# INLINE withPrimSafe #-} +{-# INLINABLE withPrimSafe #-} withPrimSafe v f = do buf <- newAlignedPinnedPrimArray 1 writePrimArray buf 0 v @@ -380,7 +383,7 @@ -- | like 'withPrimSafe', but don't write initial value. allocPrimSafe :: forall a b. Prim a => (Ptr a -> IO b) -> IO (a, b) -{-# INLINE allocPrimSafe #-} +{-# INLINABLE allocPrimSafe #-} allocPrimSafe f = do buf <- newAlignedPinnedPrimArray 1 !b <- withMutablePrimArrayContents buf $ \ ptr -> f ptr @@ -391,7 +394,7 @@ allocPrimVectorSafe :: forall a b . Prim a => Int -- ^ in elements -> (Ptr a -> IO b) -> IO (PrimVector a, b) -{-# INLINE allocPrimVectorSafe #-} +{-# INLINABLE allocPrimVectorSafe #-} allocPrimVectorSafe len f = do mpa <- newAlignedPinnedPrimArray len !r <- withMutablePrimArrayContents mpa f @@ -402,12 +405,12 @@ -- | Allocate some bytes and pass to FFI as pointer, freeze result into a 'PrimVector'. allocBytesSafe :: Int -- ^ in bytes -> (Ptr Word8 -> IO b) -> IO (Bytes, b) -{-# INLINE allocBytesSafe #-} +{-# INLINABLE allocBytesSafe #-} allocBytesSafe = allocPrimVectorSafe -- | Convert a 'PrimArray' to a pinned one(memory won't moved by GC) if necessary. pinPrimArray :: Prim a => PrimArray a -> IO (PrimArray a) -{-# INLINE pinPrimArray #-} +{-# INLINABLE pinPrimArray #-} pinPrimArray arr | isPrimArrayPinned arr = return arr | otherwise = do @@ -419,7 +422,7 @@ -- | Convert a 'PrimVector' to a pinned one(memory won't moved by GC) if necessary. pinPrimVector :: Prim a => PrimVector a -> IO (PrimVector a) -{-# INLINE pinPrimVector #-} +{-# INLINABLE pinPrimVector #-} pinPrimVector v@(PrimVector pa s l) | isPrimArrayPinned pa = return v | otherwise = do @@ -438,7 +441,7 @@ -- should be given in bytes. -- clearPtr :: Ptr a -> Int -> IO () -{-# INLINE clearPtr #-} +{-# INLINABLE clearPtr #-} clearPtr dest nbytes = memset dest 0 (fromIntegral nbytes) -- | Copy some bytes from a null terminated pointer(without copying the null terminator). @@ -447,7 +450,7 @@ -- This method is provided if you really need to read 'Bytes', there's no encoding guarantee, -- result could be any bytes sequence. fromNullTerminated :: Ptr a -> IO Bytes -{-# INLINE fromNullTerminated #-} +{-# INLINABLE fromNullTerminated #-} fromNullTerminated (Ptr addr#) = do len <- fromIntegral <$> c_strlen addr# marr <- newPrimArray len @@ -460,7 +463,7 @@ -- There's no encoding guarantee, result could be any bytes sequence. fromPtr :: Ptr a -> Int -- ^ in bytes -> IO Bytes -{-# INLINE fromPtr #-} +{-# INLINABLE fromPtr #-} fromPtr (Ptr addr#) len = do marr <- newPrimArray len copyPtrToMutablePrimArray marr 0 (Ptr addr#) len @@ -473,7 +476,7 @@ fromPrimPtr :: forall a. Prim a => Ptr a -> Int -- ^ in elements -> IO (PrimVector a) -{-# INLINE fromPrimPtr #-} +{-# INLINABLE fromPrimPtr #-} fromPrimPtr (Ptr addr#) len = do marr <- newPrimArray len copyPtrToMutablePrimArray marr 0 (Ptr addr#) len @@ -486,6 +489,7 @@ -- | Run FFI in bracket and marshall @std::string*@ result into Haskell heap bytes, -- memory pointed by @std::string*@ will be @delete@ ed. fromStdString :: IO (Ptr StdString) -> IO Bytes +{-# INLINABLE fromStdString #-} fromStdString f = bracket f hs_delete_std_string (\ q -> do siz <- hs_std_string_size q @@ -498,9 +502,11 @@ -- | O(n), Convert from 'ByteString'. fromByteString :: ByteString -> Bytes +{-# INLINABLE fromByteString #-} fromByteString bs = case toShort bs of (SBS ba#) -> PrimVector (PrimArray ba#) 0 (B.length bs) -- | O(n), Convert tp 'ByteString'. toByteString :: Bytes -> ByteString +{-# INLINABLE toByteString #-} toByteString (PrimVector (PrimArray ba#) s l) = B.unsafeTake l . B.unsafeDrop s . fromShort $ SBS ba# diff --git a/Z/Foreign/CPtr.hs b/Z/Foreign/CPtr.hs --- a/Z/Foreign/CPtr.hs +++ b/Z/Foreign/CPtr.hs @@ -28,7 +28,7 @@ import GHC.Ptr import GHC.Exts import GHC.IO -import Z.Data.Array +import Z.Data.Array hiding (newPinnedPrimArray) import Z.Foreign -- | Lightweight foreign pointers. diff --git a/test/Z/Data/Builder/TimeSpec.hs b/test/Z/Data/Builder/TimeSpec.hs --- a/test/Z/Data/Builder/TimeSpec.hs +++ b/test/Z/Data/Builder/TimeSpec.hs @@ -18,21 +18,22 @@ import Test.Hspec import Test.Hspec.QuickCheck import Data.Time.LocalTime +import Data.Time.Calendar spec :: Spec spec = describe "builder time" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do - describe "utcTime === format" $ do prop "utcTime === format" $ \ t -> (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" t) === (T.unpack . B.buildText $ B.utcTime t) - describe "localTime === format" $ do prop "localTime === format" $ \ t -> (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q" t) === (T.unpack . B.buildText $ B.localTime t) - describe "zonedTime === format" $ do prop "zonedTime === format" $ \ t0 z0 -> let z = abs z0 `div` 1440 t = ZonedTime t0 (minutesToTimeZone z) in if z == 0 then (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" t) === (T.unpack . B.buildText $ B.zonedTime t) else (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" t) === (T.unpack . B.buildText $ B.zonedTime t) + + modifyMaxSuccess (*100) . modifyMaxSize (*100) . prop "toGregorianInt64 === toGregorian" $ \ mjd -> + B.toGregorian' mjd == toGregorian mjd diff --git a/test/Z/Data/Parser/BaseSpec.hs b/test/Z/Data/Parser/BaseSpec.hs --- a/test/Z/Data/Parser/BaseSpec.hs +++ b/test/Z/Data/Parser/BaseSpec.hs @@ -57,13 +57,13 @@ (w:_) | f w -> Just (V.pack (L.dropWhile f s), V.pack (L.takeWhile f s)) _ -> Nothing - prop "take" $ \ s n -> + prop "take" $ \ s (Positive n) -> parse'' (P.take n) s === if L.length s >= n then Just (V.pack (L.drop n s), V.pack (L.take n s)) else Nothing - prop "skip" $ \ s n -> + prop "skip" $ \ s (Positive n) -> parse'' (P.skip n) s === if L.length s >= n then Just (V.pack (L.drop n s), ()) diff --git a/test/Z/Data/Parser/TimeSpec.hs b/test/Z/Data/Parser/TimeSpec.hs --- a/test/Z/Data/Parser/TimeSpec.hs +++ b/test/Z/Data/Parser/TimeSpec.hs @@ -10,6 +10,7 @@ import Data.Time.Format import qualified Z.Data.Builder as B import qualified Z.Data.Parser as P +import qualified Z.Data.Parser.Time as P import qualified Z.Data.Text as T import Test.QuickCheck import Test.QuickCheck.Function @@ -18,19 +19,20 @@ import Test.Hspec import Test.Hspec.QuickCheck import Data.Time.LocalTime +import Data.Time.Calendar spec :: Spec spec = describe "parser time" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do - describe "utcTime roundtrip" $ do prop "utcTime roundtrip" $ \ t -> Right t === (P.parse' P.utcTime . B.build $ B.utcTime t) - describe "localTime roundtrip" $ do prop "localTime roundtrip" $ \ t -> Right t === (P.parse' P.localTime . B.build $ B.localTime t) - describe "zonedTime roundtrip" $ do prop "zonedTime roundtrip" $ \ t0 z0 -> let z = abs z0 `div` 1440 t = ZonedTime t0 (minutesToTimeZone z) in (zonedTimeToUTC <$> Right t) === (zonedTimeToUTC <$> (P.parse' P.zonedTime . B.build $ B.zonedTime t)) + + modifyMaxSuccess (*100) . modifyMaxSize (*100) . prop "fromGregorianValidInt64 == fromGregorianValid" $ \ y m d -> + P.fromGregorianValid' y m d == fromGregorianValid y m d diff --git a/test/Z/Data/Vector/BaseSpec.hs b/test/Z/Data/Vector/BaseSpec.hs --- a/test/Z/Data/Vector/BaseSpec.hs +++ b/test/Z/Data/Vector/BaseSpec.hs @@ -154,6 +154,14 @@ prop "vector concat === List.concat" $ \ xss -> (V.concat . List.map (V.pack @V.PrimVector @Word8) $ xss) === (V.pack . List.concat $ xss) + describe "vector concatR == List.concat . List.reverse" $ do + prop "vector concatR === List.concat" $ \ xss -> + (V.concatR . List.map (V.pack @V.Vector @Integer) $ xss) === (V.pack . List.concat . List.reverse $ xss) + prop "vector concatR === List.concat" $ \ xss -> + (V.concatR . List.map (V.pack @V.PrimVector @Int) $ xss) === (V.pack . List.concat . List.reverse $ xss) + prop "vector concatR === List.concat" $ \ xss -> + (V.concatR . List.map (V.pack @V.PrimVector @Word8) $ xss) === (V.pack . List.concat . List.reverse $ xss) + describe "vector concatMap == List.concatMap" $ do prop "vector concatMap === List.concatMap" $ \ xss (Fun _ f) -> (V.concatMap (V.pack @V.Vector @Integer . f) . V.pack $ xss) === (V.pack . List.concatMap f $ xss)