GHC.Utils.Binary: Eliminate allocating withForeignPtr uses

1 files changed, 16 insertions, 7 deletions

diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index aed156aa8e..ce533ed127 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UnboxedTuples #-}
 
 {-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
 #if MIN_VERSION_base(4,16,0)
@@ -96,10 +97,16 @@ import System.IO as IO
 import System.IO.Unsafe         ( unsafeInterleaveIO )
 import System.IO.Error          ( mkIOError, eofErrorType )
 import GHC.Real                 ( Ratio(..) )
+#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
@@ -114,14 +121,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)
 
@@ -229,7 +236,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
@@ -239,7 +246,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
@@ -283,7 +290,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
@@ -305,7 +312,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