Commit dbe62229 authored by Matthew Pickering's avatar Matthew Pickering

Separate ModIface from cache fields

parent a143cb8d
......@@ -148,7 +148,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
wantedGot "Way" way_descr check_way ppr
when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file ways" way_descr check_way
getWithUserData ncu bh
initModIfaceCaches <$> getWithUserData ncu bh
-- | This performs a get action after reading the dictionary and symbol
......@@ -201,7 +201,7 @@ writeBinIface dflags hi_path mod_iface = do
put_ bh way_descr
putWithUserData (debugTraceMsg dflags 3) bh mod_iface
putWithUserData (debugTraceMsg dflags 3) bh (forgetModIfaceCaches mod_iface)
-- And send the result to the file
writeBinMem bh hi_path
......
......@@ -965,7 +965,8 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file
r <- read_file dynFilePath
case r of
Succeeded (dynIface, _)
| mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) ->
| mi_mod_hash (mi_backend iface)
== mi_mod_hash (mi_backend dynIface) ->
return ()
| otherwise ->
do traceIf (text "Dynamic hash doesn't match")
......@@ -1043,7 +1044,9 @@ ghcPrimIface
mi_exports = ghcPrimExports,
mi_decls = [],
mi_fixities = fixities,
mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities }
mi_final_exts =
(mi_backend empty_iface,
(mi_caches empty_iface){ mi_fix_fn = mkIfaceFixCache fixities })
}
where
empty_iface = emptyFullModIface gHC_PRIM
......@@ -1120,11 +1123,11 @@ pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ ne
pprModIface :: ModIface -> SDoc
-- Show a ModIface
pprModIface iface@ModIface{ mi_final_exts = exts }
pprModIface iface
= vcat [ text "interface"
<+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)
<+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty)
<+> (if mi_finsts exts then text "[family instance module]" else Outputable.empty)
<+> (if mi_orphan (mi_backend iface) then text "[orphan module]" else Outputable.empty)
<+> (if mi_finsts (mi_backend iface) then text "[family instance module]" else Outputable.empty)
<+> (if mi_hpc iface then text "[hpc]" else Outputable.empty)
<+> integer hiVersion
, nest 2 (text "interface hash:" <+> ppr (mi_iface_hash exts))
......@@ -1157,6 +1160,7 @@ pprModIface iface@ModIface{ mi_final_exts = exts }
, text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))
]
where
exts = mi_backend iface
pp_hsc_src HsBootFile = text "[boot]"
pp_hsc_src HsigFile = text "[hsig]"
pp_hsc_src HsSrcFile = Outputable.empty
......
......@@ -396,7 +396,7 @@ mkHashFun hsc_env eps name
iface <- initIfaceLoad hsc_env . withException
$ loadInterface (text "lookupVers2") mod ImportBySystem
return iface
return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`
return $ snd (mi_hash_fn (mi_caches iface) occ `orElse`
pprPanic "lookupVers1" (ppr mod <+> ppr occ))
-- ---------------------------------------------------------------------------
......@@ -705,7 +705,7 @@ addFingerprints hsc_env iface0
mi_hpc iface0)
let
final_iface_exts = ModIfaceBackend
final_iface_exts = (ModIfaceBackend
{ mi_iface_hash = iface_hash
, mi_mod_hash = mod_hash
, mi_flag_hash = flag_hash
......@@ -718,11 +718,11 @@ addFingerprints hsc_env iface0
&& null orph_fis)
, mi_finsts = not (null (mi_fam_insts iface0))
, mi_exp_hash = export_hash
, mi_orphan_hash = orphan_hash
, mi_warn_fn = warn_fn
, mi_orphan_hash = orphan_hash }, ModIfaceCaches {
mi_warn_fn = warn_fn
, mi_fix_fn = fix_fn
, mi_hash_fn = lookupOccEnv local_env
}
})
final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts }
--
return final_iface
......@@ -774,11 +774,11 @@ getOrphanHashes hsc_env mods = do
pit = eps_PIT eps
get_orph_hash mod =
case lookupIfaceByModule hpt pit mod of
Just iface -> return (mi_orphan_hash (mi_final_exts iface))
Just iface -> return (mi_orphan_hash (mi_backend iface))
Nothing -> do -- similar to 'mkHashFun'
iface <- initIfaceLoad hsc_env . withException
$ loadInterface (text "getOrphanHashes") mod ImportBySystem
return (mi_orphan_hash (mi_final_exts iface))
return (mi_orphan_hash (mi_backend iface))
--
mapM get_orph_hash mods
......@@ -1312,7 +1312,7 @@ checkVersions hsc_env mod_summary iface
checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
checkPlugins hsc iface = liftIO $ do
new_fingerprint <- fingerprintPlugins hsc
let old_fingerprint = mi_plugin_hash (mi_final_exts iface)
let old_fingerprint = mi_plugin_hash (mi_backend iface)
pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))
return $
pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr
......@@ -1409,7 +1409,7 @@ checkHie mod_summary = do
-- | Check the flags haven't changed
checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkFlagHash hsc_env iface = do
let old_hash = mi_flag_hash (mi_final_exts iface)
let old_hash = mi_flag_hash (mi_backend iface)
new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)
(mi_module iface)
putNameLiterally
......@@ -1422,7 +1422,7 @@ checkFlagHash hsc_env iface = do
-- | Check the optimisation flags haven't changed
checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkOptimHash hsc_env iface = do
let old_hash = mi_opt_hash (mi_final_exts iface)
let old_hash = mi_opt_hash (mi_backend iface)
new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)
putNameLiterally
if | old_hash == new_hash
......@@ -1437,7 +1437,7 @@ checkOptimHash hsc_env iface = do
-- | Check the HPC flags haven't changed
checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkHpcHash hsc_env iface = do
let old_hash = mi_hpc_hash (mi_final_exts iface)
let old_hash = mi_hpc_hash (mi_backend iface)
new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)
putNameLiterally
if | old_hash == new_hash
......@@ -1620,7 +1620,7 @@ checkModUsage _this_pkg UsagePackageModule{
usg_mod_hash = old_mod_hash }
= needInterface mod $ \iface -> do
let reason = moduleNameString (moduleName mod) ++ " changed"
checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_backend iface))
-- We only track the ABI hash of package modules, rather than
-- individual entity usages, so if the ABI hash changes we must
-- recompile. This is safe but may entail more recompilation when
......@@ -1629,7 +1629,7 @@ checkModUsage _this_pkg UsagePackageModule{
checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }
= needInterface mod $ \iface -> do
let reason = moduleNameString (moduleName mod) ++ " changed (raw)"
checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_backend iface))
checkModUsage this_pkg UsageHomeModule{
usg_mod_name = mod_name,
......@@ -1641,9 +1641,9 @@ checkModUsage this_pkg UsageHomeModule{
needInterface mod $ \iface -> do
let
new_mod_hash = mi_mod_hash (mi_final_exts iface)
new_decl_hash = mi_hash_fn (mi_final_exts iface)
new_export_hash = mi_exp_hash (mi_final_exts iface)
new_mod_hash = mi_mod_hash (mi_backend iface)
new_decl_hash = mi_hash_fn (mi_caches iface)
new_export_hash = mi_exp_hash (mi_backend iface)
reason = moduleNameString mod_name ++ " changed"
......
......@@ -1267,10 +1267,10 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })
lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt
lookupImpDeprec iface gre
= mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing,
= mi_warn_fn (mi_caches iface) (greOccName gre) `mplus` -- Bleat if the thing,
case gre_par gre of -- or its parent, is warn'd
ParentIs p -> mi_warn_fn (mi_final_exts iface) (nameOccName p)
FldParent { par_is = p } -> mi_warn_fn (mi_final_exts iface) (nameOccName p)
ParentIs p -> mi_warn_fn (mi_caches iface) (nameOccName p)
FldParent { par_is = p } -> mi_warn_fn (mi_caches iface) (nameOccName p)
NoParent -> Nothing
{-
......
......@@ -162,7 +162,7 @@ lookupFixityRn_help' name occ
-- loadInterfaceForName will find B.hi even if B is a hidden module,
-- and that's what we want.
= do { iface <- loadInterfaceForName doc name
; let mb_fix = mi_fix_fn (mi_final_exts iface) occ
; let mb_fix = mi_fix_fn (mi_caches iface) occ
; let msg = case mb_fix of
Nothing ->
text "looking up name" <+> ppr name
......
......@@ -397,8 +397,8 @@ calculateAvails :: DynFlags
calculateAvails dflags iface mod_safe' want_boot imported_by =
let imp_mod = mi_module iface
imp_sem_mod= mi_semantic_module iface
orph_iface = mi_orphan (mi_final_exts iface)
has_finsts = mi_finsts (mi_final_exts iface)
orph_iface = mi_orphan (mi_backend iface)
has_finsts = mi_finsts (mi_backend iface)
deps = mi_deps iface
trust = getSafeMode $ mi_trust iface
trust_pkg = mi_trust_pkg iface
......
......@@ -321,10 +321,10 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
-- modules accumulate in the PIT not HPT. Sigh.
Just iface = maybe_iface
finsts_mod = mi_finsts (mi_final_exts iface)
hash_env = mi_hash_fn (mi_final_exts iface)
mod_hash = mi_mod_hash (mi_final_exts iface)
export_hash | depend_on_exports = Just (mi_exp_hash (mi_final_exts iface))
finsts_mod = mi_finsts (mi_backend iface)
hash_env = mi_hash_fn (mi_caches iface)
mod_hash = mi_mod_hash (mi_backend iface)
export_hash | depend_on_exports = Just (mi_exp_hash (mi_backend iface))
| otherwise = Nothing
by_is_safe (ImportedByUser imv) = imv_is_safe imv
......
......@@ -675,8 +675,7 @@ hscIncrementalFrontend
-- save the interface that comes back from checkOldIface.
-- In one-shot mode we don't have the old iface until this
-- point, when checkOldIface reads it from the disk.
let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface
let mb_old_hash = fmap (mi_iface_hash . mi_backend) mb_checked_iface
case mb_checked_iface of
Just iface | not (recompileRequired recomp_reqd) ->
-- If the module used TH splices when it was last
......@@ -869,7 +868,7 @@ hscMaybeWriteIface dflags iface old_iface location = do
HscNothing -> False
HscInterpreted -> False
_ -> True
no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface))
no_change = old_iface == Just (mi_iface_hash (mi_backend iface))
when (write_interface || force_write_interface) $
hscWriteIface dflags iface no_change location
......@@ -1352,6 +1351,7 @@ hscSimpleIface' tc_result mb_old_iface = do
<- {-# SCC "MkFinalIface" #-}
liftIO $
mkIfaceTc hsc_env safe_mode details tc_result
let no_change = mb_old_iface == Just (mi_iface_hash (mi_backend new_iface))
-- And the answer is ...
liftIO $ dumpIfaceStats hsc_env
return (new_iface, mb_old_iface, details)
......
{-# LANGUAGE NamedFieldPuns #-}
{-
(c) The University of Glasgow, 2006
......@@ -86,12 +87,14 @@ module HscTypes (
mkQualPackage, mkQualModule, pkgQual,
-- * Interfaces
ModIface, PartialModIface, ModIface_(..), ModIfaceBackend(..),
ModIface, PartialModIface, ModIface_(..), ModIfaceBackend(..), ModIfaceCaches(..),
mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
emptyIfaceWarnCache, mi_boot, mi_fix,
mi_semantic_module,
mi_free_holes,
renameFreeHoles,
mi_caches, mi_backend,
initModIfaceCaches, forgetModIfaceCaches,
-- * Fixity
FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
......@@ -907,7 +910,8 @@ We can build a full interface file two ways:
-}
type PartialModIface = ModIface_ 'ModIfaceCore
type ModIface = ModIface_ 'ModIfaceFinal
type ModIface = ModIface_ ('ModIfaceFinal 'WithCaches)
type RawModIface = ModIface_ ('ModIfaceFinal 'NoCaches)
-- | Extends a PartialModIface with information which is either:
-- * Computed after codegen
......@@ -937,36 +941,43 @@ data ModIfaceBackend = ModIfaceBackend
, mi_orphan_hash :: !Fingerprint
-- ^ Hash for orphan rules, class and family instances combined
-- Cached environments for easy lookup. These are computed (lazily) from
-- other fields and are not put into the interface file.
-- Not really produced by the backend but there is no need to create them
-- any earlier.
, mi_warn_fn :: !(OccName -> Maybe WarningTxt)
-- ^ Cached lookup for 'mi_warns'
, mi_fix_fn :: !(OccName -> Maybe Fixity)
-- ^ Cached lookup for 'mi_fixities'
, mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint))
-- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that
-- the thing isn't in decls. It's useful to know that when seeing if we are
-- up to date wrt. the old interface. The 'OccName' is the parent of the
-- name, if it has one.
}
data ModIfacePhase
= ModIfaceCore
-- ^ Partial interface built based on output of core pipeline.
| ModIfaceFinal
| ModIfaceFinal WithCaches
data WithCaches = NoCaches | WithCaches
-- | Selects a IfaceDecl representation.
-- For fully instantiated interfaces we also maintain
-- a fingerprint, which is used for recompilation checks.
type family IfaceDeclExts (phase :: ModIfacePhase) where
IfaceDeclExts 'ModIfaceCore = IfaceDecl
IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl)
IfaceDeclExts ('ModIfaceFinal 'NoCaches) = (Fingerprint, IfaceDecl)
IfaceDeclExts ('ModIfaceFinal 'WithCaches) = (Fingerprint, IfaceDecl)
type family IfaceBackendExts (phase :: ModIfacePhase) where
IfaceBackendExts 'ModIfaceCore = ()
IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend
IfaceBackendExts ('ModIfaceFinal 'NoCaches) = ModIfaceBackend
IfaceBackendExts ('ModIfaceFinal 'WithCaches) = (ModIfaceBackend, ModIfaceCaches)
data ModIfaceCaches = ModIfaceCaches {
-- Cached environments for easy lookup. These are computed (lazily) from
-- other fields and are not put into the interface file.
-- Not really produced by the backend but there is no need to create them
-- any earlier.
mi_warn_fn :: !(OccName -> Maybe WarningTxt)
-- ^ Cached lookup for 'mi_warns'
, mi_fix_fn :: !(OccName -> Maybe Fixity)
-- ^ Cached lookup for 'mi_fixities'
, mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint))
-- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that
-- the thing isn't in decls. It's useful to know that when seeing if we are
-- up to date wrt. the old interface. The 'OccName' is the parent of the
-- name, if it has one.
}
......@@ -1078,6 +1089,12 @@ data ModIface_ (phase :: ModIfacePhase)
-- a fully instantiated interface.
}
mi_caches :: ModIface -> ModIfaceCaches
mi_caches = snd . mi_final_exts
mi_backend :: ModIface -> ModIfaceBackend
mi_backend = fst . mi_final_exts
-- | Old-style accessor for whether or not the ModIface came from an hs-boot
-- file.
mi_boot :: ModIface -> Bool
......@@ -1086,7 +1103,7 @@ mi_boot iface = mi_hsc_src iface == HsBootFile
-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be
-- found, 'defaultFixity' is returned instead.
mi_fix :: ModIface -> OccName -> Fixity
mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity
mi_fix iface name = mi_fix_fn (snd $ mi_final_exts iface) name `orElse` defaultFixity
-- | The semantic module for this interface; e.g., if it's a interface
-- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module'
......@@ -1124,7 +1141,7 @@ renameFreeHoles fhs insts =
-- It wasn't actually a hole
| otherwise = emptyUniqDSet
instance Binary ModIface where
instance Binary RawModIface where
put_ bh (ModIface {
mi_module = mod,
mi_sig_of = sig_of,
......@@ -1257,11 +1274,33 @@ instance Binary ModIface where
mi_orphan = orphan,
mi_finsts = hasFamInsts,
mi_exp_hash = exp_hash,
mi_orphan_hash = orphan_hash,
mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities,
mi_hash_fn = mkIfaceHashCache decls
}})
mi_orphan_hash = orphan_hash }
})
initModIfaceCaches :: RawModIface -> ModIface
initModIfaceCaches m@ModIface{mi_warns, mi_decls, mi_fixities, mi_final_exts} =
m { mi_decls = map convert mi_decls
, mi_final_exts = (mi_final_exts, caches)}
where
convert :: IfaceDeclExts ('ModIfaceFinal 'NoCaches) -> IfaceDeclExts ('ModIfaceFinal 'WithCaches)
convert x = x
caches =
ModIfaceCaches {
mi_warn_fn = mkIfaceWarnCache mi_warns,
mi_fix_fn = mkIfaceFixCache mi_fixities,
mi_hash_fn = mkIfaceHashCache mi_decls
}
-- | Use this function just before we serialise or compact a 'ModIface'
forgetModIfaceCaches :: ModIface -> RawModIface
forgetModIfaceCaches m@ModIface{mi_decls, mi_final_exts = (exts, _)} =
m { mi_decls = map convert mi_decls
, mi_final_exts = exts }
where
convert :: IfaceDeclExts ('ModIfaceFinal 'WithCaches) -> IfaceDeclExts ('ModIfaceFinal 'NoCaches)
convert x = x
-- | The original names declared of a certain module that are exported
type IfaceExport = AvailInfo
......@@ -1296,7 +1335,7 @@ emptyFullModIface :: Module -> ModIface
emptyFullModIface mod =
(emptyPartialModIface mod)
{ mi_decls = []
, mi_final_exts = ModIfaceBackend
, mi_final_exts = (ModIfaceBackend
{ mi_iface_hash = fingerprint0,
mi_mod_hash = fingerprint0,
mi_flag_hash = fingerprint0,
......@@ -1306,10 +1345,10 @@ emptyFullModIface mod =
mi_orphan = False,
mi_finsts = False,
mi_exp_hash = fingerprint0,
mi_orphan_hash = fingerprint0,
mi_orphan_hash = fingerprint0 }, ModIfaceCaches {
mi_warn_fn = emptyIfaceWarnCache,
mi_fix_fn = emptyIfaceFixCache,
mi_hash_fn = emptyIfaceHashCache } }
mi_hash_fn = emptyIfaceHashCache })}
-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'
mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]
......
......@@ -322,7 +322,7 @@ checkFamInstConsistency directlyImpMods
-- Note [Checking family instance optimization]
; modConsistent :: Module -> [Module]
; modConsistent mod =
if mi_finsts (mi_final_exts (modIface mod)) then mod:deps else deps
if mi_finsts (mi_backend (modIface mod)) then mod:deps else deps
where
deps = dep_finsts . mi_deps . modIface $ mod
......
......@@ -93,7 +93,7 @@ checkHsigDeclM sig_iface sig_thing real_thing = do
-- implementation cases.
checkBootDeclM False sig_thing real_thing
real_fixity <- lookupFixityRn name
let sig_fixity = case mi_fix_fn (mi_final_exts sig_iface) (occName name) of
let sig_fixity = case mi_fix_fn (mi_caches sig_iface) (occName name) of
Nothing -> defaultFixity
Just f -> f
when (real_fixity /= sig_fixity) $
......@@ -833,7 +833,8 @@ mergeSignatures
-- This is a HACK to prevent calculateAvails from including imp_mod
-- in the listing. We don't want it because a module is NOT
-- supposed to include itself in its dep_orphs/dep_finsts. See #13214
iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } }
(final_data, caches) = mi_final_exts iface
iface' = iface { mi_final_exts = (final_data { mi_orphan = False, mi_finsts = False }, caches) }
avails = plusImportAvails (tcg_imports tcg_env) $
calculateAvails dflags iface' False False ImportedBySystem
return tcg_env {
......@@ -844,7 +845,7 @@ mergeSignatures
if outer_mod == mi_module iface
-- Don't add ourselves!
then tcg_merged tcg_env
else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env
else (mi_module iface, mi_mod_hash (mi_backend iface)) : tcg_merged tcg_env
}
-- Note [Signature merging DFuns]
......
......@@ -924,7 +924,7 @@ abiHash strs = do
put_ bh hiVersion
-- package hashes change when the compiler version changes (for now)
-- see #5328
mapM_ (put_ bh . mi_mod_hash . mi_final_exts) ifaces
mapM_ (put_ bh . mi_mod_hash . mi_backend) ifaces
f <- fingerprintBinMem bh
putStrLn (showPpr dflags f)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment