Z-Data 0.8.8.0 → 2.0.1.0
raw patch · 65 files changed
Files
- ChangeLog.md +36/−0
- README.md +19/−18
- Z-Data.cabal +30/−33
- Z/Data/ASCII.hs +2/−2
- Z/Data/Array.hs +551/−688
- Z/Data/Array/Base.hs +754/−0
- Z/Data/Array/Cast.hs +48/−18
- Z/Data/Array/Checked.hs +0/−328
- Z/Data/Array/QQ.hs +9/−3
- Z/Data/Array/Unaligned.hs +125/−283
- Z/Data/Array/UnliftedArray.hs +116/−42
- Z/Data/Builder.hs +11/−0
- Z/Data/Builder/Base.hs +80/−52
- Z/Data/Builder/Numeric.hs +79/−49
- Z/Data/Builder/Numeric/DigitTable.hs +4/−1
- Z/Data/Builder/Time.hs +59/−16
- Z/Data/Builder/UUID.hs +73/−0
- Z/Data/CBytes.hs +24/−25
- Z/Data/Generics/Utils.hs +3/−2
- Z/Data/JSON.hs +13/−2
- Z/Data/JSON/Base.hs +14/−4
- Z/Data/JSON/Builder.hs +3/−2
- Z/Data/JSON/Converter.hs +1/−0
- Z/Data/JSON/Value.hs +10/−10
- Z/Data/Parser.hs +13/−3
- Z/Data/Parser/Base.hs +210/−134
- Z/Data/Parser/Numeric.hs +143/−36
- Z/Data/Parser/Time.hs +68/−16
- Z/Data/Parser/UUID.hs +45/−0
- Z/Data/PrimRef.hs +231/−17
- Z/Data/PrimRef/PrimIORef.hs +0/−193
- Z/Data/PrimRef/PrimSTRef.hs +0/−60
- Z/Data/Text.hs +2/−1
- Z/Data/Text/Base.hs +51/−31
- Z/Data/Text/Extra.hs +37/−37
- Z/Data/Text/Print.hs +5/−6
- Z/Data/Text/Regex.hs +5/−3
- Z/Data/Text/Search.hs +12/−12
- Z/Data/Text/UTF8Codec.hs +57/−57
- Z/Data/Vector.hs +5/−3
- Z/Data/Vector/Base.hs +176/−95
- Z/Data/Vector/Base64.hs +3/−3
- Z/Data/Vector/Extra.hs +48/−38
- Z/Data/Vector/FlatIntMap.hs +12/−12
- Z/Data/Vector/FlatIntSet.hs +11/−11
- Z/Data/Vector/FlatMap.hs +12/−12
- Z/Data/Vector/FlatSet.hs +11/−11
- Z/Data/Vector/Hex.hs +4/−4
- Z/Data/Vector/Search.hs +12/−12
- Z/Data/Vector/Sort.hs +7/−19
- Z/Foreign.hs +54/−37
- Z/Foreign/CPtr.hs +13/−17
- cbits/bytes.c +81/−2
- cbits/compute_float_64.c +983/−0
- cbits/text.c +59/−55
- test/Z/Data/Builder/NumericSpec.hs +17/−0
- test/Z/Data/Builder/TimeSpec.hs +4/−3
- test/Z/Data/Builder/UUIDSpec.hs +25/−0
- test/Z/Data/JSON/BaseSpec.hs +4/−2
- test/Z/Data/Parser/BaseSpec.hs +2/−2
- test/Z/Data/Parser/TimeSpec.hs +5/−3
- test/Z/Data/Parser/UUIDSpec.hs +26/−0
- test/Z/Data/Vector/BaseSpec.hs +8/−0
- test/Z/Foreign/CPtrSpec.hs +49/−0
- test/Z/ForeignSpec.hs +13/−12
ChangeLog.md view
@@ -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.
README.md view
@@ -4,6 +4,7 @@ [](https://github.com/ZHaskell/z-data/actions) [](https://github.com/ZHaskell/z-data/actions) [](https://github.com/ZHaskell/z-data/actions)+[](https://cloud.drone.io/ZHaskell/z-data) [](https://gitter.im/Z-Haskell/community) <a href="https://opencollective.com/zhaskell/donate" target="_blank"> <img src="https://opencollective.com/zhaskell/donate/button@2x.png?color=blue" width=128 />@@ -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
Z-Data.cabal view
@@ -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
Z/Data/ASCII.hs view
@@ -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
Z/Data/Array.hs view
@@ -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 <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.-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 <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.-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<l) $ copyArr marr (i+1) arr (i+s) (l-i)- unsafeFreezeArr marr---- | Delete an element of the immutable array's at given index. This function will produce a new array.-deleteIndexArr :: Arr arr a- => 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'<l) $ copyArr marr i arr (i'+s) (l-i')- unsafeFreezeArr marr+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++Unified unboxed and boxed array operations using type family. This module re-export "Z.Data.Array.Base" module, but add check+when @check-array-bound@ flag is set. To debug array algorithms just add @Z-Data: -f+check-array-bound@ to your local @cabal.project@ file.+otherwise, none of the operations are bound checked.++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+ ( -- * Arr typeclass re-export+ Arr, MArr+ , A.emptyArr, A.singletonArr, A.doubletonArr+ , modifyIndexArr, insertIndexArr, deleteIndexArr, swapArr, swapMutableArr+ , A.doubleMutableArr, shuffleMutableArr+ , 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.Primitive+import Data.Primitive.Types+import GHC.Stack+import System.Random.Stateful (StatefulGen) +import Z.Data.Array.Base (Arr, MArr)+import qualified Z.Data.Array.Base as A+import Control.Monad.ST+#ifdef CHECK_ARRAY_BOUND+import Control.Monad+#endif++#ifdef CHECK_ARRAY_BOUND+check :: HasCallStack => 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<siz)+ (A.readArr marr i)+#else+ (A.readArr marr i)+#endif+{-# INLINE readArr #-}++-- | Write to specified index of mutable array in a primitive monad.+writeArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+ => MArr arr s a -> Int -> a -> m ()+writeArr marr i x = do+#ifdef CHECK_ARRAY_BOUND+ siz <- A.sizeofMutableArr marr+ check+ (i>=0 && i<siz)+ (A.writeArr marr i x)+#else+ (A.writeArr marr i x)+#endif+{-# INLINE writeArr #-}++-- | Fill the mutable array with a given value.+setArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+ => 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<A.sizeofArr arr) (A.indexArr arr i)+#else+ (A.indexArr arr i)+#endif+{-# INLINE indexArr #-}++-- | 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 arr a, HasCallStack)+ => arr a -> Int -> (# a #)+indexArr' arr i =+#ifdef CHECK_ARRAY_BOUND+ if (i>=0 && i<A.sizeofArr arr)+ then A.indexArr' arr i+ else throw (IndexOutOfBounds $ show callStack)+#else+ (A.indexArr' arr i)+#endif+{-# INLINE indexArr' #-}++-- | 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 :: (Arr arr a, Monad m, HasCallStack)+ => arr a -> Int -> m a+indexArrM arr i =+#ifdef CHECK_ARRAY_BOUND+ check+ (i>=0 && i<A.sizeofArr arr)+ (A.indexArrM arr i)+#else+ (A.indexArrM arr i)+#endif+{-# INLINE indexArrM #-}++-- | 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 :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)+ => 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<l) $ copyArr marr (i+1) arr (i+s) (l-i)+ A.unsafeFreezeArr marr+#else+ A.insertIndexArr arr s l i x+#endif++-- | Drop an immutable array's element at given index to produce a new array.+deleteIndexArr :: Arr arr a+ => 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'<l) $ copyArr marr i arr (i'+s) (l-i')+ A.unsafeFreezeArr marr+#else+ A.deleteIndexArr arr s l i+#endif++-- | Swap two elements under given index and return a new array.+swapArr :: Arr arr a+ => 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<siz && j<siz)+ (A.swapMutableArr marr i j)+#else+ A.swapMutableArr marr i j+#endif++-- | Shuffle array's elements in slice range.+--+-- This function use <https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle Fisher-Yates> 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
+ Z/Data/Array/Base.hs view
@@ -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 <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.+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 <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>.+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<l) $ copyArr marr (i+1) arr (i+s) (l-i)+ unsafeFreezeArr marr++-- | Delete an element of the immutable array's at given index. This function will produce a new array.+deleteIndexArr :: Arr arr a+ => 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'<l) $ copyArr marr i arr (i'+s) (l-i')+ unsafeFreezeArr marr++-- | Swap two elements under given index and return a new array.+swapArr :: Arr arr a+ => 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 <https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle Fisher-Yates> 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)
Z/Data/Array/Cast.hs view
@@ -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
− Z/Data/Array/Checked.hs
@@ -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<siz)- (A.readArr marr i)-{-# INLINE readArr #-}--writeArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)- => MArr arr s a -> Int -> a -> m ()-writeArr marr i x = do- siz <- A.sizeofMutableArr marr- check- (i>=0 && i<siz)- (A.writeArr marr i x)-{-# INLINE writeArr #-}--setArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)- => 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<A.sizeofArr arr)- (A.indexArr arr i)-{-# INLINE indexArr #-}--indexArr' :: (Arr arr a, HasCallStack)- => arr a -> Int -> (# a #)-indexArr' arr i =- if (i>=0 && i<A.sizeofArr arr)- then A.indexArr' arr i- else throw (IndexOutOfBounds $ show callStack)-{-# INLINE indexArr' #-}--indexArrM :: (Arr arr a, Monad m, HasCallStack)- => arr a -> Int -> m a-indexArrM arr i = check- (i>=0 && i<A.sizeofArr arr)- (A.indexArrM arr i)-{-# INLINE indexArrM #-}--freezeArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)- => 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<l) $ copyArr marr (i+1) arr (i+s) (l-i)- A.unsafeFreezeArr marr---- | Drop an immutable array's element at given index to produce a new array.-deleteIndexArr :: Arr arr a- => 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'<l) $ copyArr marr i arr (i'+s) (l-i')- A.unsafeFreezeArr marr
Z/Data/Array/QQ.hs view
@@ -59,7 +59,7 @@ import Control.Monad import Data.Bits import Data.Char (ord)-import Data.Primitive.PrimArray+import Data.Primitive.PrimArray hiding (copyPtrToMutablePrimArray) import GHC.Exts import Data.Word import Data.Int@@ -113,13 +113,14 @@ (error "Cannot use arrASCII as a dec") word8ArrayFromAddr :: Int -> 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#)
Z/Data/Array/Unaligned.hs view
@@ -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
Z/Data/Array/UnliftedArray.hs view
@@ -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
Z/Data/Builder.hs view
@@ -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 ()
Z/Data/Builder/Base.hs view
@@ -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'. --
Z/Data/Builder/Numeric.hs view
@@ -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 ->
Z/Data/Builder/Numeric/DigitTable.hs view
@@ -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\
Z/Data/Builder/Time.hs view
@@ -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-
+ Z/Data/Builder/UUID.hs view
@@ -0,0 +1,73 @@+{-|+Module: Z.Data.Builder.UUID+Description : Builders for UUID.+Copyright: (c) 2021 Dong Han+License: BSD3+Maintainer: Dong <winterland1989@gmail.com>+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 <https://datatracker.ietf.org/doc/html/rfc4122 RFC 4122>. +encodeUUID :: UUID -> B.Builder ()+{-# INLINABLE encodeUUID #-}+encodeUUID (UUID wh wl) = do + B.encodeWord64BE wh+ B.encodeWord64BE wl
Z/Data/CBytes.hs view
@@ -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
Z/Data/Generics/Utils.hs view
@@ -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
Z/Data/JSON.hs view
@@ -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 --------------------------------------------------------------------------------
Z/Data/JSON/Base.hs view
@@ -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 --------------------------------------------------------------------------------
Z/Data/JSON/Builder.hs view
@@ -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
Z/Data/JSON/Converter.hs view
@@ -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)
Z/Data/JSON/Value.hs view
@@ -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
Z/Data/Parser.hs view
@@ -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)
Z/Data/Parser/Base.hs view
@@ -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
Z/Data/Parser/Numeric.hs view
@@ -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 <https://github.com/lemire/fast_double_parser/>.+--+-- 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
Z/Data/Parser/Time.hs view
@@ -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 ""
+ Z/Data/Parser/UUID.hs view
@@ -0,0 +1,45 @@+{-|+Module: Z.Data.Parser.UUID+Description : Parsers for UUID.+Copyright: (c) 2020 Dong Han+License: BSD3+Maintainer: Dong <winterland1989@gmail.com>+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 <https://datatracker.ietf.org/doc/html/rfc4122 RFC 4122>. +decodeUUID :: P.Parser UUID+{-# INLINABLE decodeUUID #-}+decodeUUID = UUID <$> P.decodeWord64BE <*> P.decodeWord64BE
Z/Data/PrimRef.hs view
@@ -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 #-}
− Z/Data/PrimRef/PrimIORef.hs
@@ -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_ #-}
− Z/Data/PrimRef/PrimSTRef.hs
@@ -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 #-}
Z/Data/Text.hs view
@@ -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
Z/Data/Text/Base.hs view
@@ -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 <https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle Fisher-Yates> 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 <https://en.wikipedia.org/wiki/Heap%27s_algorithm Heap's algorithm>.+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) --------------------------------------------------------------------------------
Z/Data/Text/Extra.hs view
@@ -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 -- <https://github.com/haskell/bytestring/issues/56 #56>. 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
Z/Data/Text/Print.hs view
@@ -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
Z/Data/Text/Regex.hs view
@@ -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))
Z/Data/Text/Search.hs view
@@ -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
Z/Data/Text/UTF8Codec.hs view
@@ -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#
Z/Data/Vector.hs view
@@ -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
Z/Data/Vector/Base.hs view
@@ -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 <https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle Fisher-Yates> 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# --------------------------------------------------------------------------------
Z/Data/Vector/Base64.hs view
@@ -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
Z/Data/Vector/Extra.hs view
@@ -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 -- <https://github.com/haskell/bytestring/issues/56 #56>. 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 -- <https://github.com/haskell/bytestring/issues/56 #56>. 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
Z/Data/Vector/FlatIntMap.hs view
@@ -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 --------------------------------------------------------------------------------
Z/Data/Vector/FlatIntSet.hs view
@@ -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
Z/Data/Vector/FlatMap.hs view
@@ -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 --------------------------------------------------------------------------------
Z/Data/Vector/FlatSet.hs view
@@ -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
Z/Data/Vector/Hex.hs view
@@ -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)
Z/Data/Vector/Search.hs view
@@ -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
Z/Data/Vector/Sort.hs view
@@ -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.
Z/Foreign.hs view
@@ -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 <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>. 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 <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>. 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 <https://ghc.haskell.org/trac/ghc/ticket/14346 #14346>. 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#
Z/Foreign/CPtr.hs view
@@ -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
cbits/bytes.c view
@@ -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 } /*
+ cbits/compute_float_64.c view
@@ -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 <stdlib.h>+#include <stdint.h>+#include <string.h>++/**+ * 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;+}
cbits/text.c view
@@ -38,61 +38,9 @@ #include <simdutf8check.h> #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) {\
test/Z/Data/Builder/NumericSpec.hs view
@@ -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}
test/Z/Data/Builder/TimeSpec.hs view
@@ -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
+ test/Z/Data/Builder/UUIDSpec.hs view
@@ -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)+
test/Z/Data/JSON/BaseSpec.hs view
@@ -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
test/Z/Data/Parser/BaseSpec.hs view
@@ -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), ())
test/Z/Data/Parser/TimeSpec.hs view
@@ -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
+ test/Z/Data/Parser/UUIDSpec.hs view
@@ -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)
test/Z/Data/Vector/BaseSpec.hs view
@@ -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)
+ test/Z/Foreign/CPtrSpec.hs view
@@ -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
test/Z/ForeignSpec.hs view
@@ -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