[Git][ghc/ghc][wip/fendor/ifacetype-deduplication] 3 commits: Add run-time configurability of .hi file compression
Hannes Siebenhandl (@fendor)
gitlab at gitlab.haskell.org
Wed May 1 11:19:04 UTC 2024
Hannes Siebenhandl pushed to branch wip/fendor/ifacetype-deduplication at Glasgow Haskell Compiler / GHC
Commits:
5abb60f3 by Matthew Pickering at 2024-04-30T15:51:23+02:00
Add run-time configurability of .hi file compression
Introduce the flag `-fwrite-if-compression=<n>` which allows to
configure the compression level of writing .hi files.
The motivation is that some deduplication operations are too expensive
for the average use case. Hence, we introduce multiple compression
levels that have a minimal impact on performance, but still reduce the
memory residency and `.hi` file size on disk considerably.
We introduce three compression levels:
* `1`: `Normal` mode. This is the least amount of compression.
It deduplicates only `Name` and `FastString`s, and is naturally the
fastest compression mode.
* `2`: `Safe` mode. It has a noticeable impact on .hi file size and is
marginally slower than `Normal` mode. In general, it should be safe to
always use `Safe` mode.
* `3`: `Full` deduplication mode. Deduplicate as much as we can,
resulting in minimal .hi files, but at the cost of additional
compilation time.
Reading .hi files doesn't need to know the initial compression level,
and can always deserialise a `ModIface`.
This allows users to experiment with different compression levels for
packages, without recompilation of dependencies.
Note, the deduplication also has an additional side effect of reduced
memory consumption to implicit sharing of deduplicated elements.
See https://gitlab.haskell.org/ghc/ghc/-/issues/24540 for example where
that matters.
-------------------------
Metric Decrease:
MultiLayerModulesDefsGhciWithCore
T16875
T21839c
T24471
hard_hole_fits
-------------------------
- - - - -
1b91e077 by Matthew Pickering at 2024-04-30T15:53:05+02:00
Introduce regression tests for `.hi` file sizes
Add regression tests to track how `-fwrite-if-compression` levels affect
the size of `.hi` files.
- - - - -
53880781 by Fendor at 2024-04-30T15:53:05+02:00
Implement TrieMap for IfaceType
- - - - -
21 changed files:
- compiler/GHC/Core/Map/Expr.hs
- compiler/GHC/Data/TrieMap.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Type.hs
- + compiler/GHC/Iface/Type/Map.hs
- compiler/GHC/Stg/CSE.hs
- compiler/ghc.cabal.in
- docs/users_guide/using-optimisation.rst
- + testsuite/tests/iface/IfaceSharingIfaceType.hs
- + testsuite/tests/iface/IfaceSharingName.hs
- + testsuite/tests/iface/Lib.hs
- + testsuite/tests/iface/Makefile
- + testsuite/tests/iface/all.T
- + testsuite/tests/iface/if_faststring.hs
- + testsuite/tests/iface/if_ifacetype.hs
- + testsuite/tests/iface/if_name.hs
Changes:
=====================================
compiler/GHC/Core/Map/Expr.hs
=====================================
@@ -129,7 +129,7 @@ instance TrieMap CoreMap where
-- inside another 'TrieMap', this is the type you want.
type CoreMapG = GenMap CoreMapX
-type LiteralMap a = Map.Map Literal a
+type LiteralMap a = Map.Map Literal a
-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without
-- the 'GenMap' optimization.
=====================================
compiler/GHC/Data/TrieMap.hs
=====================================
@@ -36,6 +36,8 @@ import qualified Data.IntMap as IntMap
import GHC.Utils.Outputable
import Control.Monad( (>=>) )
import Data.Kind( Type )
+import Data.Functor.Compose
+import Data.Functor.Product
import qualified Data.Semigroup as S
@@ -340,6 +342,95 @@ ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a
ftList f (LM { lm_nil = mnil, lm_cons = mcons })
= LM { lm_nil = filterMaybe f mnil, lm_cons = fmap (filterTM f) mcons }
+
+{-
+************************************************************************
+* *
+ Composition
+* *
+************************************************************************
+-}
+
+instance (TrieMap m, TrieMap n) => TrieMap (Compose m n) where
+ type Key (Compose m n) = (Key m, Key n)
+ emptyTM = Compose emptyTM
+ lookupTM = lkCompose lookupTM lookupTM
+ {-# INLINE lookupTM #-}
+ alterTM = xtCompose alterTM alterTM
+ {-# INLINE alterTM #-}
+ foldTM = fdCompose
+ {-# INLINE foldTM #-}
+ filterTM = ftCompose
+ {-# INLINE filterTM #-}
+
+lkCompose :: Monad m => (t1 -> f (g a1) -> m a2) -> (t2 -> a2 -> m b) -> (t1, t2) -> Compose f g a1 -> m b
+lkCompose f g (a, b) (Compose m) = f a m >>= g b
+{-# INLINE lkCompose #-}
+
+xtCompose ::
+ (TrieMap m, TrieMap n)
+ => (forall a . Key m -> XT a -> m a -> m a)
+ -> (forall a . Key n -> XT a -> n a -> n a)
+ -> Key (Compose m n)
+ -> XT a
+ -> Compose m n a
+ -> Compose m n a
+
+xtCompose f g (a, b) xt (Compose m) = Compose ((f a |>> g b xt) m)
+
+{-# INLINE xtCompose #-}
+
+fdCompose :: (TrieMap m1, TrieMap m2) => (a -> b -> b) -> Compose m1 m2 a -> b -> b
+fdCompose f (Compose m) = foldTM (foldTM f) m
+
+{-# INLINE fdCompose #-}
+
+
+ftCompose :: (TrieMap n, Functor m) => (a -> Bool) -> Compose m n a -> Compose m n a
+ftCompose f (Compose m) = Compose (fmap (filterTM f) m)
+
+{-# INLINE ftCompose #-}
+
+{- Product -}
+instance (TrieMap m, TrieMap n) => TrieMap (Product m n) where
+ type Key (Product m n) = Either (Key m) (Key n)
+ emptyTM = Pair emptyTM emptyTM
+ lookupTM = lkProduct
+ {-# INLINE lookupTM #-}
+ alterTM = xtProduct
+ {-# INLINE alterTM #-}
+ foldTM = fdProduct
+ {-# INLINE foldTM #-}
+ filterTM = ftProduct
+ {-# INLINE filterTM #-}
+
+lkProduct :: (TrieMap m1, TrieMap m2) => Either (Key m1) (Key m2) -> Product m1 m2 b -> Maybe b
+lkProduct k (Pair am bm) =
+ case k of
+ Left a -> lookupTM a am
+ Right b -> lookupTM b bm
+
+{-# INLINE lkProduct #-}
+
+xtProduct :: (TrieMap f, TrieMap g) => Either (Key f) (Key g) -> XT a -> Product f g a -> Product f g a
+xtProduct k xt (Pair am bm) =
+ case k of
+ Left a -> Pair (alterTM a xt am) bm
+ Right b -> Pair am (alterTM b xt bm)
+
+{-# INLINE xtProduct #-}
+
+fdProduct :: (TrieMap f, TrieMap g) => (a -> c -> c) -> Product f g a -> c -> c
+fdProduct f (Pair am bm) = foldTM f am . foldTM f bm
+
+{-# INLINE fdProduct #-}
+
+ftProduct :: (TrieMap f, TrieMap g) => (a -> Bool) -> Product f g a -> Product f g a
+ftProduct f (Pair am bm) = Pair (filterTM f am) (filterTM f bm)
+
+{-# INLINE ftProduct #-}
+
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -207,6 +207,7 @@ data DynFlags = DynFlags {
dmdUnboxWidth :: !Int, -- ^ Whether DmdAnal should optimistically put an
-- Unboxed demand on returned products with at most
-- this number of fields
+ ifCompression :: Int,
specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr
specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function
specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types
@@ -546,6 +547,7 @@ defaultDynFlags mySettings =
maxPmCheckModels = 30,
simplTickFactor = 100,
dmdUnboxWidth = 3, -- Default: Assume an unboxed demand on function bodies returning a triple
+ ifCompression = 2, -- Default: Apply safe compressions
specConstrThreshold = Just 2000,
specConstrCount = Just 3,
specConstrRecursive = 3,
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -163,7 +163,7 @@ import GHC.JS.Syntax
import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings )
-import GHC.Iface.Load ( ifaceStats, writeIface )
+import GHC.Iface.Load ( ifaceStats, writeIface, flagsToIfCompression )
import GHC.Iface.Make
import GHC.Iface.Recomp
import GHC.Iface.Tidy
@@ -612,7 +612,7 @@ extract_renamed_stuff mod_summary tc_result = do
-- enables the option which keeps the renamed source.
hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
let out_file = ml_hie_file $ ms_location mod_summary
- liftIO $ writeHieFile out_file hieFile
+ liftIO $ writeHieFile (flagsToIfCompression dflags) out_file hieFile
liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
-- Validate HIE files
@@ -1207,7 +1207,7 @@ hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do
withTiming logger
(text "WriteIface"<+>brackets (text iface_name))
(const ())
- (writeIface logger profile iface_name iface)
+ (writeIface logger profile (flagsToIfCompression dflags) iface_name iface)
if (write_interface || force_write_interface) then do
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -1695,6 +1695,9 @@ dynamic_flags_deps = [
, make_ord_flag defFlag "fno-refinement-level-hole-fits"
(noArg (\d -> d { refLevelHoleFits = Nothing }))
+ , make_ord_flag defFlag "fwrite-if-compression"
+ (intSuffix (\n d -> d { ifCompression = n }))
+
, make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs"
(noArg id)
"vectors registers are now passed in registers by default."
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -14,6 +14,7 @@ module GHC.Iface.Binary (
writeBinIface,
readBinIface,
readBinIfaceHeader,
+ CompressionIFace(..),
getSymtabName,
CheckHiWay(..),
TraceBinIFace(..),
@@ -48,7 +49,7 @@ import GHC.Types.SrcLoc
import GHC.Platform
import GHC.Settings.Constants
import GHC.Utils.Fingerprint
-import GHC.Iface.Type (IfaceType, getIfaceType, putIfaceType)
+import GHC.Iface.Type (IfaceType(..), getIfaceType, putIfaceType, ifaceTypeSharedByte)
import Control.Monad
import Data.Array
@@ -73,6 +74,21 @@ data TraceBinIFace
= TraceBinIFace (SDoc -> IO ())
| QuietBinIFace
+data CompressionIFace
+ = NormalCompression
+ -- ^ Perform the normal compression operations,
+ -- such as deduplicating 'Name's and 'FastString's
+ | SafeExtraCompression
+ -- ^ Perform some extra compression steps that have minimal impact
+ -- on the run-time of 'ghc'.
+ --
+ -- This reduces the size of '.hi' files significantly in some cases
+ -- and reduces overall memory usage in certain scenarios.
+ | MaximalCompression
+ -- ^ Try to compress as much as possible.
+ --
+ -- Yields the smallest '.hi' files but at the cost of additional run-time.
+
-- | Read an interface file header, checking the magic number, version, and
-- way. Returns the hash of the source file and a BinHandle which points at the
-- start of the rest of the interface file data.
@@ -199,8 +215,8 @@ getTables name_cache bh = do
-- | Write an interface file.
--
-- See Note [Deduplication during iface binary serialisation] for details.
-writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()
-writeBinIface profile traceBinIface hi_path mod_iface = do
+writeBinIface :: Profile -> TraceBinIFace -> CompressionIFace -> FilePath -> ModIface -> IO ()
+writeBinIface profile traceBinIface compressionLevel hi_path mod_iface = do
bh <- openBinMem initBinMemSize
let platform = profilePlatform profile
put_ bh (binaryInterfaceMagic platform)
@@ -214,7 +230,7 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
extFields_p_p <- tellBinWriter bh
put_ bh extFields_p_p
- putWithUserData traceBinIface bh mod_iface
+ putWithUserData traceBinIface compressionLevel bh mod_iface
extFields_p <- tellBinWriter bh
putAt bh extFields_p_p extFields_p
@@ -228,9 +244,9 @@ writeBinIface profile traceBinIface hi_path mod_iface = do
-- is necessary if you want to serialise Names or FastStrings.
-- It also writes a symbol table and the dictionary.
-- This segment should be read using `getWithUserData`.
-putWithUserData :: Binary a => TraceBinIFace -> WriteBinHandle -> a -> IO ()
-putWithUserData traceBinIface bh payload = do
- (name_count, fs_count, _b) <- putWithTables bh (\bh' -> put bh' payload)
+putWithUserData :: Binary a => TraceBinIFace -> CompressionIFace -> WriteBinHandle -> a -> IO ()
+putWithUserData traceBinIface compressionLevel bh payload = do
+ (name_count, fs_count, _b) <- putWithTables compressionLevel bh (\bh' -> put bh' payload)
case traceBinIface of
QuietBinIFace -> return ()
@@ -253,12 +269,12 @@ putWithUserData traceBinIface bh payload = do
-- It returns (number of names, number of FastStrings, payload write result)
--
-- See Note [Order of deduplication tables during iface binary serialisation]
-putWithTables :: WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, b)
-putWithTables bh' put_payload = do
+putWithTables :: CompressionIFace -> WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, b)
+putWithTables compressionLevel bh' put_payload = do
-- Initialise deduplicating tables.
(fast_wt, fsWriter) <- initFastStringWriterTable
(name_wt, nameWriter) <- initNameWriterTable
- (ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType
+ (ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType compressionLevel
-- Initialise the 'WriterUserData'.
let writerUserData = mkWriterUserData
@@ -485,15 +501,33 @@ initReadIfaceTypeTable ud = do
, mkReaderFromTable = \tbl -> mkReader (getGenericSymtab tbl)
}
-initWriteIfaceType :: IO (WriterTable, BinaryWriter IfaceType)
-initWriteIfaceType = do
+initWriteIfaceType :: CompressionIFace -> IO (WriterTable, BinaryWriter IfaceType)
+initWriteIfaceType compressionLevel = do
sym_tab <- initGenericSymbolTable @(Map IfaceType)
pure
( WriterTable
{ putTable = putGenericSymbolTable sym_tab (lazyPut' putIfaceType)
}
- , mkWriter $ putGenericSymTab sym_tab
+ , mkWriter $ ifaceWriter sym_tab
)
+ where
+ ifaceWriter sym_tab = case compressionLevel of
+ NormalCompression -> literalIfaceTypeSerialiser
+ SafeExtraCompression -> ifaceTyConAppSerialiser sym_tab
+ MaximalCompression -> fullIfaceTypeSerialiser sym_tab
+
+ ifaceTyConAppSerialiser sym_tab bh ty = case ty of
+ IfaceTyConApp {} -> do
+ put_ bh ifaceTypeSharedByte
+ putGenericSymTab sym_tab bh ty
+ _ -> putIfaceType bh ty
+
+
+ fullIfaceTypeSerialiser sym_tab bh ty = do
+ put_ bh ifaceTypeSharedByte
+ putGenericSymTab sym_tab bh ty
+
+ literalIfaceTypeSerialiser = putIfaceType
initNameReaderTable :: NameCache -> IO (ReaderTable Name)
=====================================
compiler/GHC/Iface/Ext/Binary.hs
=====================================
@@ -43,7 +43,7 @@ import System.Directory ( createDirectoryIfMissing )
import System.FilePath ( takeDirectory )
import GHC.Iface.Ext.Types
-import GHC.Iface.Binary (initWriteIfaceType, putAllTables, initReadIfaceTypeTable)
+import GHC.Iface.Binary (initWriteIfaceType, putAllTables, initReadIfaceTypeTable, CompressionIFace)
import GHC.Iface.Type (IfaceType)
import System.IO.Unsafe (unsafeInterleaveIO)
import qualified GHC.Utils.Binary as Binary
@@ -73,8 +73,8 @@ putBinLine bh xs = do
-- | Write a `HieFile` to the given `FilePath`, with a proper header and
-- symbol tables for `Name`s and `FastString`s
-writeHieFile :: FilePath -> HieFile -> IO ()
-writeHieFile hie_file_path hiefile = do
+writeHieFile :: CompressionIFace -> FilePath -> HieFile -> IO ()
+writeHieFile compression hie_file_path hiefile = do
bh0 <- openBinMem initBinMemSize
-- Write the header: hieHeader followed by the
@@ -85,7 +85,7 @@ writeHieFile hie_file_path hiefile = do
(fs_tbl, fs_w) <- initFastStringWriterTable
(name_tbl, name_w) <- initWriteNameTable
- (iface_tbl, iface_w) <- initWriteIfaceType
+ (iface_tbl, iface_w) <- initWriteIfaceType compression
let bh = setWriterUserData bh0 $ mkWriterUserData
[ mkSomeBinaryWriter @IfaceType iface_w
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -26,6 +26,7 @@ module GHC.Iface.Load (
loadInterface,
loadSysInterface, loadUserInterface, loadPluginInterface,
findAndReadIface, readIface, writeIface,
+ flagsToIfCompression,
moduleFreeHolesPrecise,
needWiredInHomeIface, loadWiredInHomeIface,
@@ -965,11 +966,18 @@ read_file logger name_cache unit_state dflags wanted_mod file_path = do
-- | Write interface file
-writeIface :: Logger -> Profile -> FilePath -> ModIface -> IO ()
-writeIface logger profile hi_file_path new_iface
+writeIface :: Logger -> Profile -> CompressionIFace -> FilePath -> ModIface -> IO ()
+writeIface logger profile compression_level hi_file_path new_iface
= do createDirectoryIfMissing True (takeDirectory hi_file_path)
let printer = TraceBinIFace (debugTraceMsg logger 3)
- writeBinIface profile printer hi_file_path new_iface
+ writeBinIface profile printer compression_level hi_file_path new_iface
+
+flagsToIfCompression :: DynFlags -> CompressionIFace
+flagsToIfCompression dflags = case ifCompression dflags of
+ 0 -> NormalCompression
+ 1 -> NormalCompression
+ 2 -> SafeExtraCompression
+ _ -> MaximalCompression
-- | @readIface@ tries just the one file.
--
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -34,7 +34,7 @@ module GHC.Iface.Type (
ifTyConBinderVar, ifTyConBinderName,
-- Binary utilities
- putIfaceType, getIfaceType,
+ putIfaceType, getIfaceType, ifaceTypeSharedByte,
-- Equality testing
isIfaceLiftedTypeKind,
@@ -92,12 +92,13 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar )
-import Control.DeepSeq
+import Data.Maybe (isJust)
import Data.Proxy
-import Control.Monad ((<$!>))
-import Control.Arrow (first)
import qualified Data.Semigroup as Semi
-import Data.Maybe (isJust)
+import Data.Word (Word8)
+import Control.Arrow (first)
+import Control.DeepSeq
+import Control.Monad ((<$!>))
{-
************************************************************************
@@ -112,6 +113,10 @@ newtype IfLclName = IfLclName
{ getIfLclName :: LexicalFastString
} deriving (Eq, Ord, Show)
+instance Uniquable IfLclName where
+ getUnique = getUnique . ifLclNameFS
+
+
ifLclNameFS :: IfLclName -> FastString
ifLclNameFS = getLexicalFastString . getIfLclName
@@ -2194,12 +2199,35 @@ ppr_parend_preds :: [IfacePredType] -> SDoc
ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds)))
instance Binary IfaceType where
- put_ bh tyCon = case findUserDataWriter Proxy bh of
- tbl -> putEntry tbl bh tyCon
+ put_ bh ty =
+ case findUserDataWriter Proxy bh of
+ tbl -> putEntry tbl bh ty
- get bh = case findUserDataReader Proxy bh of
- tbl -> getEntry tbl bh
+ get bh = getIfaceTypeShared bh
+-- | This is the byte tag we expect to read when the next
+-- value is not an 'IfaceType' value, but an offset into a
+-- lookup value.
+--
+-- Must not overlap with any byte tag in 'getIfaceType'.
+ifaceTypeSharedByte :: Word8
+ifaceTypeSharedByte = 99
+
+-- | Like 'getIfaceType' but checks for a specific byte tag
+-- that indicates that we won't be able to read a 'IfaceType' value
+-- but rather an offset into a lookup table. Consequentially,
+-- we look up the value for the 'IfaceType' in the look up table.
+--
+-- See Note [Deduplication during iface binary serialisation]
+-- for details.
+getIfaceTypeShared :: ReadBinHandle -> IO IfaceType
+getIfaceTypeShared bh = do
+ start <- tellBinReader bh
+ tag <- getByte bh
+ if ifaceTypeSharedByte == tag
+ then case findUserDataReader Proxy bh of
+ tbl -> getEntry tbl bh
+ else seekBinReader bh start >> getIfaceType bh
putIfaceType :: WriteBinHandle -> IfaceType -> IO ()
putIfaceType _ (IfaceFreeTyVar tv)
=====================================
compiler/GHC/Iface/Type/Map.hs
=====================================
@@ -0,0 +1,180 @@
+{-# LANGUAGE TypeFamilies #-}
+module GHC.Iface.Type.Map where
+
+import GHC.Prelude
+import GHC.Data.TrieMap
+import GHC.Iface.Type
+import qualified Data.Map as Map
+import Data.Functor.Compose
+import GHC.Types.Basic
+import Control.Monad ((>=>))
+import GHC.Types.Unique.DFM
+import Data.Functor.Product
+import GHC.Types.Var (VarBndr(..))
+
+
+newtype IfaceTypeMap a = IfaceTypeMap (IfaceTypeMapG a)
+
+instance Functor IfaceTypeMap where
+ fmap f (IfaceTypeMap m) = IfaceTypeMap (fmap f m)
+
+instance TrieMap IfaceTypeMap where
+ type Key IfaceTypeMap = IfaceType
+
+ emptyTM = IfaceTypeMap emptyTM
+
+ lookupTM k (IfaceTypeMap m) = lookupTM k m
+
+ alterTM k f (IfaceTypeMap m) = IfaceTypeMap (alterTM k f m)
+
+ filterTM f (IfaceTypeMap m) = IfaceTypeMap (filterTM f m)
+
+ foldTM f (IfaceTypeMap m) = foldTM f m
+
+type IfaceTypeMapG = GenMap IfaceTypeMapX
+
+data IfaceTypeMapX a
+ = IFM { ifm_lit :: IfaceLiteralMap a
+ , ifm_var :: UniqDFM IfLclName a
+ , ifm_app :: IfaceTypeMapG (IfaceAppArgsMap a)
+ , ifm_fun_ty :: FunTyFlagMap (IfaceTypeMapG (IfaceTypeMapG (IfaceTypeMapG a)))
+ , ifm_ty_con_app :: IfaceTyConMap (IfaceAppArgsMap 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)) }
+
+type IfaceLiteralMap = Map.Map IfaceTyLit
+type FunTyFlagMap = Map.Map FunTyFlag
+type IfaceTyConMap = Map.Map IfaceTyCon
+type ForAllTyFlagMap = Map.Map ForAllTyFlag
+type IfaceCoercionMap = Map.Map IfaceCoercion
+type TupleSortMap = Map.Map TupleSort
+type PromotionFlagMap = Map.Map PromotionFlag
+type IfaceForAllBndrMap = Compose IfaceBndrMap ForAllTyFlagMap
+
+type IfaceIdBndrMap = Compose IfaceTypeMapG (Compose (UniqDFM IfLclName) IfaceTypeMapG)
+type IfaceTvBndrMap = Compose (UniqDFM IfLclName) IfaceTypeMapG
+
+type IfaceBndrMap = Product IfaceIdBndrMap IfaceTvBndrMap
+
+
+
+
+type IfaceAppArgsMap a = ListMap (Compose IfaceTypeMapG ForAllTyFlagMap) a
+
+emptyE :: IfaceTypeMapX a
+emptyE = IFM { ifm_lit = emptyTM
+ , ifm_var = emptyTM
+ , ifm_app = emptyTM
+ , ifm_fun_ty = emptyTM
+ , ifm_ty_con_app = emptyTM
+ , ifm_forall_ty = emptyTM
+ , ifm_cast_ty = emptyTM
+ , ifm_coercion_ty = emptyTM
+ , ifm_tuple_ty = emptyTM }
+
+instance Functor IfaceTypeMapX where
+ fmap f IFM { ifm_lit = ilit
+ , ifm_var = ivar
+ , ifm_app = iapp
+ , ifm_fun_ty = ift
+ , ifm_ty_con_app = itc
+ , ifm_forall_ty = ifal
+ , ifm_cast_ty = icast
+ , ifm_coercion_ty = ico
+ , ifm_tuple_ty = itup }
+
+ = IFM { ifm_lit = fmap f ilit
+ , ifm_var = fmap f ivar
+ , ifm_app = fmap (fmap f) iapp
+ , ifm_fun_ty = fmap (fmap (fmap (fmap f))) ift
+ , ifm_ty_con_app = fmap (fmap f) itc
+ , 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 }
+
+instance TrieMap IfaceTypeMapX where
+ type Key IfaceTypeMapX = IfaceType
+
+ emptyTM = emptyE
+ lookupTM = lkE
+ alterTM = xtE
+ foldTM = fdE
+ filterTM = ftE
+ {-# INLINE lookupTM #-}
+ {-# INLINE alterTM #-}
+
+{-# INLINE ftE #-}
+ftE :: (a -> Bool) -> IfaceTypeMapX a -> IfaceTypeMapX a
+ftE f IFM { ifm_lit = ilit
+ , ifm_var = ivar
+ , ifm_app = iapp
+ , ifm_fun_ty = ift
+ , ifm_ty_con_app = itc
+ , ifm_forall_ty = ifal
+ , ifm_cast_ty = icast
+ , ifm_coercion_ty = ico
+ , ifm_tuple_ty = itup }
+
+ = IFM { ifm_lit = filterTM f ilit
+ , ifm_var = filterTM f ivar
+ , ifm_app = fmap (filterTM f) iapp
+ , ifm_fun_ty = fmap (fmap (fmap (filterTM f))) ift
+ , ifm_ty_con_app = fmap (filterTM f) itc
+ , 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 }
+
+{-# INLINE fdE #-}
+fdE :: (a -> b -> b) -> IfaceTypeMapX a -> b -> b
+fdE f IFM { ifm_lit = ilit
+ , ifm_var = ivar
+ , ifm_app = iapp
+ , ifm_fun_ty = ift
+ , ifm_ty_con_app = itc
+ , ifm_forall_ty = ifal
+ , ifm_cast_ty = icast
+ , ifm_coercion_ty = ico
+ , ifm_tuple_ty = itup }
+ = foldTM f ilit . foldTM f ivar . foldTM (foldTM f) iapp
+ . foldTM (foldTM (foldTM (foldTM f))) ift
+ . foldTM (foldTM f) itc
+ . foldTM (foldTM f) ifal
+ . foldTM (foldTM f) icast
+ . foldTM f ico
+ . foldTM (foldTM (foldTM f)) itup
+
+bndrToKey :: IfaceBndr -> Either (IfaceType, (IfLclName, IfaceType)) IfaceTvBndr
+bndrToKey (IfaceIdBndr (a,b,c)) = Left (a, (b,c))
+bndrToKey (IfaceTvBndr k) = Right k
+
+{-# INLINE lkE #-}
+lkE :: IfaceType -> IfaceTypeMapX a -> Maybe a
+lkE it ifm = go it ifm
+ where
+ go (IfaceFreeTyVar {}) = error "ftv"
+ go (IfaceTyVar var) = ifm_var >.> lookupTM var
+ go (IfaceLitTy l) = ifm_lit >.> lookupTM l
+ go (IfaceAppTy ift args) = ifm_app >.> lkG ift >=> lookupTM (appArgsIfaceTypesForAllTyFlags args)
+ go (IfaceFunTy ft t1 t2 t3) = ifm_fun_ty >.> lookupTM ft >=> lkG t1 >=> lkG t2 >=> lkG t3
+ go (IfaceForAllTy (Bndr a b) t) = ifm_forall_ty >.> lookupTM (bndrToKey a,b) >=> lkG t
+ go (IfaceTyConApp tc args) = ifm_ty_con_app >.> lookupTM tc >=> lookupTM (appArgsIfaceTypesForAllTyFlags args)
+ go (IfaceCastTy ty co) = ifm_cast_ty >.> lkG ty >=> lookupTM co
+ go (IfaceCoercionTy co) = ifm_coercion_ty >.> lookupTM co
+ go (IfaceTupleTy sort prom args) = ifm_tuple_ty >.> lookupTM sort >=> lookupTM prom >=> lookupTM (appArgsIfaceTypesForAllTyFlags args)
+
+{-# INLINE xtE #-}
+xtE :: IfaceType -> XT a -> IfaceTypeMapX a -> IfaceTypeMapX a
+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 }
+xtE (IfaceAppTy ift args) f m = m { ifm_app = ifm_app m |> xtG ift |>> alterTM (appArgsIfaceTypesForAllTyFlags args) f }
+xtE (IfaceFunTy ft t1 t2 t3) f m = m { ifm_fun_ty = ifm_fun_ty m |> alterTM ft |>> xtG t1 |>> xtG t2 |>> xtG t3 f }
+xtE (IfaceForAllTy (Bndr a b) t) f m = m { ifm_forall_ty = ifm_forall_ty m |> alterTM (bndrToKey a,b) |>> xtG t f }
+xtE (IfaceTyConApp tc args) f m = m { ifm_ty_con_app = ifm_ty_con_app m |> alterTM tc |>> alterTM (appArgsIfaceTypesForAllTyFlags args) f }
+xtE (IfaceCastTy ty co) f m = m { ifm_cast_ty = ifm_cast_ty m |> xtG ty |>> alterTM co f }
+xtE (IfaceCoercionTy co) f m = m { ifm_coercion_ty = ifm_coercion_ty m |> alterTM co f }
+xtE (IfaceTupleTy sort prom args) f m = m { ifm_tuple_ty = ifm_tuple_ty m |> alterTM sort |>> alterTM prom |>> alterTM (appArgsIfaceTypesForAllTyFlags args) f }
=====================================
compiler/GHC/Stg/CSE.hs
=====================================
@@ -124,7 +124,7 @@ data StgArgMap a = SAM
, sam_lit :: LiteralMap a
}
-type LiteralMap a = Map.Map Literal a
+type LiteralMap = Map.Map Literal
-- TODO(22292): derive
instance Functor StgArgMap where
=====================================
compiler/ghc.cabal.in
=====================================
@@ -594,6 +594,7 @@ Library
GHC.Iface.Tidy.StaticPtrTable
GHC.IfaceToCore
GHC.Iface.Type
+ GHC.Iface.Type.Map
GHC.JS.Ident
GHC.JS.Make
GHC.JS.Optimizer
=====================================
docs/users_guide/using-optimisation.rst
=====================================
@@ -1777,3 +1777,12 @@ as such you shouldn't need to set any of them explicitly. A flag
This flag sets the size (in bytes) threshold above which the second approach
is used. You can disable the second approach entirely by setting the
threshold to 0.
+
+.. ghc-flag:: -fwrite-if-compression=⟨n⟩
+ :shortdesc: *default: 2.* Tweak the level of interface file compression.
+ :type: dynamic
+ :category: optimization
+
+ :default: 2
+
+ TODO
=====================================
testsuite/tests/iface/IfaceSharingIfaceType.hs
=====================================
@@ -0,0 +1,44 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module IfaceSharingIfaceType (types) where
+
+import GHC.Data.FastString
+import GHC.Builtin.Uniques
+import GHC.Builtin.Names
+import GHC.Builtin.Types
+import GHC.Types.Name
+import GHC.Types.SrcLoc
+import GHC.Iface.Type
+import GHC.CoreToIface
+import GHC.Core.TyCo.Rep
+import GHC
+
+[f1,f2,f3,f4,f5] = map mkVarOcc ["a", "b","c","d","e"]
+
+[u1,u2,u3,u4,u5] = map mkPreludeMiscIdUnique [10000..10004]
+
+names = [ mkExternalName u1 pRELUDE f1 noSrcSpan
+ , mkExternalName u2 pRELUDE f2 noSrcSpan
+ , mkExternalName u3 pRELUDE f3 noSrcSpan
+ , mkExternalName u4 pRELUDE f4 noSrcSpan
+ , mkExternalName u5 pRELUDE f5 noSrcSpan ]
+
+-- Int
+intIfaceTy = toIfaceType intTy
+
+wordIfaceTy = toIfaceType wordTy
+
+listIntTy = toIfaceType (mkListTy intTy)
+
+funTy = (intTy `mkVisFunTyMany` wordTy `mkVisFunTyMany` mkListTy intTy)
+
+funIfaceTy = toIfaceType funTy
+
+reallyBigFunTy = toIfaceType (funTy `mkVisFunTyMany` funTy `mkVisFunTyMany` funTy `mkVisFunTyMany` funTy)
+
+forallIfaceTy = toIfaceType (dataConType justDataCon)
+
+
+types = [intIfaceTy, wordIfaceTy, listIntTy, funIfaceTy, reallyBigFunTy, forallIfaceTy]
+
=====================================
testsuite/tests/iface/IfaceSharingName.hs
=====================================
@@ -0,0 +1,21 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module IfaceSharingName where
+
+import Lib
+import GHC.Data.FastString
+import GHC.Builtin.Uniques
+import GHC.Builtin.Names
+import GHC.Types.Name
+import GHC.Types.SrcLoc
+
+[f1,f2,f3,f4,f5] = map mkVarOcc ["a", "b","c","d","e"]
+
+[u1,u2,u3,u4,u5] = map mkPreludeMiscIdUnique [10000..10004]
+
+names = [ mkExternalName u1 pRELUDE f1 noSrcSpan
+ , mkExternalName u2 pRELUDE f2 noSrcSpan
+ , mkExternalName u3 pRELUDE f3 noSrcSpan
+ , mkExternalName u4 pRELUDE f4 noSrcSpan
+ , mkExternalName u5 pRELUDE f5 noSrcSpan ]
=====================================
testsuite/tests/iface/Lib.hs
=====================================
@@ -0,0 +1,15 @@
+module Lib where
+
+import GHC.Utils.Binary
+import GHC.Iface.Binary
+import qualified Data.ByteString as B
+import System.Environment
+import Data.Maybe
+
+testSize :: Binary a => CompressionIFace -> a -> IO Int
+testSize compLvl payload = do
+ args <- getArgs
+ bh <- openBinMem 1024
+ putWithUserData QuietBinIFace compLvl bh payload
+ withBinBuffer bh (\b -> return (B.length b))
+
=====================================
testsuite/tests/iface/Makefile
=====================================
@@ -0,0 +1,4 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
=====================================
testsuite/tests/iface/all.T
=====================================
@@ -0,0 +1,24 @@
+test( 'if_faststring'
+ , [ stat_from_file('normal', 5, 'NORMALSIZE')
+ , stat_from_file('medium', 5, 'MEDIUMSIZE')
+ , stat_from_file('full', 5, 'FULLSIZE')
+ , extra_files(["Lib.hs"])]
+ , compile_and_run
+ , ['-package ghc'])
+
+test( 'if_name'
+ , [ stat_from_file('normal', 5, 'NORMALSIZE')
+ , stat_from_file('medium', 5, 'MEDIUMSIZE')
+ , stat_from_file('full', 5, 'FULLSIZE')
+ , extra_files(["Lib.hs", "IfaceSharingName.hs"])]
+ , compile_and_run
+ , ['-package ghc'])
+
+test( 'if_ifacetype'
+ , [ stat_from_file('normal', 5, 'NORMALSIZE')
+ , stat_from_file('medium', 5, 'MEDIUMSIZE')
+ , stat_from_file('full', 5, 'FULLSIZE')
+ , extra_files(["Lib.hs", "IfaceSharingIfaceType.hs"])]
+ , compile_and_run
+ , ['-package ghc'])
+
=====================================
testsuite/tests/iface/if_faststring.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+import Lib
+import GHC.Data.FastString
+import GHC.Iface.Binary
+
+main :: IO ()
+main = do
+ sz <- testSize MaximalCompression (concat (replicate 1000 ["abc", "cde", "efg" :: FastString]))
+ writeFile "FULLSIZE" (show sz)
+ sz <- testSize SafeExtraCompression (concat (replicate 1000 ["abc", "cde", "efg" :: FastString]))
+ writeFile "MEDIUMSIZE" (show sz)
+ sz <- testSize NormalCompression (concat (replicate 1000 ["abc", "cde", "efg" :: FastString]))
+ writeFile "NORMALSIZE" (show sz)
=====================================
testsuite/tests/iface/if_ifacetype.hs
=====================================
@@ -0,0 +1,13 @@
+import Lib
+import IfaceSharingIfaceType
+import GHC.Iface.Binary
+
+main :: IO ()
+main = do
+ sz <- testSize MaximalCompression (concat (replicate 500 types))
+ writeFile "FULLSIZE" (show sz)
+ sz <- testSize SafeExtraCompression (concat (replicate 500 types))
+ writeFile "MEDIUMSIZE" (show sz)
+ sz <- testSize NormalCompression (concat (replicate 500 types))
+ writeFile "NORMALSIZE" (show sz)
+
=====================================
testsuite/tests/iface/if_name.hs
=====================================
@@ -0,0 +1,12 @@
+import Lib
+import IfaceSharingName
+import GHC.Iface.Binary
+
+main :: IO ()
+main = do
+ sz <- testSize MaximalCompression (concat (replicate 1000 names))
+ writeFile "FULLSIZE" (show sz)
+ sz <- testSize SafeExtraCompression (concat (replicate 1000 names))
+ writeFile "MEDIUMSIZE" (show sz)
+ sz <- testSize NormalCompression (concat (replicate 1000 names))
+ writeFile "NORMALSIZE" (show sz)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/485d2cb3fedc7f2dbf9d20c309bf7878af38bf3f...5388078182762a2912f2feaae024ec465975f912
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/485d2cb3fedc7f2dbf9d20c309bf7878af38bf3f...5388078182762a2912f2feaae024ec465975f912
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/20240501/21b4a50b/attachment-0001.html>
More information about the ghc-commits
mailing list