From 4b43ecda94acb6544b0c793eea32daa3c97fe07f Mon Sep 17 00:00:00 2001 From: Bodigrim Date: Fri, 7 Oct 2022 19:15:24 +0100 Subject: [PATCH] Use data-array-byte package to provide ByteArray for GHC < 9.4 --- Data/Primitive/ByteArray.hs | 246 +----------------------------------- primitive.cabal | 3 + 2 files changed, 6 insertions(+), 243 deletions(-) diff --git a/Data/Primitive/ByteArray.hs b/Data/Primitive/ByteArray.hs index 65c5682..2c6f9d0 100644 --- a/Data/Primitive/ByteArray.hs +++ b/Data/Primitive/ByteArray.hs @@ -77,91 +77,11 @@ import Data.Word ( Word8 ) import qualified GHC.Exts as Exts import GHC.Exts hiding (setByteArray#) -#if MIN_VERSION_base(4,17,0) - -import Data.Array.Byte (ByteArray(..), MutableByteArray(..)) - -#else - -import Control.DeepSeq -import Data.Bits ( (.&.), unsafeShiftR ) -import GHC.Show ( intToDigit ) -import Data.Typeable ( Typeable ) -import Data.Data ( Data(..), mkNoRepType ) -import qualified Language.Haskell.TH.Syntax as TH -import qualified Language.Haskell.TH.Lib as TH -import qualified Data.Semigroup as SG -import qualified Data.Foldable as F -import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) - --- | Byte arrays. -data ByteArray = ByteArray ByteArray# deriving ( Typeable ) - --- | Mutable byte arrays associated with a primitive state token. -data MutableByteArray s = MutableByteArray (MutableByteArray# s) - deriving ( Typeable ) - --- | Respects array pinnedness for GHC >= 8.2 -instance TH.Lift ByteArray where -#if MIN_VERSION_template_haskell(2,17,0) - liftTyped ba = TH.unsafeCodeCoerce (TH.lift ba) -#elif MIN_VERSION_template_haskell(2,16,0) - liftTyped ba = TH.unsafeTExpCoerce (TH.lift ba) +#if __GLASGOW_HASKELL__ < 804 +import System.IO.Unsafe (unsafeDupablePerformIO) #endif - lift ba = - TH.appE - (if small - then [| fromLitAddrSmall# pinned len |] - else [| fromLitAddrLarge# pinned len |]) - (TH.litE (TH.stringPrimL (toList ba))) - where - -- Pin it if the original was pinned; otherwise don't. This seems more - -- logical to me than the alternatives. Anyone who wants a different - -- pinnedness can just copy the compile-time byte array to one that - -- matches what they want at run-time. -#if __GLASGOW_HASKELL__ >= 802 - pinned = isByteArrayPinned ba -#else - pinned = True -#endif - len = sizeofByteArray ba - small = len <= 2048 - --- I don't think inlining these can be very helpful, so let's not --- do it. -{-# NOINLINE fromLitAddrSmall# #-} -fromLitAddrSmall# :: Bool -> Int -> Addr# -> ByteArray -fromLitAddrSmall# pinned len ptr = inline (fromLitAddr# True pinned len ptr) - -{-# NOINLINE fromLitAddrLarge# #-} -fromLitAddrLarge# :: Bool -> Int -> Addr# -> ByteArray -fromLitAddrLarge# pinned len ptr = inline (fromLitAddr# False pinned len ptr) - -fromLitAddr# :: Bool -> Bool -> Int -> Addr# -> ByteArray -fromLitAddr# small pinned !len !ptr = upIO $ do - mba <- if pinned - then newPinnedByteArray len - else newByteArray len - copyPtrToMutableByteArray mba 0 (Ptr ptr :: Ptr Word8) len - unsafeFreezeByteArray mba - where - -- We don't care too much about duplication if the byte arrays are - -- small. If they're large, we do. Since we don't allocate while - -- we copy (we do it with a primop!), I don't believe the thunk - -- deduplication mechanism can help us if two threads just happen - -- to try to build the ByteArray at the same time. - upIO - | small = unsafeDupablePerformIO - | otherwise = unsafePerformIO - -instance NFData ByteArray where - rnf (ByteArray _) = () - -instance NFData (MutableByteArray s) where - rnf (MutableByteArray _) = () - -#endif +import Data.Array.Byte (ByteArray(..), MutableByteArray(..)) -- | Create a new mutable byte array of the specified size in bytes. -- @@ -599,65 +519,6 @@ foreign import ccall unsafe "primitive-memops.h hsprimitive_memmove" -> MutableByteArray# s -> CPtrdiff -> CSize -> IO () -#if !MIN_VERSION_base(4,17,0) - -instance Eq (MutableByteArray s) where - (==) = sameMutableByteArray - -instance Data ByteArray where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.ByteArray" - -instance Typeable s => Data (MutableByteArray s) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.MutableByteArray" - --- | @since 0.6.3.0 --- --- Behavior changed in 0.7.2.0. Before 0.7.2.0, this instance rendered --- 8-bit words less than 16 as a single hexadecimal digit (e.g. 13 was @0xD@). --- Starting with 0.7.2.0, all 8-bit words are represented as two digits --- (e.g. 13 is @0x0D@). -instance Show ByteArray where - showsPrec _ ba = - showString "[" . go 0 - where - showW8 :: Word8 -> String -> String - showW8 !w s = - '0' - : 'x' - : intToDigit (fromIntegral (unsafeShiftR w 4)) - : intToDigit (fromIntegral (w .&. 0x0F)) - : s - go i - | i < sizeofByteArray ba = comma . showW8 (indexByteArray ba i :: Word8) . go (i+1) - | otherwise = showChar ']' - where - comma | i == 0 = id - | otherwise = showString ", " - --- Only used internally -compareByteArraysFromBeginning :: ByteArray -> ByteArray -> Int -> Ordering -{-# INLINE compareByteArraysFromBeginning #-} -#if __GLASGOW_HASKELL__ >= 804 -compareByteArraysFromBeginning (ByteArray ba1#) (ByteArray ba2#) (I# n#) - = compare (I# (compareByteArrays# ba1# 0# ba2# 0# n#)) 0 -#else --- Emulate GHC 8.4's 'GHC.Prim.compareByteArrays#' -compareByteArraysFromBeginning (ByteArray ba1#) (ByteArray ba2#) (I# n#) - = compare (fromCInt (unsafeDupablePerformIO (memcmp_ba ba1# ba2# n))) 0 - where - n = fromIntegral (I# n#) :: CSize - fromCInt = fromIntegral :: CInt -> Int - -foreign import ccall unsafe "primitive-memops.h hsprimitive_memcmp" - memcmp_ba :: ByteArray# -> ByteArray# -> CSize -> IO CInt -#endif - -#endif - -- | Lexicographic comparison of equal-length slices into two byte arrays. -- This wraps the @compareByteArrays#@ primop, which wraps @memcmp@. compareByteArrays @@ -683,112 +544,11 @@ foreign import ccall unsafe "primitive-memops.h hsprimitive_memcmp_offset" memcmp_ba_offs :: ByteArray# -> Int# -> ByteArray# -> Int# -> CSize -> IO CInt #endif -#if !MIN_VERSION_base(4,17,0) - -sameByteArray :: ByteArray# -> ByteArray# -> Bool -sameByteArray ba1 ba2 = - case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of - r -> isTrue# r - --- | @since 0.6.3.0 -instance Eq ByteArray where - ba1@(ByteArray ba1#) == ba2@(ByteArray ba2#) - | sameByteArray ba1# ba2# = True - | n1 /= n2 = False - | otherwise = compareByteArraysFromBeginning ba1 ba2 n1 == EQ - where - n1 = sizeofByteArray ba1 - n2 = sizeofByteArray ba2 - --- | Non-lexicographic ordering. This compares the lengths of --- the byte arrays first and uses a lexicographic ordering if --- the lengths are equal. Subject to change between major versions. --- --- @since 0.6.3.0 -instance Ord ByteArray where - ba1@(ByteArray ba1#) `compare` ba2@(ByteArray ba2#) - | sameByteArray ba1# ba2# = EQ - | n1 /= n2 = n1 `compare` n2 - | otherwise = compareByteArraysFromBeginning ba1 ba2 n1 - where - n1 = sizeofByteArray ba1 - n2 = sizeofByteArray ba2 --- Note: On GHC 8.4, the primop compareByteArrays# performs a check for pointer --- equality as a shortcut, so the check here is actually redundant. However, it --- is included here because it is likely better to check for pointer equality --- before checking for length equality. Getting the length requires deferencing --- the pointers, which could cause accesses to memory that is not in the cache. --- By contrast, a pointer equality check is always extremely cheap. - -appendByteArray :: ByteArray -> ByteArray -> ByteArray -appendByteArray a b = runST $ do - marr <- newByteArray (sizeofByteArray a + sizeofByteArray b) - copyByteArray marr 0 a 0 (sizeofByteArray a) - copyByteArray marr (sizeofByteArray a) b 0 (sizeofByteArray b) - unsafeFreezeByteArray marr - -concatByteArray :: [ByteArray] -> ByteArray -concatByteArray arrs = runST $ do - let len = calcLength arrs 0 - marr <- newByteArray len - pasteByteArrays marr 0 arrs - unsafeFreezeByteArray marr - -pasteByteArrays :: MutableByteArray s -> Int -> [ByteArray] -> ST s () -pasteByteArrays !_ !_ [] = return () -pasteByteArrays !marr !ix (x : xs) = do - copyByteArray marr ix x 0 (sizeofByteArray x) - pasteByteArrays marr (ix + sizeofByteArray x) xs - -calcLength :: [ByteArray] -> Int -> Int -calcLength [] !n = n -calcLength (x : xs) !n = calcLength xs (sizeofByteArray x + n) - -#endif - -- | The empty 'ByteArray'. emptyByteArray :: ByteArray {-# NOINLINE emptyByteArray #-} emptyByteArray = runST (newByteArray 0 >>= unsafeFreezeByteArray) -#if !MIN_VERSION_base(4,17,0) - -replicateByteArray :: Int -> ByteArray -> ByteArray -replicateByteArray n arr = runST $ do - marr <- newByteArray (n * sizeofByteArray arr) - let go i = if i < n - then do - copyByteArray marr (i * sizeofByteArray arr) arr 0 (sizeofByteArray arr) - go (i + 1) - else return () - go 0 - unsafeFreezeByteArray marr - -instance SG.Semigroup ByteArray where - (<>) = appendByteArray - sconcat = mconcat . F.toList - stimes n arr = case compare n 0 of - LT -> die "stimes" "negative multiplier" - EQ -> emptyByteArray - GT -> replicateByteArray (fromIntegral n) arr - -instance Monoid ByteArray where - mempty = emptyByteArray -#if !(MIN_VERSION_base(4,11,0)) - mappend = appendByteArray -#endif - mconcat = concatByteArray - --- | @since 0.6.3.0 -instance Exts.IsList ByteArray where - type Item ByteArray = Word8 - - toList = foldrByteArray (:) [] - fromList xs = byteArrayFromListN (length xs) xs - fromListN = byteArrayFromListN - -#endif - die :: String -> String -> a die fun problem = error $ "Data.Primitive.ByteArray." ++ fun ++ ": " ++ problem diff --git a/primitive.cabal b/primitive.cabal index 23dc2d5..db2c5cb 100644 --- a/primitive.cabal +++ b/primitive.cabal @@ -56,6 +56,9 @@ Library , transformers >= 0.5 && < 0.7 , template-haskell >= 2.11 + if impl(ghc < 9.4) + build-depends: data-array-byte >= 0.1 && < 0.1.1 + Ghc-Options: -O2 Include-Dirs: cbits