%
% (c) The University of Glasgow 20062008
% (c) The GRASP/AQUA Project, Glasgow University, 19931998
%
\begin{code}
module MkIface (
mkUsedNames,
mkDependencies,
mkIface,
mkIfaceTc,
writeIfaceFile,
checkOldIface,
tyThingToIfaceDecl
) where
\end{code}
Recompilation checking
A complete description of how recompilation checking works can be
found in the wiki commentary:
http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
Please read the above page for a topdown description of how this all
works. Notes below cover specific issues related to the implementation.
Basic idea:
* In the mi_usages information in an interface, we record the
fingerprint of each free variable of the module
* In mkIface, we compute the fingerprint of each exported thing A.f.
For each external thing that A.f refers to, we include the fingerprint
of the external reference when computing the fingerprint of A.f. So
if anything that A.f depends on changes, then A.f's fingerprint will
change.
* In checkOldIface we compare the mi_usages for the module with
the actual fingerprint for all each thing recorded in mi_usages
\begin{code}
#include "HsVersions.h"
import IfaceSyn
import LoadIface
import Id
import IdInfo
import NewDemand
import Annotations
import CoreSyn
import CoreFVs
import Class
import TyCon
import DataCon
import Type
import TcType
import InstEnv
import FamInstEnv
import TcRnMonad
import HsSyn
import HscTypes
import Finder
import DynFlags
import VarEnv
import Var
import Name
import RdrName
import NameEnv
import NameSet
import Module
import BinIface
import ErrUtils
import Digraph
import SrcLoc
import Outputable
import BasicTypes hiding ( SuccessFlag(..) )
import LazyUniqFM
import Unique
import Util hiding ( eqListBy )
import FiniteMap
import FastString
import Maybes
import ListSetOps
import Binary
import Fingerprint
import Bag
import Control.Monad
import Data.List
import Data.IORef
import System.FilePath
\end{code}
%************************************************************************
%* *
\subsection{Completing an interface}
%* *
%************************************************************************
\begin{code}
mkIface :: HscEnv
-> Maybe Fingerprint
-> ModDetails
-> ModGuts
-> IO (Messages,
Maybe (ModIface,
Bool))
mkIface hsc_env maybe_old_fingerprint mod_details
ModGuts{ mg_module = this_mod,
mg_boot = is_boot,
mg_used_names = used_names,
mg_deps = deps,
mg_dir_imps = dir_imp_mods,
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
mg_warns = warns,
mg_hpc_info = hpc_info }
= mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names deps rdr_env
fix_env warns hpc_info dir_imp_mods mod_details
mkIfaceTc :: HscEnv
-> Maybe Fingerprint
-> ModDetails
-> TcGblEnv
-> IO (Messages, Maybe (ModIface, Bool))
mkIfaceTc hsc_env maybe_old_fingerprint 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_warns = warns,
tcg_hpc = other_hpc_info
}
= do
used_names <- mkUsedNames tc_result
deps <- mkDependencies tc_result
let hpc_info = emptyHpcInfo other_hpc_info
mkIface_ hsc_env maybe_old_fingerprint
this_mod (isHsBoot hsc_src) used_names deps rdr_env
fix_env warns hpc_info (imp_mods imports) mod_details
mkUsedNames :: TcGblEnv -> IO NameSet
mkUsedNames
TcGblEnv{ tcg_inst_uses = dfun_uses_var,
tcg_dus = dus
}
= do
dfun_uses <- readIORef dfun_uses_var
return (allUses dus `unionNameSets` dfun_uses)
mkDependencies :: TcGblEnv -> IO Dependencies
mkDependencies
TcGblEnv{ tcg_mod = mod,
tcg_imports = imports,
tcg_th_used = th_var
}
= do
th_used <- readIORef th_var
let
dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
| otherwise = imp_dep_pkgs imports
return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods,
dep_pkgs = sortBy stablePackageIdCmp pkgs,
dep_orphs = sortBy stableModuleCmp (imp_orphs imports),
dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
-> NameSet -> Dependencies -> GlobalRdrEnv
-> NameEnv FixItem -> Warnings -> HpcInfo
-> ImportedMods
-> ModDetails
-> IO (Messages, Maybe (ModIface, Bool))
mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
dir_imp_mods
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 }
= do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names
; let { entities = typeEnvElts type_env ;
decls = [ tyThingToIfaceDecl entity
| entity <- entities,
let name = getName entity,
not (isImplicitTyThing entity),
not (isWiredInName name),
nameIsLocalOrFrom this_mod name ]
; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
; warns = src_warns
; iface_rules = map (coreRuleToIfaceRule this_mod) rules
; iface_insts = map instanceToIfaceInst insts
; iface_fam_insts = map famInstToIfaceFamInst fam_insts
; iface_vect_info = flattenVectInfo vect_info
; intermediate_iface = ModIface {
mi_module = this_mod,
mi_boot = is_boot,
mi_deps = deps,
mi_usages = usages,
mi_exports = mkIfaceExports exports,
mi_insts = sortLe le_inst iface_insts,
mi_fam_insts= sortLe le_fam_inst iface_fam_insts,
mi_rules = sortLe le_rule iface_rules,
mi_vect_info = iface_vect_info,
mi_fixities = fixities,
mi_warns = warns,
mi_anns = mkIfaceAnnotations anns,
mi_globals = Just rdr_env,
mi_iface_hash = fingerprint0,
mi_mod_hash = fingerprint0,
mi_exp_hash = fingerprint0,
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_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities }
}
; (new_iface, no_change_at_all)
<-
addFingerprints hsc_env maybe_old_fingerprint
intermediate_iface decls
; let orph_warnings
| dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns
| otherwise = emptyBag
errs_and_warns = (orph_warnings, emptyBag)
unqual = mkPrintUnqualified dflags rdr_env
inst_warns = listToBag [ instOrphWarn unqual d
| (d,i) <- insts `zip` iface_insts
, isNothing (ifInstOrph i) ]
rule_warns = listToBag [ ruleOrphWarn unqual this_mod r
| r <- iface_rules
, isNothing (ifRuleOrph r) ]
; if errorsFound dflags errs_and_warns
then return ( errs_and_warns, Nothing )
else do {
; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
(pprModIface new_iface)
; let final_iface = new_iface{ mi_globals = Just rdr_env }
; return (errs_and_warns, Just (final_iface, no_change_at_all)) }}
where
r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2
i1 `le_fam_inst` i2 = ifFamInstTcName i1 `le_occ` ifFamInstTcName i2
le_occ :: Name -> Name -> Bool
le_occ n1 n2 = nameOccName n1 <= nameOccName n2
dflags = hsc_dflags hsc_env
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
flattenVectInfo (VectInfo { vectInfoVar = vVar
, vectInfoTyCon = vTyCon
}) =
IfaceVectInfo {
ifaceVectInfoVar = [ Var.varName v
| (v, _) <- varEnvElts vVar],
ifaceVectInfoTyCon = [ tyConName t
| (t, t_v) <- nameEnvElts vTyCon
, t /= t_v],
ifaceVectInfoTyConReuse = [ tyConName t
| (t, t_v) <- nameEnvElts vTyCon
, t == t_v]
}
writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
writeIfaceFile dflags location new_iface
= do createDirectoryHierarchy (takeDirectory hi_file_path)
writeBinIface dflags hi_file_path new_iface
where hi_file_path = ml_hi_file location
mkHashFun
:: HscEnv
-> ExternalPackageState
-> (Name -> Fingerprint)
mkHashFun hsc_env eps
= \name ->
let
mod = ASSERT2( isExternalName name, ppr name ) nameModule name
occ = nameOccName name
iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
pprPanic "lookupVers2" (ppr mod <+> ppr occ)
in
snd (mi_hash_fn iface occ `orElse`
pprPanic "lookupVers1" (ppr mod <+> ppr occ))
where
hpt = hsc_HPT hsc_env
pit = eps_PIT eps
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 non_orph_rules non_orph_insts decl
edges :: [(IfaceDeclABI, Unique, [Unique])]
edges = [ (abi, getUnique (ifName decl), out)
| decl <- new_decls
, let abi = declABI decl
, let out = localOccs $ freeNamesDeclABI abi
]
name_module n = ASSERT( isExternalName n ) nameModule n
localOccs = map (getUnique . getParent . getOccName)
. filter ((== this_mod) . name_module)
. nameSetToList
where getParent occ = lookupOccEnv parent_map occ `orElse` occ
parent_map :: OccEnv OccName
parent_map = foldr extend emptyOccEnv new_decls
where extend d env =
extendOccEnvList env [ (b,n) | b <- ifaceDeclSubBndrs d ]
where n = ifName d
groups = stronglyConnCompFromEdgedVertices 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
= ASSERT( isExternalName name )
let hash | nameModule name /= this_mod = global_hash_fn name
| otherwise =
snd (lookupOccEnv local_env (getOccName name)
`orElse` pprPanic "urk! lookup local fingerprint"
(ppr name))
in
put_ bh hash
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 dflags hash_fn abi
return (extend_hash_env (hash,decl) local_env,
(hash,decl) : decls_w_hashes)
fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
= do let decls = map abiDecl abis
local_env' = foldr extend_hash_env local_env
(zip (repeat fingerprint0) decls)
hash_fn = mk_put_name local_env'
let stable_abis = sortBy cmp_abiNames abis
hash <- computeFingerprint dflags hash_fn stable_abis
let pairs = zip (repeat hash) decls
return (foldr extend_hash_env local_env pairs,
pairs ++ decls_w_hashes)
extend_hash_env :: (Fingerprint,IfaceDecl)
-> OccEnv (OccName,Fingerprint)
-> OccEnv (OccName,Fingerprint)
extend_hash_env (hash,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d)
where
decl_name = ifName d
item = (decl_name, hash)
env1 = extendOccEnv env0 decl_name item
add_imp bndr env = extendOccEnv env bndr item
(local_env, decls_w_hashes) <-
foldM fingerprint_group (emptyOccEnv, []) groups
let sorted_deps = sortDependencies (mi_deps iface0)
let orph_mods = filter ((== this_pkg) . modulePackageId)
$ dep_orphs sorted_deps
dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
orphan_hash <- computeFingerprint dflags (mk_put_name local_env)
(map IfaceInstABI orph_insts, orph_rules, fam_insts)
export_hash <- computeFingerprint dflags putNameLiterally
(mi_exports iface0,
orphan_hash,
dep_orphan_hashes,
dep_pkgs (mi_deps iface0))
let sorted_decls = eltsFM $ listToFM $
[(ifName d, e) | e@(_, d) <- decls_w_hashes]
mod_hash <- computeFingerprint dflags putNameLiterally
(map fst sorted_decls,
export_hash,
orphan_hash,
mi_warns iface0)
iface_hash <- computeFingerprint dflags putNameLiterally
(mod_hash,
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_orphan = not (null orph_rules && null orph_insts),
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
dflags = hsc_dflags hsc_env
this_pkg = thisPackage dflags
(non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
(non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
fam_insts = mi_fam_insts iface0
fix_fn = mi_fix_fn 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
Nothing -> pprPanic "moduleOrphanHash" (ppr mod)
Just iface -> mi_orphan_hash iface
return (map 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` packageIdFS) (dep_pkgs d),
dep_orphs = sortBy stableModuleCmp (dep_orphs d),
dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
abiDecl :: IfaceDeclABI -> IfaceDecl
abiDecl (_, decl, _) = decl
cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare`
ifName (abiDecl abi2)
freeNamesDeclABI :: IfaceDeclABI -> NameSet
freeNamesDeclABI (_mod, decl, extras) =
freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras
data IfaceDeclExtras
= IfaceIdExtras Fixity [IfaceRule]
| IfaceDataExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
| IfaceClassExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
| IfaceSynExtras Fixity
| IfaceOtherDeclExtras
freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
freeNamesDeclExtras (IfaceIdExtras _ rules)
= unionManyNameSets (map freeNamesIfRule rules)
freeNamesDeclExtras (IfaceDataExtras _ _insts subs)
= unionManyNameSets (map freeNamesSub subs)
freeNamesDeclExtras (IfaceClassExtras _ _insts subs)
= unionManyNameSets (map freeNamesSub subs)
freeNamesDeclExtras (IfaceSynExtras _)
= emptyNameSet
freeNamesDeclExtras IfaceOtherDeclExtras
= emptyNameSet
freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet
freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)
instance Binary IfaceDeclExtras where
get _bh = panic "no get for IfaceDeclExtras"
put_ bh (IfaceIdExtras fix rules) = do
putByte bh 1; put_ bh fix; put_ bh rules
put_ bh (IfaceDataExtras fix insts cons) = do
putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons
put_ bh (IfaceClassExtras fix insts methods) = do
putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods
put_ bh (IfaceSynExtras fix) = do
putByte bh 4; put_ bh fix
put_ bh IfaceOtherDeclExtras = do
putByte bh 5
declExtras :: (OccName -> Fixity)
-> OccEnv [IfaceRule]
-> OccEnv [IfaceInst]
-> IfaceDecl
-> IfaceDeclExtras
declExtras fix_fn rule_env inst_env decl
= case decl of
IfaceId{} -> IfaceIdExtras (fix_fn n)
(lookupOccEnvL rule_env n)
IfaceData{ifCons=cons} ->
IfaceDataExtras (fix_fn n)
(map IfaceInstABI $ lookupOccEnvL inst_env n)
(map (id_extras . ifConOcc) (visibleIfConDecls cons))
IfaceClass{ifSigs=sigs} ->
IfaceClassExtras (fix_fn n)
(map IfaceInstABI $ lookupOccEnvL inst_env n)
[id_extras op | IfaceClassOp op _ _ <- sigs]
IfaceSyn{} -> IfaceSynExtras (fix_fn n)
_other -> IfaceOtherDeclExtras
where
n = ifName decl
id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
newtype IfaceInstABI = IfaceInstABI IfaceInst
instance Binary IfaceInstABI where
get = panic "no get for IfaceInstABI"
put_ bh (IfaceInstABI inst) = do
let ud = getUserData bh
bh' = setUserData bh (ud{ ud_put_name = putNameLiterally })
put_ bh' inst
lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
lookupOccEnvL env k = lookupOccEnv env k `orElse` []
putNameLiterally :: BinHandle -> Name -> IO ()
putNameLiterally bh name = ASSERT( isExternalName name )
do { put_ bh $! nameModule name
; put_ bh $! nameOccName name }
computeFingerprint :: Binary a
=> DynFlags
-> (BinHandle -> Name -> IO ())
-> a
-> IO Fingerprint
computeFingerprint _dflags put_name a = do
bh <- openBinMem (3*1024)
ud <- newWriteState put_name putFS
bh <- return $ setUserData bh ud
put_ bh a
fingerprintBinMem bh
instOrphWarn :: PrintUnqualified -> Instance -> WarnMsg
instOrphWarn unqual inst
= mkWarnMsg (getSrcSpan inst) unqual $
hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst)
ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg
ruleOrphWarn unqual mod rule
= mkWarnMsg silly_loc unqual $
ptext (sLit "Orphan rule:") <+> ppr rule
where
silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 0)
mkOrphMap :: (decl -> Maybe OccName)
-> [decl]
-> (OccEnv [decl],
[decl])
mkOrphMap get_key decls
= foldl go (emptyOccEnv, []) decls
where
go (non_orphs, orphs) d
| Just occ <- get_key d
= (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs)
| otherwise = (non_orphs, d:orphs)
\end{code}
%*********************************************************
%* *
\subsection{Keeping track of what we've slurped, and fingerprints}
%* *
%*********************************************************
\begin{code}
mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> IO [Usage]
mkUsageInfo hsc_env this_mod dir_imp_mods used_names
= do { eps <- hscEPS hsc_env
; let usages = mk_usage_info (eps_PIT eps) hsc_env this_mod
dir_imp_mods used_names
; usages `seqList` return usages }
mk_usage_info :: PackageIfaceTable
-> HscEnv
-> Module
-> ImportedMods
-> NameSet
-> [Usage]
mk_usage_info pit hsc_env this_mod direct_imports used_names
= mapCatMaybes mkUsage usage_mods
where
hpt = hsc_HPT hsc_env
dflags = hsc_dflags hsc_env
this_pkg = thisPackage dflags
used_mods = moduleEnvKeys ent_map
dir_imp_mods = (moduleEnvKeys direct_imports)
all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
usage_mods = sortBy stableModuleCmp all_mods
ent_map :: ModuleEnv [OccName]
ent_map = foldNameSet add_mv emptyModuleEnv used_names
where
add_mv name mv_map
| isWiredInName name = mv_map
| otherwise
= case nameModule_maybe name of
Nothing -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map
Just mod ->
extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ]
where occ = nameOccName name
mkUsage :: Module -> Maybe Usage
mkUsage mod
| isNothing maybe_iface
|| mod == this_mod
= Nothing
| modulePackageId mod /= this_pkg
= Just UsagePackageModule{ usg_mod = mod,
usg_mod_hash = mod_hash }
| (null used_occs
&& isNothing export_hash
&& not is_direct_import
&& not finsts_mod)
= Nothing
| otherwise
= Just UsageHomeModule {
usg_mod_name = moduleName mod,
usg_mod_hash = mod_hash,
usg_exports = export_hash,
usg_entities = fmToList ent_hashs }
where
maybe_iface = lookupIfaceByModule dflags hpt pit mod
is_direct_import = mod `elemModuleEnv` direct_imports
Just iface = maybe_iface
finsts_mod = mi_finsts iface
hash_env = mi_hash_fn iface
mod_hash = mi_mod_hash iface
export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
| otherwise = Nothing
used_occs = lookupModuleEnv ent_map mod `orElse` []
ent_hashs :: FiniteMap OccName Fingerprint
ent_hashs = listToFM (map lookup_occ used_occs)
lookup_occ occ =
case hash_env occ of
Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
Just r -> r
depend_on_exports mod =
case lookupModuleEnv direct_imports mod of
Just _ -> True
Nothing -> False
\end{code}
\begin{code}
mkIfaceAnnotations :: [Annotation] -> [IfaceAnnotation]
mkIfaceAnnotations = map mkIfaceAnnotation
mkIfaceAnnotation :: Annotation -> IfaceAnnotation
mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = IfaceAnnotation {
ifAnnotatedTarget = fmap nameOccName target,
ifAnnotatedValue = serialized
}
\end{code}
\begin{code}
mkIfaceExports :: [AvailInfo]
-> [(Module, [GenAvailInfo OccName])]
mkIfaceExports exports
= [ (mod, eltsFM avails)
| (mod, avails) <- sortBy (stableModuleCmp `on` fst)
(moduleEnvToList groupFM)
]
where
groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
groupFM = foldl add emptyModuleEnv exports
add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
-> Module -> GenAvailInfo OccName
-> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
add_one env mod avail
= extendModuleEnv_C plusFM env mod
(unitFM (occNameFS (availName avail)) avail)
add env (Avail n)
= ASSERT( isExternalName n )
add_one env (nameModule n) (Avail (nameOccName n))
add env (AvailTC tc ns)
= ASSERT( all isExternalName ns )
foldl add_for_mod env mods
where
tc_occ = nameOccName tc
mods = nub (map nameModule ns)
add_for_mod env mod
= add_one env mod (AvailTC tc_occ (sort names_from_mod))
where
names_from_mod = [nameOccName n | n <- ns, nameModule n == mod]
\end{code}
Note [Orignal module]
~~~~~~~~~~~~~~~~~~~~~
Consider this:
module X where { data family T }
module Y( T(..) ) where { import X; data instance T Int = MkT Int }
The exported Avail from Y will look like
X.T{X.T, Y.MkT}
That is, in Y,
only MkT is brought into scope by the data instance;
but the parent (used for grouping and naming in T(..) exports) is X.T
and in this case we export X.T too
In the result of MkIfaceExports, the names are grouped by defining module,
so we may need to split up a single Avail into multiple ones.
%************************************************************************
%* *
Load the old interface file for this module (unless
we have it aleady), and check whether it is up to date
%* *
%************************************************************************
\begin{code}
checkOldIface :: HscEnv
-> ModSummary
-> Bool
-> Maybe ModIface
-> IO (RecompileRequired, Maybe ModIface)
checkOldIface hsc_env mod_summary source_unchanged maybe_iface
= do { showPass (hsc_dflags hsc_env)
("Checking old interface for " ++
showSDoc (ppr (ms_mod mod_summary))) ;
; initIfaceCheck hsc_env $
check_old_iface hsc_env mod_summary source_unchanged maybe_iface
}
check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface
-> IfG (Bool, Maybe ModIface)
check_old_iface hsc_env mod_summary source_unchanged maybe_iface
= do
{ when (not source_unchanged)
(traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
; let dflags = hsc_dflags hsc_env
; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then
return (outOfDate, maybe_iface)
else
case maybe_iface of {
Just old_iface -> do
{ traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface
; return (recomp, Just old_iface) }
; Nothing -> do
{ let iface_path = msHiFilePath mod_summary
; read_result <- readIface (ms_mod mod_summary) iface_path False
; case read_result of {
Failed err -> do
{ traceIf (text "FYI: cannot read old interface file:"
$$ nest 4 err)
; return (outOfDate, Nothing) }
; Succeeded iface -> do
{ traceIf (text "Read the interface file" <+> text iface_path)
; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
; return (recomp, Just iface)
}}}}}
\end{code}
@recompileRequired@ is called from the HscMain. It checks whether
a recompilation is required. It needs access to the persistent state,
finder, etc, because it may have to load lots of interface files to
check their versions.
\begin{code}
type RecompileRequired = Bool
upToDate, outOfDate :: Bool
upToDate = False
outOfDate = True
checkVersions :: HscEnv
-> Bool
-> ModSummary
-> ModIface
-> IfG RecompileRequired
checkVersions hsc_env source_unchanged mod_summary iface
| not source_unchanged
= return outOfDate
| otherwise
= do { traceHiDiffs (text "Considering whether compilation is required for" <+>
ppr (mi_module iface) <> colon)
; recomp <- checkDependencies hsc_env mod_summary iface
; if recomp then return outOfDate else do {
updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
; let this_pkg = thisPackage (hsc_dflags hsc_env)
; checkList [checkModUsage this_pkg u | u <- mi_usages iface]
}}
where
mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
mod_deps = mkModDeps (dep_mods (mi_deps iface))
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= orM (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)
orM = foldr f (return False)
where f m rest = do b <- m; if b then return True else rest
dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do
find_res <- liftIO $ findImportedModule hsc_env mod pkg
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 outOfDate
else
return upToDate
| otherwise
-> if pkg `notElem` 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 outOfDate
else
return upToDate
where pkg = modulePackageId mod
_otherwise -> return outOfDate
needInterface :: Module -> (ModIface -> IfG RecompileRequired)
-> IfG RecompileRequired
needInterface mod continue
= do
let doc_str = sep [ptext (sLit "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 _ -> (out_of_date (sep [ptext (sLit "Couldn't load interface for module"),
ppr mod]))
Succeeded iface -> continue iface
checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
checkModUsage _this_pkg UsagePackageModule{
usg_mod = mod,
usg_mod_hash = old_mod_hash }
= needInterface mod $ \iface -> do
checkModuleFingerprint 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
recompile <- checkModuleFingerprint old_mod_hash new_mod_hash
if not recompile then return upToDate else do
checkMaybeHash maybe_old_export_hash new_export_hash
(ptext (sLit " Export list changed")) $ do
recompile <- checkList [ checkEntityUsage new_decl_hash u
| u <- old_decl_hash]
if recompile
then return outOfDate
else up_to_date (ptext (sLit " Great! The bits I use are up to date"))
checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG Bool
checkModuleFingerprint old_mod_hash new_mod_hash
| new_mod_hash == old_mod_hash
= up_to_date (ptext (sLit "Module fingerprint unchanged"))
| otherwise
= out_of_date_hash (ptext (sLit " Module fingerprint has changed"))
old_mod_hash new_mod_hash
checkMaybeHash :: Maybe Fingerprint -> Fingerprint -> SDoc
-> IfG RecompileRequired -> IfG RecompileRequired
checkMaybeHash maybe_old_hash new_hash doc continue
| Just hash <- maybe_old_hash, hash /= new_hash
= out_of_date_hash doc hash new_hash
| otherwise
= continue
checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint))
-> (OccName, Fingerprint)
-> IfG Bool
checkEntityUsage new_hash (name,old_hash)
= case new_hash name of
Nothing ->
out_of_date (sep [ptext (sLit "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 (ptext (sLit " Out of date:") <+> ppr name)
old_hash new_hash
up_to_date, out_of_date :: SDoc -> IfG Bool
up_to_date msg = traceHiDiffs msg >> return upToDate
out_of_date msg = traceHiDiffs msg >> return outOfDate
out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG Bool
out_of_date_hash msg old_hash new_hash
= out_of_date (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
checkList [] = return upToDate
checkList (check:checks) = do recompile <- check
if recompile
then return outOfDate
else checkList checks
\end{code}
%************************************************************************
%* *
Converting things to their Iface equivalents
%* *
%************************************************************************
\begin{code}
tyThingToIfaceDecl :: TyThing -> IfaceDecl
tyThingToIfaceDecl (AnId id)
= IfaceId { ifName = getOccName id,
ifType = toIfaceType (idType id),
ifIdDetails = toIfaceIdDetails (idDetails id),
ifIdInfo = info }
where
info = case toIfaceIdInfo (idInfo id) of
[] -> NoInfo
items -> HasInfo items
tyThingToIfaceDecl (AClass clas)
= IfaceClass { ifCtxt = toIfaceContext sc_theta,
ifName = getOccName clas,
ifTyVars = toIfaceTvBndrs clas_tyvars,
ifFDs = map toIfaceFD clas_fds,
ifATs = map (tyThingToIfaceDecl . ATyCon) clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
ifRec = boolToRecFlag (isRecursiveTyCon tycon) }
where
(clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff)
= classExtraBigSig clas
tycon = classTyCon clas
toIfaceClassOp (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
IfaceClassOp (getOccName sel_id) def_meth (toIfaceType op_ty)
where
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty
toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
tyThingToIfaceDecl (ATyCon tycon)
| isSynTyCon tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
ifSynRhs = syn_rhs,
ifSynKind = syn_ki,
ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
}
| isAlgTyCon tycon
= IfaceData { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
ifCtxt = toIfaceContext (tyConStupidTheta tycon),
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifGeneric = tyConHasGenerics tycon,
ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
| isForeignTyCon tycon
= IfaceForeign { ifName = getOccName tycon,
ifExtName = tyConExtName tycon }
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
tyvars = tyConTyVars tycon
(syn_rhs, syn_ki)
= case synTyConRhs tycon of
OpenSynTyCon ki _ -> (Nothing, toIfaceType ki)
SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
ifaceConDecls (NewTyCon { data_con = con }) =
IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) =
IfDataTyCon (map ifaceConDecl cons)
ifaceConDecls OpenTyCon {} = IfOpenDataTyCon
ifaceConDecls AbstractTyCon = IfAbstractTyCon
ifaceConDecl data_con
= IfCon { ifConOcc = getOccName (dataConName data_con),
ifConInfix = dataConIsInfix data_con,
ifConWrapper = isJust (dataConWrapId_maybe data_con),
ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con),
ifConEqSpec = to_eq_spec (dataConEqSpec data_con),
ifConCtxt = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
ifConArgTys = map toIfaceType (dataConOrigArgTys data_con),
ifConFields = map getOccName
(dataConFieldLabels data_con),
ifConStricts = dataConStrictMarks data_con }
to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
famInstToIface Nothing = Nothing
famInstToIface (Just (famTyCon, instTys)) =
Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
tyThingToIfaceDecl (ADataCon dc)
= pprPanic "toIfaceDecl" (ppr dc)
getFS :: NamedThing a => a -> FastString
getFS x = occNameFS (getOccName x)
instanceToIfaceInst :: Instance -> IfaceInst
instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
is_cls = cls_name, is_tcs = mb_tcs })
= ASSERT( cls_name == className cls )
IfaceInst { 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
mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name
is_local name = nameIsLocalOrFrom mod name
(_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
(tvs, fds) = classTvsFds cls
arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
orph | is_local cls_name = Just (nameOccName cls_name)
| all isJust mb_ns = head mb_ns
| otherwise = Nothing
mb_ns :: [Maybe OccName]
mb_ns | null fds = [choose_one arg_names]
| otherwise = map do_one fds
do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
, not (tv `elem` rtvs)]
choose_one :: [NameSet] -> Maybe OccName
choose_one nss = case nameSetToList (unionManyNameSets nss) of
[] -> Nothing
(n : _) -> Just (nameOccName n)
famInstToIfaceFamInst :: FamInst -> IfaceFamInst
famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
fi_fam = fam,
fi_tcs = mb_tcs })
= IfaceFamInst { ifFamInstTyCon = toIfaceTyCon tycon
, ifFamInstFam = fam
, ifFamInstTys = map do_rough mb_tcs }
where
do_rough Nothing = Nothing
do_rough (Just n) = Just (toIfaceTyCon_name n)
toIfaceLetBndr :: Id -> IfaceLetBndr
toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
(toIfaceType (idType id))
prag_info
where
id_info = idInfo id
inline_prag = inlinePragInfo id_info
prag_info | isDefaultInlinePragma inline_prag = NoInfo
| otherwise = HasInfo [HsInline inline_prag]
toIfaceIdDetails :: IdDetails -> IfaceIdDetails
toIfaceIdDetails VanillaId = IfVanillaId
toIfaceIdDetails DFunId = IfVanillaId
toIfaceIdDetails (RecSelId { sel_naughty = n
, sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n
toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
IfVanillaId
toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
toIfaceIdInfo id_info
= catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
inline_hsinfo, wrkr_hsinfo, unfold_hsinfo]
where
arity_info = arityInfo id_info
arity_hsinfo | arity_info == 0 = Nothing
| otherwise = Just (HsArity arity_info)
caf_info = cafInfo id_info
caf_hsinfo = case caf_info of
NoCafRefs -> Just HsNoCafRefs
_other -> Nothing
strict_hsinfo = case newStrictnessInfo id_info of
Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
_other -> Nothing
work_info = workerInfo id_info
has_worker = workerExists work_info
wrkr_hsinfo = case work_info of
HasWorker work_id wrap_arity ->
Just (HsWorker ((idName work_id)) wrap_arity)
NoWorker -> Nothing
unfold_info = unfoldingInfo id_info
rhs = unfoldingTemplate unfold_info
no_unfolding = neverUnfold unfold_info
unfold_hsinfo | no_unfolding = Nothing
| has_worker = Nothing
| otherwise = Just (HsUnfold (toIfaceExpr rhs))
inline_prag = inlinePragInfo id_info
inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
| no_unfolding && not has_worker
&& isFunLike (inlinePragmaRuleMatchInfo inline_prag)
= Nothing
| otherwise = Just (HsInline inline_prag)
coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
= pprTrace "toHsRule: builtin" (ppr fn) $
bogusIfaceRule fn
coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
ru_act = act, ru_bndrs = bndrs,
ru_args = args, ru_rhs = rhs })
= IfaceRule { ifRuleName = name, ifActivation = act,
ifRuleBndrs = map toIfaceBndr bndrs,
ifRuleHead = fn,
ifRuleArgs = map do_arg args,
ifRuleRhs = toIfaceExpr rhs,
ifRuleOrph = orph }
where
do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
do_arg arg = toIfaceExpr arg
lhs_names = fn : nameSetToList (exprsFreeNames args)
orph = case filter (nameIsLocalOrFrom mod) lhs_names of
(n : _) -> Just (nameOccName n)
[] -> Nothing
bogusIfaceRule :: Name -> IfaceRule
bogusIfaceRule id_name
= IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
toIfaceExpr :: CoreExpr -> IfaceExpr
toIfaceExpr (Var v) = toIfaceVar v
toIfaceExpr (Lit l) = IfaceLit l
toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
toIfaceExpr (App f a) = toIfaceApp f [a]
toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as)
toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceType co)
toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e)
toIfaceNote :: Note -> IfaceNote
toIfaceNote (SCC cc) = IfaceSCC cc
toIfaceNote InlineMe = IfaceInlineMe
toIfaceNote (CoreNote s) = IfaceCoreNote s
toIfaceBind :: Bind Id -> IfaceBinding
toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
toIfaceAlt :: (AltCon, [Var], CoreExpr)
-> (IfaceConAlt, [FastString], IfaceExpr)
toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
toIfaceCon :: AltCon -> IfaceConAlt
toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
| otherwise = IfaceDataAlt (getName dc)
where
tc = dataConTyCon dc
toIfaceCon (LitAlt l) = IfaceLitAlt l
toIfaceCon DEFAULT = IfaceDefault
toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
toIfaceApp (App f a) as = toIfaceApp f (a:as)
toIfaceApp (Var v) as
= case isDataConWorkId_maybe v of
Just dc | isTupleTyCon tc && saturated
-> IfaceTuple (tupleTyConBoxity tc) tup_args
where
val_args = dropWhile isTypeArg as
saturated = val_args `lengthIs` idArity v
tup_args = map toIfaceExpr val_args
tc = dataConTyCon dc
_ -> mkIfaceApps (toIfaceVar v) as
toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
toIfaceVar :: Id -> IfaceExpr
toIfaceVar v
| Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
| isExternalName name = IfaceExt name
| Just (TickBox m ix) <- isTickBoxOp_maybe v
= IfaceTick m ix
| otherwise = IfaceLcl (getFS name)
where
name = idName v
\end{code}