diff options
-rw-r--r-- | compiler/GHC/Utils/Binary.hs | 23 |
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 |