Allow the result of unsafeCreate to be unboxed

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