[Git][ghc/ghc][wip/mpickering-hannes] 2 commits: working
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Tue Mar 19 17:14:26 UTC 2024
Matthew Pickering pushed to branch wip/mpickering-hannes at Glasgow Haskell Compiler / GHC
Commits:
806e8243 by Matthew Pickering at 2024-03-19T16:31:08+00:00
working
- - - - -
9f3dddd5 by Fendor at 2024-03-19T17:13:52+00:00
Compact serialisation of IfaceAppArgs
In #24563, we identified that IfaceAppArgs serialisation tags each
cons cell element with a discriminator byte. These bytes add up
quickly, blowing up interface files considerably when
'-fwrite-if-simplified-core' is enabled.
We compact the serialisation by writing out the length of
'IfaceAppArgs', followed by serialising the elements directly without
any discriminator byte.
This improvement can decrease the size of some interface files by up
to 35%.
- - - - -
18 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/Types/Basic.hs
- compiler/GHC/Types/Var.hs
- compiler/GHC/Utils/Binary.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
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 = ( LexicalFastString (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)
+ , LexicalFastString (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 -> LexicalFastString
+toIfaceTyVar = LexicalFastString . occNameFS . getOccName
-toIfaceCoVar :: CoVar -> FastString
-toIfaceCoVar = occNameFS . getOccName
+toIfaceCoVar :: CoVar -> LexicalFastString
+toIfaceCoVar = LexicalFastString . 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 (LexicalFastString (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 (LexicalFastString (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 (LexicalFastString (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) (LexicalFastString (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 (LexicalFastString . 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 (LexicalFastString (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
=====================================
@@ -1,10 +1,10 @@
-{-# LANGUAGE BinaryLiterals, ScopedTypeVariables #-}
+{-# LANGUAGE BinaryLiterals, ScopedTypeVariables, RecursiveDo #-}
--
-- (c) The University of Glasgow 2002-2006
--
-{-# OPTIONS_GHC -O2 #-}
+{-# OPTIONS_GHC -O0 -ddump-simpl -ddump-to-file #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected
@@ -180,7 +180,7 @@ getWithUserData name_cache bh = do
-- (getDictFastString dict)
data ReadIfaceTable out = ReadIfaceTable
- { getTable :: HasCallStack => BinHandle -> IO out
+ { getTable :: HasCallStack => IORef BinHandle -> BinHandle -> IO out
}
data WriteIfaceTable = WriteIfaceTable
@@ -191,27 +191,38 @@ getTables' :: HasCallStack => NameCache -> BinHandle -> IO BinHandle
getTables' name_cache bh = do
fsCache <- initReadFsCachedBinary
nameCache <- initReadNameCachedBinary name_cache
- ifaceCache <- initReadIfaceTyConTable
+-- ifaceCache <- initReadIfaceTyConTable
+ ifaceTypeCache <- initReadIfaceTypeTable
+ bhRef <- newIORef (error "used too soon")
-- Read the dictionary
-- The next word in the file is a pointer to where the dictionary is
-- (probably at the end of the file)
- dict <- Binary.forwardGet bh (getTable fsCache bh)
+ dict <- Binary.forwardGet bh (getTable fsCache bhRef bh)
let
fsDecoder = mkReader $ getDictFastString dict
bh_fs = addDecoder (mkCache (Proxy @FastString) fsDecoder) bh
- symtab <- Binary.forwardGet bh_fs (getTable nameCache bh_fs)
+ symtab <- Binary.forwardGet bh_fs (getTable nameCache bhRef bh_fs)
let nameCache' = mkReader $ getSymtabName symtab
bh_name = addDecoder (mkCache (Proxy :: Proxy Name) nameCache') bh_fs
- ifaceSymTab <- Binary.forwardGet bh_fs (getTable ifaceCache bh_name)
+-- ifaceSymTab <- Binary.forwardGet bh_fs (getTable ifaceCache bh_name)
+
+-- let ifaceDecoder = mkReader $ getGenericSymtab ifaceSymTab
+
+-- bh_name2 = addDecoder (mkCache (Proxy :: Proxy IfaceTyCon) ifaceDecoder) bh_name
+
+ pprTraceM "getTables" empty
+ ifaceSymTab2 <- Binary.forwardGet bh_name (getTable ifaceTypeCache bhRef bh_name)
+ let ifaceDecoder2 = mkReader $ getGenericSymtab ifaceSymTab2
+ let bh_type = addDecoder (mkCache (Proxy :: Proxy IfaceType) (pprTrace "forced" (text "f") ifaceDecoder2)) bh_name
+ writeIORef bhRef bh_type
+ return bh_type
- let ifaceDecoder = mkReader $ getGenericSymtab ifaceSymTab
- pure $ addDecoder (mkCache (Proxy :: Proxy IfaceTyCon) ifaceDecoder) bh_name
-- | Write an interface file
writeBinIface :: HasCallStack => Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()
@@ -269,7 +280,7 @@ initReadFsCachedBinary :: (HasCallStack) => IO (ReadIfaceTable (SymbolTable Fast
initReadFsCachedBinary = do
return $
ReadIfaceTable
- { getTable = getDictionary
+ { getTable = \_ -> getDictionary
}
initWriteFsTable :: (HasCallStack) => IO (WriteIfaceTable, CachedBinary FastString)
@@ -298,7 +309,7 @@ initReadNameCachedBinary :: (HasCallStack) => NameCache -> IO (ReadIfaceTable (S
initReadNameCachedBinary cache = do
return $
ReadIfaceTable
- { getTable = \bh -> getSymbolTable bh cache
+ { getTable = \_ bh -> getSymbolTable bh cache
}
initWriteNameTable :: (HasCallStack) => IO (WriteIfaceTable, CachedBinary Name)
@@ -331,6 +342,14 @@ initReadIfaceTyConTable = do
{ getTable = getGenericSymbolTable getIfaceTyCon
}
+initReadIfaceTypeTable :: HasCallStack => IO (ReadIfaceTable (SymbolTable IfaceType))
+initReadIfaceTypeTable = do
+ pure $
+ ReadIfaceTable
+ { getTable = getGenericSymbolTable getIfaceType
+ }
+
+
initWriteIfaceTyConTable :: HasCallStack => IO (WriteIfaceTable, CachedBinary IfaceTyCon)
initWriteIfaceTyConTable = do
sym_tab <- initGenericSymbolTable
@@ -341,6 +360,16 @@ initWriteIfaceTyConTable = do
, mkWriter $ putGenericSymTab sym_tab
)
+initWriteIfaceType :: HasCallStack => IO (WriteIfaceTable, CachedBinary IfaceType)
+initWriteIfaceType = do
+ sym_tab <- initGenericSymbolTable
+ pure
+ ( WriteIfaceTable
+ { putTable = putGenericSymbolTable sym_tab putIfaceType
+ }
+ , mkWriter $ putGenericSymTab sym_tab
+ )
+
-- | Write name/symbol tables
--
-- 1. setup the given BinHandle with Name/FastString table handling
@@ -392,20 +421,23 @@ putWithTables' :: HasCallStack => BinHandle -> (BinHandle -> IO b) -> IO (Int,In
putWithTables' bh' put_payload = do
(fsTbl, fsWriter) <- initWriteFsTable
(nameTbl, nameWriter) <- initWriteNameTable
- (ifaceTyConTbl, ifaceTyConWriter) <- initWriteIfaceTyConTable
+-- (ifaceTyConTbl, ifaceTyConWriter) <- initWriteIfaceTyConTable
+ (ifaceTypeTbl, ifaceTypeWriter) <- initWriteIfaceType
let userData = withMyUserData
[ mkCache (Proxy @FastString) fsWriter
, mkCache (Proxy @Name) nameWriter
- , mkCache (Proxy @IfaceTyCon) ifaceTyConWriter
+ -- , mkCache (Proxy @IfaceTyCon) ifaceTyConWriter
+ , mkCache (Proxy @IfaceType) ifaceTypeWriter
]
let bh = setUserData bh' userData
(fs_count,(name_count,(_, r))) <-
forwardPut bh (const (putTable fsTbl bh)) $ do
forwardPut bh (const (putTable nameTbl bh)) $ do
- forwardPut bh (const (putTable ifaceTyConTbl bh)) $ do
- put_payload bh
+ -- forwardPut bh (const (putTable ifaceTyConTbl bh)) $ do
+ forwardPut bh (const (putTable ifaceTypeTbl bh)) $ do
+ put_payload bh
return (name_count, fs_count, r)
=====================================
compiler/GHC/Iface/Decl.hs
=====================================
@@ -147,7 +147,7 @@ tyConToIfaceDecl env tycon
| Just fam_flav <- famTyConFlav_maybe tycon
= ( tc_env1
, IfaceFamily { ifName = getName tycon,
- ifResVar = if_res_var,
+ ifResVar = LexicalFastString <$> if_res_var,
ifFamFlav = to_if_fam_flav fam_flav,
ifBinders = if_binders,
ifResKind = if_res_kind,
@@ -256,7 +256,7 @@ tyConToIfaceDecl env tycon
(con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs
user_bndrs' = map (tidyUserForAllTyBinder con_env2) user_bndrs
- to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)
+ to_eq_spec (tv,ty) = ((tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
-- By this point, we have tidied every universal and existential
-- tyvar. Because of the dcUserForAllTyBinders invariant
@@ -288,7 +288,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 (LexicalFastString . getOccFS) (classMinimalDef clas)
}
(env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
@@ -334,7 +334,7 @@ tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)
tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
tidyTyConBinders = mapAccumL tidyTyConBinder
-tidyTyVar :: TidyEnv -> TyVar -> FastString
+tidyTyVar :: TidyEnv -> TyVar -> LexicalFastString
tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
toIfaceBooleanFormula :: BooleanFormula IfLclName -> IfaceBooleanFormula
=====================================
compiler/GHC/Iface/Env.hs
=====================================
@@ -190,10 +190,10 @@ setNameModule (Just m) n =
************************************************************************
-}
-tcIfaceLclId :: FastString -> IfL Id
+tcIfaceLclId :: LexicalFastString -> IfL Id
tcIfaceLclId occ
= do { lcl <- getLclEnv
- ; case lookupFsEnv (if_id_env lcl) occ of
+ ; case lookupFsEnv (if_id_env lcl) (getLexicalFastString occ) of
Just ty_var -> return ty_var
Nothing -> failIfM $
vcat
@@ -209,10 +209,10 @@ extendIfaceIdEnv ids
in env { if_id_env = id_env' }
-tcIfaceTyVar :: FastString -> IfL TyVar
+tcIfaceTyVar :: LexicalFastString -> IfL TyVar
tcIfaceTyVar occ
= do { lcl <- getLclEnv
- ; case lookupFsEnv (if_tv_env lcl) occ of
+ ; case lookupFsEnv (if_tv_env lcl) (getLexicalFastString occ) of
Just ty_var -> return ty_var
Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
}
@@ -220,15 +220,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) (getLexicalFastString 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) (getLexicalFastString occ)) }
lookupIfaceVar (IfaceTvBndr (occ, _))
= do { lcl <- getLclEnv
- ; return (lookupFsEnv (if_tv_env lcl) occ) }
+ ; return (lookupFsEnv (if_tv_env lcl) (getLexicalFastString occ)) }
extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv tyvars
=====================================
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.Syntax (putIfaceTyCon, IfaceTyCon, getIfaceTyCon)
+import GHC.Iface.Syntax (putIfaceTyCon, IfaceTyCon, getIfaceTyCon, getIfaceType, IfaceType, putIfaceType )
import Data.Proxy
data HieSymbolTable = HieSymbolTable
@@ -107,7 +107,8 @@ writeHieFile hie_file_path hiefile = do
hie_dict_map = dict_map_ref }
-- put the main thing
- let bh = addDecoder (mkCache (Proxy @IfaceTyCon) (mkWriter putIfaceTyCon)) $
+ let bh = -- addDecoder (mkCache (Proxy @IfaceTyCon) (mkWriter putIfaceTyCon)) $
+ addDecoder (mkCache (Proxy @IfaceType) (mkWriter putIfaceType)) $
setUserData bh0 $ newWriteState (putName hie_symtab)
(putName hie_symtab)
(putFastString hie_dict)
@@ -224,7 +225,8 @@ readHieFileContents bh0 name_cache = do
let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
(getDictFastString dict)
symtab <- get_symbol_table bh1
- let bh1' = addDecoder (mkCache (Proxy @IfaceTyCon) (mkReader getIfaceTyCon))
+ let bh1' = -- addDecoder (mkCache (Proxy @IfaceTyCon) (mkReader getIfaceTyCon))
+ addDecoder (mkCache (Proxy @IfaceType) (mkReader getIfaceType))
$ setUserData bh1
$ newReadState (getSymTabName symtab)
(getDictFastString dict)
=====================================
compiler/GHC/Iface/Ext/Utils.hs
=====================================
@@ -11,7 +11,7 @@ import GHC.Prelude
import GHC.Core.Map.Type
import GHC.Driver.DynFlags ( DynFlags )
import GHC.Driver.Ppr
-import GHC.Data.FastString ( FastString, mkFastString )
+import GHC.Data.FastString ( FastString, mkFastString , LexicalFastString(..))
import GHC.Iface.Type
import GHC.Types.Name hiding (varName)
import GHC.Types.Name.Set
@@ -156,15 +156,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 $ (LexicalFastString (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 = (LexicalFastString (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 (LexicalFastString "<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) (getLexicalFastString fs)
+ _ -> mkVarOccFS (getLexicalFastString fs)
binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) ()
binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs)
=====================================
compiler/GHC/Iface/Recomp/Binary.hs
=====================================
@@ -36,8 +36,10 @@ computeFingerprint put_nonbinding_name a = do
put_ bh a
fingerprintBinMem bh
where
- set_user_data bh = addDecoder (mkCache (Proxy @IfaceTyCon) $ mkWriter putIfaceTyCon)
- $ setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS
+ set_user_data bh =
+ addDecoder (mkCache (Proxy @IfaceType) $ mkWriter putIfaceType) $
+ -- addDecoder (mkCache (Proxy @IfaceTyCon) $ mkWriter putIfaceTyCon) $
+ setUserData bh $ newWriteState put_nonbinding_name putNameLiterally 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 getLexicalFastString minDef) <+>
text "#-}"
-- See Note [Suppressing binder signatures] in GHC.Iface.Type
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -34,7 +34,7 @@ module GHC.Iface.Type (
ifTyConBinderVar, ifTyConBinderName,
-- Binary utilities
- putIfaceTyCon, getIfaceTyCon,
+ putIfaceTyCon, getIfaceTyCon, putIfaceType, getIfaceType,
-- Equality testing
isIfaceLiftedTypeKind,
@@ -96,6 +96,7 @@ import qualified Data.Semigroup as Semi
import Control.DeepSeq
import Data.Proxy
import Control.Monad ((<$!>))
+import Control.Arrow (first)
{-
************************************************************************
@@ -105,7 +106,7 @@ import Control.Monad ((<$!>))
************************************************************************
-}
-type IfLclName = FastString -- A local name in iface syntax
+type IfLclName = LexicalFastString -- A local name in iface syntax
type IfExtName = Name -- An External or WiredIn Name can appear in Iface syntax
-- (However Internal or System Names never should)
@@ -113,6 +114,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)
@@ -181,6 +184,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
@@ -189,9 +193,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
@@ -233,6 +237,7 @@ data IfaceAppArgs
-- arguments in @{...}.
IfaceAppArgs -- The rest of the arguments
+ deriving (Eq, Ord)
instance Semi.Semigroup IfaceAppArgs where
IA_Nil <> xs = xs
@@ -394,7 +399,7 @@ adding no inline top-level constants for the two most common cases.
data IfaceMCoercion
= IfaceMRefl
- | IfaceMCo IfaceCoercion
+ | IfaceMCo IfaceCoercion deriving (Eq, Ord)
data IfaceCoercion
= IfaceReflCo IfaceType
@@ -419,11 +424,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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -595,11 +602,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 getLexicalFastString) eq_spec)
inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool
-- See Note [Substitution on IfaceType]
-inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs)
+inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst (getLexicalFastString fs))
substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
-- See Note [Substitution on IfaceType]
@@ -655,7 +662,7 @@ substIfaceAppArgs env args
substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
substIfaceTyVar env tv
- | Just ty <- lookupFsEnv env tv = ty
+ | Just ty <- lookupFsEnv env (getLexicalFastString tv) = ty
| otherwise = IfaceTyVar tv
@@ -701,6 +708,12 @@ ifaceVisAppArgsLength = go 0
| isVisibleForAllTyFlag argf = go (n+1) rest
| otherwise = go n rest
+ifaceAppArgsLength :: IfaceAppArgs -> Int
+ifaceAppArgsLength = go 0
+ where
+ go !n IA_Nil = n
+ go !n (IA_Arg _ _ ts) = go (n + 1) ts
+
{-
Note [Suppressing invisible arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1158,7 +1171,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 (getLexicalFastString var) substituted_ty
-- Record that we should replace it with LiftedRep/Lifted/Many,
-- and recurse, discarding the forall
in go subs' True ty
@@ -1166,7 +1179,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 (getLexicalFastString tv) of
Just s -> s
Nothing -> ty
@@ -1594,7 +1607,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
@@ -1976,11 +1989,14 @@ instance Outputable IfaceCoercion where
ppr = pprIfaceCoercion
instance Binary IfaceTyCon where
- putNoStack_ bh tyCon = case findUserDataCache Proxy bh of
- tbl -> putEntry tbl bh tyCon
+ putNoStack_ bh tyCon = putIfaceTyCon bh tyCon
- get bh = case findUserDataCache Proxy bh of
- tbl -> getEntry tbl bh
+ --case findUserDataCache Proxy bh of
+ -- tbl -> putEntry tbl bh tyCon
+
+ get bh = getIfaceTyCon bh
+ --case findUserDataCache Proxy bh of
+ -- tbl -> getEntry tbl bh
putIfaceTyCon :: HasCallStack => BinHandle -> IfaceTyCon -> IO ()
putIfaceTyCon bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
@@ -2030,21 +2046,27 @@ instance Binary IfaceTyLit where
_ -> panic ("get IfaceTyLit " ++ show tag)
instance Binary IfaceAppArgs where
- putNoStack_ bh tk =
- case tk of
- IA_Arg t a ts -> putByte bh 0 >> put_ bh t >> put_ bh a >> put_ bh ts
- IA_Nil -> putByte bh 1
+ putNoStack_ bh tk = do
+ -- Int is variable length encoded so only
+ -- one byte for small lists.
+ put_ bh (ifaceAppArgsLength tk)
+ go tk
+ where
+ go IA_Nil = pure ()
+ go (IA_Arg a b t) = do
+ put_ bh a
+ put_ bh b
+ go t
- get bh =
- do c <- getByte bh
- case c of
- 0 -> do
- t <- get bh
- a <- get bh
- ts <- get bh
- return $! IA_Arg t a ts
- 1 -> return IA_Nil
- _ -> panic ("get IfaceAppArgs " ++ show c)
+ get bh = do
+ n <- get bh :: IO Int
+ go n
+ where
+ go 0 = return IA_Nil
+ go c = do
+ a <- get bh
+ b <- get bh
+ IA_Arg a b <$> go (c - 1)
-------------------
@@ -2099,38 +2121,46 @@ ppr_parend_preds :: [IfacePredType] -> SDoc
ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds)))
instance Binary IfaceType where
- putNoStack_ _ (IfaceFreeTyVar tv)
- = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
+ putNoStack_ bh tyCon = case findUserDataCache Proxy bh of
+ tbl -> putEntry tbl bh tyCon
- putNoStack_ bh (IfaceForAllTy aa ab) = do
- putByte bh 0
- put_ bh aa
- put_ bh ab
- putNoStack_ bh (IfaceTyVar ad) = do
- putByte bh 1
- put_ bh ad
- putNoStack_ bh (IfaceAppTy ae af) = do
- putByte bh 2
- put_ bh ae
- put_ bh af
- putNoStack_ bh (IfaceFunTy af aw ag ah) = do
- putByte bh 3
- put_ bh af
- put_ bh aw
- put_ bh ag
- put_ bh ah
- putNoStack_ bh (IfaceTyConApp tc tys)
- = do { putByte bh 5; put_ bh tc; put_ bh tys }
- putNoStack_ bh (IfaceCastTy a b)
- = do { putByte bh 6; put_ bh a; put_ bh b }
- putNoStack_ bh (IfaceCoercionTy a)
- = do { putByte bh 7; put_ bh a }
- putNoStack_ bh (IfaceTupleTy s i tys)
- = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
- putNoStack_ bh (IfaceLitTy n)
- = do { putByte bh 9; put_ bh n }
+ get bh = case findUserDataCache Proxy bh of
+ tbl -> getEntry tbl bh
- get bh = do
+
+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 => BinHandle -> IO IfaceType
+getIfaceType bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
=====================================
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 . getLexicalFastString) 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 . getLexicalFastString) 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 (getLexicalFastString raw_name)
+ _ -> mkVarOccFS (getLexicalFastString 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 :: LexicalFastString -> 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 (getLexicalFastString 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 (getLexicalFastString 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 (getLexicalFastString 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 getLexicalFastString 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 (getLexicalFastString 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 (getLexicalFastString 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 (getLexicalFastString occ))
; tyvar <- mk_iface_tyvar name kind
; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
=====================================
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
=====================================
@@ -64,6 +64,8 @@ module GHC.Utils.Binary
-- * Lazy Binary I/O
lazyGet,
lazyPut,
+ lazyGet',
+ lazyPut',
lazyGetMaybe,
lazyPutMaybe,
@@ -100,7 +102,7 @@ import GHC.Utils.Fingerprint
import GHC.Types.SrcLoc
import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
-import GHC.Utils.Outputable( JoinPointHood(..) )
+import GHC.Utils.Outputable( JoinPointHood(..) , Outputable(..), text)
import Control.DeepSeq
import Foreign hiding (shiftL, shiftR, void)
@@ -134,6 +136,9 @@ import qualified Data.Map.Strict as Map
import Data.Tuple (swap)
import Unsafe.Coerce (unsafeCoerce)
import qualified Data.Map.Strict as Map
+import Data.List (sortBy)
+import Data.Ord (comparing)
+import Data.Maybe
type BinArray = ForeignPtr Word8
@@ -1079,25 +1084,33 @@ forwardGet bh get_A = do
-- -----------------------------------------------------------------------------
-- Lazy reading/writing
-lazyPut :: HasCallStack => Binary a => BinHandle -> a -> IO ()
-lazyPut bh a = do
+lazyPut :: Binary a => BinHandle -> a -> IO ()
+lazyPut = lazyPut' putNoStack_
+lazyGet :: Binary a => BinHandle -> IO a
+lazyGet = lazyGet' Nothing get
+
+lazyPut' :: HasCallStack => (BinHandle -> a -> IO ()) -> BinHandle -> a -> IO ()
+lazyPut' f bh a = do
-- output the obj with a ptr to skip over it:
pre_a <- tellBin @(Bin ()) bh
putNoStack_ bh pre_a -- save a slot for the ptr
- putNoStack_ bh a -- dump the object
+ f bh a -- dump the object
q <- tellBin @() bh -- q = ptr to after object
putAt bh pre_a q -- fill in slot before a with ptr to q
seekBin bh q -- finally carry on writing at q
-lazyGet :: HasCallStack => Binary a => BinHandle -> IO a
-lazyGet bh = do
+lazyGet' :: HasCallStack => Maybe (IORef BinHandle) -> (BinHandle -> IO a) -> BinHandle -> IO a
+lazyGet' mbh f bh = do
p <- get @(Bin ()) bh -- a BinPtr
p_a <- tellBin bh
a <- unsafeInterleaveIO $ do
-- NB: Use a fresh off_r variable in the child thread, for thread
-- safety.
+ inner_bh <- maybe (pure bh) readIORef mbh
off_r <- newFastMutInt 0
- getAt bh { _off_r = off_r } p_a
+ let bh' = inner_bh { _off_r = off_r }
+ seekBin bh' p_a
+ f bh'
seekBin bh p -- skip over the object for now
return a
@@ -1205,26 +1218,34 @@ initGenericSymbolTable = do
putGenericSymbolTable :: forall a. GenericSymbolTable a -> (BinHandle -> a -> IO ()) -> BinHandle -> IO Int
putGenericSymbolTable gen_sym_tab serialiser bh = do
- table_count <- readFastMutInt symtab_next
- symtab_map <- readIORef symtab_map
- putGenericSymbolTable bh table_count symtab_map
- pure table_count
+ putGenericSymbolTable bh
where
symtab_map = gen_symtab_map gen_sym_tab
symtab_next = gen_symtab_next gen_sym_tab
- putGenericSymbolTable :: HasCallStack => BinHandle -> Int -> Map.Map a Int -> IO ()
- putGenericSymbolTable bh name_count symtab = do
- put_ bh name_count
- let genElements = elems (array (0,name_count-1) (fmap swap $ Map.toList symtab))
- mapM_ (\n -> serialiser bh n) genElements
-
-getGenericSymbolTable :: forall a. (BinHandle -> IO a) -> BinHandle -> IO (SymbolTable a)
-getGenericSymbolTable deserialiser bh = do
- sz <- get bh :: IO Int
+ putGenericSymbolTable :: HasCallStack => BinHandle -> IO Int
+ putGenericSymbolTable bh = do
+ let loop bound = do
+ d <- readIORef symtab_map
+ table_count <- readFastMutInt symtab_next
+ let vs = sortBy (comparing fst) (map swap ([(a,b) | (a,b) <- Map.toList d, b >= bound]))
+ case vs of
+ [] -> return table_count
+ todo -> do
+ print (map fst todo)
+ mapM_ (\n -> lazyPut' serialiser bh n) (map snd vs)
+ loop table_count
+ snd <$>
+ (forwardPut bh (const $ readFastMutInt symtab_next >>= put_ bh) $
+ loop 0)
+
+getGenericSymbolTable :: forall a. (BinHandle -> IO a) -> IORef BinHandle -> BinHandle -> IO (SymbolTable a)
+getGenericSymbolTable deserialiser bhRef bh = do
+ sz <- forwardGet bh (get bh) :: IO Int
mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a)
forM_ [0..(sz-1)] $ \i -> do
- f <- deserialiser bh
+ f <- lazyGet' (Just bhRef) deserialiser bh
writeArray mut_arr i f
+ pprTraceM "gotten" (ppr sz)
unsafeFreeze mut_arr
putGenericSymTab :: (Ord a, Binary a) => GenericSymbolTable a -> BinHandle -> a -> IO ()
@@ -1250,6 +1271,9 @@ getGenericSymtab symtab bh = do
data SomeCache = forall a . SomeCache (TypeRep, CachedBinary a)
+instance Outputable SomeCache where
+ ppr (SomeCache (tr,_)) = text (show tr)
+
mkCache :: Typeable a => Proxy a -> CachedBinary a -> SomeCache
mkCache p cb = SomeCache (typeRep p, cb)
@@ -1282,7 +1306,7 @@ withMyUserData caches = noUserData
findUserDataCache :: (HasCallStack, Typeable a) => Proxy a -> BinHandle -> CachedBinary a
findUserDataCache query bh = go (ud_my_user_data $ getUserData bh)
where
- go [] = panic $ "Failed to find cache for key " ++ show query
+ go [] = panic $ "Failed to find cache for key " ++ show (typeRep query)
go (SomeCache (x, y) : xs)
| x == typeRep query = unsafeCoerce y
| otherwise = go xs
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -113,6 +113,8 @@ stage0Packages = do
, transformers
, unlit
, hp2ps
+ , ghc_debug_convention
+ , ghc_debug_stub
, if windowsHost then win32 else unix
]
++ [ terminfo | not windowsHost, not cross ]
@@ -160,8 +162,6 @@ stage1Packages = do
, unlit
, xhtml
, if winTarget then win32 else unix
- , ghc_debug_convention
- , ghc_debug_stub
]
, when (not cross)
[ haddock
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -100,6 +100,7 @@ packageArgs = do
, builder (Cabal Flags) ? mconcat
[ andM [expr ghcWithInterpreter, notStage0] `cabalFlag` "internal-interpreter"
, notStage0 `cabalFlag` "ghc-debug"
+ , stage0 `cabalFlag` "ghc-debug"
, ifM stage0
-- We build a threaded stage 1 if the bootstrapping compiler
-- supports it.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b9ce372a38510482910ea20bae04a153fc7a5892...9f3dddd5a8bfbeae21638f2865e1136c2fa5d9a1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b9ce372a38510482910ea20bae04a153fc7a5892...9f3dddd5a8bfbeae21638f2865e1136c2fa5d9a1
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/20240319/73212d4a/attachment-0001.html>
More information about the ghc-commits
mailing list