[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
Mon Apr 15 16:07:51 UTC 2024
Hannes Siebenhandl pushed to branch wip/fendor/ifacetype-deduplication at Glasgow Haskell Compiler / GHC
Commits:
62e97d7d by Matthew Pickering at 2024-04-15T18:07:34+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.
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.
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.
- - - - -
3893d390 by Matthew Pickering at 2024-04-15T18:07:34+02:00
Add some tests to check for size of interface files when serialising
various types
- - - - -
50f756f4 by Fendor at 2024-04-15T18:07:34+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
=====================================
@@ -40,6 +40,7 @@ import GHC.Utils.Outputable
import qualified Data.Map as Map
import GHC.Types.Name.Env
import Control.Monad( (>=>) )
+import GHC.Types.Literal (Literal)
{-
This module implements TrieMaps over Core related data structures
@@ -128,6 +129,8 @@ instance TrieMap CoreMap where
-- inside another 'TrieMap', this is the type you want.
type CoreMapG = GenMap CoreMapX
+type LiteralMap = Map.Map Literal
+
-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without
-- the 'GenMap' optimization.
data CoreMapX a
=====================================
compiler/GHC/Data/TrieMap.hs
=====================================
@@ -13,8 +13,6 @@ module GHC.Data.TrieMap(
MaybeMap,
-- * Maps over 'List' values
ListMap,
- -- * Maps over 'Literal's
- LiteralMap,
-- * 'TrieMap' class
TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM,
@@ -30,7 +28,6 @@ module GHC.Data.TrieMap(
import GHC.Prelude
-import GHC.Types.Literal
import GHC.Types.Unique.DFM
import GHC.Types.Unique( Uniquable )
@@ -39,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
@@ -343,15 +342,87 @@ 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 }
-{-
-************************************************************************
-* *
- Basic maps
-* *
-************************************************************************
--}
+{- 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 #-}
-type LiteralMap a = Map.Map Literal a
{-
************************************************************************
=====================================
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
=====================================
@@ -1664,6 +1664,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
@@ -72,6 +73,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.
@@ -197,8 +213,8 @@ getTables name_cache bh = do
-- | Write an interface file.
--
-- See Note [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)
@@ -212,7 +228,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
@@ -226,9 +242,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 ()
@@ -251,11 +267,11 @@ putWithUserData traceBinIface bh payload = do
-- It returns (number of names, number of FastStrings, payload write result)
--
-- See Note [Iface Binary Serialiser Order]
-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
(fast_wt, fsWriter) <- initFastStringWriterTable
(name_wt, nameWriter) <- initNameWriterTable
- (ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType
+ (ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType compressionLevel
let writerUserData = mkWriterUserData
[ mkSomeBinaryWriter @FastString fsWriter
@@ -410,15 +426,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,34 @@ 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 [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
=====================================
@@ -109,6 +109,8 @@ import GHC.Core.Map.Expr
import GHC.Data.TrieMap
import GHC.Types.Name.Env
import Control.Monad( (>=>) )
+import qualified Data.Map as Map
+import GHC.Types.Literal ( Literal )
--------------
-- The Trie --
@@ -122,6 +124,8 @@ data StgArgMap a = SAM
, sam_lit :: LiteralMap a
}
+type LiteralMap = Map.Map Literal
+
-- TODO(22292): derive
instance Functor StgArgMap where
fmap f SAM { sam_var = varm, sam_lit = litm } = SAM
=====================================
compiler/ghc.cabal.in
=====================================
@@ -579,6 +579,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 `mkInvisFunTy` wordTy `mkInvisFunTy` mkListTy intTy)
+
+funIfaceTy = toIfaceType funTy
+
+reallyBigFunTy = toIfaceType (funTy `mkInvisFunTy` funTy `mkInvisFunTy` funTy `mkInvisFunTy` 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/9eb585b99098a33058d645a1c63b9ed989708e55...50f756f4a9c48c3bce6aac80d74e12311fc47261
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9eb585b99098a33058d645a1c63b9ed989708e55...50f756f4a9c48c3bce6aac80d74e12311fc47261
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/20240415/a2251ab7/attachment-0001.html>
More information about the ghc-commits
mailing list