diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,41 @@ # Revision history for Z-Data +## 2.0.0.0 -- 2021-12-08 + +* Work only with GHC >= 9.2, use sized primitive types, new integer types. +* Remove dependencies on `ghc-prim`, `integer-gmp`, use modules exported by `base` instead. +* Change `emptyArr` to a `Arr` class method. + +## 1.1.0.0 -- 2021-07-15 + +* Fix building issues on ARM platform. +* Add `UUID` builders and parsers(both textual binary). +* Add more `PrimUnlifed` instances to `Z.Data.Array.UnliftedArray`. +* Add `doubleMutableArr` to `Z.Data.Array`, useful in some buffer building logic. +* Add `shuffle` and `permutations` to `Z.Data.Vector` and `Z.Data.Text`. +* Add `prettyJSON'` to `Z.Data.JSON` with custom indentation. +* Change `CBytes` 's JSON instance to write `__base64` field(instead of `base64` field) when not UTF8 encoded. +* Add missing type alias `UnliftedIORef` for `UnliftedRef RealWorld`. + +## 1.0.0.1 -- 2021-07-08 + +* Fix a regression in `match` parsing combinator where matched chunk is returned instead of precise matched input. + +## 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/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. + ## 0.8.8.0 -- 2021-06-13 * Add `withCPtrForever` and `addCPtrDep` to `Z.Foreign.CPtr` module. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,6 +4,7 @@ [![Linux Build Status](https://github.com/ZHaskell/z-data/workflows/ubuntu-ci/badge.svg)](https://github.com/ZHaskell/z-data/actions) [![macOS Build Status](https://github.com/ZHaskell/z-data/workflows/osx-ci/badge.svg)](https://github.com/ZHaskell/z-data/actions) [![Windows Build Status](https://github.com/ZHaskell/z-data/workflows/win-ci/badge.svg)](https://github.com/ZHaskell/z-data/actions) +[![ARM Build Status](https://img.shields.io/drone/build/ZHaskell/z-data?label=arm-ci)](https://cloud.drone.io/ZHaskell/z-data) [![Gitter chat](https://badges.gitter.im/gitterHQ/gitter.svg)](https://gitter.im/Z-Haskell/community) @@ -19,12 +20,12 @@ ## Requirements -* A working haskell compiler system, GHC(>=8.6), cabal-install(>=2.4), here're some options: - * Mac users can get them via [homebew](//brew.sh/): `brew install ghc cabal-install`. - * Windows users can get them via [chocolatey](//chocolatey.org): `choco install ghc cabal`. - * Ubuntu users are recommended to use this [ppa](//launchpad.net/~hvr/+archive/ubuntu/ghc). +* A working haskell compiler system, GHC(>=9.2), cabal-install(>=3.8), here're some options: + * Using [ghcup](https://www.haskell.org/ghcup/) to setup your haskell envrionment. * A working C/C++ compiler support C++11, here're some options: - * Mac users can use the `clang` comes with the [XCode Command Line Tools](https://developer.apple.com/downloads). + * Mac users can use the `clang` comes with the [XCode](https://developer.apple.com/xcode/) or [XCode Command Line Tools](https://developer.apple.com/downloads): + * You can install XCode from app store, or XCode Command Line Tools with `sudo xcode-select --install`. + * If you came across compiling issues like [this](https://stackoverflow.com/questions/58628377/catalina-c-using-cmath-headers-yield-error-no-member-named-signbit-in-th), consider removing redundant SDKs, e.g. `sudo rm -rf /Library/Developer/CommandLineTools/SDKs` * Windows users can use the mingw's one comes with GHC, you can use it by adding `your_path_to_ghc\mingw\bin` to your `PATH`. * Ubuntu users can install `gcc/g++` by running `sudo apt install build-essential`. * Tests need [hspec-discover](https://hackage.haskell.org/package/hspec-discover). @@ -36,44 +37,44 @@ > import qualified Z.Data.Array as A > > -- convert from list -> let v = V.pack [1..10] :: V.PrimVector Int +> let v = V.pack [1..10] :: V.PrimVector Int > -- vector combinators works on arrays as well -> let a = V.pack [1..10] :: A.Array Int +> let a = V.pack [1..10] :: A.Array Int > -- slicing vector(slice) is O(1) -> V.take 3 v +> V.take 3 v [1,2,3] -- slicing array is not O(1) -> V.drop 3 a +> V.drop 3 a fromListN 7 [4,5,6,7,8,9,10] > > V.intersperse 10 v [1,10,2,10,3,10,4,10,5,10,6,10,7,10,8,10,9,10,10] > -> V.mergeSort (V.intersperse 10 v) +> V.mergeSort (V.intersperse 10 v) [1,2,3,4,5,6,7,8,9,10,10,10,10,10,10,10,10,10,10] > -- Generic KMP search on vectors -> V.indices (V.singleton 10) (V.intersperse 10 v) True +> V.indices (V.singleton 10) (V.intersperse 10 v) True [1,3,5,7,9,11,13,15,17,18] > > -- quoter for writing numeric vector literals -> :set -XQuasiQuotes -> :t [V.vecWord|1,2,3,4,5,4,3,2,1|] +> :set -XQuasiQuotes +> :t [V.vecWord|1,2,3,4,5,4,3,2,1|] [V.vecWord|1,2,3,4,5,4,3,2,1|] :: V.PrimVector Word > > import qualified Z.Data.Builder as B > import qualified Z.Data.Text as T -> :set -XOverloadedStrings +> :set -XOverloadedStrings > > -- Builders can be used with OverloadedStrings > B.build $ "builders: " >> B.hex (3 :: Word16) >> B.comma >> B.double 1.2345678 [98,117,105,108,100,101,114,115,58,32,48,48,48,51,44,49,46,50,51,52,53,54,55,56] -> +> > B.buildText $ "builders: " >> B.hex (3 :: Word16) >> B.comma >> B.double 1.2345678 "builders: 0003,1.2345678" > > import qualified Z.Data.JSON as JSON > import GHC.Generics -> +> > JSON.parseValue "[1,2,3,4,5]" ([],Right (Array [Number 1.0,Number 2.0,Number 3.0,Number 4.0,Number 5.0])) > @@ -90,13 +91,13 @@ ```bash # get code -git clone --recursive git@github.com:ZHaskell/z-data.git +git clone --recursive git@github.com:ZHaskell/z-data.git cd z-data # build cabal build # test cabal test --test-show-details=direct -# install +# install cabal install # generate document cabal haddock 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.8.8.0 +version: 2.0.1.0 synopsis: Array, vector and text description: This package provides array, slice and text operations license: BSD-3-Clause @@ -15,6 +15,7 @@ extra-source-files: AUTHORS cbits/bytes.c + cbits/compute_float_64.c cbits/dtoa.c cbits/text.c cbits/text_width.c @@ -104,10 +105,9 @@ type: git location: git://github.com/haskell-Z/z-data.git -flag integer-simple +flag check-array-bound description: - Use the [simple integer library](http://hackage.haskell.org/package/integer-simple) - instead of [integer-gmp](http://hackage.haskell.org/package/integer-gmp) + Add bound check to operations in Z.Data.Array module. default: False manual: True @@ -130,8 +130,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 @@ -141,6 +141,7 @@ Z.Data.Builder.Numeric Z.Data.Builder.Numeric.DigitTable Z.Data.Builder.Time + Z.Data.Builder.UUID Z.Data.CBytes Z.Data.Generics.Utils Z.Data.JSON @@ -152,9 +153,8 @@ Z.Data.Parser.Base Z.Data.Parser.Numeric Z.Data.Parser.Time + Z.Data.Parser.UUID Z.Data.PrimRef - Z.Data.PrimRef.PrimIORef - Z.Data.PrimRef.PrimSTRef Z.Data.Text Z.Data.Text.Base Z.Data.Text.Extra @@ -179,21 +179,22 @@ Z.Foreign.CPtr build-depends: - , base >=4.12 && <5.0 + , base >=4.16 && <5.0 , bytestring >=0.10.4 && <0.12 , case-insensitive ^>=1.2 , containers ^>=0.6 , deepseq ^>=1.4 - , ghc-prim >=0.5.3 && <0.8 - , hashable ^>=1.3 - , primitive >=0.7.1 && <0.7.2 + , hashable >=1.3 && < 1.5 + , primitive >=0.7.3 && <1.0 , QuickCheck >=2.10 - , scientific ^>=0.3 + , random >=1.2.0 && <1.3 + , scientific >=0.3.7 && <0.4 , tagged ^>=0.8 , template-haskell >=2.14.0 , time >=1.9 && <2.0 , unordered-containers ^>=0.2 , unicode-collation >=0.1.3 && <0.2 + , uuid-types >=1.0.4 && <2.0 include-dirs: third_party/fastbase64/include @@ -224,6 +225,7 @@ c-sources: cbits/bytes.c + cbits/compute_float_64.c cbits/dtoa.c cbits/text.c cbits/text_width.c @@ -275,8 +277,12 @@ default-language: Haskell2010 build-tool-depends: hsc2hs:hsc2hs -any - cc-options: -std=c11 -Wall -Wno-pointer-to-int-cast + 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++ if arch(x86_64) if flag(use-avx512) @@ -297,22 +303,15 @@ else if os(osx) extra-libraries: - c++ - pthread + c++ + pthread else extra-libraries: - stdc++ - pthread - - if flag(integer-simple) - cpp-options: -DINTEGER_SIMPLE - build-depends: integer-simple >=0.1 && <0.5 + stdc++ + pthread - 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 @@ -367,12 +366,14 @@ Z.Data.Array.UnalignedSpec Z.Data.Builder.NumericSpec Z.Data.Builder.TimeSpec + Z.Data.Builder.UUIDSpec Z.Data.CBytesSpec Z.Data.JSON.BaseSpec Z.Data.JSON.ValueSpec Z.Data.Parser.BaseSpec Z.Data.Parser.NumericSpec Z.Data.Parser.TimeSpec + Z.Data.Parser.UUIDSpec Z.Data.Text.BaseSpec Z.Data.Text.ExtraSpec Z.Data.Text.PrintSpec @@ -385,6 +386,7 @@ Z.Data.Vector.HexSpec Z.Data.Vector.SearchSpec Z.Data.Vector.SortSpec + Z.Foreign.CPtrSpec Z.ForeignSpec build-depends: @@ -403,10 +405,5 @@ c-sources: test/cbits/ffi.c - if flag(integer-simple) - cpp-options: -DINTEGER_SIMPLE - build-depends: integer-simple >=0.1 && <0.5 - - 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/ASCII.hs b/Z/Data/ASCII.hs --- a/Z/Data/ASCII.hs +++ b/Z/Data/ASCII.hs @@ -20,13 +20,13 @@ -- w2c :: Word8 -> Char {-# INLINE w2c #-} -w2c (W8# w#) = C# (chr# (word2Int# w#)) +w2c (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#))) -- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and -- silently truncates to 8 bits Chars > @\\255@. c2w :: Char -> Word8 {-# INLINE c2w #-} -c2w (C# c#) = W8# (int2Word# (ord# c#)) +c2w (C# c#) = W8# (wordToWord8# (int2Word# (ord# c#))) -- | @\\NUL <= w && w <= \\DEL@ isASCII :: Word8 -> Bool 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,552 @@ {-| -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' arr a + -> Int + -> Int + -> arr a +{-# INLINE swapArr #-} +swapArr arr i j = runST $ do + marr <- A.thawArr arr 0 (A.sizeofArr arr) + swapMutableArr marr i j + A.unsafeFreezeArr marr + +-- | Swap two elements under given index, no atomically guarantee is given. +swapMutableArr :: (PrimMonad m, PrimState m ~ s, Arr arr a) + => MArr arr s a + -> Int + -> Int + -> m () +{-# INLINE swapMutableArr #-} +swapMutableArr marr i j = do +#ifdef CHECK_ARRAY_BOUND + siz <- A.sizeofMutableArr marr + check + (i>=0 && j>=0 && i algorithm. +shuffleMutableArr :: (StatefulGen g m, PrimMonad m, PrimState m ~ s, Arr arr a) => g -> MArr arr s a + -> Int -- ^ offset + -> Int -- ^ length + -> m () +{-# INLINE shuffleMutableArr #-} +shuffleMutableArr g marr s l = do +#ifdef CHECK_ARRAY_BOUND + siz <- A.sizeofMutableArr marr + check + (s>=0 && l>=0 && (s+l)<=siz) + (A.shuffleMutableArr g marr s l) +#else + A.shuffleMutableArr g marr s l +#endif diff --git a/Z/Data/Array/Base.hs b/Z/Data/Array/Base.hs new file mode 100644 --- /dev/null +++ b/Z/Data/Array/Base.hs @@ -0,0 +1,754 @@ +{-| +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' only works on immutable Array, use 'indexArr'' to avoid thunks building up in the heap. + + * 'freezeArr' and 'thawArr' make a copy thus need slicing params. + 'unsafeFreezeArr' and 'unsafeThawArr' DO NOT COPY, use with care. + + * 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.Base ( + -- * Arr typeclass + Arr(..) + , singletonArr, doubletonArr + , modifyIndexArr, insertIndexArr, deleteIndexArr, swapArr, swapMutableArr + , doubleMutableArr, shuffleMutableArr + , 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.Bits (unsafeShiftL) +import Data.Kind (Type) +import Data.Primitive.Array +import Data.Primitive.ByteArray +#if !MIN_VERSION_primitive(0, 9, 0) +import Data.Primitive.PrimArray +#else +import Data.Primitive.PrimArray hiding + (withMutablePrimArrayContents, + withPrimArrayContents) +#endif +import Data.Primitive.Ptr (copyPtrToMutablePrimArray) +import Data.Primitive.SmallArray +import Data.Primitive.Types +import GHC.Exts +import System.Random.Stateful (StatefulGen, + UniformRange (uniformRM)) +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 + + -- | The empty array reference. + emptyArr :: Arr arr a => arr a + + -- | 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 + emptyArr = emptyArray + {-# INLINE emptyArr #-} + 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 + emptyArr = emptySmallArray + {-# INLINE emptyArr #-} + 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 #-} + shrinkMutableArr = shrinkSmallMutableArray + {-# 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 + emptyArr = emptyPrimArray + {-# INLINE emptyArr #-} + 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 = thawPrimArray + {-# 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 + emptyArr = emptyUnliftedArray + {-# INLINE emptyArr #-} + 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 #-} + +-------------------------------------------------------------------------------- + +-- FIXME: directly use Data.Primitive.PrimArray.withPrimArrayContents +-- when primitive>=0.9.0 ? +-- | 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 + +-- FIXME: directly use Data.Primitive.PrimArray.withMutablePrimArrayContents +-- when primitive>=0.9.0 ? +-- | 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# + +-------------------------------------------------------------------------------- + +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' arr a + -> Int + -> Int + -> arr a +{-# INLINE swapArr #-} +swapArr arr i j = runST $ do + marr <- thawArr arr 0 (sizeofArr arr) + swapMutableArr marr i j + unsafeFreezeArr marr + +-- | Swap two elements under given index, no atomically guarantee is given. +swapMutableArr :: (PrimMonad m, PrimState m ~ s, Arr arr a) + => MArr arr s a + -> Int + -> Int + -> m () +{-# INLINE swapMutableArr #-} +swapMutableArr marr i j = do + x <- readArr marr i + y <- readArr marr j + writeArr marr i y + writeArr marr j x + +-- | Resize mutable array to @max (given_size) (2 * original_size)@ if orignal array is smaller than @give_size@. +doubleMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s) => MArr arr s a -> Int -> m (MArr arr s a) +{-# INLINE doubleMutableArr #-} +doubleMutableArr marr l = do + siz <- sizeofMutableArr marr + if (siz < l) + then resizeMutableArr marr (max (siz `unsafeShiftL` 1) l) + else return marr + + +-- | Shuffle array's elements in slice range. +-- +-- This function use algorithm. +shuffleMutableArr :: (StatefulGen g m, PrimMonad m, PrimState m ~ s, Arr arr a) => g -> MArr arr s a + -> Int -- ^ offset + -> Int -- ^ length + -> m () +{-# INLINE shuffleMutableArr #-} +shuffleMutableArr g marr off n = go (off+n-1) + where + go i | i < off+1 = return () + | otherwise = do + j <- uniformRM (off, i) g + swapMutableArr marr i j + go (i - 1) diff --git a/Z/Data/Array/Cast.hs b/Z/Data/Array/Cast.hs --- a/Z/Data/Array/Cast.hs +++ b/Z/Data/Array/Cast.hs @@ -25,8 +25,6 @@ #endif import GHC.Float - - -- | `Cast` between primitive types of the same size. -- class Cast source destination where @@ -36,49 +34,81 @@ cast = coerce instance Cast Int8 Word8 where - cast (I8# i) = W8# (narrow8Word# (int2Word# i)) + {-# INLINE cast #-} + cast (I8# i) = W8# (int8ToWord8# i) instance Cast Int16 Word16 where - cast (I16# i) = W16# (narrow16Word# (int2Word# i)) + {-# INLINE cast #-} + cast (I16# i) = W16# (int16ToWord16# i) instance Cast Int32 Word32 where - cast (I32# i) = W32# (narrow32Word# (int2Word# i)) + {-# INLINE cast #-} + cast (I32# i) = W32# (int32ToWord32# i) instance Cast Int64 Word64 where -#if WORD_SIZE_IN_BITS < 64 - cast (I64# i) = W64# (int64ToWord64# i) -#else - cast (I64# i) = W64# (int2Word# i) -#endif + {-# INLINE cast #-} + cast = int64ToWord64 instance Cast Int Word where + {-# INLINE cast #-} cast (I# i) = W# (int2Word# i) instance Cast Word8 Int8 where - cast (W8# i) = I8# (narrow8Int# (word2Int# i)) + {-# INLINE cast #-} + cast (W8# i) = I8# (word8ToInt8# i) instance Cast Word16 Int16 where - cast (W16# i) = I16# (narrow16Int# (word2Int# i)) + {-# INLINE cast #-} + cast (W16# i) = I16# (word16ToInt16# i) instance Cast Word32 Int32 where - cast (W32# i) = I32# (narrow32Int# (word2Int# i)) + {-# INLINE cast #-} + cast (W32# i) = I32# (word32ToInt32# i) instance Cast Word64 Int64 where -#if WORD_SIZE_IN_BITS < 64 - cast (W64# i) = I64# (word64ToInt64# i) -#else - cast (W64# i) = I64# (word2Int# i) -#endif + {-# INLINE cast #-} + cast = word64ToInt64 instance Cast Word Int where + {-# INLINE cast #-} cast (W# w) = I# (word2Int# w) instance Cast Word64 Double where + {-# INLINE cast #-} cast = castWord64ToDouble instance Cast Word32 Float where + {-# INLINE cast #-} cast = castWord32ToFloat instance Cast Double Word64 where + {-# INLINE cast #-} cast = castDoubleToWord64 instance Cast Float Word32 where + {-# INLINE cast #-} cast = castFloatToWord32 instance Cast Int64 Double where + {-# INLINE cast #-} cast = castWord64ToDouble . cast instance Cast Int32 Float where + {-# INLINE cast #-} cast = castWord32ToFloat . cast instance Cast Double Int64 where + {-# INLINE cast #-} cast = cast . castDoubleToWord64 instance Cast Float Int32 where + {-# INLINE cast #-} cast = cast . castFloatToWord32 + +int64ToWord64 :: Int64 -> Word64 +#if WORD_SIZE_IN_BITS == 64 +#if __GLASGOW_HASKELL__ >= 904 +int64ToWord64 (I64# i) = W64# (int64ToWord64# i) +#else +int64ToWord64 (I64# i) = W64# (int2Word# i) +#endif +#else +int64ToWord64 (I64# i) = W64# (int64ToWord64# i) +#endif + +word64ToInt64 :: Word64 -> Int64 +#if WORD_SIZE_IN_BITS == 64 +#if __GLASGOW_HASKELL__ >= 904 +word64ToInt64 (W64# i) = I64# (word64ToInt64# i) +#else +word64ToInt64 (W64# i) = I64# (word2Int# i) +#endif +#else +word64ToInt64 (W64# i) = I64# (word64ToInt64# i) +#endif diff --git a/Z/Data/Array/Checked.hs b/Z/Data/Array/Checked.hs deleted file mode 100644 --- a/Z/Data/Array/Checked.hs +++ /dev/null @@ -1,328 +0,0 @@ -{-| -Module : Z.Data.Array.Checked -Description : Bounded checked boxed and unboxed arrays -Copyright : (c) Dong Han, 2017-2019 -License : BSD -Maintainer : winterland1989@gmail.com -Stability : experimental -Portability : non-portable - -This module provides exactly the same API with "Z.Data.Array", but will throw an 'IndexOutOfBounds' -'ArrayException' on bound check failure, it's useful when debugging array algorithms: just swap this -module with "Z.Data.Array", segmentation faults caused by out bound access will be turned into exceptions -with more informations. - --} -module Z.Data.Array.Checked - ( -- * Arr typeclass re-export - Arr, MArr - , A.emptyArr, A.singletonArr, A.doubletonArr - , modifyIndexArr, insertIndexArr, deleteIndexArr - , RealWorld - -- * Boxed array type - , A.Array(..) - , A.MutableArray(..) - , A.SmallArray(..) - , A.SmallMutableArray(..) - , A.uninitialized - -- * Primitive array type - , A.PrimArray(..) - , A.MutablePrimArray(..) - , Prim(..) - -- * Bound checked array operations - , newArr - , newArrWith - , readArr - , writeArr - , setArr - , indexArr - , indexArr' - , indexArrM - , freezeArr - , thawArr - , copyArr - , copyMutableArr - , moveArr - , cloneArr - , cloneMutableArr - , resizeMutableArr - , shrinkMutableArr - -- * No bound checked operations - , A.unsafeFreezeArr - , A.unsafeThawArr - , A.sameMutableArr - , A.sizeofArr - , A.sizeofMutableArr - , A.sameArr - -- * Bound checked primitive array operations - , newPinnedPrimArray, newAlignedPinnedPrimArray - , copyPrimArrayToPtr, copyMutablePrimArrayToPtr, copyPtrToMutablePrimArray - -- * No bound checked primitive array operations - , A.primArrayContents, A.mutablePrimArrayContents, A.withPrimArrayContents, A.withMutablePrimArrayContents - , A.isPrimArrayPinned, A.isMutablePrimArrayPinned - -- * Unlifted array type - , A.UnliftedArray(..) - , A.MutableUnliftedArray(..) - , A.PrimUnlifted(..) - -- * The 'ArrayException' type - , ArrayException(..) - -- * Cast between primitive arrays - , A.Cast - , A.castArray - , A.castMutableArray - -- * Re-export - , sizeOf - ) where - -import Control.Exception (ArrayException (..), throw) -import Control.Monad -import Control.Monad.Primitive -import Control.Monad.ST -import Data.Primitive.Types -import GHC.Stack -import Z.Data.Array (Arr, MArr) -import qualified Z.Data.Array as A - -check :: HasCallStack => 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 @@ -27,10 +27,6 @@ #include "MachDeps.h" --- toggle these defs to test different implements -#define USE_BSWAP --- #define USE_SHIFT - -------------------------------------------------------------------------------- newtype UnalignedSize a = UnalignedSize { getUnalignedSize :: Int } deriving (Show, Eq, Ord) @@ -186,7 +182,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; \ @@ -209,24 +204,32 @@ {-# INLINE indexWord8ArrayAs# #-} indexWord8ArrayAs# ba# i# = W16# (indexWord8ArrayAsWord16# ba# i#) +word16ToWord8# :: Word16# -> Word8# +{-# INLINE word16ToWord8# #-} +word16ToWord8# w# = wordToWord8# (word16ToWord# w#) + +word8ToWord16# :: Word8# -> Word16# +{-# INLINE word8ToWord16# #-} +word8ToWord16# w# = wordToWord16# (word8ToWord# w#) + instance Unaligned (LE Word16) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 2 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (W16# x#)) s0# = - let s1# = writeWord8Array# mba# i# x# s0# - in writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 8#) s1# + writeWord8ArrayAs# mba# i# (LE (W16# x#)) s0 = + let s1 = writeWord8Array# mba# i# (word16ToWord8# x#) s0 + in writeWord8Array# mba# (i# +# 1#) (word16ToWord8# (uncheckedShiftRLWord16# x# 8#)) s1 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = let !(# s1, w1# #) = readWord8Array# mba# i# s0 !(# s2, w2# #) = readWord8Array# mba# (i# +# 1#) s1 - in (# s2, LE (W16# (uncheckedShiftL# w2# 8# `or#` w1#)) #) + in (# s2, LE (W16# (uncheckedShiftRLWord16# (word8ToWord16# w2#) 8# `orWord16#` (word8ToWord16# w1#))) #) {-# INLINE indexWord8ArrayAs# #-} indexWord8ArrayAs# ba# i# = let w1# = indexWord8Array# ba# i# w2# = indexWord8Array# ba# (i# +# 1#) - in LE (W16# (uncheckedShiftL# w2# 8# `or#` w1#)) + in LE (W16# (uncheckedShiftRLWord16# (word8ToWord16# w2#) 8# `orWord16#` (word8ToWord16# w1#))) #else USE_HOST_IMPL(LE) #endif @@ -234,36 +237,23 @@ instance Unaligned (BE Word16) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 2 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) USE_HOST_IMPL(BE) #else --- on X86 we use bswap --- TODO: find out if arch64 support this -#if (defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)) && defined(USE_BSWAP) {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W16# x#)) = writeWord8ArrayAsWord16# mba# i# (byteSwap16# x#) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsWord16# mba# i# s0 - in (# s1, BE (W16# (byteSwap16# x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = BE (W16# (byteSwap16# (indexWord8ArrayAsWord16# ba# i#))) -#else - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W16# x#)) s0# = - let s1# = writeWord8Array# mba# i# (uncheckedShiftRL# x# 8#) s0# - in writeWord8Array# mba# (i# +# 1#) x# s1# + writeWord8ArrayAs# mba# i# (BE (W16# x#)) s0 = + let s1 = writeWord8Array# mba# i# (word16ToWord8# (uncheckedShiftRLWord16# x# 8#)) s0 + in writeWord8Array# mba# (i# +# 1#) (word16ToWord8# x#) s1 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = - let !(# s1, w2# #) = readWord8Array# mba# i# s0 - !(# s2, w1# #) = readWord8Array# mba# (i# +# 1#) s1 - in (# s2, BE (W16# (uncheckedShiftL# w2# 8# `or#` w1#)) #) + let !(# s1, w1# #) = readWord8Array# mba# i# s0 + !(# s2, w2# #) = readWord8Array# mba# (i# +# 1#) s1 + in (# s2, BE (W16# (uncheckedShiftLWord16# (word8ToWord16# w1#) 8# `orWord16#` (word8ToWord16# w2#))) #) {-# INLINE indexWord8ArrayAs# #-} indexWord8ArrayAs# ba# i# = - let w2# = indexWord8Array# ba# i# - w1# = indexWord8Array# ba# (i# +# 1#) - in BE (W16# (uncheckedShiftL# w2# 8# `or#` w1#)) -#endif + let w1# = indexWord8Array# ba# i# + w2# = indexWord8Array# ba# (i# +# 1#) + in BE (W16# (uncheckedShiftLWord16# (word8ToWord16# w1#) 8# `orWord16#` (word8ToWord16# w2#))) #endif -------------------------------------------------------------------------------- @@ -272,7 +262,7 @@ {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 4 {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (W32# x#) = writeWord8ArrayAsWord32# mba# i# x# + writeWord8ArrayAs# mba# i# (W32# x#) s0 = writeWord8ArrayAsWord32# mba# i# x# s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = let !(# s1, x# #) = readWord8ArrayAsWord32# mba# i# s0 in (# s1, W32# x# #) @@ -283,31 +273,15 @@ instance Unaligned (LE Word32) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (W32# x#)) s0# = - let s1# = writeWord8Array# mba# i# x# s0# - s2# = writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 8#) s1# - s3# = writeWord8Array# mba# (i# +# 2#) (uncheckedShiftRL# x# 16#) s2# - in writeWord8Array# mba# (i# +# 3#) (uncheckedShiftRL# x# 24#) s3# + writeWord8ArrayAs# mba# i# (LE w) s0 = writeWord8ArrayAs# mba# i# (byteSwap32 w) s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = - let !(# s1, w1# #) = readWord8Array# mba# i# s0 - !(# s2, w2# #) = readWord8Array# mba# (i# +# 1#) s1 - !(# s3, w3# #) = readWord8Array# mba# (i# +# 2#) s2 - !(# s4, w4# #) = readWord8Array# mba# (i# +# 3#) s3 - in (# s4, LE (W32# ((uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) #) + let !(# s1, x# #) = readWord8ArrayAsWord32# mba# i# s0 + in (# s1, LE (byteSwap32 (W32# x#)) #) {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let w1# = indexWord8Array# ba# i# - w2# = indexWord8Array# ba# (i# +# 1#) - w3# = indexWord8Array# ba# (i# +# 2#) - w4# = indexWord8Array# ba# (i# +# 3#) - in LE (W32# ((uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) + indexWord8ArrayAs# ba# i# = LE (byteSwap32 (W32# (indexWord8ArrayAsWord32# ba# i#))) #else USE_HOST_IMPL(LE) #endif @@ -318,43 +292,14 @@ #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) USE_HOST_IMPL(BE) #else --- on X86 we use bswap --- TODO: find out if arch64 support this -#if (defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)) && defined(USE_BSWAP) {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W32# x#)) = writeWord8ArrayAsWord32# mba# i# (byteSwap32# x#) + writeWord8ArrayAs# mba# i# (BE x) s0 = writeWord8ArrayAs# mba# i# (byteSwap32 x) s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = let !(# s1, x# #) = readWord8ArrayAsWord32# mba# i# s0 - in (# s1, BE (W32# (byteSwap32# x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = BE (W32# (byteSwap32# (indexWord8ArrayAsWord32# ba# i#))) -#else - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W32# x#)) s0# = - let s1# = writeWord8Array# mba# i# (uncheckedShiftRL# x# 24#) s0# - s2# = writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 16#) s1# - s3# = writeWord8Array# mba# (i# +# 2#) (uncheckedShiftRL# x# 8#) s2# - in writeWord8Array# mba# (i# +# 3#) x# s3# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, w4# #) = readWord8Array# mba# i# s0 - !(# s2, w3# #) = readWord8Array# mba# (i# +# 1#) s1 - !(# s3, w2# #) = readWord8Array# mba# (i# +# 2#) s2 - !(# s4, w1# #) = readWord8Array# mba# (i# +# 3#) s3 - in (# s4, BE (W32# ((uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) #) + in (# s1, BE (byteSwap32 (W32# x#)) #) {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let w4# = indexWord8Array# ba# i# - w3# = indexWord8Array# ba# (i# +# 1#) - w2# = indexWord8Array# ba# (i# +# 2#) - w1# = indexWord8Array# ba# (i# +# 3#) - in BE (W32# ((uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) -#endif + indexWord8ArrayAs# ba# i# = BE (byteSwap32 (W32# (indexWord8ArrayAsWord32# ba# i#))) #endif -------------------------------------------------------------------------------- @@ -363,7 +308,7 @@ {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 8 {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (W64# x#) = writeWord8ArrayAsWord64# mba# i# x# + writeWord8ArrayAs# mba# i# (W64# x#) s0 = writeWord8ArrayAsWord64# mba# i# x# s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = let !(# s1, x# #) = readWord8ArrayAsWord64# mba# i# s0 in (# s1, W64# x# #) @@ -374,51 +319,15 @@ instance Unaligned (LE Word64) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 8 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (W64# x#)) s0# = - let s1# = writeWord8Array# mba# i# x# s0# - s2# = writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 8#) s1# - s3# = writeWord8Array# mba# (i# +# 2#) (uncheckedShiftRL# x# 16#) s2# - s4# = writeWord8Array# mba# (i# +# 3#) (uncheckedShiftRL# x# 24#) s3# - s5# = writeWord8Array# mba# (i# +# 4#) (uncheckedShiftRL# x# 32#) s4# - s6# = writeWord8Array# mba# (i# +# 5#) (uncheckedShiftRL# x# 40#) s5# - s7# = writeWord8Array# mba# (i# +# 6#) (uncheckedShiftRL# x# 48#) s6# - in writeWord8Array# mba# (i# +# 7#) (uncheckedShiftRL# x# 56#) s7# + writeWord8ArrayAs# mba# i# (LE w) s0 = writeWord8ArrayAs# mba# i# (byteSwap64 w) s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = - let !(# s1, w1# #) = readWord8Array# mba# i# s0 - !(# s2, w2# #) = readWord8Array# mba# (i# +# 1#) s1 - !(# s3, w3# #) = readWord8Array# mba# (i# +# 2#) s2 - !(# s4, w4# #) = readWord8Array# mba# (i# +# 3#) s3 - !(# s5, w5# #) = readWord8Array# mba# (i# +# 4#) s4 - !(# s6, w6# #) = readWord8Array# mba# (i# +# 5#) s5 - !(# s7, w7# #) = readWord8Array# mba# (i# +# 6#) s6 - !(# s8, w8# #) = readWord8Array# mba# (i# +# 7#) s7 - in (# s8, LE (W64# ((uncheckedShiftL# w8# 56#) `or#` - (uncheckedShiftL# w7# 48#) `or#` - (uncheckedShiftL# w6# 40#) `or#` - (uncheckedShiftL# w5# 32#) `or#` - (uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) #) + let !(# s1, x# #) = readWord8ArrayAsWord64# mba# i# s0 + in (# s1, LE (byteSwap64 (W64# x#)) #) {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let w1# = indexWord8Array# ba# i# - w2# = indexWord8Array# ba# (i# +# 1#) - w3# = indexWord8Array# ba# (i# +# 2#) - w4# = indexWord8Array# ba# (i# +# 3#) - w5# = indexWord8Array# ba# (i# +# 4#) - w6# = indexWord8Array# ba# (i# +# 5#) - w7# = indexWord8Array# ba# (i# +# 6#) - w8# = indexWord8Array# ba# (i# +# 7#) - in LE (W64# ((uncheckedShiftL# w8# 56#) `or#` - (uncheckedShiftL# w7# 48#) `or#` - (uncheckedShiftL# w6# 40#) `or#` - (uncheckedShiftL# w5# 32#) `or#` - (uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) + indexWord8ArrayAs# ba# i# = LE (byteSwap64 (W64# (indexWord8ArrayAsWord64# ba# i#))) #else USE_HOST_IMPL(LE) #endif @@ -429,63 +338,14 @@ #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) USE_HOST_IMPL(BE) #else --- on X86 we use bswap --- TODO: find out if arch64 support this -#if (defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)) && defined(USE_BSWAP) {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W64# x#)) = writeWord8ArrayAsWord64# mba# i# (byteSwap64# x#) + writeWord8ArrayAs# mba# i# (BE x) s0 = writeWord8ArrayAs# mba# i# (byteSwap64 x) s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = let !(# s1, x# #) = readWord8ArrayAsWord64# mba# i# s0 - in (# s1, BE (W64# (byteSwap64# x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = BE (W64# (byteSwap64# (indexWord8ArrayAsWord64# ba# i#))) -#else - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W64# x#)) s0# = - let s1# = writeWord8Array# mba# i# (uncheckedShiftRL# x# 56#) s0# - s2# = writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 48#) s1# - s3# = writeWord8Array# mba# (i# +# 2#) (uncheckedShiftRL# x# 40#) s2# - s4# = writeWord8Array# mba# (i# +# 3#) (uncheckedShiftRL# x# 32#) s3# - s5# = writeWord8Array# mba# (i# +# 4#) (uncheckedShiftRL# x# 24#) s4# - s6# = writeWord8Array# mba# (i# +# 5#) (uncheckedShiftRL# x# 16#) s5# - s7# = writeWord8Array# mba# (i# +# 6#) (uncheckedShiftRL# x# 8#) s6# - in writeWord8Array# mba# (i# +# 7#) x# s7# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, w8# #) = readWord8Array# mba# i# s0 - !(# s2, w7# #) = readWord8Array# mba# (i# +# 1#) s1 - !(# s3, w6# #) = readWord8Array# mba# (i# +# 2#) s2 - !(# s4, w5# #) = readWord8Array# mba# (i# +# 3#) s3 - !(# s5, w4# #) = readWord8Array# mba# (i# +# 4#) s4 - !(# s6, w3# #) = readWord8Array# mba# (i# +# 5#) s5 - !(# s7, w2# #) = readWord8Array# mba# (i# +# 6#) s6 - !(# s8, w1# #) = readWord8Array# mba# (i# +# 7#) s7 - in (# s8, BE (W64# ((uncheckedShiftL# w8# 56#) `or#` - (uncheckedShiftL# w7# 48#) `or#` - (uncheckedShiftL# w6# 40#) `or#` - (uncheckedShiftL# w5# 32#) `or#` - (uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) #) + in (# s1, BE (byteSwap64 (W64# x#)) #) {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let w8# = indexWord8Array# ba# i# - w7# = indexWord8Array# ba# (i# +# 1#) - w6# = indexWord8Array# ba# (i# +# 2#) - w5# = indexWord8Array# ba# (i# +# 3#) - w4# = indexWord8Array# ba# (i# +# 4#) - w3# = indexWord8Array# ba# (i# +# 5#) - w2# = indexWord8Array# ba# (i# +# 6#) - w1# = indexWord8Array# ba# (i# +# 7#) - in BE (W64# ((uncheckedShiftL# w8# 56#) `or#` - (uncheckedShiftL# w7# 48#) `or#` - (uncheckedShiftL# w6# 40#) `or#` - (uncheckedShiftL# w5# 32#) `or#` - (uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) -#endif + indexWord8ArrayAs# ba# i# = BE (byteSwap64 (W64# (indexWord8ArrayAsWord64# ba# i#))) #endif -------------------------------------------------------------------------------- @@ -499,7 +359,7 @@ unalignedSize = UnalignedSize 8 #endif {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (W# x#) = writeWord8ArrayAsWord# mba# i# x# + writeWord8ArrayAs# mba# i# (W# x#) s0 = writeWord8ArrayAsWord# mba# i# x# s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = let !(# s1, x# #) = readWord8ArrayAsWord# mba# i# s0 in (# s1, W# x# #) @@ -510,47 +370,33 @@ #if SIZEOF_HSWORD == 4 {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 4 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (W# x#)) = writeWord8ArrayAs# mba# i# (LE (W32# x#)) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, LE (W# x#) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (W32# x#)) -> LE (W# x#) #else {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 8 +#endif {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (W# x#)) = writeWord8ArrayAs# mba# i# (LE (W64# x#)) + writeWord8ArrayAs# mba# i# (LE (W# x#)) s0 = writeWord8ArrayAsWord# mba# i# (byteSwap# x#) s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, LE (W# x#) #) + let !(# s1, x# #) = readWord8ArrayAsWord# mba# i# s0 in (# s1, LE (W# (byteSwap# x#)) #) {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (W64# x#)) -> LE (W# x#) -#endif + indexWord8ArrayAs# ba# i# = LE (W# (byteSwap# (indexWord8ArrayAsWord# ba# i#))) instance Unaligned (BE Word) where #if SIZEOF_HSWORD == 4 {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 4 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W# x#)) = writeWord8ArrayAs# mba# i# (BE (W32# x#)) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, BE (W# x#) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (W32# x#)) -> BE (W# x#) #else {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 8 +#endif {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W# x#)) = writeWord8ArrayAs# mba# i# (BE (W64# x#)) + writeWord8ArrayAs# mba# i# (BE (W# x#)) s0 = writeWord8ArrayAsWord# mba# i# (byteSwap# x#) s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, BE (W# x#) #) + let !(# s1, x# #) = readWord8ArrayAsWord# mba# i# s0 in (# s1, BE (W# (byteSwap# x#)) #) {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (W64# x#)) -> BE (W# x#) -#endif + indexWord8ArrayAs# ba# i# = BE (W# (byteSwap# (indexWord8ArrayAsWord# ba# i#))) -------------------------------------------------------------------------------- @@ -565,21 +411,28 @@ {-# INLINE indexWord8ArrayAs# #-} indexWord8ArrayAs# ba# i# = I16# (indexWord8ArrayAsInt16# ba# i#) +int16ToWord8# :: Int16# -> Word8# +{-# INLINE int16ToWord8# #-} +int16ToWord8# w# = wordToWord8# (word16ToWord# (int16ToWord16# w#)) + instance Unaligned (LE Int16) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 2 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (I16# x#)) = - writeWord8ArrayAs# mba# i# (LE (W16# (int2Word# x#))) + writeWord8ArrayAs# mba# i# (LE (I16# x#)) s0 = + let s1 = writeWord8Array# mba# i# (int16ToWord8# x#) s0 + in writeWord8Array# mba# (i# +# 1#) (int16ToWord8# (uncheckedShiftRLInt16# x# 8#)) s1 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (W16# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, LE (I16# (narrow16Int# (word2Int# x#))) #) + let !(# s1, w1# #) = readWord8Array# mba# i# s0 + !(# s2, w2# #) = readWord8Array# mba# (i# +# 1#) s1 + in (# s2, LE (I16# (word16ToInt16# (uncheckedShiftRLWord16# (word8ToWord16# w2#) 8# `orWord16#` (word8ToWord16# w1#)))) #) {-# INLINE indexWord8ArrayAs# #-} indexWord8ArrayAs# ba# i# = - let LE (W16# x#) = indexWord8ArrayAs# ba# i# - in LE (I16# (narrow16Int# (word2Int# x#))) + let w1# = indexWord8Array# ba# i# + w2# = indexWord8Array# ba# (i# +# 1#) + in LE (I16# (word16ToInt16# (uncheckedShiftRLWord16# (word8ToWord16# w2#) 8# `orWord16#` (word8ToWord16# w1#)))) #else USE_HOST_IMPL(LE) #endif @@ -587,20 +440,23 @@ instance Unaligned (BE Int16) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 2 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) USE_HOST_IMPL(BE) #else {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (I16# x#)) = - writeWord8ArrayAs# mba# i# (BE (W16# (int2Word# x#))) + writeWord8ArrayAs# mba# i# (BE (I16# x#)) s0 = + let s1 = writeWord8Array# mba# i# (int16ToWord8# (uncheckedShiftRLInt16# x# 8#)) s0 + in writeWord8Array# mba# (i# +# 1#) (int16ToWord8# x#) s1 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (W16# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, BE (I16# (narrow16Int# (word2Int# x#))) #) + let !(# s1, w1# #) = readWord8Array# mba# i# s0 + !(# s2, w2# #) = readWord8Array# mba# (i# +# 1#) s1 + in (# s2, BE (I16# (word16ToInt16# (uncheckedShiftLWord16# (word8ToWord16# w1#) 8# `orWord16#` (word8ToWord16# w2#)))) #) {-# INLINE indexWord8ArrayAs# #-} indexWord8ArrayAs# ba# i# = - let !(BE (W16# x#)) = indexWord8ArrayAs# ba# i# - in BE (I16# (narrow16Int# (word2Int# x#))) + let w1# = indexWord8Array# ba# i# + w2# = indexWord8Array# ba# (i# +# 1#) + in BE (I16# (word16ToInt16# (uncheckedShiftLWord16# (word8ToWord16# w1#) 8# `orWord16#` (word8ToWord16# w2#)))) #endif -------------------------------------------------------------------------------- @@ -609,28 +465,29 @@ {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 4 {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (I32# x#) = writeWord8ArrayAsInt32# mba# i# x# + writeWord8ArrayAs# mba# i# (I32# x#) s0 = writeWord8ArrayAsInt32# mba# i# x# s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = let !(# s1, x# #) = readWord8ArrayAsInt32# mba# i# s0 in (# s1, I32# x# #) {-# INLINE indexWord8ArrayAs# #-} indexWord8ArrayAs# ba# i# = I32# (indexWord8ArrayAsInt32# ba# i#) +byteSwapInt32 :: Int32 -> Int32 +{-# INLINE byteSwapInt32 #-} +byteSwapInt32 i = fromIntegral (byteSwap32 (fromIntegral i)) + instance Unaligned (LE Int32) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (I32# x#)) = - writeWord8ArrayAs# mba# i# (LE (W32# (int2Word# x#))) + writeWord8ArrayAs# mba# i# (LE w) s0 = writeWord8ArrayAs# mba# i# (byteSwapInt32 w) s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, LE (I32# (narrow32Int# (word2Int# x#))) #) + let !(# s1, x# #) = readWord8ArrayAsWord32# mba# i# s0 + in (# s1, LE (byteSwapInt32 (I32# x#)) #) {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let LE (W32# x#) = indexWord8ArrayAs# ba# i# - in LE (I32# (narrow32Int# (word2Int# x#))) + indexWord8ArrayAs# ba# i# = LE (byteSwapInt32 (I32# (indexWord8ArrayAsInt32# ba# i#))) #else USE_HOST_IMPL(LE) #endif @@ -642,16 +499,13 @@ USE_HOST_IMPL(BE) #else {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (I32# x#)) = - writeWord8ArrayAs# mba# i# (BE (W32# (int2Word# x#))) + writeWord8ArrayAs# mba# i# (BE x) s0 = writeWord8ArrayAs# mba# i# (byteSwapInt32 x) s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, BE (I32# (narrow32Int# (word2Int# x#))) #) + let !(# s1, x# #) = readWord8ArrayAsInt32# mba# i# s0 + in (# s1, BE (byteSwapInt32 (I32# x#)) #) {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let !(BE (W32# x#)) = indexWord8ArrayAs# ba# i# - in BE (I32# (narrow32Int# (word2Int# x#))) + indexWord8ArrayAs# ba# i# = BE (byteSwapInt32 (I32# (indexWord8ArrayAsInt32# ba# i#))) #endif -------------------------------------------------------------------------------- @@ -660,28 +514,29 @@ {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 8 {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (I64# x#) = writeWord8ArrayAsInt64# mba# i# x# + writeWord8ArrayAs# mba# i# (I64# x#) s0 = writeWord8ArrayAsInt64# mba# i# x# s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = let !(# s1, x# #) = readWord8ArrayAsInt64# mba# i# s0 in (# s1, I64# x# #) {-# INLINE indexWord8ArrayAs# #-} indexWord8ArrayAs# ba# i# = I64# (indexWord8ArrayAsInt64# ba# i#) +byteSwapInt64 :: Int64 -> Int64 +{-# INLINE byteSwapInt64 #-} +byteSwapInt64 i = fromIntegral (byteSwap64 (fromIntegral i)) + instance Unaligned (LE Int64) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 8 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (I64# x#)) = - writeWord8ArrayAs# mba# i# (LE (W64# (int2Word# x#))) + writeWord8ArrayAs# mba# i# (LE w) s0 = writeWord8ArrayAs# mba# i# (byteSwapInt64 w) s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, LE (I64# (word2Int# x#)) #) + let !(# s1, x# #) = readWord8ArrayAsInt64# mba# i# s0 + in (# s1, LE (byteSwapInt64 (I64# x#)) #) {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let LE (W64# x#) = indexWord8ArrayAs# ba# i# - in LE (I64# (word2Int# x#)) + indexWord8ArrayAs# ba# i# = LE (byteSwapInt64 (I64# (indexWord8ArrayAsInt64# ba# i#))) #else USE_HOST_IMPL(LE) #endif @@ -693,16 +548,13 @@ USE_HOST_IMPL(BE) #else {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (I64# x#)) = - writeWord8ArrayAs# mba# i# (BE (W64# (int2Word# x#))) + writeWord8ArrayAs# mba# i# (BE x) s0 = writeWord8ArrayAs# mba# i# (byteSwapInt64 x) s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, BE (I64# (word2Int# x#)) #) + let !(# s1, x# #) = readWord8ArrayAsInt64# mba# i# s0 + in (# s1, BE (byteSwapInt64 (I64# x#)) #) {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let !(BE (W64# x#)) = indexWord8ArrayAs# ba# i# - in BE (I64# (word2Int# x#)) + indexWord8ArrayAs# ba# i# = BE (byteSwapInt64 (I64# (indexWord8ArrayAsInt64# ba# i#))) #endif -------------------------------------------------------------------------------- @@ -716,58 +568,48 @@ unalignedSize = UnalignedSize 8 #endif {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (I# x#) = writeWord8ArrayAsInt# mba# i# x# + writeWord8ArrayAs# mba# i# (I# x#) s0 = writeWord8ArrayAsInt# mba# i# x# s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = let !(# s1, x# #) = readWord8ArrayAsInt# mba# i# s0 in (# s1, I# x# #) {-# INLINE indexWord8ArrayAs# #-} indexWord8ArrayAs# ba# i# = I# (indexWord8ArrayAsInt# ba# i#) +byteSwapInt :: Int -> Int +{-# INLINE byteSwapInt #-} +byteSwapInt (I# i#) = I# (word2Int# (byteSwap# (int2Word# i#))) + instance Unaligned (LE Int) where #if SIZEOF_HSWORD == 4 {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 4 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (I# x#)) = writeWord8ArrayAs# mba# i# (LE (I32# x#)) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (I32# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, LE (I# x#) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (I32# x#)) -> LE (I# x#) #else {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 8 +#endif {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (I# x#)) = writeWord8ArrayAs# mba# i# (LE (I64# x#)) + writeWord8ArrayAs# mba# i# (LE x) s0 = writeWord8ArrayAs# mba# i# (byteSwapInt x) s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (I64# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, LE (I# x#) #) + let !(# s1, x #) = readWord8ArrayAs# mba# i# s0 in (# s1, LE (byteSwapInt x) #) {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (I64# x#)) -> LE (I# x#) -#endif + indexWord8ArrayAs# ba# i# = LE (byteSwapInt (indexWord8ArrayAs# ba# i#)) instance Unaligned (BE Int) where #if SIZEOF_HSWORD == 4 {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 4 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (I# x#)) = writeWord8ArrayAs# mba# i# (BE (I32# x#)) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (I32# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, BE (I# x#) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (I32# x#)) -> BE (I# x#) #else {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 8 +#endif {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (I# x#)) = writeWord8ArrayAs# mba# i# (BE (I64# x#)) + writeWord8ArrayAs# mba# i# (BE x) s0 = writeWord8ArrayAs# mba# i# (byteSwapInt x) s0 {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (I64# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, BE (I# x#) #) + let !(# s1, x #) = readWord8ArrayAs# mba# i# s0 in (# s1, BE (byteSwapInt x) #) {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (I64# x#)) -> BE (I# x#) -#endif + indexWord8ArrayAs# ba# i# = BE (byteSwapInt (indexWord8ArrayAs# ba# i#)) -------------------------------------------------------------------------------- @@ -796,7 +638,7 @@ instance Unaligned (LE Float) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (F# x#)) = writeWord8ArrayAs# mba# i# (LE (W32# (stgFloatToWord32 x#))) @@ -815,7 +657,7 @@ instance Unaligned (BE Float) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) USE_HOST_IMPL(BE) #else {-# INLINE writeWord8ArrayAs# #-} @@ -847,7 +689,7 @@ instance Unaligned (LE Double) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 8 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (D# x#)) = writeWord8ArrayAs# mba# i# (LE (W64# (stgDoubleToWord64 x#))) @@ -866,7 +708,7 @@ instance Unaligned (BE Double) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 8 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) USE_HOST_IMPL(BE) #else {-# INLINE writeWord8ArrayAs# #-} @@ -899,7 +741,7 @@ instance Unaligned (LE Char) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (C# x#)) = writeWord8ArrayAs# mba# i# (LE (I32# (ord# x#))) @@ -918,20 +760,20 @@ instance Unaligned (BE Char) where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) +#if defined(WORDS_BIGENDIAN) USE_HOST_IMPL(BE) #else {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (BE (C# x#)) = - writeWord8ArrayAs# mba# i# (BE (I32# (ord# x#))) + writeWord8ArrayAs# mba# i# (BE (I32# (intToInt32# (ord# x#)))) {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s0 = let !(# s1, BE (I32# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, BE (C# (chr# x#)) #) + in (# s1, BE (C# (chr# (int32ToInt# x#))) #) {-# INLINE indexWord8ArrayAs# #-} indexWord8ArrayAs# ba# i# = let !(BE (I32# x#)) = indexWord8ArrayAs# ba# i# - in BE (C# (chr# x#)) + in BE (C# (chr# (int32ToInt# x#))) #endif -- | Write a, b in order 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 @@ -37,11 +37,15 @@ -} module Z.Data.Array.UnliftedArray where +import Control.Exception (ArrayException (..), throw) import Control.Monad.Primitive -import Data.Primitive.PrimArray (PrimArray(..),MutablePrimArray(..)) -import Data.Primitive.ByteArray (ByteArray(..),MutableByteArray(..)) +import Data.Primitive.Array +import Data.Primitive.ByteArray +import Data.Primitive.PrimArray +import Data.Primitive.SmallArray import GHC.MVar (MVar(..)) import GHC.IORef (IORef(..)) +import GHC.ST import GHC.STRef (STRef(..)) import GHC.Conc (TVar(..)) import GHC.Exts @@ -53,19 +57,78 @@ readUnliftedArray# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, a #) indexUnliftedArray# :: ArrayArray# -> Int# -> a +instance PrimUnlifted (UnliftedArray a) where + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} + writeUnliftedArray# a i (UnliftedArray x) = writeArrayArrayArray# a i x + readUnliftedArray# a i s0 = case readArrayArrayArray# a i s0 of + (# s1, x #) -> (# s1, UnliftedArray x #) + indexUnliftedArray# a i = UnliftedArray (indexArrayArrayArray# a i) + +instance PrimUnlifted (MutableUnliftedArray s a) where + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} + writeUnliftedArray# a i (MutableUnliftedArray x) = + writeMutableArrayArrayArray# a i (unsafeCoerce# x) + readUnliftedArray# a i s0 = case readMutableArrayArrayArray# a i s0 of + (# s1, x #) -> (# s1, MutableUnliftedArray (unsafeCoerce# x) #) + indexUnliftedArray# a i = MutableUnliftedArray (unsafeCoerce# (indexArrayArrayArray# a i)) + +instance PrimUnlifted (Array a) where + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} + writeUnliftedArray# a i (Array x) = + writeArrayArrayArray# a i (unsafeCoerce# x) + readUnliftedArray# a i s0 = case readArrayArrayArray# a i s0 of + (# s1, x #) -> (# s1, Array (unsafeCoerce# x) #) + indexUnliftedArray# a i = Array (unsafeCoerce# (indexArrayArrayArray# a i)) + +instance PrimUnlifted (MutableArray s a) where + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} + writeUnliftedArray# a i (MutableArray x) = + writeMutableArrayArrayArray# a i (unsafeCoerce# x) + readUnliftedArray# a i s0 = case readMutableArrayArrayArray# a i s0 of + (# s1, x #) -> (# s1, MutableArray (unsafeCoerce# x) #) + indexUnliftedArray# a i = MutableArray (unsafeCoerce# (indexArrayArrayArray# a i)) + +instance PrimUnlifted (SmallArray a) where + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} + writeUnliftedArray# a i (SmallArray x) = + writeArrayArrayArray# a i (unsafeCoerce# x) + readUnliftedArray# a i s0 = case readArrayArrayArray# a i s0 of + (# s1, x #) -> (# s1, SmallArray (unsafeCoerce# x) #) + indexUnliftedArray# a i = SmallArray (unsafeCoerce# (indexArrayArrayArray# a i)) + +instance PrimUnlifted (SmallMutableArray s a) where + {-# INLINE writeUnliftedArray# #-} + {-# INLINE readUnliftedArray# #-} + {-# INLINE indexUnliftedArray# #-} + writeUnliftedArray# a i (SmallMutableArray x) = + writeMutableArrayArrayArray# a i (unsafeCoerce# x) + readUnliftedArray# a i s0 = case readMutableArrayArrayArray# a i s0 of + (# s1, x #) -> (# s1, SmallMutableArray (unsafeCoerce# x) #) + indexUnliftedArray# a i = SmallMutableArray (unsafeCoerce# (indexArrayArrayArray# a i)) + 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 +141,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 +153,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 +163,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 +173,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 +183,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 +194,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,10 +220,21 @@ :: (PrimMonad m) => Int -- ^ size -> m (MutableUnliftedArray (PrimState m) a) -{-# inline unsafeNewUnliftedArray #-} +{-# INLINE unsafeNewUnliftedArray #-} +unsafeNewUnliftedArray 0 = primitive $ \s -> + -- GHC 9.2 has a bug: call newArrayArray# with 0# length will hang + -- so we unsafeCoerce# empty Array# into ArrayArray# here + case newArray# 0# (throw (UndefinedElement "Data.Array.UnliftedArray.uninitialized")) s of + (# s', maa# #) -> (# s', MutableUnliftedArray (unsafeCoerce# maa#) #) unsafeNewUnliftedArray (I# i#) = primitive $ \s -> case newArrayArray# i# s of (# s', maa# #) -> (# s', MutableUnliftedArray maa# #) +emptyUnliftedArray :: PrimUnlifted a => UnliftedArray a +{-# NOINLINE emptyUnliftedArray #-} +emptyUnliftedArray = runST (do + mua <- unsafeNewUnliftedArray 0 + unsafeFreezeUnliftedArray mua) + -- | Creates a new 'MutableUnliftedArray' with the specified value as initial -- contents. This is slower than 'unsafeNewUnliftedArray', but safer. newUnliftedArray @@ -172,7 +246,7 @@ mua <- unsafeNewUnliftedArray len setUnliftedArray mua 0 len v pure mua -{-# inline newUnliftedArray #-} +{-# INLINE newUnliftedArray #-} setUnliftedArray :: (PrimMonad m, PrimUnlifted a) @@ -181,7 +255,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 +264,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 +278,7 @@ -> Int -> a -> m () -{-# inline writeUnliftedArray #-} +{-# INLINE writeUnliftedArray #-} writeUnliftedArray (MutableUnliftedArray arr) (I# ix) a = primitive_ (writeUnliftedArray# arr ix a) @@ -212,7 +286,7 @@ => MutableUnliftedArray (PrimState m) a -> Int -> m a -{-# inline readUnliftedArray #-} +{-# INLINE readUnliftedArray #-} readUnliftedArray (MutableUnliftedArray arr) (I# ix) = primitive (readUnliftedArray# arr ix) @@ -220,7 +294,7 @@ => UnliftedArray a -> Int -> a -{-# inline indexUnliftedArray #-} +{-# INLINE indexUnliftedArray #-} indexUnliftedArray (UnliftedArray arr) (I# ix) = indexUnliftedArray# arr ix @@ -234,7 +308,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 +318,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 +329,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 +345,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 +365,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 +377,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 +389,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 +403,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,19 @@ , utcTime , localTime , zonedTime + -- * UUID + , uuid, uuidUpper, encodeUUID + -- * Specialized primitive builder + , 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 Z.Data.Builder.UUID +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 builder + , 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 @@ -58,16 +65,16 @@ import Data.Primitive.Ptr (copyPtrToMutablePrimArray) import Data.Word import Data.Int -import GHC.CString (unpackCString#, unpackCStringUtf8#) import GHC.Exts hiding (build) import GHC.Stack 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(..)) @@ -131,7 +138,7 @@ {-# INLINE (>>=) #-} (Builder b) >>= f = Builder (\ k -> b ( \ a -> runBuilder (f a) k)) {-# INLINE (>>) #-} - (>>) = append + (>>) = (*>) instance Semigroup (Builder ()) where (<>) = append @@ -140,7 +147,7 @@ instance Monoid (Builder ()) where mempty = pure () {-# INLINE mempty #-} - mappend = append + mappend = (<>) {-# INLINE mappend #-} mconcat = foldr append (pure ()) {-# INLINE mconcat #-} @@ -206,12 +213,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 +227,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 +256,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 +264,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 +320,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 +341,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 +433,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 +463,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 +504,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 @@ -37,6 +37,7 @@ , i2wDec, i2wHex, i2wHexUpper , countDigits , c_intWith, hs_intWith + , quotRem10 ) where import Control.Monad @@ -49,20 +50,18 @@ import Data.Word import GHC.Exts import GHC.Float -import GHC.Integer +import GHC.Num import Z.Data.ASCII import Z.Data.Builder.Base import Z.Data.Builder.Numeric.DigitTable import Z.Foreign import System.IO.Unsafe -#ifdef INTEGER_GMP -import GHC.Integer.GMP.Internals -#endif import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) -------------------------------------------------------------------------------- -foreign import ccall unsafe "dtoa.h" c_int_dec :: Word64 -> Int -> Int -> Word8 -> MBA# Word8 -> Int -> IO Int +foreign import ccall unsafe "dtoa.h" + c_int_dec :: Word64 -> Int -> Int -> Word8 -> MBA# Word8 -> Int -> IO Int -- | Integral formatting options. -- @@ -84,6 +83,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 @@ -112,9 +112,9 @@ -- intWith :: (Integral a, Bounded a) => IFormat -> a -> Builder () intWith = hs_intWith -{-# INLINE[0] intWith #-} -{-# RULES "intWith'/Int8" intWith = c_intWith :: IFormat -> Int8 -> Builder () #-} +{-# INLINE [1] intWith #-} {-# RULES "intWith'/Int" intWith = c_intWith :: IFormat -> Int -> Builder () #-} +{-# RULES "intWith'/Int8" intWith = c_intWith :: IFormat -> Int8 -> Builder () #-} {-# RULES "intWith'/Int16" intWith = c_intWith :: IFormat -> Int16 -> Builder () #-} {-# RULES "intWith'/Int32" intWith = c_intWith :: IFormat -> Int32 -> Builder () #-} {-# RULES "intWith'/Int64" intWith = c_intWith :: IFormat -> Int64 -> Builder () #-} @@ -123,29 +123,31 @@ {-# RULES "intWith'/Word16" intWith = c_intWith :: IFormat -> Word16 -> Builder () #-} {-# RULES "intWith'/Word32" intWith = c_intWith :: IFormat -> Word32 -> Builder () #-} {-# RULES "intWith'/Word64" intWith = c_intWith :: IFormat -> Word64 -> Builder () #-} +{-# RULES "intWith'/CShort" intWith = c_intWith :: IFormat -> CShort -> Builder () #-} +{-# RULES "intWith'/CUShort" intWith = c_intWith :: IFormat -> CUShort -> Builder () #-} +{-# RULES "intWith'/CInt" intWith = c_intWith :: IFormat -> CInt -> Builder () #-} +{-# RULES "intWith'/CUInt" intWith = c_intWith :: IFormat -> CUInt -> Builder () #-} +{-# RULES "intWith'/CLong" intWith = c_intWith :: IFormat -> CLong -> Builder () #-} +{-# RULES "intWith'/CULong" intWith = c_intWith :: IFormat -> CULong -> Builder () #-} +{-# RULES "intWith'/CLLong" intWith = c_intWith :: IFormat -> CLLong -> Builder () #-} +{-# RULES "intWith'/CULLong" intWith = c_intWith :: IFormat -> CULLong -> Builder () #-} -- | Internal formatting backed by C FFI, it must be used with type smaller than 'Word64'. -- -- We use rewrite rules to rewrite most of the integral types formatting to this function. c_intWith :: (Integral a, Bits a) => IFormat -> a -> Builder () {-# INLINE c_intWith #-} -c_intWith (IFormat{..}) x - | x < 0 = - let !x' = (fromIntegral (complement x) :: Word64) + 1 - in ensureN width' (\ (MutablePrimArray mba#) i -> - (c_int_dec x' (-1) width pad mba# i)) - | posSign = - ensureN width' (\ (MutablePrimArray mba#) i -> - (c_int_dec (fromIntegral x) 1 width pad mba# i)) - | otherwise = - ensureN width' (\ (MutablePrimArray mba#) i -> - (c_int_dec (fromIntegral x) 0 width pad mba# i)) +c_intWith (IFormat{..}) = \ x -> + ensureN (max 21 width) (\ (MutablePrimArray mba#) i -> + if x < 0 + then let !x' = (fromIntegral (complement x) :: Word64) + 1 + in (c_int_dec x' (-1) width pad mba# i) + else c_int_dec (fromIntegral x) (if posSign then 1 else 0) width pad mba# i) where - width' = max 21 width 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. -- @@ -338,9 +340,8 @@ | v < 10 = writePrimArray marr off (i2wDec v) | otherwise = write2 off v write2 off i0 = do - let i = fromIntegral i0; j = i + i - writePrimArray marr off $ indexOffPtr decDigitTable (j + 1) - writePrimArray marr (off - 1) $ indexOffPtr decDigitTable j + let i = fromIntegral i0; + writePrimWord8ArrayAs marr (off-1) $ indexOffPtr decDigitTable i -------------------------------------------------------------------------------- @@ -364,9 +365,7 @@ -- | Format a 'Integer' into decimal ASCII digits. integer :: Integer -> Builder () {-# INLINE integer #-} -#ifdef INTEGER_GMP -integer (S# i#) = int (I# i#) -#endif +integer (IS i#) = int (I# i#) -- Divide and conquer implementation of string conversion integer n0 | n0 < 0 = encodePrim MINUS >> integer' (-n0) @@ -382,7 +381,7 @@ -- that all fit into a machine word. jprinth :: [Integer] -> Builder () jprinth (n:ns) = - case n `quotRemInteger` BASE of + case n `integerQuotRem#` BASE of (# q', r' #) -> let q = fromInteger q' r = fromInteger r' @@ -392,7 +391,7 @@ jprintb :: [Integer] -> Builder () jprintb [] = pure () - jprintb (n:ns) = case n `quotRemInteger` BASE of + jprintb (n:ns) = case n `integerQuotRem#` BASE of (# q', r' #) -> let q = fromInteger q' r = fromInteger r' @@ -418,7 +417,7 @@ jsplith :: Integer -> [Integer] -> [Integer] jsplith p (n:ns) = - case n `quotRemInteger` p of + case n `integerQuotRem#` p of (# q, r #) -> if q > 0 then q : r : jsplitb p ns else r : jsplitb p ns @@ -426,7 +425,7 @@ jsplitb :: Integer -> [Integer] -> [Integer] jsplitb _ [] = [] - jsplitb p (n:ns) = case n `quotRemInteger` p of + jsplitb p (n:ns) = case n `integerQuotRem#` p of (# q, r #) -> q : r : jsplitb p ns @@ -462,13 +461,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 @@ -476,7 +475,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 @@ -501,7 +500,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) @@ -523,7 +532,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) @@ -606,9 +625,7 @@ if c == 0 then ([0], 0) else case c of -#ifdef INTEGER_GMP - (S# i#) -> goI (I# i#) 0 [] -#endif + (IS i#) -> goI (W# (int2Word# i#)) 0 [] _ -> go c 0 [] where sci' = Sci.normalize sci @@ -617,14 +634,24 @@ go :: Integer -> Int -> [Int] -> ([Int], Int) go 0 !n ds = let !ne = n + e in (ds, ne) - go i !n ds = case i `quotRemInteger` 10 of + go i !n ds = case i `integerQuotRem#` 10 of (# q, r #) -> let !d = fromIntegral r in go q (n+1) (d:ds) -#ifdef INTEGER_GMP - goI :: Int -> Int -> [Int] -> ([Int], Int) + goI :: Word -> Int -> [Int] -> ([Int], Int) goI 0 !n ds = let !ne = n + e in (ds, ne) - goI i !n ds = case i `quotRem` 10 of (q, !r) -> goI q (n+1) (r:ds) -#endif + goI i !n ds = case quotRem10 i of (q, r) -> let !d = fromIntegral r in goI q (n+1) (d:ds) +-- | A faster `quotRem` by 10. +quotRem10 :: Word -> (Word, Word) +{-# INLINE quotRem10 #-} +quotRem10 (W# w#) = + let w'# = dquot10# w# + in (W# w'#, W# (w# `minusWord#` (w'# `timesWord#` 10##))) + where + dquot10# :: Word# -> Word# + dquot10# w = + let !(# rdx, _ #) = w `timesWord2#` 0xCCCCCCCCCCCCCCCD## + in rdx `uncheckedShiftRL#` 3# + -- | Worker function to do formatting. doFmt :: FFormat -> Maybe Int -- ^ Number of decimal places to render. @@ -632,8 +659,11 @@ -> Builder () {-# INLINABLE doFmt #-} doFmt format decs (is, e) = case format of - Generic -> doFmt (if e < 0 || e > 7 then Exponent else Fixed) decs (is,e) - Exponent -> case decs of + Generic -> if e < 0 || e > 7 then doFmtExponent else doFmtFixed + Exponent -> doFmtExponent + _ -> doFmtFixed + where + doFmtExponent = case decs of Nothing -> case is of [0] -> "0.0e0" [i] -> encodeDigit i >> ".0e" >> int (e-1) @@ -670,7 +700,7 @@ encodeDigits ds' encodePrim LETTER_e int (e-1+ei) - Fixed -> case decs of + doFmtFixed = case decs of Nothing | e <= 0 -> do "0." @@ -690,7 +720,7 @@ d:ds' = if ei > 0 then is' else 0:is' encodeDigit d (unless (List.null ds') $ encodePrim DOT >> encodeDigits ds') - where + encodeDigit = word8 . i2wDec encodeDigits = mapM_ encodeDigit @@ -721,7 +751,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 -> @@ -745,7 +775,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 @@ -16,7 +16,8 @@ import Data.Primitive.Ptr import GHC.Word -decDigitTable :: Ptr Word8 +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/Builder/UUID.hs b/Z/Data/Builder/UUID.hs new file mode 100644 --- /dev/null +++ b/Z/Data/Builder/UUID.hs @@ -0,0 +1,73 @@ +{-| +Module: Z.Data.Builder.UUID +Description : Builders for UUID. +Copyright: (c) 2021 Dong Han +License: BSD3 +Maintainer: Dong +Stability: experimental +Portability: portable + +Builders for UUID. +-} + +module Z.Data.Builder.UUID + ( uuid, uuidUpper + , encodeUUID + ) where + +import Data.UUID.Types.Internal +import Data.Word +import Data.Bits +import Z.Data.ASCII +import qualified Z.Data.Builder.Base as B +import qualified Z.Data.Builder.Numeric as B + +-- | Write texutal UUID bytes, e.g. @550e8400-e29b-41d4-a716-446655440000@ +uuid :: UUID -> B.Builder () +{-# INLINABLE uuid #-} +uuid (UUID wh wl) = do + let !w1 = fromIntegral @Word64 @Word32 $ wh `unsafeShiftR` 32 + !w2 = fromIntegral @Word64 @Word16 $ wh `unsafeShiftR` 16 .&. 0xFFFF + !w3 = fromIntegral @Word64 @Word16 $ wh .&. 0xFFFF + !w4 = fromIntegral @Word64 @Word16 $ wl `unsafeShiftR` 48 + !w5 = fromIntegral @Word64 @Word16 $ wl `unsafeShiftR` 32 .&. 0xFFFF + !w6 = fromIntegral @Word64 @Word32 $ wl .&. 0xFFFFFFFF + B.hex w1 + B.word8 HYPHEN + B.hex w2 + B.word8 HYPHEN + B.hex w3 + B.word8 HYPHEN + B.hex w4 + B.word8 HYPHEN + B.hex w5 + B.hex w6 + +-- | Write texutal UUID bytes in UPPERCASE, e.g. @550E8400-E29B-41D4-A716-446655440000@ +uuidUpper :: UUID -> B.Builder () +{-# INLINABLE uuidUpper #-} +uuidUpper (UUID wh wl) = do + let !w1 = fromIntegral @Word64 @Word32 $ wh `unsafeShiftR` 32 + !w2 = fromIntegral @Word64 @Word16 $ wh `unsafeShiftR` 16 .&. 0xFFFF + !w3 = fromIntegral @Word64 @Word16 $ wh .&. 0xFFFF + !w4 = fromIntegral @Word64 @Word16 $ wl `unsafeShiftR` 48 + !w5 = fromIntegral @Word64 @Word16 $ wl `unsafeShiftR` 32 .&. 0xFFFF + !w6 = fromIntegral @Word64 @Word32 $ wl .&. 0xFFFFFFFF + B.hexUpper w1 + B.word8 HYPHEN + B.hexUpper w2 + B.word8 HYPHEN + B.hexUpper w3 + B.word8 HYPHEN + B.hexUpper w4 + B.word8 HYPHEN + B.hexUpper w5 + B.hexUpper w6 + + +-- | Encode binary UUID(two 64-bits word in big-endian), as described in . +encodeUUID :: UUID -> B.Builder () +{-# INLINABLE encodeUUID #-} +encodeUUID (UUID wh wl) = do + B.encodeWord64BE wh + B.encodeWord64BE wl diff --git a/Z/Data/CBytes.hs b/Z/Data/CBytes.hs --- a/Z/Data/CBytes.hs +++ b/Z/Data/CBytes.hs @@ -40,10 +40,8 @@ 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 import GHC.Exts import GHC.Ptr import GHC.Stack @@ -61,7 +59,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 +100,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 +127,7 @@ :: PrimMonad m => MutablePrimArray (PrimState m) Word8 -> m CBytes -{-# INLINE fromMutablePrimArray #-} +{-# INLINABLE fromMutablePrimArray #-} fromMutablePrimArray marr = do let l = sizeofMutablePrimArray marr arr <- unsafeFreezePrimArray marr @@ -176,7 +173,7 @@ {-# INLINE mempty #-} mempty = empty {-# INLINE mappend #-} - mappend = append + mappend = (<>) {-# INLINE mconcat #-} mconcat = concat @@ -213,6 +210,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 @@ -234,30 +232,30 @@ toUTF8BuilderP _ = T.stringUTF8 . show . unpack -- | JSON instances check if 'CBytes' is properly UTF8 encoded, --- if it is, decode/encode it as 'T.Text', otherwise as an object with a base64 field. +-- if it is, decode/encode it as 'T.Text', otherwise as an object with a @__base64@ field. -- -- @ -- > encodeText ("hello" :: CBytes) -- "\"hello\"" -- > encodeText ("hello\\NUL" :: CBytes) -- @\\NUL@ is encoded as C0 80, which is illegal UTF8 --- "{\"base64\":\"aGVsbG/AgA==\"}" +-- "{\"__base64\":\"aGVsbG/AgA==\"}" -- @ instance JSON.JSON CBytes where {-# INLINE fromValue #-} fromValue v = JSON.withText "Z.Data.CBytes" (pure . fromText) v - <|> JSON.withFlatMapR "Z.Data.CBytes" (\ o -> fromBytes <$> o .: "base64") v + <|> JSON.withFlatMapR "Z.Data.CBytes" (\ o -> fromBytes <$> o .: "__base64") v {-# INLINE toValue #-} toValue cbytes = case toTextMaybe cbytes of Just t -> JSON.toValue t - Nothing -> JSON.object $ [ "base64" .= toBytes cbytes ] + Nothing -> JSON.object $ [ "__base64" .= toBytes cbytes ] {-# INLINE encodeJSON #-} encodeJSON cbytes = case toTextMaybe cbytes of Just t -> JSON.encodeJSON t - Nothing -> JSON.object' $ "base64" .! toBytes cbytes + Nothing -> JSON.object' $ "__base64" .! toBytes cbytes -- | 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 +459,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 +490,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 +512,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)) -------------------------------------------------------------------------------- @@ -613,8 +611,8 @@ | otherwise = do mba@(MutablePrimArray mba#) <- newPrimArray n :: IO (MutablePrimArray RealWorld Word8) a <- fill mba# - l <- fromIntegral <$> (c_memchr mba# 0 0 n) - let l' = if l == -1 then (n-1) else l + l <- fromIntegral <$> c_memchr mba# 0 0 n + let l' = if l == -1 then n-1 else l shrinkMutablePrimArray mba (l'+1) writePrimArray mba l' 0 bs <- unsafeFreezePrimArray mba @@ -635,8 +633,8 @@ | otherwise = do mba@(MutablePrimArray mba#) <- newPinnedPrimArray n :: IO (MutablePrimArray RealWorld Word8) a <- withMutablePrimArrayContents mba (fill . castPtr) - l <- fromIntegral <$> (c_memchr mba# 0 0 n) - let l' = if l == -1 then (n-1) else l + l <- fromIntegral <$> c_memchr mba# 0 0 n + let l' = if l == -1 then n-1 else l shrinkMutablePrimArray mba (l'+1) writePrimArray mba l' 0 bs <- unsafeFreezePrimArray mba @@ -659,4 +657,5 @@ c_strlen_ptr (Ptr a#) = V.c_strlen a# -- HsInt hs_memchr(uint8_t *a, HsInt aoff, uint8_t b, HsInt n); -foreign import ccall unsafe "hs_memchr" c_memchr :: MBA# Word8 -> Int -> Word8 -> Int -> IO Int +foreign import ccall unsafe "hs_memchr" + c_memchr :: MBA# Word8 -> Int -> Word8 -> Int -> IO Int diff --git a/Z/Data/Generics/Utils.hs b/Z/Data/Generics/Utils.hs --- a/Z/Data/Generics/Utils.hs +++ b/Z/Data/Generics/Utils.hs @@ -23,9 +23,10 @@ import GHC.Generics import GHC.TypeNats import GHC.Exts (Proxy#, proxy#) +import Data.Kind -- | type class for calculating product size. -class KnownNat (PSize f) => ProductSize (f :: * -> *) where +class KnownNat (PSize f) => ProductSize (f :: Type -> Type) where type PSize f :: Nat instance ProductSize (S1 s a) where @@ -38,7 +39,7 @@ productSize _ = fromIntegral (natVal' (proxy# :: Proxy# (PSize f))) -class KnownNat (SSize f) => SumSize (f :: * -> *) where +class KnownNat (SSize f) => SumSize (f :: Type -> Type) where type SSize f :: Nat instance SumSize (C1 c a) where diff --git a/Z/Data/JSON.hs b/Z/Data/JSON.hs --- a/Z/Data/JSON.hs +++ b/Z/Data/JSON.hs @@ -34,7 +34,7 @@ , decode, decode', decodeText, decodeText' , ParseChunks, decodeChunk, decodeChunks , encode, encodeChunks, encodeText - , prettyJSON, prettyValue + , prettyJSON, prettyValue, prettyJSON', prettyValue' -- * parse into JSON Value , parseValue, parseValue' -- * Generic functions @@ -72,6 +72,7 @@ import Z.Data.JSON.Base import qualified Z.Data.Parser as P import qualified Z.Data.Text as T +import Data.UUID.Types (UUID) -- $use -- @@ -206,7 +207,7 @@ -------------------------------------------------------------------------------- symbCase :: Char -> String -> T.Text -{-# INLINE symbCase #-} +{-# INLINABLE symbCase #-} symbCase sym = T.pack . go . applyFirst toLower where go [] = [] @@ -391,6 +392,16 @@ encodeJSON Saturday = "\"Saturday\"" encodeJSON Sunday = "\"Sunday\"" +instance JSON UUID where + {-# INLINE fromValue #-} + fromValue = withText "UUID" $ \ t -> + case P.parse' (P.uuid <* P.endOfInput) (T.getUTF8Bytes t) of + Left err -> fail' $ "could not parse UUID: " <> T.toText err + Right r -> return r + {-# INLINE toValue #-} + toValue = String . B.unsafeBuildText . B.quotes . B.uuid + {-# INLINE encodeJSON #-} + encodeJSON = B.quotes . B.uuid -------------------------------------------------------------------------------- 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 @@ -20,7 +20,7 @@ , decode, decode', decodeText, decodeText' , P.ParseChunks, decodeChunk, decodeChunks , encode, encodeChunks, encodeText - , prettyJSON, JB.prettyValue + , prettyJSON, JB.prettyValue, prettyJSON', JB.prettyValue' -- * parse into JSON Value , JV.parseValue, JV.parseValue' -- * Generic functions @@ -188,11 +188,20 @@ {-# INLINE convertValue #-} convertValue = convert fromValue --- | Directly encode data to JSON bytes. +-- | Pretty a 'JSON' data with 'JB.prettyValue'. prettyJSON :: JSON a => a -> B.Builder () {-# INLINE prettyJSON #-} prettyJSON = JB.prettyValue . toValue +-- | Pretty a 'JSON' data with 'JB.prettyValue\''. +prettyJSON' :: JSON a + => Int -- ^ indentation per level + -> Int -- ^ initial indentation + -> a + -> B.Builder () +{-# INLINE prettyJSON' #-} +prettyJSON' i ii = JB.prettyValue' i ii . toValue + -------------------------------------------------------------------------------- -- | Produce an error message like @converting XXX failed, expected XXX, encountered XXX@. @@ -200,7 +209,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 +333,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 +450,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 @@ -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 @@ -104,7 +104,7 @@ 3 -> do c <- arbitrary e <- arbitrary - pure . Number $ scientific c e + pure . Number $! scientific c e 4 -> Bool <$> arbitrary _ -> pure Null @@ -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 @@ -66,11 +66,21 @@ , timeZone , utcTime , zonedTime + -- * UUID + , uuid, decodeUUID -- * Misc , fail', failWithInput, unsafeLiftIO + -- * Specialized primitive parser + , decodeWord , decodeWord64, decodeWord32, decodeWord16, decodeWord8 + , decodeInt , decodeInt64 , decodeInt32 , decodeInt16 , decodeInt8 , decodeDouble, decodeFloat + , decodeWordLE , decodeWord64LE , decodeWord32LE , decodeWord16LE + , decodeIntLE , decodeInt64LE , decodeInt32LE , decodeInt16LE , decodeDoubleLE , decodeFloatLE + , decodeWordBE , decodeWord64BE , decodeWord32BE , decodeWord16BE + , decodeIntBE , decodeInt64BE , decodeInt32BE , decodeInt16BE , decodeDoubleBE , decodeFloatBE ) where import Z.Data.Parser.Base import Z.Data.Parser.Numeric import Z.Data.Parser.Time -import Prelude hiding (take, takeWhile) +import Z.Data.Parser.UUID +import Prelude hiding (take, takeWhile, decodeFloat) 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,13 +30,21 @@ , 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 + -- * Specialized primitive parser + , decodeWord , decodeWord64, decodeWord32, decodeWord16, decodeWord8 + , decodeInt , decodeInt64 , decodeInt32 , decodeInt16 , decodeInt8 , decodeDouble, decodeFloat + , decodeWordLE , decodeWord64LE , decodeWord32LE , decodeWord16LE + , decodeIntLE , decodeInt64LE , decodeInt32LE , decodeInt16LE , decodeDoubleLE , decodeFloatLE + , decodeWordBE , decodeWord64BE , decodeWord32BE , decodeWord16BE + , decodeIntBE , decodeInt64BE , decodeInt32BE , decodeInt16BE , decodeDoubleBE , decodeFloatBE ) where import Control.Applicative +import Control.Exception (assert) import Control.Monad import Control.Monad.Primitive import qualified Control.Monad.Fail as Fail @@ -45,9 +53,9 @@ import Data.Int import Data.Word import Data.Bits ((.&.)) -import GHC.Types +import GHC.IO import GHC.Exts (State#, runRW#, unsafeCoerce#) -import Prelude hiding (take, takeWhile) +import Prelude hiding (take, takeWhile, decodeFloat) import Z.Data.Array.Unaligned import Z.Data.ASCII import qualified Z.Data.Text as T @@ -110,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 #-} @@ -136,10 +152,14 @@ instance PrimMonad Parser where type PrimState Parser = ParserState {-# INLINE primitive #-} - primitive = \ io -> Parser $ \ _ k st inp -> + primitive io = Parser (\ _ k st inp -> let !(# st', r #) = io st - in k st' r inp + in k st' r inp) +{-# RULES "replicateM/Parser" forall n (x :: Parser a). V.replicateM n x = V.replicatePM n x #-} +{-# RULES "traverse/Parser" forall (f :: a -> Parser b). V.traverse f = V.traverseWithIndexPM (const f) #-} +{-# RULES "traverseWithIndex/Parser" forall (f :: Int -> a -> Parser b). V.traverseWithIndex f = V.traverseWithIndexPM f #-} + -- | Unsafely lifted an `IO` action into 'Parser'. -- -- This is only for debugging purpose(logging, etc). Don't mix compuation from @@ -164,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 (<|>) #-} @@ -184,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 #-} @@ -216,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 @@ -233,27 +270,28 @@ -- 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 -- | Return both the result of a parse and the portion of the input -- that was consumed while it was being parsed. +-- 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' -> let consumed' = V.dropR (V.length inp') consumed + in consumed' `seq` k s (consumed' , r') inp' Failure err inp' -> Failure err inp' Partial _ -> error "Z.Data.Parser.Base.match: impossible") @@ -262,32 +300,67 @@ -- -- Since this parser is used in many other parsers, an extra error param is provide -- to attach custom error info. -ensureN :: Int -> ParseError -> Parser () +ensureN :: Int -> T.Text -> Parser () {-# INLINE ensureN #-} ensureN n0 err = Parser $ \ kf k s inp -> do let l = V.length inp - if l >= n0 + if n0 <= l then k s () inp - else Partial (ensureNPartial l inp kf k s) + else Partial (ensureNPartial (n0-l) inp kf k s) where - {-# INLINABLE ensureNPartial #-} 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 = + 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.concat (reverse (inp:acc))) + then kf [err] (V.concatR (inp:acc)) else do - let l'' = l + l' - if l'' < n0 - then Partial (go (inp:acc) l'' s) - else - let !inp' = V.concat (reverse (inp:acc)) - in k s () inp' + 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 +-- | 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 @@ -323,68 +396,74 @@ -- | 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) +#define DECODE_HOST(f, type) \ + f :: Parser type; {-# INLINE f #-}; f = decodePrim; \ + -- ^ Decode type in host endian order. + +DECODE_HOST(decodeWord , Word ) +DECODE_HOST(decodeWord64, Word64 ) +DECODE_HOST(decodeWord32, Word32 ) +DECODE_HOST(decodeWord16, Word16 ) +DECODE_HOST(decodeWord8 , Word8 ) +DECODE_HOST(decodeInt , Int ) +DECODE_HOST(decodeInt64 , Int64 ) +DECODE_HOST(decodeInt32 , Int32 ) +DECODE_HOST(decodeInt16 , Int16 ) +DECODE_HOST(decodeInt8 , Int8 ) +DECODE_HOST(decodeDouble, Double ) +DECODE_HOST(decodeFloat , Float ) + -- | 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)) +#define DECODE_LE(f, type) \ + f :: Parser type; {-# INLINE f #-}; f = decodePrimLE; \ + -- ^ Decode type in little endian order. + +DECODE_LE(decodeWordLE , Word ) +DECODE_LE(decodeWord64LE, Word64 ) +DECODE_LE(decodeWord32LE, Word32 ) +DECODE_LE(decodeWord16LE, Word16 ) +DECODE_LE(decodeIntLE , Int ) +DECODE_LE(decodeInt64LE , Int64 ) +DECODE_LE(decodeInt32LE , Int32 ) +DECODE_LE(decodeInt16LE , Int16 ) +DECODE_LE(decodeDoubleLE, Double ) +DECODE_LE(decodeFloatLE , Float ) + -- | 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)) +#define DECODE_BE(f, type) \ + f :: Parser type; {-# INLINE f #-}; f = decodePrimBE; \ + -- ^ Decode type in big endian order. + +DECODE_BE(decodeWordBE , Word ) +DECODE_BE(decodeWord64BE, Word64 ) +DECODE_BE(decodeWord32BE, Word32 ) +DECODE_BE(decodeWord16BE, Word16 ) +DECODE_BE(decodeIntBE , Int ) +DECODE_BE(decodeInt64BE , Int64 ) +DECODE_BE(decodeInt32BE , Int32 ) +DECODE_BE(decodeInt16BE , Int16 ) +DECODE_BE(decodeDoubleBE, Double ) +DECODE_BE(decodeFloatBE , Float ) + -- | A stateful scanner. The predicate consumes and transforms a -- state argument, and each transformed state is passed to successive -- invocations of the predicate on each byte of the input until one @@ -417,6 +496,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 -> @@ -425,19 +507,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 -------------------------------------------------------------------------------- @@ -479,7 +561,7 @@ satisfy :: (Word8 -> Bool) -> Parser Word8 {-# INLINE satisfy #-} satisfy p = do - ensureN 1 ["Z.Data.Parser.Base.satisfy: not enough bytes"] + ensureN 1 "Z.Data.Parser.Base.satisfy: not enough bytes" Parser $ \ kf k s inp -> let w = V.unsafeHead inp in if p w @@ -494,7 +576,7 @@ satisfyWith :: (Word8 -> a) -> (a -> Bool) -> Parser a {-# INLINE satisfyWith #-} satisfyWith f p = do - ensureN 1 ["Z.Data.Parser.Base.satisfyWith: not enough bytes"] + ensureN 1 "Z.Data.Parser.Base.satisfyWith: not enough bytes" Parser $ \ kf k s inp -> let a = f (V.unsafeHead inp) in if p a @@ -506,7 +588,7 @@ word8 :: Word8 -> Parser () {-# INLINE word8 #-} word8 w' = do - ensureN 1 ["Z.Data.Parser.Base.word8: not enough bytes"] + ensureN 1 "Z.Data.Parser.Base.word8: not enough bytes" Parser (\ kf k s inp -> let w = V.unsafeHead inp in if w == w' @@ -564,7 +646,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 @@ -579,7 +661,7 @@ else k st (Left 1) inp case r of Left d -> do - ensureN d ["Z.Data.Parser.Base.anyCharUTF8: not enough bytes"] + ensureN d "Z.Data.Parser.Base.anyCharUTF8: not enough bytes" anyCharUTF8 Right c -> return c @@ -607,27 +689,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. -- @@ -648,13 +728,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 = @@ -672,16 +750,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. @@ -689,24 +761,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, @@ -715,25 +786,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 @@ -754,16 +823,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). -- @@ -788,7 +864,7 @@ {-# INLINE bytes #-} bytes bs = do let n = V.length bs - ensureN n ["Z.Data.Parser.Base.bytes: not enough bytes"] + ensureN n "Z.Data.Parser.Base.bytes: not enough bytes" Parser (\ kf k s inp -> if bs == V.unsafeTake n inp then k s () $! V.unsafeDrop n inp @@ -806,7 +882,7 @@ bytesCI bs = do let n = V.length bs -- casefold an ASCII string should not change it's length - ensureN n ["Z.Data.Parser.Base.bytesCI: not enough bytes"] + ensureN n "Z.Data.Parser.Base.bytesCI: not enough bytes" Parser (\ kf k s inp -> if bs' == CI.foldCase (V.unsafeTake n inp) then k s () $! V.unsafeDrop n inp @@ -814,7 +890,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 @@ -32,19 +32,25 @@ , hexLoop , decLoop , decLoopIntegerFast + , sciToDouble ) where import Control.Applicative import Control.Monad import Data.Bits import Data.Int -import qualified Data.Scientific as Sci +import qualified Data.Scientific as Sci import Data.Word +import GHC.Exts +import GHC.Num +import GHC.Float (expt) import Z.Data.ASCII import Z.Data.Parser.Base (Parser, ()) import qualified Z.Data.Parser.Base as P import qualified Z.Data.Vector.Base as V import qualified Z.Data.Vector.Extra as V +import Z.Foreign +import System.IO.Unsafe #define WORD64_SAFE_DIGITS_LEN 19 #define INT64_SAFE_DIGITS_LEN 18 @@ -62,11 +68,21 @@ -- >>> 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 - then return (hexLoop 0 bs) + then return $! hexLoop 0 bs else P.fail' "hex numeric number overflow" -- | Same with 'hex', but only take as many as (bit_size/4) bytes. @@ -76,7 +92,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) @@ -89,7 +115,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. @@ -112,26 +148,46 @@ -- | 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 then do let w64 = decLoop @Word64 0 bs if w64 <= fromIntegral (maxBound :: a) - then return (fromIntegral w64) + then return $! fromIntegral w64 else P.fail' "decimal numeric value overflow" else do let w64 = decLoop @Integer 0 bs if w64 <= fromIntegral (maxBound :: a) - then return (fromIntegral w64) + then return $! fromIntegral w64 else P.fail' "decimal numeric value overflow" -- | Decode digits sequence within an array. @@ -165,6 +221,7 @@ -- | Take a single decimal digit and return as 'Int'. -- digit :: Parser Int +{-# INLINE digit #-} digit = do d <- P.satisfy isDigit return $! w2iDec d @@ -174,7 +231,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 @@ -187,12 +254,12 @@ then do let w64 = decLoop @Word64 0 bs if w64 <= fromIntegral (maxBound :: a) - then return (fromIntegral w64) + then return $! fromIntegral w64 else P.fail' "decimal numeric value overflow" else do let w64 = decLoop @Integer 0 bs if w64 <= fromIntegral (maxBound :: a) - then return (fromIntegral w64) + then return $! fromIntegral w64 else P.fail' "decimal numeric value overflow" loopNe = do bs <- P.takeWhile1 isDigit @@ -200,17 +267,27 @@ then do let i64 = negate (decLoop @Int64 0 bs) if i64 >= fromIntegral (minBound :: a) - then return (fromIntegral i64) + then return $! fromIntegral i64 else P.fail' "decimal numeric value overflow" else do let i64 = negate (decLoop @Integer 0 bs) if i64 >= fromIntegral (minBound :: a) - then return (fromIntegral i64) + then return $! fromIntegral i64 else P.fail' "decimal numeric value overflow" -- | 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 @@ -222,7 +299,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 @@ -245,7 +322,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'. @@ -275,14 +352,14 @@ -- \"Infinity\". -- double :: Parser Double -{-# INLINE double #-} -double = "Z.Data.Parser.Numeric.double" scientificallyInternal Sci.toRealFloat +{-# 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. @@ -290,14 +367,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. @@ -321,15 +398,16 @@ else let i = decLoopIntegerFast intPart f = decLoopIntegerFast fracPart - in i * 10 ^ flen + f + 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) - Sci.scientific c . subtract e <$> int) <|> pure (Sci.scientific c (negate e)) + e' <- int + pure $! Sci.scientific c (e' - e)) <|> (pure $! Sci.scientific c (negate e)) -------------------------------------------------------------------------------- @@ -346,7 +424,7 @@ -- instead. -- rational' :: (Fractional a) => Parser a -{-# INLINE rational' #-} +{-# INLINABLE rational' #-} rational' = "Z.Data.Parser.Numeric.rational'" scientificallyInternal' realToFrac -- | More strict number parsing(rfc8259). @@ -379,28 +457,50 @@ -- \"Infinity\". -- reference: https://tools.ietf.org/html/rfc8259#section-6 double' :: Parser Double -{-# INLINE double' #-} -double' = "Z.Data.Parser.Numeric.double'" scientificallyInternal' Sci.toRealFloat +{-# 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 + (IS 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) + (success, r) <- allocPrimUnsafe @Word8 (compute_float_64 (fromIntegral e) i' s) + if success == 0 + then return $! Sci.toRealFloat sci + else return $! r + _ -> Sci.toRealFloat sci + where + e = Sci.base10Exponent sci + c = Sci.coefficient sci + -- | Parse a rational number and round to 'Float' using stricter grammer. -- -- 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'. @@ -425,15 +525,22 @@ else let i = decLoopIntegerFast intPart f = decLoopIntegerFast fracPart - in i * 10 ^ flen + f + 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 Just ec | ec == LETTER_e || ec == LETTER_E -> P.skipWord8 *> int _ -> pure 0 pure $! Sci.scientific c (e' - e) + +foreign import ccall unsafe compute_float_64 :: Int64 -- ^ power of 10 + -> Word64 -- ^ base + -> Word8 -- ^ negative + -> MBA# Word8 -- ^ success? + -> IO Double -- ^ result 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 Z.Data.Parser.Base (Parser) -import qualified Z.Data.Parser.Base as P -import qualified Z.Data.Parser.Numeric as P -import Z.Data.ASCII -import Data.Fixed (Pico, Fixed(..)) -import Data.Int (Int64) -import Data.Maybe (fromMaybe) -import Data.Time.Calendar (Day, fromGregorianValid) -import Data.Time.Clock (UTCTime(..)) -import qualified Z.Data.Vector as V -import Data.Time.LocalTime hiding (utc) +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.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/Parser/UUID.hs b/Z/Data/Parser/UUID.hs new file mode 100644 --- /dev/null +++ b/Z/Data/Parser/UUID.hs @@ -0,0 +1,45 @@ +{-| +Module: Z.Data.Parser.UUID +Description : Parsers for UUID. +Copyright: (c) 2020 Dong Han +License: BSD3 +Maintainer: Dong +Stability: experimental +Portability: portable + +Parsers for parsing UUID. +-} + +module Z.Data.Parser.UUID + ( uuid + , decodeUUID + ) where + +import Z.Data.ASCII +import qualified Z.Data.Parser.Base as P +import qualified Z.Data.Parser.Numeric as P +import Data.UUID.Types.Internal + +-- | Parse texutal UUID bytes(lower or upper-cased), e.g. @550e8400-e29b-41d4-a716-446655440000@ +uuid :: P.Parser UUID +{-# INLINABLE uuid #-} +uuid = do + p1 <- P.takeN isHexDigit 8 + P.word8 HYPHEN + p2 <- P.takeN isHexDigit 4 + P.word8 HYPHEN + p3 <- P.takeN isHexDigit 4 + P.word8 HYPHEN + p4 <- P.takeN isHexDigit 4 + P.word8 HYPHEN + p5 <- P.takeN isHexDigit 12 + + let !w1 = P.hexLoop (P.hexLoop (P.hexLoop 0 p1) p2) p3 + !w2 = P.hexLoop (P.hexLoop 0 p4) p5 + + pure (UUID w1 w2) + +-- | Decode binary UUID(two 64-bits word in big-endian), as described in . +decodeUUID :: P.Parser UUID +{-# INLINABLE decodeUUID #-} +decodeUUID = UUID <$> P.decodeWord64BE <*> P.decodeWord64BE 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(..), UnliftedIORef + , 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,212 @@ , 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) + +-- | Type alias for 'UnliftedRef' in IO. +type UnliftedIORef a = UnliftedRef RealWorld 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,8 @@ , map', imap' , foldl', ifoldl' , foldr', ifoldr' - , concat, concatMap + , concat, concatR, concatMap + , shuffle, permutations -- ** 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,8 @@ , map', imap' , foldl', ifoldl' , foldr', ifoldr' - , concat, concatMap + , concat, concatR, concatMap + , shuffle, permutations -- ** Special folds , count, all, any -- ** Text display width @@ -121,41 +122,41 @@ import Control.DeepSeq import Control.Exception -import Control.Monad.ST import Control.Monad +import Control.Monad.Primitive +import Control.Monad.ST import Data.Bits -import Data.Char hiding (toLower, toUpper, toTitle) import qualified Data.CaseInsensitive as CI +import Data.Char hiding (toLower, toTitle, toUpper) import Data.Foldable (foldlM) -import Data.Hashable (Hashable(..)) +import Data.Hashable (Hashable (..)) +import Data.Int import qualified Data.List as List -import Data.Primitive.PrimArray +import Data.Primitive.PrimArray hiding (copyPtrToMutablePrimArray) import Data.Typeable -import Data.Int import Data.Word -import Foreign.C.Types (CSize(..)) +import Foreign.C.Types (CSize (..)) import GHC.Exts -import GHC.Types import GHC.Stack -import GHC.CString (unpackCString#, unpackCStringUtf8#) +import System.IO.Unsafe (unsafeDupablePerformIO) +import System.Random.Stateful (StatefulGen) import Z.Data.Array import Z.Data.ASCII (c2w, pattern DOUBLE_QUOTE) import Z.Data.Text.UTF8Codec import Z.Data.Text.UTF8Rewind -import Z.Data.Vector.Base (Bytes, PrimVector(..), c_strlen) import qualified Z.Data.Vector.Base as V +import Z.Data.Vector.Base (Bytes, PrimVector (..), c_strlen) import qualified Z.Data.Vector.Search as V -import System.IO.Unsafe (unsafeDupablePerformIO) -import Prelude hiding (concat, concatMap, - elem, notElem, null, length, map, - foldl, foldl1, foldr, foldr1, - maximum, minimum, product, sum, - all, any, replicate, traverse) +import Prelude hiding (all, any, concat, concatMap, + elem, foldl, foldl1, foldr, foldr1, + length, map, maximum, minimum, + notElem, null, product, replicate, + sum, traverse) -import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) -import Text.Read (Read(..)) +import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..)) import Text.Collate hiding (collate) +import Text.Read (Read (..)) -- | 'Text' represented as UTF-8 encoded 'Bytes' -- @@ -232,13 +233,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 +255,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 +269,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 +291,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 +520,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 +546,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 @@ -609,6 +610,17 @@ !marr' <- resizeMutablePrimArray marr siz' go i' j' k' marr' + +-- | Shuffle a text using algorithm. +shuffle :: (StatefulGen g m, PrimMonad m) => g -> Text -> m Text +{-# INLINE shuffle #-} +shuffle g t = fromVector <$> V.shuffle g (toVector t) + +-- | Generate all permutation of a text using . +permutations :: Text -> [Text] +{-# INLINE permutations #-} +permutations t = fromVector <$> V.permutations (toVector t) + -------------------------------------------------------------------------------- -- -- Strict folds @@ -665,6 +677,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 +736,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 @@ -730,7 +750,7 @@ -- | /O(n*m)/ 'cycleN' a text n times. cycleN :: Int -> Text -> Text {-# INLINE cycleN #-} -cycleN 0 _ = empty +cycleN 0 _ = empty cycleN n (Text v) = Text (V.cycleN n v) -------------------------------------------------------------------------------- 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 @@ -67,7 +67,6 @@ import Data.Int import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Monoid as Monoid -import Data.Proxy (Proxy(..)) import Data.Ratio (Ratio, numerator, denominator) import Data.Tagged (Tagged (..)) import qualified Data.Scientific as Sci @@ -137,22 +136,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 +283,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/Regex.hs b/Z/Data/Text/Regex.hs --- a/Z/Data/Text/Regex.hs +++ b/Z/Data/Text/Regex.hs @@ -115,7 +115,9 @@ {-# NOINLINE regex #-} regex t = unsafePerformIO $ do (cp, r) <- newCPtrUnsafe (\ mba# -> - (withPrimVectorUnsafe (T.getUTF8Bytes t) (hs_re2_compile_pattern_default mba#))) + withPrimVectorUnsafe + (T.getUTF8Bytes t) + (hs_re2_compile_pattern_default mba#)) p_hs_re2_delete_pattern when (r == nullPtr) (throwIO (InvalidRegexPattern t callStack)) @@ -130,7 +132,7 @@ {-# NOINLINE regexOpts #-} regexOpts RegexOpts{..} t = unsafePerformIO $ do (cp, r) <- newCPtrUnsafe ( \ mba# -> - (withPrimVectorUnsafe (T.getUTF8Bytes t) $ \ p o l -> + withPrimVectorUnsafe (T.getUTF8Bytes t) $ \ p o l -> hs_re2_compile_pattern mba# p o l (fromBool posix_syntax ) (fromBool longest_match ) @@ -142,7 +144,7 @@ (fromBool case_sensitive) (fromBool perl_classes ) (fromBool word_boundary ) - (fromBool one_line ))) + (fromBool one_line )) p_hs_re2_delete_pattern when (r == nullPtr) (throwIO (InvalidRegexPattern t callStack)) 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/Text/UTF8Codec.hs b/Z/Data/Text/UTF8Codec.hs --- a/Z/Data/Text/UTF8Codec.hs +++ b/Z/Data/Text/UTF8Codec.hs @@ -41,6 +41,10 @@ encodeChar (MutablePrimArray mba#) (I# i#) (C# c#) = primitive (\ s# -> let !(# s1#, j# #) = encodeChar# mba# i# c# s# in (# s1#, I# j# #)) +writeWord8'# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s +{-# INLINE writeWord8'# #-} +writeWord8'# mba# i# w# s# = writeWord8Array# mba# i# (wordToWord8# w#) s# + -- | The unboxed version of 'encodeChar'. -- -- This function is marked as @NOINLINE@ to reduce code size, and stop messing up simplifier @@ -50,37 +54,37 @@ encodeChar# mba# i# c# = case (int2Word# (ord# c#)) of n# | isTrue# (n# `leWord#` 0x0000007F##) -> \ s# -> - let s1# = writeWord8Array# mba# i# n# s# + let s1# = writeWord8'# mba# i# n# s# in (# s1#, i# +# 1# #) | isTrue# (n# `leWord#` 0x000007FF##) -> \ s# -> - let s1# = writeWord8Array# mba# i# (0xC0## `or#` (n# `uncheckedShiftRL#` 6#)) s# - s2# = writeWord8Array# mba# (i# +# 1#) (0x80## `or#` (n# `and#` 0x3F##)) s1# + let s1# = writeWord8'# mba# i# (0xC0## `or#` (n# `uncheckedShiftRL#` 6#)) s# + s2# = writeWord8'# mba# (i# +# 1#) (0x80## `or#` (n# `and#` 0x3F##)) s1# in (# s2#, i# +# 2# #) | isTrue# (n# `leWord#` 0x0000D7FF##) -> \ s# -> - let s1# = writeWord8Array# mba# i# (0xE0## `or#` (n# `uncheckedShiftRL#` 12#)) s# - s2# = writeWord8Array# mba# (i# +# 1#) (0x80## `or#` ((n# `uncheckedShiftRL#` 6#) `and#` 0x3F##)) s1# - s3# = writeWord8Array# mba# (i# +# 2#) (0x80## `or#` (n# `and#` 0x3F##)) s2# + let s1# = writeWord8'# mba# i# (0xE0## `or#` (n# `uncheckedShiftRL#` 12#)) s# + s2# = writeWord8'# mba# (i# +# 1#) (0x80## `or#` ((n# `uncheckedShiftRL#` 6#) `and#` 0x3F##)) s1# + s3# = writeWord8'# mba# (i# +# 2#) (0x80## `or#` (n# `and#` 0x3F##)) s2# in (# s3#, i# +# 3# #) | isTrue# (n# `leWord#` 0x0000DFFF##) -> \ s# -> -- write replacement char \U+FFFD - let s1# = writeWord8Array# mba# i# 0xEF## s# - s2# = writeWord8Array# mba# (i# +# 1#) 0xBF## s1# - s3# = writeWord8Array# mba# (i# +# 2#) 0xBD## s2# + let s1# = writeWord8'# mba# i# 0xEF## s# + s2# = writeWord8'# mba# (i# +# 1#) 0xBF## s1# + s3# = writeWord8'# mba# (i# +# 2#) 0xBD## s2# in (# s3#, i# +# 3# #) | isTrue# (n# `leWord#` 0x0000FFFF##) -> \ s# -> - let s1# = writeWord8Array# mba# i# (0xE0## `or#` (n# `uncheckedShiftRL#` 12#)) s# - s2# = writeWord8Array# mba# (i# +# 1#) (0x80## `or#` ((n# `uncheckedShiftRL#` 6#) `and#` 0x3F##)) s1# - s3# = writeWord8Array# mba# (i# +# 2#) (0x80## `or#` (n# `and#` 0x3F##)) s2# + let s1# = writeWord8'# mba# i# (0xE0## `or#` (n# `uncheckedShiftRL#` 12#)) s# + s2# = writeWord8'# mba# (i# +# 1#) (0x80## `or#` ((n# `uncheckedShiftRL#` 6#) `and#` 0x3F##)) s1# + s3# = writeWord8'# mba# (i# +# 2#) (0x80## `or#` (n# `and#` 0x3F##)) s2# in (# s3#, i# +# 3# #) | isTrue# (n# `leWord#` 0x0010FFFF##) -> \ s# -> - let s1# = writeWord8Array# mba# i# (0xF0## `or#` (n# `uncheckedShiftRL#` 18#)) s# - s2# = writeWord8Array# mba# (i# +# 1#) (0x80## `or#` ((n# `uncheckedShiftRL#` 12#) `and#` 0x3F##)) s1# - s3# = writeWord8Array# mba# (i# +# 2#) (0x80## `or#` ((n# `uncheckedShiftRL#` 6#) `and#` 0x3F##)) s2# - s4# = writeWord8Array# mba# (i# +# 3#) (0x80## `or#` (n# `and#` 0x3F##)) s3# + let s1# = writeWord8'# mba# i# (0xF0## `or#` (n# `uncheckedShiftRL#` 18#)) s# + s2# = writeWord8'# mba# (i# +# 1#) (0x80## `or#` ((n# `uncheckedShiftRL#` 12#) `and#` 0x3F##)) s1# + s3# = writeWord8'# mba# (i# +# 2#) (0x80## `or#` ((n# `uncheckedShiftRL#` 6#) `and#` 0x3F##)) s2# + s4# = writeWord8'# mba# (i# +# 3#) (0x80## `or#` (n# `and#` 0x3F##)) s3# in (# s4#, i# +# 4# #) | otherwise -> \ s# -> -- write replacement char \U+FFFD - let s1# = writeWord8Array# mba# i# 0xEF## s# - s2# = writeWord8Array# mba# (i# +# 1#) 0xBF## s1# - s3# = writeWord8Array# mba# (i# +# 2#) 0xBD## s2# + let s1# = writeWord8'# mba# i# 0xEF## s# + s2# = writeWord8'# mba# (i# +# 1#) 0xBF## s1# + s3# = writeWord8'# mba# (i# +# 2#) 0xBD## s2# in (# s3#, i# +# 3# #) @@ -99,26 +103,26 @@ encodeCharModifiedUTF8# mba# i# c# = case (int2Word# (ord# c#)) of n# | isTrue# (n# `eqWord#` 0x00000000##) -> \ s# -> -- encode \NUL as \xC0 \x80 - let s1# = writeWord8Array# mba# i# 0xC0## s# - s2# = writeWord8Array# mba# (i# +# 1#) 0x80## s1# + let s1# = writeWord8'# mba# i# 0xC0## s# + s2# = writeWord8'# mba# (i# +# 1#) 0x80## s1# in (# s2#, i# +# 2# #) | isTrue# (n# `leWord#` 0x0000007F##) -> \ s# -> - let s1# = writeWord8Array# mba# i# n# s# + let s1# = writeWord8'# mba# i# n# s# in (# s1#, i# +# 1# #) | isTrue# (n# `leWord#` 0x000007FF##) -> \ s# -> - let s1# = writeWord8Array# mba# i# (0xC0## `or#` (n# `uncheckedShiftRL#` 6#)) s# - s2# = writeWord8Array# mba# (i# +# 1#) (0x80## `or#` (n# `and#` 0x3F##)) s1# + let s1# = writeWord8'# mba# i# (0xC0## `or#` (n# `uncheckedShiftRL#` 6#)) s# + s2# = writeWord8'# mba# (i# +# 1#) (0x80## `or#` (n# `and#` 0x3F##)) s1# in (# s2#, i# +# 2# #) | isTrue# (n# `leWord#` 0x0000FFFF##) -> \ s# -> -- \xD800 ~ \xDFFF is encoded as normal UTF-8 codepoints - let s1# = writeWord8Array# mba# i# (0xE0## `or#` (n# `uncheckedShiftRL#` 12#)) s# - s2# = writeWord8Array# mba# (i# +# 1#) (0x80## `or#` ((n# `uncheckedShiftRL#` 6#) `and#` 0x3F##)) s1# - s3# = writeWord8Array# mba# (i# +# 2#) (0x80## `or#` (n# `and#` 0x3F##)) s2# + let s1# = writeWord8'# mba# i# (0xE0## `or#` (n# `uncheckedShiftRL#` 12#)) s# + s2# = writeWord8'# mba# (i# +# 1#) (0x80## `or#` ((n# `uncheckedShiftRL#` 6#) `and#` 0x3F##)) s1# + s3# = writeWord8'# mba# (i# +# 2#) (0x80## `or#` (n# `and#` 0x3F##)) s2# in (# s3#, i# +# 3# #) | otherwise -> \ s# -> - let s1# = writeWord8Array# mba# i# (0xF0## `or#` (n# `uncheckedShiftRL#` 18#)) s# - s2# = writeWord8Array# mba# (i# +# 1#) (0x80## `or#` ((n# `uncheckedShiftRL#` 12#) `and#` 0x3F##)) s1# - s3# = writeWord8Array# mba# (i# +# 2#) (0x80## `or#` ((n# `uncheckedShiftRL#` 6#) `and#` 0x3F##)) s2# - s4# = writeWord8Array# mba# (i# +# 3#) (0x80## `or#` (n# `and#` 0x3F##)) s3# + let s1# = writeWord8'# mba# i# (0xF0## `or#` (n# `uncheckedShiftRL#` 18#)) s# + s2# = writeWord8'# mba# (i# +# 1#) (0x80## `or#` ((n# `uncheckedShiftRL#` 12#) `and#` 0x3F##)) s1# + s3# = writeWord8'# mba# (i# +# 2#) (0x80## `or#` ((n# `uncheckedShiftRL#` 6#) `and#` 0x3F##)) s2# + s4# = writeWord8'# mba# (i# +# 3#) (0x80## `or#` (n# `and#` 0x3F##)) s3# in (# s4#, i# +# 4# #) -------------------------------------------------------------------------------- @@ -148,11 +152,11 @@ {-# NOINLINE decodeChar# #-} -- This branchy code make GHC impossible to fuse, DON'T inline decodeChar# ba# idx# = case indexWord8Array# ba# idx# of w1# - | isTrue# (w1# `leWord#` 0x7F##) -> (# chr1# w1#, 1# #) - | isTrue# (w1# `leWord#` 0xDF##) -> + | isTrue# (w1# `leWord8#` (wordToWord8# 0x7F##)) -> (# chr1# w1#, 1# #) + | isTrue# (w1# `leWord8#` (wordToWord8# 0xDF##)) -> let w2# = indexWord8Array# ba# (idx# +# 1#) in (# chr2# w1# w2#, 2# #) - | isTrue# (w1# `leWord#` 0xEF##) -> + | isTrue# (w1# `leWord8#` (wordToWord8# 0xEF##)) -> let w2# = indexWord8Array# ba# (idx# +# 1#) w3# = indexWord8Array# ba# (idx# +# 2#) in (# chr3# w1# w2# w3#, 3# #) @@ -181,9 +185,9 @@ {-# INLINE decodeCharLen# #-} decodeCharLen# ba# idx# = case indexWord8Array# ba# idx# of w1# - | isTrue# (w1# `leWord#` 0x7F##) -> 1# - | isTrue# (w1# `leWord#` 0xDF##) -> 2# - | isTrue# (w1# `leWord#` 0xEF##) -> 3# + | isTrue# (w1# `leWord8#` (wordToWord8# 0x7F##)) -> 1# + | isTrue# (w1# `leWord8#` (wordToWord8# 0xDF##)) -> 2# + | isTrue# (w1# `leWord8#` (wordToWord8# 0xEF##)) -> 3# | otherwise -> 4# -- | Decode a 'Char' from bytes in rerverse order. @@ -256,48 +260,44 @@ -------------------------------------------------------------------------------- -between# :: Word# -> Word# -> Word# -> Bool -{-# INLINE between# #-} -between# w# l# h# = isTrue# (w# `geWord#` l#) && isTrue# (w# `leWord#` h#) - -isContinueByte# :: Word# -> Bool +isContinueByte# :: Word8# -> Bool {-# INLINE isContinueByte# #-} -isContinueByte# w# = isTrue# (and# w# 0xC0## `eqWord#` 0x80##) +isContinueByte# w# = isTrue# (and# (word8ToWord# w#) 0xC0## `eqWord#` 0x80##) -chr1# :: Word# -> Char# +chr1# :: Word8# -> Char# {-# INLINE chr1# #-} chr1# x1# = chr# y1# where - !y1# = word2Int# x1# + !y1# = word2Int# (word8ToWord# x1#) -chr2# :: Word# -> Word# -> Char# +chr2# :: Word8# -> Word8# -> Char# {-# INLINE chr2# #-} chr2# x1# x2# = chr# (z1# +# z2#) where - !y1# = word2Int# x1# - !y2# = word2Int# x2# + !y1# = word2Int# (word8ToWord# x1#) + !y2# = word2Int# (word8ToWord# x2#) !z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6# !z2# = y2# -# 0x80# -chr3# :: Word# -> Word# -> Word# -> Char# +chr3# :: Word8# -> Word8# -> Word8# -> Char# {-# INLINE chr3# #-} chr3# x1# x2# x3# = chr# (z1# +# z2# +# z3#) where - !y1# = word2Int# x1# - !y2# = word2Int# x2# - !y3# = word2Int# x3# + !y1# = word2Int# (word8ToWord# x1#) + !y2# = word2Int# (word8ToWord# x2#) + !y3# = word2Int# (word8ToWord# x3#) !z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12# !z2# = uncheckedIShiftL# (y2# -# 0x80#) 6# !z3# = y3# -# 0x80# -chr4# :: Word# -> Word# -> Word# -> Word# -> Char# +chr4# :: Word8# -> Word8# -> Word8# -> Word8# -> Char# {-# INLINE chr4# #-} chr4# x1# x2# x3# x4# = chr# (z1# +# z2# +# z3# +# z4#) where - !y1# = word2Int# x1# - !y2# = word2Int# x2# - !y3# = word2Int# x3# - !y4# = word2Int# x4# + !y1# = word2Int# (word8ToWord# x1#) + !y2# = word2Int# (word8ToWord# x2#) + !y3# = word2Int# (word8ToWord# x3#) + !y4# = word2Int# (word8ToWord# x4#) !z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18# !z2# = uncheckedIShiftL# (y2# -# 0x80#) 12# !z3# = uncheckedIShiftL# (y3# -# 0x80#) 6# diff --git a/Z/Data/Vector.hs b/Z/Data/Vector.hs --- a/Z/Data/Vector.hs +++ b/Z/Data/Vector.hs @@ -80,11 +80,13 @@ , null , length , append - , map, map', imap', traverseVec, traverseWithIndex, traverseVec_, traverseWithIndex_ + , map, map', imap', traverse, traverseWithIndex, traverse_, traverseWithIndex_ + , mapM, mapM_, forM, forM_ , foldl', ifoldl', foldl1', foldl1Maybe' , foldr', ifoldr', foldr1', foldr1Maybe' + , shuffle, permutations -- ** Special folds - , concat, concatMap + , concat, concatR, concatMap , maximum, minimum, maximumMaybe, minimumMaybe , sum , count @@ -96,7 +98,7 @@ , mapAccumR -- ** Generating and unfolding vector , replicate - , replicateMVec + , replicateM , cycleN , unfoldr , unfoldrN 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 @@ -40,11 +40,13 @@ , null , length , append - , map, map', imap', traverseVec, traverseWithIndex, traverseVec_, traverseWithIndex_ + , map, map', imap', traverse, traverseWithIndex, traverse_, traverseWithIndex_ + , mapM, mapM_, forM, forM_ , foldl', ifoldl', foldl1', foldl1Maybe' , foldr', ifoldr', foldr1', foldr1Maybe' + , shuffle, permutations -- ** Special folds - , concat, concatMap + , concat, concatR, concatMap , maximum, minimum, maximumMaybe, minimumMaybe , sum , count, countBytes @@ -56,7 +58,7 @@ , mapAccumR -- ** Generating and unfolding vector , replicate - , replicateMVec + , replicateM , cycleN , unfoldr , unfoldrN @@ -72,6 +74,8 @@ , errorEmptyVector , errorOutRange , castVector + , replicatePM + , traverseWithIndexPM -- * C FFI , c_strcmp , c_memchr @@ -84,40 +88,40 @@ import Control.DeepSeq import Control.Exception -import Control.Monad -import Control.Monad.ST +import qualified Control.Monad as M import Control.Monad.Primitive +import Control.Monad.ST import Data.Bits -import Data.Char (ord) -import qualified Data.Foldable as F -import Data.Kind (Type) -import Data.Hashable (Hashable(..)) -import Data.Hashable.Lifted (Hashable1(..), hashWithSalt1) -import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.CaseInsensitive as CI +import Data.Char (ord) +import qualified Data.Foldable as F +import Data.Functor.Classes (Eq1 (..)) +import Data.Hashable (Hashable (..)) +import Data.Hashable.Lifted (Hashable1 (..), hashWithSalt1) +import Data.Kind (Type) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty ((:|))) 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 Data.Primitive hiding (copyPtrToMutablePrimArray) +import Data.Semigroup (Semigroup (..)) +import qualified Data.Traversable as T import Foreign.C import GHC.Exts import GHC.Stack -import GHC.CString import GHC.Word -import Prelude hiding (concat, concatMap, - elem, notElem, null, length, map, - foldl, foldl1, foldr, foldr1, - maximum, minimum, product, sum, - all, any, replicate, traverse) -import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) -import Test.QuickCheck.Gen (chooseInt) -import Text.Read (Read(..)) -import System.IO.Unsafe (unsafeDupablePerformIO) +import Prelude hiding (all, any, concat, concatMap, + elem, foldl, foldl1, foldr, foldr1, + length, map, mapM, mapM_, maximum, + minimum, notElem, null, product, + replicate, sum, traverse) +import System.IO.Unsafe (unsafeDupablePerformIO) +import System.Random.Stateful (StatefulGen) +import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..)) +import Test.QuickCheck.Gen (chooseInt) +import Text.Read (Read (..)) import Z.Data.Array -import Z.Data.ASCII (toLower) +import Z.Data.ASCII (toLower) -- | Typeclass for box and unboxed vectors, which are created by slicing arrays. -- @@ -137,7 +141,7 @@ -- | Create a vector by slicing an array(with offset and length). fromArr :: IArray v a -> Int -> Int -> v a --- | Change vector types based on same array type, e.g. construct an array from a slice, or vice-versa. +-- | Change vector types based on same array type, e.g. construct a whole slice from an array. arrVec :: (Vec v a, Vec u a, IArray v ~ IArray u) => v a -> u a {-# INLINE arrVec #-} arrVec bs = let (arr, s, l) = toArr bs in fromArr arr s l @@ -217,13 +221,17 @@ fromListN = packN instance Eq a => Eq (Vector a) where - {-# INLINABLE (==) #-} - v1 == v2 = eqVector v1 v2 + {-# INLINE (==) #-} + v1 == v2 = eqVector (==) v1 v2 -eqVector :: Eq a => Vector a -> Vector a -> Bool +instance Eq1 Vector where + {-# INLINE liftEq #-} + liftEq = eqVector + +eqVector :: (a -> b -> Bool) -> Vector a -> Vector b -> Bool {-# INLINE eqVector #-} -eqVector (Vector baA sA lA) (Vector baB sB lB) - | baA `sameArr` baB = +eqVector eq (Vector baA sA lA) (Vector baB sB lB) + | baA `sameArr'` baB = if sA == sB then lA == lB else lA == lB && go sA sB | otherwise = lA == lB && go sA sB where @@ -231,10 +239,14 @@ go !i !j | i >= endA = True | otherwise = - (indexSmallArray baA i == indexSmallArray baB j) && go (i+1) (j+1) + (indexSmallArray baA i `eq` indexSmallArray baB j) && go (i+1) (j+1) + -- The same implementation as 'sameArr' but with different type signature + -- sameArr' :: arr a -> arr b -> Bool + sameArr' (SmallArray arr1#) (SmallArray arr2#) = isTrue# ( + sameSmallMutableArray# (unsafeCoerce# arr1#) (unsafeCoerce# arr2#)) instance Ord a => Ord (Vector a) where - {-# INLINABLE compare #-} + {-# INLINE compare #-} compare = compareVector compareVector :: Ord a => Vector a -> Vector a -> Ordering @@ -263,7 +275,7 @@ {-# INLINE mempty #-} mempty = empty {-# INLINE mappend #-} - mappend = append + mappend = (<>) {-# INLINE mconcat #-} mconcat = concat @@ -313,7 +325,7 @@ instance T.Traversable Vector where {-# INLINE traverse #-} - traverse = traverseVec + traverse = traverse instance Arbitrary a => Arbitrary (Vector a) where arbitrary = do @@ -344,38 +356,50 @@ -- -- There're rules to optimize the intermedia list away when @f@ is an instance of 'PrimMoand', -- such as 'IO', 'ST' or 'Z.Data.Parser.Parser'. -traverseVec :: (Vec v a, Vec u b, Applicative f) => (a -> f b) -> v a -> f (u b) -{-# INLINE [1] traverseVec #-} -{-# RULES "traverseVec/PrimMonad" forall (f :: PrimMonad m => a -> m b). traverseVec f = traverseWithIndexPM (const f) #-} -traverseVec f v = packN (length v) <$> T.traverse f (unpack v) +traverse :: (Vec v a, Vec u b, Applicative f) => (a -> f b) -> v a -> f (u b) +{-# INLINE [1] traverse #-} +{-# RULES "traverse/IO" forall (f :: a -> IO b). traverse f = traverseWithIndexPM (const f) #-} +{-# RULES "traverse/ST" forall (f :: a -> ST s b). traverse f = traverseWithIndexPM (const f) #-} +traverse f v = packN (length v) <$> T.traverse f (unpack v) -- | Traverse vector and gather result in another vector. traverseWithIndex :: (Vec v a, Vec u b, Applicative f) => (Int -> a -> f b) -> v a -> f (u b) {-# INLINE [1] traverseWithIndex #-} -{-# RULES "traverseWithIndex/PrimMonad" forall (f :: PrimMonad m => Int -> a -> m b). traverseWithIndex f = traverseWithIndexPM f #-} -traverseWithIndex f v = packN (length v) <$> zipWithM f [0..] (unpack v) +{-# 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) <$> 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. -traverseVec_ :: (Vec v a, Applicative f) => (a -> f b) -> v a -> f () -{-# INLINE traverseVec_ #-} -traverseVec_ f (Vec arr s l) = go s +traverse_ :: (Vec v a, Applicative f) => (a -> f b) -> v a -> f () +{-# INLINE traverse_ #-} +traverse_ f (Vec arr s l) = go s where end = s + l go !i @@ -392,6 +416,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 -- @@ -453,7 +498,7 @@ let !(I# n#) = min lA lB r = I# (compareByteArrays# baA# sA# baB# sB# n#) in case r `compare` 0 of - EQ -> lA `compare` lB + EQ -> lA `compare` lB x -> x instance Prim a => Semigroup (PrimVector a) where @@ -468,7 +513,7 @@ {-# INLINE mempty #-} mempty = empty {-# INLINE mappend #-} - mappend = append + mappend = (<>) {-# INLINE mconcat #-} mconcat = concat @@ -572,8 +617,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 @@ -588,8 +632,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' @@ -606,8 +649,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 @@ -624,8 +666,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' @@ -685,6 +726,7 @@ -- | /O(1)/. The empty vector. -- empty :: Vec v a => v a +{-# NOINLINE empty #-} empty = Vec emptyArr 0 0 -- | /O(1)/. Single element vector. @@ -720,7 +762,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) @@ -729,34 +771,40 @@ -- Keep an eye on its core! go :: IPair (MArr (IArray v) s a) -> a -> ST s (IPair (MArr (IArray v) s a)) go (IPair i marr) !x = do - n <- sizeofMutableArr marr - if i < n - then do writeArr marr i x - return (IPair (i+1) marr) - else do let !n' = n `unsafeShiftL` 1 - !marr' <- resizeMutableArr marr n' - writeArr marr' i x - return (IPair (i+1) marr') + let i' = i+1 + marr' <- doubleMutableArr marr i' + writeArr marr' i x + return (IPair i' marr') -- | A version of 'replicateM' which works on 'Vec', with specialized rules under 'PrimMonad'. -- -- There're rules to optimize the intermedia list away when m is an instance of 'PrimMoand', -- such as 'IO', 'ST' or 'Z.Data.Parser.Parser'. -replicateMVec :: (Applicative f, Vec v a) => Int -> f a -> f (v a) -{-# INLINE [1] replicateMVec #-} -{-# RULES "replicateMVec/PrimMonad" forall n (x :: IO a). replicateMVec n x = replicatePMVec n x #-} -replicateMVec n f = packN n <$> replicateM n f +replicateM :: (Applicative f, Vec v a) => Int -> f a -> f (v a) +{-# INLINE [1] replicateM #-} +{-# RULES "replicateM/IO" forall n (x :: IO a). replicateM n x = replicatePM n x #-} +{-# 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'. -replicatePMVec :: (PrimMonad m, Vec v a) => Int -> m a -> m (v a) -{-# INLINE replicatePMVec #-} -replicatePMVec n f = do - marr <- newArr n +-- | '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 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 @@ -772,7 +820,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) @@ -800,7 +848,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 @@ -828,7 +876,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 @@ -968,6 +1016,20 @@ go (i+1) marr | otherwise = return () +-- | Shuffle a vector using algorithm. +shuffle :: (StatefulGen g m, PrimMonad m, Vec v a) => g -> v a -> m (v a) +{-# INLINE shuffle #-} +shuffle g (Vec arr s l) = do + marr <- thawArr arr s l + shuffleMutableArr g marr 0 l + arr' <- unsafeFreezeArr marr + pure $! fromArr arr' 0 l + +-- | Generate all permutation of a vector. +permutations :: forall v a. (Vec v a) => v a -> [v a] +{-# INLINE permutations #-} +permutations v = packN (length v) <$> List.permutations (unpack v) + -------------------------------------------------------------------------------- -- -- Strict folds @@ -1064,25 +1126,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 #-} @@ -1410,6 +1490,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 @@ -74,7 +74,7 @@ instance Monoid.Monoid (FlatIntMap v) where {-# INLINE mappend #-} - mappend = merge + mappend = (<>) {-# INLINE mempty #-} mempty = empty @@ -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 @@ -60,7 +60,7 @@ instance Monoid.Monoid FlatIntSet where {-# INLINE mappend #-} - mappend = merge + mappend = (<>) {-# INLINE mempty #-} mempty = empty @@ -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 @@ -74,7 +74,7 @@ instance Ord k => Monoid.Monoid (FlatMap k v) where {-# INLINE mappend #-} - mappend = merge + mappend = (<>) {-# INLINE mempty #-} mempty = empty @@ -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 @@ -60,7 +60,7 @@ instance Ord v => Monoid.Monoid (FlatSet v) where {-# INLINE mappend #-} - mappend = merge + mappend = (<>) {-# INLINE mempty #-} mempty = empty @@ -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 @@ -88,7 +88,6 @@ return $! fromArr w 0 l) where firstPass :: forall s. v a -> Int -> MArr (IArray v) s a -> ST s () - {-# INLINABLE firstPass #-} firstPass !v !i !marr | i >= l = return () | otherwise = do @@ -97,7 +96,6 @@ firstPass rest (i+mergeTileSize) marr mergePass :: forall s. MArr (IArray v) s a -> MArr (IArray v) s a -> Int -> ST s (IArray v a) - {-# INLINABLE mergePass #-} mergePass !w1 !w2 !blockSiz | blockSiz >= l = unsafeFreezeArr w1 | otherwise = do @@ -105,7 +103,6 @@ mergePass w2 w1 (blockSiz*2) -- swap worker array and continue merging mergeLoop :: forall s. MArr (IArray v) s a -> MArr (IArray v) s a -> Int -> Int -> ST s () - {-# INLINABLE mergeLoop #-} mergeLoop !src !target !blockSiz !i | i >= l-blockSiz = -- remaining elements less than a block if i >= l @@ -117,7 +114,6 @@ mergeLoop src target blockSiz mergeEnd mergeBlock :: forall s. MArr (IArray v) s a -> MArr (IArray v) s a -> Int -> Int -> Int -> Int -> Int -> ST s () - {-# INLINABLE mergeBlock #-} mergeBlock !src !target !leftEnd !rightEnd !i !j !k = do lv <- readArr src i rv <- readArr src j @@ -139,7 +135,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,7 +144,7 @@ -- 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 @@ -171,7 +167,7 @@ | otherwise = case indexArr' arr i of (# x #) -> do insert x (i+doff) go (i+1) - insert !temp !i + insert temp !i | i <= moff = do writeArr marr moff temp | otherwise = do @@ -307,7 +303,6 @@ buktSiz = bucketSize (undefined :: a) !end = s + l - {-# INLINABLE firstCountPass #-} firstCountPass :: forall s. IArray v a -> MutablePrimArray s Int -> Int -> ST s () firstCountPass !arr' !bucket !i | i >= end = return () @@ -318,7 +313,6 @@ writeArr bucket r (c+1) firstCountPass arr' bucket (i+1) - {-# INLINABLE accumBucket #-} accumBucket :: forall s. MutablePrimArray s Int -> Int -> Int -> Int -> ST s () accumBucket !bucket !bsiz !i !acc | i >= bsiz = return () @@ -327,7 +321,6 @@ writeArr bucket i acc accumBucket bucket bsiz (i+1) (acc+c) - {-# INLINABLE firstMovePass #-} firstMovePass :: forall s. IArray v a -> Int -> MutablePrimArray s Int -> MArr (IArray v) s a -> ST s () firstMovePass !arr' !i !bucket !w | i >= end = return () @@ -339,7 +332,6 @@ writeArr w c x firstMovePass arr' (i+1) bucket w - {-# INLINABLE radixLoop #-} radixLoop :: forall s. MArr (IArray v) s a -> MArr (IArray v) s a -> MutablePrimArray s Int -> Int -> Int -> ST s ((IArray v) a) radixLoop !w1 !w2 !bucket !bsiz !pass | pass >= passSiz-1 = do @@ -355,7 +347,6 @@ movePass w1 bucket pass w2 0 radixLoop w2 w1 bucket bsiz (pass+1) - {-# INLINABLE countPass #-} countPass :: forall s. MArr (IArray v) s a -> MutablePrimArray s Int -> Int -> Int -> ST s () countPass !marr !bucket !pass !i | i >= l = return () @@ -366,7 +357,6 @@ writeArr bucket r (c+1) countPass marr bucket pass (i+1) - {-# INLINABLE movePass #-} movePass :: forall s. MArr (IArray v) s a -> MutablePrimArray s Int -> Int -> MArr (IArray v) s a -> Int -> ST s () movePass !src !bucket !pass !target !i | i >= l = return () @@ -378,7 +368,6 @@ writeArr target c x movePass src bucket pass target (i+1) - {-# INLINABLE lastCountPass #-} lastCountPass :: forall s. MArr (IArray v) s a -> MutablePrimArray s Int -> Int -> ST s () lastCountPass !marr !bucket !i | i >= l = return () @@ -389,7 +378,6 @@ writeArr bucket r (c+1) lastCountPass marr bucket (i+1) - {-# INLINABLE lastMovePass #-} lastMovePass :: forall s. MArr (IArray v) s a -> MutablePrimArray s Int -> MArr (IArray v) s a -> Int -> ST s () lastMovePass !src !bucket !target !i | i >= l = return () @@ -457,7 +445,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 +454,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 @@ -76,7 +76,7 @@ , pinPrimArray , pinPrimVector -- ** Pointer helpers - , BA#, MBA#, BAArray# + , BA# (..), MBA# (..), BAArray# (..) , clearMBA , clearPtr , castPtr @@ -93,32 +93,41 @@ , 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 , hs_delete_std_string ) where -import Control.Exception (bracket) +import Control.Exception (bracket) import Control.Monad import Control.Monad.Primitive -import Data.Primitive -import Data.Word -import qualified Data.List as List -import Data.Primitive.Ptr +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Short.Internal (ShortByteString (..), + fromShort, toShort) +import qualified Data.ByteString.Unsafe as B +import qualified Data.List as List import Data.Primitive.ByteArray +import Data.Primitive.Types +#if !MIN_VERSION_primitive(0, 9, 0) import Data.Primitive.PrimArray +#else +import Data.Primitive.PrimArray hiding + (withMutablePrimArrayContents, + withPrimArrayContents) +#endif +import Data.Primitive.Ptr +import Data.Word import Foreign.C.Types -import GHC.Ptr import GHC.Exts -import Z.Data.Array +import GHC.Ptr +import Z.Data.Array.Base (withMutablePrimArrayContents, + withPrimArrayContents) import Z.Data.Array.Unaligned import Z.Data.Array.UnliftedArray import Z.Data.Vector.Base -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Unsafe as B -import Data.ByteString.Short.Internal (ShortByteString(..), fromShort, toShort) -- | Type alias for 'ByteArray#'. -- @@ -133,6 +142,8 @@ -- -- USE THIS TYPE WITH UNSAFE FFI CALL ONLY. A 'ByteArray#' COULD BE MOVED BY GC DURING SAFE FFI CALL. type BA# a = ByteArray# +pattern BA# :: ByteArray# -> BA# a +pattern BA# ba = ba -- | Type alias for 'MutableByteArray#' 'RealWorld'. -- @@ -144,6 +155,8 @@ -- -- USE THIS TYPE WITH UNSAFE FFI CALL ONLY. A 'MutableByteArray#' COULD BE MOVED BY GC DURING SAFE FFI CALL. type MBA# a = MutableByteArray# RealWorld +pattern MBA# :: MutableByteArray# RealWorld -> MBA# a +pattern MBA# mba = mba -- | Type alias for 'ArrayArray#'. -- @@ -176,16 +189,17 @@ -- -- by the type system in this example since ArrayArray is untyped. -- foreign import ccall unsafe "sum_first" sumFirst :: BAArray# Int -> Int -> IO CInt -- @ --- type BAArray# a = ArrayArray# +pattern BAArray# :: ArrayArray# -> BAArray# a +pattern BAArray# baa = baa -- | Clear 'MBA#' with given length to zero. clearMBA :: MBA# a -> Int -- ^ in bytes -> IO () -clearMBA mba# len = do - let mba = (MutableByteArray mba#) - setByteArray mba 0 len (0 :: Word8) +{-# INLINE clearMBA #-} +clearMBA (MBA# mba#) len = + setByteArray (MutableByteArray mba#) 0 len (0 :: Word8) -- | Pass primitive array to unsafe FFI as pointer. -- @@ -197,7 +211,7 @@ -- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY. withPrimArrayUnsafe :: (Prim a) => PrimArray a -> (BA# a -> Int -> IO b) -> IO b {-# INLINE withPrimArrayUnsafe #-} -withPrimArrayUnsafe pa@(PrimArray ba#) f = f ba# (sizeofPrimArray pa) +withPrimArrayUnsafe pa@(PrimArray ba#) f = f (BA# ba#) (sizeofPrimArray pa) -- | Pass primitive array list to unsafe FFI as @StgArrBytes**@. -- @@ -209,12 +223,13 @@ -- -- 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 foldM_ (\ !i pa -> writeUnliftedArray mla i pa >> return (i+1)) 0 pas (UnliftedArray la#) <- unsafeFreezeUnliftedArray mla - f la# l + f (BAArray# la#) l -- | Allocate some bytes and pass to FFI as pointer, freeze result into a 'PrimArray'. -- @@ -223,7 +238,7 @@ {-# INLINE allocPrimArrayUnsafe #-} allocPrimArrayUnsafe len f = do (mpa@(MutablePrimArray mba#) :: MutablePrimArray RealWorld a) <- newPrimArray len - !r <- f mba# + !r <- f (MBA# mba#) !pa <- unsafeFreezePrimArray mpa return (pa, r) @@ -249,7 +264,7 @@ {-# INLINE allocPrimVectorUnsafe #-} allocPrimVectorUnsafe len f = do (mpa@(MutablePrimArray mba#) :: MutablePrimArray RealWorld a) <- newPrimArray len - !r <- f mba# + !r <- f (MBA# mba#) !pa <- unsafeFreezePrimArray mpa let !v = PrimVector pa 0 len return (v, r) @@ -258,11 +273,10 @@ -- -- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY. allocBytesUnsafe :: Int -- ^ number of bytes - -> (MBA# a -> IO b) -> IO (Bytes, b) + -> (MBA# Word8 -> IO b) -> IO (Bytes, b) {-# INLINE allocBytesUnsafe #-} allocBytesUnsafe = allocPrimVectorUnsafe - -- | Create an one element primitive array and use it as a pointer to the primitive element. -- -- Return the element and the computation result. @@ -275,7 +289,7 @@ withPrimUnsafe v f = do mpa@(MutablePrimArray mba#) <- newPrimArray 1 -- All heap objects are WORD aligned writePrimArray mpa 0 v - !b <- f mba# -- so no need to do extra alignment + !b <- f (MBA# mba#) -- so no need to do extra alignment !a <- readPrimArray mpa 0 return (a, b) @@ -286,7 +300,7 @@ {-# INLINE allocPrimUnsafe #-} allocPrimUnsafe f = do mpa@(MutablePrimArray mba#) <- newPrimArray 1 -- All heap objects are WORD aligned - !b <- f mba# -- so no need to do extra alignment + !b <- f (MBA# mba#) -- so no need to do extra alignment !a <- readPrimArray mpa 0 return (a, b) @@ -301,7 +315,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 +354,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 +368,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 +384,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 +394,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 +405,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 +416,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 +433,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 +452,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 +461,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 +474,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 +487,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 +500,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 +513,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 @@ -21,15 +21,19 @@ , FunPtr ) where -import Control.Monad -import Control.Monad.Primitive -import Data.Primitive.PrimArray -import qualified Z.Data.Text as T -import GHC.Ptr -import GHC.Exts -import GHC.IO -import Z.Data.Array -import Z.Foreign +import Control.Monad +import Control.Monad.Primitive +#if !MIN_VERSION_primitive(0, 9, 0) +import Data.Primitive.PrimArray +#else +import Data.Primitive.PrimArray hiding (withMutablePrimArrayContents) +#endif +import GHC.Exts +import GHC.IO +import GHC.Ptr +import Z.Data.Array hiding (newPinnedPrimArray) +import qualified Z.Data.Text as T +import Z.Foreign -- | Lightweight foreign pointers. newtype CPtr a = CPtr (PrimArray (Ptr a)) @@ -118,18 +122,10 @@ -- so it may be optimized away, 'withCPtrForever' solves that. -- withCPtrForever :: CPtr a -> (Ptr a -> IO b) -> IO b -#if MIN_VERSION_base(4,15,0) {-# INLINABLE withCPtrForever #-} withCPtrForever (CPtr pa@(PrimArray ba#)) f = IO $ \ s -> case f (indexPrimArray pa 0) of IO action# -> keepAlive# ba# s action# -#else -{-# NOINLINE withCPtrForever #-} -withCPtrForever (CPtr pa@(PrimArray ba#)) f = do - r <- f (indexPrimArray pa 0) - primitive_ (touch# ba#) - return r -#endif -- | Pass a list of 'CPtr Foo' as @foo**@. USE THIS FUNCTION WITH UNSAFE FFI ONLY! withCPtrsUnsafe :: forall a b. [CPtr a] -> (BA# (Ptr a) -> Int -> IO b) -> IO b diff --git a/cbits/bytes.c b/cbits/bytes.c --- a/cbits/bytes.c +++ b/cbits/bytes.c @@ -3,6 +3,7 @@ Copyright Johan Tibell 2011, Dong Han 2019 Copyright Dmitry Ivanov 2020 Copyright Georg Rudoy 2021 +Copyright (c) 2017 Zach Bjornson (From https://github.com/zbjornson/fast-hex/) All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -199,7 +200,8 @@ "E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF" "F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF"; -void hs_hex_encode(char* output, HsInt output_off, const uint8_t* input, HsInt input_off, HsInt input_length){ +void hs_hex_encode_generic(uint8_t* output, size_t output_off, + const uint8_t* input, size_t input_off, size_t input_length){ uint16_t* output_ptr = (uint16_t*)(output+output_off); const uint8_t* input_ptr = input + input_off; uint16_t* table = (uint16_t*)BIN_TO_HEX; @@ -208,13 +210,90 @@ } } -void hs_hex_encode_upper(char* output, HsInt output_off, const uint8_t* input, HsInt input_off, HsInt input_length){ +void hs_hex_encode_upper_generic(uint8_t* output, size_t output_off, + const uint8_t* input, size_t input_off, size_t input_length){ uint16_t* output_ptr = (uint16_t*)(output+output_off); const uint8_t* input_ptr = input + input_off; uint16_t* table = (uint16_t*)BIN_TO_HEX_UPPER; for(size_t i = 0; i != input_length;) { *(output_ptr++) = table[input_ptr[i++]]; } +} + +#if defined(__AVX2__) +inline static __m256i hex(__m256i value) { + __m256i HEX_LUTR = _mm256_setr_epi8( + '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f', + '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'); + return _mm256_shuffle_epi8(HEX_LUTR, value); +} +inline static __m256i hex_upper(__m256i value) { + __m256i HEX_LUTR_UPPER = _mm256_setr_epi8( + '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F', + '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'); + return _mm256_shuffle_epi8(HEX_LUTR_UPPER, value); +} + +// a -> [a >> 4, a & 0b1111] +inline static __m256i byte2nib(__m128i val) { + __m256i ROT2 = _mm256_setr_epi8( + -1, 0, -1, 2, -1, 4, -1, 6, -1, 8, -1, 10, -1, 12, -1, 14, + -1, 0, -1, 2, -1, 4, -1, 6, -1, 8, -1, 10, -1, 12, -1, 14 + ); + __m256i doubled = _mm256_cvtepu8_epi16(val); + __m256i hi = _mm256_srli_epi16(doubled, 4); + __m256i lo = _mm256_shuffle_epi8(doubled, ROT2); + __m256i bytes = _mm256_or_si256(hi, lo); + bytes = _mm256_and_si256(bytes, _mm256_set1_epi8(0b1111)); + return bytes; +} + +// len is number of src bytes +void hs_hex_encode_avx2(uint8_t* __restrict__ dest, const uint8_t* __restrict__ src, size_t len) { + const __m128i* input128 = (const __m128i*)(src); + __m256i* output256 = (__m256i*)(dest); + + size_t tailLen = len % 16; + size_t vectLen = (len - tailLen) >> 4; + for (size_t i = 0; i < vectLen; i++) { + __m128i av = _mm_lddqu_si128(&input128[i]); + __m256i nibs = byte2nib(av); + __m256i hexed = hex(nibs); + _mm256_storeu_si256(&output256[i], hexed); + } + hs_hex_encode_generic(dest, (vectLen << 5), src, (vectLen << 4), tailLen); +} +// len is number of src bytes +void hs_hex_encode_upper_avx2(uint8_t* __restrict__ dest, const uint8_t* __restrict__ src, size_t len) { + const __m128i* input128 = (const __m128i*)(src); + __m256i* output256 = (__m256i*)(dest); + + size_t tailLen = len % 16; + size_t vectLen = (len - tailLen) >> 4; + for (size_t i = 0; i < vectLen; i++) { + __m128i av = _mm_lddqu_si128(&input128[i]); + __m256i nibs = byte2nib(av); + __m256i hexed = hex_upper(nibs); + _mm256_storeu_si256(&output256[i], hexed); + } + hs_hex_encode_upper_generic(dest, (vectLen << 5), src, (vectLen << 4), tailLen); +} +#endif + +void hs_hex_encode(uint8_t* output, HsInt output_off, const uint8_t* input, HsInt input_off, HsInt input_length){ +#if (__AVX2__) + hs_hex_encode_avx2(output+output_off, input+input_off, input_length); +#else + hs_hex_encode_generic(output, output_off, input, input_off, input_length); +#endif +} + +void hs_hex_encode_upper(uint8_t* output, HsInt output_off, const uint8_t* input, HsInt input_off, HsInt input_length){ +#if (__AVX2__) + hs_hex_encode_upper_avx2(output+output_off, input+input_off, input_length); +#else + hs_hex_encode_upper_generic(output, output_off, input, input_off, input_length); +#endif } /* diff --git a/cbits/compute_float_64.c b/cbits/compute_float_64.c new file mode 100644 --- /dev/null +++ b/cbits/compute_float_64.c @@ -0,0 +1,983 @@ +/* Modified from https://github.com/lemire/fast_double_parser/blob/master/include/fast_double_parser.h + +Copyright (c) Daniel Lemire + +Boost Software License - Version 1.0 - August 17th, 2003 + +Permission is hereby granted, free of charge, to any person or organization +obtaining a copy of the software and accompanying documentation covered by +this license (the "Software") to use, reproduce, display, distribute, +execute, and transmit the Software, and to prepare derivative works of the +Software, and to permit third-parties to whom the Software is furnished to +do so, all subject to the following: + +The copyright notices in the Software and this entire statement, including +the above license grant, this restriction and the following disclaimer, +must be included in all copies of the Software, in whole or in part, and +all derivative works of the Software, unless such copies or derivative +works are solely in the form of machine-executable object code generated by +a source language processor. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT +SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE +FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. +*/ + +#include +#include +#include + +/** + * The smallest non-zero float (binary64) is 2^−1074. + * We take as input numbers of the form w x 10^q where w < 2^64. + * We have that w * 10^-343 < 2^(64-344) 5^-343 < 2^-1076. + * However, we have that + * (2^64-1) * 10^-342 = (2^64-1) * 2^-342 * 5^-342 > 2^−1074. + * Thus it is possible for a number of the form w * 10^-342 where + * w is a 64-bit value to be a non-zero floating-point number. + ********* + * If we are solely interested in the *normal* numbers then the + * smallest value is 2^-1022. We can generate a value larger + * than 2^-1022 with expressions of the form w * 10^-326. + * Thus we need to pick FASTFLOAT_SMALLEST_POWER >= -326. + ********* + * Any number of form w * 10^309 where w>= 1 is going to be + * infinite in binary64 so we never need to worry about powers + * of 5 greater than 308. + */ +#define FASTFLOAT_SMALLEST_POWER -325 +#define FASTFLOAT_LARGEST_POWER 308 + +#ifndef unlikely +#define unlikely(x) __builtin_expect(!!(x), 0) +#endif // unlikely + +#ifndef really_inline +#define really_inline __attribute__((always_inline)) inline +#endif // really_inline + +// We need a backup on old systems. +// credit: https://stackoverflow.com/questions/28868367/getting-the-high-part-of-64-bit-integer-multiplication +really_inline uint64_t Emulate64x64to128(uint64_t r_hi, const uint64_t x, const uint64_t y) { + const uint64_t x0 = (uint32_t)x, x1 = x >> 32; + const uint64_t y0 = (uint32_t)y, y1 = y >> 32; + const uint64_t p11 = x1 * y1, p01 = x0 * y1; + const uint64_t p10 = x1 * y0, p00 = x0 * y0; + + // 64-bit product + two 32-bit values + const uint64_t middle = p10 + (p00 >> 32) + (uint32_t)p01; + + // 64-bit product + two 32-bit values + r_hi = p11 + (middle >> 32) + (p01 >> 32); + + // Add LOW PART and lower half of MIDDLE PART + return (middle << 32) | (uint32_t)p00; +} + +typedef struct value128_s { + uint64_t low; + uint64_t high; +} value128; + +really_inline value128 full_multiplication(uint64_t value1, uint64_t value2) { + value128 answer; +#ifdef __SIZEOF_INT128__ // this is what we have on most 32-bit systems + __uint128_t r = ((__uint128_t)value1) * value2; + answer.low = (uint64_t)r; + answer.high = (uint64_t)(r >> 64); +#else + // fallback + answer.low = Emulate64x64to128(answer.high, value1, value2); +#endif + return answer; +} + +/* result might be undefined when input_num is zero */ +inline int leading_zeroes(uint64_t input_num) { + return __builtin_clzll(input_num); +} + + +/** + * When mapping numbers from decimal to binary, + * we go from w * 10^q to m * 2^p but we have + * 10^q = 5^q * 2^q, so effectively + * we are trying to match + * w * 2^q * 5^q to m * 2^p. Thus the powers of two + * are not a concern since they can be represented + * exactly using the binary notation, only the powers of five + * affect the binary significand. + */ + +// Attempts to compute i * 10^(power) exactly; and if "negative" is +// true, negate the result. +// This function will only work in some cases, when it does not work, success is +// set to 0. This should work *most of the time* (like 99% of the time). +// We assume that power is in the [FASTFLOAT_SMALLEST_POWER, +// FASTFLOAT_LARGEST_POWER] interval: the caller is responsible for this check. +double compute_float_64(int64_t power, uint64_t i, uint8_t negative, + uint8_t *success) { + + // Precomputed powers of ten from 10^0 to 10^22. These + // can be represented exactly using the double type. + static const double power_of_ten[] = { + 1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9, 1e10, 1e11, + 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19, 1e20, 1e21, 1e22}; + + // The mantissas of powers of ten from -308 to 308, extended out to sixty four + // bits. The array contains the powers of ten approximated + // as a 64-bit mantissa. It goes from 10^FASTFLOAT_SMALLEST_POWER to + // 10^FASTFLOAT_LARGEST_POWER (inclusively). + // The mantissa is truncated, and + // never rounded up. Uses about 5KB. + static const uint64_t mantissa_64[] = { + 0xa5ced43b7e3e9188, 0xcf42894a5dce35ea, + 0x818995ce7aa0e1b2, 0xa1ebfb4219491a1f, + 0xca66fa129f9b60a6, 0xfd00b897478238d0, + 0x9e20735e8cb16382, 0xc5a890362fddbc62, + 0xf712b443bbd52b7b, 0x9a6bb0aa55653b2d, + 0xc1069cd4eabe89f8, 0xf148440a256e2c76, + 0x96cd2a865764dbca, 0xbc807527ed3e12bc, + 0xeba09271e88d976b, 0x93445b8731587ea3, + 0xb8157268fdae9e4c, 0xe61acf033d1a45df, + 0x8fd0c16206306bab, 0xb3c4f1ba87bc8696, + 0xe0b62e2929aba83c, 0x8c71dcd9ba0b4925, + 0xaf8e5410288e1b6f, 0xdb71e91432b1a24a, + 0x892731ac9faf056e, 0xab70fe17c79ac6ca, + 0xd64d3d9db981787d, 0x85f0468293f0eb4e, + 0xa76c582338ed2621, 0xd1476e2c07286faa, + 0x82cca4db847945ca, 0xa37fce126597973c, + 0xcc5fc196fefd7d0c, 0xff77b1fcbebcdc4f, + 0x9faacf3df73609b1, 0xc795830d75038c1d, + 0xf97ae3d0d2446f25, 0x9becce62836ac577, + 0xc2e801fb244576d5, 0xf3a20279ed56d48a, + 0x9845418c345644d6, 0xbe5691ef416bd60c, + 0xedec366b11c6cb8f, 0x94b3a202eb1c3f39, + 0xb9e08a83a5e34f07, 0xe858ad248f5c22c9, + 0x91376c36d99995be, 0xb58547448ffffb2d, + 0xe2e69915b3fff9f9, 0x8dd01fad907ffc3b, + 0xb1442798f49ffb4a, 0xdd95317f31c7fa1d, + 0x8a7d3eef7f1cfc52, 0xad1c8eab5ee43b66, + 0xd863b256369d4a40, 0x873e4f75e2224e68, + 0xa90de3535aaae202, 0xd3515c2831559a83, + 0x8412d9991ed58091, 0xa5178fff668ae0b6, + 0xce5d73ff402d98e3, 0x80fa687f881c7f8e, + 0xa139029f6a239f72, 0xc987434744ac874e, + 0xfbe9141915d7a922, 0x9d71ac8fada6c9b5, + 0xc4ce17b399107c22, 0xf6019da07f549b2b, + 0x99c102844f94e0fb, 0xc0314325637a1939, + 0xf03d93eebc589f88, 0x96267c7535b763b5, + 0xbbb01b9283253ca2, 0xea9c227723ee8bcb, + 0x92a1958a7675175f, 0xb749faed14125d36, + 0xe51c79a85916f484, 0x8f31cc0937ae58d2, + 0xb2fe3f0b8599ef07, 0xdfbdcece67006ac9, + 0x8bd6a141006042bd, 0xaecc49914078536d, + 0xda7f5bf590966848, 0x888f99797a5e012d, + 0xaab37fd7d8f58178, 0xd5605fcdcf32e1d6, + 0x855c3be0a17fcd26, 0xa6b34ad8c9dfc06f, + 0xd0601d8efc57b08b, 0x823c12795db6ce57, + 0xa2cb1717b52481ed, 0xcb7ddcdda26da268, + 0xfe5d54150b090b02, 0x9efa548d26e5a6e1, + 0xc6b8e9b0709f109a, 0xf867241c8cc6d4c0, + 0x9b407691d7fc44f8, 0xc21094364dfb5636, + 0xf294b943e17a2bc4, 0x979cf3ca6cec5b5a, + 0xbd8430bd08277231, 0xece53cec4a314ebd, + 0x940f4613ae5ed136, 0xb913179899f68584, + 0xe757dd7ec07426e5, 0x9096ea6f3848984f, + 0xb4bca50b065abe63, 0xe1ebce4dc7f16dfb, + 0x8d3360f09cf6e4bd, 0xb080392cc4349dec, + 0xdca04777f541c567, 0x89e42caaf9491b60, + 0xac5d37d5b79b6239, 0xd77485cb25823ac7, + 0x86a8d39ef77164bc, 0xa8530886b54dbdeb, + 0xd267caa862a12d66, 0x8380dea93da4bc60, + 0xa46116538d0deb78, 0xcd795be870516656, + 0x806bd9714632dff6, 0xa086cfcd97bf97f3, + 0xc8a883c0fdaf7df0, 0xfad2a4b13d1b5d6c, + 0x9cc3a6eec6311a63, 0xc3f490aa77bd60fc, + 0xf4f1b4d515acb93b, 0x991711052d8bf3c5, + 0xbf5cd54678eef0b6, 0xef340a98172aace4, + 0x9580869f0e7aac0e, 0xbae0a846d2195712, + 0xe998d258869facd7, 0x91ff83775423cc06, + 0xb67f6455292cbf08, 0xe41f3d6a7377eeca, + 0x8e938662882af53e, 0xb23867fb2a35b28d, + 0xdec681f9f4c31f31, 0x8b3c113c38f9f37e, + 0xae0b158b4738705e, 0xd98ddaee19068c76, + 0x87f8a8d4cfa417c9, 0xa9f6d30a038d1dbc, + 0xd47487cc8470652b, 0x84c8d4dfd2c63f3b, + 0xa5fb0a17c777cf09, 0xcf79cc9db955c2cc, + 0x81ac1fe293d599bf, 0xa21727db38cb002f, + 0xca9cf1d206fdc03b, 0xfd442e4688bd304a, + 0x9e4a9cec15763e2e, 0xc5dd44271ad3cdba, + 0xf7549530e188c128, 0x9a94dd3e8cf578b9, + 0xc13a148e3032d6e7, 0xf18899b1bc3f8ca1, + 0x96f5600f15a7b7e5, 0xbcb2b812db11a5de, + 0xebdf661791d60f56, 0x936b9fcebb25c995, + 0xb84687c269ef3bfb, 0xe65829b3046b0afa, + 0x8ff71a0fe2c2e6dc, 0xb3f4e093db73a093, + 0xe0f218b8d25088b8, 0x8c974f7383725573, + 0xafbd2350644eeacf, 0xdbac6c247d62a583, + 0x894bc396ce5da772, 0xab9eb47c81f5114f, + 0xd686619ba27255a2, 0x8613fd0145877585, + 0xa798fc4196e952e7, 0xd17f3b51fca3a7a0, + 0x82ef85133de648c4, 0xa3ab66580d5fdaf5, + 0xcc963fee10b7d1b3, 0xffbbcfe994e5c61f, + 0x9fd561f1fd0f9bd3, 0xc7caba6e7c5382c8, + 0xf9bd690a1b68637b, 0x9c1661a651213e2d, + 0xc31bfa0fe5698db8, 0xf3e2f893dec3f126, + 0x986ddb5c6b3a76b7, 0xbe89523386091465, + 0xee2ba6c0678b597f, 0x94db483840b717ef, + 0xba121a4650e4ddeb, 0xe896a0d7e51e1566, + 0x915e2486ef32cd60, 0xb5b5ada8aaff80b8, + 0xe3231912d5bf60e6, 0x8df5efabc5979c8f, + 0xb1736b96b6fd83b3, 0xddd0467c64bce4a0, + 0x8aa22c0dbef60ee4, 0xad4ab7112eb3929d, + 0xd89d64d57a607744, 0x87625f056c7c4a8b, + 0xa93af6c6c79b5d2d, 0xd389b47879823479, + 0x843610cb4bf160cb, 0xa54394fe1eedb8fe, + 0xce947a3da6a9273e, 0x811ccc668829b887, + 0xa163ff802a3426a8, 0xc9bcff6034c13052, + 0xfc2c3f3841f17c67, 0x9d9ba7832936edc0, + 0xc5029163f384a931, 0xf64335bcf065d37d, + 0x99ea0196163fa42e, 0xc06481fb9bcf8d39, + 0xf07da27a82c37088, 0x964e858c91ba2655, + 0xbbe226efb628afea, 0xeadab0aba3b2dbe5, + 0x92c8ae6b464fc96f, 0xb77ada0617e3bbcb, + 0xe55990879ddcaabd, 0x8f57fa54c2a9eab6, + 0xb32df8e9f3546564, 0xdff9772470297ebd, + 0x8bfbea76c619ef36, 0xaefae51477a06b03, + 0xdab99e59958885c4, 0x88b402f7fd75539b, + 0xaae103b5fcd2a881, 0xd59944a37c0752a2, + 0x857fcae62d8493a5, 0xa6dfbd9fb8e5b88e, + 0xd097ad07a71f26b2, 0x825ecc24c873782f, + 0xa2f67f2dfa90563b, 0xcbb41ef979346bca, + 0xfea126b7d78186bc, 0x9f24b832e6b0f436, + 0xc6ede63fa05d3143, 0xf8a95fcf88747d94, + 0x9b69dbe1b548ce7c, 0xc24452da229b021b, + 0xf2d56790ab41c2a2, 0x97c560ba6b0919a5, + 0xbdb6b8e905cb600f, 0xed246723473e3813, + 0x9436c0760c86e30b, 0xb94470938fa89bce, + 0xe7958cb87392c2c2, 0x90bd77f3483bb9b9, + 0xb4ecd5f01a4aa828, 0xe2280b6c20dd5232, + 0x8d590723948a535f, 0xb0af48ec79ace837, + 0xdcdb1b2798182244, 0x8a08f0f8bf0f156b, + 0xac8b2d36eed2dac5, 0xd7adf884aa879177, + 0x86ccbb52ea94baea, 0xa87fea27a539e9a5, + 0xd29fe4b18e88640e, 0x83a3eeeef9153e89, + 0xa48ceaaab75a8e2b, 0xcdb02555653131b6, + 0x808e17555f3ebf11, 0xa0b19d2ab70e6ed6, + 0xc8de047564d20a8b, 0xfb158592be068d2e, + 0x9ced737bb6c4183d, 0xc428d05aa4751e4c, + 0xf53304714d9265df, 0x993fe2c6d07b7fab, + 0xbf8fdb78849a5f96, 0xef73d256a5c0f77c, + 0x95a8637627989aad, 0xbb127c53b17ec159, + 0xe9d71b689dde71af, 0x9226712162ab070d, + 0xb6b00d69bb55c8d1, 0xe45c10c42a2b3b05, + 0x8eb98a7a9a5b04e3, 0xb267ed1940f1c61c, + 0xdf01e85f912e37a3, 0x8b61313bbabce2c6, + 0xae397d8aa96c1b77, 0xd9c7dced53c72255, + 0x881cea14545c7575, 0xaa242499697392d2, + 0xd4ad2dbfc3d07787, 0x84ec3c97da624ab4, + 0xa6274bbdd0fadd61, 0xcfb11ead453994ba, + 0x81ceb32c4b43fcf4, 0xa2425ff75e14fc31, + 0xcad2f7f5359a3b3e, 0xfd87b5f28300ca0d, + 0x9e74d1b791e07e48, 0xc612062576589dda, + 0xf79687aed3eec551, 0x9abe14cd44753b52, + 0xc16d9a0095928a27, 0xf1c90080baf72cb1, + 0x971da05074da7bee, 0xbce5086492111aea, + 0xec1e4a7db69561a5, 0x9392ee8e921d5d07, + 0xb877aa3236a4b449, 0xe69594bec44de15b, + 0x901d7cf73ab0acd9, 0xb424dc35095cd80f, + 0xe12e13424bb40e13, 0x8cbccc096f5088cb, + 0xafebff0bcb24aafe, 0xdbe6fecebdedd5be, + 0x89705f4136b4a597, 0xabcc77118461cefc, + 0xd6bf94d5e57a42bc, 0x8637bd05af6c69b5, + 0xa7c5ac471b478423, 0xd1b71758e219652b, + 0x83126e978d4fdf3b, 0xa3d70a3d70a3d70a, + 0xcccccccccccccccc, 0x8000000000000000, + 0xa000000000000000, 0xc800000000000000, + 0xfa00000000000000, 0x9c40000000000000, + 0xc350000000000000, 0xf424000000000000, + 0x9896800000000000, 0xbebc200000000000, + 0xee6b280000000000, 0x9502f90000000000, + 0xba43b74000000000, 0xe8d4a51000000000, + 0x9184e72a00000000, 0xb5e620f480000000, + 0xe35fa931a0000000, 0x8e1bc9bf04000000, + 0xb1a2bc2ec5000000, 0xde0b6b3a76400000, + 0x8ac7230489e80000, 0xad78ebc5ac620000, + 0xd8d726b7177a8000, 0x878678326eac9000, + 0xa968163f0a57b400, 0xd3c21bcecceda100, + 0x84595161401484a0, 0xa56fa5b99019a5c8, + 0xcecb8f27f4200f3a, 0x813f3978f8940984, + 0xa18f07d736b90be5, 0xc9f2c9cd04674ede, + 0xfc6f7c4045812296, 0x9dc5ada82b70b59d, + 0xc5371912364ce305, 0xf684df56c3e01bc6, + 0x9a130b963a6c115c, 0xc097ce7bc90715b3, + 0xf0bdc21abb48db20, 0x96769950b50d88f4, + 0xbc143fa4e250eb31, 0xeb194f8e1ae525fd, + 0x92efd1b8d0cf37be, 0xb7abc627050305ad, + 0xe596b7b0c643c719, 0x8f7e32ce7bea5c6f, + 0xb35dbf821ae4f38b, 0xe0352f62a19e306e, + 0x8c213d9da502de45, 0xaf298d050e4395d6, + 0xdaf3f04651d47b4c, 0x88d8762bf324cd0f, + 0xab0e93b6efee0053, 0xd5d238a4abe98068, + 0x85a36366eb71f041, 0xa70c3c40a64e6c51, + 0xd0cf4b50cfe20765, 0x82818f1281ed449f, + 0xa321f2d7226895c7, 0xcbea6f8ceb02bb39, + 0xfee50b7025c36a08, 0x9f4f2726179a2245, + 0xc722f0ef9d80aad6, 0xf8ebad2b84e0d58b, + 0x9b934c3b330c8577, 0xc2781f49ffcfa6d5, + 0xf316271c7fc3908a, 0x97edd871cfda3a56, + 0xbde94e8e43d0c8ec, 0xed63a231d4c4fb27, + 0x945e455f24fb1cf8, 0xb975d6b6ee39e436, + 0xe7d34c64a9c85d44, 0x90e40fbeea1d3a4a, + 0xb51d13aea4a488dd, 0xe264589a4dcdab14, + 0x8d7eb76070a08aec, 0xb0de65388cc8ada8, + 0xdd15fe86affad912, 0x8a2dbf142dfcc7ab, + 0xacb92ed9397bf996, 0xd7e77a8f87daf7fb, + 0x86f0ac99b4e8dafd, 0xa8acd7c0222311bc, + 0xd2d80db02aabd62b, 0x83c7088e1aab65db, + 0xa4b8cab1a1563f52, 0xcde6fd5e09abcf26, + 0x80b05e5ac60b6178, 0xa0dc75f1778e39d6, + 0xc913936dd571c84c, 0xfb5878494ace3a5f, + 0x9d174b2dcec0e47b, 0xc45d1df942711d9a, + 0xf5746577930d6500, 0x9968bf6abbe85f20, + 0xbfc2ef456ae276e8, 0xefb3ab16c59b14a2, + 0x95d04aee3b80ece5, 0xbb445da9ca61281f, + 0xea1575143cf97226, 0x924d692ca61be758, + 0xb6e0c377cfa2e12e, 0xe498f455c38b997a, + 0x8edf98b59a373fec, 0xb2977ee300c50fe7, + 0xdf3d5e9bc0f653e1, 0x8b865b215899f46c, + 0xae67f1e9aec07187, 0xda01ee641a708de9, + 0x884134fe908658b2, 0xaa51823e34a7eede, + 0xd4e5e2cdc1d1ea96, 0x850fadc09923329e, + 0xa6539930bf6bff45, 0xcfe87f7cef46ff16, + 0x81f14fae158c5f6e, 0xa26da3999aef7749, + 0xcb090c8001ab551c, 0xfdcb4fa002162a63, + 0x9e9f11c4014dda7e, 0xc646d63501a1511d, + 0xf7d88bc24209a565, 0x9ae757596946075f, + 0xc1a12d2fc3978937, 0xf209787bb47d6b84, + 0x9745eb4d50ce6332, 0xbd176620a501fbff, + 0xec5d3fa8ce427aff, 0x93ba47c980e98cdf, + 0xb8a8d9bbe123f017, 0xe6d3102ad96cec1d, + 0x9043ea1ac7e41392, 0xb454e4a179dd1877, + 0xe16a1dc9d8545e94, 0x8ce2529e2734bb1d, + 0xb01ae745b101e9e4, 0xdc21a1171d42645d, + 0x899504ae72497eba, 0xabfa45da0edbde69, + 0xd6f8d7509292d603, 0x865b86925b9bc5c2, + 0xa7f26836f282b732, 0xd1ef0244af2364ff, + 0x8335616aed761f1f, 0xa402b9c5a8d3a6e7, + 0xcd036837130890a1, 0x802221226be55a64, + 0xa02aa96b06deb0fd, 0xc83553c5c8965d3d, + 0xfa42a8b73abbf48c, 0x9c69a97284b578d7, + 0xc38413cf25e2d70d, 0xf46518c2ef5b8cd1, + 0x98bf2f79d5993802, 0xbeeefb584aff8603, + 0xeeaaba2e5dbf6784, 0x952ab45cfa97a0b2, + 0xba756174393d88df, 0xe912b9d1478ceb17, + 0x91abb422ccb812ee, 0xb616a12b7fe617aa, + 0xe39c49765fdf9d94, 0x8e41ade9fbebc27d, + 0xb1d219647ae6b31c, 0xde469fbd99a05fe3, + 0x8aec23d680043bee, 0xada72ccc20054ae9, + 0xd910f7ff28069da4, 0x87aa9aff79042286, + 0xa99541bf57452b28, 0xd3fa922f2d1675f2, + 0x847c9b5d7c2e09b7, 0xa59bc234db398c25, + 0xcf02b2c21207ef2e, 0x8161afb94b44f57d, + 0xa1ba1ba79e1632dc, 0xca28a291859bbf93, + 0xfcb2cb35e702af78, 0x9defbf01b061adab, + 0xc56baec21c7a1916, 0xf6c69a72a3989f5b, + 0x9a3c2087a63f6399, 0xc0cb28a98fcf3c7f, + 0xf0fdf2d3f3c30b9f, 0x969eb7c47859e743, + 0xbc4665b596706114, 0xeb57ff22fc0c7959, + 0x9316ff75dd87cbd8, 0xb7dcbf5354e9bece, + 0xe5d3ef282a242e81, 0x8fa475791a569d10, + 0xb38d92d760ec4455, 0xe070f78d3927556a, + 0x8c469ab843b89562, 0xaf58416654a6babb, + 0xdb2e51bfe9d0696a, 0x88fcf317f22241e2, + 0xab3c2fddeeaad25a, 0xd60b3bd56a5586f1, + 0x85c7056562757456, 0xa738c6bebb12d16c, + 0xd106f86e69d785c7, 0x82a45b450226b39c, + 0xa34d721642b06084, 0xcc20ce9bd35c78a5, + 0xff290242c83396ce, 0x9f79a169bd203e41, + 0xc75809c42c684dd1, 0xf92e0c3537826145, + 0x9bbcc7a142b17ccb, 0xc2abf989935ddbfe, + 0xf356f7ebf83552fe, 0x98165af37b2153de, + 0xbe1bf1b059e9a8d6, 0xeda2ee1c7064130c, + 0x9485d4d1c63e8be7, 0xb9a74a0637ce2ee1, + 0xe8111c87c5c1ba99, 0x910ab1d4db9914a0, + 0xb54d5e4a127f59c8, 0xe2a0b5dc971f303a, + 0x8da471a9de737e24, 0xb10d8e1456105dad, + 0xdd50f1996b947518, 0x8a5296ffe33cc92f, + 0xace73cbfdc0bfb7b, 0xd8210befd30efa5a, + 0x8714a775e3e95c78, 0xa8d9d1535ce3b396, + 0xd31045a8341ca07c, 0x83ea2b892091e44d, + 0xa4e4b66b68b65d60, 0xce1de40642e3f4b9, + 0x80d2ae83e9ce78f3, 0xa1075a24e4421730, + 0xc94930ae1d529cfc, 0xfb9b7cd9a4a7443c, + 0x9d412e0806e88aa5, 0xc491798a08a2ad4e, + 0xf5b5d7ec8acb58a2, 0x9991a6f3d6bf1765, + 0xbff610b0cc6edd3f, 0xeff394dcff8a948e, + 0x95f83d0a1fb69cd9, 0xbb764c4ca7a4440f, + 0xea53df5fd18d5513, 0x92746b9be2f8552c, + 0xb7118682dbb66a77, 0xe4d5e82392a40515, + 0x8f05b1163ba6832d, 0xb2c71d5bca9023f8, + 0xdf78e4b2bd342cf6, 0x8bab8eefb6409c1a, + 0xae9672aba3d0c320, 0xda3c0f568cc4f3e8, + 0x8865899617fb1871, 0xaa7eebfb9df9de8d, + 0xd51ea6fa85785631, 0x8533285c936b35de, + 0xa67ff273b8460356, 0xd01fef10a657842c, + 0x8213f56a67f6b29b, 0xa298f2c501f45f42, + 0xcb3f2f7642717713, 0xfe0efb53d30dd4d7, + 0x9ec95d1463e8a506, 0xc67bb4597ce2ce48, + 0xf81aa16fdc1b81da, 0x9b10a4e5e9913128, + 0xc1d4ce1f63f57d72, 0xf24a01a73cf2dccf, + 0x976e41088617ca01, 0xbd49d14aa79dbc82, + 0xec9c459d51852ba2, 0x93e1ab8252f33b45, + 0xb8da1662e7b00a17, 0xe7109bfba19c0c9d, + 0x906a617d450187e2, 0xb484f9dc9641e9da, + 0xe1a63853bbd26451, 0x8d07e33455637eb2, + 0xb049dc016abc5e5f, 0xdc5c5301c56b75f7, + 0x89b9b3e11b6329ba, 0xac2820d9623bf429, + 0xd732290fbacaf133, 0x867f59a9d4bed6c0, + 0xa81f301449ee8c70, 0xd226fc195c6a2f8c, + 0x83585d8fd9c25db7, 0xa42e74f3d032f525, + 0xcd3a1230c43fb26f, 0x80444b5e7aa7cf85, + 0xa0555e361951c366, 0xc86ab5c39fa63440, + 0xfa856334878fc150, 0x9c935e00d4b9d8d2, + 0xc3b8358109e84f07, 0xf4a642e14c6262c8, + 0x98e7e9cccfbd7dbd, 0xbf21e44003acdd2c, + 0xeeea5d5004981478, 0x95527a5202df0ccb, + 0xbaa718e68396cffd, 0xe950df20247c83fd, + 0x91d28b7416cdd27e, 0xb6472e511c81471d, + 0xe3d8f9e563a198e5, 0x8e679c2f5e44ff8f}; + // A complement to mantissa_64 + // complete to a 128-bit mantissa. + // Uses about 5KB but is rarely accessed. + static const uint64_t mantissa_128[] = { + 0x419ea3bd35385e2d, 0x52064cac828675b9, + 0x7343efebd1940993, 0x1014ebe6c5f90bf8, + 0xd41a26e077774ef6, 0x8920b098955522b4, + 0x55b46e5f5d5535b0, 0xeb2189f734aa831d, + 0xa5e9ec7501d523e4, 0x47b233c92125366e, + 0x999ec0bb696e840a, 0xc00670ea43ca250d, + 0x380406926a5e5728, 0xc605083704f5ecf2, + 0xf7864a44c633682e, 0x7ab3ee6afbe0211d, + 0x5960ea05bad82964, 0x6fb92487298e33bd, + 0xa5d3b6d479f8e056, 0x8f48a4899877186c, + 0x331acdabfe94de87, 0x9ff0c08b7f1d0b14, + 0x7ecf0ae5ee44dd9, 0xc9e82cd9f69d6150, + 0xbe311c083a225cd2, 0x6dbd630a48aaf406, + 0x92cbbccdad5b108, 0x25bbf56008c58ea5, + 0xaf2af2b80af6f24e, 0x1af5af660db4aee1, + 0x50d98d9fc890ed4d, 0xe50ff107bab528a0, + 0x1e53ed49a96272c8, 0x25e8e89c13bb0f7a, + 0x77b191618c54e9ac, 0xd59df5b9ef6a2417, + 0x4b0573286b44ad1d, 0x4ee367f9430aec32, + 0x229c41f793cda73f, 0x6b43527578c1110f, + 0x830a13896b78aaa9, 0x23cc986bc656d553, + 0x2cbfbe86b7ec8aa8, 0x7bf7d71432f3d6a9, + 0xdaf5ccd93fb0cc53, 0xd1b3400f8f9cff68, + 0x23100809b9c21fa1, 0xabd40a0c2832a78a, + 0x16c90c8f323f516c, 0xae3da7d97f6792e3, + 0x99cd11cfdf41779c, 0x40405643d711d583, + 0x482835ea666b2572, 0xda3243650005eecf, + 0x90bed43e40076a82, 0x5a7744a6e804a291, + 0x711515d0a205cb36, 0xd5a5b44ca873e03, + 0xe858790afe9486c2, 0x626e974dbe39a872, + 0xfb0a3d212dc8128f, 0x7ce66634bc9d0b99, + 0x1c1fffc1ebc44e80, 0xa327ffb266b56220, + 0x4bf1ff9f0062baa8, 0x6f773fc3603db4a9, + 0xcb550fb4384d21d3, 0x7e2a53a146606a48, + 0x2eda7444cbfc426d, 0xfa911155fefb5308, + 0x793555ab7eba27ca, 0x4bc1558b2f3458de, + 0x9eb1aaedfb016f16, 0x465e15a979c1cadc, + 0xbfacd89ec191ec9, 0xcef980ec671f667b, + 0x82b7e12780e7401a, 0xd1b2ecb8b0908810, + 0x861fa7e6dcb4aa15, 0x67a791e093e1d49a, + 0xe0c8bb2c5c6d24e0, 0x58fae9f773886e18, + 0xaf39a475506a899e, 0x6d8406c952429603, + 0xc8e5087ba6d33b83, 0xfb1e4a9a90880a64, + 0x5cf2eea09a55067f, 0xf42faa48c0ea481e, + 0xf13b94daf124da26, 0x76c53d08d6b70858, + 0x54768c4b0c64ca6e, 0xa9942f5dcf7dfd09, + 0xd3f93b35435d7c4c, 0xc47bc5014a1a6daf, + 0x359ab6419ca1091b, 0xc30163d203c94b62, + 0x79e0de63425dcf1d, 0x985915fc12f542e4, + 0x3e6f5b7b17b2939d, 0xa705992ceecf9c42, + 0x50c6ff782a838353, 0xa4f8bf5635246428, + 0x871b7795e136be99, 0x28e2557b59846e3f, + 0x331aeada2fe589cf, 0x3ff0d2c85def7621, + 0xfed077a756b53a9, 0xd3e8495912c62894, + 0x64712dd7abbbd95c, 0xbd8d794d96aacfb3, + 0xecf0d7a0fc5583a0, 0xf41686c49db57244, + 0x311c2875c522ced5, 0x7d633293366b828b, + 0xae5dff9c02033197, 0xd9f57f830283fdfc, + 0xd072df63c324fd7b, 0x4247cb9e59f71e6d, + 0x52d9be85f074e608, 0x67902e276c921f8b, + 0xba1cd8a3db53b6, 0x80e8a40eccd228a4, + 0x6122cd128006b2cd, 0x796b805720085f81, + 0xcbe3303674053bb0, 0xbedbfc4411068a9c, + 0xee92fb5515482d44, 0x751bdd152d4d1c4a, + 0xd262d45a78a0635d, 0x86fb897116c87c34, + 0xd45d35e6ae3d4da0, 0x8974836059cca109, + 0x2bd1a438703fc94b, 0x7b6306a34627ddcf, + 0x1a3bc84c17b1d542, 0x20caba5f1d9e4a93, + 0x547eb47b7282ee9c, 0xe99e619a4f23aa43, + 0x6405fa00e2ec94d4, 0xde83bc408dd3dd04, + 0x9624ab50b148d445, 0x3badd624dd9b0957, + 0xe54ca5d70a80e5d6, 0x5e9fcf4ccd211f4c, + 0x7647c3200069671f, 0x29ecd9f40041e073, + 0xf468107100525890, 0x7182148d4066eeb4, + 0xc6f14cd848405530, 0xb8ada00e5a506a7c, + 0xa6d90811f0e4851c, 0x908f4a166d1da663, + 0x9a598e4e043287fe, 0x40eff1e1853f29fd, + 0xd12bee59e68ef47c, 0x82bb74f8301958ce, + 0xe36a52363c1faf01, 0xdc44e6c3cb279ac1, + 0x29ab103a5ef8c0b9, 0x7415d448f6b6f0e7, + 0x111b495b3464ad21, 0xcab10dd900beec34, + 0x3d5d514f40eea742, 0xcb4a5a3112a5112, + 0x47f0e785eaba72ab, 0x59ed216765690f56, + 0x306869c13ec3532c, 0x1e414218c73a13fb, + 0xe5d1929ef90898fa, 0xdf45f746b74abf39, + 0x6b8bba8c328eb783, 0x66ea92f3f326564, + 0xc80a537b0efefebd, 0xbd06742ce95f5f36, + 0x2c48113823b73704, 0xf75a15862ca504c5, + 0x9a984d73dbe722fb, 0xc13e60d0d2e0ebba, + 0x318df905079926a8, 0xfdf17746497f7052, + 0xfeb6ea8bedefa633, 0xfe64a52ee96b8fc0, + 0x3dfdce7aa3c673b0, 0x6bea10ca65c084e, + 0x486e494fcff30a62, 0x5a89dba3c3efccfa, + 0xf89629465a75e01c, 0xf6bbb397f1135823, + 0x746aa07ded582e2c, 0xa8c2a44eb4571cdc, + 0x92f34d62616ce413, 0x77b020baf9c81d17, + 0xace1474dc1d122e, 0xd819992132456ba, + 0x10e1fff697ed6c69, 0xca8d3ffa1ef463c1, + 0xbd308ff8a6b17cb2, 0xac7cb3f6d05ddbde, + 0x6bcdf07a423aa96b, 0x86c16c98d2c953c6, + 0xe871c7bf077ba8b7, 0x11471cd764ad4972, + 0xd598e40d3dd89bcf, 0x4aff1d108d4ec2c3, + 0xcedf722a585139ba, 0xc2974eb4ee658828, + 0x733d226229feea32, 0x806357d5a3f525f, + 0xca07c2dcb0cf26f7, 0xfc89b393dd02f0b5, + 0xbbac2078d443ace2, 0xd54b944b84aa4c0d, + 0xa9e795e65d4df11, 0x4d4617b5ff4a16d5, + 0x504bced1bf8e4e45, 0xe45ec2862f71e1d6, + 0x5d767327bb4e5a4c, 0x3a6a07f8d510f86f, + 0x890489f70a55368b, 0x2b45ac74ccea842e, + 0x3b0b8bc90012929d, 0x9ce6ebb40173744, + 0xcc420a6a101d0515, 0x9fa946824a12232d, + 0x47939822dc96abf9, 0x59787e2b93bc56f7, + 0x57eb4edb3c55b65a, 0xede622920b6b23f1, + 0xe95fab368e45eced, 0x11dbcb0218ebb414, + 0xd652bdc29f26a119, 0x4be76d3346f0495f, + 0x6f70a4400c562ddb, 0xcb4ccd500f6bb952, + 0x7e2000a41346a7a7, 0x8ed400668c0c28c8, + 0x728900802f0f32fa, 0x4f2b40a03ad2ffb9, + 0xe2f610c84987bfa8, 0xdd9ca7d2df4d7c9, + 0x91503d1c79720dbb, 0x75a44c6397ce912a, + 0xc986afbe3ee11aba, 0xfbe85badce996168, + 0xfae27299423fb9c3, 0xdccd879fc967d41a, + 0x5400e987bbc1c920, 0x290123e9aab23b68, + 0xf9a0b6720aaf6521, 0xf808e40e8d5b3e69, + 0xb60b1d1230b20e04, 0xb1c6f22b5e6f48c2, + 0x1e38aeb6360b1af3, 0x25c6da63c38de1b0, + 0x579c487e5a38ad0e, 0x2d835a9df0c6d851, + 0xf8e431456cf88e65, 0x1b8e9ecb641b58ff, + 0xe272467e3d222f3f, 0x5b0ed81dcc6abb0f, + 0x98e947129fc2b4e9, 0x3f2398d747b36224, + 0x8eec7f0d19a03aad, 0x1953cf68300424ac, + 0x5fa8c3423c052dd7, 0x3792f412cb06794d, + 0xe2bbd88bbee40bd0, 0x5b6aceaeae9d0ec4, + 0xf245825a5a445275, 0xeed6e2f0f0d56712, + 0x55464dd69685606b, 0xaa97e14c3c26b886, + 0xd53dd99f4b3066a8, 0xe546a8038efe4029, + 0xde98520472bdd033, 0x963e66858f6d4440, + 0xdde7001379a44aa8, 0x5560c018580d5d52, + 0xaab8f01e6e10b4a6, 0xcab3961304ca70e8, + 0x3d607b97c5fd0d22, 0x8cb89a7db77c506a, + 0x77f3608e92adb242, 0x55f038b237591ed3, + 0x6b6c46dec52f6688, 0x2323ac4b3b3da015, + 0xabec975e0a0d081a, 0x96e7bd358c904a21, + 0x7e50d64177da2e54, 0xdde50bd1d5d0b9e9, + 0x955e4ec64b44e864, 0xbd5af13bef0b113e, + 0xecb1ad8aeacdd58e, 0x67de18eda5814af2, + 0x80eacf948770ced7, 0xa1258379a94d028d, + 0x96ee45813a04330, 0x8bca9d6e188853fc, + 0x775ea264cf55347d, 0x95364afe032a819d, + 0x3a83ddbd83f52204, 0xc4926a9672793542, + 0x75b7053c0f178293, 0x5324c68b12dd6338, + 0xd3f6fc16ebca5e03, 0x88f4bb1ca6bcf584, + 0x2b31e9e3d06c32e5, 0x3aff322e62439fcf, + 0x9befeb9fad487c2, 0x4c2ebe687989a9b3, + 0xf9d37014bf60a10, 0x538484c19ef38c94, + 0x2865a5f206b06fb9, 0xf93f87b7442e45d3, + 0xf78f69a51539d748, 0xb573440e5a884d1b, + 0x31680a88f8953030, 0xfdc20d2b36ba7c3d, + 0x3d32907604691b4c, 0xa63f9a49c2c1b10f, + 0xfcf80dc33721d53, 0xd3c36113404ea4a8, + 0x645a1cac083126e9, 0x3d70a3d70a3d70a3, + 0xcccccccccccccccc, 0x0, + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x0, + 0x0, 0x4000000000000000, + 0x5000000000000000, 0xa400000000000000, + 0x4d00000000000000, 0xf020000000000000, + 0x6c28000000000000, 0xc732000000000000, + 0x3c7f400000000000, 0x4b9f100000000000, + 0x1e86d40000000000, 0x1314448000000000, + 0x17d955a000000000, 0x5dcfab0800000000, + 0x5aa1cae500000000, 0xf14a3d9e40000000, + 0x6d9ccd05d0000000, 0xe4820023a2000000, + 0xdda2802c8a800000, 0xd50b2037ad200000, + 0x4526f422cc340000, 0x9670b12b7f410000, + 0x3c0cdd765f114000, 0xa5880a69fb6ac800, + 0x8eea0d047a457a00, 0x72a4904598d6d880, + 0x47a6da2b7f864750, 0x999090b65f67d924, + 0xfff4b4e3f741cf6d, 0xbff8f10e7a8921a4, + 0xaff72d52192b6a0d, 0x9bf4f8a69f764490, + 0x2f236d04753d5b4, 0x1d762422c946590, + 0x424d3ad2b7b97ef5, 0xd2e0898765a7deb2, + 0x63cc55f49f88eb2f, 0x3cbf6b71c76b25fb, + 0x8bef464e3945ef7a, 0x97758bf0e3cbb5ac, + 0x3d52eeed1cbea317, 0x4ca7aaa863ee4bdd, + 0x8fe8caa93e74ef6a, 0xb3e2fd538e122b44, + 0x60dbbca87196b616, 0xbc8955e946fe31cd, + 0x6babab6398bdbe41, 0xc696963c7eed2dd1, + 0xfc1e1de5cf543ca2, 0x3b25a55f43294bcb, + 0x49ef0eb713f39ebe, 0x6e3569326c784337, + 0x49c2c37f07965404, 0xdc33745ec97be906, + 0x69a028bb3ded71a3, 0xc40832ea0d68ce0c, + 0xf50a3fa490c30190, 0x792667c6da79e0fa, + 0x577001b891185938, 0xed4c0226b55e6f86, + 0x544f8158315b05b4, 0x696361ae3db1c721, + 0x3bc3a19cd1e38e9, 0x4ab48a04065c723, + 0x62eb0d64283f9c76, 0x3ba5d0bd324f8394, + 0xca8f44ec7ee36479, 0x7e998b13cf4e1ecb, + 0x9e3fedd8c321a67e, 0xc5cfe94ef3ea101e, + 0xbba1f1d158724a12, 0x2a8a6e45ae8edc97, + 0xf52d09d71a3293bd, 0x593c2626705f9c56, + 0x6f8b2fb00c77836c, 0xb6dfb9c0f956447, + 0x4724bd4189bd5eac, 0x58edec91ec2cb657, + 0x2f2967b66737e3ed, 0xbd79e0d20082ee74, + 0xecd8590680a3aa11, 0xe80e6f4820cc9495, + 0x3109058d147fdcdd, 0xbd4b46f0599fd415, + 0x6c9e18ac7007c91a, 0x3e2cf6bc604ddb0, + 0x84db8346b786151c, 0xe612641865679a63, + 0x4fcb7e8f3f60c07e, 0xe3be5e330f38f09d, + 0x5cadf5bfd3072cc5, 0x73d9732fc7c8f7f6, + 0x2867e7fddcdd9afa, 0xb281e1fd541501b8, + 0x1f225a7ca91a4226, 0x3375788de9b06958, + 0x52d6b1641c83ae, 0xc0678c5dbd23a49a, + 0xf840b7ba963646e0, 0xb650e5a93bc3d898, + 0xa3e51f138ab4cebe, 0xc66f336c36b10137, + 0xb80b0047445d4184, 0xa60dc059157491e5, + 0x87c89837ad68db2f, 0x29babe4598c311fb, + 0xf4296dd6fef3d67a, 0x1899e4a65f58660c, + 0x5ec05dcff72e7f8f, 0x76707543f4fa1f73, + 0x6a06494a791c53a8, 0x487db9d17636892, + 0x45a9d2845d3c42b6, 0xb8a2392ba45a9b2, + 0x8e6cac7768d7141e, 0x3207d795430cd926, + 0x7f44e6bd49e807b8, 0x5f16206c9c6209a6, + 0x36dba887c37a8c0f, 0xc2494954da2c9789, + 0xf2db9baa10b7bd6c, 0x6f92829494e5acc7, + 0xcb772339ba1f17f9, 0xff2a760414536efb, + 0xfef5138519684aba, 0x7eb258665fc25d69, + 0xef2f773ffbd97a61, 0xaafb550ffacfd8fa, + 0x95ba2a53f983cf38, 0xdd945a747bf26183, + 0x94f971119aeef9e4, 0x7a37cd5601aab85d, + 0xac62e055c10ab33a, 0x577b986b314d6009, + 0xed5a7e85fda0b80b, 0x14588f13be847307, + 0x596eb2d8ae258fc8, 0x6fca5f8ed9aef3bb, + 0x25de7bb9480d5854, 0xaf561aa79a10ae6a, + 0x1b2ba1518094da04, 0x90fb44d2f05d0842, + 0x353a1607ac744a53, 0x42889b8997915ce8, + 0x69956135febada11, 0x43fab9837e699095, + 0x94f967e45e03f4bb, 0x1d1be0eebac278f5, + 0x6462d92a69731732, 0x7d7b8f7503cfdcfe, + 0x5cda735244c3d43e, 0x3a0888136afa64a7, + 0x88aaa1845b8fdd0, 0x8aad549e57273d45, + 0x36ac54e2f678864b, 0x84576a1bb416a7dd, + 0x656d44a2a11c51d5, 0x9f644ae5a4b1b325, + 0x873d5d9f0dde1fee, 0xa90cb506d155a7ea, + 0x9a7f12442d588f2, 0xc11ed6d538aeb2f, + 0x8f1668c8a86da5fa, 0xf96e017d694487bc, + 0x37c981dcc395a9ac, 0x85bbe253f47b1417, + 0x93956d7478ccec8e, 0x387ac8d1970027b2, + 0x6997b05fcc0319e, 0x441fece3bdf81f03, + 0xd527e81cad7626c3, 0x8a71e223d8d3b074, + 0xf6872d5667844e49, 0xb428f8ac016561db, + 0xe13336d701beba52, 0xecc0024661173473, + 0x27f002d7f95d0190, 0x31ec038df7b441f4, + 0x7e67047175a15271, 0xf0062c6e984d386, + 0x52c07b78a3e60868, 0xa7709a56ccdf8a82, + 0x88a66076400bb691, 0x6acff893d00ea435, + 0x583f6b8c4124d43, 0xc3727a337a8b704a, + 0x744f18c0592e4c5c, 0x1162def06f79df73, + 0x8addcb5645ac2ba8, 0x6d953e2bd7173692, + 0xc8fa8db6ccdd0437, 0x1d9c9892400a22a2, + 0x2503beb6d00cab4b, 0x2e44ae64840fd61d, + 0x5ceaecfed289e5d2, 0x7425a83e872c5f47, + 0xd12f124e28f77719, 0x82bd6b70d99aaa6f, + 0x636cc64d1001550b, 0x3c47f7e05401aa4e, + 0x65acfaec34810a71, 0x7f1839a741a14d0d, + 0x1ede48111209a050, 0x934aed0aab460432, + 0xf81da84d5617853f, 0x36251260ab9d668e, + 0xc1d72b7c6b426019, 0xb24cf65b8612f81f, + 0xdee033f26797b627, 0x169840ef017da3b1, + 0x8e1f289560ee864e, 0xf1a6f2bab92a27e2, + 0xae10af696774b1db, 0xacca6da1e0a8ef29, + 0x17fd090a58d32af3, 0xddfc4b4cef07f5b0, + 0x4abdaf101564f98e, 0x9d6d1ad41abe37f1, + 0x84c86189216dc5ed, 0x32fd3cf5b4e49bb4, + 0x3fbc8c33221dc2a1, 0xfabaf3feaa5334a, + 0x29cb4d87f2a7400e, 0x743e20e9ef511012, + 0x914da9246b255416, 0x1ad089b6c2f7548e, + 0xa184ac2473b529b1, 0xc9e5d72d90a2741e, + 0x7e2fa67c7a658892, 0xddbb901b98feeab7, + 0x552a74227f3ea565, 0xd53a88958f87275f, + 0x8a892abaf368f137, 0x2d2b7569b0432d85, + 0x9c3b29620e29fc73, 0x8349f3ba91b47b8f, + 0x241c70a936219a73, 0xed238cd383aa0110, + 0xf4363804324a40aa, 0xb143c6053edcd0d5, + 0xdd94b7868e94050a, 0xca7cf2b4191c8326, + 0xfd1c2f611f63a3f0, 0xbc633b39673c8cec, + 0xd5be0503e085d813, 0x4b2d8644d8a74e18, + 0xddf8e7d60ed1219e, 0xcabb90e5c942b503, + 0x3d6a751f3b936243, 0xcc512670a783ad4, + 0x27fb2b80668b24c5, 0xb1f9f660802dedf6, + 0x5e7873f8a0396973, 0xdb0b487b6423e1e8, + 0x91ce1a9a3d2cda62, 0x7641a140cc7810fb, + 0xa9e904c87fcb0a9d, 0x546345fa9fbdcd44, + 0xa97c177947ad4095, 0x49ed8eabcccc485d, + 0x5c68f256bfff5a74, 0x73832eec6fff3111, + 0xc831fd53c5ff7eab, 0xba3e7ca8b77f5e55, + 0x28ce1bd2e55f35eb, 0x7980d163cf5b81b3, + 0xd7e105bcc332621f, 0x8dd9472bf3fefaa7, + 0xb14f98f6f0feb951, 0x6ed1bf9a569f33d3, + 0xa862f80ec4700c8, 0xcd27bb612758c0fa, + 0x8038d51cb897789c, 0xe0470a63e6bd56c3, + 0x1858ccfce06cac74, 0xf37801e0c43ebc8, + 0xd30560258f54e6ba, 0x47c6b82ef32a2069, + 0x4cdc331d57fa5441, 0xe0133fe4adf8e952, + 0x58180fddd97723a6, 0x570f09eaa7ea7648,}; + + // we start with a fast path + // It was described in + // Clinger WD. How to read floating point numbers accurately. + // ACM SIGPLAN Notices. 1990 +#if (FLT_EVAL_METHOD != 1) && (FLT_EVAL_METHOD != 0) + // we do not trust the divisor + if (0 <= power && power <= 22 && i <= 9007199254740991) { +#else + if (-22 <= power && power <= 22 && i <= 9007199254740991) { +#endif + // convert the integer into a double. This is lossless since + // 0 <= i <= 2^53 - 1. + double d = (double)i; + // + // The general idea is as follows. + // If 0 <= s < 2^53 and if 10^0 <= p <= 10^22 then + // 1) Both s and p can be represented exactly as 64-bit floating-point + // values + // (binary64). + // 2) Because s and p can be represented exactly as floating-point values, + // then s * p + // and s / p will produce correctly rounded values. + // + if (power < 0) { + d = d / power_of_ten[-power]; + } else { + d = d * power_of_ten[power]; + } + if (negative) { + d = -d; + } + *success = 1; + return d; + } + // When 22 < power && power < 22 + 16, we could + // hope for another, secondary fast path. It wa + // described by David M. Gay in "Correctly rounded + // binary-decimal and decimal-binary conversions." (1990) + // If you need to compute i * 10^(22 + x) for x < 16, + // first compute i * 10^x, if you know that result is exact + // (e.g., when i * 10^x < 2^53), + // then you can still proceed and do (i * 10^x) * 10^22. + // Is this worth your time? + // You need 22 < power *and* power < 22 + 16 *and* (i * 10^(x-22) < 2^53) + // for this second fast path to work. + // If you you have 22 < power *and* power < 22 + 16, and then you + // optimistically compute "i * 10^(x-22)", there is still a chance that you + // have wasted your time if i * 10^(x-22) >= 2^53. It makes the use cases of + // this optimization maybe less common than we would like. Source: + // http://www.exploringbinary.com/fast-path-decimal-to-floating-point-conversion/ + // also used in RapidJSON: https://rapidjson.org/strtod_8h_source.html + + + + // The fast path has now failed, so we are failing back on the slower path. + + // In the slow path, we need to adjust i so that it is > 1<<63 which is always + // possible, except if i == 0, so we handle i == 0 separately. + if(i == 0) { + return negative ? -0.0 : 0.0; + } + + + // We are going to need to do some 64-bit arithmetic to get a more precise product. + // We use a table lookup approach. + // It is safe because + // power >= FASTFLOAT_SMALLEST_POWER + // and power <= FASTFLOAT_LARGEST_POWER + // We recover the mantissa of the power, it has a leading 1. It is always + // rounded down. + uint64_t factor_mantissa = mantissa_64[power - FASTFLOAT_SMALLEST_POWER]; + + + // The exponent is 1024 + 63 + power + // + floor(log(5**power)/log(2)). + // The 1024 comes from the ieee64 standard. + // The 63 comes from the fact that we use a 64-bit word. + // + // Computing floor(log(5**power)/log(2)) could be + // slow. Instead we use a fast function. + // + // For power in (-400,350), we have that + // (((152170 + 65536) * power ) >> 16); + // is equal to + // floor(log(5**power)/log(2)) + power when power >= 0 + // and it is equal to + // ceil(log(5**-power)/log(2)) + power when power < 0 + // + // + // The 65536 is (1<<16) and corresponds to + // (65536 * power) >> 16 ---> power + // + // ((152170 * power ) >> 16) is equal to + // floor(log(5**power)/log(2)) + // + // Note that this is not magic: 152170/(1<<16) is + // approximatively equal to log(5)/log(2). + // The 1<<16 value is a power of two; we could use a + // larger power of 2 if we wanted to. + // + int64_t exponent = (((152170 + 65536) * power) >> 16) + 1024 + 63; + // We want the most significant bit of i to be 1. Shift if needed. + int lz = leading_zeroes(i); + i <<= lz; + // We want the most significant 64 bits of the product. We know + // this will be non-zero because the most significant bit of i is + // 1. + value128 product = full_multiplication(i, factor_mantissa); + uint64_t lower = product.low; + uint64_t upper = product.high; + // We know that upper has at most one leading zero because + // both i and factor_mantissa have a leading one. This means + // that the result is at least as large as ((1<<63)*(1<<63))/(1<<64). + + // As long as the first 9 bits of "upper" are not "1", then we + // know that we have an exact computed value for the leading + // 55 bits because any imprecision would play out as a +1, in + // the worst case. + // Having 55 bits is necessary because + // we need 53 bits for the mantissa but we have to have one rounding bit and + // we can waste a bit if the most significant bit of the product is zero. + // We expect this next branch to be rarely taken (say 1% of the time). + // When (upper & 0x1FF) == 0x1FF, it can be common for + // lower + i < lower to be true (proba. much higher than 1%). + if (unlikely((upper & 0x1FF) == 0x1FF) && (lower + i < lower)) { + uint64_t factor_mantissa_low = + mantissa_128[power - FASTFLOAT_SMALLEST_POWER]; + // next, we compute the 64-bit x 128-bit multiplication, getting a 192-bit + // result (three 64-bit values) + product = full_multiplication(i, factor_mantissa_low); + uint64_t product_low = product.low; + uint64_t product_middle2 = product.high; + uint64_t product_middle1 = lower; + uint64_t product_high = upper; + uint64_t product_middle = product_middle1 + product_middle2; + if (product_middle < product_middle1) { + product_high++; // overflow carry + } + // we want to check whether mantissa *i + i would affect our result + // This does happen, e.g. with 7.3177701707893310e+15 + if (((product_middle + 1 == 0) && ((product_high & 0x1FF) == 0x1FF) && + (product_low + i < product_low))) { // let us be prudent and bail out. + *success = 0; + return 0; + } + upper = product_high; + lower = product_middle; + } + // The final mantissa should be 53 bits with a leading 1. + // We shift it so that it occupies 54 bits with a leading 1. + /////// + uint64_t upperbit = upper >> 63; + uint64_t mantissa = upper >> (upperbit + 9); + lz += (int)(1 ^ upperbit); + // Here we have mantissa < (1<<54). + + // We have to round to even. The "to even" part + // is only a problem when we are right in between two floats + // which we guard against. + // If we have lots of trailing zeros, we may fall right between two + // floating-point values. + if (unlikely((lower == 0) && ((upper & 0x1FF) == 0) && + ((mantissa & 3) == 1))) { + // if mantissa & 1 == 1 we might need to round up. + // + // Scenarios: + // 1. We are not in the middle. Then we should round up. + // + // 2. We are right in the middle. Whether we round up depends + // on the last significant bit: if it is "one" then we round + // up (round to even) otherwise, we do not. + // + // So if the last significant bit is 1, we can safely round up. + // Hence we only need to bail out if (mantissa & 3) == 1. + // Otherwise we may need more accuracy or analysis to determine whether + // we are exactly between two floating-point numbers. + // It can be triggered with 1e23. + // Note: because the factor_mantissa and factor_mantissa_low are + // almost always rounded down (except for small positive powers), + // almost always should round up. + *success = 0; + return 0; + } + mantissa += mantissa & 1; + mantissa >>= 1; + // Here we have mantissa < (1<<53), unless there was an overflow + if (mantissa >= (1ULL << 53)) { + ////////// + // This will happen when parsing values such as 7.2057594037927933e+16 + //////// + mantissa = (1ULL << 52); + lz--; // undo previous addition + } + mantissa &= ~(1ULL << 52); + uint64_t real_exponent = exponent - lz; + // we have to check that real_exponent is in range, otherwise we bail out + if (unlikely((real_exponent < 1) || (real_exponent > 2046))) { + *success = 0; + return 0; + } + mantissa |= real_exponent << 52; + mantissa |= (((uint64_t)negative) << 63); + double d; + memcpy(&d, &mantissa, sizeof(d)); + *success = 1; + return d; +} diff --git a/cbits/text.c b/cbits/text.c --- a/cbits/text.c +++ b/cbits/text.c @@ -38,61 +38,9 @@ #include #endif -HsInt ascii_validate(const char* p, HsInt off, HsInt len){ - const char* q = p + off; -#if defined(AVX512_IMPLEMENTATION) - return (HsInt)validate_ascii_fast_avx512(q, (size_t)len); -#elif defined(__AVX2__) - return (HsInt)validate_ascii_fast_avx(q, (size_t)len); -#elif defined(__SSSE3__) - return (HsInt)validate_ascii_fast(q, (size_t)len); -#else - return (HsInt)ascii_u64(q, (size_t)len); -#endif -} -// for some reason unknown, on windows we have to supply a seperated version of ascii_validate -// otherwise we got segfault if we import the same FFI with different type (Addr# vs ByteArray#) -HsInt ascii_validate_addr(const char* p, HsInt len){ -#if defined(AVX512_IMPLEMENTATION) - return (HsInt)validate_ascii_fast_avx512(p, (size_t)len); -#elif defined(__AVX2__) - return (HsInt)validate_ascii_fast_avx(p, (size_t)len); -#elif defined(__SSSE3__) - return (HsInt)validate_ascii_fast(p, (size_t)len); -#else - return (HsInt)ascii_u64(p, (size_t)len); -#endif -} - -HsInt utf8_validate(const char* p, HsInt off, HsInt len){ - const char* q = p + off; -#if defined(AVX512_IMPLEMENTATION) - return (HsInt)validate_utf8_fast_avx512(q, (size_t)len); -#elif defined(__AVX2__) - return (HsInt)validate_utf8_fast_avx(q, (size_t)len); -#elif defined(__SSSE3__) - return (HsInt)validate_utf8_fast(q, (size_t)len); -#else - return utf8_validate_slow(q, (size_t)len); -#endif -} -// for some reason unknown, on windows we have to supply a seperated version of utf8_validate -// otherwise we got segfault if we import the same FFI with different type (Addr# vs ByteArray#) -HsInt utf8_validate_addr(const char* p, HsInt len){ -#if defined(AVX512_IMPLEMENTATION) - return (HsInt)validate_utf8_fast_avx512(p, (size_t)len); -#elif defined(__AVX2__) - return (HsInt)validate_utf8_fast_avx(p, (size_t)len); -#elif defined(__SSSE3__) - return (HsInt)validate_utf8_fast(p, (size_t)len); -#else - return utf8_validate_slow(p, (size_t)len); -#endif -} - //////////////////////////////////////////////////////////////////////////////// -static inline int ascii_u64(const uint8_t *data, size_t len) +int ascii_u64(const uint8_t *data, size_t len) { uint8_t orall = 0; @@ -171,6 +119,62 @@ return ((state == UTF8_ACCEPT) ? 2 : 0); } +//////////////////////////////////////////////////////////////////////////////// + +HsInt ascii_validate(const char* p, HsInt off, HsInt len){ + const char* q = p + off; +#if defined(AVX512_IMPLEMENTATION) + return (HsInt)validate_ascii_fast_avx512(q, (size_t)len); +#elif defined(__AVX2__) + return (HsInt)validate_ascii_fast_avx(q, (size_t)len); +#elif defined(__SSSE3__) + return (HsInt)validate_ascii_fast(q, (size_t)len); +#else + return (HsInt)ascii_u64(q, (size_t)len); +#endif +} +// for some reason unknown, on windows we have to supply a seperated version of ascii_validate +// otherwise we got segfault if we import the same FFI with different type (Addr# vs ByteArray#) +HsInt ascii_validate_addr(const char* p, HsInt len){ +#if defined(AVX512_IMPLEMENTATION) + return (HsInt)validate_ascii_fast_avx512(p, (size_t)len); +#elif defined(__AVX2__) + return (HsInt)validate_ascii_fast_avx(p, (size_t)len); +#elif defined(__SSSE3__) + return (HsInt)validate_ascii_fast(p, (size_t)len); +#else + return (HsInt)ascii_u64(p, (size_t)len); +#endif +} + +HsInt utf8_validate(const char* p, HsInt off, HsInt len){ + const char* q = p + off; +#if defined(AVX512_IMPLEMENTATION) + return (HsInt)validate_utf8_fast_avx512(q, (size_t)len); +#elif defined(__AVX2__) + return (HsInt)validate_utf8_fast_avx(q, (size_t)len); +#elif defined(__SSSE3__) + return (HsInt)validate_utf8_fast(q, (size_t)len); +#else + return utf8_validate_slow(q, (size_t)len); +#endif +} +// for some reason unknown, on windows we have to supply a seperated version of utf8_validate +// otherwise we got segfault if we import the same FFI with different type (Addr# vs ByteArray#) +HsInt utf8_validate_addr(const char* p, HsInt len){ +#if defined(AVX512_IMPLEMENTATION) + return (HsInt)validate_utf8_fast_avx512(p, (size_t)len); +#elif defined(__AVX2__) + return (HsInt)validate_utf8_fast_avx(p, (size_t)len); +#elif defined(__SSSE3__) + return (HsInt)validate_utf8_fast(p, (size_t)len); +#else + return utf8_validate_slow(p, (size_t)len); +#endif +} + +//////////////////////////////////////////////////////////////////////////////// + static inline uint32_t decode_hex(uint32_t c) { if (c >= '0' && c <= '9') return c - '0'; else if (c >= 'a' && c <= 'f') return c - 'a' + 10; @@ -191,8 +195,8 @@ uint32_t temp_hex = 0; uint32_t unidata; // ECMA 404 require codepoints beyond Basic Multilingual Plane encoded as surrogate pair - uint32_t h_surrogate; - uint32_t l_surrogate; + uint32_t h_surrogate = 0; + uint32_t l_surrogate = 0; // read current byte to cur_byte and guard input end #define DISPATCH(label) {\ diff --git a/test/Z/Data/Builder/NumericSpec.hs b/test/Z/Data/Builder/NumericSpec.hs --- a/test/Z/Data/Builder/NumericSpec.hs +++ b/test/Z/Data/Builder/NumericSpec.hs @@ -8,6 +8,7 @@ import Data.Int import GHC.Float import Text.Printf (printf) +import Foreign.C.Types import qualified Z.Data.Builder.Numeric as B import qualified Z.Data.Builder.Base as B import qualified Z.Data.Text as T @@ -43,6 +44,22 @@ i === (read . T.unpack . B.buildText $ B.int @Word8 i) prop "int roundtrip" $ \ i -> i === (read . T.unpack . B.buildText $ B.int @Int8 i) + prop "int roundtrip" $ \ i -> + i === (read . T.unpack . B.buildText $ B.int @CShort i) + prop "int roundtrip" $ \ i -> + i === (read . T.unpack . B.buildText $ B.int @CUShort i) + prop "int roundtrip" $ \ i -> + i === (read . T.unpack . B.buildText $ B.int @CInt i) + prop "int roundtrip" $ \ i -> + i === (read . T.unpack . B.buildText $ B.int @CUInt i) + prop "int roundtrip" $ \ i -> + i === (read . T.unpack . B.buildText $ B.int @CLong i) + prop "int roundtrip" $ \ i -> + i === (read . T.unpack . B.buildText $ B.int @CULong i) + prop "int roundtrip" $ \ i -> + i === (read . T.unpack . B.buildText $ B.int @CLLong i) + prop "int roundtrip" $ \ i -> + i === (read . T.unpack . B.buildText $ B.int @CULLong i) describe "int roundtrip" $ do let f = B.defaultIFormat{B.width = 100, B.padding = B.ZeroPadding} 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/Builder/UUIDSpec.hs b/test/Z/Data/Builder/UUIDSpec.hs new file mode 100644 --- /dev/null +++ b/test/Z/Data/Builder/UUIDSpec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Z.Data.Builder.UUIDSpec where + +import qualified Data.List as List +import Data.Word +import Data.Int +import GHC.Float +import Data.Time.Format +import qualified Z.Data.Builder.UUID as B +import qualified Z.Data.Builder.Base as B +import qualified Z.Data.Text as T +import Test.QuickCheck +import Test.QuickCheck.Function +import Test.QuickCheck.Property +import Test.QuickCheck.Instances.UUID +import Test.Hspec +import Test.Hspec.QuickCheck + +spec :: Spec +spec = describe "builder uuid" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do + prop "uuid === show" $ \ t -> + (show t) === (T.unpack . B.buildText $ B.uuid t) + diff --git a/test/Z/Data/JSON/BaseSpec.hs b/test/Z/Data/JSON/BaseSpec.hs --- a/test/Z/Data/JSON/BaseSpec.hs +++ b/test/Z/Data/JSON/BaseSpec.hs @@ -241,7 +241,8 @@ it "(int, int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int, Int)) -> encodeText' a === JSON.encodeText a it "(int, int, int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int, Int, Int)) -> encodeText' a === JSON.encodeText a it "(int, int, int, int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int, Int, Int, Int)) -> encodeText' a === JSON.encodeText a - it "[(int, double)]" $ property $ \(a :: [(Int, Double)]) -> encodeText' a === JSON.encodeText a + -- | 0.0 /== 0 + -- it "[(int, double)]" $ property $ \(a :: [(Int, Double)]) -> encodeText' a === JSON.encodeText a it "[(string, string)]" $ property $ \(a :: [(String, String)]) -> encodeText' a === JSON.encodeText a it "HashMap Text Int" $ property $ \(a :: HM.HashMap T.Text Int) -> encodeText' a === JSON.encodeText a it "HashSet Text" $ property $ \(a :: HS.HashSet T.Text) -> encodeText' a === JSON.encodeText a @@ -264,7 +265,8 @@ it "maybe (int, int, int)" $ property $ \(a :: Maybe (Int, Int, Int)) -> encodeText' a === JSON.encodeText a it "maybe (int, int, int, int)" $ property $ \(a :: Maybe (Int, Int, Int, Int)) -> encodeText' a === JSON.encodeText a it "maybe (int, int, int, int, int)" $ property $ \(a :: Maybe (Int, Int, Int, Int, Int)) -> encodeText' a === JSON.encodeText a - it "maybe [(int, double)]" $ property $ \(a :: Maybe [(Int, Double)]) -> encodeText' a === JSON.encodeText a + -- | 0.0 /== 0 + -- it "maybe [(int, double)]" $ property $ \(a :: Maybe [(Int, Double)]) -> encodeText' a === JSON.encodeText a it "maybe [(string, string)]" $ property $ \(a :: Maybe [(String, String)]) -> encodeText' a === JSON.encodeText a -- | 0.0 /== 0 -- it "either int float" $ property $ \(a :: Either Int Float) -> encodeText' a === JSON.encodeText a 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/Parser/UUIDSpec.hs b/test/Z/Data/Parser/UUIDSpec.hs new file mode 100644 --- /dev/null +++ b/test/Z/Data/Parser/UUIDSpec.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Z.Data.Parser.UUIDSpec where + +import qualified Data.List as List +import Data.Word +import Data.Int +import GHC.Float +import qualified Z.Data.Builder as B +import qualified Z.Data.Parser as P +import qualified Z.Data.Text as T +import Test.QuickCheck +import Test.QuickCheck.Function +import Test.QuickCheck.Property +import Test.QuickCheck.Instances.UUID +import Test.Hspec +import Test.Hspec.QuickCheck + +spec :: Spec +spec = describe "parser uuid" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do + prop "uuid roundtrip" $ \ t -> + Right t === (P.parse' P.uuid . B.build $ B.uuid t) + + prop "uuid binary roundtrip" $ \ t -> + Right t === (P.parse' P.decodeUUID . B.build $ B.encodeUUID t) 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) diff --git a/test/Z/Foreign/CPtrSpec.hs b/test/Z/Foreign/CPtrSpec.hs new file mode 100644 --- /dev/null +++ b/test/Z/Foreign/CPtrSpec.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Z.Foreign.CPtrSpec where + +import Foreign.Ptr +import qualified Data.List as List +import qualified Z.Data.CBytes as CB +import qualified Z.Data.JSON as JSON +import Z.Foreign +import qualified Z.Data.Vector.Base as V +import qualified Z.Data.Array as A +import Z.Foreign.CPtr +import Test.HUnit +import Test.Hspec +import Test.Hspec.QuickCheck +import System.IO.Unsafe + +spec :: Spec +spec = describe "Foreign.CPtr" $ do + it "pass cptr list to foreign" $ do + foo1 <- newCPtr' (malloc_foo 8) free_foo + foo2 <- newCPtr' (malloc_foo 8) free_foo + foo3 <- newCPtr' (malloc_foo 8) free_foo + + s1 <- withCPtrsUnsafe [foo1, foo2, foo3] sum_pointer + s2 <- withCPtrs [foo1, foo2, foo3] sum_pointer_safe + + s3 <- withCPtr foo1 $ \ p1 -> + withCPtr foo2 $ \ p2 -> + withCPtr foo3 $ \ p3 -> do + let WordPtr p1' = ptrToWordPtr p1 + WordPtr p2' = ptrToWordPtr p2 + WordPtr p3' = ptrToWordPtr p3 + return (p1'+p2'+p3') + s1 @=? s3 + s2 @=? s3 + +-------------------------------------------------------------------------------- + +data Foo + +foreign import ccall unsafe "malloc" malloc_foo :: CSize -> IO (Ptr Foo) +foreign import ccall unsafe "&free" free_foo :: FunPtr (Ptr Foo -> IO ()) + +foreign import ccall unsafe "sum_pointer" sum_pointer :: BA# (Ptr Foo) -> Int -> IO Word +foreign import ccall safe "sum_pointer" sum_pointer_safe :: (Ptr (Ptr Foo)) -> Int -> IO Word diff --git a/test/Z/ForeignSpec.hs b/test/Z/ForeignSpec.hs --- a/test/Z/ForeignSpec.hs +++ b/test/Z/ForeignSpec.hs @@ -1,22 +1,23 @@ -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnliftedFFITypes #-} module Z.ForeignSpec where -import qualified Data.List as List -import qualified Z.Data.CBytes as CB -import qualified Z.Data.JSON as JSON -import Z.Foreign -import qualified Z.Data.Vector.Base as V -import qualified Z.Data.Array as A +import qualified Data.List as List +import GHC.Exts +import System.IO.Unsafe +import Test.Hspec +import Test.Hspec.QuickCheck import Test.QuickCheck import Test.QuickCheck.Function import Test.QuickCheck.Property -import Test.Hspec -import Test.Hspec.QuickCheck -import System.IO.Unsafe +import qualified Z.Data.Array as A +import qualified Z.Data.CBytes as CB +import qualified Z.Data.JSON as JSON +import qualified Z.Data.Vector.Base as V +import Z.Foreign spec :: Spec spec = describe "Foreign" $ do