From 8d296b75bb9d232f12175a8b13b2c02e7196bdcd Mon Sep 17 00:00:00 2001 From: Matthew Craven Date: Wed, 7 Jun 2023 15:04:27 -0400 Subject: [PATCH] Allow the result of unsafeCreate to be unboxed (#580) * Allow the result of unsafeCreate to be unboxed * Fix build with old versions of ghc * Add hackage source link for referenced Note * Improvement documentation for the new functions * Publicly export deferForeignPtrAvailability * Add convenience function `mkDeferredByteString` * remove extra ' --- Data/ByteString.hs | 3 +- Data/ByteString/Internal.hs | 2 + Data/ByteString/Internal/Type.hs | 79 +++++++++++++++++++++++++------ Data/ByteString/Short/Internal.hs | 7 +-- 4 files changed, 71 insertions(+), 20 deletions(-) diff --git a/Data/ByteString.hs b/Data/ByteString.hs index f8f7c5be7..fbf559158 100644 --- a/Data/ByteString.hs +++ b/Data/ByteString.hs @@ -267,7 +267,6 @@ import GHC.IO.Handle.Types import GHC.IO.Buffer import GHC.IO.BufferedIO as Buffered import GHC.IO.Encoding (getFileSystemEncoding) -import GHC.IO (unsafePerformIO, unsafeDupablePerformIO) import GHC.Foreign (newCStringLen, peekCStringLen) import GHC.Stack.Types (HasCallStack) import Data.Char (ord) @@ -887,7 +886,7 @@ unfoldr f = concat . unfoldChunk 32 64 unfoldrN :: Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a) unfoldrN i f x0 | i < 0 = (empty, Just x0) - | otherwise = unsafePerformIO $ createFpAndTrim' i $ \p -> go p x0 0 + | otherwise = unsafeDupablePerformIO $ createFpAndTrim' i $ \p -> go p x0 0 where go !p !x !n = go' x n where diff --git a/Data/ByteString/Internal.hs b/Data/ByteString/Internal.hs index b4481a833..c4c831bc0 100644 --- a/Data/ByteString/Internal.hs +++ b/Data/ByteString/Internal.hs @@ -51,6 +51,7 @@ module Data.ByteString.Internal ( mallocByteString, -- * Conversion to and from ForeignPtrs + mkDeferredByteString, fromForeignPtr, toForeignPtr, fromForeignPtr0, @@ -58,6 +59,7 @@ module Data.ByteString.Internal ( -- * Utilities nullForeignPtr, + deferForeignPtrAvailability, SizeOverflowException, overflowError, checkedAdd, diff --git a/Data/ByteString/Internal/Type.hs b/Data/ByteString/Internal/Type.hs index e8769788b..aef61cad9 100644 --- a/Data/ByteString/Internal/Type.hs +++ b/Data/ByteString/Internal/Type.hs @@ -62,6 +62,7 @@ module Data.ByteString.Internal.Type ( mallocByteString, -- * Conversion to and from ForeignPtrs + mkDeferredByteString, fromForeignPtr, toForeignPtr, fromForeignPtr0, @@ -75,6 +76,8 @@ module Data.ByteString.Internal.Type ( pokeFpByteOff, minusForeignPtr, memcpyFp, + deferForeignPtrAvailability, + unsafeDupablePerformIO, SizeOverflowException, overflowError, checkedAdd, @@ -138,9 +141,9 @@ import Data.Word import Data.Data (Data(..), mkNoRepType) import GHC.Base (nullAddr#,realWorld#,unsafeChr) -import GHC.Exts (IsList(..)) +import GHC.Exts (IsList(..), Addr#, minusAddr#) import GHC.CString (unpackCString#) -import GHC.Exts (Addr#, minusAddr#) +import GHC.Magic (runRW#, lazy) #define TIMES_INT_2_AVAILABLE MIN_VERSION_ghc_prim(0,7,0) #if TIMES_INT_2_AVAILABLE @@ -155,7 +158,7 @@ import GHC.Prim ( timesWord2# import Data.Bits (finiteBitSize) #endif -import GHC.IO (IO(IO),unsafeDupablePerformIO) +import GHC.IO (IO(IO)) import GHC.ForeignPtr (ForeignPtr(ForeignPtr) #if __GLASGOW_HASKELL__ < 900 , newForeignPtr_ @@ -229,6 +232,51 @@ pokeFpByteOff :: Storable a => ForeignPtr b -> Int -> a -> IO () pokeFpByteOff fp off val = unsafeWithForeignPtr fp $ \p -> pokeByteOff p off val +-- | Most operations on a 'ByteString' need to read from the buffer +-- given by its @ForeignPtr Word8@ field. But since most operations +-- on @ByteString@ are (nominally) pure, their implementations cannot +-- see the IO state thread that was used to initialize the contents of +-- that buffer. This means that under some circumstances, these +-- buffer-reads may be executed before the writes used to initialize +-- the buffer are executed, with unpredictable results. +-- +-- 'deferForeignPtrAvailability' exists to help solve this problem. +-- At runtime, a call @'deferForeignPtrAvailability' x@ is equivalent +-- to @pure $! x@, but the former is more opaque to the simplifier, so +-- that reads from the pointer in its result cannot be executed until +-- the @'deferForeignPtrAvailability' x@ call is complete. +-- +-- The opaque bits evaporate during CorePrep, so using +-- 'deferForeignPtrAvailability' incurs no direct overhead. +-- +-- @since 0.11.5.0 +deferForeignPtrAvailability :: ForeignPtr a -> IO (ForeignPtr a) +deferForeignPtrAvailability (ForeignPtr addr0# guts) = IO $ \s0 -> + case lazy runRW# (\_ -> (# s0, addr0# #)) of + (# s1, addr1# #) -> (# s1, ForeignPtr addr1# guts #) + +-- | Variant of 'fromForeignPtr0' that calls 'deferForeignPtrAvailability' +-- +-- @since 0.11.5.0 +mkDeferredByteString :: ForeignPtr Word8 -> Int -> IO ByteString +mkDeferredByteString fp len = do + deferredFp <- deferForeignPtrAvailability fp + pure $! BS deferredFp len + +unsafeDupablePerformIO :: IO a -> a +-- Why does this exist? In base-4.15.1.0 until at least base-4.18.0.0, +-- the version of unsafeDupablePerformIO in base prevents unboxing of +-- its results with an opaque call to GHC.Exts.lazy, for reasons described +-- in Note [unsafePerformIO and strictness] in GHC.IO.Unsafe. (See +-- https://hackage.haskell.org/package/base-4.18.0.0/docs/src/GHC.IO.Unsafe.html#line-30 .) +-- Even if we accept the (very questionable) premise that the sort of +-- function described in that note should work, we expect no such +-- calls to be made in the context of bytestring. (And we really want +-- unboxing!) +unsafeDupablePerformIO (IO act) = case runRW# act of (# _, res #) -> res + + + -- ----------------------------------------------------------------------------- -- | A space-efficient representation of a 'Word8' vector, supporting many @@ -568,8 +616,8 @@ fromForeignPtr fp o = BS (plusForeignPtr fp o) -- | @since 0.11.0.0 fromForeignPtr0 :: ForeignPtr Word8 - -> Int -- ^ Length - -> ByteString + -> Int -- ^ Length + -> ByteString fromForeignPtr0 = BS {-# INLINE fromForeignPtr0 #-} @@ -609,7 +657,7 @@ createFp :: Int -> (ForeignPtr Word8 -> IO ()) -> IO ByteString createFp l action = do fp <- mallocByteString l action fp - return $! BS fp l + mkDeferredByteString fp l {-# INLINE createFp #-} -- | Given a maximum size @l@ and an action @f@ that fills the 'ByteString' @@ -619,7 +667,7 @@ createFpUptoN :: Int -> (ForeignPtr Word8 -> IO Int) -> IO ByteString createFpUptoN l action = do fp <- mallocByteString l l' <- action fp - assert (l' <= l) $ return $! BS fp l' + assert (l' <= l) $ mkDeferredByteString fp l' {-# INLINE createFpUptoN #-} -- | Like 'createFpUptoN', but also returns an additional value created by the @@ -628,7 +676,8 @@ createFpUptoN' :: Int -> (ForeignPtr Word8 -> IO (Int, a)) -> IO (ByteString, a) createFpUptoN' l action = do fp <- mallocByteString l (l', res) <- action fp - assert (l' <= l) $ return (BS fp l', res) + bs <- mkDeferredByteString fp l' + assert (l' <= l) $ pure (bs, res) {-# INLINE createFpUptoN' #-} -- | Given the maximum size needed and a function to make the contents @@ -644,19 +693,19 @@ createFpAndTrim l action = do fp <- mallocByteString l l' <- action fp if assert (0 <= l' && l' <= l) $ l' >= l - then return $! BS fp l - else createFp l' $ \fp' -> memcpyFp fp' fp l' + then mkDeferredByteString fp l + else createFp l' $ \dest -> memcpyFp dest fp l' {-# INLINE createFpAndTrim #-} createFpAndTrim' :: Int -> (ForeignPtr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a) createFpAndTrim' l action = do fp <- mallocByteString l (off, l', res) <- action fp - if assert (0 <= l' && l' <= l) $ l' >= l - then return (BS fp l, res) - else do ps <- createFp l' $ \fp' -> - memcpyFp fp' (fp `plusForeignPtr` off) l' - return (ps, res) + bs <- if assert (0 <= l' && l' <= l) $ l' >= l + then mkDeferredByteString fp l -- entire buffer used => offset is zero + else createFp l' $ \dest -> + memcpyFp dest (fp `plusForeignPtr` off) l' + return (bs, res) {-# INLINE createFpAndTrim' #-} diff --git a/Data/ByteString/Short/Internal.hs b/Data/ByteString/Short/Internal.hs index 78846b360..cd3980a0b 100644 --- a/Data/ByteString/Short/Internal.hs +++ b/Data/ByteString/Short/Internal.hs @@ -161,8 +161,9 @@ module Data.ByteString.Short.Internal ( useAsCStringLen, ) where -import Data.ByteString.Internal +import Data.ByteString.Internal.Type ( ByteString(..) + , unsafeDupablePerformIO , accursedUnutterablePerformIO , checkedAdd ) @@ -241,7 +242,7 @@ import GHC.Exts , writeWord8Array# , unsafeFreezeByteArray# , touch# ) -import GHC.IO +import GHC.IO hiding ( unsafeDupablePerformIO ) import GHC.ForeignPtr ( ForeignPtr(ForeignPtr) , ForeignPtrContents(PlainPtr) @@ -268,7 +269,7 @@ import Prelude , snd ) -import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Internal.Type as BS import qualified Data.List as List import qualified GHC.Exts