[Git][ghc/ghc][wip/fendor/ifacetype-delay-serialisation] Delay deserialisation of `IfaceType` until needed
Hannes Siebenhandl (@fendor)
gitlab at gitlab.haskell.org
Fri Apr 26 15:33:30 UTC 2024
Hannes Siebenhandl pushed to branch wip/fendor/ifacetype-delay-serialisation at Glasgow Haskell Compiler / GHC
Commits:
fbdc1671 by Matthew Pickering at 2024-04-26T17:33:15+02:00
Delay deserialisation of `IfaceType` until needed
Introduces `IfaceSerialisationType` which holds onto a ByteString
in-memory. All `IfaceType`'s are first deserialised to
`IfaceSerialisationType`, so no actual deserialisation happens until the
value is requested. Then, we decode `IfaceSerialisationType` into the
real `IfaceType` value.
- - - - -
9 changed files:
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Iface/Type/Map.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Unit/Module/ModIface.hs
- compiler/GHC/Utils/Binary.hs
Changes:
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -43,7 +43,6 @@ import GHC.Types.Unique.FM
import GHC.Utils.Panic
import GHC.Utils.Binary as Binary
import GHC.Data.FastMutInt
-import GHC.Data.FastString (FastString)
import GHC.Types.Unique
import GHC.Utils.Outputable
import GHC.Types.Name.Cache
@@ -59,12 +58,17 @@ import Data.Array.IO
import Data.Array.Unsafe
import Data.Char
import Data.IORef
+import Control.Monad
+import GHC.Iface.Type (IfaceType, getIfaceType, putIfaceType)
+import System.IO.Unsafe
import Data.Map.Strict (Map)
import Data.Word
import System.IO.Unsafe
import Data.Typeable (Typeable)
import qualified GHC.Data.Strict as Strict
+import GHC.Data.FastString
+import GHC.Iface.Type
-- ---------------------------------------------------------------------------
-- Reading and writing binary interface files
@@ -509,11 +513,18 @@ Here, a visualisation of the table structure we currently have (ignoring 'Extens
-- The symbol table
--
+readFromSymTab :: ReaderUserData -> ReadBinHandle -> IO FullBinData
+readFromSymTab ud bh = do
+ p <- getRelBin bh -- a BinPtr
+ frozen_bh <- freezeBinHandle (makeAbsoluteBin p) (setReaderUserData bh ud)
+ seekBinReaderRel bh p -- skip over the object for now
+ return frozen_bh
+
initReadIfaceTypeTable :: ReaderUserData -> IO (ReaderTable IfaceType)
initReadIfaceTypeTable ud = do
pure $
ReaderTable
- { getTable = getGenericSymbolTable (\bh -> lazyGet' getIfaceType (setReaderUserData bh ud))
+ { getTable = getGenericSymbolTable (\bh -> IfaceSerialisedType <$!> readFromSymTab ud bh)
, mkReaderFromTable = \tbl -> mkReader (getGenericSymtab tbl)
}
@@ -582,7 +593,6 @@ initNameWriterTable = do
, mkWriter $ putName bin_symtab
)
-
putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
putSymbolTable bh name_count symtab = do
put_ bh name_count
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -172,10 +172,8 @@ shareIface _ NormalCompression mi = do
pure mi
shareIface nc compressionLevel mi = do
bh <- openBinMem (1024 * 1024)
- start <- tellBinWriter bh
putIfaceWithExtFields QuietBinIFace compressionLevel bh mi
rbh <- shrinkBinBuffer bh
- seekBinReader rbh start
res <- getIfaceWithExtFields nc rbh
let resiface = res { mi_src_hash = mi_src_hash mi }
forceModIface resiface
@@ -272,6 +270,7 @@ mkIfaceTc hsc_env safe_mode mod_details mod_summary mb_program
mkFullIface hsc_env partial_iface Nothing Nothing
+
mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource
-> Bool -> Dependencies -> GlobalRdrEnv
-> NameEnv FixItem -> Warnings GhcRn -> HpcInfo
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -37,6 +37,8 @@ module GHC.Iface.Syntax (
fromIfaceWarnings,
fromIfaceWarningTxt,
+ getIfaceExpr,
+
-- Free Names
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
freeNamesIfConDecls,
@@ -615,7 +617,8 @@ fromIfaceStringLiteral (IfStringLiteral st fs) = StringLiteral st fs Nothing
-}
data IfaceExpr
- = IfaceLcl IfLclName
+ = IfaceSerialisedExpr !FullBinData
+ | IfaceLcl IfLclName
| IfaceExt IfExtName
| IfaceType IfaceType
| IfaceCo IfaceCoercion
@@ -2478,6 +2481,9 @@ instance Binary IfaceAlt where
return (IfaceAlt a b c)
instance Binary IfaceExpr where
+ put_ bh (IfaceSerialisedExpr f) = do
+ deserialised <- getIfaceExpr =<< thawBinHandle f
+ put_ bh deserialised
put_ bh (IfaceLcl aa) = do
putByte bh 0
put_ bh aa
@@ -2537,7 +2543,20 @@ instance Binary IfaceExpr where
put_ bh (IfaceLitRubbish ConstraintLike r) = do
putByte bh 15
put_ bh r
+
get bh = do
+ start <- tellBinReader @() bh
+ _ <- getIfaceExpr bh
+ end <- tellBinReader @() bh
+ seekBinReader bh start
+ frozen <- IfaceSerialisedExpr <$> freezeBinHandle end bh
+ seekBinReader bh end
+ return frozen
+
+
+
+getIfaceExpr :: ReadBinHandle -> IO IfaceExpr
+getIfaceExpr bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
@@ -2831,6 +2850,7 @@ instance NFData IfaceUnfolding where
instance NFData IfaceExpr where
rnf = \case
+ IfaceSerialisedExpr bd -> bd `seq` ()
IfaceLcl nm -> rnf nm
IfaceExt nm -> rnf nm
IfaceType ty -> rnf ty
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -175,7 +175,8 @@ type IfaceKind = IfaceType
-- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType'
-- before being printed. See Note [Pretty printing via Iface syntax] in "GHC.Types.TyThing.Ppr"
data IfaceType
- = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType]
+ = IfaceSerialisedType !FullBinData
+ | IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType]
| IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
| IfaceLitTy IfaceTyLit
| IfaceAppTy IfaceType IfaceAppArgs
@@ -2230,6 +2231,10 @@ getIfaceTypeShared bh = do
else seekBinReader bh start >> getIfaceType bh
putIfaceType :: WriteBinHandle -> IfaceType -> IO ()
+putIfaceType bh (IfaceSerialisedType fb) = do
+ ity <- getIfaceType =<< thawBinHandle fb
+ putIfaceType bh ity
+
putIfaceType _ (IfaceFreeTyVar tv)
= pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
@@ -2287,8 +2292,9 @@ getIfaceType bh = do
8 -> do { s <- get bh; i <- get bh; tys <- get bh
; return (IfaceTupleTy s i tys) }
- _ -> do n <- get bh
+ 9 -> do n <- get bh
return (IfaceLitTy n)
+ n -> panic $ "getIfaceType: " ++ show n
instance Binary IfLclName where
put_ bh = put_ bh . ifLclNameFS
@@ -2487,6 +2493,7 @@ instance Binary (DefMethSpec IfaceType) where
instance NFData IfaceType where
rnf = \case
+ IfaceSerialisedType bh -> bh `seq` ()
IfaceFreeTyVar f1 -> f1 `seq` ()
IfaceTyVar f1 -> rnf f1
IfaceLitTy f1 -> rnf f1
=====================================
compiler/GHC/Iface/Type/Map.hs
=====================================
@@ -11,6 +11,7 @@ import Control.Monad ((>=>))
import GHC.Types.Unique.DFM
import Data.Functor.Product
import GHC.Types.Var (VarBndr(..))
+import GHC.Utils.Binary
newtype IfaceTypeMap a = IfaceTypeMap (IfaceTypeMapG a)
@@ -42,7 +43,8 @@ data IfaceTypeMapX a
, ifm_forall_ty :: IfaceForAllBndrMap (IfaceTypeMapG a)
, ifm_cast_ty :: IfaceTypeMapG (IfaceCoercionMap a)
, ifm_coercion_ty :: IfaceCoercionMap a
- , ifm_tuple_ty :: TupleSortMap (PromotionFlagMap (IfaceAppArgsMap a)) }
+ , ifm_tuple_ty :: TupleSortMap (PromotionFlagMap (IfaceAppArgsMap a))
+ , ifm_serialised_ty :: ForeignBinDataMap (OffsetBinDataMap a) }
type IfaceLiteralMap = Map.Map IfaceTyLit
type FunTyFlagMap = Map.Map FunTyFlag
@@ -51,6 +53,8 @@ type ForAllTyFlagMap = Map.Map ForAllTyFlag
type IfaceCoercionMap = Map.Map IfaceCoercion
type TupleSortMap = Map.Map TupleSort
type PromotionFlagMap = Map.Map PromotionFlag
+type ForeignBinDataMap = Map.Map BinArray
+type OffsetBinDataMap = Map.Map Int
type IfaceForAllBndrMap = Compose IfaceBndrMap ForAllTyFlagMap
type IfaceIdBndrMap = Compose IfaceTypeMapG (Compose (UniqDFM IfLclName) IfaceTypeMapG)
@@ -72,7 +76,9 @@ emptyE = IFM { ifm_lit = emptyTM
, ifm_forall_ty = emptyTM
, ifm_cast_ty = emptyTM
, ifm_coercion_ty = emptyTM
- , ifm_tuple_ty = emptyTM }
+ , ifm_tuple_ty = emptyTM
+ , ifm_serialised_ty = emptyTM
+ }
instance Functor IfaceTypeMapX where
fmap f IFM { ifm_lit = ilit
@@ -83,7 +89,8 @@ instance Functor IfaceTypeMapX where
, ifm_forall_ty = ifal
, ifm_cast_ty = icast
, ifm_coercion_ty = ico
- , ifm_tuple_ty = itup }
+ , ifm_tuple_ty = itup
+ , ifm_serialised_ty = iser }
= IFM { ifm_lit = fmap f ilit
, ifm_var = fmap f ivar
@@ -93,7 +100,9 @@ instance Functor IfaceTypeMapX where
, ifm_forall_ty = fmap (fmap f) ifal
, ifm_cast_ty = fmap (fmap f) icast
, ifm_coercion_ty = fmap f ico
- , ifm_tuple_ty = fmap (fmap (fmap f)) itup }
+ , ifm_tuple_ty = fmap (fmap (fmap f)) itup
+ , ifm_serialised_ty = fmap (fmap f) iser
+ }
instance TrieMap IfaceTypeMapX where
type Key IfaceTypeMapX = IfaceType
@@ -116,7 +125,8 @@ ftE f IFM { ifm_lit = ilit
, ifm_forall_ty = ifal
, ifm_cast_ty = icast
, ifm_coercion_ty = ico
- , ifm_tuple_ty = itup }
+ , ifm_tuple_ty = itup
+ , ifm_serialised_ty = iser }
= IFM { ifm_lit = filterTM f ilit
, ifm_var = filterTM f ivar
@@ -126,7 +136,9 @@ ftE f IFM { ifm_lit = ilit
, ifm_forall_ty = fmap (filterTM f) ifal
, ifm_cast_ty = fmap (filterTM f) icast
, ifm_coercion_ty = filterTM f ico
- , ifm_tuple_ty = fmap (fmap (filterTM f)) itup }
+ , ifm_tuple_ty = fmap (fmap (filterTM f)) itup
+ , ifm_serialised_ty = fmap (filterTM f) iser
+ }
{-# INLINE fdE #-}
fdE :: (a -> b -> b) -> IfaceTypeMapX a -> b -> b
@@ -138,7 +150,8 @@ fdE f IFM { ifm_lit = ilit
, ifm_forall_ty = ifal
, ifm_cast_ty = icast
, ifm_coercion_ty = ico
- , ifm_tuple_ty = itup }
+ , ifm_tuple_ty = itup
+ , ifm_serialised_ty= iser }
= foldTM f ilit . foldTM f ivar . foldTM (foldTM f) iapp
. foldTM (foldTM (foldTM (foldTM f))) ift
. foldTM (foldTM f) itc
@@ -146,6 +159,7 @@ fdE f IFM { ifm_lit = ilit
. foldTM (foldTM f) icast
. foldTM f ico
. foldTM (foldTM (foldTM f)) itup
+ . foldTM (foldTM f) iser
bndrToKey :: IfaceBndr -> Either (IfaceType, (IfLclName, IfaceType)) IfaceTvBndr
bndrToKey (IfaceIdBndr (a,b,c)) = Left (a, (b,c))
@@ -155,6 +169,7 @@ bndrToKey (IfaceTvBndr k) = Right k
lkE :: IfaceType -> IfaceTypeMapX a -> Maybe a
lkE it ifm = go it ifm
where
+ go (IfaceSerialisedType binData) = ifm_serialised_ty >.> lookupTM (fbd_buffer binData) >=> lookupTM (fbd_off_s binData)
go (IfaceFreeTyVar {}) = error "ftv"
go (IfaceTyVar var) = ifm_var >.> lookupTM var
go (IfaceLitTy l) = ifm_lit >.> lookupTM l
@@ -168,6 +183,7 @@ lkE it ifm = go it ifm
{-# INLINE xtE #-}
xtE :: IfaceType -> XT a -> IfaceTypeMapX a -> IfaceTypeMapX a
+xtE (IfaceSerialisedType binData) f m = m { ifm_serialised_ty = ifm_serialised_ty m |> alterTM (fbd_buffer binData) |>> alterTM (fbd_off_s binData) f }
xtE (IfaceFreeTyVar {}) _ _ = error "ftv"
xtE (IfaceTyVar var) f m = m { ifm_var = ifm_var m |> alterTM var f }
xtE (IfaceLitTy l) f m = m { ifm_lit = ifm_lit m |> alterTM l f }
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -131,6 +131,7 @@ import Data.Foldable
import GHC.Builtin.Names (ioTyConName, rOOT_MAIN)
import GHC.Iface.Errors.Types
import Language.Haskell.Syntax.Extension (NoExtField (NoExtField))
+import GHC.Utils.Binary
{-
This module takes
@@ -1386,6 +1387,11 @@ loop. See #19744.
tcIfaceType :: IfaceType -> IfL Type
tcIfaceType = go
where
+ go i@(IfaceSerialisedType bs) = do
+ deserialised <- liftIO (getIfaceType =<< thawBinHandle bs)
+ go deserialised
+
+
go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n
go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)
go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l
@@ -1504,6 +1510,9 @@ tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
-}
tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
+tcIfaceExpr (IfaceSerialisedExpr fbh) = do
+ deserialised <- liftIO (getIfaceExpr =<< thawBinHandle fbh)
+ tcIfaceExpr deserialised
tcIfaceExpr (IfaceType ty)
= Type <$> tcIfaceType ty
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -342,7 +342,7 @@ data IfLclEnv
-- Whether or not the IfaceDecl came from a boot
-- file or not; we'll use this to choose between
-- NoUnfolding and BootUnfolding
- if_boot :: IsBootInterface,
+ if_boot :: !IsBootInterface,
-- The field is used only for error reporting
-- if (say) there's a Lint error in it
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -458,6 +458,7 @@ instance Binary ModIface where
lazyPut bh warns
lazyPut bh anns
put_ bh decls
+ --lazyPutMaybe bh extra_decls
put_ bh extra_decls
put_ bh insts
put_ bh fam_insts
@@ -490,6 +491,7 @@ instance Binary ModIface where
warns <- {-# SCC "bin_warns" #-} lazyGet bh
anns <- {-# SCC "bin_anns" #-} lazyGet bh
decls <- {-# SCC "bin_tycldecls" #-} get bh
+-- extra_decls <- lazyGetMaybe bh
extra_decls <- get bh
insts <- {-# SCC "bin_insts" #-} get bh
fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -19,7 +19,7 @@
-- http://www.cs.york.ac.uk/fp/nhc98/
module GHC.Utils.Binary
- ( {-type-} Bin, RelBin(..), getRelBin,
+ ( {-type-} Bin, RelBin(..), getRelBin, makeAbsoluteBin,
{-class-} Binary(..),
{-type-} ReadBinHandle, WriteBinHandle,
SymbolTable, Dictionary,
@@ -39,6 +39,7 @@ module GHC.Utils.Binary
withBinBuffer,
freezeWriteHandle,
thawReadHandle,
+ shrinkBinBuffer,
foldGet, foldGet',
@@ -246,18 +247,6 @@ thawBinHandle (FullBinData user_data ix _end sz ba) = do
ixr <- newFastMutInt ix
return $ ReadBinMem user_data ixr sz ba
--- 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 :: WriteBinHandle -> IO ReadBinHandle
-shrinkBinBuffer bh = withBinBuffer bh $ \bs -> do
- unsafeUnpackBinBuffer (copy bs)
-
-
---------------------------------------------------------------
-- BinHandle
---------------------------------------------------------------
@@ -276,6 +265,8 @@ data WriteBinHandle
wbm_sz_r :: !FastMutInt, -- ^ size of the array (cached)
wbm_arr_r :: !(IORef BinArray) -- ^ the array (bounds: (0,size-1))
}
+ -- XXX: should really store a "high water mark" for dumping out
+ -- the binary data to a file.
-- | A read-only handle that can be used to deserialise binary data from a buffer.
--
@@ -344,6 +335,17 @@ unsafeUnpackBinBuffer (BS.BS arr len) = do
ix_r <- newFastMutInt 0
return (ReadBinMem noReaderUserData ix_r len arr)
+-- 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 :: WriteBinHandle -> IO ReadBinHandle
+shrinkBinBuffer bh = withBinBuffer bh $ \bs -> do
+ unsafeUnpackBinBuffer (copy bs)
+
---------------------------------------------------------------
-- Bin
---------------------------------------------------------------
@@ -1277,7 +1279,7 @@ forwardGetRel bh get_A = do
-- store current position
p_a <- tellBinReader bh
-- go read the forward value, then seek back
- seekBinReader bh $ makeAbsoluteBin p
+ seekBinReaderRel bh p
r <- get_A
seekBinReader bh p_a
pure r
@@ -1615,7 +1617,7 @@ getGenericSymbolTable deserialiser bh = do
sz <- forwardGetRel bh (get bh) :: IO Int
mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a)
forM_ [0..(sz-1)] $ \i -> do
- f <- deserialiser bh
+ !f <- deserialiser bh
writeArray mut_arr i f
unsafeFreeze mut_arr
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fbdc16716431c447a0493313cecbceb693e25541
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fbdc16716431c447a0493313cecbceb693e25541
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/20240426/d53c5b69/attachment-0001.html>
More information about the ghc-commits
mailing list