module MkIface (
mkIface,
mkIfaceTc,
writeIfaceFile,
checkOldIface,
RecompileRequired(..), recompileRequired,
mkIfaceExports,
tyThingToIfaceDecl
) where
#include "HsVersions.h"
import IfaceSyn
import BinFingerprint
import LoadIface
import ToIface
import FlagChecker
import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies )
import Id
import Annotations
import CoreSyn
import Class
import TyCon
import CoAxiom
import ConLike
import DataCon
import Type
import TcType
import InstEnv
import FamInstEnv
import TcRnMonad
import HsSyn
import HscTypes
import Finder
import DynFlags
import VarEnv
import VarSet
import Var
import Name
import Avail
import RdrName
import NameEnv
import NameSet
import Module
import BinIface
import ErrUtils
import Digraph
import SrcLoc
import Outputable
import BasicTypes hiding ( SuccessFlag(..) )
import Unique
import Util hiding ( eqListBy )
import FastString
import Maybes
import Binary
import Fingerprint
import Exception
import UniqSet
import UniqDFM
import Packages
import Control.Monad
import Data.Function
import Data.List
import qualified Data.Map as Map
import Data.Ord
import Data.IORef
import System.Directory
import System.FilePath
mkIface :: HscEnv
-> Maybe Fingerprint
-> ModDetails
-> ModGuts
-> IO (ModIface,
Bool)
mkIface hsc_env maybe_old_fingerprint mod_details
ModGuts{ mg_module = this_mod,
mg_hsc_src = hsc_src,
mg_usages = usages,
mg_used_th = used_th,
mg_deps = deps,
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
mg_warns = warns,
mg_hpc_info = hpc_info,
mg_safe_haskell = safe_mode,
mg_trust_pkg = self_trust
}
= mkIface_ hsc_env maybe_old_fingerprint
this_mod hsc_src used_th deps rdr_env fix_env
warns hpc_info self_trust
safe_mode usages mod_details
mkIfaceTc :: HscEnv
-> Maybe Fingerprint
-> SafeHaskellMode
-> ModDetails
-> TcGblEnv
-> IO (ModIface, Bool)
mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
tc_result@TcGblEnv{ tcg_mod = this_mod,
tcg_src = hsc_src,
tcg_imports = imports,
tcg_rdr_env = rdr_env,
tcg_fix_env = fix_env,
tcg_merged = merged,
tcg_warns = warns,
tcg_hpc = other_hpc_info,
tcg_th_splice_used = tc_splice_used,
tcg_dependent_files = dependent_files
}
= do
let used_names = mkUsedNames tc_result
deps <- mkDependencies tc_result
let hpc_info = emptyHpcInfo other_hpc_info
used_th <- readIORef tc_splice_used
dep_files <- (readIORef dependent_files)
usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files merged
mkIface_ hsc_env maybe_old_fingerprint
this_mod hsc_src
used_th deps rdr_env
fix_env warns hpc_info
(imp_trust_own_pkg imports) safe_mode usages mod_details
mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
-> Bool -> Dependencies -> GlobalRdrEnv
-> NameEnv FixItem -> Warnings -> HpcInfo
-> Bool
-> SafeHaskellMode
-> [Usage]
-> ModDetails
-> IO (ModIface, Bool)
mkIface_ hsc_env maybe_old_fingerprint
this_mod hsc_src used_th deps rdr_env fix_env src_warns
hpc_info pkg_trust_req safe_mode usages
ModDetails{ md_insts = insts,
md_fam_insts = fam_insts,
md_rules = rules,
md_anns = anns,
md_vect_info = vect_info,
md_types = type_env,
md_exports = exports,
md_complete_sigs = complete_sigs }
= do
let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)
entities = typeEnvElts type_env
decls = [ tyThingToIfaceDecl entity
| entity <- entities,
let name = getName entity,
not (isImplicitTyThing entity),
not (isWiredInName name),
nameIsLocalOrFrom semantic_mod name ]
fixities = sortBy (comparing fst)
[(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
warns = src_warns
iface_rules = map coreRuleToIfaceRule rules
iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts
iface_fam_insts = map famInstToIfaceFamInst fam_insts
iface_vect_info = flattenVectInfo vect_info
trust_info = setSafeMode safe_mode
annotations = map mkIfaceAnnotation anns
icomplete_sigs = map mkIfaceCompleteSig complete_sigs
intermediate_iface = ModIface {
mi_module = this_mod,
mi_sig_of = if semantic_mod == this_mod
then Nothing
else Just semantic_mod,
mi_hsc_src = hsc_src,
mi_deps = deps,
mi_usages = usages,
mi_exports = mkIfaceExports exports,
mi_insts = sortBy cmp_inst iface_insts,
mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts,
mi_rules = sortBy cmp_rule iface_rules,
mi_vect_info = iface_vect_info,
mi_fixities = fixities,
mi_warns = warns,
mi_anns = annotations,
mi_globals = maybeGlobalRdrEnv rdr_env,
mi_iface_hash = fingerprint0,
mi_mod_hash = fingerprint0,
mi_flag_hash = fingerprint0,
mi_exp_hash = fingerprint0,
mi_used_th = used_th,
mi_orphan_hash = fingerprint0,
mi_orphan = False,
mi_finsts = False,
mi_decls = deliberatelyOmitted "decls",
mi_hash_fn = deliberatelyOmitted "hash_fn",
mi_hpc = isHpcUsed hpc_info,
mi_trust = trust_info,
mi_trust_pkg = pkg_trust_req,
mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities,
mi_complete_sigs = icomplete_sigs }
(new_iface, no_change_at_all)
<-
addFingerprints hsc_env maybe_old_fingerprint
intermediate_iface decls
dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
(pprModIface new_iface)
let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
return (final_iface, no_change_at_all)
where
cmp_rule = comparing ifRuleName
cmp_inst = comparing (nameOccName . ifDFun)
cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)
dflags = hsc_dflags hsc_env
maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
maybeGlobalRdrEnv rdr_env
| targetRetainsAllBindings (hscTarget dflags) = Just rdr_env
| otherwise = Nothing
deliberatelyOmitted :: String -> a
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
ifFamInstTcName = ifFamInstFam
flattenVectInfo (VectInfo { vectInfoVar = vVar
, vectInfoTyCon = vTyCon
, vectInfoParallelVars = vParallelVars
, vectInfoParallelTyCons = vParallelTyCons
}) =
IfaceVectInfo
{ ifaceVectInfoVar = [Var.varName v | (v, _ ) <- dVarEnvElts vVar]
, ifaceVectInfoTyCon = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]
, ifaceVectInfoTyConReuse = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t == t_v]
, ifaceVectInfoParallelVars = [Var.varName v | v <- dVarSetElems vParallelVars]
, ifaceVectInfoParallelTyCons = nameSetElemsStable vParallelTyCons
}
writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
writeIfaceFile dflags hi_file_path new_iface
= do createDirectoryIfMissing True (takeDirectory hi_file_path)
writeBinIface dflags hi_file_path new_iface
mkHashFun
:: HscEnv
-> ExternalPackageState
-> (Name -> IO Fingerprint)
mkHashFun hsc_env eps name
| isHoleModule orig_mod
= lookup (mkModule (thisPackage 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 dflags 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 iface occ `orElse`
pprPanic "lookupVers1" (ppr mod <+> ppr occ))
addFingerprints
:: HscEnv
-> Maybe Fingerprint
-> ModIface
-> [IfaceDecl]
-> IO (ModIface,
Bool)
addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
= do
eps <- hscEPS hsc_env
let
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 decl
edges :: [(IfaceDeclABI, Unique, [Unique])]
edges = [ (abi, getUnique (getOccName decl), out)
| decl <- new_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 new_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 decls = map abiDecl abis
local_env1 <- foldM extend_hash_env local_env
(zip (repeat fingerprint0) decls)
let hash_fn = mk_put_name local_env1
let stable_abis = sortBy cmp_abiNames abis
hash <- computeFingerprint hash_fn stable_abis
let pairs = zip (repeat hash) decls
local_env2 <- foldM extend_hash_env local_env pairs
return (local_env2, pairs ++ decls_w_hashes)
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 = Map.elems $ Map.fromList $
[(getOccName d, e) | e@(_, d) <- decls_w_hashes]
flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
mod_hash <- computeFingerprint putNameLiterally
(map fst sorted_decls,
export_hash,
mi_warns iface0,
mi_vect_info iface0)
iface_hash <- computeFingerprint putNameLiterally
(mod_hash,
ann_fn (mkVarOcc "module"),
mi_usages iface0,
sorted_deps,
mi_hpc iface0)
let
no_change_at_all = Just iface_hash == mb_old_fingerprint
final_iface = iface0 {
mi_mod_hash = mod_hash,
mi_iface_hash = iface_hash,
mi_exp_hash = export_hash,
mi_orphan_hash = orphan_hash,
mi_flag_hash = flag_hash,
mi_orphan = not ( all ifRuleAuto orph_rules
&& null orph_insts
&& null orph_fis
&& isNoIfaceVectInfo (mi_vect_info iface0)),
mi_finsts = not . null $ mi_fam_insts iface0,
mi_decls = sorted_decls,
mi_hash_fn = lookupOccEnv local_env }
return (final_iface, no_change_at_all)
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)
fix_fn = mi_fix_fn 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
dflags = hsc_dflags hsc_env
get_orph_hash mod =
case lookupIfaceByModule dflags hpt pit mod of
Just iface -> return (mi_orphan_hash iface)
Nothing -> do
iface <- initIfaceLoad hsc_env . withException
$ loadInterface (text "getOrphanHashes") mod ImportBySystem
return (mi_orphan_hash iface)
mapM get_orph_hash mods
sortDependencies :: Dependencies -> Dependencies
sortDependencies d
= Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (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) }
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)
type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
data IfaceDeclExtras
= IfaceIdExtras IfaceIdExtras
| IfaceDataExtras
(Maybe Fixity)
[IfaceInstABI]
[AnnPayload]
[IfaceIdExtras]
| IfaceClassExtras
(Maybe Fixity)
[IfaceInstABI]
[AnnPayload]
[IfaceIdExtras]
| 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)
= unionNameSets (mkNameSet insts : 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) = vcat [ppr fix, ppr_insts insts, ppr anns,
ppr_id_extras_s stuff]
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) = do
putByte bh 3; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh methods
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]
-> IfaceDecl
-> IfaceDeclExtras
declExtras fix_fn ann_fn rule_env inst_env fi_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)
(map ifDFun $ (concatMap at_extras ats)
++ lookupOccEnvL inst_env n)
(ann_fn n)
[id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]
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 (:) singleton non_orphs occ d, orphs)
| otherwise = (non_orphs, d:orphs)
mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc
mkIfaceAnnotation :: Annotation -> IfaceAnnotation
mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })
= IfaceAnnotation {
ifAnnotatedTarget = fmap nameOccName target,
ifAnnotatedValue = payload
}
mkIfaceExports :: [AvailInfo] -> [IfaceExport]
mkIfaceExports exports
= sortBy stableAvailCmp (map sort_subs exports)
where
sort_subs :: AvailInfo -> AvailInfo
sort_subs (Avail n) = Avail n
sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
sort_subs (AvailTC n (m:ms) fs)
| n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
| otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)
sort_flds = sortBy (stableNameCmp `on` flSelector)
data RecompileRequired
= UpToDate
| MustCompile
| RecompBecause String
deriving Eq
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 moduleUnitId (mi_module iface) /= thisPackage (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 <- 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 <- checkDependencies hsc_env mod_summary iface
; if recompileRequired recomp then return (recomp, Just iface) else do {
; updateEps_ $ \eps -> eps { eps_is_boot = udfmToUfm mod_deps }
; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
; return (recomp, Just iface)
}}}}}}
where
this_pkg = thisPackage (hsc_dflags hsc_env)
mod_deps :: DModuleNameEnv (ModuleName, IsBootInterface)
mod_deps = mkModDeps (dep_mods (mi_deps iface))
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( moduleUnitId outer_mod == thisPackage dflags )
case inner_mod == mi_semantic_module iface of
True -> up_to_date (text "implementing module unchanged")
False -> return (RecompBecause "implementing module changed")
checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
checkFlagHash hsc_env iface = do
let old_hash = mi_flag_hash 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
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 (pkgState dflags)) of
Nothing -> []
Just r -> sort $ map (indefModuleToModule 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
= checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
where
prev_dep_mods = dep_mods (mi_deps iface)
prev_dep_pkgs = dep_pkgs (mi_deps iface)
this_pkg = thisPackage (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 fst prev_dep_mods
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " not among previous dependencies"
return (RecompBecause reason)
else
return UpToDate
| otherwise
-> if toInstalledUnitId 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 = moduleUnitId mod
_otherwise -> return (RecompBecause reason)
needInterface :: Module -> (ModIface -> IfG RecompileRequired)
-> IfG RecompileRequired
needInterface mod continue
= do
let doc_str = sep [text "need version info for", ppr mod]
traceHiDiffs (text "Checking usages 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 MustCompile
Succeeded iface -> continue iface
checkModUsage :: UnitId -> 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 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 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 iface
new_decl_hash = mi_hash_fn iface
new_export_hash = mi_exp_hash 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 handle $ do
new_hash <- getFileHash file
if (old_hash /= new_hash)
then return recomp
else return UpToDate
where
recomp = RecompBecause (file ++ " changed")
handle =
#ifdef 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
tyThingToIfaceDecl :: TyThing -> IfaceDecl
tyThingToIfaceDecl (AnId id) = idToIfaceDecl id
tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)
tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax
tyThingToIfaceDecl (AConLike cl) = case cl of
RealDataCon dc -> dataConToIfaceDecl dc
PatSynCon ps -> patSynToIfaceDecl ps
idToIfaceDecl :: Id -> IfaceDecl
idToIfaceDecl id
= IfaceId { ifName = getName id,
ifType = toIfaceType (idType id),
ifIdDetails = toIfaceIdDetails (idDetails id),
ifIdInfo = toIfaceIdInfo (idInfo id) }
dataConToIfaceDecl :: DataCon -> IfaceDecl
dataConToIfaceDecl dataCon
= IfaceId { ifName = getName dataCon,
ifType = toIfaceType (dataConUserType dataCon),
ifIdDetails = IfVanillaId,
ifIdInfo = NoInfo }
coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
, co_ax_role = role })
= IfaceAxiom { ifName = getName ax
, ifTyCon = toIfaceTyCon tycon
, ifRole = role
, ifAxBranches = map (coAxBranchToIfaceBranch tycon
(map coAxBranchLHS branch_list))
branch_list }
where
branch_list = fromBranches branches
coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch tc lhs_s
branch@(CoAxBranch { cab_incomps = incomps })
= (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps }
where
iface_incomps = map (expectJust "iface_incomps"
. (flip findIndex lhs_s
. eqTypes)
. coAxBranchLHS) incomps
coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
, cab_lhs = lhs
, cab_roles = roles, cab_rhs = rhs })
= IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tidy_tvs
, ifaxbCoVars = map toIfaceIdBndr cvs
, ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs
, ifaxbRoles = roles
, ifaxbRHS = tidyToIfaceType env1 rhs
, ifaxbIncomps = [] }
where
(env1, tidy_tvs) = tidyTyCoVarBndrs emptyTidyEnv tvs
tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
tyConToIfaceDecl env tycon
| Just clas <- tyConClass_maybe tycon
= classToIfaceDecl env clas
| Just syn_rhs <- synTyConRhs_maybe tycon
= ( tc_env1
, IfaceSynonym { ifName = getName tycon,
ifRoles = tyConRoles tycon,
ifSynRhs = if_syn_type syn_rhs,
ifBinders = if_binders,
ifResKind = if_res_kind
})
| Just fam_flav <- famTyConFlav_maybe tycon
= ( tc_env1
, IfaceFamily { ifName = getName tycon,
ifResVar = if_res_var,
ifFamFlav = to_if_fam_flav fam_flav,
ifBinders = if_binders,
ifResKind = if_res_kind,
ifFamInj = familyTyConInjectivityInfo tycon
})
| isAlgTyCon tycon
= ( tc_env1
, IfaceData { ifName = getName tycon,
ifBinders = if_binders,
ifResKind = if_res_kind,
ifCType = tyConCType tycon,
ifRoles = tyConRoles tycon,
ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
ifCons = ifaceConDecls (algTyConRhs tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifParent = parent })
| otherwise
= ( env
, IfaceData { ifName = getName tycon,
ifBinders = if_binders,
ifResKind = if_res_kind,
ifCType = Nothing,
ifRoles = tyConRoles tycon,
ifCtxt = [],
ifCons = IfDataTyCon [],
ifGadtSyntax = False,
ifParent = IfNoParent })
where
(tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
tc_tyvars = binderVars tc_binders
if_binders = toIfaceTyVarBinders tc_binders
if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon)
if_syn_type ty = tidyToIfaceType tc_env1 ty
if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon
parent = case tyConFamInstSig_maybe tycon of
Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
(toIfaceTyCon tc)
(tidyToIfaceTcArgs tc_env1 tc ty)
Nothing -> IfNoParent
to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
= IfaceClosedSynFamilyTyCon (Just (axn, ibr))
where defs = fromBranches $ coAxiomBranches ax
ibr = map (coAxBranchToIfaceBranch' tycon) defs
axn = coAxiomName ax
to_if_fam_flav (ClosedSynFamilyTyCon Nothing)
= IfaceClosedSynFamilyTyCon Nothing
to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon
to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon
ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon [ifaceConDecl con]
ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
ifaceConDecls AbstractTyCon = IfAbstractTyCon
ifaceConDecl data_con
= IfCon { ifConName = dataConName data_con,
ifConInfix = dataConIsInfix data_con,
ifConWrapper = isJust (dataConWrapId_maybe data_con),
ifConExTvs = map toIfaceForAllBndr ex_bndrs',
ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec,
ifConCtxt = tidyToIfaceContext con_env2 theta,
ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
ifConFields = dataConFieldLabels data_con,
ifConStricts = map (toIfaceBang con_env2)
(dataConImplBangs data_con),
ifConSrcStricts = map toIfaceSrcBang
(dataConSrcBangs data_con)}
where
(univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _)
= dataConFullSig data_con
ex_bndrs = dataConExTyVarBinders data_con
con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
(con_env2, ex_bndrs') = tidyTyVarBinders con_env1 ex_bndrs
to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)
classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
classToIfaceDecl env clas
= ( env1
, IfaceClass { ifName = getName tycon,
ifRoles = tyConRoles (classTyCon clas),
ifBinders = toIfaceTyVarBinders tc_binders,
ifBody = body,
ifFDs = map toIfaceFD clas_fds })
where
(_, clas_fds, sc_theta, _, clas_ats, op_stuff)
= classExtraBigSig clas
tycon = classTyCon clas
body | isAbstractTyCon tycon = IfAbstractClass
| otherwise
= IfConcreteClass {
ifClassCtxt = tidyToIfaceContext env1 sc_theta,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
ifMinDef = fmap getOccFS (classMinimalDef clas)
}
(env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
toIfaceAT :: ClassATItem -> IfaceAT
toIfaceAT (ATI tc def)
= IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)
where
(env2, if_decl) = tyConToIfaceDecl env1 tc
toIfaceClassOp (sel_id, def_meth)
= ASSERT( sel_tyvars == binderVars tc_binders )
IfaceClassOp (getName sel_id)
(tidyToIfaceType env1 op_ty)
(fmap toDmSpec def_meth)
where
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty
toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType
toDmSpec (_, VanillaDM) = VanillaDM
toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)
toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1
,map (tidyTyVar env1) tvs2)
tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
tidyTyConBinder env@(_, subst) tvb@(TvBndr tv vis)
= case lookupVarEnv subst tv of
Just tv' -> (env, TvBndr tv' vis)
Nothing -> tidyTyVarBinder env tvb
tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
tidyTyConBinders = mapAccumL tidyTyConBinder
tidyTyVar :: TidyEnv -> TyVar -> FastString
tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
instanceToIfaceInst :: ClsInst -> IfaceClsInst
instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
, is_cls_nm = cls_name, is_cls = cls
, is_tcs = mb_tcs
, is_orphan = orph })
= ASSERT( cls_name == className cls )
IfaceClsInst { ifDFun = dfun_name,
ifOFlag = oflag,
ifInstCls = cls_name,
ifInstTys = map do_rough mb_tcs,
ifInstOrph = orph }
where
do_rough Nothing = Nothing
do_rough (Just n) = Just (toIfaceTyCon_name n)
dfun_name = idName dfun_id
famInstToIfaceFamInst :: FamInst -> IfaceFamInst
famInstToIfaceFamInst (FamInst { fi_axiom = axiom,
fi_fam = fam,
fi_tcs = roughs })
= IfaceFamInst { ifFamInstAxiom = coAxiomName axiom
, ifFamInstFam = fam
, ifFamInstTys = map do_rough roughs
, ifFamInstOrph = orph }
where
do_rough Nothing = Nothing
do_rough (Just n) = Just (toIfaceTyCon_name n)
fam_decl = tyConName $ coAxiomTyCon axiom
mod = ASSERT( isExternalName (coAxiomName axiom) )
nameModule (coAxiomName axiom)
is_local name = nameIsLocalOrFrom mod name
lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
orph | is_local fam_decl
= NotOrphan (nameOccName fam_decl)
| otherwise
= chooseOrphanAnchor lhs_names
coreRuleToIfaceRule :: CoreRule -> IfaceRule
coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})
= pprTrace "toHsRule: builtin" (ppr fn) $
bogusIfaceRule fn
coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,
ru_act = act, ru_bndrs = bndrs,
ru_args = args, ru_rhs = rhs,
ru_orphan = orph, ru_auto = auto })
= IfaceRule { ifRuleName = name, ifActivation = act,
ifRuleBndrs = map toIfaceBndr bndrs,
ifRuleHead = fn,
ifRuleArgs = map do_arg args,
ifRuleRhs = toIfaceExpr rhs,
ifRuleAuto = auto,
ifRuleOrph = orph }
where
do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
do_arg (Coercion co) = IfaceCo (toIfaceCoercion co)
do_arg arg = toIfaceExpr arg
bogusIfaceRule :: Name -> IfaceRule
bogusIfaceRule id_name
= IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,
ifRuleAuto = True }