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

@@ -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

Data/ByteString/Internal.hs

@@ -51,13 +51,15 @@ module Data.ByteString.Internal (
  mallocByteString,
 
  -- * Conversion to and from ForeignPtrs
+ mkDeferredByteString,
  fromForeignPtr,
  toForeignPtr,
  fromForeignPtr0,
  toForeignPtr0,
 
  -- * Utilities
  nullForeignPtr,
+ deferForeignPtrAvailability,
  SizeOverflowException,
  overflowError,
  checkedAdd,

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' #-}
 
 

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