module GHC.Iface.Recomp
( checkOldIface
, RecompileRequired(..)
, recompileRequired
, addFingerprints
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Iface.Syntax
import GHC.Iface.Recomp.Binary
import GHC.Iface.Load
import GHC.Iface.Recomp.Flags
import GHC.Types.Annotations
import GHC.Core
import GHC.Tc.Utils.Monad
import GHC.Hs
import GHC.Driver.Types
import GHC.Driver.Finder
import GHC.Driver.Session
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Unit.Module
import GHC.Utils.Error
import GHC.Data.Graph.Directed
import GHC.Types.SrcLoc
import GHC.Utils.Outputable as Outputable
import GHC.Types.Unique
import GHC.Utils.Misc as Utils hiding ( eqListBy )
import GHC.Data.Maybe
import GHC.Utils.Binary
import GHC.Utils.Fingerprint
import GHC.Utils.Exception
import GHC.Types.Unique.Set
import GHC.Unit.State
import Control.Monad
import Data.Function
import Data.List (find, sortBy, sort)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Word (Word64)
import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins )
import qualified Data.Semigroup
data RecompileRequired
= UpToDate
| MustCompile
| RecompBecause String
deriving Eq
instance Semigroup RecompileRequired where
UpToDate <> r = r
mc <> _ = mc
instance Monoid RecompileRequired where
mempty = UpToDate
recompileRequired :: RecompileRequired -> Bool
recompileRequired UpToDate = False
recompileRequired _ = True
checkOldIface
:: HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> IO (RecompileRequired, Maybe ModIface)
checkOldIface hsc_env mod_summary source_modified maybe_iface
= do let dflags = hsc_dflags hsc_env
showPass dflags $
"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 source_modified maybe_iface
check_old_iface
:: HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> IfG (RecompileRequired, Maybe ModIface)
check_old_iface hsc_env mod_summary src_modified maybe_iface
= let dflags = hsc_dflags hsc_env
getIface =
case maybe_iface of
Just _ -> do
traceIf (text "We already have the old interface for" <+>
ppr (ms_mod mod_summary))
return maybe_iface
Nothing -> loadIface
loadIface = do
let iface_path = msHiFilePath mod_summary
read_result <- readIface (ms_mod mod_summary) iface_path
case read_result of
Failed err -> do
traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)
traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)
return Nothing
Succeeded iface -> do
traceIf (text "Read the interface file" <+> text iface_path)
return $ Just iface
src_changed
| gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
| SourceModified <- src_modified = True
| otherwise = False
in do
when src_changed $
traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")
case src_changed of
True | not (isObjectTarget $ hscTarget dflags) ->
return (MustCompile, maybe_iface)
True -> do
maybe_iface' <- getIface
return (MustCompile, maybe_iface')
False -> do
maybe_iface' <- getIface
case maybe_iface' of
Nothing -> return (MustCompile, Nothing)
Just iface -> checkVersions hsc_env mod_summary iface
checkVersions :: HscEnv
-> ModSummary
-> ModIface
-> IfG (RecompileRequired, Maybe ModIface)
checkVersions hsc_env mod_summary iface
= do { traceHiDiffs (text "Considering whether compilation is required for" <+>
ppr (mi_module iface) <> colon)
; if moduleUnit (mi_module iface) /= homeUnit (hsc_dflags hsc_env)
then return (RecompBecause "-this-unit-id changed", Nothing) else do {
; recomp <- checkFlagHash hsc_env iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
; recomp <- checkOptimHash hsc_env iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
; recomp <- checkHpcHash hsc_env iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
; recomp <- checkMergedSignatures mod_summary iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
; recomp <- checkHsig mod_summary iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
; recomp <- checkHie mod_summary
; if recompileRequired recomp then return (recomp, Nothing) else do {
; recomp <- checkDependencies hsc_env mod_summary iface
; if recompileRequired recomp then return (recomp, Just iface) else do {
; recomp <- checkPlugins hsc_env iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
; return (recomp, Just iface)
}}}}}}}}}}
where
this_pkg = homeUnit (hsc_dflags hsc_env)
mod_deps :: ModuleNameEnv ModuleNameWithIsBoot
mod_deps = mkModDeps (dep_mods (mi_deps 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)
pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))
return $
pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr
fingerprintPlugins :: HscEnv -> IO Fingerprint
fingerprintPlugins hsc_env = do
fingerprintPlugins' $ plugins (hsc_dflags hsc_env)
fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint
fingerprintPlugins' plugins = do
res <- mconcat <$> mapM pluginRecompile' plugins
return $ case res 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 -> RecompBecause "Impure plugin forced recompilation"
| old_fp `elem` magic_fingerprints ||
new_fp `elem` magic_fingerprints
= RecompBecause "Plugins changed"
| otherwise =
let reason = "Plugin fingerprint changed" in
case pr of
ForceRecompile -> RecompBecause reason
_ -> RecompBecause reason
where
magic_fingerprints =
[ fingerprintString "NoForceRecompile"
, fingerprintString "ForceRecompile"
]
checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
checkHsig mod_summary iface = do
dflags <- getDynFlags
let outer_mod = ms_mod mod_summary
inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)
MASSERT( moduleUnit outer_mod == homeUnit dflags )
case inner_mod == mi_semantic_module iface of
True -> up_to_date (text "implementing module unchanged")
False -> return (RecompBecause "implementing module changed")
checkHie :: ModSummary -> IfG RecompileRequired
checkHie mod_summary = do
dflags <- getDynFlags
let hie_date_opt = ms_hie_date mod_summary
hs_date = ms_hs_date mod_summary
pure $ case gopt Opt_WriteHie dflags of
False -> UpToDate
True -> case hie_date_opt of
Nothing -> RecompBecause "HIE file is missing"
Just hie_date
| hie_date < hs_date
-> RecompBecause "HIE file is out of date"
| otherwise
-> UpToDate
checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkFlagHash hsc_env iface = do
let old_hash = mi_flag_hash (mi_final_exts iface)
new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)
(mi_module iface)
putNameLiterally
case old_hash == new_hash of
True -> up_to_date (text "Module flags unchanged")
False -> out_of_date_hash "flags changed"
(text " Module flags have changed")
old_hash new_hash
checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkOptimHash hsc_env iface = do
let old_hash = mi_opt_hash (mi_final_exts iface)
new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)
putNameLiterally
if | old_hash == new_hash
-> up_to_date (text "Optimisation flags unchanged")
| gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)
-> up_to_date (text "Optimisation flags changed; ignoring")
| otherwise
-> out_of_date_hash "Optimisation flags changed"
(text " Optimisation flags have changed")
old_hash new_hash
checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkHpcHash hsc_env iface = do
let old_hash = mi_hpc_hash (mi_final_exts iface)
new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)
putNameLiterally
if | old_hash == new_hash
-> up_to_date (text "HPC flags unchanged")
| gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)
-> up_to_date (text "HPC flags changed; ignoring")
| otherwise
-> out_of_date_hash "HPC flags changed"
(text " HPC flags have changed")
old_hash new_hash
checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired
checkMergedSignatures mod_summary iface = do
dflags <- getDynFlags
let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]
new_merged = case Map.lookup (ms_mod_name mod_summary)
(requirementContext (unitState dflags)) of
Nothing -> []
Just r -> sort $ map (instModuleToModule (unitState dflags)) r
if old_merged == new_merged
then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)
else return (RecompBecause "signatures to merge in changed")
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
checkList $
[ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
, do
(recomp, mnames_seen) <- runUntilRecompRequired $ map
checkForNewHomeDependency
(ms_home_imps summary)
case recomp of
UpToDate -> do
let
seen_home_deps = Set.unions $ map Set.fromList mnames_seen
checkIfAllOldHomeDependenciesAreSeen seen_home_deps
_ -> return recomp]
where
prev_dep_mods = dep_mods (mi_deps iface)
prev_dep_plgn = dep_plgins (mi_deps iface)
prev_dep_pkgs = dep_pkgs (mi_deps iface)
this_pkg = homeUnit (hsc_dflags hsc_env)
dep_missing (mb_pkg, L _ mod) = do
find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)
let reason = moduleNameString mod ++ " changed"
case find_res of
Found _ mod
| pkg == this_pkg
-> if moduleName mod `notElem` map gwib_mod prev_dep_mods ++ prev_dep_plgn
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " not among previous dependencies"
return (RecompBecause reason)
else
return UpToDate
| otherwise
-> if toUnitId pkg `notElem` (map fst prev_dep_pkgs)
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " is from package " <> quotes (ppr pkg) <>
text ", which is not among previous dependencies"
return (RecompBecause reason)
else
return UpToDate
where pkg = moduleUnit mod
_otherwise -> return (RecompBecause reason)
projectNonBootNames = map gwib_mod . filter ((== NotBoot) . gwib_isBoot)
old_deps = Set.fromList
$ projectNonBootNames prev_dep_mods
isOldHomeDeps = flip Set.member old_deps
checkForNewHomeDependency (L _ mname) = do
let
mod = mkModule this_pkg mname
str_mname = moduleNameString mname
reason = str_mname ++ " changed"
if not (isOldHomeDeps mname)
then return (UpToDate, [])
else do
mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do
let mnames = mname:(map gwib_mod $ filter ((== NotBoot) . gwib_isBoot) $
dep_mods $ mi_deps imported_iface)
case find (not . isOldHomeDeps) mnames of
Nothing -> return (UpToDate, mnames)
Just new_dep_mname -> do
traceHiDiffs $
text "imported home module " <> quotes (ppr mod) <>
text " has a new dependency " <> quotes (ppr new_dep_mname)
return (RecompBecause reason, [])
return $ fromMaybe (MustCompile, []) mb_result
runUntilRecompRequired [] = return (UpToDate, [])
runUntilRecompRequired (check:checks) = do
(recompile, value) <- check
if recompileRequired recompile
then return (recompile, [])
else do
(recomp, values) <- runUntilRecompRequired checks
return (recomp, value:values)
checkIfAllOldHomeDependenciesAreSeen seen_deps = do
let unseen_old_deps = Set.difference
old_deps
seen_deps
if not (null unseen_old_deps)
then do
let missing_dep = Set.elemAt 0 unseen_old_deps
traceHiDiffs $
text "missing old home dependency " <> quotes (ppr missing_dep)
return $ RecompBecause "missing old dependency"
else return UpToDate
needInterface :: Module -> (ModIface -> IfG RecompileRequired)
-> IfG RecompileRequired
needInterface mod continue
= do
mb_recomp <- getFromModIface
"need version info for"
mod
continue
case mb_recomp of
Nothing -> return MustCompile
Just recomp -> return recomp
getFromModIface :: String -> Module -> (ModIface -> IfG a)
-> IfG (Maybe a)
getFromModIface doc_msg mod getter
= do
let doc_str = sep [text doc_msg, ppr mod]
traceHiDiffs (text "Checking innterface for module" <+> ppr mod)
mb_iface <- loadInterface doc_str mod ImportBySystem
case mb_iface of
Failed _ -> do
traceHiDiffs (sep [text "Couldn't load interface for module",
ppr mod])
return Nothing
Succeeded iface -> Just <$> getter iface
checkModUsage :: Unit -> Usage -> IfG RecompileRequired
checkModUsage _this_pkg UsagePackageModule{
usg_mod = mod,
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))
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))
checkModUsage this_pkg UsageHomeModule{
usg_mod_name = mod_name,
usg_mod_hash = old_mod_hash,
usg_exports = maybe_old_export_hash,
usg_entities = old_decl_hash }
= do
let mod = mkModule this_pkg mod_name
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 = moduleNameString mod_name ++ " changed"
recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash
if not (recompileRequired recompile)
then return UpToDate
else do
checkMaybeHash reason maybe_old_export_hash new_export_hash
(text " Export list changed") $ do
recompile <- checkList [ checkEntityUsage reason new_decl_hash u
| u <- old_decl_hash]
if recompileRequired recompile
then return recompile
else up_to_date (text " Great! The bits I use are up to date")
checkModUsage _this_pkg UsageFile{ usg_file_path = file,
usg_file_hash = old_hash } =
liftIO $
handleIO handler $ do
new_hash <- getFileHash file
if (old_hash /= new_hash)
then return recomp
else return UpToDate
where
recomp = RecompBecause (file ++ " changed")
handler =
#if defined(DEBUG)
\e -> pprTrace "UsageFile" (text (show e)) $ return recomp
#else
\_ -> return recomp
#endif
checkModuleFingerprint :: String -> Fingerprint -> Fingerprint
-> IfG RecompileRequired
checkModuleFingerprint reason old_mod_hash new_mod_hash
| new_mod_hash == old_mod_hash
= up_to_date (text "Module fingerprint unchanged")
| otherwise
= out_of_date_hash reason (text " Module fingerprint has changed")
old_mod_hash new_mod_hash
checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc
-> IfG RecompileRequired -> IfG RecompileRequired
checkMaybeHash reason maybe_old_hash new_hash doc continue
| Just hash <- maybe_old_hash, hash /= new_hash
= out_of_date_hash reason doc hash new_hash
| otherwise
= continue
checkEntityUsage :: String
-> (OccName -> Maybe (OccName, Fingerprint))
-> (OccName, Fingerprint)
-> IfG RecompileRequired
checkEntityUsage reason new_hash (name,old_hash)
= case new_hash name of
Nothing ->
out_of_date reason (sep [text "No longer exported:", ppr name])
Just (_, new_hash)
| new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
return UpToDate
| otherwise -> out_of_date_hash reason (text " Out of date:" <+> ppr name)
old_hash new_hash
up_to_date :: SDoc -> IfG RecompileRequired
up_to_date msg = traceHiDiffs msg >> return UpToDate
out_of_date :: String -> SDoc -> IfG RecompileRequired
out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)
out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
out_of_date_hash reason msg old_hash new_hash
= out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
checkList [] = return UpToDate
checkList (check:checks) = do recompile <- check
if recompileRequired recompile
then return recompile
else checkList checks
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 = ASSERT2( 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
= ASSERT2( 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) = do
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 = sortDependencies (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)
export_hash <- computeFingerprint putNameLiterally
(mi_exports iface0,
orphan_hash,
dep_orphan_hashes,
dep_pkgs (mi_deps iface0),
dep_finsts (mi_deps iface0),
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 dflags this_mod putNameLiterally
opt_hash <- fingerprintOptFlags dflags putNameLiterally
hpc_hash <- fingerprintHpcFlags dflags putNameLiterally
plugin_hash <- fingerprintPlugins hsc_env
mod_hash <- computeFingerprint putNameLiterally
(map fst sorted_decls,
export_hash,
mi_warns iface0)
iface_hash <- computeFingerprint putNameLiterally
(mod_hash,
ann_fn (mkVarOcc "module"),
mi_usages iface0,
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)
getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes hsc_env mods = do
eps <- hscEPS hsc_env
let
hpt = hsc_HPT hsc_env
pit = eps_PIT eps
get_orph_hash mod =
case lookupIfaceByModule hpt pit mod of
Just iface -> return (mi_orphan_hash (mi_final_exts iface))
Nothing -> do
iface <- initIfaceLoad hsc_env . withException
$ loadInterface (text "getOrphanHashes") mod ImportBySystem
return (mi_orphan_hash (mi_final_exts iface))
mapM get_orph_hash mods
sortDependencies :: Dependencies -> Dependencies
sortDependencies d
= Deps { dep_mods = sortBy (compare `on` (moduleNameFS . gwib_mod)) (dep_mods d),
dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d),
dep_orphs = sortBy stableModuleCmp (dep_orphs d),
dep_finsts = sortBy stableModuleCmp (dep_finsts d),
dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }
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 dflags (moduleName orig_mod))
| otherwise
= lookup orig_mod
where
dflags = hsc_dflags hsc_env
hpt = hsc_HPT hsc_env
pit = eps_PIT eps
occ = nameOccName name
orig_mod = nameModule name
lookup mod = do
MASSERT2( isExternalName name, ppr name )
iface <- case lookupIfaceByModule hpt pit mod of
Just iface -> return iface
Nothing -> do
iface <- initIfaceLoad hsc_env . withException
$ loadInterface (text "lookupVers2") mod ImportBySystem
return iface
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)