foundation 0.0.12 → 0.0.13
raw patch · 63 files changed
+2353/−1151 lines, 63 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Foundation.Array.Internal: UVecAddr :: {-# UNPACK #-} !(Offset ty) -> {-# UNPACK #-} !(CountOf ty) -> !(FinalPtr ty) -> UArray ty
- Foundation.Array.Internal: UVecBA :: {-# UNPACK #-} !(Offset ty) -> {-# UNPACK #-} !(CountOf ty) -> {-# UNPACK #-} !PinnedStatus -> !ByteArray# -> UArray ty
- Foundation.Random: getRandomPrimType :: forall randomly ty. (PrimType ty, MonadRandom randomly) => randomly ty
+ Foundation: fromCount :: CountOf ty -> Int
+ Foundation: stripPrefix :: (Sequential c, Eq (Element c)) => c -> c -> Maybe c
+ Foundation: stripSuffix :: (Sequential c, Eq (Element c)) => c -> c -> Maybe c
+ Foundation: toCount :: Int -> CountOf ty
+ Foundation.Array.Internal: UArray :: {-# UNPACK #-} !(Offset ty) -> {-# UNPACK #-} !(CountOf ty) -> !(UArrayBackend ty) -> UArray ty
+ Foundation.Collection: class Foldable f => Fold1able f
+ Foundation.Collection: foldl1' :: Fold1able f => (Element f -> Element f -> Element f) -> NonEmpty f -> Element f
+ Foundation.Collection: foldr1 :: Fold1able f => (Element f -> Element f -> Element f) -> NonEmpty f -> Element f
+ Foundation.Collection: stripPrefix :: (Sequential c, Eq (Element c)) => c -> c -> Maybe c
+ Foundation.Collection: stripSuffix :: (Sequential c, Eq (Element c)) => c -> c -> Maybe c
+ Foundation.Foreign: touchFinalPtr :: PrimMonad prim => FinalPtr p -> prim ()
+ Foundation.Parser: reportError :: ParseError input -> Parser input a
+ Foundation.Primitive: primShiftToBytes :: PrimType ty => Proxy ty -> Int
+ Foundation.Primitive.Block: isMutablePinned :: MutableBlock s ty -> PinnedStatus
+ Foundation.Primitive.Block: isPinned :: Block ty -> PinnedStatus
+ Foundation.Random: getRandomF32 :: MonadRandom m => m Float
+ Foundation.Random: getRandomF64 :: MonadRandom m => m Double
+ Foundation.Random: getRandomWord64 :: MonadRandom m => m Word64
+ Foundation.Random: randomGenerateF32 :: RandomGen gen => gen -> (Float, gen)
+ Foundation.Random: randomGenerateF64 :: RandomGen gen => gen -> (Double, gen)
+ Foundation.Random: randomGenerateWord64 :: RandomGen gen => gen -> (Word64, gen)
+ Foundation.String: breakLine :: String -> Either Bool (String, String)
+ Foundation.UUID: newUUID :: MonadRandom randomly => randomly UUID
+ Foundation.UUID: uuidParser :: (ParserSource input, Element input ~ Char, Sequential (Chunk input), Element input ~ Element (Chunk input)) => Parser input UUID
- Foundation: class (IsList c, Item c ~ Element c, Monoid c, Collection c) => Sequential c where take n = fst . splitAt n revTake n = fst . revSplitAt n drop n = snd . splitAt n revDrop n = snd . revSplitAt n splitAt n c = (take n c, drop n c) revSplitAt n c = (revTake n c, revDrop n c) break predicate = span (not . predicate) breakElem c = break (== c) takeWhile predicate = fst . span predicate dropWhile predicate = snd . span predicate intercalate xs xss = mconcatCollection (intersperse xs xss) span predicate = break (not . predicate) partition predicate c = (filter predicate c, filter (not . predicate) c) head nel = maybe (error "head") fst $ uncons (getNonEmpty nel) last nel = maybe (error "last") snd $ unsnoc (getNonEmpty nel) tail nel = maybe (error "tail") snd $ uncons (getNonEmpty nel) init nel = maybe (error "init") fst $ unsnoc (getNonEmpty nel) isPrefixOf c1 c2 | len1 > len2 = False | len1 == len2 = c1 == c2 | otherwise = c1 == take len1 c2 where len1 = length c1 len2 = length c2 isSuffixOf c1 c2 | len1 > len2 = False | len1 == len2 = c1 == c2 | otherwise = c1 == revTake len1 c2 where len1 = length c1 len2 = length c2 isInfixOf c1 c2 | len1 > len2 = False | otherwise = loop 0 where endofs = len2 - len1 len1 = length c1 len2 = length c2 loop i | i == endofs = c1 == c2Sub | c1 == c2Sub = True | otherwise = loop (succ i) where c2Sub = take len1 $ drop i c2
+ Foundation: class (IsList c, Item c ~ Element c, Monoid c, Collection c) => Sequential c where take n = fst . splitAt n revTake n = fst . revSplitAt n drop n = snd . splitAt n revDrop n = snd . revSplitAt n splitAt n c = (take n c, drop n c) revSplitAt n c = (revTake n c, revDrop n c) break predicate = span (not . predicate) breakElem c = break (== c) takeWhile predicate = fst . span predicate dropWhile predicate = snd . span predicate intercalate xs xss = mconcatCollection (intersperse xs xss) span predicate = break (not . predicate) partition predicate c = (filter predicate c, filter (not . predicate) c) head nel = maybe (error "head") fst $ uncons (getNonEmpty nel) last nel = maybe (error "last") snd $ unsnoc (getNonEmpty nel) tail nel = maybe (error "tail") snd $ uncons (getNonEmpty nel) init nel = maybe (error "init") fst $ unsnoc (getNonEmpty nel) isPrefixOf c1 c2 | len1 > len2 = False | len1 == len2 = c1 == c2 | otherwise = c1 == take len1 c2 where len1 = length c1 len2 = length c2 isSuffixOf c1 c2 | len1 > len2 = False | len1 == len2 = c1 == c2 | otherwise = c1 == revTake len1 c2 where len1 = length c1 len2 = length c2 isInfixOf c1 c2 | len1 > len2 = False | otherwise = loop 0 where endofs = len2 - len1 len1 = length c1 len2 = length c2 loop i | i == endofs = c1 == c2Sub | c1 == c2Sub = True | otherwise = loop (succ i) where c2Sub = take len1 $ drop i c2 stripPrefix pre s | isPrefixOf pre s = Just $ drop (length pre) s | otherwise = Nothing stripSuffix suf s | isSuffixOf suf s = Just $ revDrop (length suf) s | otherwise = Nothing
- Foundation.Array.Internal: newPinned :: (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))
+ Foundation.Array.Internal: newPinned :: forall prim ty. (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))
- Foundation.Array.Internal: withPtr :: (PrimMonad prim, PrimType ty) => UArray ty -> (Ptr ty -> prim a) -> prim a
+ Foundation.Array.Internal: withPtr :: forall ty prim a. (PrimMonad prim, PrimType ty) => UArray ty -> (Ptr ty -> prim a) -> prim a
- Foundation.Collection: class (IsList c, Item c ~ Element c, Monoid c, Collection c) => Sequential c where take n = fst . splitAt n revTake n = fst . revSplitAt n drop n = snd . splitAt n revDrop n = snd . revSplitAt n splitAt n c = (take n c, drop n c) revSplitAt n c = (revTake n c, revDrop n c) break predicate = span (not . predicate) breakElem c = break (== c) takeWhile predicate = fst . span predicate dropWhile predicate = snd . span predicate intercalate xs xss = mconcatCollection (intersperse xs xss) span predicate = break (not . predicate) partition predicate c = (filter predicate c, filter (not . predicate) c) head nel = maybe (error "head") fst $ uncons (getNonEmpty nel) last nel = maybe (error "last") snd $ unsnoc (getNonEmpty nel) tail nel = maybe (error "tail") snd $ uncons (getNonEmpty nel) init nel = maybe (error "init") fst $ unsnoc (getNonEmpty nel) isPrefixOf c1 c2 | len1 > len2 = False | len1 == len2 = c1 == c2 | otherwise = c1 == take len1 c2 where len1 = length c1 len2 = length c2 isSuffixOf c1 c2 | len1 > len2 = False | len1 == len2 = c1 == c2 | otherwise = c1 == revTake len1 c2 where len1 = length c1 len2 = length c2 isInfixOf c1 c2 | len1 > len2 = False | otherwise = loop 0 where endofs = len2 - len1 len1 = length c1 len2 = length c2 loop i | i == endofs = c1 == c2Sub | c1 == c2Sub = True | otherwise = loop (succ i) where c2Sub = take len1 $ drop i c2
+ Foundation.Collection: class (IsList c, Item c ~ Element c, Monoid c, Collection c) => Sequential c where take n = fst . splitAt n revTake n = fst . revSplitAt n drop n = snd . splitAt n revDrop n = snd . revSplitAt n splitAt n c = (take n c, drop n c) revSplitAt n c = (revTake n c, revDrop n c) break predicate = span (not . predicate) breakElem c = break (== c) takeWhile predicate = fst . span predicate dropWhile predicate = snd . span predicate intercalate xs xss = mconcatCollection (intersperse xs xss) span predicate = break (not . predicate) partition predicate c = (filter predicate c, filter (not . predicate) c) head nel = maybe (error "head") fst $ uncons (getNonEmpty nel) last nel = maybe (error "last") snd $ unsnoc (getNonEmpty nel) tail nel = maybe (error "tail") snd $ uncons (getNonEmpty nel) init nel = maybe (error "init") fst $ unsnoc (getNonEmpty nel) isPrefixOf c1 c2 | len1 > len2 = False | len1 == len2 = c1 == c2 | otherwise = c1 == take len1 c2 where len1 = length c1 len2 = length c2 isSuffixOf c1 c2 | len1 > len2 = False | len1 == len2 = c1 == c2 | otherwise = c1 == revTake len1 c2 where len1 = length c1 len2 = length c2 isInfixOf c1 c2 | len1 > len2 = False | otherwise = loop 0 where endofs = len2 - len1 len1 = length c1 len2 = length c2 loop i | i == endofs = c1 == c2Sub | c1 == c2Sub = True | otherwise = loop (succ i) where c2Sub = take len1 $ drop i c2 stripPrefix pre s | isPrefixOf pre s = Just $ drop (length pre) s | otherwise = Nothing stripSuffix suf s | isSuffixOf suf s = Just $ revDrop (length suf) s | otherwise = Nothing
Files
- CHANGELOG.md +37/−0
- Foundation.hs +10/−0
- Foundation/Array/Bitmap.hs +2/−2
- Foundation/Array/Boxed.hs +32/−14
- Foundation/Array/Unboxed.hs +251/−614
- Foundation/Array/Unboxed/ByteArray.hs +1/−1
- Foundation/Array/Unboxed/Mutable.hs +51/−198
- Foundation/Boot/List.hs +16/−2
- Foundation/Check/Arbitrary.hs +29/−25
- Foundation/Check/Main.hs +1/−1
- Foundation/Collection.hs +1/−0
- Foundation/Collection/Collection.hs +2/−2
- Foundation/Collection/Sequential.hs +18/−0
- Foundation/Conduit/Textual.hs +15/−9
- Foundation/Hashing/FNV.hs +7/−7
- Foundation/Hashing/Hashable.hs +6/−5
- Foundation/Hashing/Hasher.hs +9/−9
- Foundation/Internal/Natural.hs +5/−0
- Foundation/Internal/PrimTypes.hs +8/−0
- Foundation/Internal/Primitive.hs +25/−11
- Foundation/Parser.hs +14/−0
- Foundation/Primitive/Block.hs +35/−15
- Foundation/Primitive/Block/Base.hs +19/−12
- Foundation/Primitive/Block/Mutable.hs +1/−8
- Foundation/Primitive/Endianness.hs +5/−2
- Foundation/Primitive/FinalPtr.hs +10/−5
- Foundation/Primitive/IntegralConv.hs +11/−0
- Foundation/Primitive/NormalForm.hs +5/−0
- Foundation/Primitive/Runtime.hs +1/−1
- Foundation/Primitive/Types.hs +70/−2
- Foundation/Primitive/Types/OffsetSize.hs +23/−10
- Foundation/Primitive/UArray/Addr.hs +101/−0
- Foundation/Primitive/UArray/BA.hs +100/−0
- Foundation/Primitive/UArray/Base.hs +550/−0
- Foundation/Primitive/UTF8/Addr.hs +110/−21
- Foundation/Primitive/UTF8/BA.hs +110/−21
- Foundation/Primitive/UTF8/Base.hs +22/−30
- Foundation/Primitive/UTF8/Helper.hs +0/−9
- Foundation/Primitive/UTF8/Types.hs +50/−0
- Foundation/Random.hs +71/−5
- Foundation/String.hs +1/−0
- Foundation/String/ASCII.hs +1/−1
- Foundation/String/ModifiedUTF8.hs +2/−1
- Foundation/String/UTF8.hs +104/−79
- Foundation/String/UTF8/Addr.hs +3/−3
- Foundation/String/UTF8/BA.hs +3/−3
- Foundation/System/Bindings/Hs.hs +18/−4
- Foundation/Time/Types.hs +2/−0
- Foundation/UUID.hs +71/−1
- benchs/Fake/ByteString.hs +21/−0
- benchs/Fake/Text.hs +4/−1
- benchs/Fake/Vector.hs +42/−0
- benchs/Main.hs +69/−11
- benchs/Sys.hs +3/−0
- cbits/foundation_mem.c +9/−1
- cbits/foundation_prim.h +8/−0
- cbits/foundation_random.c +31/−0
- cbits/foundation_rts.c +8/−0
- cbits/foundation_utf8.c +85/−0
- foundation.cabal +8/−1
- tests/Checks.hs +4/−4
- tests/Test/Foundation/Misc.hs +6/−0
- tests/Test/Foundation/String.hs +16/−0
CHANGELOG.md view
@@ -1,3 +1,40 @@+## 0.0.13++Block:+* Optimise fold++UArray:+* Re-organise type to be more modular for later change+* Remove the pinned array explicit status in favor of asking+ the runtime system directly on demand.+* Optimise fold operations+* Optimise all&any+* Optimise isPrefixOf+* Optimise isSuffixOf+* Optimise finding byte+* Add an optimise function to break on line (CRLF & LF) as part of a stream++String:+* Optimise length+* Optimise all&any+* Optimise foldr+* Remove many unboxed tuples (next, prev, ..) in favor of a strict unpack+ constructor+* Optimise lines using array breakLine++Collection:+* add stripPrefix & stripSuffix++Tests:+* Improve performance++Misc:+* Cleanup Offset/Size types with the C boundary+* Faster Offset/Size convertions+* Add Base64 support+* Add LE/BE instance for NormalForm+* Add UUID generation and parsing+ ## 0.0.12 * Fix build windows building & time subsystem
Foundation.hs view
@@ -86,6 +86,8 @@ , Prelude.Float , Prelude.Double , CountOf(..), Offset(..)+ , toCount+ , fromCount -- ** Collection types , UArray , PrimType@@ -197,3 +199,11 @@ -- | Returns a list of the program's command line arguments (not including the program name). getArgs :: Prelude.IO [String] getArgs = (Data.List.map fromList <$> System.Environment.getArgs)++fromCount :: CountOf ty -> Prelude.Int+fromCount (CountOf n) = n++toCount :: Prelude.Int -> CountOf ty+toCount i+ | i Prelude.<= 0 = CountOf 0+ | Prelude.otherwise = CountOf i
Foundation/Array/Bitmap.hs view
@@ -257,7 +257,7 @@ mutableLength (MutableBitmap sz _) = sz empty :: Bitmap-empty = Bitmap 0 A.empty+empty = Bitmap 0 mempty new :: PrimMonad prim => CountOf Bool -> prim (MutableBitmap (PrimState prim)) new sz@(CountOf len) =@@ -279,7 +279,7 @@ runST $ do mba <- A.new nbElements ba <- loop mba (0 :: Int) allBools- return (Bitmap len ba)+ pure (Bitmap len ba) where loop mba _ [] = A.unsafeFreeze mba loop mba i l = do
Foundation/Array/Boxed.hs view
@@ -60,6 +60,8 @@ , foldr1 , all , any+ , isPrefixOf+ , isSuffixOf , builderAppend , builderBuild , builderBuild_@@ -219,7 +221,7 @@ thaw array = do m <- new (length array) unsafeCopyAtRO m (Offset 0) array (Offset 0) (length array)- return m+ pure m {-# INLINE thaw #-} freeze :: PrimMonad prim => MArray ty (PrimState prim) -> prim (Array ty)@@ -277,7 +279,7 @@ where len = length v' endIdx = Offset 0 `offsetPlusE` len fill i f' r'- | i == endIdx = return r'+ | i == endIdx = pure r' | otherwise = do f' v' i r' fill (i + Offset 1) f' r' @@ -367,7 +369,7 @@ r <- new (mconcat $ fmap length l) loop r (Offset 0) l unsafeFreeze r- where loop _ _ [] = return ()+ where loop _ _ [] = pure () loop r i (x:xs) = do unsafeCopyAtRO r i x (Offset 0) lx loop r (i `offsetPlusE` lx) xs@@ -584,7 +586,7 @@ doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma where qsort lo hi- | lo >= hi = return ()+ | lo >= hi = pure () | otherwise = do p <- partition lo hi qsort lo (pred p)@@ -592,16 +594,16 @@ partition lo hi = do pivot <- unsafeRead ma hi let loop i j- | j == hi = return i+ | j == hi = pure i | otherwise = do aj <- unsafeRead ma j i' <- if ford aj pivot == GT- then return i+ then pure i else do ai <- unsafeRead ma i unsafeWrite ma j ai unsafeWrite ma i aj- return $ i + 1+ pure $ i + 1 loop i' (j+1) i <- loop lo lo@@ -609,7 +611,7 @@ ahi <- unsafeRead ma hi unsafeWrite ma hi ai unsafeWrite ma i ahi- return i+ pure i filter :: forall ty . (ty -> Bool) -> Array ty -> Array ty filter predicate vec = runST (new len >>= copyFilterFreeze predicate (unsafeIndex vec))@@ -619,7 +621,7 @@ copyFilterFreeze predi getVec mvec = loop (Offset 0) (Offset 0) >>= freezeUntilIndex mvec where loop d s- | s .==# len = return d+ | s .==# len = pure d | predi v = unsafeWrite mvec d v >> loop (d+1) (s+1) | otherwise = loop d (s+1) where@@ -682,6 +684,22 @@ | p (unsafeIndex ba i) = True | otherwise = loop (i + 1) +isPrefixOf :: Eq ty => Array ty -> Array ty -> Bool+isPrefixOf pre arr+ | pLen > pArr = False+ | otherwise = pre == take pLen arr+ where+ !pLen = length pre+ !pArr = length arr++isSuffixOf :: Eq ty => Array ty -> Array ty -> Bool+isSuffixOf suffix arr+ | pLen > pArr = False+ | otherwise = suffix == revTake pLen arr+ where+ !pLen = length suffix+ !pArr = length arr+ builderAppend :: PrimMonad state => ty -> Builder (Array ty) (MArray ty) ty state err () builderAppend v = Builder $ State $ \(i, st, e) -> if i .==# chunkSize st@@ -689,13 +707,13 @@ cur <- unsafeFreeze (curChunk st) newChunk <- new (chunkSize st) unsafeWrite newChunk 0 v- return ((), (Offset 1, st { prevChunks = cur : prevChunks st+ pure ((), (Offset 1, st { prevChunks = cur : prevChunks st , prevChunksSize = chunkSize st + prevChunksSize st , curChunk = newChunk }, e)) else do unsafeWrite (curChunk st) i v- return ((), (i+1, st, e))+ pure ((), (i+1, st, e)) builderBuild :: PrimMonad m => Int -> Builder (Array ty) (MArray ty) ty m err () -> m (Either err (Array ty)) builderBuild sizeChunksI ab@@ -704,17 +722,17 @@ first <- new sizeChunks ((), (i, st, e)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing) case e of- Just err -> return (Left err)+ Just err -> pure (Left err) Nothing -> do cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) -- Build final array let totalSize = prevChunksSize st + offsetAsSize i bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze- return (Right bytes)+ pure (Right bytes) where sizeChunks = CountOf sizeChunksI - fillFromEnd _ [] mua = return mua+ fillFromEnd _ [] mua = pure mua fillFromEnd !end (x:xs) mua = do let sz = length x unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz
Foundation/Array/Unboxed.hs view
@@ -5,11 +5,10 @@ -- Stability : experimental -- Portability : portable ----- A simple array abstraction that allow to use typed--- array of bytes where the array is pinned in memory--- to allow easy use with Foreign interfaces, ByteString--- and always aligned to 64 bytes.+-- An unboxed array of primitive types --+-- All the cells in the array are in one chunk of contiguous+-- memory. {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -31,7 +30,6 @@ , unsafeThaw -- * Creation , new- , empty , create , createFromIO , createFromPtr@@ -68,9 +66,9 @@ , revTake , revSplitAt , splitOn- , splitElem , break , breakElem+ , breakLine , elem , indices , intersperse@@ -90,6 +88,8 @@ , foldl1' , all , any+ , isPrefixOf+ , isSuffixOf , foreignMem , fromForeignPtr , builderAppend@@ -105,76 +105,29 @@ import GHC.Word import GHC.ST import GHC.Ptr-import GHC.IO (unsafeDupablePerformIO) import GHC.ForeignPtr (ForeignPtr) import Foreign.Marshal.Utils (copyBytes)-import Foreign.C.Types (CInt, CSize)-import qualified Prelude import Foundation.Internal.Base import Foundation.Internal.Primitive import Foundation.Internal.Proxy import Foundation.Primitive.Types.OffsetSize import Foundation.Internal.MonadTrans import Foundation.Collection.NonEmpty-import qualified Foundation.Primitive.Base16 as Base16 import Foundation.Primitive.Monad import Foundation.Primitive.Types-import Foundation.Primitive.NormalForm import Foundation.Primitive.FinalPtr import Foundation.Primitive.Utils import Foundation.Primitive.Exception-import Foundation.System.Bindings.Hs+import Foundation.Primitive.UArray.Base+import Foundation.Primitive.Block (Block(..), MutableBlock(..)) import Foundation.Array.Unboxed.Mutable hiding (sub, copyToPtr) import Foundation.Numerical import Foundation.Boot.Builder-import qualified Data.List---- | An array of type built on top of GHC primitive.------ The elements need to have fixed sized and the representation is a--- packed contiguous array in memory that can easily be passed--- to foreign interface-data UArray ty =- UVecBA {-# UNPACK #-} !(Offset ty)- {-# UNPACK #-} !(CountOf ty)- {-# UNPACK #-} !PinnedStatus {- unpinned / pinned flag -}- !ByteArray#- | UVecAddr {-# UNPACK #-} !(Offset ty)- {-# UNPACK #-} !(CountOf ty)- !(FinalPtr ty)- deriving (Typeable)--instance Data ty => Data (UArray ty) where- dataTypeOf _ = arrayType- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"--arrayType :: DataType-arrayType = mkNoRepType "Foundation.UArray"--instance NormalForm (UArray ty) where- toNormalForm (UVecBA _ _ _ !_) = ()- toNormalForm (UVecAddr {}) = ()-instance (PrimType ty, Show ty) => Show (UArray ty) where- show v = show (toList v)-instance (PrimType ty, Eq ty) => Eq (UArray ty) where- (==) = equal-instance (PrimType ty, Ord ty) => Ord (UArray ty) where- {-# SPECIALIZE instance Ord (UArray Word8) #-}- compare = vCompare--instance PrimType ty => Monoid (UArray ty) where- mempty = empty- mappend = append- mconcat = concat--instance PrimType ty => IsList (UArray ty) where- type Item (UArray ty) = ty- fromList = vFromList- toList = vToList--vectorProxyTy :: UArray ty -> Proxy ty-vectorProxyTy _ = Proxy+import Foundation.System.Bindings.Hs (sysHsMemFindByteBa, sysHsMemFindByteAddr)+import qualified Foundation.Boot.List as List+import qualified Foundation.Primitive.Base16 as Base16+import qualified Foundation.Primitive.UArray.BA as PrimBA+import qualified Foundation.Primitive.UArray.Addr as PrimAddr -- | Copy every cells of an existing array to a new array copy :: PrimType ty => UArray ty -> UArray ty@@ -188,7 +141,7 @@ thaw array = do ma <- new (length array) unsafeCopyAtRO ma azero array (Offset 0) (length array)- return ma+ pure ma {-# INLINE thaw #-} -- | Return the element at a specific index from an array.@@ -202,94 +155,18 @@ !len = length array {-# INLINE index #-} --- | Return the element at a specific index from an array without bounds checking.------ Reading from invalid memory can return unpredictable and invalid values.--- use 'index' if unsure.-unsafeIndex :: forall ty . PrimType ty => UArray ty -> Offset ty -> ty-unsafeIndex (UVecBA start _ _ ba) n = primBaIndex ba (start + n)-unsafeIndex (UVecAddr start _ fptr) n = withUnsafeFinalPtr fptr (\(Ptr addr) -> return (primAddrIndex addr (start+n)) :: IO ty)-{-# INLINE unsafeIndex #-}--unsafeIndexer :: (PrimMonad prim, PrimType ty) => UArray ty -> ((Offset ty -> ty) -> prim a) -> prim a-unsafeIndexer (UVecBA start _ _ ba) f = f (\n -> primBaIndex ba (start + n))-unsafeIndexer (UVecAddr start _ fptr) f = withFinalPtr fptr $ \(Ptr addr) -> f (\n -> primAddrIndex addr (start + n))-{-# INLINE unsafeIndexer #-}--unsafeDewrap :: (ByteArray# -> Offset ty -> a)- -> (Ptr ty -> Offset ty -> ST s a)- -> UArray ty- -> a-unsafeDewrap _ g (UVecAddr start _ fptr) = withUnsafeFinalPtr fptr $ \ptr -> g ptr start-unsafeDewrap f _ (UVecBA start _ _ ba) = f ba start-{-# INLINE unsafeDewrap #-}--unsafeDewrap2 :: (ByteArray# -> Offset ty -> ByteArray# -> Offset ty -> a)- -> (Ptr ty -> Offset ty -> Ptr ty -> Offset ty -> ST s a)- -> (ByteArray# -> Offset ty -> Ptr ty -> Offset ty -> ST s a)- -> (Ptr ty -> Offset ty -> ByteArray# -> Offset ty -> ST s a)- -> UArray ty- -> UArray ty- -> a-unsafeDewrap2 f _ _ _ (UVecBA start1 _ _ ba1) (UVecBA start2 _ _ ba2) = f ba1 start1 ba2 start2-unsafeDewrap2 _ f _ _ (UVecAddr start1 _ fptr1) (UVecAddr start2 _ fptr2) = withUnsafeFinalPtr fptr1 $ \ptr1 ->- withFinalPtr fptr2 $ \ptr2 -> f ptr1 start1 ptr2 start2-unsafeDewrap2 _ _ f _ (UVecBA start1 _ _ ba1) (UVecAddr start2 _ fptr2) = withUnsafeFinalPtr fptr2 $ \ptr2 -> f ba1 start1 ptr2 start2-unsafeDewrap2 _ _ _ f (UVecAddr start1 _ fptr1) (UVecBA start2 _ _ ba2) = withUnsafeFinalPtr fptr1 $ \ptr1 -> f ptr1 start1 ba2 start2-{-# INLINE [2] unsafeDewrap2 #-}- foreignMem :: PrimType ty => FinalPtr ty -- ^ the start pointer with a finalizer -> CountOf ty -- ^ the number of elements (in elements, not bytes) -> UArray ty-foreignMem fptr nb = UVecAddr (Offset 0) nb fptr+foreignMem fptr nb = UArray (Offset 0) nb (UArrayAddr fptr) fromForeignPtr :: PrimType ty => (ForeignPtr ty, Int, Int) -- ForeignPtr, an offset in prim elements, a size in prim elements -> UArray ty-fromForeignPtr (fptr, ofs, len) = UVecAddr (Offset ofs) (CountOf len) (toFinalPtrForeign fptr)+fromForeignPtr (fptr, ofs, len) = UArray (Offset ofs) (CountOf len) (UArrayAddr $ toFinalPtrForeign fptr) -length :: UArray ty -> CountOf ty-length (UVecAddr _ len _) = len-length (UVecBA _ len _ _) = len-{-# INLINE[1] length #-} --- TODO Optimise with copyByteArray#--- | Copy @n@ sequential elements from the specified offset in a source array--- to the specified position in a destination array.------ This function does not check bounds. Accessing invalid memory can return--- unpredictable and invalid values.-unsafeCopyAtRO :: (PrimMonad prim, PrimType ty)- => MUArray ty (PrimState prim) -- ^ destination array- -> Offset ty -- ^ offset at destination- -> UArray ty -- ^ source array- -> Offset ty -- ^ offset at source- -> CountOf ty -- ^ number of elements to copy- -> prim ()-unsafeCopyAtRO (MUVecMA dstStart _ _ dstMba) ed uvec@(UVecBA srcStart _ _ srcBa) es n =- primitive $ \st -> (# copyByteArray# srcBa os dstMba od nBytes st, () #)- where- sz = primSizeInBytes (vectorProxyTy uvec)- !(Offset (I# os)) = offsetOfE sz (srcStart+es)- !(Offset (I# od)) = offsetOfE sz (dstStart+ed)- !(CountOf (I# nBytes)) = sizeOfE sz n-unsafeCopyAtRO (MUVecMA dstStart _ _ dstMba) ed uvec@(UVecAddr srcStart _ srcFptr) es n =- withFinalPtr srcFptr $ \srcPtr ->- let !(Ptr srcAddr) = srcPtr `plusPtr` os- in primitive $ \s -> (# compatCopyAddrToByteArray# srcAddr dstMba od nBytes s, () #)- where- sz = primSizeInBytes (vectorProxyTy uvec)- !(Offset os) = offsetOfE sz (srcStart+es)- !(Offset (I# od)) = offsetOfE sz (dstStart+ed)- !(CountOf (I# nBytes)) = sizeOfE sz n-unsafeCopyAtRO dst od src os n = loop od os- where- !endIndex = os `offsetPlusE` n- loop d i- | i == endIndex = return ()- | otherwise = unsafeWrite dst d (unsafeIndex src i) >> loop (d+1) (i+1)- -- | Allocate a new array with a fill function that has access to the elements of -- the source array. unsafeCopyFrom :: (PrimType a, PrimType b)@@ -301,31 +178,16 @@ unsafeCopyFrom v' newLen f = new newLen >>= fill 0 >>= unsafeFreeze where len = length v' fill i r'- | i .==# len = return r'+ | i .==# len = pure r' | otherwise = do f v' i r' fill (i + 1) r' --- | Freeze a mutable array into an array.------ the MUArray must not be changed after freezing.-unsafeFreeze :: PrimMonad prim => MUArray ty (PrimState prim) -> prim (UArray ty)-unsafeFreeze (MUVecMA start len pinnedState mba) = primitive $ \s1 ->- case unsafeFreezeByteArray# mba s1 of- (# s2, ba #) -> (# s2, UVecBA start len pinnedState ba #)-unsafeFreeze (MUVecAddr start len fptr) = return $ UVecAddr start len fptr-{-# INLINE unsafeFreeze #-}--unsafeFreezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty)-unsafeFreezeShrink (MUVecMA start _ pinnedState mba) n = unsafeFreeze (MUVecMA start n pinnedState mba)-unsafeFreezeShrink (MUVecAddr start _ fptr) n = unsafeFreeze (MUVecAddr start n fptr)-{-# INLINE unsafeFreezeShrink #-}- freeze :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> prim (UArray ty) freeze ma = do ma' <- new len copyAt ma' (Offset 0) ma (Offset 0) len unsafeFreeze ma'- where len = CountOf $ mutableLength ma+ where len = mutableLength ma freezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty) freezeShrink ma n = do@@ -337,19 +199,11 @@ unsafeSlide mua s e = doSlide mua s e where doSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Offset ty -> Offset ty -> prim ()- doSlide (MUVecMA mbStart _ _ mba) start end =+ doSlide (MUArray mbStart _ (MUArrayMBA (MutableBlock mba))) start end = primMutableByteArraySlideToStart mba (offsetInBytes $ mbStart+start) (offsetInBytes end)- doSlide (MUVecAddr mbStart _ fptr) start end = withFinalPtr fptr $ \(Ptr addr) ->+ doSlide (MUArray mbStart _ (MUArrayAddr fptr)) start end = withFinalPtr fptr $ \(Ptr addr) -> primMutableAddrSlideToStart addr (offsetInBytes $ mbStart+start) (offsetInBytes end) --- | Thaw an immutable array.------ The UArray must not be used after thawing.-unsafeThaw :: (PrimType ty, PrimMonad prim) => UArray ty -> prim (MUArray ty (PrimState prim))-unsafeThaw (UVecBA start len pinnedState ba) = primitive $ \st -> (# st, MUVecMA start len pinnedState (unsafeCoerce# ba) #)-unsafeThaw (UVecAddr start len fptr) = return $ MUVecAddr start len fptr-{-# INLINE unsafeThaw #-}- -- | Create a new array of size @n by settings each cells through the -- function @f. create :: forall ty . PrimType ty@@ -357,7 +211,7 @@ -> (Offset ty -> ty) -- ^ the function that set the value at the index -> UArray ty -- ^ the array created create n initializer- | n == 0 = empty+ | n == 0 = mempty | otherwise = runST (new n >>= iter initializer) where iter :: (PrimType ty, PrimMonad prim) => (Offset ty -> ty) -> MUArray ty (PrimState prim) -> prim (UArray ty)@@ -375,12 +229,12 @@ -> (Ptr ty -> IO (CountOf ty)) -- ^ filling function that -> IO (UArray ty) createFromIO size filler- | size == 0 = return empty+ | size == 0 = pure mempty | otherwise = do mba <- newPinned size r <- withMutablePtr mba $ \p -> filler p case r of- 0 -> return empty -- make sure we don't keep our array referenced by using empty+ 0 -> pure mempty -- make sure we don't keep our array referenced by using empty _ | r < 0 -> error "filler returned negative number" | otherwise -> unsafeFreezeShrink mba r @@ -397,209 +251,13 @@ ----------------------------------------------------------------------- -- higher level collection implementation ------------------------------------------------------------------------data BA0 = BA0 !ByteArray# -- zero ba -empty_ :: BA0-empty_ = runST $ primitive $ \s1 ->- case newByteArray# 0# s1 of { (# s2, mba #) ->- case unsafeFreezeByteArray# mba s2 of { (# s3, ba #) ->- (# s3, BA0 ba #) }}--empty :: UArray ty-empty = UVecBA 0 0 unpinned ba where !(BA0 ba) = empty_- singleton :: PrimType ty => ty -> UArray ty singleton ty = create 1 (const ty) replicate :: PrimType ty => CountOf ty -> ty -> UArray ty replicate sz ty = create sz (const ty) --- | make an array from a list of elements.-vFromList :: PrimType ty => [ty] -> UArray ty-vFromList l = runST $ do- ma <- new (CountOf len)- iter azero l $ \i x -> unsafeWrite ma i x- unsafeFreeze ma- where len = Data.List.length l- iter _ [] _ = return ()- iter !i (x:xs) z = z i x >> iter (i+1) xs z---- | transform an array to a list.-vToList :: forall ty . PrimType ty => UArray ty -> [ty]-vToList a- | len == 0 = []- | otherwise = unsafeDewrap goBa goPtr a- where- !len = length a- goBa ba start = loop start- where- !end = start `offsetPlusE` len- loop !i | i == end = []- | otherwise = primBaIndex ba i : loop (i+1)- goPtr (Ptr addr) start = pureST (loop start)- where- !end = start `offsetPlusE` len- loop !i | i == end = []- | otherwise = primAddrIndex addr i : loop (i+1)---- | Check if two vectors are identical-equal :: (PrimType ty, Eq ty) => UArray ty -> UArray ty -> Bool-equal a b- | la /= lb = False- | otherwise = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b- where- !la = length a- !lb = length b- goBaBa ba1 start1 ba2 start2 = loop start1 start2- where- !end = start1 `offsetPlusE` la- loop !i !o | i == end = True- | otherwise = primBaIndex ba1 i == primBaIndex ba2 o && loop (i+o1) (o+o1)- goPtrPtr (Ptr addr1) start1 (Ptr addr2) start2 = pureST (loop start1 start2)- where- !end = start1 `offsetPlusE` la- loop !i !o | i == end = True- | otherwise = primAddrIndex addr1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1)- goBaPtr ba1 start1 (Ptr addr2) start2 = pureST (loop start1 start2)- where- !end = start1 `offsetPlusE` la- loop !i !o | i == end = True- | otherwise = primBaIndex ba1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1)- goPtrBa (Ptr addr1) start1 ba2 start2 = pureST (loop start1 start2)- where- !end = start1 `offsetPlusE` la- loop !i !o | i == end = True- | otherwise = primAddrIndex addr1 i == primBaIndex ba2 o && loop (i+o1) (o+o1)-- o1 = Offset (I# 1#)-{-# RULES "UArray/Eq/Word8" [3] equal = equalBytes #-}-{-# INLINEABLE [2] equal #-}--equalBytes :: UArray Word8 -> UArray Word8 -> Bool-equalBytes a b- | la /= lb = False- | otherwise = memcmp a b (csizeOfSize $ sizeInBytes la) == 0- where- !la = length a- !lb = length b--equalMemcmp :: PrimType ty => UArray ty -> UArray ty -> Bool-equalMemcmp a b- | la /= lb = False- | otherwise = memcmp a b (csizeOfSize $ sizeInBytes la) == 0- where- !la = length a- !lb = length b---- | Compare 2 vectors-vCompare :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering-vCompare a b = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b- where- !la = length a- !lb = length b- o1 = Offset (I# 1#)- goBaBa ba1 start1 ba2 start2 = loop start1 start2- where- !end = start1 `offsetPlusE` min la lb- loop !i !o | i == end = la `compare` lb- | v1 == v2 = loop (i + o1) (o + o1)- | otherwise = v1 `compare` v2- where v1 = primBaIndex ba1 i- v2 = primBaIndex ba2 o- goPtrPtr (Ptr addr1) start1 (Ptr addr2) start2 = pureST (loop start1 start2)- where- !end = start1 `offsetPlusE` min la lb- loop !i !o | i == end = la `compare` lb- | v1 == v2 = loop (i + o1) (o + o1)- | otherwise = v1 `compare` v2- where v1 = primAddrIndex addr1 i- v2 = primAddrIndex addr2 o- goBaPtr ba1 start1 (Ptr addr2) start2 = pureST (loop start1 start2)- where- !end = start1 `offsetPlusE` min la lb- loop !i !o | i == end = la `compare` lb- | v1 == v2 = loop (i + o1) (o + o1)- | otherwise = v1 `compare` v2- where v1 = primBaIndex ba1 i- v2 = primAddrIndex addr2 o- goPtrBa (Ptr addr1) start1 ba2 start2 = pureST (loop start1 start2)- where- !end = start1 `offsetPlusE` min la lb- loop !i !o | i == end = la `compare` lb- | v1 == v2 = loop (i + o1) (o + o1)- | otherwise = v1 `compare` v2- where v1 = primAddrIndex addr1 i- v2 = primBaIndex ba2 o--- {-# SPECIALIZE [3] vCompare :: UArray Word8 -> UArray Word8 -> Ordering = vCompareBytes #-}-{-# RULES "UArray/Ord/Word8" [3] vCompare = vCompareBytes #-}-{-# INLINEABLE [2] vCompare #-}--vCompareBytes :: UArray Word8 -> UArray Word8 -> Ordering-vCompareBytes = vCompareMemcmp--vCompareMemcmp :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering-vCompareMemcmp a b = cintToOrdering $ memcmp a b sz- where- la = length a- lb = length b- sz = csizeOfSize $ sizeInBytes $ min la lb- cintToOrdering :: CInt -> Ordering- cintToOrdering 0 = la `compare` lb- cintToOrdering r | r < 0 = LT- | otherwise = GT-{-# SPECIALIZE [3] vCompareMemcmp :: UArray Word8 -> UArray Word8 -> Ordering #-}--memcmp :: PrimType ty => UArray ty -> UArray ty -> CSize -> CInt-memcmp a b sz = unsafeDewrap2- (\s1 o1 s2 o2 -> unsafeDupablePerformIO $ sysHsMemcmpBaBa s1 (offsetToCSize o1) s2 (offsetToCSize o2) sz)- (\s1 o1 s2 o2 -> unsafePrimToST $ sysHsMemcmpPtrPtr s1 (offsetToCSize o1) s2 (offsetToCSize o2) sz)- (\s1 o1 s2 o2 -> unsafePrimToST $ sysHsMemcmpBaPtr s1 (offsetToCSize o1) s2 (offsetToCSize o2) sz)- (\s1 o1 s2 o2 -> unsafePrimToST $ sysHsMemcmpPtrBa s1 (offsetToCSize o1) s2 (offsetToCSize o2) sz)- a b- where- offsetToCSize ofs = csizeOfOffset $ offsetInBytes ofs-{-# SPECIALIZE [3] memcmp :: UArray Word8 -> UArray Word8 -> CSize -> CInt #-}---- | Append 2 arrays together by creating a new bigger array-append :: PrimType ty => UArray ty -> UArray ty -> UArray ty-append a b- | la == azero = b- | lb == azero = a- | otherwise = runST $ do- r <- new (la+lb)- ma <- unsafeThaw a- mb <- unsafeThaw b- copyAt r (Offset 0) ma (Offset 0) la- copyAt r (sizeAsOffset la) mb (Offset 0) lb- unsafeFreeze r- where- !la = length a- !lb = length b--concat :: PrimType ty => [UArray ty] -> UArray ty-concat [] = empty-concat l =- case filterAndSum (CountOf 0) [] l of- (_,[]) -> empty- (_,[x]) -> x- (totalLen,chunks) -> runST $ do- r <- new totalLen- doCopy r (Offset 0) chunks- unsafeFreeze r- where- -- TODO would go faster not to reverse but pack from the end instead- filterAndSum !totalLen acc [] = (totalLen, Prelude.reverse acc)- filterAndSum !totalLen acc (x:xs)- | len == CountOf 0 = filterAndSum totalLen acc xs- | otherwise = filterAndSum (len+totalLen) (x:acc) xs- where len = length x-- doCopy _ _ [] = return ()- doCopy r i (x:xs) = do- unsafeCopyAtRO r i x (Offset 0) lx- doCopy r (i `offsetPlusE` lx) xs- where lx = length x- -- | update an array by creating a new array with the updates. -- -- the operation copy the previous array, modify it in place, then freeze it.@@ -630,43 +288,33 @@ => UArray ty -- ^ the source array to copy -> Ptr ty -- ^ The destination address where the copy is going to start -> prim ()-copyToPtr (UVecBA start sz _ ba) (Ptr p) = primitive $ \s1 ->- (# compatCopyByteArrayToAddr# ba offset p szBytes s1, () #)- where- !(Offset (I# offset)) = offsetInBytes start- !(CountOf (I# szBytes)) = sizeInBytes sz-copyToPtr (UVecAddr start sz fptr) dst =- unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> copyBytes dst (ptr `plusPtr` os) szBytes+copyToPtr arr dst@(Ptr dst#) = onBackendPrim copyBa copyPtr arr where- !(Offset os) = offsetInBytes start- !(CountOf szBytes) = sizeInBytes sz--data TmpBA = TmpBA ByteArray#+ !(Offset os@(I# os#)) = offsetInBytes $ offset arr+ !(CountOf szBytes@(I# szBytes#)) = sizeInBytes $ length arr+ copyBa ba = primitive $ \s1 -> (# compatCopyByteArrayToAddr# ba os# dst# szBytes# s1, () #)+ copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> copyBytes dst (ptr `plusPtr` os) szBytes -withPtr :: (PrimMonad prim, PrimType ty)+withPtr :: forall ty prim a . (PrimMonad prim, PrimType ty) => UArray ty -> (Ptr ty -> prim a) -> prim a-withPtr vec@(UVecAddr start _ fptr) f =- withFinalPtr fptr (\ptr -> f (ptr `plusPtr` os))- where- sz = primSizeInBytes (vectorProxyTy vec)- !(Offset os) = offsetOfE sz start-withPtr vec@(UVecBA start _ pstatus a) f- | isPinned pstatus = f (Ptr (byteArrayContents# a) `plusPtr` os)- | otherwise = do- -- TODO don't copy the whole vector, and just allocate+copy the slice.- let !sz# = sizeofByteArray# a- (TmpBA ba) <- primitive $ \s -> do- case newAlignedPinnedByteArray# sz# 8# s of { (# s2, mba #) ->- case copyByteArray# a 0# mba 0# sz# s2 of { s3 ->- case unsafeFreezeByteArray# mba s3 of { (# s4, ba #) -> (# s4, TmpBA ba #) }}}- r <- f (Ptr (byteArrayContents# ba))- unsafePrimFromIO $ primitive $ \s -> case touch# ba s of { s2 -> (# s2, () #) }+withPtr a f+ | isPinned a == Pinned =+ onBackendPrim (\ba -> f (Ptr (byteArrayContents# ba) `plusPtr` os))+ (\fptr -> withFinalPtr fptr $ \ptr -> f (ptr `plusPtr` os))+ a+ | otherwise = do+ arr <- do+ trampoline <- newPinned (length a)+ unsafeCopyAtRO trampoline 0 a 0 (length a)+ unsafeFreeze trampoline+ r <- withPtr arr f+ touch arr pure r where- sz = primSizeInBytes (vectorProxyTy vec)- !(Offset os) = offsetOfE sz start+ !sz = primSizeInBytes (Proxy :: Proxy ty)+ !(Offset os) = offsetOfE sz $ offset a {-# INLINE withPtr #-} -- | Recast an array of type a to an array of b@@ -687,98 +335,103 @@ missing = alen `mod` bs unsafeRecast :: (PrimType a, PrimType b) => UArray a -> UArray b-unsafeRecast (UVecBA start len pinStatus b) = UVecBA (primOffsetRecast start) (sizeRecast len) pinStatus b-unsafeRecast (UVecAddr start len a) = UVecAddr (primOffsetRecast start) (sizeRecast len) (castFinalPtr a)+unsafeRecast (UArray start len backend) = UArray (primOffsetRecast start) (sizeRecast len) $+ case backend of+ UArrayAddr fptr -> UArrayAddr (castFinalPtr fptr)+ UArrayBA (Block ba) -> UArrayBA (Block ba) {-# INLINE [1] unsafeRecast #-}-{-# RULES "unsafeRecast from Word8" [2] forall a . unsafeRecast a = unsafeRecastBytes a #-}--unsafeRecastBytes :: PrimType a => UArray Word8 -> UArray a-unsafeRecastBytes (UVecBA start len pinStatus b) = UVecBA (primOffsetRecast start) (sizeRecast len) pinStatus b-unsafeRecastBytes (UVecAddr start len a) = UVecAddr (primOffsetRecast start) (sizeRecast len) (castFinalPtr a)-{-# INLINE [1] unsafeRecastBytes #-}+{-# SPECIALIZE [3] unsafeRecast :: PrimType a => UArray Word8 -> UArray a #-} null :: UArray ty -> Bool-null (UVecBA _ sz _ _) = sz == CountOf 0-null (UVecAddr _ l _) = l == CountOf 0+null arr = length arr == 0 -- | Take a count of elements from the array and create an array with just those elements-take :: PrimType ty => CountOf ty -> UArray ty -> UArray ty-take n v+take :: CountOf ty -> UArray ty -> UArray ty+take n arr@(UArray start len backend) | n <= 0 = empty- | n >= vlen = v- | otherwise =- case v of- UVecBA start _ pinst ba -> UVecBA start n pinst ba- UVecAddr start _ fptr -> UVecAddr start n fptr- where- vlen = length v+ | n >= len = arr+ | otherwise = UArray start n backend -unsafeTake :: PrimType ty => CountOf ty -> UArray ty -> UArray ty-unsafeTake sz (UVecBA start _ pinst ba) = UVecBA start sz pinst ba-unsafeTake sz (UVecAddr start _ fptr) = UVecAddr start sz fptr+unsafeTake :: CountOf ty -> UArray ty -> UArray ty+unsafeTake sz (UArray start _ ba) = UArray start sz ba -- | Drop a count of elements from the array and return the new array minus those dropped elements-drop :: PrimType ty => CountOf ty -> UArray ty -> UArray ty-drop n v- | n <= 0 = v- | n >= vlen = empty- | otherwise =- case v of- UVecBA start len pinst ba -> UVecBA (start `offsetPlusE` n) (len - n) pinst ba- UVecAddr start len fptr -> UVecAddr (start `offsetPlusE` n) (len - n) fptr- where- vlen = length v+drop :: CountOf ty -> UArray ty -> UArray ty+drop n arr@(UArray start len backend)+ | n <= 0 = arr+ | n >= len = empty+ | otherwise = UArray (start `offsetPlusE` n) (len - n) backend -unsafeDrop :: PrimType ty => CountOf ty -> UArray ty -> UArray ty-unsafeDrop n (UVecBA start sz pinst ba) = UVecBA (start `offsetPlusE` sz) (sz `sizeSub` n) pinst ba-unsafeDrop n (UVecAddr start sz fptr) = UVecAddr (start `offsetPlusE` sz) (sz `sizeSub` n) fptr+unsafeDrop :: CountOf ty -> UArray ty -> UArray ty+unsafeDrop n (UArray start sz backend) = UArray (start `offsetPlusE` n) (sz `sizeSub` n) backend -- | Split an array into two, with a count of at most N elements in the first one -- and the remaining in the other.-splitAt :: PrimType ty => CountOf ty -> UArray ty -> (UArray ty, UArray ty)-splitAt nbElems v- | nbElems <= 0 = (empty, v)- | n == vlen = (v, empty)- | otherwise =- case v of- UVecBA start len pinst ba -> ( UVecBA start n pinst ba- , UVecBA (start `offsetPlusE` n) (len - n) pinst ba)- UVecAddr start len fptr -> ( UVecAddr start n fptr- , UVecAddr (start `offsetPlusE` n) (len - n) fptr)+splitAt :: CountOf ty -> UArray ty -> (UArray ty, UArray ty)+splitAt nbElems arr@(UArray start len backend)+ | nbElems <= 0 = (empty, arr)+ | n == len = (arr, empty)+ | otherwise = (UArray start n backend, UArray (start `offsetPlusE` n) (len - n) backend) where- n = min nbElems vlen- vlen = length v+ n = min nbElems len -splitElem :: PrimType ty => ty -> UArray ty -> (# UArray ty, UArray ty #)-splitElem !ty r@(UVecBA start len pinst ba)- | k == end = (# r, empty #)- | k == start = (# empty, r #)- | otherwise =- (# UVecBA start (offsetAsSize k - offsetAsSize start) pinst ba- , UVecBA k (len - (offsetAsSize k - offsetAsSize start)) pinst ba- #)+breakElem :: PrimType ty => ty -> UArray ty -> (UArray ty, UArray ty)+breakElem !ty arr@(UArray start len backend)+ | k == end = (arr, empty)+ | k == start = (empty, arr)+ | otherwise = ( UArray start (offsetAsSize k - offsetAsSize start) backend+ , UArray k (len - (offsetAsSize k - offsetAsSize start)) backend) where !end = start `offsetPlusE` len- !k = loop start- loop !i | i < end && t /= ty = loop (i+Offset 1)- | otherwise = i- where t = primBaIndex ba i-splitElem !ty r@(UVecAddr start len fptr)- | k == end = (# r, empty #)- | otherwise =- (# UVecAddr start (offsetAsSize k - offsetAsSize start) fptr- , UVecAddr k (len - (offsetAsSize k - offsetAsSize start)) fptr- #)+ !k = onBackend goBa (\fptr -> pure . goAddr fptr) arr+ goBa ba = PrimBA.findIndexElem ty ba start end+ goAddr _ (Ptr addr) = PrimAddr.findIndexElem ty addr start end+{-# NOINLINE [3] breakElem #-}+{-# RULES "breakElem Word8" [3] breakElem = breakElemByte #-}+{-# SPECIALIZE [3] breakElem :: Word32 -> UArray Word32 -> (UArray Word32, UArray Word32) #-}++breakElemByte :: Word8 -> UArray Word8 -> (UArray Word8, UArray Word8)+breakElemByte !ty arr@(UArray start len backend)+ | k == end = (arr, empty)+ | k == start = (empty, arr)+ | otherwise = ( UArray start (offsetAsSize k - offsetAsSize start) backend+ , UArray k (len - (offsetAsSize k - offsetAsSize start)) backend) where- !(Ptr addr) = withFinalPtrNoTouch fptr id !end = start `offsetPlusE` len- !k = loop start- loop !i | i < end && t /= ty = loop (i+Offset 1)- | otherwise = i- where t = primAddrIndex addr i-{-# SPECIALIZE [3] splitElem :: Word8 -> UArray Word8 -> (# UArray Word8, UArray Word8 #) #-}-{-# SPECIALIZE [3] splitElem :: Word32 -> UArray Word32 -> (# UArray Word32, UArray Word32 #) #-}+ !k = onBackend goBa (\fptr -> pure . goAddr fptr) arr+ goBa ba = sysHsMemFindByteBa ba start end ty+ goAddr _ (Ptr addr) = sysHsMemFindByteAddr addr start end ty +-- | Similar to breakElem specialized to split on linefeed+--+-- it either returns:+-- * Left. no line has been found, and whether the last character is a CR+-- * Right, a line has been found with an optional CR, and it returns+-- the array of bytes on the left of the CR/LF, and the+-- the array of bytes on the right of the LF.+--+breakLine :: UArray Word8 -> Either Bool (UArray Word8, UArray Word8)+breakLine arr@(UArray start len backend)+ | end == start = Left False+ | k2 == end = Left (k1 /= k2)+ | k2 == start = Right (empty, if k2 + 1 == end then empty else unsafeDrop 1 arr)+ | otherwise = Right ( unsafeTake (offsetAsSize k1 - offsetAsSize start) arr+ , if k2+1 == end then empty else UArray (k2+1) (len - (offsetAsSize (k2+1) - offsetAsSize start)) backend)+ where+ !end = start `offsetPlusE` len+ -- return (offset of CR, offset of LF, whether the last element was a carriage return+ !(k1, k2) = onBackend goBa (\fptr -> pure . goAddr fptr) arr+ lineFeed = 0xa+ carriageReturn = 0xd+ goBa ba =+ let k = sysHsMemFindByteBa ba start end lineFeed+ cr = if k > start then PrimBA.primIndex ba (k `offsetSub` 1) == carriageReturn else False+ in (if cr then k `offsetSub` 1 else k, k)+ goAddr _ (Ptr addr) =+ let k = sysHsMemFindByteAddr addr start end lineFeed+ cr = if k > start then PrimAddr.primIndex addr (k `offsetSub` 1) == carriageReturn else False+ in (if cr then k `offsetSub` 1 else k, k)+ -- inverse a CountOf that is specified from the end (e.g. take n elements from the end) countFromStart :: UArray ty -> CountOf ty -> CountOf ty countFromStart v sz@(CountOf sz')@@ -787,17 +440,17 @@ where len@(CountOf len') = length v -- | Take the N elements from the end of the array-revTake :: PrimType ty => CountOf ty -> UArray ty -> UArray ty+revTake :: CountOf ty -> UArray ty -> UArray ty revTake n v = drop (countFromStart v n) v -- | Drop the N elements from the end of the array-revDrop :: PrimType ty => CountOf ty -> UArray ty -> UArray ty+revDrop :: CountOf ty -> UArray ty -> UArray ty revDrop n v = take (countFromStart v n) v -- | Split an array at the N element from the end, and return -- the last N elements in the first part of the tuple, and whatever first -- elements remaining in the second-revSplitAt :: PrimType ty => CountOf ty -> UArray ty -> (UArray ty, UArray ty)+revSplitAt :: CountOf ty -> UArray ty -> (UArray ty, UArray ty) revSplitAt n v = (drop sz v, take sz v) where sz = countFromStart v n splitOn :: PrimType ty => (ty -> Bool) -> UArray ty -> [UArray ty]@@ -818,20 +471,13 @@ else loop prevIdx idx' {-# INLINE go #-} -pureST :: a -> ST s a-pureST = pure- sub :: PrimType ty => UArray ty -> Offset ty -> Offset ty -> UArray ty-sub vec startIdx expectedEndIdx- | startIdx >= endIdx = empty- | otherwise =- case vec of- UVecBA start _ pinst ba -> UVecBA (start + startIdx) newLen pinst ba- UVecAddr start _ fptr -> UVecAddr (start + startIdx) newLen fptr+sub (UArray start len backend) startIdx expectedEndIdx+ | startIdx >= endIdx = mempty+ | otherwise = UArray (start + startIdx) newLen backend where newLen = endIdx - startIdx endIdx = min expectedEndIdx (0 `offsetPlusE` len)- len = length vec findIndex :: forall ty . PrimType ty => ty -> UArray ty -> Maybe (Offset ty) findIndex tyOuter ba = runST $ unsafeIndexer ba (go tyOuter)@@ -842,22 +488,22 @@ go ty getIdx = loop (Offset 0) where loop ofs- | ofs .==# len = return Nothing- | getIdx ofs == ty = return $ Just ofs+ | ofs .==# len = pure Nothing+ | getIdx ofs == ty = pure $ Just ofs | otherwise = loop (ofs + Offset 1) {-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} break :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) break xpredicate xv- | len == 0 = (empty, empty)+ | len == 0 = (mempty, mempty) | otherwise = runST $ unsafeIndexer xv (go xv xpredicate) where !len = length xv go :: PrimType ty => UArray ty -> (ty -> Bool) -> (Offset ty -> ty) -> ST s (UArray ty, UArray ty)- go v predicate getIdx = return (findBreak $ Offset 0)+ go v predicate getIdx = pure (findBreak $ Offset 0) where findBreak !i- | i .==# len = (v, empty)+ | i .==# len = (v, mempty) | predicate (getIdx i) = splitAt (offsetAsSize i) v | otherwise = findBreak (i + Offset 1) {-# INLINE findBreak #-}@@ -871,31 +517,13 @@ {-# RULES "break (== ty)" [3] forall (x :: Word8) . break (== x) = breakElem x #-} -} -breakElem :: PrimType ty => ty -> UArray ty -> (UArray ty, UArray ty)-breakElem xelem xv = let (# v1, v2 #) = splitElem xelem xv in (v1, v2)-{-# SPECIALIZE [2] breakElem :: Word8 -> UArray Word8 -> (UArray Word8, UArray Word8) #-}-{-# SPECIALIZE [2] breakElem :: Word32 -> UArray Word32 -> (UArray Word32, UArray Word32) #-}- elem :: PrimType ty => ty -> UArray ty -> Bool-elem !ty (UVecBA start len _ ba)- | k == end = False- | otherwise = True- where- !end = start `offsetPlusE` len- !k = loop start- loop !i | i < end && t /= ty = loop (i+Offset 1)- | otherwise = i- where t = primBaIndex ba i-elem ty (UVecAddr start len fptr)- | k == end = False- | otherwise = True+elem !ty arr = onBackend goBa (\_ -> pure . goAddr) arr /= end where- !(Ptr addr) = withFinalPtrNoTouch fptr id- !end = start `offsetPlusE` len- !k = loop start- loop !i | i < end && t /= ty = loop (i+Offset 1)- | otherwise = i- where t = primAddrIndex addr i+ !start = offset arr+ !end = start `offsetPlusE` length arr+ goBa ba = PrimBA.findIndexElem ty ba start end+ goAddr (Ptr addr) = PrimAddr.findIndexElem ty addr start end {-# SPECIALIZE [2] elem :: Word8 -> UArray Word8 -> Bool #-} intersperse :: forall ty . PrimType ty => ty -> UArray ty -> UArray ty@@ -975,7 +603,7 @@ sortBy :: forall ty . PrimType ty => (ty -> ty -> Ordering) -> UArray ty -> UArray ty sortBy xford vec- | len == 0 = empty+ | len == 0 = mempty | otherwise = runST (thaw vec >>= doSort xford) where len = length vec@@ -983,7 +611,7 @@ doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma where qsort lo hi- | lo >= hi = return ()+ | lo >= hi = pure () | otherwise = do p <- partition lo hi qsort lo (pred p)@@ -991,16 +619,16 @@ partition lo hi = do pivot <- unsafeRead ma hi let loop i j- | j == hi = return i+ | j == hi = pure i | otherwise = do aj <- unsafeRead ma j i' <- if ford aj pivot == GT- then return i+ then pure i else do ai <- unsafeRead ma i unsafeWrite ma j ai unsafeWrite ma i aj- return $ i + 1+ pure $ i + 1 loop i' (j+1) i <- loop lo lo@@ -1008,66 +636,47 @@ ahi <- unsafeRead ma hi unsafeWrite ma hi ai unsafeWrite ma i ahi- return i+ pure i filter :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> UArray ty filter predicate arr = runST $ do (newLen, ma) <- newNative (length arr) $ \mba ->- case arr of- (UVecAddr start _ fptr) -> withFinalPtr fptr (goAddr mba start)- (UVecBA start _ _ ba) -> goBA mba ba start+ onBackendPrim (\ba -> PrimBA.filter predicate mba ba start end)+ (\fptr -> withFinalPtr fptr $ \(Ptr addr) ->+ PrimAddr.filter predicate mba addr start end)+ arr unsafeFreezeShrink ma newLen where- !len = length arr- o1 = Offset 1-- goBA :: PrimType ty => MutableByteArray# s -> ByteArray# -> Offset ty -> ST s (CountOf ty)- goBA dst src start = loop azero start- where- end = start `offsetPlusE` len- loop !d !s- | s == end = pure (offsetAsSize d)- | predicate v = primMbaWrite dst d v >> loop (d+o1) (s+o1)- | otherwise = loop d (s+o1)- where- v = primBaIndex src s- goAddr :: PrimType ty => MutableByteArray# s -> Offset ty -> (Ptr addr) -> ST s (CountOf ty)- goAddr dst start (Ptr addr) = loop azero start- where- end = start `offsetPlusE` len- loop !d !s- | s == end = pure (offsetAsSize d)- | predicate v = primMbaWrite dst d v >> loop (d+o1) (s+o1)- | otherwise = loop d (s+o1)- where- v = primAddrIndex addr s+ !len = length arr+ !start = offset arr+ !end = start `offsetPlusE` len reverse :: PrimType ty => UArray ty -> UArray ty reverse a- | len == CountOf 0 = empty- | otherwise = runST $ do- ((), ma) <- newNative len $ \mba ->- case a of- (UVecBA start _ _ ba) -> goNative endOfs mba ba start- (UVecAddr start _ fptr) -> withFinalPtr fptr $ \ptr -> goAddr endOfs mba ptr start+ | len == 0 = mempty+ | otherwise = runST $ do+ ((), ma) <- newNative len $ \mba -> onBackendPrim (goNative mba)+ (\fptr -> withFinalPtr fptr $ goAddr mba)+ a unsafeFreeze ma where !len = length a- !endOfs = Offset 0 `offsetPlusE` len+ !end = 0 `offsetPlusE` len+ !start = offset a+ !endI = sizeAsOffset ((start + end) - Offset 1) - goNative :: PrimType ty => Offset ty -> MutableByteArray# s -> ByteArray# -> Offset ty -> ST s ()- goNative !end !ma !ba !srcStart = loop (Offset 0)+ goNative :: MutableByteArray# s -> ByteArray# -> ST s ()+ goNative !ma !ba = loop 0 where- !endI = sizeAsOffset ((srcStart + end) - Offset 1) loop !i- | i == end = return ()- | otherwise = primMbaWrite ma i (primBaIndex ba (sizeAsOffset (endI - i))) >> loop (i+Offset 1)- goAddr !end !ma (Ptr ba) !srcStart = loop (Offset 0)+ | i == end = pure ()+ | otherwise = primMbaWrite ma i (primBaIndex ba (sizeAsOffset (endI - i))) >> loop (i+1)+ goAddr :: MutableByteArray# s -> Ptr ty -> ST s ()+ goAddr !ma (Ptr addr) = loop 0 where- !endI = sizeAsOffset ((srcStart + end) - Offset 1) loop !i- | i == end = return ()- | otherwise = primMbaWrite ma i (primAddrIndex ba (sizeAsOffset (endI - i))) >> loop (i+Offset 1)+ | i == end = pure ()+ | otherwise = primMbaWrite ma i (primAddrIndex addr (sizeAsOffset (endI - i))) >> loop (i+1) {-# SPECIALIZE [3] reverse :: UArray Word8 -> UArray Word8 #-} -- Finds where are the insertion points when we search for a `needle`@@ -1091,7 +700,7 @@ in case matcher == needle of -- TODO: Move away from right-appending as it's gonna be slow. True -> go (currentOffset `offsetPlusE` needleLen) (ipoints <> [currentOffset])- False -> go (currentOffset + Offset 1) ipoints+ False -> go (currentOffset + 1) ipoints -- | Replace all the occurrencies of `needle` with `replacement` in -- the `haystack` string.@@ -1101,7 +710,7 @@ True -> error "Foundation.Array.Unboxed.replace: empty needle" False -> do let insertionPoints = indices needle haystack- let !occs = Prelude.length insertionPoints+ let !occs = List.length insertionPoints let !newLen = haystackLen - (multBy needleLen occs) + (multBy replacementLen occs) ms <- new newLen loop ms (Offset 0) (Offset 0) insertionPoints@@ -1149,38 +758,46 @@ | otherwise = unsafeIndex vec i `f` loop (i+1) foldl' :: PrimType ty => (a -> ty -> a) -> a -> UArray ty -> a-foldl' f initialAcc vec = loop 0 initialAcc+foldl' f initialAcc arr = onBackend goNative (\_ -> pure . goAddr) arr where- !len = length vec- loop i !acc- | i .==# len = acc- | otherwise = loop (i+1) (f acc (unsafeIndex vec i))+ !len = length arr+ !start = offset arr+ !end = start `offsetPlusE` len+ goNative ba = PrimBA.foldl f initialAcc ba start end+ goAddr (Ptr ptr) = PrimAddr.foldl f initialAcc ptr start end+{-# SPECIALIZE [3] foldl' :: (a -> Word8 -> a) -> a -> UArray Word8 -> a #-} foldl1' :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty-foldl1' f arr = let (initialAcc, rest) = splitAt 1 $ getNonEmpty arr- in foldl' f (unsafeIndex initialAcc 0) rest+foldl1' f (NonEmpty arr) = onBackend goNative (\_ -> pure . goAddr) arr+ where+ !len = length arr+ !start = offset arr+ !end = start `offsetPlusE` len+ goNative ba = PrimBA.foldl1 f ba start end+ goAddr (Ptr ptr) = PrimAddr.foldl1 f ptr start end+{-# SPECIALIZE [3] foldl1' :: (Word8 -> Word8 -> Word8) -> NonEmpty (UArray Word8) -> Word8 #-} foldr1 :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (UArray ty) -> ty foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr in foldr f (unsafeIndex initialAcc 0) rest all :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool-all p uv = loop 0+all predicate arr = onBackend (\ba -> PrimBA.all predicate ba start end)+ (\_ (Ptr ptr) -> pure (PrimAddr.all predicate ptr start end))+ arr where- len = length uv- loop !i- | i .==# len = True- | not $ p (unsafeIndex uv i) = False- | otherwise = loop (i + 1)+ start = offset arr+ end = start `offsetPlusE` length arr+{-# SPECIALIZE [3] all :: (Word8 -> Bool) -> UArray Word8 -> Bool #-} any :: PrimType ty => (ty -> Bool) -> UArray ty -> Bool-any p uv = loop 0+any predicate arr = onBackend (\ba -> PrimBA.any predicate ba start end)+ (\_ (Ptr ptr) -> pure (PrimAddr.any predicate ptr start end))+ arr where- len = length uv- loop !i- | i .==# len = False- | p (unsafeIndex uv i) = True- | otherwise = loop (i + 1)+ start = offset arr+ end = start `offsetPlusE` length arr+{-# SPECIALIZE [3] any :: (Word8 -> Bool) -> UArray Word8 -> Bool #-} builderAppend :: (PrimType ty, PrimMonad state) => ty -> Builder (UArray ty) (MUArray ty) ty state err () builderAppend v = Builder $ State $ \(i, st, e) ->@@ -1189,13 +806,13 @@ cur <- unsafeFreeze (curChunk st) newChunk <- new (chunkSize st) unsafeWrite newChunk 0 v- return ((), (Offset 1, st { prevChunks = cur : prevChunks st- , prevChunksSize = chunkSize st + prevChunksSize st- , curChunk = newChunk- }, e))+ pure ((), (Offset 1, st { prevChunks = cur : prevChunks st+ , prevChunksSize = chunkSize st + prevChunksSize st+ , curChunk = newChunk+ }, e)) else do unsafeWrite (curChunk st) i v- return ((), (i + 1, st, e))+ pure ((), (i + 1, st, e)) builderBuild :: (PrimType ty, PrimMonad m) => Int -> Builder (UArray ty) (MUArray ty) ty m err () -> m (Either err (UArray ty)) builderBuild sizeChunksI ab@@ -1204,17 +821,17 @@ first <- new sizeChunks ((), (i, st, e)) <- runState (runBuilder ab) (Offset 0, BuildingState [] (CountOf 0) first sizeChunks, Nothing) case e of- Just err -> return (Left err)+ Just err -> pure (Left err) Nothing -> do cur <- unsafeFreezeShrink (curChunk st) (offsetAsSize i) -- Build final array let totalSize = prevChunksSize st + offsetAsSize i bytes <- new totalSize >>= fillFromEnd totalSize (cur : prevChunks st) >>= unsafeFreeze- return (Right bytes)+ pure (Right bytes) where sizeChunks = CountOf sizeChunksI - fillFromEnd _ [] mua = return mua+ fillFromEnd _ [] mua = pure mua fillFromEnd !end (x:xs) mua = do let sz = length x unsafeCopyAtRO mua (sizeAsOffset (end - sz)) x (Offset 0) sz@@ -1225,7 +842,7 @@ toHexadecimal :: PrimType ty => UArray ty -> UArray Word8 toHexadecimal ba- | len == CountOf 0 = empty+ | len == CountOf 0 = mempty | otherwise = runST $ do ma <- new (len `scale` 2) unsafeIndexer b8 (go ma)@@ -1239,7 +856,7 @@ go !ma !getAt = loop 0 0 where loop !dIdx !sIdx- | sIdx == endOfs = return ()+ | sIdx == endOfs = pure () | otherwise = do let !(W8# !w) = getAt sIdx (# wHi, wLo #) = Base16.unsafeConvertByte w@@ -1249,7 +866,7 @@ toBase64Internal :: PrimType ty => Addr# -> UArray ty -> Bool -> UArray Word8 toBase64Internal table src padded- | len == CountOf 0 = empty+ | len == CountOf 0 = mempty | otherwise = runST $ do ma <- new dstLen unsafeIndexer b8 (go ma)@@ -1259,6 +876,7 @@ !len = length b8 !dstLen = outputLengthBase64 padded len !endOfs = Offset 0 `offsetPlusE` len+ !dstEndOfs = Offset 0 `offsetPlusE` dstLen go :: MUArray Word8 s -> (Offset Word8 -> Word8) -> ST s () go !ma !getAt = loop 0 0@@ -1266,43 +884,44 @@ eqChar = 0x3d :: Word8 loop !sIdx !dIdx- | sIdx >= endOfs = return ()+ | sIdx == endOfs = when padded $ do+ when (dIdx `offsetPlusE` CountOf 1 <= dstEndOfs) $ unsafeWrite ma dIdx eqChar+ when (dIdx `offsetPlusE` CountOf 2 == dstEndOfs) $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 1) eqChar | otherwise = do- let !a = getAt sIdx- !b = if sIdx `offsetPlusE` CountOf 1 >= endOfs then 0 else getAt (sIdx `offsetPlusE` CountOf 1)- !c = if sIdx `offsetPlusE` CountOf 2 >= endOfs then 0 else getAt (sIdx `offsetPlusE` CountOf 2)+ let !b2Idx = sIdx `offsetPlusE` CountOf 1+ !b3Idx = sIdx `offsetPlusE` CountOf 2 - let (w,x,y,z) = convert3 table a b c+ !b2Available = b2Idx < endOfs+ !b3Available = b3Idx < endOfs + !b1 = getAt sIdx+ !b2 = if b2Available then getAt b2Idx else 0+ !b3 = if b3Available then getAt b3Idx else 0++ (w,x,y,z) = convert3 table b1 b2 b3++ sNextIncr = 1 + fromEnum b2Available + fromEnum b3Available+ dNextIncr = 1 + sNextIncr+ unsafeWrite ma dIdx w unsafeWrite ma (dIdx `offsetPlusE` CountOf 1) x - if sIdx `offsetPlusE` CountOf 1 < endOfs- then- unsafeWrite ma (dIdx `offsetPlusE` CountOf 2) y- else- when padded (unsafeWrite ma (dIdx `offsetPlusE` CountOf 2) eqChar)- if sIdx `offsetPlusE` CountOf 2 < endOfs- then- unsafeWrite ma (dIdx `offsetPlusE` CountOf 3) z- else- when padded (unsafeWrite ma (dIdx `offsetPlusE` CountOf 3) eqChar)+ when b2Available $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 2) y+ when b3Available $ unsafeWrite ma (dIdx `offsetPlusE` CountOf 3) z - loop (sIdx `offsetPlusE` CountOf 3) (dIdx `offsetPlusE` CountOf 4)+ loop (sIdx `offsetPlusE` CountOf sNextIncr) (dIdx `offsetPlusE` CountOf dNextIncr) outputLengthBase64 :: Bool -> CountOf Word8 -> CountOf Word8 outputLengthBase64 padding (CountOf inputLenInt) = outputLength where- outputLength = if padding then CountOf lenWithPadding else CountOf (lenWithPadding - numPadChars)-- lenWithPadding :: Int- lenWithPadding = 4 * roundUp (Prelude.fromIntegral inputLenInt / 3.0 :: Double)-- numPadChars :: Int- numPadChars = case inputLenInt `mod` 3 of- 1 -> 2- 2 -> 1- _ -> 0+ outputLength = if padding then CountOf lenWithPadding else CountOf lenWithoutPadding+ lenWithPadding+ | m == 0 = 4 * d+ | otherwise = 4 * (d + 1)+ lenWithoutPadding+ | m == 0 = 4 * d+ | otherwise = 4 * d + m + 1+ (d,m) = inputLenInt `divMod` 3 convert3 :: Addr# -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8) convert3 table (W8# a) (W8# b) (W8# c) =@@ -1314,3 +933,21 @@ where idx :: Word# -> Word8 idx i = W8# (indexWord8OffAddr# table (word2Int# i))++isPrefixOf :: PrimType ty => UArray ty -> UArray ty -> Bool+isPrefixOf pre arr+ | pLen > pArr = False+ | otherwise = pre == unsafeTake pLen arr+ where+ !pLen = length pre+ !pArr = length arr+{-# SPECIALIZE [3] isPrefixOf :: UArray Word8 -> UArray Word8 -> Bool #-}++isSuffixOf :: PrimType ty => UArray ty -> UArray ty -> Bool+isSuffixOf suffix arr+ | pLen > pArr = False+ | otherwise = suffix == revTake pLen arr+ where+ !pLen = length suffix+ !pArr = length arr+{-# SPECIALIZE [3] isSuffixOf :: UArray Word8 -> UArray Word8 -> Bool #-}
Foundation/Array/Unboxed/ByteArray.hs view
@@ -19,7 +19,7 @@ -- naive haskell way. TODO: call memset or a 32-bit/64-bit method forM_ [0..(sizeLastOffset len)] $ \i -> unsafeWrite mba i val where- len = mutableLengthSize mba+ len = mutableLength mba {- mutableByteArraySetBetween :: PrimMonad prim => MUArray Word8 (PrimState prim) -> Word8 -> Offset Word8 -> CountOf Word8 -> prim ()
Foundation/Array/Unboxed/Mutable.hs view
@@ -1,6 +1,5 @@ -- |--- Module : Foundation.Array.Unboxed.Mutable--- License : BSD-style+-- Module : Foundation.Array.Unboxed.Mutable -- License : BSD-style -- Maintainer : Vincent Hanquez <vincent@snarc.org> -- Stability : experimental -- Portability : portable@@ -18,8 +17,9 @@ -- * Property queries , sizeInMutableBytesOfContent , mutableLength- , mutableLengthSize+ , mutableOffset , mutableSame+ , onMutableBackend -- * Allocation & Copy , new , newPinned@@ -42,7 +42,6 @@ import GHC.Types import GHC.Ptr import Foundation.Internal.Base-import qualified Foundation.Primitive.Runtime as Runtime import Foundation.Internal.Primitive import Foundation.Internal.Proxy import Foundation.Primitive.Types.OffsetSize@@ -50,31 +49,16 @@ import Foundation.Primitive.Types import Foundation.Primitive.FinalPtr import Foundation.Primitive.Exception+import qualified Foundation.Primitive.Block.Mutable as MBLK+import Foundation.Primitive.Block (MutableBlock(..))+import Foundation.Primitive.UArray.Base hiding (empty) import Foundation.Numerical import Foreign.Marshal.Utils (copyBytes) --- | A Mutable array of types built on top of GHC primitive.------ Element in this array can be modified in place.-data MUArray ty st =- MUVecMA {-# UNPACK #-} !(Offset ty)- {-# UNPACK #-} !(CountOf ty)- {-# UNPACK #-} !PinnedStatus- (MutableByteArray# st)- | MUVecAddr {-# UNPACK #-} !(Offset ty)- {-# UNPACK #-} !(CountOf ty)- !(FinalPtr ty)--mutableArrayProxyTy :: MUArray ty st -> Proxy ty-mutableArrayProxyTy _ = Proxy--sizeInMutableBytesOfContent :: PrimType ty => MUArray ty s -> Size8-sizeInMutableBytesOfContent = primSizeInBytes . mutableArrayProxyTy+sizeInMutableBytesOfContent :: forall ty s . PrimType ty => MUArray ty s -> Size8+sizeInMutableBytesOfContent _ = primSizeInBytes (Proxy :: Proxy ty) {-# INLINE sizeInMutableBytesOfContent #-} -mvectorProxyTy :: MUArray ty s -> Proxy ty-mvectorProxyTy _ = Proxy- -- | read a cell in a mutable array. -- -- If the index is out of bounds, an error is raised.@@ -82,18 +66,9 @@ read array n | isOutOfBound n len = primOutOfBound OOB_Read n len | otherwise = unsafeRead array n- where len = mutableLengthSize array+ where len = mutableLength array {-# INLINE read #-} --- | read from a cell in a mutable array without bounds checking.------ Reading from invalid memory can return unpredictable and invalid values.--- use 'read' if unsure.-unsafeRead :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> prim ty-unsafeRead (MUVecMA start _ _ mba) i = primMbaRead mba (start + i)-unsafeRead (MUVecAddr start _ fptr) i = withFinalPtr fptr $ \(Ptr addr) -> primAddrRead addr (start + i)-{-# INLINE unsafeRead #-}- -- | Write to a cell in a mutable array. -- -- If the index is out of bounds, an error is raised.@@ -102,177 +77,54 @@ | isOutOfBound n len = primOutOfBound OOB_Write n len | otherwise = unsafeWrite array n val where- len = mutableLengthSize array+ len = mutableLength array {-# INLINE write #-} --- | write to a cell in a mutable array without bounds checking.------ Writing with invalid bounds will corrupt memory and your program will--- become unreliable. use 'write' if unsure.-unsafeWrite :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> ty -> prim ()-unsafeWrite (MUVecMA start _ _ mba) i v = primMbaWrite mba (start+i) v-unsafeWrite (MUVecAddr start _ fptr) i v = withFinalPtr fptr $ \(Ptr addr) -> primAddrWrite addr (start+i) v-{-# INLINE unsafeWrite #-}---- | Create a new pinned mutable array of size @n.------ all the cells are uninitialized and could contains invalid values.------ All mutable arrays are allocated on a 64 bits aligned addresses-newPinned :: (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))-newPinned n = newFake n Proxy- where newFake :: (PrimMonad prim, PrimType ty) => CountOf ty -> Proxy ty -> prim (MUArray ty (PrimState prim))- newFake sz ty = primitive $ \s1 ->- case newAlignedPinnedByteArray# bytes 8# s1 of- (# s2, mba #) -> (# s2, MUVecMA (Offset 0) sz pinned mba #)- where- !(CountOf (I# bytes)) = sizeOfE (primSizeInBytes ty) sz- {-# INLINE newFake #-}--newUnpinned :: (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))-newUnpinned n = newFake n Proxy- where newFake :: (PrimMonad prim, PrimType ty) => CountOf ty -> Proxy ty -> prim (MUArray ty (PrimState prim))- newFake sz ty = primitive $ \s1 ->- case newByteArray# bytes s1 of- (# s2, mba #) -> (# s2, MUVecMA (Offset 0) sz unpinned mba #)- where- !(CountOf (I# bytes)) = sizeOfE (primSizeInBytes ty) sz- {-# INLINE newFake #-}--empty :: PrimMonad prim => prim (MUArray ty (PrimState prim))-empty = primitive $ \s1 -> case newByteArray# 0# s1 of { (# s2, mba #) -> (# s2, MUVecMA 0 0 unpinned mba #) }---- | Create a new mutable array of size @n.------ When memory for a new array is allocated, we decide if that memory region--- should be pinned (will not be copied around by GC) or unpinned (can be--- moved around by GC) depending on its size.------ You can change the threshold value used by setting the environment variable--- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@.-new :: (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))-new sz- | sizeRecast sz <= maxSizeUnpinned = newUnpinned sz- | otherwise = newPinned sz- where- -- Safe to use here: If the value changes during runtime, this will only- -- have an impact on newly created arrays.- maxSizeUnpinned = Runtime.unsafeUArrayUnpinnedMaxSize-{-# INLINE new #-}+empty :: (PrimType ty, PrimMonad prim) => prim (MUArray ty (PrimState prim))+empty = MUArray 0 0 . MUArrayMBA <$> MBLK.mutableEmpty mutableSame :: MUArray ty st -> MUArray ty st -> Bool-mutableSame (MUVecMA sa ea _ ma) (MUVecMA sb eb _ mb) = (sa == sb) && (ea == eb) && bool# (sameMutableByteArray# ma mb)-mutableSame (MUVecAddr s1 e1 f1) (MUVecAddr s2 e2 f2) = (s1 == s2) && (e1 == e2) && finalPtrSameMemory f1 f2-mutableSame MUVecMA {} MUVecAddr {} = False-mutableSame MUVecAddr {} MUVecMA {} = False---newNative :: (PrimMonad prim, PrimType ty)- => CountOf ty- -> (MutableByteArray# (PrimState prim) -> prim a)- -> prim (a, MUArray ty (PrimState prim))-newNative n f = do- muvec <- new n- case muvec of- (MUVecMA _ _ _ mba) -> f mba >>= \a -> pure (a, muvec)- MUVecAddr {} -> error "internal error: unboxed new only supposed to allocate natively"+mutableSame (MUArray sa ea (MUArrayMBA (MutableBlock ma))) (MUArray sb eb (MUArrayMBA (MutableBlock mb))) = (sa == sb) && (ea == eb) && bool# (sameMutableByteArray# ma mb)+mutableSame (MUArray s1 e1 (MUArrayAddr f1)) (MUArray s2 e2 (MUArrayAddr f2)) = (s1 == s2) && (e1 == e2) && finalPtrSameMemory f1 f2+mutableSame _ _ = False mutableForeignMem :: (PrimMonad prim, PrimType ty) => FinalPtr ty -- ^ the start pointer with a finalizer -> Int -- ^ the number of elements (in elements, not bytes) -> prim (MUArray ty (PrimState prim))-mutableForeignMem fptr nb = return $ MUVecAddr (Offset 0) (CountOf nb) fptr---- | Copy a number of elements from an array to another array with offsets-copyAt :: (PrimMonad prim, PrimType ty)- => MUArray ty (PrimState prim) -- ^ destination array- -> Offset ty -- ^ offset at destination- -> MUArray ty (PrimState prim) -- ^ source array- -> Offset ty -- ^ offset at source- -> CountOf ty -- ^ number of elements to copy- -> prim ()-copyAt (MUVecMA dstStart _ _ dstMba) ed uvec@(MUVecMA srcStart _ _ srcBa) es n =- primitive $ \st -> (# copyMutableByteArray# srcBa os dstMba od nBytes st, () #)- where- !sz = primSizeInBytes (mutableArrayProxyTy uvec)- !(Offset (I# os)) = offsetOfE sz (srcStart + es)- !(Offset (I# od)) = offsetOfE sz (dstStart + ed)- !(CountOf (I# nBytes)) = sizeOfE sz n-copyAt (MUVecMA dstStart _ _ dstMba) ed muvec@(MUVecAddr srcStart _ srcFptr) es n =- withFinalPtr srcFptr $ \srcPtr ->- let !(Ptr srcAddr) = srcPtr `plusPtr` os- in primitive $ \s -> (# compatCopyAddrToByteArray# srcAddr dstMba od nBytes s, () #)- where- !sz = primSizeInBytes (mutableArrayProxyTy muvec)- !(Offset os) = offsetOfE sz (srcStart + es)- !(Offset (I# od)) = offsetOfE sz (dstStart + ed)- !(CountOf (I# nBytes)) = sizeOfE sz n-copyAt dst od src os n = loop od os- where- !endIndex = os `offsetPlusE` n- loop !d !i- | i == endIndex = return ()- | otherwise = unsafeRead src i >>= unsafeWrite dst d >> loop (d+1) (i+1)+mutableForeignMem fptr nb = pure $ MUArray (Offset 0) (CountOf nb) (MUArrayAddr fptr) sub :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Int -- The number of elements to drop ahead -> Int -- Then the number of element to retain -> prim (MUArray ty (PrimState prim))-sub (MUVecMA start sz pstatus mba) dropElems' takeElems- | takeElems <= 0 = empty- | resultEmpty = empty- | otherwise = return $ MUVecMA (start `offsetPlusE` dropElems) (min (CountOf takeElems) (sz - dropElems)) pstatus mba- where- dropElems = max 0 (CountOf dropElems')- resultEmpty = dropElems >= sz-sub (MUVecAddr start sz addr) dropElems' takeElems+sub (MUArray start sz back) dropElems' takeElems | takeElems <= 0 = empty | resultEmpty = empty- | otherwise = return $ MUVecAddr (start `offsetPlusE` dropElems) (min (CountOf takeElems) (sz - dropElems)) addr+ | otherwise = pure $ MUArray (start `offsetPlusE` dropElems) (min (CountOf takeElems) (sz - dropElems)) back where dropElems = max 0 (CountOf dropElems') resultEmpty = dropElems >= sz -{--copyAddr :: (PrimMonad prim, PrimType ty)- => MUArray ty (PrimState prim) -- ^ destination array- -> Offset ty -- ^ offset at destination- -> Ptr Word8 -- ^ source ptr- -> Offset ty -- ^ offset at source- -> CountOf ty -- ^ number of elements to copy- -> prim ()-copyAddr (MUVecMA dstStart _ _ dst) dstOfs (Ptr src) srcOfs sz = primitive $ \s ->- (# compatCopyAddrToByteArray# (plusAddr# src os) dst od sz s, () #)-copyAddr (MUVecAddr start _ fptr) od src os sz =- withFinalPtr fptr $ \dst ->- unsafePrimFromIO $ copyBytes (dst `plusPtr` od) (src `plusPtr` os) sz- --memcpy addr to addr- -}- -- | return the numbers of elements in a mutable array-mutableLength :: PrimType ty => MUArray ty st -> Int-mutableLength (MUVecMA _ (CountOf end) _ _) = end-mutableLength (MUVecAddr _ (CountOf end) _) = end--mutableLengthSize :: PrimType ty => MUArray ty st -> CountOf ty-mutableLengthSize (MUVecMA _ end _ _) = end-mutableLengthSize (MUVecAddr _ end _) = end+mutableLength :: PrimType ty => MUArray ty st -> CountOf ty+mutableLength (MUArray _ end _) = end -withMutablePtrHint :: (PrimMonad prim, PrimType ty)+withMutablePtrHint :: forall ty prim a . (PrimMonad prim, PrimType ty) => Bool -> Bool -> MUArray ty (PrimState prim) -> (Ptr ty -> prim a) -> prim a-withMutablePtrHint _ _ vec@(MUVecAddr start _ fptr) f =+withMutablePtrHint _ _ (MUArray start _ (MUArrayAddr fptr)) f = withFinalPtr fptr (\ptr -> f (ptr `plusPtr` os)) where- sz = primSizeInBytes (mvectorProxyTy vec)+ sz = primSizeInBytes (Proxy :: Proxy ty) !(Offset os) = offsetOfE sz start-withMutablePtrHint skipCopy skipCopyBack vec@(MUVecMA start vecSz pstatus a) f- | isPinned pstatus = mutableByteArrayContent a >>= \ptr -> f (ptr `plusPtr` os)- | otherwise = do+withMutablePtrHint skipCopy skipCopyBack vec@(MUArray start vecSz (MUArrayMBA (MutableBlock a))) f+ | isMutablePinned vec == Pinned = mutableByteArrayContent a >>= \ptr -> f (ptr `plusPtr` os)+ | otherwise = do trampoline <- newPinned vecSz if not skipCopy then copyAt trampoline 0 vec 0 vecSz@@ -284,7 +136,7 @@ pure r where !(Offset os) = offsetOfE sz start- sz = primSizeInBytes (mvectorProxyTy vec)+ sz = primSizeInBytes (Proxy :: Proxy ty) mutableByteArrayContent :: PrimMonad prim => MutableByteArray# (PrimState prim) -> prim (Ptr ty) mutableByteArrayContent mba = primitive $ \s1 ->@@ -308,35 +160,36 @@ -- | Copy from a pointer, @count@ elements, into the mutable array copyFromPtr :: forall prim ty . (PrimMonad prim, PrimType ty) => Ptr ty -> CountOf ty -> MUArray ty (PrimState prim) -> prim ()-copyFromPtr (Ptr p) count (MUVecMA ofs arrSz _ mba)- | count > arrSz = primOutOfBound OOB_MemCopy (sizeAsOffset count) arrSz- | otherwise = primitive $ \st -> (# copyAddrToByteArray# p mba od countBytes st, () #)- where- !sz = primSizeInBytes (Proxy :: Proxy ty)- !(CountOf (I# countBytes)) = sizeOfE sz count- !(Offset (I# od)) = offsetOfE sz ofs-copyFromPtr p count (MUVecAddr ofs arrSz fptr)+copyFromPtr src@(Ptr src#) count marr | count > arrSz = primOutOfBound OOB_MemCopy (sizeAsOffset count) arrSz- | otherwise = withFinalPtr fptr $ \dstPtr ->- unsafePrimFromIO $ copyBytes (dstPtr `plusPtr` os) p bytes+ | otherwise = onMutableBackend copyNative copyPtr marr where- sz = primSizeInBytes (Proxy :: Proxy ty)- !(CountOf bytes) = sizeOfE sz count- !(Offset os) = offsetOfE sz ofs+ arrSz = mutableLength marr+ ofs = mutableOffset marr + sz = primSizeInBytes (Proxy :: Proxy ty)+ !(CountOf bytes@(I# bytes#)) = sizeOfE sz count+ !(Offset od@(I# od#)) = offsetOfE sz $ ofs++ copyNative mba = primitive $ \st -> (# copyAddrToByteArray# src# mba od# bytes# st, () #)+ copyPtr fptr = withFinalPtr fptr $ \dst ->+ unsafePrimFromIO $ copyBytes (dst `plusPtr` od) src bytes+ -- | Copy all the block content to the memory starting at the destination address copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -- ^ the source mutable array to copy -> Ptr ty -- ^ The destination address where the copy is going to start -> prim ()-copyToPtr (MUVecMA start sz _ ma) (Ptr p) = primitive $ \s1 ->- case unsafeFreezeByteArray# ma s1 of- (# s2, ba #) -> (# compatCopyByteArrayToAddr# ba offset p szBytes s2, () #)- where- !(Offset (I# offset)) = offsetInBytes start- !(CountOf (I# szBytes)) = sizeInBytes sz-copyToPtr (MUVecAddr start sz fptr) dst =- unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> copyBytes dst (ptr `plusPtr` os) szBytes+copyToPtr marr dst@(Ptr dst#) = onMutableBackend copyNative copyPtr marr where- !(Offset os) = offsetInBytes start- !(CountOf szBytes) = sizeInBytes sz+ copyNative mba = primitive $ \s1 ->+ case unsafeFreezeByteArray# mba s1 of+ (# s2, ba #) -> (# compatCopyByteArrayToAddr# ba os# dst# szBytes# s2, () #)+ copyPtr fptr = unsafePrimFromIO $ withFinalPtr fptr $ \ptr ->+ copyBytes dst (ptr `plusPtr` os) szBytes++ !(Offset os@(I# os#)) = offsetInBytes $ mutableOffset marr+ !(CountOf szBytes@(I# szBytes#)) = sizeInBytes $ mutableLength marr++mutableOffset :: MUArray ty st -> Offset ty+mutableOffset (MUArray ofs _ _) = ofs
Foundation/Boot/List.hs view
@@ -1,15 +1,23 @@+{-# LANGUAGE CPP #-} module Foundation.Boot.List ( length , sum+ , reverse ) where import Foundation.Internal.Base import Foundation.Numerical.Additive+import qualified GHC.List as List -- | Compute the size of the list length :: [a] -> Int-length [] = 0-length (_:xs) = succ (length xs)+#if MIN_VERSION_base(4,8,0)+length = List.foldl' (\c _ -> c+1) 0+#else+length = loop 0+ where loop !acc [] = acc+ loop !acc (_:xs) = loop (1+acc) xs+#endif -- | Sum the element in a list sum :: Additive n => [n] -> n@@ -19,3 +27,9 @@ loop !acc [] = acc loop !acc (x:xs) = loop (acc+x) xs {-# INLINE loop #-}++reverse :: [a] -> [a]+reverse l = go l []+ where+ go [] acc = acc+ go (x:xs) acc = go xs (x:acc)
Foundation/Check/Arbitrary.hs view
@@ -11,8 +11,7 @@ import Foundation.Primitive.Imports import Foundation.Primitive-import Foundation.Primitive.IntegralConv (wordToChar)-import Foundation.Primitive.Floating+import Foundation.Primitive.IntegralConv import Foundation.Primitive.Types.OffsetSize import Foundation.Check.Gen import Foundation.Random@@ -32,45 +31,41 @@ -- prim types instance Arbitrary Int where- arbitrary = arbitraryPrimtype+ arbitrary = int64ToInt <$> arbitraryInt64 instance Arbitrary Word where- arbitrary = arbitraryPrimtype+ arbitrary = word64ToWord <$> arbitraryWord64 instance Arbitrary Word64 where- arbitrary = arbitraryPrimtype+ arbitrary = arbitraryWord64 instance Arbitrary Word32 where- arbitrary = arbitraryPrimtype+ arbitrary = integralDownsize <$> arbitraryWord64 instance Arbitrary Word16 where- arbitrary = arbitraryPrimtype+ arbitrary = integralDownsize <$> arbitraryWord64 instance Arbitrary Word8 where- arbitrary = arbitraryPrimtype+ arbitrary = integralDownsize <$> arbitraryWord64 instance Arbitrary Int64 where- arbitrary = arbitraryPrimtype+ arbitrary = arbitraryInt64 instance Arbitrary Int32 where- arbitrary = arbitraryPrimtype+ arbitrary = integralDownsize <$> arbitraryInt64 instance Arbitrary Int16 where- arbitrary = arbitraryPrimtype+ arbitrary = integralDownsize <$> arbitraryInt64 instance Arbitrary Int8 where- arbitrary = arbitraryPrimtype+ arbitrary = integralDownsize <$> arbitraryInt64 instance Arbitrary Char where arbitrary = arbitraryChar instance Arbitrary (CountOf ty) where arbitrary = CountOf <$> arbitrary instance Arbitrary Bool where- arbitrary = flip testBit 0 <$> (arbitraryPrimtype :: Gen Word)+ arbitrary = flip testBit 0 <$> arbitraryWord64 instance Arbitrary String where arbitrary = genWithParams $ \params -> fromList <$> (genMax (genMaxSizeString params) >>= \i -> replicateM (integralCast i) arbitrary) instance Arbitrary Float where- arbitrary = toFloat <$> arbitrary <*> arbitrary <*> arbitrary- where toFloat i n Nothing = integerToFloat i + (naturalToFloat n / 100000)- toFloat i n (Just e) = (integerToFloat i + (naturalToFloat n / 1000000)) * (integerToFloat e)+ arbitrary = arbitraryF32 instance Arbitrary Double where- arbitrary = toDouble <$> arbitrary <*> arbitrary <*> arbitrary- where toDouble i n Nothing = integerToDouble i + (naturalToDouble n / 100000)- toDouble i n (Just e) = (integerToDouble i + (naturalToDouble n / 1000000)) * (integerToDouble e)+ arbitrary = arbitraryF64 instance Arbitrary a => Arbitrary (Maybe a) where arbitrary = frequency $ nonEmpty_ [ (1, pure Nothing), (4, Just <$> arbitrary) ]@@ -121,13 +116,22 @@ , (1, wordToChar <$> genMax 0x10ffff) ] -arbitraryPrimtype :: PrimType ty => Gen ty-arbitraryPrimtype = genWithRng getRandomPrimType+arbitraryWord64 :: Gen Word64+arbitraryWord64 = genWithRng getRandomWord64 -arbitraryUArrayOf :: PrimType ty => Word -> Gen (UArray ty)-arbitraryUArrayOf size =- between (0, size) >>= \sz -> (fromList <$> replicateM (integralCast sz) arbitraryPrimtype)+arbitraryInt64 :: Gen Int64+arbitraryInt64 = integralCast <$> arbitraryWord64 +arbitraryF64 :: Gen Double+arbitraryF64 = genWithRng getRandomF64++arbitraryF32 :: Gen Float+arbitraryF32 = genWithRng getRandomF32++arbitraryUArrayOf :: (PrimType ty, Arbitrary ty) => Word -> Gen (UArray ty)+arbitraryUArrayOf size = between (0, size) >>=+ \sz -> fromList <$> replicateM (integralCast sz) arbitrary+ -- | Call one of the generator weighted frequency :: NonEmpty [(Word, Gen a)] -> Gen a frequency (getNonEmpty -> l) = between (0, sum) >>= pickOne l@@ -151,4 +155,4 @@ where range = y - x genMax :: Word -> Gen Word-genMax m = (flip mod m) <$> arbitraryPrimtype+genMax m = flip mod m <$> arbitrary
Foundation/Check/Main.hs view
@@ -98,7 +98,7 @@ Right c -> pure c -- use the user defined seed or generate a new seed- seed <- maybe getRandomPrimType pure $ udfSeed cfg+ seed <- maybe getRandomWord64 pure $ udfSeed cfg let testState = newState cfg seed
Foundation/Collection.hs view
@@ -14,6 +14,7 @@ , Element , InnerFunctor(..) , Foldable(..)+ , Fold1able(..) , Mappable(..) , traverse_ , mapM_
Foundation/Collection/Collection.hs view
@@ -146,8 +146,8 @@ elem = S.elem minimum = Data.List.minimum . toList . getNonEmpty -- TODO faster implementation maximum = Data.List.maximum . toList . getNonEmpty -- TODO faster implementation- all p = Data.List.all p . toList- any p = Data.List.any p . toList+ all = S.all+ any = S.any instance Collection c => Collection (NonEmpty c) where null _ = False
Foundation/Collection/Sequential.hs view
@@ -192,6 +192,18 @@ | otherwise = loop (succ i) where c2Sub = take len1 $ drop i c2 + -- | Try to strip a prefix from a collection+ stripPrefix :: Eq (Element c) => c -> c -> Maybe c+ stripPrefix pre s+ | isPrefixOf pre s = Just $ drop (length pre) s+ | otherwise = Nothing++ -- | Try to strip a suffix from a collection+ stripSuffix :: Eq (Element c) => c -> c -> Maybe c+ stripSuffix suf s+ | isSuffixOf suf s = Just $ revDrop (length suf) s+ | otherwise = Nothing+ -- Temporary utility functions mconcatCollection :: (Monoid (Item c), Sequential c) => c -> Element c mconcatCollection c = mconcat (toList c)@@ -263,6 +275,8 @@ sortBy = UV.sortBy singleton = fromList . (:[]) replicate = UV.replicate+ isPrefixOf = UV.isPrefixOf+ isSuffixOf = UV.isSuffixOf instance Sequential (BA.Array ty) where take = BA.take@@ -285,6 +299,8 @@ sortBy = BA.sortBy singleton = BA.singleton replicate = BA.replicate+ isSuffixOf = BA.isSuffixOf+ isPrefixOf = BA.isPrefixOf instance Sequential S.String where take = S.take@@ -311,3 +327,5 @@ isSuffixOf = S.isSuffixOf isPrefixOf = S.isPrefixOf isInfixOf = S.isInfixOf+ stripPrefix = S.stripPrefix+ stripSuffix = S.stripSuffix
Foundation/Conduit/Textual.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module Foundation.Conduit.Textual ( lines , words@@ -5,7 +6,7 @@ , toBytes ) where -import Foundation.Internal.Base hiding (throw)+import Foundation.Primitive.Imports hiding (throw) import Foundation.Array.Unboxed (UArray) import Foundation.String (String) import Foundation.Collection@@ -19,22 +20,27 @@ -- This is very similar to Prelude lines except -- it work directly on Conduit ----- Note that if the newline character is not coming,+-- Note that if the newline character is not ever appearing in the stream, -- this function will keep accumulating data until OOM+--+-- TODO: make a size-limited function lines :: Monad m => Conduit String String m ()-lines = await >>= maybe (finish []) (go [])+lines = await >>= maybe (finish []) (go False []) where mconcatRev = mconcat . reverse finish l = if null l then return () else yield (mconcatRev l) - go prevs nextBuf =- case S.uncons next' of- Just (_, rest') -> yield (mconcatRev (line : prevs)) >> go mempty rest'- Nothing ->+ go prevCR prevs nextBuf = do+ case S.breakLine nextBuf of+ Right (line, next)+ | S.null line && prevCR -> yield (mconcatRev (line : stripCRFromHead prevs)) >> go False mempty next+ | otherwise -> yield (mconcatRev (line : prevs)) >> go False mempty next+ Left lastCR -> let nextCurrent = nextBuf : prevs- in await >>= maybe (finish nextCurrent) (go nextCurrent)- where (line, next') = S.breakElem '\n' nextBuf+ in await >>= maybe (finish nextCurrent) (go lastCR nextCurrent)+ stripCRFromHead [] = []+ stripCRFromHead (x:xs) = S.revDrop 1 x:xs words :: Monad m => Conduit String String m () words = await >>= maybe (finish []) (go [])
Foundation/Hashing/FNV.hs view
@@ -25,12 +25,12 @@ import qualified Foundation.Array.Unboxed as A import Foundation.Primitive.Types.OffsetSize import Foundation.Primitive.Types+import Foundation.Primitive.IntegralConv import Foundation.Numerical import Foundation.Hashing.Hasher import Data.Bits import GHC.Prim import GHC.ST-import qualified Prelude -- | FNV1(a) hash (32 bit variants) newtype FNV1Hash32 = FNV1Hash32 Word32@@ -41,11 +41,11 @@ deriving (Show,Eq,Ord) xor32 :: Word -> Word8 -> Word-xor32 !a !b = a `xor` Prelude.fromIntegral b+xor32 !a !b = a `xor` integralUpsize b {-# INLINE xor32 #-} xor64 :: Word64 -> Word8 -> Word64-xor64 !a !b = a `xor` Prelude.fromIntegral b+xor64 !a !b = a `xor` integralUpsize b {-# INLINE xor64 #-} -- | FNV1 32 bit state@@ -81,7 +81,7 @@ type HashInitParam FNV1_32 = Word hashNew = FNV1_32 0 hashNewParam w = FNV1_32 w- hashEnd (FNV1_32 w) = FNV1Hash32 (Prelude.fromIntegral w)+ hashEnd (FNV1_32 w) = FNV1Hash32 (integralDownsize w) hashMix8 = fnv1_32_Mix8 hashMixBytes = fnv1_32_mixBa @@ -90,7 +90,7 @@ type HashInitParam FNV1a_32 = Word hashNew = FNV1a_32 0 hashNewParam w = FNV1a_32 w- hashEnd (FNV1a_32 w) = FNV1Hash32 (Prelude.fromIntegral w)+ hashEnd (FNV1a_32 w) = FNV1Hash32 (integralDownsize w) hashMix8 = fnv1a_32_Mix8 hashMixBytes = fnv1a_32_mixBa @@ -99,7 +99,7 @@ type HashInitParam FNV1_64 = Word64 hashNew = FNV1_64 0xcbf29ce484222325 hashNewParam w = FNV1_64 w- hashEnd (FNV1_64 w) = FNV1Hash64 (Prelude.fromIntegral w)+ hashEnd (FNV1_64 w) = FNV1Hash64 w hashMix8 = fnv1_64_Mix8 hashMixBytes = fnv1_64_mixBa @@ -108,7 +108,7 @@ type HashInitParam FNV1a_64 = Word64 hashNew = FNV1a_64 0xcbf29ce484222325 hashNewParam w = FNV1a_64 w- hashEnd (FNV1a_64 w) = FNV1Hash64 (Prelude.fromIntegral w)+ hashEnd (FNV1a_64 w) = FNV1Hash64 w hashMix8 = fnv1a_64_Mix8 hashMixBytes = fnv1a_64_mixBa
Foundation/Hashing/Hashable.hs view
@@ -14,6 +14,7 @@ import Foundation.Internal.Base import Foundation.Internal.Natural+import Foundation.Primitive.IntegralConv import Foundation.Numerical.Primitives import Foundation.Numerical.Multiplicative import Foundation.Array@@ -21,7 +22,6 @@ import Foundation.String import Foundation.Collection.Foldable import Foundation.Hashing.Hasher-import qualified Prelude -- | Type with the ability to be hashed --@@ -50,7 +50,7 @@ where loop 0 acc = acc loop w acc =- let b = Prelude.fromIntegral w+ let b = integralDownsize (w :: Natural) :: Word8 in loop (w `div` 256) (hashMix8 b acc) instance Hashable Int8 where hashMix w = hashMix8 (integralConvert w)@@ -63,12 +63,13 @@ instance Hashable Integer where hashMix i iacc | i == 0 = hashMix8 0 iacc- | i < 0 = loop (-i) (hashMix8 1 iacc)- | otherwise = loop i (hashMix8 0 iacc)+ | i < 0 = loop (integerToNatural i) (hashMix8 1 iacc)+ | otherwise = loop (integerToNatural i) (hashMix8 0 iacc) where+ loop :: Hasher st => Natural -> st -> st loop 0 acc = acc loop w acc =- let b = Prelude.fromIntegral w+ let b = integralDownsize w :: Word8 in loop (w `div` 256) (hashMix8 b acc) instance Hashable String where
Foundation/Hashing/Hasher.hs view
@@ -4,10 +4,10 @@ ) where import Foundation.Internal.Base+import Foundation.Primitive.IntegralConv import Foundation.Array (UArray) import qualified Foundation.Array.Unboxed as A import Data.Bits-import qualified Prelude -- | Incremental Hashing state. Represent an hashing algorithm --@@ -57,18 +57,18 @@ hashMixBytes ba st = A.foldl' (flip hashMix8) st (A.unsafeRecast ba) unWord16 :: Word16 -> (# Word8, Word8 #)-unWord16 w = (# Prelude.fromIntegral (w `unsafeShiftR` 8)- , Prelude.fromIntegral w #)+unWord16 w = (# integralDownsize (w `unsafeShiftR` 8)+ , integralDownsize w #) {-# INLINE unWord16 #-} unWord32 :: Word32 -> (# Word8, Word8, Word8, Word8 #)-unWord32 w = (# Prelude.fromIntegral (w `unsafeShiftR` 24)- , Prelude.fromIntegral (w `unsafeShiftR` 16)- , Prelude.fromIntegral (w `unsafeShiftR` 8)- , Prelude.fromIntegral w #)+unWord32 w = (# integralDownsize (w `unsafeShiftR` 24)+ , integralDownsize (w `unsafeShiftR` 16)+ , integralDownsize (w `unsafeShiftR` 8)+ , integralDownsize w #) {-# INLINE unWord32 #-} unWord64_32 :: Word64 -> (# Word32, Word32 #)-unWord64_32 w = (# Prelude.fromIntegral (w `unsafeShiftR` 32)- , Prelude.fromIntegral w #)+unWord64_32 w = (# integralDownsize (w `unsafeShiftR` 32)+ , integralDownsize w #) {-# INLINE unWord64_32 #-}
Foundation/Internal/Natural.hs view
@@ -2,11 +2,13 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Internal.Natural ( Natural+ , integerToNatural ) where #if MIN_VERSION_base(4,8,0) import Numeric.Natural+import Prelude (Integer, abs, fromInteger) #else @@ -49,3 +51,6 @@ mod = rem #endif++integerToNatural :: Integer -> Natural+integerToNatural i = fromInteger (abs i)
Foundation/Internal/PrimTypes.hs view
@@ -10,6 +10,8 @@ ( FileSize# , Offset# , CountOf#+ , Bool#+ , Pinned# ) where import GHC.Prim@@ -26,3 +28,9 @@ -- -- for code documentation purpose only, just a simple type alias on Int# type CountOf# = Int#++-- | Lowlevel Boolean+type Bool# = Int#++-- | Pinning status+type Pinned# = Bool#
Foundation/Internal/Primitive.hs view
@@ -8,9 +8,10 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE UnliftedFFITypes #-} module Foundation.Internal.Primitive ( bool#- , PinnedStatus, pinned, unpinned, isPinned+ , PinnedStatus(..), toPinnedStatus# , compatAndI# , compatQuotRemInt# , compatCopyAddrToByteArray#@@ -19,6 +20,8 @@ , compatGetSizeofMutableByteArray# , compatShrinkMutableByteArray# , compatResizeMutableByteArray#+ , compatIsByteArrayPinned#+ , compatIsMutableByteArrayPinned# , Word(..) ) where @@ -29,6 +32,8 @@ import GHC.IO #endif +import Foundation.Internal.PrimTypes+ -- GHC 8.0 | Base 4.9 -- GHC 7.10 | Base 4.8 -- GHC 7.8 | Base 4.7@@ -36,17 +41,12 @@ -- GHC 7.4 | Base 4.5 -- | Flag record whether a specific byte array is pinned or not-data PinnedStatus = PinnedStatus Int#--isPinned :: PinnedStatus -> Prelude.Bool-isPinned (PinnedStatus 0#) = Prelude.False-isPinned _ = Prelude.True--pinned :: PinnedStatus-pinned = PinnedStatus 1#+data PinnedStatus = Pinned | Unpinned+ deriving (Prelude.Eq) -unpinned :: PinnedStatus-unpinned = PinnedStatus 0#+toPinnedStatus# :: Pinned# -> PinnedStatus+toPinnedStatus# 0# = Unpinned+toPinnedStatus# _ = Pinned -- | turn an Int# into a Bool --@@ -163,3 +163,17 @@ !len = sizeofMutableByteArray# src #endif {-# INLINE compatResizeMutableByteArray# #-}++#if __GLASGOW_HASKELL__ >= 802+compatIsByteArrayPinned# :: ByteArray# -> Pinned#+compatIsByteArrayPinned# ba = isByteArrayPinned# ba++compatIsMutableByteArrayPinned# :: MutableByteArray# s -> Pinned#+compatIsMutableByteArrayPinned# ba = isMutableByteArrayPinned# ba+#else+foreign import ccall unsafe "foundation_is_bytearray_pinned"+ compatIsByteArrayPinned# :: ByteArray# -> Pinned#++foreign import ccall unsafe "foundation_is_bytearray_pinned"+ compatIsMutableByteArrayPinned# :: MutableByteArray# s -> Pinned#+#endif
Foundation/Parser.hs view
@@ -32,6 +32,7 @@ , -- * Result Result(..) , ParseError(..)+ , reportError , -- * Parser source ParserSource(..)@@ -278,6 +279,19 @@ -- ------------------------------------------------------------------------- -- -- Helpers -- -- ------------------------------------------------------------------------- --++-- | helper function to report error when writing parsers+--+-- This way we can provide more detailed error when building custom+-- parsers and still avoid to use the naughty _fail_.+--+-- @+-- myParser :: Parser input Int+-- myParser = reportError $ Satisfy (Just "this function is not implemented...")+-- @+--+reportError :: ParseError input -> Parser input a+reportError pe = Parser $ \buf off nm err _ -> err buf off nm pe -- | Get the next `Element input` from the parser anyElement :: ParserSource input => Parser input (Element input)
Foundation/Primitive/Block.hs view
@@ -7,7 +7,7 @@ -- very similar to an unboxed array but with the key difference: -- -- * It doesn't have slicing capability (no cheap take or drop)--- * It consume less memory: 1 Offset, 1 CountOf, 1 Pinning status trimmed+-- * It consume less memory: 1 Offset, 1 CountOf -- * It's unpackable in any constructor -- * It uses unpinned memory by default --@@ -28,6 +28,8 @@ , copy -- * safer api , create+ , isPinned+ , isMutablePinned , singleton , replicate , index@@ -96,6 +98,12 @@ M.iterSet initializer mb unsafeFreeze mb +isPinned :: Block ty -> PinnedStatus+isPinned (Block ba) = toPinnedStatus# (compatIsByteArrayPinned# ba)++isMutablePinned :: MutableBlock s ty -> PinnedStatus+isMutablePinned (MutableBlock mba) = toPinnedStatus# (compatIsMutableByteArrayPinned# mba)+ singleton :: PrimType ty => ty -> Block ty singleton ty = create 1 (const ty) @@ -108,14 +116,14 @@ -- and its content is copied to the mutable block thaw :: (PrimMonad prim, PrimType ty) => Block ty -> prim (MutableBlock ty (PrimState prim)) thaw array = do- ma <- M.unsafeNew unpinned (lengthBytes array)+ ma <- M.unsafeNew Unpinned (lengthBytes array) M.unsafeCopyBytesRO ma 0 array 0 (lengthBytes array)- return ma+ pure ma {-# INLINE thaw #-} freeze :: (PrimType ty, PrimMonad prim) => MutableBlock ty (PrimState prim) -> prim (Block ty) freeze ma = do- ma' <- unsafeNew unpinned len+ ma' <- unsafeNew Unpinned len M.unsafeCopyBytes ma' 0 ma 0 len --M.copyAt ma' (Offset 0) ma (Offset 0) len unsafeFreeze ma'@@ -146,21 +154,28 @@ foldr f initialAcc vec = loop 0 where !len = length vec- loop i+ loop !i | i .==# len = initialAcc | otherwise = unsafeIndex vec i `f` loop (i+1)+{-# SPECIALIZE [2] foldr :: (Word8 -> a -> a) -> a -> Block Word8 -> a #-} foldl' :: PrimType ty => (a -> ty -> a) -> a -> Block ty -> a foldl' f initialAcc vec = loop 0 initialAcc where !len = length vec- loop i !acc+ loop !i !acc | i .==# len = acc | otherwise = loop (i+1) (f acc (unsafeIndex vec i))+{-# SPECIALIZE [2] foldl' :: (a -> Word8 -> a) -> a -> Block Word8 -> a #-} foldl1' :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (Block ty) -> ty-foldl1' f arr = let (initialAcc, rest) = splitAt 1 $ getNonEmpty arr- in foldl' f (unsafeIndex initialAcc 0) rest+foldl1' f (NonEmpty arr) = loop 1 (unsafeIndex arr 0)+ where+ !len = length arr+ loop !i !acc+ | i .==# len = acc+ | otherwise = loop (i+1) (f acc (unsafeIndex arr i))+{-# SPECIALIZE [3] foldl1' :: (Word8 -> Word8 -> Word8) -> NonEmpty (Block Word8) -> Word8 #-} foldr1 :: PrimType ty => (ty -> ty -> ty) -> NonEmpty (Block ty) -> ty foldr1 f arr = let (initialAcc, rest) = revSplitAt 1 $ getNonEmpty arr@@ -179,11 +194,11 @@ snoc :: PrimType ty => Block ty -> ty -> Block ty snoc vec e- | len == CountOf 0 = singleton e- | otherwise = runST $ do+ | len == 0 = singleton e+ | otherwise = runST $ do muv <- new (len + 1) M.unsafeCopyElementsRO muv 0 vec 0 len- M.unsafeWrite muv (0 `offsetPlusE` length vec) e+ M.unsafeWrite muv (0 `offsetPlusE` len) e unsafeFreeze muv where !len = length vec@@ -229,6 +244,7 @@ where n = min nbElems vlen vlen = length blk+{-# SPECIALIZE [2] splitAt :: CountOf Word8 -> Block Word8 -> (Block Word8, Block Word8) #-} revSplitAt :: PrimType ty => CountOf ty -> Block ty -> (Block ty, Block ty) revSplitAt n blk@@ -244,6 +260,7 @@ | predicate (unsafeIndex blk i) = splitAt (offsetAsSize i) blk | otherwise = findBreak (i + 1) {-# INLINE findBreak #-}+{-# SPECIALIZE [2] break :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-} span :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) span p = break (not . p)@@ -252,28 +269,31 @@ elem v blk = loop 0 where !len = length blk- loop i+ loop !i | i .==# len = False | unsafeIndex blk i == v = True | otherwise = loop (i+1)+{-# SPECIALIZE [2] elem :: Word8 -> Block Word8 -> Bool #-} all :: PrimType ty => (ty -> Bool) -> Block ty -> Bool all p blk = loop 0 where !len = length blk- loop i+ loop !i | i .==# len = True | p (unsafeIndex blk i) = loop (i+1) | otherwise = False+{-# SPECIALIZE [2] all :: (Word8 -> Bool) -> Block Word8 -> Bool #-} any :: PrimType ty => (ty -> Bool) -> Block ty -> Bool any p blk = loop 0 where !len = length blk- loop i+ loop !i | i .==# len = False | p (unsafeIndex blk i) = True | otherwise = loop (i+1)+{-# SPECIALIZE [2] any :: (Word8 -> Bool) -> Block Word8 -> Bool #-} splitOn :: PrimType ty => (ty -> Bool) -> Block ty -> [Block ty] splitOn predicate blk@@ -332,7 +352,7 @@ doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma where qsort lo hi- | lo >= hi = return ()+ | lo >= hi = pure () | otherwise = do p <- partition lo hi qsort lo (pred p)
Foundation/Primitive/Block/Base.hs view
@@ -19,6 +19,7 @@ , length , lengthBytes -- * Other methods+ , mutableEmpty , new , newPinned , touch@@ -74,10 +75,11 @@ length :: forall ty . PrimType ty => Block ty -> CountOf ty length (Block ba) =- let !(CountOf (I# szBits)) = primSizeInBytes (Proxy :: Proxy ty)- !elems = quotInt# (sizeofByteArray# ba) szBits- in CountOf (I# elems)+ case primShiftToBytes (Proxy :: Proxy ty) of+ 0 -> CountOf (I# (sizeofByteArray# ba))+ (I# szBits) -> CountOf (I# (uncheckedIShiftRL# (sizeofByteArray# ba) szBits)) {-# INLINE[1] length #-}+{-# SPECIALIZE [2] length :: Block Word8 -> CountOf Word8 #-} lengthBytes :: Block ty -> CountOf Word8 lengthBytes (Block ba) = CountOf (I# (sizeofByteArray# ba))@@ -93,6 +95,11 @@ case unsafeFreezeByteArray# mba s2 of { (# s3, ba #) -> (# s3, Block ba #) }} +mutableEmpty :: PrimMonad prim => prim (MutableBlock ty (PrimState prim))+mutableEmpty = primitive $ \s1 ->+ case newByteArray# 0# s1 of { (# s2, mba #) ->+ (# s2, MutableBlock mba #) }+ -- | Return the element at a specific index from an array without bounds checking. -- -- Reading from invalid memory can return unpredictable and invalid values.@@ -143,7 +150,7 @@ equalMemcmp :: PrimMemoryComparable ty => Block ty -> Block ty -> Bool equalMemcmp b1@(Block a) b2@(Block b) | la /= lb = False- | otherwise = unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 (csizeOfSize la)) == 0+ | otherwise = unsafeDupablePerformIO (sysHsMemcmpBaBa a 0 b 0 la) == 0 where la = lengthBytes b1 lb = lengthBytes b2@@ -175,7 +182,7 @@ where la = lengthBytes b1 lb = lengthBytes b2- sz = csizeOfSize $ min la lb+ sz = min la lb {-# SPECIALIZE [3] compareMemcmp :: Block Word8 -> Block Word8 -> Ordering #-} -- | Append 2 blocks together by creating a new bigger block@@ -184,7 +191,7 @@ | la == azero = b | lb == azero = a | otherwise = runST $ do- r <- unsafeNew unpinned (la+lb)+ r <- unsafeNew Unpinned (la+lb) unsafeCopyBytesRO r 0 a 0 la unsafeCopyBytesRO r (sizeAsOffset la) b 0 lb unsafeFreeze r@@ -199,7 +206,7 @@ (_,[]) -> empty (_,[x]) -> x (totalLen,chunks) -> runST $ do- r <- unsafeNew unpinned totalLen+ r <- unsafeNew Unpinned totalLen doCopy r 0 chunks unsafeFreeze r where@@ -247,16 +254,16 @@ => PinnedStatus -> CountOf Word8 -> prim (MutableBlock ty (PrimState prim))-unsafeNew pinStatus (CountOf (I# bytes))- | isPinned pinStatus = primitive $ \s1 -> case newByteArray# bytes s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }- | otherwise = primitive $ \s1 -> case newAlignedPinnedByteArray# bytes 8# s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }+unsafeNew pinSt (CountOf (I# bytes)) = case pinSt of+ Unpinned -> primitive $ \s1 -> case newByteArray# bytes s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }+ _ -> primitive $ \s1 -> case newAlignedPinnedByteArray# bytes 8# s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) } -- | Create a new mutable block of a specific N size of 'ty' elements new :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim))-new n = unsafeNew unpinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n)+new n = unsafeNew Unpinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n) newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MutableBlock ty (PrimState prim))-newPinned n = unsafeNew pinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n)+newPinned n = unsafeNew Pinned (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n) -- | Copy a number of elements from an array to another array with offsets unsafeCopyElements :: forall prim ty . (PrimMonad prim, PrimType ty)
Foundation/Primitive/Block/Mutable.hs view
@@ -41,7 +41,7 @@ , mutableGetAddr , new , newPinned- , isPinned+ , mutableEmpty , iterSet , read , write@@ -80,13 +80,6 @@ mutableLengthBytes :: MutableBlock ty st -> CountOf Word8 mutableLengthBytes (MutableBlock mba) = CountOf (I# (sizeofMutableByteArray# mba)) {-# INLINE[1] mutableLengthBytes #-}---- | Return if a Mutable Block is pinned or not-isPinned :: MutableBlock ty st -> Bool-isPinned (MutableBlock mba) =- -- TODO use the exact value where the array become pinned (LARGE_OBJECT_THRESHOLD)- -- in 8.2, there's a primitive to know if an array in pinned- I# (sizeofMutableByteArray# mba) > 3000 -- | Get the address of the context of the mutable block. --
Foundation/Primitive/Endianness.hs view
@@ -10,6 +10,7 @@ -- {-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Primitive.Endianness (@@ -35,7 +36,9 @@ import System.IO.Unsafe (unsafePerformIO) #endif +import Data.Bits + -- #if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN) -- import Foundation.System.Info (endianness, Endianness(..)) -- #endif@@ -47,13 +50,13 @@ -- | Little Endian value newtype LE a = LE { unLE :: a }- deriving (Show, Eq, Typeable)+ deriving (Show, Eq, Typeable, Bits) instance (ByteSwap a, Ord a) => Ord (LE a) where compare e1 e2 = compare (fromLE e1) (fromLE e2) -- | Big Endian value newtype BE a = BE { unBE :: a }- deriving (Show, Eq, Typeable)+ deriving (Show, Eq, Typeable, Bits) instance (ByteSwap a, Ord a) => Ord (BE a) where compare e1 e2 = compare (fromBE e1) (fromBE e2)
Foundation/Primitive/FinalPtr.hs view
@@ -18,6 +18,7 @@ , castFinalPtr , toFinalPtr , toFinalPtrForeign+ , touchFinalPtr , withFinalPtr , withUnsafeFinalPtr , withFinalPtrNoTouch@@ -36,7 +37,7 @@ data FinalPtr a = FinalPtr (Ptr a) | FinalForeign (ForeignPtr a) instance Show (FinalPtr a) where- show f = runST $ withFinalPtr f (return . show)+ show f = runST $ withFinalPtr f (pure . show) instance Eq (FinalPtr a) where (==) f1 f2 = runST (equal f1 f2) instance Ord (FinalPtr a) where@@ -80,13 +81,17 @@ withFinalPtr (FinalPtr ptr) f = do r <- f ptr primTouch ptr- return r+ pure r withFinalPtr (FinalForeign fptr) f = do r <- f (unsafeForeignPtrToPtr fptr) unsafePrimFromIO (touchForeignPtr fptr)- return r+ pure r {-# INLINE withFinalPtr #-} +touchFinalPtr :: PrimMonad prim => FinalPtr p -> prim ()+touchFinalPtr (FinalPtr ptr) = primTouch ptr+touchFinalPtr (FinalForeign fptr) = unsafePrimFromIO (touchForeignPtr fptr)+ -- | Unsafe version of 'withFinalPtr' withUnsafeFinalPtr :: PrimMonad prim => FinalPtr p -> (Ptr p -> prim a) -> a withUnsafeFinalPtr fptr f = unsafePerformIO (unsafePrimToIO (withFinalPtr fptr f))@@ -96,12 +101,12 @@ equal f1 f2 = withFinalPtr f1 $ \ptr1 -> withFinalPtr f2 $ \ptr2 ->- return $ ptr1 == ptr2+ pure $ ptr1 == ptr2 {-# INLINE equal #-} compare_ :: PrimMonad prim => FinalPtr a -> FinalPtr a -> prim Ordering compare_ f1 f2 = withFinalPtr f1 $ \ptr1 -> withFinalPtr f2 $ \ptr2 ->- return $ ptr1 `compare` ptr2+ pure $ ptr1 `compare` ptr2 {-# INLINE compare_ #-}
Foundation/Primitive/IntegralConv.hs view
@@ -9,6 +9,7 @@ , IntegralUpsize(..) , IntegralCast(..) , intToInt64+ , int64ToInt , wordToWord64 , word64ToWord32s , word64ToWord@@ -183,6 +184,16 @@ integralDownsizeCheck = integralDownsizeBounded integralDownsize instance IntegralDownsize Word64 Word32 where integralDownsize (W64# i) = W32# (narrow32Word# (word64ToWord# i))+ integralDownsizeCheck = integralDownsizeBounded integralDownsize++instance IntegralDownsize Word Word8 where+ integralDownsize (W# w) = W8# (narrow8Word# w)+ integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Word Word16 where+ integralDownsize (W# w) = W16# (narrow16Word# w)+ integralDownsizeCheck = integralDownsizeBounded integralDownsize+instance IntegralDownsize Word Word32 where+ integralDownsize (W# w) = W32# (narrow32Word# w) integralDownsizeCheck = integralDownsizeBounded integralDownsize instance IntegralDownsize Word32 Word8 where
Foundation/Primitive/NormalForm.hs view
@@ -7,6 +7,7 @@ import Foundation.Internal.Base import Foundation.Internal.Natural import Foundation.Primitive.Types.OffsetSize+import Foundation.Primitive.Endianness import Foreign.C.Types -- | Data that can be fully evaluated in Normal Form@@ -78,6 +79,10 @@ instance (NormalForm l, NormalForm r) => NormalForm (Either l r) where toNormalForm (Left l) = toNormalForm l `seq` () toNormalForm (Right r) = toNormalForm r `seq` ()+instance NormalForm a => NormalForm (LE a) where+ toNormalForm (LE a) = toNormalForm a `seq` ()+instance NormalForm a => NormalForm (BE a) where+ toNormalForm (BE a) = toNormalForm a `seq` () instance NormalForm a => NormalForm [a] where toNormalForm [] = ()
Foundation/Primitive/Runtime.hs view
@@ -26,5 +26,5 @@ unsafeUArrayUnpinnedMaxSize :: Size8 unsafeUArrayUnpinnedMaxSize = unsafePerformIO $ do maxSize <- (>>= readMaybe) <$> lookupEnv "HS_FOUNDATION_UARRAY_UNPINNED_MAX"- return $ maybe (CountOf 1024) CountOf maxSize+ pure $ maybe (CountOf 1024) CountOf maxSize {-# NOINLINE unsafeUArrayUnpinnedMaxSize #-}
Foundation/Primitive/Types.hs view
@@ -25,6 +25,8 @@ , sizeAsOffset , sizeInBytes , offsetInBytes+ , offsetInElements+ , offsetIsAligned , primWordGetByteAndShift , primWord64GetByteAndShift , primWord64GetHiLo@@ -36,9 +38,11 @@ import GHC.Int import GHC.Types import GHC.Word+import Data.Bits import Foreign.C.Types import Foundation.Internal.Proxy import Foundation.Internal.Base+import Foundation.Numerical.Subtractive import Foundation.Primitive.Types.OffsetSize import Foundation.Primitive.Endianness import Foundation.Primitive.Monad@@ -156,6 +160,9 @@ -- | get the size in bytes of a ty element primSizeInBytes :: Proxy ty -> Size8 + -- | get the shift size+ primShiftToBytes :: Proxy ty -> Int+ ----- -- ByteArray section -----@@ -201,12 +208,17 @@ -> prim () sizeInt, sizeWord :: CountOf Word8+shiftInt, shiftWord :: Int #if WORD_SIZE_IN_BITS == 64 sizeInt = CountOf 8 sizeWord = CountOf 8+shiftInt = 3+shiftWord = 3 #else sizeInt = CountOf 4 sizeWord = CountOf 4+shiftInt = 2+shiftWord = 2 #endif {-# SPECIALIZE [3] primBaUIndex :: ByteArray# -> Offset Word8 -> Word8 #-}@@ -214,6 +226,8 @@ instance PrimType Int where primSizeInBytes _ = sizeInt {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = shiftInt+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset (I# n)) = I# (indexIntArray# ba n) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readIntArray# mba n s1 in (# s2, I# r #)@@ -230,6 +244,8 @@ instance PrimType Word where primSizeInBytes _ = sizeWord {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = shiftWord+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset (I# n)) = W# (indexWordArray# ba n) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWordArray# mba n s1 in (# s2, W# r #)@@ -246,6 +262,8 @@ instance PrimType Word8 where primSizeInBytes _ = CountOf 1 {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = 0+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset (I# n)) = W8# (indexWord8Array# ba n) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord8Array# mba n s1 in (# s2, W8# r #)@@ -262,6 +280,8 @@ instance PrimType Word16 where primSizeInBytes _ = CountOf 2 {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = 1+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset (I# n)) = W16# (indexWord16Array# ba n) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord16Array# mba n s1 in (# s2, W16# r #)@@ -277,6 +297,8 @@ instance PrimType Word32 where primSizeInBytes _ = CountOf 4 {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = 2+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset (I# n)) = W32# (indexWord32Array# ba n) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord32Array# mba n s1 in (# s2, W32# r #)@@ -292,6 +314,8 @@ instance PrimType Word64 where primSizeInBytes _ = CountOf 8 {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = 3+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset (I# n)) = W64# (indexWord64Array# ba n) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWord64Array# mba n s1 in (# s2, W64# r #)@@ -307,6 +331,8 @@ instance PrimType Int8 where primSizeInBytes _ = CountOf 1 {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = 0+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset (I# n)) = I8# (indexInt8Array# ba n) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt8Array# mba n s1 in (# s2, I8# r #)@@ -322,6 +348,8 @@ instance PrimType Int16 where primSizeInBytes _ = CountOf 2 {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = 1+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset (I# n)) = I16# (indexInt16Array# ba n) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt16Array# mba n s1 in (# s2, I16# r #)@@ -337,6 +365,8 @@ instance PrimType Int32 where primSizeInBytes _ = CountOf 4 {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = 2+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset (I# n)) = I32# (indexInt32Array# ba n) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt32Array# mba n s1 in (# s2, I32# r #)@@ -352,6 +382,8 @@ instance PrimType Int64 where primSizeInBytes _ = CountOf 8 {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = 3+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset (I# n)) = I64# (indexInt64Array# ba n) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readInt64Array# mba n s1 in (# s2, I64# r #)@@ -368,6 +400,8 @@ instance PrimType Float where primSizeInBytes _ = CountOf 4 {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = 2+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset (I# n)) = F# (indexFloatArray# ba n) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readFloatArray# mba n s1 in (# s2, F# r #)@@ -383,6 +417,8 @@ instance PrimType Double where primSizeInBytes _ = CountOf 8 {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = 3+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset (I# n)) = D# (indexDoubleArray# ba n) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readDoubleArray# mba n s1 in (# s2, D# r #)@@ -399,6 +435,8 @@ instance PrimType Char where primSizeInBytes _ = CountOf 4 {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = 2+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset (I# n)) = C# (indexWideCharArray# ba n) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset (I# n)) = primitive $ \s1 -> let (# s2, r #) = readWideCharArray# mba n s1 in (# s2, C# r #)@@ -415,6 +453,8 @@ instance PrimType CChar where primSizeInBytes _ = CountOf 1 {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = 0+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset n) = CChar (primBaUIndex ba (Offset n)) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset n) = CChar <$> primMbaURead mba (Offset n)@@ -430,6 +470,8 @@ instance PrimType CUChar where primSizeInBytes _ = CountOf 1 {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = 0+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset n) = CUChar (primBaUIndex ba (Offset n :: Offset Word8)) {-# INLINE primBaUIndex #-} primMbaURead mba (Offset n) = CUChar <$> primMbaURead mba (Offset n :: Offset Word8)@@ -446,6 +488,8 @@ instance PrimType a => PrimType (LE a) where primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy a) {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy a)+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset a) = LE $ primBaUIndex ba (Offset a) {-# INLINE primBaUIndex #-} primMbaURead ba (Offset a) = LE <$> primMbaURead ba (Offset a)@@ -461,6 +505,8 @@ instance PrimType a => PrimType (BE a) where primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy a) {-# INLINE primSizeInBytes #-}+ primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy a)+ {-# INLINE primShiftToBytes #-} primBaUIndex ba (Offset a) = BE $ primBaUIndex ba (Offset a) {-# INLINE primBaUIndex #-} primMbaURead ba (Offset a) = BE <$> primMbaURead ba (Offset a)@@ -501,7 +547,7 @@ -- | Cast a CountOf linked to type A (CountOf A) to a CountOf linked to type B (CountOf B) sizeRecast :: forall a b . (PrimType a, PrimType b) => CountOf a -> CountOf b sizeRecast sz = CountOf (bytes `Prelude.quot` szB)- where !szA = primSizeInBytes (Proxy :: Proxy a)+ where !szA = primSizeInBytes (Proxy :: Proxy a) !(CountOf szB) = primSizeInBytes (Proxy :: Proxy b) !(CountOf bytes) = sizeOfE szA sz {-# INLINE [1] sizeRecast #-}@@ -516,8 +562,21 @@ sizeInBytes sz = sizeOfE (primSizeInBytes (Proxy :: Proxy a)) sz offsetInBytes :: forall a . PrimType a => Offset a -> Offset Word8-offsetInBytes sz = offsetOfE (primSizeInBytes (Proxy :: Proxy a)) sz+offsetInBytes ofs = offsetShiftL (primShiftToBytes (Proxy :: Proxy a)) ofs+{-# INLINE [2] offsetInBytes #-}+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word64 -> Offset Word8 #-}+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word32 -> Offset Word8 #-}+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word16 -> Offset Word8 #-}+{-# RULES "offsetInBytes Bytes" [3] forall x . offsetInBytes x = x #-} +offsetInElements :: forall a . PrimType a => Offset Word8 -> Offset a+offsetInElements ofs = offsetShiftR (primShiftToBytes (Proxy :: Proxy a)) ofs+{-# INLINE [2] offsetInElements #-}+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word64 -> Offset Word8 #-}+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word32 -> Offset Word8 #-}+{-# SPECIALIZE INLINE [3] offsetInBytes :: Offset Word16 -> Offset Word8 #-}+{-# RULES "offsetInElements Bytes" [3] forall x . offsetInElements x = x #-}+ primOffsetRecast :: forall a b . (PrimType a, PrimType b) => Offset a -> Offset b primOffsetRecast !ofs = let !(Offset bytes) = offsetOfE szA ofs@@ -528,7 +587,16 @@ {-# INLINE [1] primOffsetRecast #-} {-# RULES "primOffsetRecast W8" [3] forall a . primOffsetRecast a = primOffsetRecastBytes a #-} +offsetIsAligned :: forall a . PrimType a => Proxy a -> Offset Word8 -> Bool+offsetIsAligned _ (Offset ofs) = (ofs .&. mask) == 0+ where (CountOf sz) = primSizeInBytes (Proxy :: Proxy a)+ mask = sz - 1+{-# INLINE [1] offsetIsAligned #-}+{-# SPECIALIZE [3] offsetIsAligned :: Proxy Word64 -> Offset Word8 -> Bool #-}+{-# RULES "offsetInAligned Bytes" [3] forall (prx :: Proxy Word8) x . offsetIsAligned prx x = True #-}+ primOffsetRecastBytes :: forall b . PrimType b => Offset Word8 -> Offset b+primOffsetRecastBytes (Offset 0) = Offset 0 primOffsetRecastBytes (Offset o) = Offset (szA `Prelude.quot` o) where !(CountOf szA) = primSizeInBytes (Proxy :: Proxy b) {-# INLINE [1] primOffsetRecastBytes #-}
Foundation/Primitive/Types/OffsetSize.hs view
@@ -19,6 +19,8 @@ , offsetRecast , offsetCast , offsetSub+ , offsetShiftL+ , offsetShiftR , sizeCast , sizeLastOffset , sizeAsOffset@@ -43,6 +45,7 @@ import GHC.Prim import Foreign.C.Types import System.Posix.Types (CSsize (..))+import Data.Bits import Foundation.Internal.Base import Foundation.Internal.Proxy import Foundation.Numerical.Primitives@@ -52,6 +55,7 @@ import Foundation.Numerical.Multiplicative import Foundation.Primitive.IntegralConv import Data.List (foldl')+import qualified Prelude #if WORD_SIZE_IN_BITS < 64 import GHC.IntWord64@@ -73,12 +77,8 @@ -- considering that GHC/Haskell are mostly using this for offset. -- Trying to bring some sanity by a lightweight wrapping. newtype Offset ty = Offset Int- deriving (Show,Eq,Ord,Enum,Additive,Typeable)+ deriving (Show,Eq,Ord,Enum,Additive,Typeable,Integral,Prelude.Num) -instance Integral (Offset ty) where- fromInteger n- | n < 0 = error "CountOf: fromInteger: negative"- | otherwise = Offset . fromInteger $ n instance IsIntegral (Offset ty) where toInteger (Offset i) = toInteger i instance IsNatural (Offset ty) where@@ -122,6 +122,12 @@ let (Offset bytes) = offsetOfE szTy ofs in Offset (bytes `div` szTy2) +offsetShiftR :: Int -> Offset ty -> Offset ty2+offsetShiftR n (Offset o) = Offset (o `unsafeShiftR` n)++offsetShiftL :: Int -> Offset ty -> Offset ty2+offsetShiftL n (Offset o) = Offset (o `unsafeShiftL` n)+ offsetCast :: Proxy (a -> b) -> Offset a -> Offset b offsetCast _ (Offset o) = Offset o {-# INLINE offsetCast #-}@@ -169,12 +175,19 @@ -- -- Same caveats as 'Offset' apply here. newtype CountOf ty = CountOf Int- deriving (Show,Eq,Ord,Enum,Typeable)+ deriving (Show,Eq,Ord,Enum,Typeable,Integral) -instance Integral (CountOf ty) where- fromInteger n- | n < 0 = error "CountOf: fromInteger: negative"- | otherwise = CountOf . fromInteger $ n+instance Prelude.Num (CountOf ty) where+ fromInteger a = CountOf (fromInteger a)+ (+) (CountOf a) (CountOf b) = CountOf (a+b)+ (-) (CountOf a) (CountOf b)+ | b > a = CountOf 0+ | otherwise = CountOf (a - b)+ (*) (CountOf a) (CountOf b) = CountOf (a*b)+ abs a = a+ negate _ = error "cannot negate CountOf: use Foundation Numerical hierarchy for this function to not be exposed to CountOf"+ signum (CountOf a) = CountOf (Prelude.signum a)+ instance IsIntegral (CountOf ty) where toInteger (CountOf i) = toInteger i instance IsNatural (CountOf ty) where
+ Foundation/Primitive/UArray/Addr.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE CPP #-}+module Foundation.Primitive.UArray.Addr+ ( findIndexElem+ , findIndexPredicate+ , foldl+ , foldr+ , foldl1+ , all+ , any+ , filter+ , primIndex+ ) where++import GHC.Types+import GHC.Prim+import Foundation.Internal.Base+import Foundation.Numerical+import Foundation.Primitive.Types.OffsetSize+import Foundation.Primitive.Types+import Foundation.Primitive.Monad++type Immutable = Addr#++primIndex :: PrimType ty => Immutable -> Offset ty -> ty+primIndex = primAddrIndex++findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty+findIndexElem ty ba startIndex endIndex = loop startIndex+ where+ loop !i+ | i < endIndex && t /= ty = loop (i+1)+ | otherwise = i+ where t = primIndex ba i+{-# INLINE findIndexElem #-}++findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty+findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex+ where+ loop !i+ | i < endIndex && not found = loop (i+1)+ | otherwise = i+ where found = predicate (primIndex ba i)+{-# INLINE findIndexPredicate #-}++foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a+foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc+ where+ loop !i !acc+ | i == endIndex = acc+ | otherwise = loop (i+1) (f acc (primIndex ba i))+{-# INLINE foldl #-}++foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a+foldr f !initialAcc ba startIndex endIndex = loop startIndex+ where+ loop !i+ | i == endIndex = initialAcc+ | otherwise = primIndex ba i `f` loop (i+1)+{-# INLINE foldr #-}++foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty+foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex)+ where+ loop !i !acc+ | i == endIndex = acc+ | otherwise = loop (i+1) (f acc (primIndex ba i))+{-# INLINE foldl1 #-}++filter :: (PrimMonad prim, PrimType ty)+ => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty)+filter predicate dst src start end = loop azero start+ where+ loop !d !s+ | s == end = pure (offsetAsSize d)+ | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1)+ | otherwise = loop d (s+Offset 1)+ where+ v = primIndex src s++all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool+all predicate ba start end = loop start+ where+ loop !i+ | i == end = True+ | predicate (primIndex ba i) = loop (i+1)+ | otherwise = False+{-# INLINE all #-}++any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool+any predicate ba start end = loop start+ where+ loop !i+ | i == end = False+ | predicate (primIndex ba i) = True+ | otherwise = loop (i+1)+{-# INLINE any #-}
+ Foundation/Primitive/UArray/BA.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+module Foundation.Primitive.UArray.BA+ ( findIndexElem+ , findIndexPredicate+ , foldl+ , foldr+ , foldl1+ , all+ , any+ , filter+ , primIndex+ ) where++import GHC.Types+import GHC.Prim+import Foundation.Internal.Base+import Foundation.Numerical+import Foundation.Primitive.Types.OffsetSize+import Foundation.Primitive.Types+import Foundation.Primitive.Monad++type Immutable = ByteArray#++primIndex :: PrimType ty => Immutable -> Offset ty -> ty+primIndex = primBaIndex++findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty+findIndexElem ty ba startIndex endIndex = loop startIndex+ where+ loop !i+ | i < endIndex && t /= ty = loop (i+1)+ | otherwise = i+ where t = primIndex ba i+{-# INLINE findIndexElem #-}++findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty+findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex+ where+ loop !i+ | i < endIndex && not found = loop (i+1)+ | otherwise = i+ where found = predicate (primIndex ba i)+{-# INLINE findIndexPredicate #-}++foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a+foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc+ where+ loop !i !acc+ | i == endIndex = acc+ | otherwise = loop (i+1) (f acc (primIndex ba i))+{-# INLINE foldl #-}++foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a+foldr f !initialAcc ba startIndex endIndex = loop startIndex+ where+ loop !i+ | i == endIndex = initialAcc+ | otherwise = primIndex ba i `f` loop (i+1)+{-# INLINE foldr #-}++foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty+foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex)+ where+ loop !i !acc+ | i == endIndex = acc+ | otherwise = loop (i+1) (f acc (primIndex ba i))+{-# INLINE foldl1 #-}++filter :: (PrimMonad prim, PrimType ty)+ => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty)+filter predicate dst src start end = loop azero start+ where+ loop !d !s+ | s == end = pure (offsetAsSize d)+ | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1)+ | otherwise = loop d (s+Offset 1)+ where+ v = primIndex src s++all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool+all predicate ba start end = loop start+ where+ loop !i+ | i == end = True+ | predicate (primIndex ba i) = loop (i+1)+ | otherwise = False+{-# INLINE all #-}++any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool+any predicate ba start end = loop start+ where+ loop !i+ | i == end = False+ | predicate (primIndex ba i) = True+ | otherwise = loop (i+1)+{-# INLINE any #-}
+ Foundation/Primitive/UArray/Base.hs view
@@ -0,0 +1,550 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+module Foundation.Primitive.UArray.Base+ ( MUArray(..)+ , UArray(..)+ , MUArrayBackend(..)+ , UArrayBackend(..)+ -- * New mutable array creation+ , newUnpinned+ , newPinned+ , newNative+ , new+ -- * Pinning status+ , isPinned+ , isMutablePinned+ -- * Mutable array accessor+ , unsafeRead+ , unsafeWrite+ -- * Freezing routines+ , unsafeFreezeShrink+ , unsafeFreeze+ , unsafeThaw+ -- * Array accessor+ , unsafeIndex+ , unsafeIndexer+ , onBackend+ , onBackendPrim+ , onMutableBackend+ , unsafeDewrap+ , unsafeDewrap2+ -- * Basic lowlevel functions+ , empty+ , length+ , offset+ , ValidRange(..)+ , offsetsValidRange+ , equal+ , equalMemcmp+ , compare+ , copyAt+ , unsafeCopyAtRO+ , touch+ -- * temporary+ , pureST+ ) where++import GHC.Prim+import GHC.Types+import GHC.Ptr+import GHC.ST+import Foundation.Internal.Primitive+import Foundation.Primitive.Monad+import Foundation.Primitive.Types+import Foundation.Internal.Base+import qualified Foundation.Primitive.Runtime as Runtime+import Foundation.Internal.Proxy+import qualified Foundation.Boot.List as List+import Foundation.Primitive.Types.OffsetSize+import Foundation.Primitive.FinalPtr+import Foundation.Primitive.NormalForm+import Foundation.Primitive.Block (MutableBlock(..), Block(..))+import qualified Foundation.Primitive.Block as BLK+import qualified Foundation.Primitive.Block.Base as BLK (touch)+import qualified Foundation.Primitive.Block.Mutable as MBLK+import Foundation.Numerical+import Foundation.System.Bindings.Hs+import Foreign.C.Types+import System.IO.Unsafe (unsafeDupablePerformIO)++-- | A Mutable array of types built on top of GHC primitive.+--+-- Element in this array can be modified in place.+data MUArray ty st = MUArray {-# UNPACK #-} !(Offset ty)+ {-# UNPACK #-} !(CountOf ty)+ !(MUArrayBackend ty st)++data MUArrayBackend ty st = MUArrayMBA (MutableBlock ty st) | MUArrayAddr (FinalPtr ty)+++-- | An array of type built on top of GHC primitive.+--+-- The elements need to have fixed sized and the representation is a+-- packed contiguous array in memory that can easily be passed+-- to foreign interface+data UArray ty = UArray {-# UNPACK #-} !(Offset ty)+ {-# UNPACK #-} !(CountOf ty)+ !(UArrayBackend ty)+ deriving (Typeable)++data UArrayBackend ty = UArrayBA !(Block ty) | UArrayAddr !(FinalPtr ty)+ deriving (Typeable)++instance Data ty => Data (UArray ty) where+ dataTypeOf _ = arrayType+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"++arrayType :: DataType+arrayType = mkNoRepType "Foundation.UArray"++instance NormalForm (UArray ty) where+ toNormalForm (UArray _ _ !_) = ()+instance (PrimType ty, Show ty) => Show (UArray ty) where+ show v = show (toList v)+instance (PrimType ty, Eq ty) => Eq (UArray ty) where+ (==) = equal+instance (PrimType ty, Ord ty) => Ord (UArray ty) where+ {-# SPECIALIZE instance Ord (UArray Word8) #-}+ compare = vCompare++instance PrimType ty => Monoid (UArray ty) where+ mempty = empty+ mappend = append+ mconcat = concat++instance PrimType ty => IsList (UArray ty) where+ type Item (UArray ty) = ty+ fromList = vFromList+ toList = vToList++length :: UArray ty -> CountOf ty+length (UArray _ len _) = len+{-# INLINE[1] length #-}++offset :: UArray ty -> Offset ty+offset (UArray ofs _ _) = ofs+{-# INLINE[1] offset #-}++data ValidRange ty = ValidRange {-# UNPACK #-} !(Offset ty) {-# UNPACK #-} !(Offset ty)++offsetsValidRange :: UArray ty -> ValidRange ty+offsetsValidRange (UArray ofs len _) = ValidRange ofs (ofs `offsetPlusE` len)++-- | Return if the array is pinned in memory+--+-- note that Foreign array are considered pinned+isPinned :: UArray ty -> PinnedStatus+isPinned (UArray _ _ (UArrayAddr {})) = Pinned+isPinned (UArray _ _ (UArrayBA blk)) = BLK.isPinned blk++-- | Return if a mutable array is pinned in memory+isMutablePinned :: MUArray ty st -> PinnedStatus+isMutablePinned (MUArray _ _ (MUArrayAddr {})) = Pinned+isMutablePinned (MUArray _ _ (MUArrayMBA mb)) = BLK.isMutablePinned mb++-- | Create a new pinned mutable array of size @n.+--+-- all the cells are uninitialized and could contains invalid values.+--+-- All mutable arrays are allocated on a 64 bits aligned addresses+newPinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))+newPinned n = MUArray 0 n . MUArrayMBA <$> MBLK.newPinned n++newUnpinned :: forall prim ty . (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))+newUnpinned n = MUArray 0 n . MUArrayMBA <$> MBLK.new n++newNative :: (PrimMonad prim, PrimType ty)+ => CountOf ty+ -> (MutableByteArray# (PrimState prim) -> prim a) -- ^ move to a MutableBlock+ -> prim (a, MUArray ty (PrimState prim))+newNative n f = do+ mb@(MutableBlock mba) <- MBLK.new n+ a <- f mba+ pure (a, MUArray 0 n (MUArrayMBA mb))++-- | Create a new mutable array of size @n.+--+-- When memory for a new array is allocated, we decide if that memory region+-- should be pinned (will not be copied around by GC) or unpinned (can be+-- moved around by GC) depending on its size.+--+-- You can change the threshold value used by setting the environment variable+-- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@.+new :: (PrimMonad prim, PrimType ty) => CountOf ty -> prim (MUArray ty (PrimState prim))+new sz+ | sizeRecast sz <= maxSizeUnpinned = newUnpinned sz+ | otherwise = newPinned sz+ where+ -- Safe to use here: If the value changes during runtime, this will only+ -- have an impact on newly created arrays.+ maxSizeUnpinned = Runtime.unsafeUArrayUnpinnedMaxSize+{-# INLINE new #-}++-- | read from a cell in a mutable array without bounds checking.+--+-- Reading from invalid memory can return unpredictable and invalid values.+-- use 'read' if unsure.+unsafeRead :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> prim ty+unsafeRead (MUArray start _ (MUArrayMBA (MutableBlock mba))) i = primMbaRead mba (start + i)+unsafeRead (MUArray start _ (MUArrayAddr fptr)) i = withFinalPtr fptr $ \(Ptr addr) -> primAddrRead addr (start + i)+{-# INLINE unsafeRead #-}+++-- | write to a cell in a mutable array without bounds checking.+--+-- Writing with invalid bounds will corrupt memory and your program will+-- become unreliable. use 'write' if unsure.+unsafeWrite :: (PrimMonad prim, PrimType ty) => MUArray ty (PrimState prim) -> Offset ty -> ty -> prim ()+unsafeWrite (MUArray start _ (MUArrayMBA mb)) i v = MBLK.unsafeWrite mb (start+i) v+unsafeWrite (MUArray start _ (MUArrayAddr fptr)) i v = withFinalPtr fptr $ \(Ptr addr) -> primAddrWrite addr (start+i) v+{-# INLINE unsafeWrite #-}++-- | Return the element at a specific index from an array without bounds checking.+--+-- Reading from invalid memory can return unpredictable and invalid values.+-- use 'index' if unsure.+unsafeIndex :: forall ty . PrimType ty => UArray ty -> Offset ty -> ty+unsafeIndex (UArray start _ (UArrayBA ba)) n = BLK.unsafeIndex ba (start + n)+unsafeIndex (UArray start _ (UArrayAddr fptr)) n = withUnsafeFinalPtr fptr (\(Ptr addr) -> return (primAddrIndex addr (start+n)) :: IO ty)+{-# INLINE unsafeIndex #-}++unsafeIndexer :: (PrimMonad prim, PrimType ty) => UArray ty -> ((Offset ty -> ty) -> prim a) -> prim a+unsafeIndexer (UArray start _ (UArrayBA ba)) f = f (\n -> BLK.unsafeIndex ba (start + n))+unsafeIndexer (UArray start _ (UArrayAddr fptr)) f = withFinalPtr fptr $ \(Ptr addr) -> f (\n -> primAddrIndex addr (start + n))+{-# INLINE unsafeIndexer #-}++-- | Freeze a mutable array into an array.+--+-- the MUArray must not be changed after freezing.+unsafeFreeze :: PrimMonad prim => MUArray ty (PrimState prim) -> prim (UArray ty)+unsafeFreeze (MUArray start len (MUArrayMBA mba)) =+ UArray start len . UArrayBA <$> MBLK.unsafeFreeze mba+unsafeFreeze (MUArray start len (MUArrayAddr fptr)) =+ pure $ UArray start len (UArrayAddr fptr)+{-# INLINE unsafeFreeze #-}++unsafeFreezeShrink :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> CountOf ty -> prim (UArray ty)+unsafeFreezeShrink (MUArray start _ backend) n = unsafeFreeze (MUArray start n backend)+{-# INLINE unsafeFreezeShrink #-}++-- | Thaw an immutable array.+--+-- The UArray must not be used after thawing.+unsafeThaw :: (PrimType ty, PrimMonad prim) => UArray ty -> prim (MUArray ty (PrimState prim))+unsafeThaw (UArray start len (UArrayBA blk)) = MUArray start len . MUArrayMBA <$> BLK.unsafeThaw blk+unsafeThaw (UArray start len (UArrayAddr fptr)) = pure $ MUArray start len (MUArrayAddr fptr)+{-# INLINE unsafeThaw #-}++onBackend :: (ByteArray# -> a)+ -> (FinalPtr ty -> Ptr ty -> ST s a)+ -> UArray ty+ -> a+onBackend onBa _ (UArray _ _ (UArrayBA (Block ba))) = onBa ba+onBackend _ onAddr (UArray _ _ (UArrayAddr fptr)) = withUnsafeFinalPtr fptr (onAddr fptr)+{-# INLINE onBackend #-}++onBackendPrim :: PrimMonad prim+ => (ByteArray# -> prim a)+ -> (FinalPtr ty -> prim a)+ -> UArray ty+ -> prim a+onBackendPrim onBa _ (UArray _ _ (UArrayBA (Block ba))) = onBa ba+onBackendPrim _ onAddr (UArray _ _ (UArrayAddr fptr)) = onAddr fptr+{-# INLINE onBackendPrim #-}++onMutableBackend :: PrimMonad prim+ => (MutableByteArray# (PrimState prim) -> prim a)+ -> (FinalPtr ty -> prim a)+ -> MUArray ty (PrimState prim)+ -> prim a+onMutableBackend onMba _ (MUArray _ _ (MUArrayMBA (MutableBlock mba))) = onMba mba+onMutableBackend _ onAddr (MUArray _ _ (MUArrayAddr fptr)) = onAddr fptr+{-# INLINE onMutableBackend #-}+++unsafeDewrap :: (ByteArray# -> Offset ty -> a)+ -> (Ptr ty -> Offset ty -> ST s a)+ -> UArray ty+ -> a+unsafeDewrap _ g (UArray start _ (UArrayAddr fptr)) = withUnsafeFinalPtr fptr $ \ptr -> g ptr start+unsafeDewrap f _ (UArray start _ (UArrayBA (Block ba))) = f ba start+{-# INLINE unsafeDewrap #-}++unsafeDewrap2 :: (ByteArray# -> ByteArray# -> a)+ -> (Ptr ty -> Ptr ty -> ST s a)+ -> (ByteArray# -> Ptr ty -> ST s a)+ -> (Ptr ty -> ByteArray# -> ST s a)+ -> UArray ty+ -> UArray ty+ -> a+unsafeDewrap2 f g h i (UArray _ _ back1) (UArray _ _ back2) =+ case (back1, back2) of+ (UArrayBA (Block ba1), UArrayBA (Block ba2)) -> f ba1 ba2+ (UArrayAddr fptr1, UArrayAddr fptr2) -> withUnsafeFinalPtr fptr1 $ \ptr1 -> withFinalPtr fptr2 $ \ptr2 -> g ptr1 ptr2+ (UArrayBA (Block ba1), UArrayAddr fptr2) -> withUnsafeFinalPtr fptr2 $ \ptr2 -> h ba1 ptr2+ (UArrayAddr fptr1, UArrayBA (Block ba2)) -> withUnsafeFinalPtr fptr1 $ \ptr1 -> i ptr1 ba2+{-# INLINE [2] unsafeDewrap2 #-}++pureST :: a -> ST s a+pureST = pure++-- | make an array from a list of elements.+vFromList :: PrimType ty => [ty] -> UArray ty+vFromList l = runST $ do+ ma <- new (CountOf len)+ iter azero l $ \i x -> unsafeWrite ma i x+ unsafeFreeze ma+ where len = List.length l+ iter _ [] _ = return ()+ iter !i (x:xs) z = z i x >> iter (i+1) xs z++-- | transform an array to a list.+vToList :: forall ty . PrimType ty => UArray ty -> [ty]+vToList a+ | len == 0 = []+ | otherwise = unsafeDewrap goBa goPtr a+ where+ !len = length a+ goBa ba start = loop start+ where+ !end = start `offsetPlusE` len+ loop !i | i == end = []+ | otherwise = primBaIndex ba i : loop (i+1)+ goPtr (Ptr addr) start = pureST (loop start)+ where+ !end = start `offsetPlusE` len+ loop !i | i == end = []+ | otherwise = primAddrIndex addr i : loop (i+1)++-- | Check if two vectors are identical+equal :: (PrimType ty, Eq ty) => UArray ty -> UArray ty -> Bool+equal a b+ | la /= lb = False+ | otherwise = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b+ where+ !start1 = offset a+ !start2 = offset b+ !end = start1 `offsetPlusE` la+ !la = length a+ !lb = length b+ goBaBa ba1 ba2 = loop start1 start2+ where+ loop !i !o | i == end = True+ | otherwise = primBaIndex ba1 i == primBaIndex ba2 o && loop (i+o1) (o+o1)+ goPtrPtr (Ptr addr1) (Ptr addr2) = pureST (loop start1 start2)+ where+ loop !i !o | i == end = True+ | otherwise = primAddrIndex addr1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1)+ goBaPtr ba1 (Ptr addr2) = pureST (loop start1 start2)+ where+ loop !i !o | i == end = True+ | otherwise = primBaIndex ba1 i == primAddrIndex addr2 o && loop (i+o1) (o+o1)+ goPtrBa (Ptr addr1) ba2 = pureST (loop start1 start2)+ where+ loop !i !o | i == end = True+ | otherwise = primAddrIndex addr1 i == primBaIndex ba2 o && loop (i+o1) (o+o1)++ o1 = Offset (I# 1#)+{-# RULES "UArray/Eq/Word8" [3] equal = equalBytes #-}+{-# INLINEABLE [2] equal #-}++equalBytes :: UArray Word8 -> UArray Word8 -> Bool+equalBytes a b+ | la /= lb = False+ | otherwise = memcmp a b (sizeInBytes la) == 0+ where+ !la = length a+ !lb = length b++equalMemcmp :: PrimType ty => UArray ty -> UArray ty -> Bool+equalMemcmp a b+ | la /= lb = False+ | otherwise = memcmp a b (sizeInBytes la) == 0+ where+ !la = length a+ !lb = length b++-- | Compare 2 vectors+vCompare :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering+vCompare a@(UArray start1 la _) b@(UArray start2 lb _) = unsafeDewrap2 goBaBa goPtrPtr goBaPtr goPtrBa a b+ where+ !end = start1 `offsetPlusE` min la lb+ o1 = Offset (I# 1#)+ goBaBa ba1 ba2 = loop start1 start2+ where+ loop !i !o | i == end = la `compare` lb+ | v1 == v2 = loop (i + o1) (o + o1)+ | otherwise = v1 `compare` v2+ where v1 = primBaIndex ba1 i+ v2 = primBaIndex ba2 o+ goPtrPtr (Ptr addr1) (Ptr addr2) = pureST (loop start1 start2)+ where+ loop !i !o | i == end = la `compare` lb+ | v1 == v2 = loop (i + o1) (o + o1)+ | otherwise = v1 `compare` v2+ where v1 = primAddrIndex addr1 i+ v2 = primAddrIndex addr2 o+ goBaPtr ba1 (Ptr addr2) = pureST (loop start1 start2)+ where+ loop !i !o | i == end = la `compare` lb+ | v1 == v2 = loop (i + o1) (o + o1)+ | otherwise = v1 `compare` v2+ where v1 = primBaIndex ba1 i+ v2 = primAddrIndex addr2 o+ goPtrBa (Ptr addr1) ba2 = pureST (loop start1 start2)+ where+ loop !i !o | i == end = la `compare` lb+ | v1 == v2 = loop (i + o1) (o + o1)+ | otherwise = v1 `compare` v2+ where v1 = primAddrIndex addr1 i+ v2 = primBaIndex ba2 o+-- {-# SPECIALIZE [3] vCompare :: UArray Word8 -> UArray Word8 -> Ordering = vCompareBytes #-}+{-# RULES "UArray/Ord/Word8" [3] vCompare = vCompareBytes #-}+{-# INLINEABLE [2] vCompare #-}++vCompareBytes :: UArray Word8 -> UArray Word8 -> Ordering+vCompareBytes = vCompareMemcmp++vCompareMemcmp :: (Ord ty, PrimType ty) => UArray ty -> UArray ty -> Ordering+vCompareMemcmp a b = cintToOrdering $ memcmp a b sz+ where+ la = length a+ lb = length b+ sz = sizeInBytes $ min la lb+ cintToOrdering :: CInt -> Ordering+ cintToOrdering 0 = la `compare` lb+ cintToOrdering r | r < 0 = LT+ | otherwise = GT+{-# SPECIALIZE [3] vCompareMemcmp :: UArray Word8 -> UArray Word8 -> Ordering #-}++memcmp :: PrimType ty => UArray ty -> UArray ty -> CountOf Word8 -> CInt+memcmp a@(UArray (offsetInBytes -> o1) _ _) b@(UArray (offsetInBytes -> o2) _ _) sz = unsafeDewrap2+ (\s1 s2 -> unsafeDupablePerformIO $ sysHsMemcmpBaBa s1 o1 s2 o2 sz)+ (\s1 s2 -> unsafePrimToST $ sysHsMemcmpPtrPtr s1 o1 s2 o2 sz)+ (\s1 s2 -> unsafePrimToST $ sysHsMemcmpBaPtr s1 o1 s2 o2 sz)+ (\s1 s2 -> unsafePrimToST $ sysHsMemcmpPtrBa s1 o1 s2 o2 sz)+ a b+{-# SPECIALIZE [3] memcmp :: UArray Word8 -> UArray Word8 -> CountOf Word8 -> CInt #-}++-- | Copy a number of elements from an array to another array with offsets+copyAt :: forall prim ty . (PrimMonad prim, PrimType ty)+ => MUArray ty (PrimState prim) -- ^ destination array+ -> Offset ty -- ^ offset at destination+ -> MUArray ty (PrimState prim) -- ^ source array+ -> Offset ty -- ^ offset at source+ -> CountOf ty -- ^ number of elements to copy+ -> prim ()+copyAt (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (MUArray srcStart _ (MUArrayMBA (MutableBlock srcBa))) es n =+ primitive $ \st -> (# copyMutableByteArray# srcBa os dstMba od nBytes st, () #)+ where+ !sz = primSizeInBytes (Proxy :: Proxy ty)+ !(Offset (I# os)) = offsetOfE sz (srcStart + es)+ !(Offset (I# od)) = offsetOfE sz (dstStart + ed)+ !(CountOf (I# nBytes)) = sizeOfE sz n+copyAt (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (MUArray srcStart _ (MUArrayAddr srcFptr)) es n =+ withFinalPtr srcFptr $ \srcPtr ->+ let !(Ptr srcAddr) = srcPtr `plusPtr` os+ in primitive $ \s -> (# compatCopyAddrToByteArray# srcAddr dstMba od nBytes s, () #)+ where+ !sz = primSizeInBytes (Proxy :: Proxy ty)+ !(Offset os) = offsetOfE sz (srcStart + es)+ !(Offset (I# od)) = offsetOfE sz (dstStart + ed)+ !(CountOf (I# nBytes)) = sizeOfE sz n+copyAt dst od src os n = loop od os+ where+ !endIndex = os `offsetPlusE` n+ loop !d !i+ | i == endIndex = return ()+ | otherwise = unsafeRead src i >>= unsafeWrite dst d >> loop (d+1) (i+1)++-- TODO Optimise with copyByteArray#+-- | Copy @n@ sequential elements from the specified offset in a source array+-- to the specified position in a destination array.+--+-- This function does not check bounds. Accessing invalid memory can return+-- unpredictable and invalid values.+unsafeCopyAtRO :: forall prim ty . (PrimMonad prim, PrimType ty)+ => MUArray ty (PrimState prim) -- ^ destination array+ -> Offset ty -- ^ offset at destination+ -> UArray ty -- ^ source array+ -> Offset ty -- ^ offset at source+ -> CountOf ty -- ^ number of elements to copy+ -> prim ()+unsafeCopyAtRO (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (UArray srcStart _ (UArrayBA (Block srcBa))) es n =+ primitive $ \st -> (# copyByteArray# srcBa os dstMba od nBytes st, () #)+ where+ sz = primSizeInBytes (Proxy :: Proxy ty)+ !(Offset (I# os)) = offsetOfE sz (srcStart+es)+ !(Offset (I# od)) = offsetOfE sz (dstStart+ed)+ !(CountOf (I# nBytes)) = sizeOfE sz n+unsafeCopyAtRO (MUArray dstStart _ (MUArrayMBA (MutableBlock dstMba))) ed (UArray srcStart _ (UArrayAddr srcFptr)) es n =+ withFinalPtr srcFptr $ \srcPtr ->+ let !(Ptr srcAddr) = srcPtr `plusPtr` os+ in primitive $ \s -> (# compatCopyAddrToByteArray# srcAddr dstMba od nBytes s, () #)+ where+ sz = primSizeInBytes (Proxy :: Proxy ty)+ !(Offset os) = offsetOfE sz (srcStart+es)+ !(Offset (I# od)) = offsetOfE sz (dstStart+ed)+ !(CountOf (I# nBytes)) = sizeOfE sz n+unsafeCopyAtRO dst od src os n = loop od os+ where+ !endIndex = os `offsetPlusE` n+ loop d i+ | i == endIndex = return ()+ | otherwise = unsafeWrite dst d (unsafeIndex src i) >> loop (d+1) (i+1)++empty_ :: Block ()+empty_ = runST $ primitive $ \s1 ->+ case newByteArray# 0# s1 of { (# s2, mba #) ->+ case unsafeFreezeByteArray# mba s2 of { (# s3, ba #) ->+ (# s3, Block ba #) }}++empty :: UArray ty+empty = UArray 0 0 (UArrayBA $ Block ba) where !(Block ba) = empty_++-- | Append 2 arrays together by creating a new bigger array+append :: PrimType ty => UArray ty -> UArray ty -> UArray ty+append a b+ | la == azero = b+ | lb == azero = a+ | otherwise = runST $ do+ r <- new (la+lb)+ ma <- unsafeThaw a+ mb <- unsafeThaw b+ copyAt r (Offset 0) ma (Offset 0) la+ copyAt r (sizeAsOffset la) mb (Offset 0) lb+ unsafeFreeze r+ where+ !la = length a+ !lb = length b++concat :: PrimType ty => [UArray ty] -> UArray ty+concat [] = empty+concat l =+ case filterAndSum (CountOf 0) [] l of+ (_,[]) -> empty+ (_,[x]) -> x+ (totalLen,chunks) -> runST $ do+ r <- new totalLen+ doCopy r (Offset 0) chunks+ unsafeFreeze r+ where+ -- TODO would go faster not to reverse but pack from the end instead+ filterAndSum !totalLen acc [] = (totalLen, List.reverse acc)+ filterAndSum !totalLen acc (x:xs)+ | len == CountOf 0 = filterAndSum totalLen acc xs+ | otherwise = filterAndSum (len+totalLen) (x:acc) xs+ where len = length x++ doCopy _ _ [] = return ()+ doCopy r i (x:xs) = do+ unsafeCopyAtRO r i x (Offset 0) lx+ doCopy r (i `offsetPlusE` lx) xs+ where lx = length x++touch :: PrimMonad prim => UArray ty -> prim ()+touch (UArray _ _ (UArrayBA blk)) = BLK.touch blk+touch (UArray _ _ (UArrayAddr fptr)) = touchFinalPtr fptr
Foundation/Primitive/UTF8/Addr.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Foundation.Primitive.UTF8.Addr@@ -15,8 +14,14 @@ , prev , prevSkip , write+ , toList+ , all+ , any+ , foldr+ , length -- temporary , primIndex+ , primIndex64 , primRead , primWrite ) where@@ -25,15 +30,17 @@ import GHC.Types import GHC.Word import GHC.Prim-import Foundation.Internal.Base+import Data.Bits+import Foundation.Internal.Base hiding (toList) import Foundation.Internal.Primitive+import Foundation.Internal.Proxy import Foundation.Numerical import Foundation.Primitive.Types.OffsetSize import Foundation.Primitive.Monad import Foundation.Primitive.Types import Foundation.Primitive.UTF8.Helper import Foundation.Primitive.UTF8.Table-import Foundation.Bits+import Foundation.Primitive.UTF8.Types type Immutable = Addr# type Mutable (prim :: * -> *) = Addr#@@ -47,33 +54,34 @@ primIndex :: Immutable -> Offset Word8 -> Word8 primIndex = primAddrIndex +primIndex64 :: Immutable -> Offset Word64 -> Word64+primIndex64 = primAddrIndex -nextAscii :: Immutable -> Offset Word8 -> (# Word8, Bool #)-nextAscii ba n = (# w, not (testBit w 7) #)+nextAscii :: Immutable -> Offset Word8 -> StepASCII+nextAscii ba n = StepASCII w where !w = primIndex ba n {-# INLINE nextAscii #-} -- | nextAsciiBa specialized to get a digit between 0 and 9 (included)-nextAsciiDigit :: Immutable -> Offset Word8 -> (# Word8, Bool #)-nextAsciiDigit ba n = (# d, d < 0xa #)- where !d = primIndex ba n - 0x30+nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit+nextAsciiDigit ba n = StepDigit (primIndex ba n - 0x30) {-# INLINE nextAsciiDigit #-} expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool expectAscii ba n v = primIndex ba n == v {-# INLINE expectAscii #-} -next :: Immutable -> Offset8 -> (# Char, Offset8 #)+next :: Immutable -> Offset8 -> Step next ba n = case getNbBytes h of- 0 -> (# toChar1 h, n + Offset 1 #)- 1 -> (# toChar2 h (primIndex ba (n + Offset 1)) , n + Offset 2 #)- 2 -> (# toChar3 h (primIndex ba (n + Offset 1))- (primIndex ba (n + Offset 2)) , n + Offset 3 #)- 3 -> (# toChar4 h (primIndex ba (n + Offset 1))- (primIndex ba (n + Offset 2))- (primIndex ba (n + Offset 3)) , n + Offset 4 #)+ 0 -> Step (toChar1 h) (n + Offset 1)+ 1 -> Step (toChar2 h (primIndex ba (n + Offset 1))) (n + Offset 2)+ 2 -> Step (toChar3 h (primIndex ba (n + Offset 1))+ (primIndex ba (n + Offset 2))) (n + Offset 3)+ 3 -> Step (toChar4 h (primIndex ba (n + Offset 1))+ (primIndex ba (n + Offset 2))+ (primIndex ba (n + Offset 3))) (n + Offset 4) r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h) where !h = primIndex ba n@@ -81,11 +89,11 @@ -- Given a non null offset, give the previous character and the offset of this character -- will fail bad if apply at the beginning of string or an empty string.-prev :: Immutable -> Offset Word8 -> (# Char, Offset8 #)+prev :: Immutable -> Offset Word8 -> StepBack prev ba offset = case primIndex ba prevOfs1 of (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1)- | otherwise -> (# toChar# v1, prevOfs1 #)+ | otherwise -> StepBack (toChar# v1) prevOfs1 where sz1 = CountOf 1 !prevOfs1 = offset `offsetMinusE` sz1@@ -95,14 +103,14 @@ atLeast2 !v = case primIndex ba prevOfs2 of (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v)- | otherwise -> (# toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v), prevOfs2 #)+ | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 atLeast3 !v = case primIndex ba prevOfs3 of (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v)- | otherwise -> (# toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v), prevOfs3 #)+ | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 atLeast4 !v = case primIndex ba prevOfs4 of- (W8# v4) -> (# toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v), prevOfs4 #)+ (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 prevSkip :: Immutable -> Offset Word8 -> Offset Word8 prevSkip ba offset = loop (offset `offsetMinusE` sz1)@@ -153,3 +161,84 @@ toContinuation :: Word# -> Word# toContinuation w = or# (and# w 0x3f##) 0x80## {-# INLINE write #-}++toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char]+toList ba !start !end = loop start+ where+ loop !idx+ | idx == end = []+ | otherwise = c : loop idx'+ where (Step c idx') = next ba idx++all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool+all predicate ba start end = loop start+ where+ loop !idx+ | idx == end = True+ | predicate c = loop idx'+ | otherwise = False+ where (Step c idx') = next ba idx+{-# INLINE all #-}++any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool+any predicate ba start end = loop start+ where+ loop !idx+ | idx == end = False+ | predicate c = True+ | otherwise = loop idx'+ where (Step c idx') = next ba idx+{-# INLINE any #-}++foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a+foldr dat start end f acc = loop start+ where+ loop !i+ | i == end = acc+ | otherwise =+ let (Step c i') = next dat i+ in c `f` loop i'+{-# INLINE foldr #-}++length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char+length dat start end+ | start == end = 0+ | otherwise = processStart 0 start+ where+ end64 :: Offset Word64+ end64 = offsetInElements end++ prx64 :: Proxy Word64+ prx64 = Proxy++ mask64_80 :: Word64+ mask64_80 = 0x8080808080808080++ processStart :: CountOf Char -> Offset Word8 -> CountOf Char+ processStart !c !i+ | i == end = c+ | offsetIsAligned prx64 i = processAligned c (offsetInElements i)+ | otherwise =+ let h = primIndex dat i+ cont = (h .&. 0xc0) == 0x80+ c' = if cont then c else c+1+ in processStart c' (i+1)+ processAligned :: CountOf Char -> Offset Word64 -> CountOf Char+ processAligned !c !i+ | i >= end64 = processEnd c (offsetInBytes i)+ | otherwise =+ let !h = primIndex64 dat i+ !h80 = h .&. mask64_80+ in if h80 == 0+ then processAligned (c+8) (i+1)+ else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80)+ !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1))+ in processAligned (c + nbAscii + nbHigh) (i+1)+ processEnd !c !i+ | i == end = c+ | otherwise =+ let h = primIndex dat i+ cont = (h .&. 0xc0) == 0x80+ c' = if cont then c else c+1+ in processStart c' (i+1)+{-# INLINE length #-}
Foundation/Primitive/UTF8/BA.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Foundation.Primitive.UTF8.BA@@ -15,8 +14,14 @@ , prev , prevSkip , write+ , toList+ , all+ , any+ , foldr+ , length -- temporary , primIndex+ , primIndex64 , primRead , primWrite ) where@@ -25,15 +30,17 @@ import GHC.Types import GHC.Word import GHC.Prim-import Foundation.Internal.Base+import Data.Bits+import Foundation.Internal.Base hiding (toList) import Foundation.Internal.Primitive+import Foundation.Internal.Proxy import Foundation.Numerical import Foundation.Primitive.Types.OffsetSize import Foundation.Primitive.Monad import Foundation.Primitive.Types import Foundation.Primitive.UTF8.Helper import Foundation.Primitive.UTF8.Table-import Foundation.Bits+import Foundation.Primitive.UTF8.Types type Immutable = ByteArray# type Mutable prim = MutableByteArray# (PrimState prim)@@ -47,33 +54,34 @@ primIndex :: Immutable -> Offset Word8 -> Word8 primIndex = primBaIndex +primIndex64 :: Immutable -> Offset Word64 -> Word64+primIndex64 = primBaIndex -nextAscii :: Immutable -> Offset Word8 -> (# Word8, Bool #)-nextAscii ba n = (# w, not (testBit w 7) #)+nextAscii :: Immutable -> Offset Word8 -> StepASCII+nextAscii ba n = StepASCII w where !w = primIndex ba n {-# INLINE nextAscii #-} -- | nextAsciiBa specialized to get a digit between 0 and 9 (included)-nextAsciiDigit :: Immutable -> Offset Word8 -> (# Word8, Bool #)-nextAsciiDigit ba n = (# d, d < 0xa #)- where !d = primIndex ba n - 0x30+nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit+nextAsciiDigit ba n = StepDigit (primIndex ba n - 0x30) {-# INLINE nextAsciiDigit #-} expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool expectAscii ba n v = primIndex ba n == v {-# INLINE expectAscii #-} -next :: Immutable -> Offset8 -> (# Char, Offset8 #)+next :: Immutable -> Offset8 -> Step next ba n = case getNbBytes h of- 0 -> (# toChar1 h, n + Offset 1 #)- 1 -> (# toChar2 h (primIndex ba (n + Offset 1)) , n + Offset 2 #)- 2 -> (# toChar3 h (primIndex ba (n + Offset 1))- (primIndex ba (n + Offset 2)) , n + Offset 3 #)- 3 -> (# toChar4 h (primIndex ba (n + Offset 1))- (primIndex ba (n + Offset 2))- (primIndex ba (n + Offset 3)) , n + Offset 4 #)+ 0 -> Step (toChar1 h) (n + Offset 1)+ 1 -> Step (toChar2 h (primIndex ba (n + Offset 1))) (n + Offset 2)+ 2 -> Step (toChar3 h (primIndex ba (n + Offset 1))+ (primIndex ba (n + Offset 2))) (n + Offset 3)+ 3 -> Step (toChar4 h (primIndex ba (n + Offset 1))+ (primIndex ba (n + Offset 2))+ (primIndex ba (n + Offset 3))) (n + Offset 4) r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h) where !h = primIndex ba n@@ -81,11 +89,11 @@ -- Given a non null offset, give the previous character and the offset of this character -- will fail bad if apply at the beginning of string or an empty string.-prev :: Immutable -> Offset Word8 -> (# Char, Offset8 #)+prev :: Immutable -> Offset Word8 -> StepBack prev ba offset = case primIndex ba prevOfs1 of (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1)- | otherwise -> (# toChar# v1, prevOfs1 #)+ | otherwise -> StepBack (toChar# v1) prevOfs1 where sz1 = CountOf 1 !prevOfs1 = offset `offsetMinusE` sz1@@ -95,14 +103,14 @@ atLeast2 !v = case primIndex ba prevOfs2 of (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v)- | otherwise -> (# toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v), prevOfs2 #)+ | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 atLeast3 !v = case primIndex ba prevOfs3 of (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v)- | otherwise -> (# toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v), prevOfs3 #)+ | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 atLeast4 !v = case primIndex ba prevOfs4 of- (W8# v4) -> (# toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v), prevOfs4 #)+ (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 prevSkip :: Immutable -> Offset Word8 -> Offset Word8 prevSkip ba offset = loop (offset `offsetMinusE` sz1)@@ -153,3 +161,84 @@ toContinuation :: Word# -> Word# toContinuation w = or# (and# w 0x3f##) 0x80## {-# INLINE write #-}++toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char]+toList ba !start !end = loop start+ where+ loop !idx+ | idx == end = []+ | otherwise = c : loop idx'+ where (Step c idx') = next ba idx++all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool+all predicate ba start end = loop start+ where+ loop !idx+ | idx == end = True+ | predicate c = loop idx'+ | otherwise = False+ where (Step c idx') = next ba idx+{-# INLINE all #-}++any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool+any predicate ba start end = loop start+ where+ loop !idx+ | idx == end = False+ | predicate c = True+ | otherwise = loop idx'+ where (Step c idx') = next ba idx+{-# INLINE any #-}++foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a+foldr dat start end f acc = loop start+ where+ loop !i+ | i == end = acc+ | otherwise =+ let (Step c i') = next dat i+ in c `f` loop i'+{-# INLINE foldr #-}++length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char+length dat start end+ | start == end = 0+ | otherwise = processStart 0 start+ where+ end64 :: Offset Word64+ end64 = offsetInElements end++ prx64 :: Proxy Word64+ prx64 = Proxy++ mask64_80 :: Word64+ mask64_80 = 0x8080808080808080++ processStart :: CountOf Char -> Offset Word8 -> CountOf Char+ processStart !c !i+ | i == end = c+ | offsetIsAligned prx64 i = processAligned c (offsetInElements i)+ | otherwise =+ let h = primIndex dat i+ cont = (h .&. 0xc0) == 0x80+ c' = if cont then c else c+1+ in processStart c' (i+1)+ processAligned :: CountOf Char -> Offset Word64 -> CountOf Char+ processAligned !c !i+ | i >= end64 = processEnd c (offsetInBytes i)+ | otherwise =+ let !h = primIndex64 dat i+ !h80 = h .&. mask64_80+ in if h80 == 0+ then processAligned (c+8) (i+1)+ else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80)+ !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1))+ in processAligned (c + nbAscii + nbHigh) (i+1)+ processEnd !c !i+ | i == end = c+ | otherwise =+ let h = primIndex dat i+ cont = (h .&. 0xc0) == 0x80+ c' = if cont then c else c+1+ in processStart c' (i+1)+{-# INLINE length #-}
Foundation/Primitive/UTF8/Base.hs view
@@ -10,7 +10,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Foundation.Primitive.UTF8.Base@@ -22,13 +21,13 @@ import GHC.Prim import Foundation.Internal.Base import Foundation.Numerical-import Foundation.Bits import Foundation.Class.Bifunctor import Foundation.Primitive.NormalForm import Foundation.Primitive.Types.OffsetSize import Foundation.Primitive.Monad import Foundation.Primitive.FinalPtr import Foundation.Primitive.UTF8.Helper+import Foundation.Primitive.UTF8.Types import qualified Foundation.Primitive.UTF8.BA as PrimBA import qualified Foundation.Primitive.UTF8.Addr as PrimAddr import Foundation.Array.Unboxed (UArray)@@ -36,6 +35,7 @@ import qualified Foundation.Array.Unboxed as C import Foundation.Array.Unboxed.ByteArray (MutableByteArray) import qualified Foundation.Array.Unboxed.Mutable as MVec+import Foundation.Primitive.UArray.Base as Vec (offset, pureST, onBackend) import Foundation.String.ModifiedUTF8 (fromModified) import GHC.CString (unpackCString#, unpackCStringUtf8#) @@ -90,7 +90,7 @@ loop idx | idx .==# nbBytes = [] | otherwise =- let (# c , idx' #) = next s idx in c : loop idx'+ let !(Step c idx') = next s idx in c : loop idx' {-# RULES "String sFromList" forall s .@@ -119,35 +119,26 @@ loop idx (c:xs) = write ms idx c >>= \idx' -> loop idx' xs {-# INLINE [0] sFromList #-} -next :: String -> Offset8 -> (# Char, Offset8 #)-next (String array) n =- case array of- Vec.UVecBA start _ _ ba -> let (# c, o #) = PrimBA.next ba (start + n)- in (# c, o `offsetSub` start #)- Vec.UVecAddr start _ fptr -> unt2 $ withUnsafeFinalPtr fptr $ \(Ptr ptr) -> pureST $ t2 start (PrimAddr.next ptr (start + n))+next :: String -> Offset8 -> Step+next (String array) !n = Vec.onBackend nextNative nextAddr array where- pureST :: a -> ST s a- pureST = pure- unt2 (a,b) = (# a, b #)- t2 x (# a, b #) = (a, b `offsetSub` x)+ !start = Vec.offset array+ reoffset (Step a ofs) = Step a (ofs `offsetSub` start)+ nextNative ba = reoffset (PrimBA.next ba (start + n))+ nextAddr _ (Ptr ptr) = pureST $ reoffset (PrimAddr.next ptr (start + n)) -prev :: String -> Offset8 -> (# Char, Offset8 #)-prev (String array) n =- case array of- Vec.UVecBA start _ _ ba -> let (# c, o #) = PrimBA.prev ba (start + n)- in (# c, o `offsetSub` start #)- Vec.UVecAddr start _ fptr -> unt2 $ withUnsafeFinalPtr fptr $ \(Ptr ptr) -> pureST $ t2 start (PrimAddr.prev ptr (start + n))+prev :: String -> Offset8 -> StepBack+prev (String array) !n = Vec.onBackend prevNative prevAddr array where- pureST :: a -> ST s a- pureST = pure- unt2 (a,b) = (# a, b #)- t2 x (# a, b #) = (a, b `offsetSub` x)+ !start = Vec.offset array+ reoffset (StepBack a ofs) = StepBack a (ofs `offsetSub` start)+ prevNative ba = reoffset (PrimBA.prev ba (start + n))+ prevAddr _ (Ptr ptr) = pureST $ reoffset (PrimAddr.prev ptr (start + n)) -- A variant of 'next' when you want the next character--- to be ASCII only. if Bool is False, then it's not ascii,--- otherwise it is and the return Word8 is valid.-nextAscii :: String -> Offset8 -> (# Word8, Bool #)-nextAscii (String ba) n = (# w, not (testBit w 7) #)+-- to be ASCII only.+nextAscii :: String -> Offset8 -> StepASCII+nextAscii (String ba) n = StepASCII w where !w = Vec.unsafeIndex ba n @@ -157,9 +148,10 @@ write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8 write (MutableString marray) ofs c =- case marray of- MVec.MUVecMA start _ _ mba -> PrimBA.write mba (start + ofs) c- MVec.MUVecAddr start _ fptr -> withFinalPtr fptr $ \(Ptr ptr) -> PrimAddr.write ptr (start + ofs) c+ MVec.onMutableBackend (\mba -> PrimBA.write mba (start + ofs) c)+ (\fptr -> withFinalPtr fptr $ \(Ptr ptr) -> PrimAddr.write ptr (start + ofs) c)+ marray+ where start = MVec.mutableOffset marray -- | Allocate a MutableString of a specific size in bytes. new :: PrimMonad prim
Foundation/Primitive/UTF8/Helper.hs view
@@ -23,15 +23,6 @@ import GHC.Types import GHC.Word --- | Possible failure related to validating bytes of UTF8 sequences.-data ValidationFailure = InvalidHeader- | InvalidContinuation- | MissingByte- | BuildingFailure- deriving (Show,Eq,Typeable)--instance Exception ValidationFailure- -- mask an UTF8 continuation byte (stripping the leading 10 and returning 6 valid bits) maskContinuation# :: Word# -> Word# maskContinuation# v = and# v 0x3f##
+ Foundation/Primitive/UTF8/Types.hs view
@@ -0,0 +1,50 @@+module Foundation.Primitive.UTF8.Types+ (+ -- * Stepper+ Step(..)+ , StepBack(..)+ , StepASCII(..)+ , StepDigit(..)+ , isValidStepASCII+ , isValidStepDigit+ -- * Unicode Errors+ , ValidationFailure(..)+ ) where++import Foundation.Internal.Base+import Foundation.Primitive.Types.OffsetSize++-- | Step when walking a String+--+-- this is a return value composed of :+-- * the unicode code point read (Char) which need to be+-- between 0 and 0x10ffff (inclusive)+-- * The next offset to start reading the next unicode code point (or end)+data Step = Step {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8)++-- | Similar to Step but used when processing the string from the end.+--+-- The stepper is thus the previous character, and the offset of+-- the beginning of the previous character+data StepBack = StepBack {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8)++-- | Step when processing digits. the value is between 0 and 9 to be valid+newtype StepDigit = StepDigit Word8++-- | Step when processing ASCII character+newtype StepASCII = StepASCII Word8++isValidStepASCII :: StepASCII -> Bool+isValidStepASCII (StepASCII w) = w < 0x80++isValidStepDigit :: StepDigit -> Bool+isValidStepDigit (StepDigit w) = w < 0xa++-- | Possible failure related to validating bytes of UTF8 sequences.+data ValidationFailure = InvalidHeader+ | InvalidContinuation+ | MissingByte+ | BuildingFailure+ deriving (Show,Eq,Typeable)++instance Exception ValidationFailure
Foundation/Random.hs view
@@ -21,12 +21,13 @@ ( MonadRandom(..) , MonadRandomState(..) , RandomGen(..)- , getRandomPrimType+ -- , getRandomPrimType , withRandomGenerator , RNG , RNGv1 ) where +import Foundation.Class.Storable (peek) import Foundation.Internal.Base import Foundation.Primitive.Types.OffsetSize import Foundation.Internal.Proxy@@ -37,13 +38,23 @@ import qualified Foundation.Array.Unboxed.Mutable as A import GHC.ST import qualified Prelude+import qualified Foreign.Marshal.Alloc (alloca) -- | A monad constraint that allows to generate random bytes class (Functor m, Applicative m, Monad m) => MonadRandom m where getRandomBytes :: CountOf Word8 -> m (UArray Word8)+ getRandomWord64 :: m Word64+ getRandomF32 :: m Float+ getRandomF64 :: m Double instance MonadRandom IO where- getRandomBytes = getEntropy+ getRandomBytes = getEntropy+ getRandomWord64 = flip A.index 0 . A.unsafeRecast+ <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64))+ getRandomF32 = flip A.index 0 . A.unsafeRecast+ <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64))+ getRandomF64 = flip A.index 0 . A.unsafeRecast+ <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64)) -- | A Deterministic Random Generator (DRG) class class RandomGen gen where@@ -59,6 +70,13 @@ -- | Generate N bytes of randomness from a DRG randomGenerate :: CountOf Word8 -> gen -> (UArray Word8, gen) + -- | Generate a Word64 from a DRG+ randomGenerateWord64 :: gen -> (Word64, gen)++ randomGenerateF32 :: gen -> (Float, gen)++ randomGenerateF64 :: gen -> (Double, gen)+ -- | A simple Monad class very similar to a State Monad -- with the state being a RandomGenerator. newtype MonadRandomState gen a = MonadRandomState { runRandomState :: gen -> (a, gen) }@@ -82,10 +100,10 @@ instance RandomGen gen => MonadRandom (MonadRandomState gen) where getRandomBytes n = MonadRandomState (randomGenerate n)+ getRandomWord64 = MonadRandomState randomGenerateWord64+ getRandomF32 = MonadRandomState randomGenerateF32+ getRandomF64 = MonadRandomState randomGenerateF64 -getRandomPrimType :: forall randomly ty . (PrimType ty, MonadRandom randomly) => randomly ty-getRandomPrimType =- flip A.index 0 . A.unsafeRecast <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy ty)) -- | Run a pure computation with a Random Generator in the 'MonadRandomState' withRandomGenerator :: RandomGen gen@@ -114,6 +132,9 @@ | A.length bs == 32 = Just $ RNGv1 bs | otherwise = Nothing randomGenerate = rngv1Generate+ randomGenerateWord64 = rngv1GenerateWord64+ randomGenerateF32 = rngv1GenerateF32+ randomGenerateF64 = rngv1GenerateF64 rngv1KeySize :: CountOf Word8 rngv1KeySize = 32@@ -130,6 +151,33 @@ (,) <$> A.unsafeFreeze dst <*> (RNGv1 <$> A.unsafeFreeze newKey) +rngv1GenerateWord64 :: RNGv1 -> (Word64, RNGv1)+rngv1GenerateWord64 (RNGv1 key) = runST $ unsafePrimFromIO $+ Foreign.Marshal.Alloc.alloca $ \dst -> do+ newKey <- A.newPinned rngv1KeySize+ A.withMutablePtr newKey $ \newKeyP ->+ A.withPtr key $ \keyP ->+ c_rngv1_generate_word64 newKeyP dst keyP *> return ()+ (,) <$> peek dst <*> (RNGv1 <$> A.unsafeFreeze newKey)++rngv1GenerateF32 :: RNGv1 -> (Float, RNGv1)+rngv1GenerateF32 (RNGv1 key) = runST $ unsafePrimFromIO $+ Foreign.Marshal.Alloc.alloca $ \dst -> do+ newKey <- A.newPinned rngv1KeySize+ A.withMutablePtr newKey $ \newKeyP ->+ A.withPtr key $ \keyP ->+ c_rngv1_generate_f32 newKeyP dst keyP *> return ()+ (,) <$> peek dst <*> (RNGv1 <$> A.unsafeFreeze newKey)++rngv1GenerateF64 :: RNGv1 -> (Double, RNGv1)+rngv1GenerateF64 (RNGv1 key) = runST $ unsafePrimFromIO $+ Foreign.Marshal.Alloc.alloca $ \dst -> do+ newKey <- A.newPinned rngv1KeySize+ A.withMutablePtr newKey $ \newKeyP ->+ A.withPtr key $ \keyP ->+ c_rngv1_generate_f64 newKeyP dst keyP *> return ()+ (,) <$> peek dst <*> (RNGv1 <$> A.unsafeFreeze newKey)+ -- return 0 on success, !0 for failure foreign import ccall unsafe "foundation_rngV1_generate" c_rngv1_generate :: Ptr Word8 -- new key@@ -137,3 +185,21 @@ -> Ptr Word8 -- current key -> Word32 -- number of bytes to generate -> IO Word32++foreign import ccall unsafe "foundation_rngV1_generate_word64"+ c_rngv1_generate_word64 :: Ptr Word8 -- new key+ -> Ptr Word64 -- destination+ -> Ptr Word8 -- current key+ -> IO Word32++foreign import ccall unsafe "foundation_rngV1_generate_f32"+ c_rngv1_generate_f32 :: Ptr Word8 -- new key+ -> Ptr Float -- destination+ -> Ptr Word8 -- current key+ -> IO Word32++foreign import ccall unsafe "foundation_rngV1_generate_f64"+ c_rngv1_generate_f64 :: Ptr Word8 -- new key+ -> Ptr Double -- destination+ -> Ptr Word8 -- current key+ -> IO Word32
Foundation/String.hs view
@@ -37,6 +37,7 @@ , toBase64 , toBase64URL , toBase64OpenBSD+ , breakLine ) where import Foundation.String.UTF8
Foundation/String/ASCII.hs view
@@ -190,7 +190,7 @@ breakElem :: CUChar -> AsciiString -> (AsciiString, AsciiString) breakElem !el (AsciiString ba) =- let (# v1,v2 #) = Vec.splitElem el ba in (AsciiString v1, AsciiString v2)+ bimap AsciiString AsciiString $ Vec.breakElem el ba {-# INLINE breakElem #-} intersperse :: CUChar -> AsciiString -> AsciiString
Foundation/String/ModifiedUTF8.hs view
@@ -27,6 +27,7 @@ import Foundation.Internal.Base import Foundation.Primitive.Types.OffsetSize import qualified Foundation.Array.Unboxed as Vec+import qualified Foundation.Primitive.UArray.Base as Vec import Foundation.Array.Unboxed (UArray) import Foundation.Numerical import Foundation.Primitive.FinalPtr@@ -46,7 +47,7 @@ | otherwise = getAtIdx off : loop (off + 1) buildByteArray :: Addr# -> ST st (UArray Word8)-buildByteArray addr = Vec.UVecAddr (Offset 0) (CountOf 100000) `fmap`+buildByteArray addr = Vec.UArray (Offset 0) (CountOf 100000) . Vec.UArrayAddr <$> toFinalPtr (Ptr addr) (\_ -> return ()) -- | assuming the given ByteArray is a valid modified UTF-8 sequence of bytes
Foundation/String/UTF8.hs view
@@ -52,6 +52,7 @@ , span , break , breakElem+ , breakLine , dropWhile , singleton , charMap@@ -79,6 +80,10 @@ , isPrefixOf , isSuffixOf , isInfixOf+ , stripPrefix+ , stripSuffix+ , all+ , any -- * Legacy utility , lines , words@@ -108,6 +113,8 @@ import Foundation.Primitive.UTF8.Table import Foundation.Primitive.UTF8.Helper import Foundation.Primitive.UTF8.Base+import Foundation.Primitive.UTF8.Types+import Foundation.Primitive.UArray.Base as C (onBackendPrim, onBackend, offset, ValidRange(..), offsetsValidRange) import qualified Foundation.Primitive.UTF8.BA as PrimBA import qualified Foundation.Primitive.UTF8.Addr as PrimAddr import qualified Foundation.String.UTF8.BA as BackendBA@@ -411,7 +418,7 @@ loop prevIdx idx | idx == end = [sub s prevIdx idx] | otherwise =- let (# c, idx' #) = next s idx+ let !(Step c idx') = next s idx in if predicate c then sub s prevIdx idx : loop idx' idx' else loop prevIdx idx'@@ -464,7 +471,7 @@ | sz == 0 = (mempty, mempty) | otherwise = case asUTF8Char el of- UTF8_1 w -> let (# v1,v2 #) = Vec.splitElem w ba in (String v1, String v2)+ UTF8_1 w -> let !(v1,v2) = Vec.breakElem w ba in (String v1, String v2) _ -> runST $ Vec.unsafeIndexer ba go where sz = size s@@ -482,6 +489,15 @@ True -> return $ splitIndex idx s False -> loop idx' +-- | Same as break but cut on a line feed with an optional carriage return.+--+-- This is the same operation as 'breakElem LF' dropping the last character of the+-- string if it's a CR.+--+-- Also for efficiency reason (streaming), it returns if the last character was a CR character.+breakLine :: String -> Either Bool (String, String)+breakLine (String arr) = bimap String String <$> Vec.breakLine arr+ -- | Apply a @predicate@ to the string to return the longest prefix that satisfy the predicate and -- the remaining span :: (Char -> Bool) -> String -> (String, String)@@ -540,7 +556,7 @@ nextDstIdx' <- write dst nextDstIdx sep' return (nextSrcIdx, nextDstIdx') where- (# c, nextSrcIdx #) = next src' srcIdx+ !(Step c nextSrcIdx) = next src' srcIdx -- | Allocate a new @String@ with a fill function that has access to the characters of -- the source @String@.@@ -562,25 +578,13 @@ -- -- this size is available in o(n) length :: String -> CountOf Char-length (String ba)- | C.null ba = CountOf 0- | otherwise = Vec.unsafeDewrap goVec goAddr ba+length (String arr)+ | start == end = 0+ | otherwise = C.onBackend goVec (\_ -> pure . goAddr) arr where- goVec ma start = loop start (CountOf 0)- where- !end = start `offsetPlusE` Vec.length ba- loop !idx !i- | idx >= end = i- | otherwise = loop (idx `offsetPlusE` d) (i + CountOf 1)- where d = skipNextHeaderValue (primBaIndex ma idx)-- goAddr (Ptr ptr) start = return $ loop start (CountOf 0)- where- !end = start `offsetPlusE` Vec.length ba- loop !idx !i- | idx >= end = i- | otherwise = loop (idx `offsetPlusE` d) (i + CountOf 1)- where d = skipNextHeaderValue (primAddrIndex ptr idx)+ (C.ValidRange !start !end) = offsetsValidRange arr+ goVec ma = PrimBA.length ma start end+ goAddr (Ptr ptr) = PrimAddr.length ptr start end -- | Replicate a character @c@ @n@ times to create a string of length @n@ replicate :: CountOf Char -> Char -> String@@ -672,7 +676,7 @@ | srcIdx == srcEnd = return (offsetAsSize dstIdx, srcIdx) | dstIdx == endDst = return (offsetAsSize dstIdx, srcIdx) | otherwise =- let (# c, srcIdx' #) = next src srcIdx+ let !(Step c srcIdx') = next src srcIdx c' = f c -- the mapped char !nbBytes = charToBytes (fromEnum c') in -- check if we have room in the destination buffer@@ -721,7 +725,7 @@ unsnoc s@(String arr) | sz == 0 = Nothing | otherwise =- let (# c, idx #) = prev s (sizeAsOffset sz)+ let !(StepBack c idx) = prev s (sizeAsOffset sz) in Just (String $ Vec.take (offsetAsSize idx) arr, c) where sz = size s@@ -733,7 +737,7 @@ uncons s@(String ba) | null s = Nothing | otherwise =- let (# c, idx #) = next s azero+ let !(Step c idx) = next s azero in Just (c, String $ Vec.drop (offsetAsSize idx) ba) -- | Look for a predicate in the String and return the matched character, if any.@@ -745,7 +749,7 @@ loop idx | idx == end = Nothing | otherwise =- let (# c, idx' #) = next s idx+ let !(Step c idx') = next s idx in case predicate c of True -> Just c False -> loop idx'@@ -760,12 +764,13 @@ filter :: (Char -> Bool) -> String -> String filter predicate (String arr) = runST $ do (finalSize, dst) <- newNative sz $ \mba ->- case arr of- C.UVecBA start _ _ ba -> BackendBA.copyFilter predicate sz mba ba start- C.UVecAddr start _ fptr -> withFinalPtr fptr $ \(Ptr addr) -> BackendAddr.copyFilter predicate sz mba addr start+ C.onBackendPrim (\ba -> BackendBA.copyFilter predicate sz mba ba start)+ (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> BackendAddr.copyFilter predicate sz mba addr start)+ arr freezeShrink finalSize dst where- !sz = C.length arr+ !sz = C.length arr+ !start = C.offset arr -- | Reverse a string reverse :: String -> String@@ -818,7 +823,7 @@ index s n | ofs >= end = Nothing | otherwise =- let (# c, _ #) = next s ofs+ let (Step !c _) = next s ofs in Just c where !nbBytes = size s@@ -835,7 +840,7 @@ loop ofs idx | idx .==# sz = Nothing | otherwise =- let (# c, idx' #) = next s idx+ let !(Step c idx') = next s idx in case predicate c of True -> Just ofs False -> loop (ofs+1) idx'@@ -982,9 +987,15 @@ toBytes UTF16 (String bytes) = toEncoderBytes Encoder.UTF16 bytes toBytes UTF32 (String bytes) = toEncoderBytes Encoder.UTF32 bytes --- | Split lines in a string using newline as separation+-- | Split lines in a string using newline as separation.+--+-- Note that carriage return preceding a newline are also strip for+-- maximum compatibility between Windows and Unix system. lines :: String -> [String]-lines = fmap fromList . Prelude.lines . toList+lines s =+ case breakLine s of+ Left _ -> [s]+ Right (line,r) -> line : lines r -- | Split words in a string using spaces as separation --@@ -1052,7 +1063,7 @@ readIntegral :: (HasNegation i, IntegralUpsize Word8 i, Additive i, Multiplicative i, IsIntegral i) => String -> Maybe i readIntegral str | sz == 0 = Nothing- | otherwise = stringDewrap withBa withPtr str+ | otherwise = stringDewrap withBa (\(Ptr ptr) -> pure . withPtr ptr) str where !sz = size str withBa ba ofs =@@ -1062,10 +1073,10 @@ (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc _ -> Nothing where !endOfs = ofs `offsetPlusE` sz- withPtr (Ptr ptr) ofs = return $- let negativeSign = PrimAddr.expectAscii ptr ofs 0x2d+ withPtr addr ofs =+ let negativeSign = PrimAddr.expectAscii addr ofs 0x2d startOfs = if negativeSign then succ ofs else ofs- in case decimalDigitsPtr 0 ptr endOfs startOfs of+ in case decimalDigitsPtr 0 addr endOfs startOfs of (# acc, True, endOfs' #) | endOfs' > startOfs -> Just $! if negativeSign then negate acc else acc _ -> Nothing where !endOfs = ofs `offsetPlusE` sz@@ -1080,13 +1091,20 @@ -- Consume many digits until end of string. readNatural :: String -> Maybe Natural readNatural str- | sz == 0 = Nothing- | otherwise =- case decimalDigits 0 str 0 of- (# acc, True, endOfs #) | endOfs > 0 -> Just acc- _ -> Nothing+ | sz == 0 = Nothing+ | otherwise = stringDewrap withBa (\(Ptr ptr) -> pure . withPtr ptr) str where !sz = size str+ withBa ba stringStart =+ case decimalDigitsBA 0 ba eofs stringStart of+ (# acc, True, endOfs #) | endOfs > stringStart -> Just acc+ _ -> Nothing+ where eofs = stringStart `offsetPlusE` sz+ withPtr addr stringStart =+ case decimalDigitsPtr 0 addr eofs stringStart of+ (# acc, True, endOfs #) | endOfs > stringStart -> Just acc+ _ -> Nothing+ where eofs = stringStart `offsetPlusE` sz -- | Try to read a Double readDouble :: String -> Maybe Double@@ -1182,9 +1200,9 @@ | otherwise = -- consume 'E' or 'e' case PrimBA.nextAscii ba startOfs of- (# 0x45, True #) -> consumeExponantSign (startOfs+1)- (# 0x65, True #) -> consumeExponantSign (startOfs+1)- (# _ , _ #) -> Nothing+ StepASCII 0x45 -> consumeExponantSign (startOfs+1)+ StepASCII 0x65 -> consumeExponantSign (startOfs+1)+ _ -> Nothing where consumeExponantSign ofs | ofs == eofs = Nothing@@ -1195,7 +1213,7 @@ case decimalDigitsBA 0 ba eofs ofs of (# acc, True, endOfs #) | endOfs > ofs -> f isNegative integral floatingDigits (Just $! if exponentNegative then negate acc else acc) _ -> Nothing- withPtr (Ptr ptr) stringStart = return $+ withPtr (Ptr ptr) stringStart = pure $ let !isNegative = PrimAddr.expectAscii ptr stringStart 0x2d in consumeIntegral isNegative (if isNegative then stringStart+1 else stringStart) where@@ -1222,9 +1240,9 @@ | otherwise = -- consume 'E' or 'e' case PrimAddr.nextAscii ptr startOfs of- (# 0x45, True #) -> consumeExponantSign (startOfs+1)- (# 0x65, True #) -> consumeExponantSign (startOfs+1)- (# _ , _ #) -> Nothing+ StepASCII 0x45 -> consumeExponantSign (startOfs+1)+ StepASCII 0x65 -> consumeExponantSign (startOfs+1)+ _ -> Nothing where consumeExponantSign ofs | ofs == eofs = Nothing@@ -1258,26 +1276,6 @@ -- -- If end offset == start offset then no digits have been consumed by -- this function-decimalDigits :: (IntegralUpsize Word8 acc, Additive acc)- => acc- -> String- -> Offset Word8- -> (# acc, Bool, Offset Word8 #)-decimalDigits startAcc str startOfs = loop startAcc startOfs- where- !sz = size str- loop acc ofs- | ofs .==# sz = (# acc, True, ofs #)- | otherwise =- case nextAscii str ofs of- (# d, True #) | isDigit d -> loop (scale (10::Word) acc + fromDigit d) (ofs+1)- (# _, _ #) -> (# acc, False, ofs #)- ascii0 = 0x30 -- use pattern synonym when we support >= 8.0- ascii9 = 0x39- isDigit c = c >= ascii0 && c <= ascii9- fromDigit c = integralUpsize (c - ascii0)---- | same as decimalDigitsBA for a bytearray# decimalDigitsBA :: (IntegralUpsize Word8 acc, Additive acc, Multiplicative acc, Integral acc) => acc -> ByteArray#@@ -1290,8 +1288,8 @@ | ofs == endOfs = (# acc, True, ofs #) | otherwise = case PrimBA.nextAsciiDigit ba ofs of- (# d, True #) -> loop (10 * acc + integralUpsize d) (succ ofs)- (# _, _ #) -> (# acc, False, ofs #)+ sg@(StepDigit d) | isValidStepDigit sg -> loop (10 * acc + integralUpsize d) (succ ofs)+ | otherwise -> (# acc, False, ofs #) {-# SPECIALIZE decimalDigitsBA :: Integer -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-} {-# SPECIALIZE decimalDigitsBA :: Natural -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-} {-# SPECIALIZE decimalDigitsBA :: Int -> ByteArray# -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-}@@ -1310,8 +1308,8 @@ | ofs == endOfs = (# acc, True, ofs #) | otherwise = case PrimAddr.nextAsciiDigit ptr ofs of- (# d, True #) -> loop (10 * acc + integralUpsize d) (succ ofs)- (# _, _ #) -> (# acc, False, ofs #)+ sg@(StepDigit d) | isValidStepDigit sg -> loop (10 * acc + integralUpsize d) (succ ofs)+ | otherwise -> (# acc, False, ofs #) {-# SPECIALIZE decimalDigitsPtr :: Integer -> Addr# -> Offset Word8 -> Offset Word8 -> (# Integer, Bool, Offset Word8 #) #-} {-# SPECIALIZE decimalDigitsPtr :: Natural -> Addr# -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-} {-# SPECIALIZE decimalDigitsPtr :: Int -> Addr# -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-}@@ -1329,12 +1327,7 @@ -- | Check whether the first string is a prefix of the second string. isPrefixOf :: String -> String -> Bool-isPrefixOf (String needle) (String haystack)- | needleLen > hayLen = False- | otherwise = needle == C.take needleLen haystack- where- needleLen = C.length needle- hayLen = C.length haystack+isPrefixOf (String needle) (String haystack) = C.isPrefixOf needle haystack -- | Check whether the first string is a suffix of the second string. isSuffixOf :: String -> String -> Bool@@ -1362,6 +1355,38 @@ | needle == haystackSub = True | otherwise = loop (i+1) where haystackSub = C.take needleLen $ C.drop i haystack++-- | Try to strip a prefix from the start of a String.+--+-- If the prefix is not starting the string, then Nothing is returned,+-- otherwise the striped string is returned+stripPrefix :: String -> String -> Maybe String+stripPrefix (String suffix) (String arr)+ | C.isPrefixOf suffix arr = Just $ String $ C.drop (C.length suffix) arr+ | otherwise = Nothing++-- | Try to strip a suffix from the end of a String.+--+-- If the suffix is not ending the string, then Nothing is returned,+-- otherwise the striped string is returned+stripSuffix :: String -> String -> Maybe String+stripSuffix (String prefix) (String arr)+ | C.isSuffixOf prefix arr = Just $ String $ C.revDrop (C.length prefix) arr+ | otherwise = Nothing++all :: (Char -> Bool) -> String -> Bool+all predicate (String arr) = C.onBackend goNative (\_ -> pure . goAddr) arr+ where+ !(C.ValidRange start end) = C.offsetsValidRange arr+ goNative ba = PrimBA.all predicate ba start end+ goAddr (Ptr addr) = PrimAddr.all predicate addr start end++any :: (Char -> Bool) -> String -> Bool+any predicate (String arr) = C.onBackend goNative (\_ -> pure . goAddr) arr+ where+ !(C.ValidRange start end) = C.offsetsValidRange arr+ goNative ba = PrimBA.any predicate ba start end+ goAddr (Ptr addr) = PrimAddr.any predicate addr start end -- | Transform string @src@ to base64 binary representation. toBase64 :: String -> String
Foundation/String/UTF8/Addr.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Foundation.String.UTF8.Addr@@ -20,6 +19,7 @@ import qualified Foundation.Primitive.UTF8.Addr as PrimBackend import Foundation.Primitive.UTF8.Helper import Foundation.Primitive.UTF8.Table+import Foundation.Primitive.UTF8.Types copyFilter :: (Char -> Bool) -> CountOf Word8@@ -39,8 +39,8 @@ | otherwise -> loop d (s + Offset 1) False -> case PrimBackend.next src s of- (# c, s' #) | predicate c -> PrimBA.write dst d c >>= \d' -> loop d' s'- | otherwise -> loop d s'+ Step c s' | predicate c -> PrimBA.write dst d c >>= \d' -> loop d' s'+ | otherwise -> loop d s' validate :: Offset Word8 -> PrimBackend.Immutable
Foundation/String/UTF8/BA.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Foundation.String.UTF8.BA@@ -20,6 +19,7 @@ import qualified Foundation.Primitive.UTF8.BA as PrimBackend import Foundation.Primitive.UTF8.Helper import Foundation.Primitive.UTF8.Table+import Foundation.Primitive.UTF8.Types copyFilter :: (Char -> Bool) -> CountOf Word8@@ -39,8 +39,8 @@ | otherwise -> loop d (s + Offset 1) False -> case PrimBackend.next src s of- (# c, s' #) | predicate c -> PrimBA.write dst d c >>= \d' -> loop d' s'- | otherwise -> loop d s'+ Step c s' | predicate c -> PrimBA.write dst d c >>= \d' -> loop d' s'+ | otherwise -> loop d s' validate :: Offset Word8 -> PrimBackend.Immutable
Foundation/System/Bindings/Hs.hs view
@@ -6,19 +6,33 @@ import GHC.IO import GHC.Prim+import GHC.Word import Foreign.C.Types import Foreign.Ptr+import Foundation.Primitive.Types.OffsetSize foreign import ccall unsafe "HsBase.h __hscore_get_errno" sysHsCoreGetErrno :: IO CInt foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaBa ::- ByteArray# -> CSize -> ByteArray# -> CSize -> CSize -> IO CInt+ ByteArray# -> Offset Word8 -> ByteArray# -> Offset Word8 -> CountOf Word8 -> IO CInt foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaPtr ::- ByteArray# -> CSize -> Ptr a -> CSize -> CSize -> IO CInt+ ByteArray# -> Offset Word8 -> Ptr a -> Offset Word8 -> CountOf Word8 -> IO CInt foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrBa ::- Ptr a -> CSize -> ByteArray# -> CSize -> CSize -> IO CInt+ Ptr a -> Offset Word8 -> ByteArray# -> Offset Word8 -> CountOf Word8 -> IO CInt foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrPtr ::- Ptr a -> CSize -> Ptr b -> CSize -> CSize -> IO CInt+ Ptr a -> Offset Word8 -> Ptr b -> Offset Word8 -> CountOf Word8 -> IO CInt++foreign import ccall unsafe "_foundation_mem_findbyte" sysHsMemFindByteBa ::+ ByteArray# -> Offset Word8 -> Offset Word8 -> Word8 -> Offset Word8++foreign import ccall unsafe "_foundation_mem_findbyte" sysHsMemFindByteAddr ::+ Addr# -> Offset Word8 -> Offset Word8 -> Word8 -> Offset Word8++--foreign import ccall unsafe "foundation_utf8_length" sysHsUTF8LengthBa ::+-- ByteArray# -> Offset Word8 -> Offset Word8 -> CountOf Char++--foreign import ccall unsafe "foundation_utf8_length" sysHsUTF8LengthAddr ::+-- Addr# -> Offset Word8 -> Offset Word8 -> CountOf Char
Foundation/Time/Types.hs view
@@ -23,6 +23,7 @@ instance PrimType NanoSeconds where primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy Word64)+ primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy Word64) primBaUIndex ba ofs = primBaUIndex ba (coerce ofs) primMbaURead mba ofs = primMbaURead mba (coerce ofs) primMbaUWrite mba ofs v = primMbaUWrite mba (coerce ofs) (coerce v :: Word64)@@ -36,6 +37,7 @@ instance PrimType Seconds where primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy Word64)+ primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy Word64) primBaUIndex ba ofs = primBaUIndex ba (coerce ofs) primMbaURead mba ofs = primMbaURead mba (coerce ofs) primMbaUWrite mba ofs v = primMbaUWrite mba (coerce ofs) (coerce v :: Word64)
Foundation/UUID.hs view
@@ -1,18 +1,31 @@-{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ module Foundation.UUID ( UUID(..)+ , newUUID , nil , fromBinary+ , uuidParser ) where +import Control.Monad (unless)+import Data.Maybe (fromMaybe)+ import Foundation.Internal.Base+import Foundation.Collection (Element, Sequential, foldl') import Foundation.Class.Storable import Foundation.Hashing.Hashable import Foundation.Bits+import Foundation.Parser+import Foundation.Numerical import Foundation.Primitive import Foundation.Primitive.Base16 import Foundation.Primitive.IntegralConv+import Foundation.Primitive.Types.OffsetSize import qualified Foundation.Array.Unboxed as UA+import Foundation.Random (MonadRandom, getRandomBytes) data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 deriving (Eq,Ord,Typeable)@@ -59,6 +72,11 @@ nil :: UUID nil = UUID 0 0 +newUUID :: MonadRandom randomly => randomly UUID+newUUID = fromMaybe (error "Foundation.UUID.newUUID: the impossible happned")+ . fromBinary+ <$> getRandomBytes 16+ fromBinary :: UA.UArray Word8 -> Maybe UUID fromBinary ba | UA.length ba /= 16 = Nothing@@ -85,3 +103,55 @@ b13 = integralUpsize (UA.unsafeIndex ba 13) b14 = integralUpsize (UA.unsafeIndex ba 14) b15 = integralUpsize (UA.unsafeIndex ba 15)++uuidParser :: ( ParserSource input, Element input ~ Char+ , Sequential (Chunk input), Element input ~ Element (Chunk input)+ )+ => Parser input UUID+uuidParser = do+ hex1 <- parseHex (CountOf 8) <* element '-'+ hex2 <- parseHex (CountOf 4) <* element '-'+ hex3 <- parseHex (CountOf 4) <* element '-'+ hex4 <- parseHex (CountOf 4) <* element '-'+ hex5 <- parseHex (CountOf 12)+ return $ UUID (hex1 .<<. 32 .|. hex2 .<<. 16 .|. hex3)+ (hex4 .<<. 48 .|. hex5)+++parseHex :: ( ParserSource input, Element input ~ Char+ , Sequential (Chunk input), Element input ~ Element (Chunk input)+ )+ => CountOf Char -> Parser input Word64+parseHex count = do+ r <- toList <$> take count+ unless (and $ isValidHexa <$> r) $+ reportError $ Satisfy $ Just $ "expecting hexadecimal character only: "+ <> fromList (show r)+ return $ listToHex 0 r+ where+ listToHex = foldl' (\acc' x -> acc' * 16 + fromHex x)+ isValidHexa :: Char -> Bool+ isValidHexa c = ('0' <= c && c <= '9') || ('a' <= c && c <= 'f') || ('A' <= c && c <= 'F')+ fromHex '0' = 0+ fromHex '1' = 1+ fromHex '2' = 2+ fromHex '3' = 3+ fromHex '4' = 4+ fromHex '5' = 5+ fromHex '6' = 6+ fromHex '7' = 7+ fromHex '8' = 8+ fromHex '9' = 9+ fromHex 'a' = 10+ fromHex 'b' = 11+ fromHex 'c' = 12+ fromHex 'd' = 13+ fromHex 'e' = 14+ fromHex 'f' = 15+ fromHex 'A' = 10+ fromHex 'B' = 11+ fromHex 'C' = 12+ fromHex 'D' = 13+ fromHex 'E' = 14+ fromHex 'F' = 15+ fromHex _ = error "Foundation.UUID.parseUUID: the impossible happened"
benchs/Fake/ByteString.hs view
@@ -4,14 +4,23 @@ , length , splitAt , take+ , takeWhile , break , reverse , filter+ , foldl'+ , foldl1'+ , foldr+ , and+ , all+ , any , readInt , readInteger+ , unpack ) where import Prelude (undefined, Maybe(..))+import Data.Word data ByteString = ByteString @@ -20,8 +29,20 @@ splitAt _ _ = (undefined, undefined) take = undefined break _ _ = (undefined, undefined)+takeWhile _ _ = undefined reverse = undefined filter _ = undefined+foldl' :: (Word8 -> a -> a) -> a -> ByteString -> a+foldl' _ _ _ = undefined+foldl1' :: (Word8 -> Word8 -> Word8) -> ByteString -> a+foldl1' _ _ = undefined+foldr :: (a -> Word8 -> a) -> a -> ByteString -> a+foldr _ _ _ = undefined+and _ _ = undefined+all _ _ = undefined+any _ _ = undefined+unpack :: ByteString -> [Word8]+unpack = undefined readInt :: ByteString -> Maybe (a,b) readInt _ = undefined
benchs/Fake/Text.hs view
@@ -1,6 +1,7 @@ module Fake.Text ( Text , pack+ , unpack , length , splitAt , take@@ -12,11 +13,13 @@ , decodeUtf8 ) where -import Prelude (undefined, Either(..))+import Prelude (undefined, Either(..), Char) data Text = Text pack _ = Text+unpack :: Text -> [Char]+unpack _ = undefined length = undefined splitAt _ _ = (undefined, undefined) take = undefined
+ benchs/Fake/Vector.hs view
@@ -0,0 +1,42 @@+module Fake.Vector+ ( Vector+ , fromList+ , toList+ , length+ , splitAt+ , take+ , takeWhile+ , break+ , reverse+ , filter+ , foldl'+ , foldl1'+ , foldr+ , and+ , all+ , any+ ) where++import Prelude (undefined)++data Vector ty = Vector++fromList _ = Vector+toList :: Vector ty -> [ty]+toList _ = undefined+length = undefined+splitAt _ _ = (undefined, undefined)+take = undefined+break _ _ = (undefined, undefined)+takeWhile _ _ = undefined+reverse = undefined+filter _ = undefined+foldl' :: (ty -> a -> a) -> a -> Vector ty -> a+foldl' _ _ _ = undefined+foldl1' :: (ty -> ty -> ty) -> Vector ty -> a+foldl1' _ _ = undefined+foldr :: (a -> ty -> a) -> a -> Vector ty -> a+foldr _ _ _ = undefined+and _ _ = undefined+all _ _ = undefined+any _ _ = undefined
benchs/Main.hs view
@@ -8,6 +8,7 @@ import Foundation import Foundation.Collection+import Foundation.Primitive.Block (Block) import Foundation.String.Read import Foundation.String import BenchUtil.Common@@ -21,15 +22,18 @@ import qualified Data.Text as Text import qualified Data.Text.Read as Text import qualified Data.Text.Encoding as Text+import qualified Data.Vector.Unboxed as Vector #else import qualified Fake.ByteString as ByteString import qualified Fake.Text as Text+import qualified Fake.Vector as Vector #endif -------------------------------------------------------------------------- benchsString = bgroup "String" [ benchLength+ , benchUnpack , benchElem , benchTake , benchSplitAt@@ -97,6 +101,9 @@ benchLength = bgroup "Length" $ fmap (\(n, dat) -> bgroup n $ diffTextString length Text.length dat) allDat+ benchUnpack = bgroup "Unpack" $+ fmap (\(n, dat) -> bgroup n $ diffTextString (length . toList) (length . Text.unpack) dat)+ allDat benchElem = bgroup "Elem" $ fmap (\(n, dat) -> bgroup n $ diffTextString (elem '.') (Text.any (== '.')) dat) allDat@@ -160,25 +167,36 @@ benchsByteArray = bgroup "ByteArray" [ benchLength , benchTake+ , benchSplitAt , benchBreakElem+ , benchTakeWhile+ , benchFoldl+ , benchFoldl1+ , benchFoldr , benchReverse , benchFilter- --, benchSplitAt+ , benchAll ] where- diffByteString :: (UArray Word8 -> a)- -> (ByteString.ByteString -> b)+ diffByteArray :: (UArray Word8 -> a)+ -> (Block Word8 -> b)+ -> (ByteString.ByteString -> c)+ -> (Vector.Vector Word8 -> d) -> [Word8] -> [Benchmark]- diffByteString foundationBench textBench dat =- [ bench "UArray_W8" $ whnf foundationBench s+ diffByteArray uarrayBench blockBench bsBench vectorBench dat =+ [ bench "UArray_W8" $ whnf uarrayBench s+ , bench "Block_W8" $ whnf blockBench s' #ifdef BENCH_ALL- , bench "ByteString" $ whnf textBench t+ , bench "ByteString" $ whnf bsBench t+ , bench "Vector_W8" $ whnf vectorBench v #endif ] where s = fromList dat+ s' = fromList dat t = ByteString.pack dat+ v = Vector.fromList dat allDat = [ ("bs20", rdBytes20)@@ -188,23 +206,63 @@ allDatSuffix s = fmap (first (\x -> x <> "-" <> s)) allDat benchLength = bgroup "Length" $- fmap (\(n, dat) -> bgroup n $ diffByteString length ByteString.length dat) allDat+ fmap (\(n, dat) -> bgroup n $ diffByteArray length length ByteString.length Vector.length dat) allDat benchTake = bgroup "Take" $ mconcat $ fmap (\p ->- fmap (\(n, dat) -> bgroup n $ diffByteString (take (CountOf p)) (ByteString.take p) dat)+ fmap (\(n, dat) -> bgroup n $ diffByteArray (take (CountOf p)) (take (CountOf p))+ (ByteString.take p) (Vector.take p) dat) $ allDatSuffix (show p) ) [ 0, 10, 100 ] + benchSplitAt = bgroup "SplitAt" $ mconcat $ fmap (\p ->+ fmap (\(n, dat) -> bgroup n $ diffByteArray (fst . splitAt (CountOf p)) (fst . splitAt (CountOf p))+ (fst . ByteString.splitAt p) (fst . Vector.splitAt p) dat)+ $ allDatSuffix (show p)+ ) [ 19, 199, 0 ]+ benchBreakElem = bgroup "BreakElem" $ mconcat $ fmap (\p ->- fmap (\(n, dat) -> bgroup n $ diffByteString (fst . breakElem p) (fst . ByteString.break (== p)) dat)+ fmap (\(n, dat) -> bgroup n $ diffByteArray (fst . breakElem p) (fst . breakElem p)+ (fst . ByteString.break (== p)) (fst . Vector.break (== p)) dat) $ allDatSuffix (show p) ) [ 19, 199, 0 ] + benchTakeWhile = bgroup "TakeWhile" $ fmap (\(n, dat) ->+ bgroup n $ diffByteArray (takeWhile (< 0x80)) (takeWhile (< 0x80))+ (ByteString.takeWhile (< 0x80)) (Vector.takeWhile (< 0x80)) dat)+ $ allDat++ benchFoldl = bgroup "Foldl" $ fmap (\(n, dat) ->+ bgroup n $ diffByteArray (foldl' (+) 0) (foldl' (+) 0)+ (ByteString.foldl' (+) 0) (Vector.foldl' (+) 0) dat)+ $ allDat++ benchFoldl1 = bgroup "Foldl1" $ fmap (\(n, dat) ->+ bgroup n $ diffByteArray (foldl1' (+) . nonEmpty_) (foldl1' (+) . nonEmpty_)+ (ByteString.foldl1' (+)) (Vector.foldl1' (+)) dat)+ $ allDat++ benchFoldr = bgroup "Foldr" $ fmap (\(n, dat) ->+ bgroup n $ diffByteArray (foldr (+) 1) (foldr (+) 1)+ (ByteString.foldr (+) 1) (Vector.foldr (+) 1) dat)+ $ allDat++ benchAll = bgroup "All" $ fmap (\(n, dat) ->+ bgroup n $ diffByteArray (all (> 0)) (all (> 0))+ (ByteString.all (> 0)) (Vector.all (> 0)) dat)+ $ allDat++ benchAny = bgroup "Any" $ fmap (\(n, dat) ->+ bgroup n $ diffByteArray (any (== 80)) (any (== 80))+ (ByteString.any (== 80)) (Vector.any (== 80)) dat)+ $ allDat+ benchReverse = bgroup "Reverse" $- fmap (\(n, dat) -> bgroup n $ diffByteString reverse ByteString.reverse dat) allDat+ fmap (\(n, dat) -> bgroup n $ diffByteArray reverse reverse ByteString.reverse Vector.reverse dat) allDat benchFilter = bgroup "Filter" $- fmap (\(n, dat) -> bgroup n $ diffByteString (filter (> 100)) (ByteString.filter (> 100)) dat) allDat+ fmap (\(n, dat) -> bgroup n $ diffByteArray (filter (> 100)) (filter (> 100))+ (ByteString.filter (> 100))+ (Vector.filter (> 100)) dat) allDat --------------------------------------------------------------------------
benchs/Sys.hs view
@@ -19,6 +19,9 @@ randomNew = return NullRandom randomNewFrom = error "no randomNewFrom" randomGenerate (CountOf n) r = (fromList (Prelude.replicate n 0), r)+ randomGenerateWord64 r = (0, r)+ randomGenerateF32 r = (0.0, r)+ randomGenerateF64 r = (0.0, r) benchSys = [ bgroup "Random"
cbits/foundation_mem.c view
@@ -1,6 +1,14 @@ #include <string.h>+#include <stdint.h>+#include "foundation_prim.h" -int _foundation_memcmp(const void *s1, size_t off1, const void *s2, size_t off2, size_t n)+int _foundation_memcmp(const void *s1, FsOffset off1, const void *s2, FsOffset off2, FsCountOf n) { return memcmp(s1 + off1, s2 + off2, n);+}++FsOffset _foundation_mem_findbyte(uint8_t * const arr, FsOffset startofs, FsOffset endofs, uint8_t ty)+{+ uint8_t *r = memchr(arr + startofs, ty, endofs - startofs);+ return ((r == NULL) ? endofs : r - arr); }
+ cbits/foundation_prim.h view
@@ -0,0 +1,8 @@+#ifndef FOUNDATION_PRIM_H+#define FOUNDATION_PRIM_H+#include "Rts.h"++typedef StgInt FsOffset;+typedef StgInt FsCountOf;++#endif
cbits/foundation_random.c view
@@ -143,3 +143,34 @@ return 0; } +int foundation_rngV1_generate_word32(uint8_t newkey[CHACHA_KEY_SIZE], uint32_t *dst_w, uint8_t key[CHACHA_KEY_SIZE])+{+ return foundation_rngV1_generate(newkey, (uint8_t*)dst_w, key, sizeof(uint32_t));+}++int foundation_rngV1_generate_word64(uint8_t newkey[CHACHA_KEY_SIZE], uint64_t *dst_w, uint8_t key[CHACHA_KEY_SIZE])+{+ return foundation_rngV1_generate(newkey, (uint8_t*)dst_w, key, sizeof(uint64_t));+}++int foundation_rngV1_generate_f32(uint8_t newkey[CHACHA_KEY_SIZE], float *dst_w, uint8_t key[CHACHA_KEY_SIZE])+{+ uint32_t const UPPER_MASK = 0x3F800000UL;+ uint32_t const LOWER_MASK = 0x007FFFFFUL;+ uint32_t tmp32;+ int r = foundation_rngV1_generate_word32(newkey, &tmp32, key);+ tmp32 = UPPER_MASK | (tmp32 & LOWER_MASK);+ *dst_w = (float)tmp32 - 1.0;+ return r;+}++int foundation_rngV1_generate_f64(uint8_t newkey[CHACHA_KEY_SIZE], double *dst_w, uint8_t key[CHACHA_KEY_SIZE])+{+ uint64_t const UPPER_MASK = 0x3FF0000000000000ULL;+ uint64_t const LOWER_MASK = 0x000FFFFFFFFFFFFFULL;+ uint64_t tmp64;+ int r = foundation_rngV1_generate_word64(newkey, &tmp64, key);+ tmp64 = UPPER_MASK | (tmp64 & LOWER_MASK);+ *dst_w = (double)tmp64 - 1.0;+ return r;+}
+ cbits/foundation_rts.c view
@@ -0,0 +1,8 @@+#include "Rts.h"++#if __GLASGOW_HASKELL__ < 802+int foundation_is_bytearray_pinned(void *p)+{+ return Bdescr((StgPtr) p)->flags & BF_PINNED;+}+#endif
+ cbits/foundation_utf8.c view
@@ -0,0 +1,85 @@+#include <stdint.h>+#include <stdlib.h>+#include "foundation_prim.h"++#if 0+static const uint64_t utf8_mask_80 = 0x8080808080808080ULL;+static const uint64_t utf8_mask_40 = 0x4040404040404040ULL;++typedef unsigned long pu;+#define POPCOUNT(x) __builtin_popcountl(x)+#define ALIGNED8(p) ((((uintptr_t) (p)) & (sizeof(pu)-1)) == 0)++FsCountOf foundation_utf8_length(uint8_t *p8, const FsOffset start_offset, const FsOffset end_offset)+{+ const uint8_t *end = p8 + end_offset;+ FsCountOf n = 0;++ p8 += start_offset;++ while (!ALIGNED8(p8) && p8 < end) {+ if ((*p8++ & 0xc0) != 0x80) { n++; }+ }++ /* process 8 bytes */+ for (; (p8 + sizeof(pu)) <= end; p8 += sizeof(pu)) {+ pu h = *((pu *) p8);+ pu h80 = h & utf8_mask_80;++ /* only ASCII */+ if (h80 == 0) {+ n += sizeof(pu);+ continue;+ }++ int nb_ascii = (h80 == utf8_mask_80) ? 0 : (8 - __builtin_popcountl(h80));+ int nb_high = __builtin_popcountl( h & (h80 >> 1));+ n += nb_ascii + nb_high;+ }++ while (p8 < end) {+ if ((*p8++ & 0xc0) != 0x80) { n++; }+ }++ return n;+}++#define IS_CONT(x) ((x & 0xc0) == 0x80)++int foundation_utf8_validate(const uint8_t *c, size_t offset, size_t end)+{+ while (offset < end) {+ uint8_t h = c[offset];+ if (!(h & 0x80)) {+ offset++;+ continue;+ }++ /* continuation */+ if (h < 0xC0) { goto fail1; }+ /* 2 bytes */+ else if (h < 0xE0) { if (offset + 1 >= end) { goto fail2; }+ else if (IS_CONT(c[offset+1])) { offset += 2; }+ else { goto fail1; }+ }+ /* 3 bytes */+ else if (h < 0xF0) { if (offset + 2 >= end) { goto fail2; }+ else if (IS_CONT(c[offset+1]) && IS_CONT(c[offset+2])) { offset += 3; }+ else { goto fail1; }+ }++ /* 4 bytes */+ else if (h < 0xFE) { if (offset + 3 >= end) { goto fail2; }+ else if (IS_CONT(c[offset+1]) && IS_CONT(c[offset+2]) && IS_CONT(c[offset+3])) { offset += 4; }+ else { goto fail1; }+ }+ /* invalid > 4 bytes */+ else { goto fail1; }+ }+ return 0;+fail1:+ return 1;+fail2:+ return 2;+}+#endif
foundation.cabal view
@@ -1,5 +1,5 @@ name: foundation-version: 0.0.12+version: 0.0.13 synopsis: Alternative prelude with batteries and no dependencies description: A custom prelude with no dependencies apart from base.@@ -192,6 +192,10 @@ Foundation.Primitive.UTF8.Base Foundation.Primitive.UTF8.BA Foundation.Primitive.UTF8.Addr+ Foundation.Primitive.UTF8.Types+ Foundation.Primitive.UArray.Base+ Foundation.Primitive.UArray.BA+ Foundation.Primitive.UArray.Addr Foundation.Primitive.Runtime Foundation.Primitive.Imports Foundation.Monad.MonadIO@@ -220,6 +224,8 @@ cbits/foundation_network.c cbits/foundation_mem.c cbits/foundation_time.c+ cbits/foundation_utf8.c+ cbits/foundation_rts.c if flag(experimental) exposed-modules: Foundation.Network.HostName@@ -353,6 +359,7 @@ Sys Fake.ByteString Fake.Text+ Fake.Vector hs-source-dirs: benchs default-language: Haskell2010 type: exitcode-stdio-1.0
tests/Checks.hs view
@@ -75,13 +75,13 @@ readFloatingExact' str = readFloatingExact str (\s x y z -> Just (s,x,y,z)) doubleEqualApprox :: Double -> Double -> PropertyCheck-doubleEqualApprox d1 d2 = (propertyCompare pName1 (<) (negate lim) d) `propertyAnd` (propertyCompare pName2 (<) d lim)+doubleEqualApprox d1 d2 = propertyCompare name (<) (abs d) lim where d = d2 - d1 - pName1 = show (negate lim) <> " < " <> show d2 <> " - " <> show d1 <> " (== " <> show d <> " )"- pName2 = show d1 <> " - " <> show d2 <> " (== " <> show d <> " )" <> " < " <> show lim- lim = 1.0e-8+ name = show d1 <> " - " <> show d2 <> " (differential=" <> show (abs d) <> " )" <> " < " <> show lim++ lim = min d1 d2 * (10^^(-15 :: Int)) main = defaultMain $ Group "foundation" [ Group "Numerical"
tests/Test/Foundation/Misc.hs view
@@ -14,7 +14,11 @@ import Test.Foundation.Collection (fromListP, toListP) import qualified Foundation.UUID as UUID+import Foundation.Parser +instance Arbitrary UUID.UUID where+ arbitrary = UUID.UUID <$> arbitrary <*> arbitrary+ hex :: [Word8] -> [Word8] hex = loop where@@ -45,4 +49,6 @@ testUUID = testGroup "UUID" [ testProperty "show" $ show UUID.nil === "00000000-0000-0000-0000-000000000000" , testProperty "show-bin" $ fmap show (UUID.fromBinary (fromList [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16])) === Just "100f0e0d-0c0b-0a09-0807-060504030201"+ , testProperty "parser . show = id" $ \uuid ->+ (either (error . show) id $ parseOnly UUID.uuidParser (show uuid)) === uuid ]
tests/Test/Foundation/String.hs view
@@ -96,6 +96,22 @@ , testCase "30 31 E2 82 0C" $ expectFromBytesErr UTF8 ("01", Just InvalidContinuation, 2) (fromList [0x30,0x31,0xE2,0x82,0x0c]) ] ]+ , testGroup "Lines"+ [ testCase "Hello<LF>Foundation" $+ (breakLine "Hello\nFoundation" @?= Right ("Hello", "Foundation"))+ , testCase "Hello<CRLF>Foundation" $+ (breakLine "Hello\r\nFoundation" @?= Right ("Hello", "Foundation"))+ , testCase "Hello<LF>Foundation" $+ (breakLine (drop 5 "Hello\nFoundation\nSomething") @?= Right ("", "Foundation\nSomething"))+ , testCase "Hello<CR>" $+ (breakLine "Hello\r" @?= Left True)+ , testCase "CR" $+ (breakLine "\r" @?= Left True)+ , testCase "LF" $+ (breakLine "\n" @?= Right ("", ""))+ , testCase "empty" $+ (breakLine "" @?= Left False)+ ] ] testAsciiStringCases :: [TestTree]