[Git][ghc/ghc][wip/mpickering-hannes] putFullBinHandle and shrinkBinBuffer

[Matthew Pickering (@mpickering)]

Matthew Pickering pushed to branch wip/mpickering-hannes at Glasgow Haskell Compiler / GHC


Commits:
b073324a by Matthew Pickering at 2024-03-28T10:56:41+00:00
putFullBinHandle and shrinkBinBuffer

- - - - -


4 changed files:

- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Utils/Binary.hs


Changes:

=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -162,7 +162,7 @@ shareIface nc mi = do
   putWithUserData QuietBinIFace bh mi
   -- Copy out just the part of the buffer which is used, otherwise each interface
   -- retains a 1mb bytearray
-  bh' <- withBinBuffer bh (\bs -> unsafeUnpackBinBuffer (BS.copy bs))
+  bh' <- shrinkBinBuffer bh
   res <- getWithUserData nc bh'
   let resiface = res { mi_src_hash = mi_src_hash mi }
   forceModIface  resiface


=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -2484,9 +2484,7 @@ instance Binary IfaceAlt where
 
 instance Binary IfaceExpr where
 
-    putNoStack_ bh (IfaceSerialisedExpr f) = do
-      deserialised <- getIfaceExpr =<< thawBinHandle f
-      putNoStack_ bh deserialised
+    putNoStack_ bh (IfaceSerialisedExpr f) = putFullBinData bh f
     putNoStack_ bh (IfaceLcl aa) = do
         putByte bh 0
         put_ bh aa


=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -2130,10 +2130,7 @@ instance Binary IfaceType where
     tbl -> getEntry tbl bh
 
 
-putIfaceType bh (IfaceSerialisedType fb) = do -- putFullBinData bh fb
-  deserialised <- getIfaceType =<< thawBinHandle fb
-  putIfaceType bh deserialised
-
+putIfaceType bh (IfaceSerialisedType fb) = putFullBinData bh fb
 
 putIfaceType _ (IfaceFreeTyVar tv)
    = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)


=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -35,6 +35,7 @@ module GHC.Utils.Binary
    tellBin,
    castBin,
    withBinBuffer,
+   shrinkBinBuffer,
 
    foldGet, foldGet',
 
@@ -111,7 +112,7 @@ import Foreign hiding (shiftL, shiftR, void)
 import Data.Array
 import Data.Array.IO
 import Data.Array.Unsafe
-import Data.ByteString (ByteString)
+import Data.ByteString (ByteString, copy)
 import qualified Data.ByteString.Internal as BS
 import qualified Data.ByteString.Unsafe   as BS
 import Data.IORef
@@ -232,6 +233,8 @@ data BinHandle
      _arr_r :: !(IORef BinArray), -- the array (bounds: (0,size-1))
      prof :: {-# UNPACK #-} !BinProf
     }
+        -- XXX: should really store a "high water mark" for dumping out
+        -- the binary data to a file.
 
 data ProfKey = StringKey !String | TypeableKey !TypeRep deriving (Eq, Ord)
 
@@ -250,8 +253,6 @@ addStack s (BinProf ss i) = (BinProf (TypeableKey s:ss) i)
 recordSample :: Int -> BinProf -> IO ()
 recordSample _ _ = return ()
 recordSample weight (BinProf ss i) = modifyIORef i (Map.insertWith (+) ss weight)
-        -- XXX: should really store a "high water mark" for dumping out
-        -- the binary data to a file.
 
 getUserData :: BinHandle -> UserData
 getUserData bh = bh_usr bh
@@ -282,6 +283,17 @@ unsafeUnpackBinBuffer (BS.BS arr len) = do
   bp  <- initBinProf
   return (BinMem noUserData ix_r sz_r arr_r bp)
 
+-- Copy the BinBuffer to a new BinBuffer which is exactly the right size.
+-- This performs a copy of the underlying buffer.
+-- The buffer may be truncated if the offset is not at the end of the written
+-- output.
+--
+-- UserData is also discarded during the copy
+-- You should just use this when translating a Put handle into a Get handle.
+shrinkBinBuffer :: BinHandle -> IO BinHandle
+shrinkBinBuffer bh = withBinBuffer bh (\bs -> unsafeUnpackBinBuffer (copy bs))
+
+
 ---------------------------------------------------------------
 -- Bin
 ---------------------------------------------------------------



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b073324ae076b60e8cbc6ef411beb51ffc55b1f5

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b073324ae076b60e8cbc6ef411beb51ffc55b1f5
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240328/cb864b90/attachment-0001.html>