[Git][ghc/ghc][wip/fendor/ifacetype-deduplication] 2 commits: Add deduplication table for `IfaceType`
Hannes Siebenhandl (@fendor)
gitlab at gitlab.haskell.org
Mon Apr 8 10:21:31 UTC 2024
Hannes Siebenhandl pushed to branch wip/fendor/ifacetype-deduplication at Glasgow Haskell Compiler / GHC
Commits:
8dada682 by Matthew Pickering at 2024-04-08T12:21:09+02:00
Add deduplication table for `IfaceType`
The type `IfaceType` is a highly redundant, tree-like data structure.
While benchmarking, we realised that the high redundancy of `IfaceType`
causes high memory consumption in GHCi sessions.
We fix this by adding a deduplication table to the serialisation of
`ModIface`, similar to how we deduplicate `Name`s and `FastString`s.
When reading the interface file back, the table allows us to automatically
share identical values of `IfaceType`.
This deduplication has the beneficial side effect to additionally reduce
the size of the on-disk interface files tremendously. On the agda code
base, we reduce the size from 28 MB to 16 MB. When `-fwrite-simplified-core`
is enabled, we reduce the size from 112 MB to 22 MB.
We have to add an `Ord` instance to `IfaceType` in order to store it
efficiently for look up operations. This is mostly straightforward, we
change occurrences of `FastString` with `LexicalFastString` and add a
newtype definition for `IfLclName = LexicalFastString`.
Bump haddock submodule for `IfLclName` newtype changes.
- - - - -
fba95eb0 by Fendor at 2024-04-08T12:21:09+02:00
Add IfaceType deduplication table to .hie serialisation
Refactor .hie file serialisation to use the same infrastrucutre as
`putWithTables`.
- - - - -
20 changed files:
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Env.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Utils.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Binary.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Var.hs
- compiler/GHC/Utils/Binary.hs
- compiler/Language/Haskell/Syntax/Type.hs
- compiler/Language/Haskell/Syntax/Type.hs-boot
- utils/haddock
Changes:
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -952,13 +952,13 @@ data CoSel -- See Note [SelCo]
| SelForAll -- Decomposes (forall a. co)
- deriving( Eq, Data.Data )
+ deriving( Eq, Data.Data, Ord )
data FunSel -- See Note [SelCo]
= SelMult -- Multiplicity
| SelArg -- Argument of function
| SelRes -- Result of function
- deriving( Eq, Data.Data )
+ deriving( Eq, Data.Data, Ord )
type CoercionN = Coercion -- always nominal
type CoercionR = Coercion -- always representational
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -121,7 +121,7 @@ toIfaceTvBndr :: TyVar -> IfaceTvBndr
toIfaceTvBndr = toIfaceTvBndrX emptyVarSet
toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr
-toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar)
+toIfaceTvBndrX fr tyvar = ( mkIfLclName (occNameFS (getOccName tyvar))
, toIfaceTypeX fr (tyVarKind tyvar)
)
@@ -133,7 +133,7 @@ toIfaceIdBndr = toIfaceIdBndrX emptyVarSet
toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr
toIfaceIdBndrX fr covar = ( toIfaceType (idMult covar)
- , occNameFS (getOccName covar)
+ , mkIfLclName (occNameFS (getOccName covar))
, toIfaceTypeX fr (varType covar)
)
@@ -218,11 +218,11 @@ toIfaceTypeX fr (TyConApp tc tys)
arity = tyConArity tc
n_tys = length tys
-toIfaceTyVar :: TyVar -> FastString
-toIfaceTyVar = occNameFS . getOccName
+toIfaceTyVar :: TyVar -> IfLclName
+toIfaceTyVar = mkIfLclName . occNameFS . getOccName
-toIfaceCoVar :: CoVar -> FastString
-toIfaceCoVar = occNameFS . getOccName
+toIfaceCoVar :: CoVar -> IfLclName
+toIfaceCoVar = mkIfLclName . occNameFS . getOccName
----------------
toIfaceTyCon :: TyCon -> IfaceTyCon
@@ -264,7 +264,7 @@ toIfaceTyCon_name n = IfaceTyCon n info
toIfaceTyLit :: TyLit -> IfaceTyLit
toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x
-toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x
+toIfaceTyLit (StrTyLit x) = IfaceStrTyLit (LexicalFastString x)
toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x
----------------
@@ -296,7 +296,7 @@ toIfaceCoercionX fr co
go (InstCo co arg) = IfaceInstCo (go co) (go arg)
go (KindCo c) = IfaceKindCo (go c)
go (SubCo co) = IfaceSubCo (go co)
- go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs)
+ go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (mkIfLclName (coaxrName co)) (map go cs)
go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs)
go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r
(toIfaceTypeX fr t1)
@@ -433,7 +433,7 @@ toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang
toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang
toIfaceLetBndr :: Id -> IfaceLetBndr
-toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
+toIfaceLetBndr id = IfLetBndr (mkIfLclName (occNameFS (getOccName id)))
(toIfaceType (idType id))
(toIfaceIdInfo (idInfo id))
(idJoinPointHood id)
@@ -444,7 +444,7 @@ toIfaceTopBndr :: Id -> IfaceTopBndrInfo
toIfaceTopBndr id
= if isExternalName name
then IfGblTopBndr name
- else IfLclTopBndr (occNameFS (getOccName id)) (toIfaceType (idType id))
+ else IfLclTopBndr (mkIfLclName (occNameFS (getOccName id))) (toIfaceType (idType id))
(toIfaceIdInfo (idInfo id)) (toIfaceIdDetails (idDetails id))
where
name = getName id
@@ -555,7 +555,7 @@ toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfac
toIfaceExpr (App f a) = toIfaceApp f [a]
toIfaceExpr (Case s x ty as)
| null as = IfaceECase (toIfaceExpr s) (toIfaceType ty)
- | otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as)
+ | otherwise = IfaceCase (toIfaceExpr s) (mkIfLclName (getOccFS x)) (map toIfaceAlt as)
toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)
toIfaceExpr (Tick t e) = IfaceTick (toIfaceTickish t) (toIfaceExpr e)
@@ -610,7 +610,7 @@ toIfaceTopBind b =
---------------------
toIfaceAlt :: CoreAlt -> IfaceAlt
-toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map getOccFS bs) (toIfaceExpr r)
+toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map (mkIfLclName . getOccFS) bs) (toIfaceExpr r)
---------------------
toIfaceCon :: AltCon -> IfaceConAlt
@@ -655,7 +655,7 @@ toIfaceVar v
-- Foreign calls have special syntax
| isExternalName name = IfaceExt name
- | otherwise = IfaceLcl (occNameFS $ nameOccName name)
+ | otherwise = IfaceLcl (mkIfLclName (occNameFS $ nameOccName name))
where
name = idName v
ty = idType v
=====================================
compiler/GHC/Data/FastString.hs
=====================================
@@ -283,13 +283,16 @@ instance Ord NonDetFastString where
-- `lexicalCompareFS` (i.e. which compares FastStrings on their String
-- representation). Hence it is deterministic from one run to the other.
newtype LexicalFastString
- = LexicalFastString FastString
+ = LexicalFastString { getLexicalFastString :: FastString }
deriving newtype (Eq, Show)
deriving stock Data
instance Ord LexicalFastString where
compare (LexicalFastString fs1) (LexicalFastString fs2) = lexicalCompareFS fs1 fs2
+instance NFData LexicalFastString where
+ rnf (LexicalFastString f) = rnf f
+
-- -----------------------------------------------------------------------------
-- Construction
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -25,6 +25,8 @@ module GHC.Iface.Binary (
putName,
putSymbolTable,
BinSymbolTable(..),
+ initWriteIfaceType, initReadIfaceTypeTable,
+ putAllTables,
) where
import GHC.Prelude
@@ -54,6 +56,9 @@ import Data.Char
import Data.Word
import Data.IORef
import Control.Monad
+import GHC.Iface.Type (IfaceType, getIfaceType, putIfaceType)
+import System.IO.Unsafe
+
-- ---------------------------------------------------------------------------
-- Reading and writing binary interface files
@@ -158,9 +163,13 @@ getWithUserData name_cache bh = do
-- Reading names has the side effect of adding them into the given NameCache.
getTables :: NameCache -> ReadBinHandle -> IO ReadBinHandle
getTables name_cache bh = do
- fsReaderTable <- initFastStringReaderTable
- nameReaderTable <- (initReadNameCachedBinary name_cache)
+ bhRef <- newIORef (error "used too soon")
+ -- It is important this is passed to 'getTable'
+ ud <- unsafeInterleaveIO (readIORef bhRef)
+ fsReaderTable <- initFastStringReaderTable
+ nameReaderTable <- initReadNameCachedBinary name_cache
+ ifaceTypeReaderTable <- initReadIfaceTypeTable ud
-- The order of these deserialisation matters!
--
@@ -168,14 +177,21 @@ getTables name_cache bh = do
fsTable <- Binary.forwardGet bh (getTable fsReaderTable bh)
let
fsReader = mkReaderFromTable fsReaderTable fsTable
- bhFs = addReaderToUserData (mkSomeBinaryReader fsReader) bh
+ bhFs = addReaderToUserData fsReader bh
+
nameTable <- Binary.forwardGet bh (getTable nameReaderTable bhFs)
let
nameReader = mkReaderFromTable nameReaderTable nameTable
- bhName = addReaderToUserData (mkSomeBinaryReader nameReader) bhFs
+ bhName = addReaderToUserData nameReader bhFs
- pure bhName
+ ifaceTypeTable <- Binary.forwardGet bh (getTable ifaceTypeReaderTable bhName)
+ let
+ ifaceTypeReader = mkReaderFromTable ifaceTypeReaderTable ifaceTypeTable
+ bhIfaceType = addReaderToUserData ifaceTypeReader bhName
+
+ writeIORef bhRef (getReaderUserData bhIfaceType)
+ pure bhIfaceType
-- | Write an interface file.
--
@@ -238,11 +254,13 @@ putWithTables :: WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, b)
putWithTables bh' put_payload = do
(fast_wt, fsWriter) <- initFastStringWriterTable
(name_wt, nameWriter) <- initWriteNameTable
+ (ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType
let writerUserData = mkWriterUserData
[ mkSomeBinaryWriter @FastString fsWriter
, mkSomeBinaryWriter @Name nameWriter
, mkSomeBinaryWriter @BindingName $ mkWriter (\bh name -> putEntry nameWriter bh (getBindingName name))
+ , mkSomeBinaryWriter @IfaceType ifaceTypeWriter
]
let bh = setWriterUserData bh' writerUserData
@@ -250,18 +268,24 @@ putWithTables bh' put_payload = do
-- The order of these entries matters!
--
-- See Note [Iface Binary Serialiser Order] for details.
- putAllTables bh [fast_wt, name_wt] $ do
+ putAllTables bh [fast_wt, name_wt, ifaceType_wt] $ do
put_payload bh
return (name_count, fs_count, r)
- where
- putAllTables _ [] act = do
- a <- act
- pure ([], a)
- putAllTables bh (x : xs) act = do
- (r, (res, a)) <- forwardPut bh (const $ putTable x bh) $ do
- putAllTables bh xs act
- pure (r : res, a)
+
+-- | Write all deduplication tables to disk after serialising the
+-- main payload.
+--
+-- Writes forward pointers to the deduplication tables before writing the payload
+-- to allow deserialisation *before* the payload is read again.
+putAllTables :: WriteBinHandle -> [WriterTable] -> IO b -> IO ([Int], b)
+putAllTables _ [] act = do
+ a <- act
+ pure ([], a)
+putAllTables bh (x : xs) act = do
+ (r, (res, a)) <- forwardPut bh (const $ putTable x bh) $ do
+ putAllTables bh xs act
+ pure (r : res, a)
-- | Initial ram buffer to allocate for writing interface files
initBinMemSize :: Int
@@ -335,6 +359,24 @@ Here, a visualisation of the table structure we currently have:
-- The symbol table
--
+initReadIfaceTypeTable :: ReaderUserData -> IO (ReaderTable IfaceType)
+initReadIfaceTypeTable ud = do
+ pure $
+ ReaderTable
+ { getTable = getGenericSymbolTable (\bh -> getIfaceType (setReaderUserData bh ud))
+ , mkReaderFromTable = \tbl -> mkReader (getGenericSymtab tbl)
+ }
+
+initWriteIfaceType :: IO (WriterTable, BinaryWriter IfaceType)
+initWriteIfaceType = do
+ sym_tab <- initGenericSymbolTable
+ pure
+ ( WriterTable
+ { putTable = putGenericSymbolTable sym_tab (lazyPut' putIfaceType)
+ }
+ , mkWriter $ putGenericSymTab sym_tab
+ )
+
initReadNameCachedBinary :: NameCache -> IO (ReaderTable Name)
initReadNameCachedBinary cache = do
=====================================
compiler/GHC/Iface/Decl.hs
=====================================
@@ -45,7 +45,6 @@ import GHC.Types.SrcLoc
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
-import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.BooleanFormula
@@ -147,7 +146,7 @@ tyConToIfaceDecl env tycon
| Just fam_flav <- famTyConFlav_maybe tycon
= ( tc_env1
, IfaceFamily { ifName = getName tycon,
- ifResVar = if_res_var,
+ ifResVar = mkIfLclName <$> if_res_var,
ifFamFlav = to_if_fam_flav fam_flav,
ifBinders = if_binders,
ifResKind = if_res_kind,
@@ -288,7 +287,7 @@ classToIfaceDecl env clas
ifClassCtxt = tidyToIfaceContext env1 sc_theta,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
- ifMinDef = toIfaceBooleanFormula $ fmap getOccFS (classMinimalDef clas)
+ ifMinDef = toIfaceBooleanFormula $ fmap (mkIfLclName . getOccFS) (classMinimalDef clas)
}
(env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
@@ -334,7 +333,7 @@ tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)
tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
tidyTyConBinders = mapAccumL tidyTyConBinder
-tidyTyVar :: TidyEnv -> TyVar -> FastString
+tidyTyVar :: TidyEnv -> TyVar -> IfLclName
tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
toIfaceBooleanFormula :: BooleanFormula IfLclName -> IfaceBooleanFormula
=====================================
compiler/GHC/Iface/Env.hs
=====================================
@@ -34,7 +34,6 @@ import GHC.Runtime.Context
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
-import GHC.Data.FastString
import GHC.Data.FastString.Env
import GHC.Types.Var
@@ -190,10 +189,10 @@ setNameModule (Just m) n =
************************************************************************
-}
-tcIfaceLclId :: FastString -> IfL Id
+tcIfaceLclId :: IfLclName -> IfL Id
tcIfaceLclId occ
= do { lcl <- getLclEnv
- ; case lookupFsEnv (if_id_env lcl) occ of
+ ; case lookupFsEnv (if_id_env lcl) (ifLclNameFS occ) of
Just ty_var -> return ty_var
Nothing -> failIfM $
vcat
@@ -209,10 +208,10 @@ extendIfaceIdEnv ids
in env { if_id_env = id_env' }
-tcIfaceTyVar :: FastString -> IfL TyVar
+tcIfaceTyVar :: IfLclName -> IfL TyVar
tcIfaceTyVar occ
= do { lcl <- getLclEnv
- ; case lookupFsEnv (if_tv_env lcl) occ of
+ ; case lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ) of
Just ty_var -> return ty_var
Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
}
@@ -220,15 +219,15 @@ tcIfaceTyVar occ
lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
lookupIfaceTyVar (occ, _)
= do { lcl <- getLclEnv
- ; return (lookupFsEnv (if_tv_env lcl) occ) }
+ ; return (lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ)) }
lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
lookupIfaceVar (IfaceIdBndr (_, occ, _))
= do { lcl <- getLclEnv
- ; return (lookupFsEnv (if_id_env lcl) occ) }
+ ; return (lookupFsEnv (if_id_env lcl) (ifLclNameFS occ)) }
lookupIfaceVar (IfaceTvBndr (occ, _))
= do { lcl <- getLclEnv
- ; return (lookupFsEnv (if_tv_env lcl) occ) }
+ ; return (lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ)) }
extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv tyvars
=====================================
compiler/GHC/Iface/Ext/Binary.hs
=====================================
@@ -38,22 +38,21 @@ import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.Word ( Word8, Word32 )
-import Control.Monad ( replicateM, when, forM_ )
+import Control.Monad ( replicateM, when, forM_, foldM )
import System.Directory ( createDirectoryIfMissing )
import System.FilePath ( takeDirectory )
import GHC.Iface.Ext.Types
+import GHC.Iface.Binary (initWriteIfaceType, putAllTables, initReadIfaceTypeTable)
+import GHC.Iface.Type (IfaceType)
+import System.IO.Unsafe (unsafeInterleaveIO)
+import qualified GHC.Utils.Binary as Binary
data HieSymbolTable = HieSymbolTable
{ hie_symtab_next :: !FastMutInt
, hie_symtab_map :: !(IORef (UniqFM Name (Int, HieName)))
}
-data HieDictionary = HieDictionary
- { hie_dict_next :: !FastMutInt -- The next index to use
- , hie_dict_map :: !(IORef (UniqFM FastString (Int,FastString))) -- indexed by FastString
- }
-
initBinMemSize :: Int
initBinMemSize = 1024*1024
@@ -84,58 +83,58 @@ writeHieFile hie_file_path hiefile = do
putBinLine bh0 $ BSC.pack $ show hieVersion
putBinLine bh0 $ ghcVersion
- -- remember where the dictionary pointer will go
- dict_p_p <- tellBinWriter bh0
- put_ bh0 dict_p_p
+ (fs_tbl, fs_w) <- initFastStringWriterTable
+ (name_tbl, name_w) <- initWriteNameTable
+ (iface_tbl, iface_w) <- initWriteIfaceType
- -- remember where the symbol table pointer will go
- symtab_p_p <- tellBinWriter bh0
- put_ bh0 symtab_p_p
+ let bh = setWriterUserData bh0 $ mkWriterUserData
+ [ mkSomeBinaryWriter @IfaceType iface_w
+ , mkSomeBinaryWriter @Name name_w
+ , mkSomeBinaryWriter @BindingName (simpleBindingNameWriter name_w)
+ , mkSomeBinaryWriter @FastString fs_w
+ ]
- -- Make some initial state
- symtab_next <- newFastMutInt 0
- symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName)))
- let hie_symtab = HieSymbolTable {
- hie_symtab_next = symtab_next,
- hie_symtab_map = symtab_map }
- dict_next_ref <- newFastMutInt 0
- dict_map_ref <- newIORef emptyUFM
- let hie_dict = HieDictionary {
- hie_dict_next = dict_next_ref,
- hie_dict_map = dict_map_ref }
-
- -- put the main thing
- let bh = setWriterUserData bh0
- $ newWriteState (putName hie_symtab)
- (putName hie_symtab)
- (putFastString hie_dict)
- put_ bh hiefile
-
- -- write the symtab pointer at the front of the file
- symtab_p <- tellBinWriter bh
- putAt bh symtab_p_p symtab_p
- seekBinWriter bh symtab_p
-
- -- write the symbol table itself
- symtab_next' <- readFastMutInt symtab_next
- symtab_map' <- readIORef symtab_map
- putSymbolTable bh symtab_next' symtab_map'
-
- -- write the dictionary pointer at the front of the file
- dict_p <- tellBinWriter bh
- putAt bh dict_p_p dict_p
- seekBinWriter bh dict_p
-
- -- write the dictionary itself
- dict_next <- readFastMutInt dict_next_ref
- dict_map <- readIORef dict_map_ref
- putDictionary bh dict_next dict_map
+ -- Discard number of written elements
+ -- Order matters! See Note [Iface Binary Serialiser Order]
+ _ <- putAllTables bh [fs_tbl, name_tbl, iface_tbl] $ do
+ put_ bh hiefile
-- and send the result to the file
createDirectoryIfMissing True (takeDirectory hie_file_path)
writeBinMem bh hie_file_path
return ()
+initWriteNameTable :: IO (WriterTable, BinaryWriter Name)
+initWriteNameTable = do
+ symtab_next <- newFastMutInt 0
+ symtab_map <- newIORef emptyUFM
+ let bin_symtab =
+ HieSymbolTable
+ { hie_symtab_next = symtab_next
+ , hie_symtab_map = symtab_map
+ }
+
+ let put_symtab bh = do
+ name_count <- readFastMutInt symtab_next
+ symtab_map <- readIORef symtab_map
+ putSymbolTable bh name_count symtab_map
+ pure name_count
+
+ return
+ ( WriterTable
+ { putTable = put_symtab
+ }
+ , mkWriter $ putName bin_symtab
+ )
+
+initReadNameTable :: NameCache -> IO (ReaderTable Name)
+initReadNameTable cache = do
+ return $
+ ReaderTable
+ { getTable = \bh -> getSymbolTable bh cache
+ , mkReaderFromTable = \tbl -> mkReader (getSymTabName tbl)
+ }
+
data HieFileResult
= HieFileResult
{ hie_file_result_version :: Integer
@@ -216,50 +215,32 @@ readHieFileHeader file bh0 = do
readHieFileContents :: ReadBinHandle -> NameCache -> IO HieFile
readHieFileContents bh0 name_cache = do
- dict <- get_dictionary bh0
+ bhRef <- newIORef (error "used too soon")
+ -- It is important this is passed to 'getTable'
+ ud <- unsafeInterleaveIO (readIORef bhRef)
+
+ fsReaderTable <- initFastStringReaderTable
+ nameReaderTable <- initReadNameTable name_cache
+ ifaceTypeReaderTable <- initReadIfaceTypeTable ud
+
-- read the symbol table so we are capable of reading the actual data
- bh1 <- do
- let bh1 = setReaderUserData bh0
- $ newReadState (error "getSymtabName")
- (getDictFastString dict)
- symtab <- get_symbol_table bh1
- let bh1' = setReaderUserData bh1
- $ newReadState (getSymTabName symtab)
- (getDictFastString dict)
- return bh1'
+ bh1 <-
+ foldM (\bh tblReader -> tblReader bh) bh0
+ [ get_dictionary fsReaderTable
+ , get_dictionary nameReaderTable
+ , get_dictionary ifaceTypeReaderTable
+ ]
-- load the actual data
get bh1
where
- get_dictionary bin_handle = do
- dict_p <- get bin_handle
- data_p <- tellBinReader bin_handle
- seekBinReader bin_handle dict_p
- dict <- getDictionary bin_handle
- seekBinReader bin_handle data_p
- return dict
-
- get_symbol_table bh1 = do
- symtab_p <- get bh1
- data_p' <- tellBinReader bh1
- seekBinReader bh1 symtab_p
- symtab <- getSymbolTable bh1 name_cache
- seekBinReader bh1 data_p'
- return symtab
-
-putFastString :: HieDictionary -> WriteBinHandle -> FastString -> IO ()
-putFastString HieDictionary { hie_dict_next = j_r,
- hie_dict_map = out_r} bh f
- = do
- out <- readIORef out_r
- let !unique = getUnique f
- case lookupUFM_Directly out unique of
- Just (j, _) -> put_ bh (fromIntegral j :: Word32)
- Nothing -> do
- j <- readFastMutInt j_r
- put_ bh (fromIntegral j :: Word32)
- writeFastMutInt j_r (j + 1)
- writeIORef out_r $! addToUFM_Directly out unique (j, f)
+ get_dictionary tbl bin_handle = do
+ fsTable <- Binary.forwardGet bin_handle (getTable tbl bin_handle)
+ let
+ fsReader = mkReaderFromTable tbl fsTable
+ bhFs = addReaderToUserData fsReader bin_handle
+ pure bhFs
+
putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
putSymbolTable bh next_off symtab = do
=====================================
compiler/GHC/Iface/Ext/Utils.hs
=====================================
@@ -162,15 +162,15 @@ getEvidenceTree refmap var = go emptyNameSet var
hieTypeToIface :: HieTypeFix -> IfaceType
hieTypeToIface = foldType go
where
- go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n
+ go (HTyVarTy n) = IfaceTyVar $ (mkIfLclName (occNameFS $ getOccName n))
go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
go (HLitTy l) = IfaceLitTy l
- go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)
+ go (HForAllTy ((n,k),af) t) = let b = (mkIfLclName (occNameFS $ getOccName n), k)
in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
go (HFunTy w a b) = IfaceFunTy visArgTypeLike w a b
go (HQualTy pred b) = IfaceFunTy invisArgTypeLike many_ty pred b
go (HCastTy a) = a
- go HCoercionTy = IfaceTyVar "<coercion type>"
+ go HCoercionTy = IfaceTyVar (mkIfLclName "<coercion type>")
go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
-- This isn't fully faithful - we can't produce the 'Inferred' case
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -1216,8 +1216,8 @@ addFingerprints hsc_env iface0
getOcc (IfLclTopBndr fs _ _ details) =
case details of
IfRecSelId { ifRecSelFirstCon = first_con }
- -> mkRecFieldOccFS (getOccFS first_con) fs
- _ -> mkVarOccFS fs
+ -> mkRecFieldOccFS (getOccFS first_con) (ifLclNameFS fs)
+ _ -> mkVarOccFS (ifLclNameFS fs)
binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) ()
binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs)
=====================================
compiler/GHC/Iface/Recomp/Binary.hs
=====================================
@@ -14,6 +14,7 @@ import GHC.Utils.Fingerprint
import GHC.Utils.Binary
import GHC.Types.Name
import GHC.Utils.Panic.Plain
+import GHC.Iface.Type (putIfaceType)
fingerprintBinMem :: WriteBinHandle -> IO Fingerprint
fingerprintBinMem bh = withBinBuffer bh f
@@ -34,8 +35,12 @@ computeFingerprint put_nonbinding_name a = do
put_ bh a
fingerprintBinMem bh
where
- set_user_data bh =
- setWriterUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS
+ set_user_data bh = setWriterUserData bh $ mkWriterUserData
+ [ mkSomeBinaryWriter $ mkWriter putIfaceType
+ , mkSomeBinaryWriter $ mkWriter put_nonbinding_name
+ , mkSomeBinaryWriter $ simpleBindingNameWriter $ mkWriter putNameLiterally
+ , mkSomeBinaryWriter $ mkWriter putFS
+ ]
-- | Used when we want to fingerprint a structure without depending on the
-- fingerprints of external Names that it refers to.
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -632,6 +632,7 @@ data IfaceExpr
| IfaceFCall ForeignCall IfaceType
| IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E
+
data IfaceTickish
= IfaceHpcTick Module Int -- from HpcTick x
| IfaceSCC CostCentre Bool Bool -- from ProfNote
@@ -1026,7 +1027,7 @@ pprIfaceDecl ss (IfaceClass { ifName = clas
pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions
text "{-# MINIMAL" <+>
pprBooleanFormula
- (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+>
+ (\_ def -> cparen (isLexSym def) (ppr def)) 0 (fmap ifLclNameFS minDef) <+>
text "#-}"
-- See Note [Suppressing binder signatures] in GHC.Iface.Type
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -10,7 +10,8 @@ This module defines interface types and binders
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Iface.Type (
- IfExtName, IfLclName,
+ IfExtName,
+ IfLclName(..), mkIfLclName, ifLclNameFS,
IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
IfaceMCoercion(..),
@@ -32,6 +33,8 @@ module GHC.Iface.Type (
ifForAllBndrVar, ifForAllBndrName, ifaceBndrName,
ifTyConBinderVar, ifTyConBinderName,
+ -- Binary utilities
+ putIfaceType, getIfaceType,
-- Equality testing
isIfaceLiftedTypeKind,
@@ -90,9 +93,11 @@ import GHC.Utils.Panic
import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar )
import Control.DeepSeq
+import Data.Proxy
import Control.Monad ((<$!>))
+import Control.Arrow (first)
import qualified Data.Semigroup as Semi
-import Data.Maybe( isJust )
+import Data.Maybe (isJust)
{-
************************************************************************
@@ -102,7 +107,16 @@ import Data.Maybe( isJust )
************************************************************************
-}
-type IfLclName = FastString -- A local name in iface syntax
+-- | A local name in iface syntax
+newtype IfLclName = IfLclName
+ { getIfLclName :: LexicalFastString
+ } deriving (Eq, Ord, Show)
+
+ifLclNameFS :: IfLclName -> FastString
+ifLclNameFS = getLexicalFastString . getIfLclName
+
+mkIfLclName :: FastString -> IfLclName
+mkIfLclName = IfLclName . LexicalFastString
type IfExtName = Name -- An External or WiredIn Name can appear in Iface syntax
-- (However Internal or System Names never should)
@@ -110,6 +124,8 @@ type IfExtName = Name -- An External or WiredIn Name can appear in Iface synta
data IfaceBndr -- Local (non-top-level) binders
= IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr
| IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr
+ deriving (Eq, Ord)
+
type IfaceIdBndr = (IfaceType, IfLclName, IfaceType)
type IfaceTvBndr = (IfLclName, IfaceKind)
@@ -178,6 +194,7 @@ data IfaceType
-- In an experiment, removing IfaceTupleTy resulted in a 0.75% regression
-- in interface file size (in GHC's boot libraries).
-- See !3987.
+ deriving (Eq, Ord)
type IfaceMult = IfaceType
@@ -186,9 +203,9 @@ type IfaceContext = [IfacePredType]
data IfaceTyLit
= IfaceNumTyLit Integer
- | IfaceStrTyLit FastString
+ | IfaceStrTyLit LexicalFastString
| IfaceCharTyLit Char
- deriving (Eq)
+ deriving (Eq, Ord)
type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis
type IfaceForAllBndr = VarBndr IfaceBndr ForAllTyFlag
@@ -230,6 +247,7 @@ data IfaceAppArgs
-- arguments in @{...}.
IfaceAppArgs -- The rest of the arguments
+ deriving (Eq, Ord)
instance Semi.Semigroup IfaceAppArgs where
IA_Nil <> xs = xs
@@ -256,7 +274,7 @@ data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName
-- See Note [Sharing IfaceTyConInfo] for why
-- sharing is so important for 'IfaceTyConInfo'.
}
- deriving (Eq)
+ deriving (Eq, Ord)
-- | The various types of TyCons which have special, built-in syntax.
data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon
@@ -276,7 +294,7 @@ data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon
-- that is actually being applied to two types
-- of the same kind. This affects pretty-printing
-- only: see Note [Equality predicates in IfaceType]
- deriving (Eq)
+ deriving (Eq, Ord)
instance Outputable IfaceTyConSort where
ppr IfaceNormalTyCon = text "normal"
@@ -370,7 +388,7 @@ data IfaceTyConInfo -- Used only to guide pretty-printing
-- should be printed as 'D to distinguish it from
-- an existing type constructor D.
, ifaceTyConSort :: IfaceTyConSort }
- deriving (Eq)
+ deriving (Eq, Ord)
-- | This smart constructor allows sharing of the two most common
-- cases. See Note [Sharing IfaceTyConInfo]
@@ -420,7 +438,7 @@ This one change leads to an 15% reduction in residency for GHC when embedding
data IfaceMCoercion
= IfaceMRefl
- | IfaceMCo IfaceCoercion
+ | IfaceMCo IfaceCoercion deriving (Eq, Ord)
data IfaceCoercion
= IfaceReflCo IfaceType
@@ -445,11 +463,13 @@ data IfaceCoercion
| IfaceSubCo IfaceCoercion
| IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType]
| IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion]
+ deriving (Eq, Ord)
data IfaceUnivCoProv
= IfacePhantomProv IfaceCoercion
| IfaceProofIrrelProv IfaceCoercion
| IfacePluginProv String
+ deriving (Eq, Ord)
{- Note [Holes in IfaceCoercion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -621,11 +641,11 @@ type IfaceTySubst = FastStringEnv IfaceType -- Note [Substitution on IfaceType]
mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst
-- See Note [Substitution on IfaceType]
-mkIfaceTySubst eq_spec = mkFsEnv eq_spec
+mkIfaceTySubst eq_spec = mkFsEnv (map (first ifLclNameFS) eq_spec)
inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool
-- See Note [Substitution on IfaceType]
-inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs)
+inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst (ifLclNameFS fs))
substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
-- See Note [Substitution on IfaceType]
@@ -681,7 +701,7 @@ substIfaceAppArgs env args
substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
substIfaceTyVar env tv
- | Just ty <- lookupFsEnv env tv = ty
+ | Just ty <- lookupFsEnv env (ifLclNameFS tv) = ty
| otherwise = IfaceTyVar tv
@@ -1190,7 +1210,7 @@ defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv True ty
| isInvisibleForAllTyFlag argf -- Don't default *visible* quantification
-- or we get the mess in #13963
, Just substituted_ty <- check_substitution var_kind
- = let subs' = extendFsEnv subs var substituted_ty
+ = let subs' = extendFsEnv subs (ifLclNameFS var) substituted_ty
-- Record that we should replace it with LiftedRep/Lifted/Many,
-- and recurse, discarding the forall
in go subs' True ty
@@ -1198,7 +1218,7 @@ defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv True ty
go subs rank1 (IfaceForAllTy bndr ty)
= IfaceForAllTy (go_ifacebndr subs bndr) (go subs rank1 ty)
- go subs _ ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of
+ go subs _ ty@(IfaceTyVar tv) = case lookupFsEnv subs (ifLclNameFS tv) of
Just s -> s
Nothing -> ty
@@ -1626,7 +1646,7 @@ pprTyTcApp ctxt_prec tc tys =
, IA_Arg (IfaceLitTy (IfaceStrTyLit n))
Required (IA_Arg ty Required IA_Nil) <- tys
-> maybeParen ctxt_prec funPrec
- $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
+ $ char '?' <> ftext (getLexicalFastString n) <> text "::" <> ppr_ty topPrec ty
| IfaceTupleTyCon arity sort <- ifaceTyConSort info
, not debug
@@ -2014,6 +2034,9 @@ pprIfaceUnivCoProv (IfacePluginProv s)
= text "plugin" <+> doubleQuotes (text s)
-------------------
+instance Outputable IfLclName where
+ ppr = ppr . ifLclNameFS
+
instance Outputable IfaceTyCon where
ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
@@ -2171,38 +2194,47 @@ ppr_parend_preds :: [IfacePredType] -> SDoc
ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds)))
instance Binary IfaceType where
- put_ _ (IfaceFreeTyVar tv)
- = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
-
- put_ bh (IfaceForAllTy aa ab) = do
- putByte bh 0
- put_ bh aa
- put_ bh ab
- put_ bh (IfaceTyVar ad) = do
- putByte bh 1
- put_ bh ad
- put_ bh (IfaceAppTy ae af) = do
- putByte bh 2
- put_ bh ae
- put_ bh af
- put_ bh (IfaceFunTy af aw ag ah) = do
- putByte bh 3
- put_ bh af
- put_ bh aw
- put_ bh ag
- put_ bh ah
- put_ bh (IfaceTyConApp tc tys)
- = do { putByte bh 5; put_ bh tc; put_ bh tys }
- put_ bh (IfaceCastTy a b)
- = do { putByte bh 6; put_ bh a; put_ bh b }
- put_ bh (IfaceCoercionTy a)
- = do { putByte bh 7; put_ bh a }
- put_ bh (IfaceTupleTy s i tys)
- = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
- put_ bh (IfaceLitTy n)
- = do { putByte bh 9; put_ bh n }
-
- get bh = do
+ put_ bh tyCon = case findUserDataWriter Proxy bh of
+ tbl -> putEntry tbl bh tyCon
+
+ get bh = case findUserDataReader Proxy bh of
+ tbl -> getEntry tbl bh
+
+
+putIfaceType :: WriteBinHandle -> IfaceType -> IO ()
+putIfaceType _ (IfaceFreeTyVar tv)
+ = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
+
+putIfaceType bh (IfaceForAllTy aa ab) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh ab
+putIfaceType bh (IfaceTyVar ad) = do
+ putByte bh 1
+ put_ bh ad
+putIfaceType bh (IfaceAppTy ae af) = do
+ putByte bh 2
+ put_ bh ae
+ put_ bh af
+putIfaceType bh (IfaceFunTy af aw ag ah) = do
+ putByte bh 3
+ put_ bh af
+ put_ bh aw
+ put_ bh ag
+ put_ bh ah
+putIfaceType bh (IfaceTyConApp tc tys)
+ = do { putByte bh 5; put_ bh tc; put_ bh tys }
+putIfaceType bh (IfaceCastTy a b)
+ = do { putByte bh 6; put_ bh a; put_ bh b }
+putIfaceType bh (IfaceCoercionTy a)
+ = do { putByte bh 7; put_ bh a }
+putIfaceType bh (IfaceTupleTy s i tys)
+ = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
+putIfaceType bh (IfaceLitTy n)
+ = do { putByte bh 9; put_ bh n }
+
+getIfaceType :: HasCallStack => ReadBinHandle -> IO IfaceType
+getIfaceType bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
@@ -2230,6 +2262,13 @@ instance Binary IfaceType where
_ -> do n <- get bh
return (IfaceLitTy n)
+instance Binary IfLclName where
+ put_ bh = put_ bh . ifLclNameFS
+
+ get bh = do
+ fs <- get bh
+ pure $ IfLclName $ LexicalFastString fs
+
instance Binary IfaceMCoercion where
put_ bh IfaceMRefl =
putByte bh 1
@@ -2475,6 +2514,9 @@ instance NFData IfaceTyConSort where
IfaceSumTyCon arity -> rnf arity
IfaceEqualityTyCon -> ()
+instance NFData IfLclName where
+ rnf (IfLclName lfs) = rnf lfs
+
instance NFData IfaceTyConInfo where
rnf (IfaceTyConInfo f s) = f `seq` rnf s
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -733,7 +733,7 @@ tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
{ res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop]
; rhs <- forkM (mk_doc tc_name) $
tc_fam_flav tc_name fam_flav
- ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
+ ; res_name <- traverse (newIfaceName . mkTyVarOccFS . ifLclNameFS) res
; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj
; return (ATyCon tycon) }
where
@@ -782,7 +782,7 @@ tc_iface_decl _parent ignore_prags
; fds <- mapM tc_fd rdr_fds
; traceIf (text "tc-iface-class3" <+> ppr tc_name)
; let mindef_occ = fromIfaceBooleanFormula if_mindef
- ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
+ ; mindef <- traverse (lookupIfaceTop . mkVarOccFS . ifLclNameFS) mindef_occ
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_name)
@@ -936,8 +936,8 @@ mk_top_id (IfLclTopBndr raw_name iface_type info details) = do
; let occ = case details' of
RecSelId { sel_tycon = parent }
-> let con_fs = getOccFS $ recSelFirstConName parent
- in mkRecFieldOccFS con_fs raw_name
- _ -> mkVarOccFS raw_name
+ in mkRecFieldOccFS con_fs (ifLclNameFS raw_name)
+ _ -> mkVarOccFS (ifLclNameFS raw_name)
; name <- newIfaceName occ }
info' <- tcIdInfo False TopLevel name ty info
let new_id = mkGlobalId details' name ty info'
@@ -1441,7 +1441,7 @@ tcIfaceCtxt sts = mapM tcIfaceType sts
-----------------------------------------
tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
-tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
+tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit (getLexicalFastString n))
tcIfaceTyLit (IfaceCharTyLit n) = return (CharTyLit n)
{-
@@ -1485,7 +1485,7 @@ tcIfaceCo = go
go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)
go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c)
- go_var :: FastString -> IfL CoVar
+ go_var :: IfLclName -> IfL CoVar
go_var = tcIfaceLclId
tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
@@ -1561,7 +1561,7 @@ tcIfaceExpr (IfaceECase scrut ty)
tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
scrut' <- tcIfaceExpr scrut
- case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
+ case_bndr_name <- newIfaceName (mkVarOccFS (ifLclNameFS case_bndr))
let
scrut_ty = exprType scrut'
case_mult = ManyTy
@@ -1580,7 +1580,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
return (Case scrut' case_bndr' (coreAltsType alts') alts')
tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
- = do { name <- newIfaceName (mkVarOccFS fs)
+ = do { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs))
; ty' <- tcIfaceType ty
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
NotTopLevel name ty' info
@@ -1598,7 +1598,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
; return (Let (Rec pairs') body') } }
where
tc_rec_bndr (IfLetBndr fs ty _ ji)
- = do { name <- newIfaceName (mkVarOccFS fs)
+ = do { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs))
; ty' <- tcIfaceType ty
; return (mkLocalId name ManyTy ty' `asJoinId_maybe` ji) }
tc_pair (IfLetBndr _ _ info _, rhs) id
@@ -1655,12 +1655,12 @@ tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceAlt (IfaceDataAlt data_occ) arg_st
(failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
; tcIfaceDataAlt mult con inst_tys arg_strs rhs }
-tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr
+tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [IfLclName] -> IfaceExpr
-> IfL CoreAlt
tcIfaceDataAlt mult con inst_tys arg_strs rhs
= do { uniqs <- getUniquesM
; let (ex_tvs, arg_ids)
- = dataConRepFSInstPat arg_strs uniqs mult con inst_tys
+ = dataConRepFSInstPat (map ifLclNameFS arg_strs) uniqs mult con inst_tys
; rhs' <- extendIfaceEnvs ex_tvs $
extendIfaceIdEnv arg_ids $
@@ -2031,7 +2031,7 @@ tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule
-- - axioms for type-level literals (Nat and Symbol),
-- enumerated in typeNatCoAxiomRules
tcIfaceCoAxiomRule n
- | Just ax <- lookupUFM typeNatCoAxiomRules n
+ | Just ax <- lookupUFM typeNatCoAxiomRules (ifLclNameFS n)
= return ax
| otherwise
= pprPanic "tcIfaceCoAxiomRule" (ppr n)
@@ -2075,7 +2075,7 @@ tcIfaceImplicit n = do
bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
bindIfaceId (w, fs, ty) thing_inside
- = do { name <- newIfaceName (mkVarOccFS fs)
+ = do { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs))
; ty' <- tcIfaceType ty
; w' <- tcIfaceType w
; let id = mkLocalIdOrCoVar name w' ty'
@@ -2118,7 +2118,7 @@ bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
- = do { name <- newIfaceName (mkTyVarOccFS occ)
+ = do { name <- newIfaceName (mkTyVarOccFS (ifLclNameFS occ))
; tyvar <- mk_iface_tyvar name kind
; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -314,7 +314,7 @@ putObject bh mod_name deps os = do
put_ bh (moduleNameString mod_name)
(fs_tbl, fs_writer) <- initFastStringWriterTable
- let bh_fs = addWriterToUserData (mkSomeBinaryWriter fs_writer) bh
+ let bh_fs = addWriterToUserData fs_writer bh
forwardPut_ bh (const (putTable fs_tbl bh_fs)) $ do
put_ bh_fs deps
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -148,7 +148,7 @@ import qualified Data.Semigroup as Semi
********************************************************************* -}
data LeftOrRight = CLeft | CRight
- deriving( Eq, Data )
+ deriving( Eq, Data, Ord )
pickLR :: LeftOrRight -> (a,a) -> a
pickLR CLeft (l,_) = l
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -720,7 +720,7 @@ Currently there are nine different uses of 'VarBndr':
data VarBndr var argf = Bndr var argf
-- See Note [The VarBndr type and its uses]
- deriving( Data )
+ deriving( Data, Eq, Ord)
-- | Variable Binder
--
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -65,6 +65,8 @@ module GHC.Utils.Binary
-- * Lazy Binary I/O
lazyGet,
lazyPut,
+ lazyGet',
+ lazyPut',
lazyGetMaybe,
lazyPutMaybe,
@@ -87,10 +89,17 @@ module GHC.Utils.Binary
initFastStringReaderTable, initFastStringWriterTable,
putDictionary, getDictionary, putFS,
FSTable(..), getDictFastString, putDictFastString,
+ -- * Generic deduplication table
+ GenericSymbolTable(..),
+ initGenericSymbolTable,
+ getGenericSymtab, putGenericSymTab,
+ getGenericSymbolTable, putGenericSymbolTable,
-- * Newtype wrappers
BinSpan(..), BinSrcSpan(..), BinLocated(..),
-- * Newtypes for types that have canonically more than one valid encoding
BindingName(..),
+ simpleBindingNameWriter,
+ simpleBindingNameReader,
) where
import GHC.Prelude
@@ -103,11 +112,11 @@ import GHC.Utils.Panic.Plain
import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
import GHC.Utils.Fingerprint
-import GHC.Utils.Misc (HasCallStack)
import GHC.Types.SrcLoc
import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
import GHC.Utils.Outputable( JoinPointHood(..) )
+import GHC.Utils.Misc ( HasCallStack )
import Control.DeepSeq
import Control.Monad ( when, (<$!>), unless, forM_, void )
@@ -127,7 +136,7 @@ import qualified Data.Map.Strict as Map
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.Time
-import Data.List (unfoldr)
+import Data.List (sortOn, unfoldr)
import Data.Typeable
import System.IO as IO
import System.IO.Unsafe ( unsafeInterleaveIO )
@@ -230,22 +239,26 @@ setReaderUserData bh us = bh { rbm_userData = us }
-- | Add 'SomeBinaryReader' as a known binary decoder.
-- If a 'BinaryReader' for the associated type already exists in 'ReaderUserData',
-- it is overwritten.
-addReaderToUserData :: SomeBinaryReader -> ReadBinHandle -> ReadBinHandle
-addReaderToUserData cache@(SomeBinaryReader typRep _) bh = bh
+addReaderToUserData :: Typeable a => BinaryReader a -> ReadBinHandle -> ReadBinHandle
+addReaderToUserData reader bh = bh
{ rbm_userData = (rbm_userData bh)
{ ud_reader_data = Map.insert typRep cache (ud_reader_data (rbm_userData bh))
}
}
+ where
+ cache@(SomeBinaryReader typRep _) = mkSomeBinaryReader reader
-- | Add 'SomeBinaryWriter' as a known binary encoder.
-- If a 'BinaryWriter' for the associated type already exists in 'WriterUserData',
-- it is overwritten.
-addWriterToUserData :: SomeBinaryWriter -> WriteBinHandle -> WriteBinHandle
-addWriterToUserData cache@(SomeBinaryWriter typRep _) bh = bh
+addWriterToUserData :: Typeable a => BinaryWriter a -> WriteBinHandle -> WriteBinHandle
+addWriterToUserData writer bh = bh
{ wbm_userData = (wbm_userData bh)
{ ud_writer_data = Map.insert typRep cache (ud_writer_data (wbm_userData bh))
}
}
+ where
+ cache@(SomeBinaryWriter typRep _) = mkSomeBinaryWriter writer
-- | Get access to the underlying buffer.
withBinBuffer :: WriteBinHandle -> (ByteString -> IO a) -> IO a
@@ -1102,24 +1115,35 @@ forwardGet bh get_A = do
-- Lazy reading/writing
lazyPut :: Binary a => WriteBinHandle -> a -> IO ()
-lazyPut bh a = do
+lazyPut = lazyPut' put_
+
+lazyGet :: Binary a => ReadBinHandle -> IO a
+lazyGet = lazyGet' Nothing (\_ -> get)
+
+lazyPut' :: HasCallStack => (WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO ()
+lazyPut' f bh a = do
-- output the obj with a ptr to skip over it:
pre_a <- tellBinWriter bh
put_ bh pre_a -- save a slot for the ptr
- put_ bh a -- dump the object
+ f bh a -- dump the object
q <- tellBinWriter bh -- q = ptr to after object
putAt bh pre_a q -- fill in slot before a with ptr to q
seekBinWriter bh q -- finally carry on writing at q
-lazyGet :: Binary a => ReadBinHandle -> IO a
-lazyGet bh = do
+lazyGet' :: HasCallStack => Maybe (IORef ReadBinHandle) -> (Bin () -> ReadBinHandle -> IO a) -> ReadBinHandle -> IO a
+lazyGet' mbh f bh = do
p <- get bh -- a BinPtr
p_a <- tellBinReader bh
+ -- Do this before to avoid retaining reference to old BH inside the unsafeInterleaveIO.
+ let !get_inner_bh = maybe (pure bh) readIORef mbh
a <- unsafeInterleaveIO $ do
- -- NB: Use a fresh off_r variable in the child thread, for thread
+ -- NB: Use a fresh rbm_off_r variable in the child thread, for thread
-- safety.
+ inner_bh <- get_inner_bh
off_r <- newFastMutInt 0
- getAt bh { rbm_off_r = off_r } p_a
+ let bh' = inner_bh { rbm_off_r = off_r }
+ seekBinReader bh' p_a
+ f p bh'
seekBinReader bh p -- skip over the object for now
return a
@@ -1173,6 +1197,12 @@ lazyGetMaybe bh = do
newtype BindingName = BindingName { getBindingName :: Name }
deriving ( Eq )
+simpleBindingNameWriter :: BinaryWriter Name -> BinaryWriter BindingName
+simpleBindingNameWriter = coerce
+
+simpleBindingNameReader :: BinaryReader Name -> BinaryReader BindingName
+simpleBindingNameReader = coerce
+
-- | Existential for 'BinaryWriter' with a type witness.
data SomeBinaryWriter = forall a . SomeBinaryWriter TypeRep (BinaryWriter a)
@@ -1313,6 +1343,80 @@ data WriterTable = WriterTable
{ putTable :: WriteBinHandle -> IO Int
}
+-- ----------------------------------------------------------------------------
+-- Common data structures for constructing and maintaining lookup tables for
+-- binary serialisation and deserialisation.
+-- ----------------------------------------------------------------------------
+
+data GenericSymbolTable a = GenericSymbolTable
+ { gen_symtab_next :: !FastMutInt
+ -- ^ The next index to use
+ , gen_symtab_map :: !(IORef (Map.Map a Int))
+ -- ^ Given a symbol, find the symbol
+ }
+
+initGenericSymbolTable :: IO (GenericSymbolTable a)
+initGenericSymbolTable = do
+ symtab_next <- newFastMutInt 0
+ symtab_map <- newIORef Map.empty
+ pure $ GenericSymbolTable
+ { gen_symtab_next = symtab_next
+ , gen_symtab_map = symtab_map
+ }
+
+putGenericSymbolTable :: forall a. GenericSymbolTable a -> (WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> IO Int
+putGenericSymbolTable gen_sym_tab serialiser bh = do
+ putGenericSymbolTable bh
+ where
+ symtab_map = gen_symtab_map gen_sym_tab
+ symtab_next = gen_symtab_next gen_sym_tab
+ putGenericSymbolTable :: HasCallStack => WriteBinHandle -> IO Int
+ putGenericSymbolTable bh = do
+ let loop bound = do
+ d <- readIORef symtab_map
+ table_count <- readFastMutInt symtab_next
+ let vs = sortOn fst [(b, a) | (a,b) <- Map.toList d, b >= bound]
+ case vs of
+ [] -> return table_count
+ todo -> do
+ mapM_ (\n -> serialiser bh n) (map snd todo)
+ loop table_count
+ snd <$>
+ (forwardPut bh (const $ readFastMutInt symtab_next >>= put_ bh) $
+ loop 0)
+
+getGenericSymbolTable :: forall a. (ReadBinHandle -> IO a) -> ReadBinHandle -> IO (SymbolTable a)
+getGenericSymbolTable deserialiser bh = do
+ sz <- forwardGet bh (get bh) :: IO Int
+ mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a)
+ -- Using lazyPut/lazyGet is quite space inefficient as each usage will allocate a large closure
+ -- (6 arguments-ish).
+ forM_ [0..(sz-1)] $ \i -> do
+ f <- lazyGet' Nothing (\_ -> deserialiser) bh
+ -- f <- deserialiser bh
+ writeArray mut_arr i f
+ unsafeFreeze mut_arr
+
+putGenericSymTab :: (Ord a, Binary a) => GenericSymbolTable a -> WriteBinHandle -> a -> IO ()
+putGenericSymTab GenericSymbolTable{
+ gen_symtab_map = symtab_map_ref,
+ gen_symtab_next = symtab_next }
+ bh val = do
+ symtab_map <- readIORef symtab_map_ref
+ case Map.lookup val symtab_map of
+ Just off -> put_ bh (fromIntegral off :: Word32)
+ Nothing -> do
+ off <- readFastMutInt symtab_next
+ writeFastMutInt symtab_next (off+1)
+ writeIORef symtab_map_ref
+ $! Map.insert val off symtab_map
+ put_ bh (fromIntegral off :: Word32)
+
+getGenericSymtab :: Binary a => SymbolTable a -> ReadBinHandle -> IO a
+getGenericSymtab symtab bh = do
+ i :: Word32 <- get bh
+ return $! symtab ! fromIntegral i
+
---------------------------------------------------------
-- The Dictionary
---------------------------------------------------------
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -78,6 +78,7 @@ import Data.Eq
import Data.Bool
import Data.Char
import Prelude (Integer, length)
+import Data.Ord (Ord)
{-
************************************************************************
@@ -91,7 +92,7 @@ import Prelude (Integer, length)
data PromotionFlag
= NotPromoted
| IsPromoted
- deriving ( Eq, Data )
+ deriving ( Eq, Data, Ord )
isPromoted :: PromotionFlag -> Bool
isPromoted IsPromoted = True
=====================================
compiler/Language/Haskell/Syntax/Type.hs-boot
=====================================
@@ -2,6 +2,7 @@ module Language.Haskell.Syntax.Type where
import Data.Bool
import Data.Eq
+import Data.Ord
{-
************************************************************************
@@ -17,5 +18,6 @@ data PromotionFlag
| IsPromoted
instance Eq PromotionFlag
+instance Ord PromotionFlag
isPromoted :: PromotionFlag -> Bool
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit edf742131e272fc29c6d6eae549b0fe37eea11b9
+Subproject commit e095ca841b89b5958376768d18ae156b7a413da0
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/17010aed403c3388411e15efb585d81bb3c30e3c...fba95eb0166ee5660fc92e603decf83ce381bf64
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/17010aed403c3388411e15efb585d81bb3c30e3c...fba95eb0166ee5660fc92e603decf83ce381bf64
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/20240408/6762328c/attachment-0001.html>
More information about the ghc-commits
mailing list