GHC.Utils.Binary: Eliminate allocating withForeignPtr uses

(cherry picked from commit bc178f49d65ceb8c930d00302b9d25a47ab48692)

1 files changed, 16 insertions, 7 deletions

diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index d73939c53c..32d8608f81 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE UnboxedTuples #-}
 
 {-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
 -- We always optimise this, otherwise performance of a non-optimised
@@ -98,10 +99,16 @@ import System.IO.Unsafe         ( unsafeInterleaveIO )
 import System.IO.Error          ( mkIOError, eofErrorType )
 import GHC.Real                 ( Ratio(..) )
 import GHC.Serialized
+#if MIN_VERSION_base(4,15,0)
+import GHC.ForeignPtr           ( unsafeWithForeignPtr )
+#endif
 
 type BinArray = ForeignPtr Word8
 
-
+#if !MIN_VERSION_base(4,15,0)
+unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
+unsafeWithForeignPtr = withForeignPtr
+#endif
 
 ---------------------------------------------------------------
 -- BinData
@@ -116,14 +123,14 @@ instance Binary BinData where
   put_ bh (BinData sz dat) = do
     put_ bh sz
     putPrim bh sz $ \dest ->
-      withForeignPtr dat $ \orig ->
+      unsafeWithForeignPtr dat $ \orig ->
         copyBytes dest orig sz
   --
   get bh = do
     sz <- get bh
     dat <- mallocForeignPtrBytes sz
     getPrim bh sz $ \orig ->
-      withForeignPtr dat $ \dest ->
+      unsafeWithForeignPtr dat $ \dest ->
         copyBytes dest orig sz
     return (BinData sz dat)
 
@@ -231,7 +238,7 @@ writeBinMem (BinMem _ ix_r _ arr_r) fn = do
   h <- openBinaryFile fn WriteMode
   arr <- readIORef arr_r
   ix  <- readFastMutInt ix_r
-  withForeignPtr arr $ \p -> hPutBuf h p ix
+  unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix
   hClose h
 
 readBinMem :: FilePath -> IO BinHandle
@@ -241,7 +248,7 @@ readBinMem filename = do
   filesize' <- hFileSize h
   let filesize = fromIntegral filesize'
   arr <- mallocForeignPtrBytes filesize
-  count <- withForeignPtr arr $ \p -> hGetBuf h p filesize
+  count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize
   when (count /= filesize) $
        error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
   hClose h
@@ -285,7 +292,7 @@ putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do
   when (ix + size > sz) $
     expandBin h (ix + size)
   arr <- readIORef arr_r
-  withForeignPtr arr $ \op -> f (op `plusPtr` ix)
+  unsafeWithForeignPtr arr $ \op -> f (op `plusPtr` ix)
   writeFastMutInt ix_r (ix + size)
 
 -- -- | Similar to putPrim but advances the index by the actual number of
@@ -307,7 +314,9 @@ getPrim (BinMem _ ix_r sz_r arr_r) size f = do
   when (ix + size > sz) $
       ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing)
   arr <- readIORef arr_r
-  w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)
+  w <- unsafeWithForeignPtr arr $ \p -> f (p `plusPtr` ix)
+    -- This is safe WRT #17760 as we we guarantee that the above line doesn't
+    -- diverge
   writeFastMutInt ix_r (ix + size)
   return w