module GHC.Iface.Recomp
( checkOldIface
, RecompileRequired(..)
, needsRecompileBecause
, recompThen
, MaybeValidated(..)
, outOfDateItemBecause
, RecompReason (..)
, CompileReason(..)
, recompileRequired
, addFingerprints
)
where
import GHC.Prelude
import GHC.Driver.Backend
import GHC.Driver.Config.Finder
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Plugins
import GHC.Iface.Syntax
import GHC.Iface.Recomp.Binary
import GHC.Iface.Load
import GHC.Iface.Recomp.Flags
import GHC.Iface.Env
import GHC.Core
import GHC.Tc.Utils.Monad
import GHC.Hs
import GHC.Data.Graph.Directed
import GHC.Data.Maybe
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Misc as Utils hiding ( eqListBy )
import GHC.Utils.Binary
import GHC.Utils.Fingerprint
import GHC.Utils.Exception
import GHC.Utils.Logger
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Trace
import GHC.Types.Annotations
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Types.Fixity.Env
import GHC.Unit.External
import GHC.Unit.Finder
import GHC.Unit.State
import GHC.Unit.Home
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Warnings
import GHC.Unit.Module.Deps
import Control.Monad
import Data.List (sortBy, sort)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Word (Word64)
import Data.Either
import qualified Data.Semigroup
import GHC.List (uncons)
import Data.Ord
import Data.Containers.ListUtils
import Data.Bifunctor
data RecompileRequired
= UpToDate
| NeedsRecompile !CompileReason
deriving (Eq)
needsRecompileBecause :: RecompReason -> RecompileRequired
needsRecompileBecause = NeedsRecompile . RecompBecause
data MaybeValidated a
= UpToDateItem a
| OutOfDateItem
!CompileReason
(Maybe a)
deriving (Functor)
outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause reason item = OutOfDateItem (RecompBecause reason) item
data CompileReason
= MustCompile
| RecompBecause !RecompReason
deriving (Eq)
instance Outputable RecompileRequired where
ppr UpToDate = text "UpToDate"
ppr (NeedsRecompile reason) = ppr reason
instance Outputable CompileReason where
ppr MustCompile = text "MustCompile"
ppr (RecompBecause r) = text "RecompBecause" <+> ppr r
instance Semigroup RecompileRequired where
UpToDate <> r = r
mc <> _ = mc
instance Monoid RecompileRequired where
mempty = UpToDate
data RecompReason
= UnitDepRemoved UnitId
| ModulePackageChanged String
| SourceFileChanged
| ThisUnitIdChanged
| ImpurePlugin
| PluginsChanged
| PluginFingerprintChanged
| ModuleInstChanged
| HieMissing
| HieOutdated
| SigsMergeChanged
| ModuleChanged ModuleName
| ModuleRemoved (UnitId, ModuleName)
| ModuleAdded (UnitId, ModuleName)
| ModuleChangedRaw ModuleName
| ModuleChangedIface ModuleName
| FileChanged FilePath
| CustomReason String
| FlagsChanged
| OptimFlagsChanged
| HpcFlagsChanged
| MissingBytecode
| MissingObjectFile
| MissingDynObjectFile
| MissingDynHiFile
| MismatchedDynHiFile
| ObjectsChanged
| LibraryChanged
deriving (Eq)
instance Outputable RecompReason where
ppr = \case
UnitDepRemoved uid -> ppr uid <+> text "removed"
ModulePackageChanged s -> text s <+> text "package changed"
SourceFileChanged -> text "Source file changed"
ThisUnitIdChanged -> text "-this-unit-id changed"
ImpurePlugin -> text "Impure plugin forced recompilation"
PluginsChanged -> text "Plugins changed"
PluginFingerprintChanged -> text "Plugin fingerprint changed"
ModuleInstChanged -> text "Implementing module changed"
HieMissing -> text "HIE file is missing"
HieOutdated -> text "HIE file is out of date"
SigsMergeChanged -> text "Signatures to merge in changed"
ModuleChanged m -> ppr m <+> text "changed"
ModuleChangedRaw m -> ppr m <+> text "changed (raw)"
ModuleChangedIface m -> ppr m <+> text "changed (interface)"
ModuleRemoved (_uid, m) -> ppr m <+> text "removed"
ModuleAdded (_uid, m) -> ppr m <+> text "added"
FileChanged fp -> text fp <+> text "changed"
CustomReason s -> text s
FlagsChanged -> text "Flags changed"
OptimFlagsChanged -> text "Optimisation flags changed"
HpcFlagsChanged -> text "HPC flags changed"
MissingBytecode -> text "Missing bytecode"
MissingObjectFile -> text "Missing object file"
MissingDynObjectFile -> text "Missing dynamic object file"
MissingDynHiFile -> text "Missing dynamic interface file"
MismatchedDynHiFile -> text "Mismatched dynamic interface file"
ObjectsChanged -> text "Objects changed"
LibraryChanged -> text "Library changed"
recompileRequired :: RecompileRequired -> Bool
recompileRequired UpToDate = False
recompileRequired _ = True
recompThen :: Monad m => m RecompileRequired -> m RecompileRequired -> m RecompileRequired
recompThen ma mb = ma >>= \case
UpToDate -> mb
rr@(NeedsRecompile _) -> pure rr
checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired
checkList = \case
[] -> return UpToDate
(check : checks) -> check `recompThen` checkList checks
checkOldIface
:: HscEnv
-> ModSummary
-> Maybe ModIface
-> IO (MaybeValidated ModIface)
checkOldIface hsc_env mod_summary maybe_iface
= do let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
showPass logger $
"Checking old interface for " ++
(showPpr dflags $ ms_mod mod_summary) ++
" (use -ddump-hi-diffs for more details)"
initIfaceCheck (text "checkOldIface") hsc_env $
check_old_iface hsc_env mod_summary maybe_iface
check_old_iface
:: HscEnv
-> ModSummary
-> Maybe ModIface
-> IfG (MaybeValidated ModIface)
check_old_iface hsc_env mod_summary maybe_iface
= let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
getIface =
case maybe_iface of
Just _ -> do
trace_if logger (text "We already have the old interface for" <+>
ppr (ms_mod mod_summary))
return maybe_iface
Nothing -> loadIface dflags (msHiFilePath mod_summary)
loadIface read_dflags iface_path = do
let ncu = hsc_NC hsc_env
read_result <- readIface read_dflags ncu (ms_mod mod_summary) iface_path
case read_result of
Failed err -> do
trace_if logger (text "FYI: cannot read old interface file:" $$ nest 4 err)
trace_hi_diffs logger (text "Old interface file was invalid:" $$ nest 4 err)
return Nothing
Succeeded iface -> do
trace_if logger (text "Read the interface file" <+> text iface_path)
return $ Just iface
check_dyn_hi :: ModIface
-> IfG (MaybeValidated ModIface)
-> IfG (MaybeValidated ModIface)
check_dyn_hi normal_iface recomp_check | gopt Opt_BuildDynamicToo dflags = do
res <- recomp_check
case res of
UpToDateItem _ -> do
maybe_dyn_iface <- liftIO $ loadIface (setDynamicNow dflags) (msDynHiFilePath mod_summary)
case maybe_dyn_iface of
Nothing -> return $ outOfDateItemBecause MissingDynHiFile Nothing
Just dyn_iface | mi_iface_hash (mi_final_exts dyn_iface)
/= mi_iface_hash (mi_final_exts normal_iface)
-> return $ outOfDateItemBecause MismatchedDynHiFile Nothing
Just {} -> return res
_ -> return res
check_dyn_hi _ recomp_check = recomp_check
src_changed
| gopt Opt_ForceRecomp dflags = True
| otherwise = False
in do
when src_changed $
liftIO $ trace_hi_diffs logger (nest 4 $ text "Recompilation check turned off")
case src_changed of
True | not (backendProducesObject $ backend dflags) ->
return $ OutOfDateItem MustCompile maybe_iface
True -> do
maybe_iface' <- liftIO $ getIface
return $ OutOfDateItem MustCompile maybe_iface'
False -> do
maybe_iface' <- liftIO $ getIface
case maybe_iface' of
Nothing -> return $ OutOfDateItem MustCompile Nothing
Just iface ->
check_dyn_hi iface $ checkVersions hsc_env mod_summary iface
checkVersions :: HscEnv
-> ModSummary
-> ModIface
-> IfG (MaybeValidated ModIface)
checkVersions hsc_env mod_summary iface
= do { liftIO $ trace_hi_diffs logger
(text "Considering whether compilation is required for" <+>
ppr (mi_module iface) <> colon)
; hsc_env <- getTopEnv
; if mi_src_hash iface /= ms_hs_hash mod_summary
then return $ outOfDateItemBecause SourceFileChanged Nothing else do {
; if not (isHomeModule home_unit (mi_module iface))
then return $ outOfDateItemBecause ThisUnitIdChanged Nothing else do {
; recomp <- liftIO $ checkFlagHash hsc_env iface
`recompThen` checkOptimHash hsc_env iface
`recompThen` checkHpcHash hsc_env iface
`recompThen` checkMergedSignatures hsc_env mod_summary iface
`recompThen` checkHsig logger home_unit mod_summary iface
`recompThen` pure (checkHie dflags mod_summary)
; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {
; recomp <- checkDependencies hsc_env mod_summary iface
; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {
; recomp <- checkPlugins (hsc_plugins hsc_env) iface
; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {
when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {
; updateEps_ $ \eps -> eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) }
}
; recomp <- checkList [checkModUsage (hsc_FC hsc_env) u
| u <- mi_usages iface]
; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {
; return $ UpToDateItem iface
}}}}}}}
where
logger = hsc_logger hsc_env
dflags = hsc_dflags hsc_env
home_unit = hsc_home_unit hsc_env
checkPlugins :: Plugins -> ModIface -> IfG RecompileRequired
checkPlugins plugins iface = liftIO $ do
recomp <- recompPlugins plugins
let new_fingerprint = fingerprintPluginRecompile recomp
let old_fingerprint = mi_plugin_hash (mi_final_exts iface)
return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint recomp
recompPlugins :: Plugins -> IO PluginRecompile
recompPlugins plugins = mconcat <$> mapM pluginRecompile' (pluginsWithArgs plugins)
fingerprintPlugins :: Plugins -> IO Fingerprint
fingerprintPlugins plugins = fingerprintPluginRecompile <$> recompPlugins plugins
fingerprintPluginRecompile :: PluginRecompile -> Fingerprint
fingerprintPluginRecompile recomp = case recomp of
NoForceRecompile -> fingerprintString "NoForceRecompile"
ForceRecompile -> fingerprintString "ForceRecompile"
MaybeRecompile fp -> fp
pluginRecompileToRecompileRequired
:: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired
pluginRecompileToRecompileRequired old_fp new_fp pr
| old_fp == new_fp =
case pr of
NoForceRecompile -> UpToDate
MaybeRecompile _ -> UpToDate
ForceRecompile -> needsRecompileBecause ImpurePlugin
| old_fp `elem` magic_fingerprints ||
new_fp `elem` magic_fingerprints
= needsRecompileBecause PluginsChanged
| otherwise =
case pr of
ForceRecompile -> needsRecompileBecause PluginFingerprintChanged
_ -> needsRecompileBecause PluginFingerprintChanged
where
magic_fingerprints =
[ fingerprintString "NoForceRecompile"
, fingerprintString "ForceRecompile"
]
checkHsig :: Logger -> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired
checkHsig logger home_unit mod_summary iface = do
let outer_mod = ms_mod mod_summary
inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod)
massert (isHomeModule home_unit outer_mod)
case inner_mod == mi_semantic_module iface of
True -> up_to_date logger (text "implementing module unchanged")
False -> return $ needsRecompileBecause ModuleInstChanged
checkHie :: DynFlags -> ModSummary -> RecompileRequired
checkHie dflags mod_summary =
let hie_date_opt = ms_hie_date mod_summary
hi_date = ms_iface_date mod_summary
in if not (gopt Opt_WriteHie dflags)
then UpToDate
else case (hie_date_opt, hi_date) of
(Nothing, _) -> needsRecompileBecause HieMissing
(Just hie_date, Just hi_date)
| hie_date < hi_date
-> needsRecompileBecause HieOutdated
_ -> UpToDate
checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired
checkFlagHash hsc_env iface = do
let logger = hsc_logger hsc_env
let old_hash = mi_flag_hash (mi_final_exts iface)
new_hash <- fingerprintDynFlags hsc_env (mi_module iface) putNameLiterally
case old_hash == new_hash of
True -> up_to_date logger (text "Module flags unchanged")
False -> out_of_date_hash logger FlagsChanged
(text " Module flags have changed")
old_hash new_hash
checkOptimHash :: HscEnv -> ModIface -> IO RecompileRequired
checkOptimHash hsc_env iface = do
let logger = hsc_logger hsc_env
let old_hash = mi_opt_hash (mi_final_exts iface)
new_hash <- fingerprintOptFlags (hsc_dflags hsc_env)
putNameLiterally
if | old_hash == new_hash
-> up_to_date logger (text "Optimisation flags unchanged")
| gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)
-> up_to_date logger (text "Optimisation flags changed; ignoring")
| otherwise
-> out_of_date_hash logger OptimFlagsChanged
(text " Optimisation flags have changed")
old_hash new_hash
checkHpcHash :: HscEnv -> ModIface -> IO RecompileRequired
checkHpcHash hsc_env iface = do
let logger = hsc_logger hsc_env
let old_hash = mi_hpc_hash (mi_final_exts iface)
new_hash <- fingerprintHpcFlags (hsc_dflags hsc_env)
putNameLiterally
if | old_hash == new_hash
-> up_to_date logger (text "HPC flags unchanged")
| gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)
-> up_to_date logger (text "HPC flags changed; ignoring")
| otherwise
-> out_of_date_hash logger HpcFlagsChanged
(text " HPC flags have changed")
old_hash new_hash
checkMergedSignatures :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired
checkMergedSignatures hsc_env mod_summary iface = do
let logger = hsc_logger hsc_env
let unit_state = hsc_units hsc_env
let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]
new_merged = case Map.lookup (ms_mod_name mod_summary)
(requirementContext unit_state) of
Nothing -> []
Just r -> sort $ map (instModuleToModule unit_state) r
if old_merged == new_merged
then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged)
else return $ needsRecompileBecause SigsMergeChanged
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
let (hs, ps) = partitionEithers es
liftIO $
check_mods (sort hs) prev_dep_mods
`recompThen`
let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd (ps ++ implicit_deps ++ bkpk_units)
in check_packages allPkgDeps prev_dep_pkgs
where
classify_import :: (ModuleName -> t -> IO FindResult)
-> [(t, GenLocated l ModuleName)]
-> IfG
[Either
CompileReason (Either (UnitId, ModuleName) (String, UnitId))]
classify_import find_import imports =
liftIO $ traverse (\(mb_pkg, L _ mod) ->
let reason = ModuleChanged mod
in classify reason <$> find_import mod mb_pkg)
imports
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
logger = hsc_logger hsc_env
fc = hsc_FC hsc_env
mhome_unit = hsc_home_unit_maybe hsc_env
all_home_units = hsc_all_home_unit_ids hsc_env
units = hsc_units hsc_env
prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface)
prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface))
(dep_plugin_pkgs (mi_deps iface)))
bkpk_units = map (("Signature",) . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface)))
implicit_deps = map ("Implicit",) (implicitPackageDeps dflags)
fake_ghc_prim_import = case mhome_unit of
Just home_unit
| homeUnitId home_unit == primUnitId
-> Left (primUnitId, mkModuleName "GHC.Prim")
_ -> Right ("GHC.Prim", primUnitId)
classify _ (Found _ mod)
| (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod))
| otherwise = Right (Right (moduleNameString (moduleName mod), toUnitId $ moduleUnit mod))
classify reason _ = Left (RecompBecause reason)
check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired
check_mods [] [] = return UpToDate
check_mods [] (old:_) = do
trace_hi_diffs logger $
text "module no longer" <+> quotes (ppr old) <+>
text "in dependencies"
return $ needsRecompileBecause $ ModuleRemoved old
check_mods (new:news) olds
| Just (old, olds') <- uncons olds
, new == old = check_mods (dropWhile (== new) news) olds'
| otherwise = do
trace_hi_diffs logger $
text "imported module " <> quotes (ppr new) <>
text " not among previous dependencies"
return $ needsRecompileBecause $ ModuleAdded new
check_packages :: [(String, UnitId)] -> [UnitId] -> IO RecompileRequired
check_packages [] [] = return UpToDate
check_packages [] (old:_) = do
trace_hi_diffs logger $
text "package " <> quotes (ppr old) <>
text "no longer in dependencies"
return $ needsRecompileBecause $ UnitDepRemoved old
check_packages (new:news) olds
| Just (old, olds') <- uncons olds
, snd new == old = check_packages (dropWhile ((== (snd new)) . snd) news) olds'
| otherwise = do
trace_hi_diffs logger $
text "imported package " <> quotes (ppr new) <>
text " not among previous dependencies"
return $ needsRecompileBecause $ ModulePackageChanged $ fst new
needInterface :: Module -> (ModIface -> IO RecompileRequired)
-> IfG RecompileRequired
needInterface mod continue
= do
mb_recomp <- tryGetModIface
"need version info for"
mod
case mb_recomp of
Nothing -> return $ NeedsRecompile MustCompile
Just iface -> liftIO $ continue iface
tryGetModIface :: String -> Module -> IfG (Maybe ModIface)
tryGetModIface doc_msg mod
= do
logger <- getLogger
let doc_str = sep [text doc_msg, ppr mod]
liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod <+> ppr (moduleUnit mod))
mb_iface <- loadInterface doc_str mod ImportBySystem
case mb_iface of
Failed _ -> do
liftIO $ trace_hi_diffs logger (sep [text "Couldn't load interface for module", ppr mod])
return Nothing
Succeeded iface -> pure $ Just iface
checkModUsage :: FinderCache -> Usage -> IfG RecompileRequired
checkModUsage _ UsagePackageModule{
usg_mod = mod,
usg_mod_hash = old_mod_hash } = do
logger <- getLogger
needInterface mod $ \iface -> do
let reason = ModuleChanged (moduleName mod)
checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do
logger <- getLogger
needInterface mod $ \iface -> do
let reason = ModuleChangedRaw (moduleName mod)
checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
checkModUsage _ UsageHomeModuleInterface{ usg_mod_name = mod_name
, usg_unit_id = uid
, usg_iface_hash = old_mod_hash } = do
let mod = mkModule (RealUnit (Definite uid)) mod_name
logger <- getLogger
needInterface mod $ \iface -> do
let reason = ModuleChangedIface mod_name
checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash (mi_final_exts iface))
checkModUsage _ UsageHomeModule{
usg_mod_name = mod_name,
usg_unit_id = uid,
usg_mod_hash = old_mod_hash,
usg_exports = maybe_old_export_hash,
usg_entities = old_decl_hash }
= do
let mod = mkModule (RealUnit (Definite uid)) mod_name
logger <- getLogger
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)
reason = ModuleChanged (moduleName mod)
liftIO $ do
recompile <- checkModuleFingerprint logger reason old_mod_hash new_mod_hash
if not (recompileRequired recompile)
then return UpToDate
else checkList
[
checkMaybeHash logger reason maybe_old_export_hash new_export_hash
(text " Export list changed")
,
checkList [ checkEntityUsage logger reason new_decl_hash u
| u <- old_decl_hash]
, up_to_date logger (text " Great! The bits I use are up to date")
]
checkModUsage fc UsageFile{ usg_file_path = file,
usg_file_hash = old_hash,
usg_file_label = mlabel } =
liftIO $
handleIO handler $ do
new_hash <- lookupFileCache fc file
if (old_hash /= new_hash)
then return recomp
else return UpToDate
where
reason = FileChanged file
recomp = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel
handler = if debugIsOn
then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
else \_ -> return recomp
checkModuleFingerprint
:: Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkModuleFingerprint logger reason old_mod_hash new_mod_hash
| new_mod_hash == old_mod_hash
= up_to_date logger (text "Module fingerprint unchanged")
| otherwise
= out_of_date_hash logger reason (text " Module fingerprint has changed")
old_mod_hash new_mod_hash
checkIfaceFingerprint
:: Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
checkIfaceFingerprint logger reason old_mod_hash new_mod_hash
| new_mod_hash == old_mod_hash
= up_to_date logger (text "Iface fingerprint unchanged")
| otherwise
= out_of_date_hash logger reason (text " Iface fingerprint has changed")
old_mod_hash new_mod_hash
checkMaybeHash
:: Logger
-> RecompReason
-> Maybe Fingerprint
-> Fingerprint
-> SDoc
-> IO RecompileRequired
checkMaybeHash logger reason maybe_old_hash new_hash doc
| Just hash <- maybe_old_hash, hash /= new_hash
= out_of_date_hash logger reason doc hash new_hash
| otherwise
= return UpToDate
checkEntityUsage :: Logger
-> RecompReason
-> (OccName -> Maybe (OccName, Fingerprint))
-> (OccName, Fingerprint)
-> IO RecompileRequired
checkEntityUsage logger reason new_hash (name,old_hash) = do
case new_hash name of
Nothing -> out_of_date logger reason (sep [text "No longer exported:", ppr name])
Just (_, new_hash)
| new_hash == old_hash
-> do trace_hi_diffs logger (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
return UpToDate
| otherwise
-> out_of_date_hash logger reason (text " Out of date:" <+> ppr name) old_hash new_hash
up_to_date :: Logger -> SDoc -> IO RecompileRequired
up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate
out_of_date :: Logger -> RecompReason -> SDoc -> IO RecompileRequired
out_of_date logger reason msg = trace_hi_diffs logger msg >> return (needsRecompileBecause reason)
out_of_date_hash :: Logger -> RecompReason -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired
out_of_date_hash logger reason msg old_hash new_hash
= out_of_date logger reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
addFingerprints
:: HscEnv
-> PartialModIface
-> IO ModIface
addFingerprints hsc_env iface0
= do
eps <- hscEPS hsc_env
let
decls = mi_decls iface0
warn_fn = mkIfaceWarnCache (mi_warns iface0)
fix_fn = mkIfaceFixCache (mi_fixities iface0)
declABI :: IfaceDecl -> IfaceDeclABI
declABI decl = (this_mod, decl, extras)
where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts
non_orph_fis top_lvl_name_env decl
top_lvl_name_env =
mkOccEnv [ (nameOccName nm, nm)
| IfaceId { ifName = nm } <- decls ]
edges :: [ Node Unique IfaceDeclABI ]
edges = [ DigraphNode abi (getUnique (getOccName decl)) out
| decl <- decls
, let abi = declABI decl
, let out = localOccs $ freeNamesDeclABI abi
]
name_module n = assertPpr (isExternalName n) (ppr n) (nameModule n)
localOccs =
map (getUnique . getParent . getOccName)
. filter ((== semantic_mod) . name_module)
. nonDetEltsUniqSet
where getParent :: OccName -> OccName
getParent occ = lookupOccEnv parent_map occ `orElse` occ
parent_map :: OccEnv OccName
parent_map = foldl' extend emptyOccEnv decls
where extend env d =
extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]
where n = getOccName d
groups :: [SCC IfaceDeclABI]
groups = stronglyConnCompFromEdgedVerticesUniq edges
global_hash_fn = mkHashFun hsc_env eps
mk_put_name :: OccEnv (OccName,Fingerprint)
-> BinHandle -> Name -> IO ()
mk_put_name local_env bh name
| isWiredInName name = putNameLiterally bh name
| otherwise
= assertPpr (isExternalName name) (ppr name) $
let hash | nameModule name /= semantic_mod = global_hash_fn name
| semantic_mod /= this_mod
, not (isHoleModule semantic_mod) = global_hash_fn name
| otherwise = return (snd (lookupOccEnv local_env (getOccName name)
`orElse` pprPanic "urk! lookup local fingerprint"
(ppr name $$ ppr local_env)))
in hash >>= put_ bh
fingerprint_group :: (OccEnv (OccName,Fingerprint),
[(Fingerprint,IfaceDecl)])
-> SCC IfaceDeclABI
-> IO (OccEnv (OccName,Fingerprint),
[(Fingerprint,IfaceDecl)])
fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
= do let hash_fn = mk_put_name local_env
decl = abiDecl abi
hash <- computeFingerprint hash_fn abi
env' <- extend_hash_env local_env (hash,decl)
return (env', (hash,decl) : decls_w_hashes)
fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
= do let stable_abis = sortBy cmp_abiNames abis
stable_decls = map abiDecl stable_abis
local_env1 <- foldM extend_hash_env local_env
(zip (map mkRecFingerprint [0..]) stable_decls)
let hash_fn = mk_put_name local_env1
hash <- computeFingerprint hash_fn stable_abis
let pairs = zip (map (bumpFingerprint hash) [0..]) stable_decls
local_env2 <- foldM extend_hash_env local_env pairs
return (local_env2, pairs ++ decls_w_hashes)
mkRecFingerprint :: Word64 -> Fingerprint
mkRecFingerprint i = Fingerprint 0 i
bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint
bumpFingerprint fp n = fingerprintFingerprints [ fp, mkRecFingerprint n ]
extend_hash_env :: OccEnv (OccName,Fingerprint)
-> (Fingerprint,IfaceDecl)
-> IO (OccEnv (OccName,Fingerprint))
extend_hash_env env0 (hash,d) =
return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0
(ifaceDeclFingerprints hash d))
(local_env, decls_w_hashes) <-
foldM fingerprint_group (emptyOccEnv, []) groups
let sorted_deps :: Dependencies
sorted_deps = mi_deps iface0
let orph_mods
= filter (/= this_mod)
$ dep_orphs sorted_deps
dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
orphan_hash <- computeFingerprint (mk_put_name local_env)
(map ifDFun orph_insts, orph_rules, orph_fis)
dep_hash <- computeFingerprint putNameLiterally
(dep_sig_mods (mi_deps iface0),
dep_boot_mods (mi_deps iface0),
dep_trusted_pkgs (mi_deps iface0),
dep_finsts (mi_deps iface0) )
export_hash <- computeFingerprint putNameLiterally
(mi_exports iface0,
orphan_hash,
dep_hash,
dep_orphan_hashes,
mi_trust iface0)
let sorted_decls :: [(Fingerprint, IfaceDecl)]
sorted_decls = Map.elems $ Map.fromList $
[(getOccName d, e) | e@(_, d) <- decls_w_hashes]
flag_hash <- fingerprintDynFlags hsc_env this_mod putNameLiterally
opt_hash <- fingerprintOptFlags dflags putNameLiterally
hpc_hash <- fingerprintHpcFlags dflags putNameLiterally
plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env)
mod_hash <- computeFingerprint putNameLiterally
(map fst sorted_decls,
export_hash,
mi_warns iface0)
iface_hash <- computeFingerprint putNameLiterally
(mod_hash,
mi_src_hash iface0,
ann_fn (mkVarOcc "module"),
usages,
sorted_deps,
mi_hpc iface0)
let
final_iface_exts = ModIfaceBackend
{ mi_iface_hash = iface_hash
, mi_mod_hash = mod_hash
, mi_flag_hash = flag_hash
, mi_opt_hash = opt_hash
, mi_hpc_hash = hpc_hash
, mi_plugin_hash = plugin_hash
, mi_orphan = not ( all ifRuleAuto orph_rules
&& null orph_insts
&& 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_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
where
this_mod = mi_module iface0
semantic_mod = mi_semantic_module iface0
dflags = hsc_dflags hsc_env
(non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
(non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
(non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)
ann_fn = mkIfaceAnnCache (mi_anns iface0)
usages = [ case u of UsageFile _ fp fl -> UsageFile "" fp fl; _ -> u | u <- mi_usages iface0 ]
getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes hsc_env mods = do
let
dflags = hsc_dflags hsc_env
ctx = initSDocContext dflags defaultUserStyle
get_orph_hash mod = do
iface <- initIfaceLoad hsc_env . withException ctx
$ loadInterface (text "getOrphanHashes") mod ImportBySystem
return (mi_orphan_hash (mi_final_exts iface))
mapM get_orph_hash mods
type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
data IfaceDeclExtras
= IfaceIdExtras IfaceIdExtras
| IfaceDataExtras
(Maybe Fixity)
[IfaceInstABI]
[AnnPayload]
[IfaceIdExtras]
| IfaceClassExtras
(Maybe Fixity)
[IfaceInstABI]
[AnnPayload]
[IfaceIdExtras]
[IfExtName]
| IfaceSynonymExtras (Maybe Fixity) [AnnPayload]
| IfaceFamilyExtras (Maybe Fixity) [IfaceInstABI] [AnnPayload]
| IfaceOtherDeclExtras
data IfaceIdExtras
= IdExtras
(Maybe Fixity)
[IfaceRule]
[AnnPayload]
type IfaceInstABI = IfExtName
abiDecl :: IfaceDeclABI -> IfaceDecl
abiDecl (_, decl, _) = decl
cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`
getOccName (abiDecl abi2)
freeNamesDeclABI :: IfaceDeclABI -> NameSet
freeNamesDeclABI (_mod, decl, extras) =
freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras
freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
freeNamesDeclExtras (IfaceIdExtras id_extras)
= freeNamesIdExtras id_extras
freeNamesDeclExtras (IfaceDataExtras _ insts _ subs)
= unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms)
= unionNameSets $
mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs
freeNamesDeclExtras (IfaceSynonymExtras _ _)
= emptyNameSet
freeNamesDeclExtras (IfaceFamilyExtras _ insts _)
= mkNameSet insts
freeNamesDeclExtras IfaceOtherDeclExtras
= emptyNameSet
freeNamesIdExtras :: IfaceIdExtras -> NameSet
freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)
instance Outputable IfaceDeclExtras where
ppr IfaceOtherDeclExtras = Outputable.empty
ppr (IfaceIdExtras extras) = ppr_id_extras extras
ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]
ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]
ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
ppr_id_extras_s stuff]
ppr (IfaceClassExtras fix insts anns stuff defms) =
vcat [ppr fix, ppr_insts insts, ppr anns,
ppr_id_extras_s stuff, ppr defms]
ppr_insts :: [IfaceInstABI] -> SDoc
ppr_insts _ = text "<insts>"
ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)
ppr_id_extras :: IfaceIdExtras -> SDoc
ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)
instance Binary IfaceDeclExtras where
get _bh = panic "no get for IfaceDeclExtras"
put_ bh (IfaceIdExtras extras) = do
putByte bh 1; put_ bh extras
put_ bh (IfaceDataExtras fix insts anns cons) = do
putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons
put_ bh (IfaceClassExtras fix insts anns methods defms) = do
putByte bh 3
put_ bh fix
put_ bh insts
put_ bh anns
put_ bh methods
put_ bh defms
put_ bh (IfaceSynonymExtras fix anns) = do
putByte bh 4; put_ bh fix; put_ bh anns
put_ bh (IfaceFamilyExtras fix finsts anns) = do
putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns
put_ bh IfaceOtherDeclExtras = putByte bh 6
instance Binary IfaceIdExtras where
get _bh = panic "no get for IfaceIdExtras"
put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }
declExtras :: (OccName -> Maybe Fixity)
-> (OccName -> [AnnPayload])
-> OccEnv [IfaceRule]
-> OccEnv [IfaceClsInst]
-> OccEnv [IfaceFamInst]
-> OccEnv IfExtName
-> IfaceDecl
-> IfaceDeclExtras
declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl
= case decl of
IfaceId{} -> IfaceIdExtras (id_extras n)
IfaceData{ifCons=cons} ->
IfaceDataExtras (fix_fn n)
(map ifFamInstAxiom (lookupOccEnvL fi_env n) ++
map ifDFun (lookupOccEnvL inst_env n))
(ann_fn n)
(map (id_extras . occName . ifConName) (visibleIfConDecls cons))
IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->
IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms
where
insts = (map ifDFun $ (concatMap at_extras ats)
++ lookupOccEnvL inst_env n)
meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]
defms = [ dmName
| IfaceClassOp bndr _ (Just _) <- sigs
, let dmOcc = mkDefaultMethodOcc (nameOccName bndr)
, Just dmName <- [lookupOccEnv dm_env dmOcc] ]
IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)
(ann_fn n)
IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)
(map ifFamInstAxiom (lookupOccEnvL fi_env n))
(ann_fn n)
_other -> IfaceOtherDeclExtras
where
n = getOccName decl
id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)
at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)
lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
lookupOccEnvL env k = lookupOccEnv env k `orElse` []
mkOrphMap :: (decl -> IsOrphan)
-> [decl]
-> (OccEnv [decl],
[decl])
mkOrphMap get_key decls
= foldl' go (emptyOccEnv, []) decls
where
go (non_orphs, orphs) d
| NotOrphan occ <- get_key d
= (extendOccEnv_Acc (:) Utils.singleton non_orphs occ d, orphs)
| otherwise = (non_orphs, d:orphs)
mkHashFun
:: HscEnv
-> ExternalPackageState
-> (Name -> IO Fingerprint)
mkHashFun hsc_env eps name
| isHoleModule orig_mod
= lookup (mkHomeModule home_unit (moduleName orig_mod))
| otherwise
= lookup orig_mod
where
home_unit = hsc_home_unit hsc_env
dflags = hsc_dflags hsc_env
hpt = hsc_HUG hsc_env
pit = eps_PIT eps
ctx = initSDocContext dflags defaultUserStyle
occ = nameOccName name
orig_mod = nameModule name
lookup mod = do
massertPpr (isExternalName name) (ppr name)
iface <- case lookupIfaceByModule hpt pit mod of
Just iface -> return iface
Nothing ->
initIfaceLoad hsc_env . withException ctx
$ withoutDynamicNow
$ loadInterface (text "lookupVers2") mod ImportBySystem
return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`
pprPanic "lookupVers1" (ppr mod <+> ppr occ))
mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
mkIfaceAnnCache anns
= \n -> lookupOccEnv env n `orElse` []
where
pair (IfaceAnnotation target value) =
(case target of
NamedTarget occn -> occn
ModuleTarget _ -> mkVarOcc "module"
, [value])
env = mkOccEnv_C (flip (++)) (map pair anns)