/compiler/iface/MkIface.lhs
Haskell | 1851 lines | 1248 code | 250 blank | 353 comment | 55 complexity | 0a10bcd2d5e130a2f1e748d0980bf01c MD5 | raw file
Large files files are truncated, but you can click here to view the full file
- %
- % (c) The University of Glasgow 2006-2008
- % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
- %
- \begin{code}
- -- | Module for constructing @ModIface@ values (interface files),
- -- writing them to disk and comparing two versions to see if
- -- recompilation is required.
- module MkIface (
- mkUsedNames,
- mkDependencies,
- mkIface, -- Build a ModIface from a ModGuts,
- -- including computing version information
- mkIfaceTc,
- writeIfaceFile, -- Write the interface file
- checkOldIface, -- See if recompilation is required, by
- -- comparing version information
- RecompileRequired(..), recompileRequired,
- tyThingToIfaceDecl -- Converting things to their Iface equivalents
- ) 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 top-down 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.
- Also record any dependent files added with addDependentFile.
- In the future record any #include usages.
- * 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 FlagChecker
- import Id
- import IdInfo
- import Demand
- import Annotations
- import CoreSyn
- import CoreFVs
- import Class
- import Kind
- import TyCon
- import Coercion ( coAxiomSplitLHS )
- 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 UniqFM
- import Unique
- import Util hiding ( eqListBy )
- import FastString
- import Maybes
- import ListSetOps
- import Binary
- import Fingerprint
- import Bag
- import Exception
- import Control.Monad
- import Data.Function
- import Data.List
- import Data.Map (Map)
- import qualified Data.Map as Map
- import Data.Ord
- import Data.IORef
- import System.Directory
- import System.FilePath
- \end{code}
- %************************************************************************
- %* *
- \subsection{Completing an interface}
- %* *
- %************************************************************************
- \begin{code}
- mkIface :: HscEnv
- -> Maybe Fingerprint -- The old fingerprint, if we have it
- -> ModDetails -- The trimmed, tidied interface
- -> ModGuts -- Usages, deprecations, etc
- -> IO (Messages,
- Maybe (ModIface, -- The new one
- Bool)) -- True <=> there was an old Iface, and the
- -- new one is identical, so no need
- -- to write it
- mkIface hsc_env maybe_old_fingerprint mod_details
- ModGuts{ mg_module = this_mod,
- mg_boot = is_boot,
- mg_used_names = used_names,
- mg_used_th = used_th,
- 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,
- mg_safe_haskell = safe_mode,
- mg_trust_pkg = self_trust,
- mg_dependent_files = dependent_files
- }
- = mkIface_ hsc_env maybe_old_fingerprint
- this_mod is_boot used_names used_th deps rdr_env fix_env
- warns hpc_info dir_imp_mods self_trust dependent_files
- safe_mode mod_details
- -- | make an interface from the results of typechecking only. Useful
- -- for non-optimising compilation, or where we aren't generating any
- -- object code at all ('HscNothing').
- mkIfaceTc :: HscEnv
- -> Maybe Fingerprint -- The old fingerprint, if we have it
- -> SafeHaskellMode -- The safe haskell mode
- -> ModDetails -- gotten from mkBootModDetails, probably
- -> TcGblEnv -- Usages, deprecations, etc
- -> IO (Messages, Maybe (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_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)
- mkIface_ hsc_env maybe_old_fingerprint
- this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env
- fix_env warns hpc_info (imp_mods imports)
- (imp_trust_own_pkg imports) dep_files safe_mode mod_details
-
- mkUsedNames :: TcGblEnv -> NameSet
- mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
-
- -- | Extract information from the rename and typecheck phases to produce
- -- a dependencies information for the module being compiled.
- mkDependencies :: TcGblEnv -> IO Dependencies
- mkDependencies
- TcGblEnv{ tcg_mod = mod,
- tcg_imports = imports,
- tcg_th_used = th_var
- }
- = do
- -- Template Haskell used?
- th_used <- readIORef th_var
- let dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
- -- M.hi-boot can be in the imp_dep_mods, but we must remove
- -- it before recording the modules on which this one depends!
- -- (We want to retain M.hi-boot in imp_dep_mods so that
- -- loadHiBootInterface can see if M's direct imports depend
- -- on M.hi-boot, and hence that we should do the hi-boot consistency
- -- check.)
- pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
- | otherwise = imp_dep_pkgs imports
- -- Set the packages required to be Safe according to Safe Haskell.
- -- See Note [RnNames . Tracking Trust Transitively]
- sorted_pkgs = sortBy stablePackageIdCmp pkgs
- trust_pkgs = imp_trust_pkgs imports
- dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
- return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods,
- dep_pkgs = dep_pkgs',
- dep_orphs = sortBy stableModuleCmp (imp_orphs imports),
- dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
- -- sort to get into canonical order
- -- NB. remember to use lexicographic ordering
- mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
- -> NameSet -> Bool -> Dependencies -> GlobalRdrEnv
- -> NameEnv FixItem -> Warnings -> HpcInfo
- -> ImportedMods -> Bool
- -> [FilePath]
- -> SafeHaskellMode
- -> ModDetails
- -> IO (Messages, Maybe (ModIface, Bool))
- mkIface_ hsc_env maybe_old_fingerprint
- this_mod is_boot used_names used_th deps rdr_env fix_env src_warns
- hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode
- 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 }
- -- NB: notice that mkIface does not look at the bindings
- -- only at the TypeEnv. The previous Tidy phase has
- -- put exactly the info into the TypeEnv that we want
- -- to expose in the interface
- = do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
- ; let { entities = typeEnvElts type_env ;
- decls = [ tyThingToIfaceDecl entity
- | entity <- entities,
- let name = getName entity,
- not (isImplicitTyThing entity),
- -- No implicit Ids and class tycons in the interface file
- not (isWiredInName name),
- -- Nor wired-in things; the compiler knows about them anyhow
- nameIsLocalOrFrom this_mod name ]
- -- Sigh: see Note [Root-main Id] in TcRnDriver
- ; 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
- ; trust_info = setSafeMode safe_mode
- ; intermediate_iface = ModIface {
- mi_module = this_mod,
- mi_boot = is_boot,
- mi_deps = deps,
- mi_usages = usages,
- mi_exports = mkIfaceExports exports,
-
- -- Sort these lexicographically, so that
- -- the result is stable across compilations
- 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 = mkIfaceAnnotations anns,
- mi_globals = maybeGlobalRdrEnv rdr_env,
- -- Left out deliberately: filled in by addFingerprints
- 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, -- Always set by addFingerprints, but
- -- it's a strict field, so we can't omit it.
- mi_finsts = False, -- Ditto
- 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,
- -- And build the cached values
- mi_warn_fn = mkIfaceWarnCache warns,
- mi_fix_fn = mkIfaceFixCache fixities }
- }
- ; (new_iface, no_change_at_all)
- <- {-# SCC "versioninfo" #-}
- addFingerprints hsc_env maybe_old_fingerprint
- intermediate_iface decls
- -- Warn about orphans
- ; let warn_orphs = wopt Opt_WarnOrphans dflags
- warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags
- orph_warnings --- Laziness means no work done unless -fwarn-orphans
- | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
- | otherwise = emptyBag
- errs_and_warns = (orph_warnings, emptyBag)
- unqual = mkPrintUnqualified dflags rdr_env
- inst_warns = listToBag [ instOrphWarn dflags unqual d
- | (d,i) <- insts `zip` iface_insts
- , isNothing (ifInstOrph i) ]
- rule_warns = listToBag [ ruleOrphWarn dflags unqual this_mod r
- | r <- iface_rules
- , isNothing (ifRuleOrph r)
- , if ifRuleAuto r then warn_auto_orphs
- else warn_orphs ]
- ; if errorsFound dflags errs_and_warns
- then return ( errs_and_warns, Nothing )
- else do {
- -- Debug printing
- ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
- (pprModIface new_iface)
- -- bug #1617: on reload we weren't updating the PrintUnqualified
- -- correctly. This stems from the fact that the interface had
- -- not changed, so addFingerprints returns the old ModIface
- -- with the old GlobalRdrEnv (mi_globals).
- ; let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
- ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }}
- where
- cmp_rule = comparing ifRuleName
- -- Compare these lexicographically by OccName, *not* by unique,
- -- because the latter is not stable across compilations:
- cmp_inst = comparing (nameOccName . ifDFun)
- cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)
- dflags = hsc_dflags hsc_env
- -- We only fill in mi_globals if the module was compiled to byte
- -- code. Otherwise, the compiler may not have retained all the
- -- top-level bindings and they won't be in the TypeEnv (see
- -- Desugar.addExportFlagsAndRules). The mi_globals field is used
- -- by GHCi to decide whether the module has its full top-level
- -- scope available. (#5534)
- 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
- , vectInfoScalarVars = vScalarVars
- , vectInfoScalarTyCons = vScalarTyCons
- }) =
- 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]
- , ifaceVectInfoScalarVars = [Var.varName v | v <- varSetElems vScalarVars]
- , ifaceVectInfoScalarTyCons = nameSetToList vScalarTyCons
- }
- -----------------------------
- writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
- writeIfaceFile dflags location new_iface
- = do createDirectoryIfMissing True (takeDirectory hi_file_path)
- writeBinIface dflags hi_file_path new_iface
- where hi_file_path = ml_hi_file location
- -- -----------------------------------------------------------------------------
- -- Look up parents and versions of Names
- -- This is like a global version of the mi_hash_fn field in each ModIface.
- -- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
- -- the parent and version info.
- mkHashFun
- :: HscEnv -- needed to look up versions
- -> ExternalPackageState -- ditto
- -> (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
- -- ---------------------------------------------------------------------------
- -- Compute fingerprints for the interface
- addFingerprints
- :: HscEnv
- -> Maybe Fingerprint -- the old fingerprint, if any
- -> ModIface -- The new interface (lacking decls)
- -> [IfaceDecl] -- The new decls
- -> IO (ModIface, -- Updated interface
- Bool) -- True <=> no changes at all;
- -- no need to write Iface
- addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
- = do
- eps <- hscEPS hsc_env
- let
- -- The ABI of a declaration represents everything that is made
- -- visible about the declaration that a client can depend on.
- -- see IfaceDeclABI below.
- declABI :: IfaceDecl -> IfaceDeclABI
- declABI decl = (this_mod, decl, extras)
- where extras = declExtras fix_fn non_orph_rules non_orph_insts
- non_orph_fis 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 = ASSERT2( isExternalName n, ppr n ) nameModule n
- localOccs = map (getUnique . getParent . getOccName)
- . filter ((== this_mod) . name_module)
- . nameSetToList
- where getParent occ = lookupOccEnv parent_map occ `orElse` occ
- -- maps OccNames to their parents in the current module.
- -- e.g. a reference to a constructor must be turned into a reference
- -- to the TyCon for the purposes of calculating dependencies.
- parent_map :: OccEnv OccName
- parent_map = foldr extend emptyOccEnv new_decls
- where extend d env =
- extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]
- where n = ifName d
- -- strongly-connected groups of declarations, in dependency order
- groups = stronglyConnCompFromEdgedVertices edges
- global_hash_fn = mkHashFun hsc_env eps
- -- how to output Names when generating the data to fingerprint.
- -- Here we want to output the fingerprint for each top-level
- -- Name, whether it comes from the current module or another
- -- module. In this way, the fingerprint for a declaration will
- -- change if the fingerprint for anything it refers to (transitively)
- -- changes.
- mk_put_name :: (OccEnv (OccName,Fingerprint))
- -> BinHandle -> Name -> IO ()
- mk_put_name local_env bh name
- | isWiredInName name = putNameLiterally bh name
- -- wired-in names don't have fingerprints
- | otherwise
- = ASSERT2( isExternalName name, ppr 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)) -- (undefined,fingerprint0))
- -- This panic indicates that we got the dependency
- -- analysis wrong, because we needed a fingerprint for
- -- an entity that wasn't in the environment. To debug
- -- it, turn the panic into a trace, uncomment the
- -- pprTraces below, run the compile again, and inspect
- -- the output and the generated .hi file with
- -- --show-iface.
- in put_ bh hash
- -- take a strongly-connected group of declarations and compute
- -- its fingerprint.
- 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
- -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
- 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
- -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
- let stable_abis = sortBy cmp_abiNames abis
- -- put the cycle in a canonical order
- 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)
- -- we have fingerprinted the whole declaration, but we now need
- -- to assign fingerprints to all the OccNames that it binds, to
- -- use when referencing those OccNames in later declarations.
- --
- 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
- -- when calculating fingerprints, we always need to use canonical
- -- ordering for lists of things. In particular, the mi_deps has various
- -- lists of modules and suchlike, so put these all in canonical order:
- let sorted_deps = sortDependencies (mi_deps iface0)
- -- the export hash of a module depends on the orphan hashes of the
- -- orphan modules below us in the dependency tree. This is the way
- -- that changes in orphans get propagated all the way up the
- -- dependency tree. We only care about orphan modules in the current
- -- package, because changes to orphans outside this package will be
- -- tracked by the usage on the ABI hash of package modules that we import.
- let orph_mods = filter ((== this_pkg) . modulePackageId)
- $ 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)
- -- the export list hash doesn't depend on the fingerprints of
- -- the Names it mentions, only the Names themselves, hence putNameLiterally.
- export_hash <- computeFingerprint putNameLiterally
- (mi_exports iface0,
- orphan_hash,
- dep_orphan_hashes,
- dep_pkgs (mi_deps iface0),
- -- dep_pkgs: see "Package Version Changes" on
- -- wiki/Commentary/Compiler/RecompilationAvoidance
- mi_trust iface0)
- -- Make sure change of Safe Haskell mode causes recomp.
- -- put the declarations in a canonical order, sorted by OccName
- let sorted_decls = Map.elems $ Map.fromList $
- [(ifName d, e) | e@(_, d) <- decls_w_hashes]
-
- -- the flag hash depends on:
- -- - (some of) dflags
- -- it returns two hashes, one that shouldn't change
- -- the abi hash and one that should
- flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
- -- the ABI hash depends on:
- -- - decls
- -- - export list
- -- - orphans
- -- - deprecations
- -- - vect info
- -- - flag abi hash
- mod_hash <- computeFingerprint putNameLiterally
- (map fst sorted_decls,
- export_hash, -- includes orphan_hash
- mi_warns iface0,
- mi_vect_info iface0)
- -- The interface hash depends on:
- -- - the ABI hash, plus
- -- - usages
- -- - deps
- -- - hpc
- iface_hash <- computeFingerprint 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_flag_hash = flag_hash,
- mi_orphan = not ( null 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
- 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)
- (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (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 (stablePackageIdCmp `on` fst) (dep_pkgs d),
- dep_orphs = sortBy stableModuleCmp (dep_orphs d),
- dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
- \end{code}
- %************************************************************************
- %* *
- The ABI of an IfaceDecl
- %* *
- %************************************************************************
- Note [The ABI of an IfaceDecl]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- The ABI of a declaration consists of:
- (a) the full name of the identifier (inc. module and package,
- because these are used to construct the symbol name by which
- the identifier is known externally).
- (b) the declaration itself, as exposed to clients. That is, the
- definition of an Id is included in the fingerprint only if
- it is made available as as unfolding in the interface.
- (c) the fixity of the identifier
- (d) for Ids: rules
- (e) for classes: instances, fixity & rules for methods
- (f) for datatypes: instances, fixity & rules for constrs
- Items (c)-(f) are not stored in the IfaceDecl, but instead appear
- elsewhere in the interface file. But they are *fingerprinted* with
- the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
- and fingerprinting that as part of the declaration.
- \begin{code}
- type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
- data IfaceDeclExtras
- = IfaceIdExtras Fixity [IfaceRule]
- | IfaceDataExtras
- Fixity -- Fixity of the tycon itself
- [IfaceInstABI] -- Local class and family instances of this tycon
- -- See Note [Orphans] in IfaceSyn
- [(Fixity,[IfaceRule])] -- For each construcotr, fixity and RULES
- | IfaceClassExtras
- Fixity -- Fixity of the class itself
- [IfaceInstABI] -- Local instances of this class *or*
- -- of its associated data types
- -- See Note [Orphans] in IfaceSyn
- [(Fixity,[IfaceRule])] -- For each class method, fixity and RULES
- | IfaceSynExtras Fixity [IfaceInstABI]
- | IfaceOtherDeclExtras
- -- When hashing a class or family instance, we hash only the
- -- DFunId or CoAxiom, because that depends on all the
- -- information about the instance.
- --
- type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance
- 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
- freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
- freeNamesDeclExtras (IfaceIdExtras _ rules)
- = unionManyNameSets (map freeNamesIfRule rules)
- freeNamesDeclExtras (IfaceDataExtras _ insts subs)
- = unionManyNameSets (mkNameSet insts : map freeNamesSub subs)
- freeNamesDeclExtras (IfaceClassExtras _ insts subs)
- = unionManyNameSets (mkNameSet insts : map freeNamesSub subs)
- freeNamesDeclExtras (IfaceSynExtras _ insts)
- = mkNameSet insts
- freeNamesDeclExtras IfaceOtherDeclExtras
- = emptyNameSet
- freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet
- freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)
- instance Outputable IfaceDeclExtras where
- ppr IfaceOtherDeclExtras = empty
- ppr (IfaceIdExtras fix rules) = ppr_id_extras fix rules
- ppr (IfaceSynExtras fix finsts) = vcat [ppr fix, ppr finsts]
- ppr (IfaceDataExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts,
- ppr_id_extras_s stuff]
- ppr (IfaceClassExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts,
- ppr_id_extras_s stuff]
- ppr_insts :: [IfaceInstABI] -> SDoc
- ppr_insts _ = ptext (sLit "<insts>")
- ppr_id_extras_s :: [(Fixity, [IfaceRule])] -> SDoc
- ppr_id_extras_s stuff = vcat [ppr_id_extras f r | (f,r)<- stuff]
- ppr_id_extras :: Fixity -> [IfaceRule] -> SDoc
- ppr_id_extras fix rules = ppr fix $$ vcat (map ppr rules)
- -- This instance is used only to compute fingerprints
- 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 finsts) = do
- putByte bh 4; put_ bh fix; put_ bh finsts
- put_ bh IfaceOtherDeclExtras = do
- putByte bh 5
- declExtras :: (OccName -> Fixity)
- -> OccEnv [IfaceRule]
- -> OccEnv [IfaceClsInst]
- -> OccEnv [IfaceFamInst]
- -> IfaceDecl
- -> IfaceDeclExtras
- declExtras fix_fn rule_env inst_env fi_env decl
- = case decl of
- IfaceId{} -> IfaceIdExtras (fix_fn n)
- (lookupOccEnvL rule_env n)
- IfaceData{ifCons=cons} ->
- IfaceDataExtras (fix_fn n)
- (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++
- map ifDFun (lookupOccEnvL inst_env n))
- (map (id_extras . ifConOcc) (visibleIfConDecls cons))
- IfaceClass{ifSigs=sigs, ifATs=ats} ->
- IfaceClassExtras (fix_fn n)
- (map ifDFun $ (concatMap at_extras ats)
- ++ lookupOccEnvL inst_env n)
- -- Include instances of the associated types
- -- as well as instances of the class (Trac #5147)
- [id_extras op | IfaceClassOp op _ _ <- sigs]
- IfaceSyn{} -> IfaceSynExtras (fix_fn n)
- (map ifFamInstAxiom (lookupOccEnvL fi_env n))
- _other -> IfaceOtherDeclExtras
- where
- n = ifName decl
- id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
- at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (ifName decl)
- lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
- lookupOccEnvL env k = lookupOccEnv env k `orElse` []
- -- used when we want to fingerprint a structure without depending on the
- -- fingerprints of external Names that it refers to.
- putNameLiterally :: BinHandle -> Name -> IO ()
- putNameLiterally bh name = ASSERT( isExternalName name )
- do { put_ bh $! nameModule name
- ; put_ bh $! nameOccName name }
- {-
- -- for testing: use the md5sum command to generate fingerprints and
- -- compare the results against our built-in version.
- fp' <- oldMD5 dflags bh
- if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
- else return fp
- oldMD5 dflags bh = do
- tmp <- newTempName dflags "bin"
- writeBinMem bh tmp
- tmp2 <- newTempName dflags "md5"
- let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
- r <- system cmd
- case r of
- ExitFailure _ -> ghcError (PhaseFailed cmd r)
- ExitSuccess -> do
- hash_str <- readFile tmp2
- return $! readHexFingerprint hash_str
- -}
- instOrphWarn :: DynFlags -> PrintUnqualified -> ClsInst -> WarnMsg
- instOrphWarn dflags unqual inst
- = mkWarnMsg dflags (getSrcSpan inst) unqual $
- hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
- ruleOrphWarn :: DynFlags -> PrintUnqualified -> Module -> IfaceRule -> WarnMsg
- ruleOrphWarn dflags unqual mod rule
- = mkWarnMsg dflags silly_loc unqual $
- ptext (sLit "Orphan rule:") <+> ppr rule
- where
- silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
- -- We don't have a decent SrcSpan for a Rule, not even the CoreRule
- -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to
- ----------------------
- -- mkOrphMap partitions instance decls or rules into
- -- (a) an OccEnv for ones that are not orphans,
- -- mapping the local OccName to a list of its decls
- -- (b) a list of orphan decls
- mkOrphMap :: (decl -> Maybe OccName) -- (Just occ) for a non-orphan decl, keyed by occ
- -- Nothing for an orphan decl
- -> [decl] -- Sorted into canonical order
- -> (OccEnv [decl], -- Non-orphan decls associated with their key;
- -- each sublist in canonical order
- [decl]) -- Orphan decls; in canonical order
- mkOrphMap get_key decls
- = foldl go (emptyOccEnv, []) decls
- where
- go (non_orphs, orphs) d
- | Just occ <- get_key d
- = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
- | otherwise = (non_orphs, d:orphs)
- \end{code}
- %************************************************************************
- %* *
- Keeping track of what we've slurped, and fingerprints
- %* *
- %************************************************************************
- \begin{code}
- mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage]
- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
- = do { eps <- hscEPS hsc_env
- ; mtimes <- mapM getModificationUTCTime dependent_files
- ; let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
- dir_imp_mods used_names
- ; let usages = mod_usages ++ map to_file_usage (zip dependent_files mtimes)
- ; usages `seqList` return usages }
- -- seq the list of Usages returned: occasionally these
- -- don't get evaluated for a while and we can end up hanging on to
- -- the entire collection of Ifaces.
- where
- to_file_usage (f, mtime) = UsageFile { usg_file_path = f, usg_mtime = mtime }
- mk_mod_usage_info :: PackageIfaceTable
- -> HscEnv
- -> Module
- -> ImportedMods
- -> NameSet
- -> [Usage]
- mk_mod_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
- -- canonical order is imported, to avoid interface-file
- -- wobblage.
- -- ent_map groups together all the things imported and used
- -- from a particular module
- ent_map :: ModuleEnv [OccName]
- ent_map = foldNameSet add_mv emptyModuleEnv used_names
- where
- add_mv name mv_map
- | isWiredInName name = mv_map -- ignore wired-in names
- | otherwise
- = case nameModule_maybe name of
- Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map
- -- See Note [Internal used_names]
- Just mod -> -- This lambda function is really just a
- -- specialised (++); originally came about to
- -- avoid quadratic behaviour (trac #2680)
- extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ]
- where occ = nameOccName name
-
- -- We want to create a Usage for a home module if
- -- a) we used something from it; has something in used_names
- -- b) we imported it, even if we used nothing from it
- -- (need to recompile if its export list changes: export_fprint)
- mkUsage :: Module -> Maybe Usage
- mkUsage mod
- | isNothing maybe_iface -- We can't depend on it if we didn't
- -- load its interface.
- || mod == this_mod -- We don't care about usages of
- -- things in *this* module
- = Nothing
- | modulePackageId mod /= this_pkg
- = Just UsagePackageModule{ usg_mod = mod,
- usg_mod_hash = mod_hash,
- usg_safe = imp_safe }
- -- for package modules, we record the module hash only
- | (null used_occs
- && isNothing export_hash
- && not is_direct_import
- && not finsts_mod)
- = Nothing -- Record no usage info
- -- for directly-imported modules, we always want to record a usage
- -- on the orphan hash. This is what triggers a recompilation if
- -- an orphan is added or removed somewhere below us in the future.
-
- | otherwise
- = Just UsageHomeModule {
- usg_mod_name = moduleName mod,
- usg_mod_hash = mod_hash,
- usg_exports = export_hash,
- usg_entities = Map.toList ent_hashs,
- usg_safe = imp_safe }
- where
- maybe_iface = lookupIfaceByModule dflags hpt pit mod
- -- In one-shot mode, the interfaces for home-package
- -- modules accumulate in the PIT not HPT. Sigh.
- 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 = Just (mi_exp_hash iface)
- | otherwise = Nothing
- (is_direct_import, imp_safe)
- = case lookupModuleEnv direct_imports mod of
- Just ((_,_,_,safe):_xs) -> (True, safe)
- Just _ -> pprPanic "mkUsage: empty direct import" empty
- Nothing -> (False, safeImplicitImpsReq dflags)
- -- Nothing case is for implicit imports like 'System.IO' when 'putStrLn'
- -- is used in the source code. We require them to be safe in Safe Haskell
-
- used_occs = lookupModuleEnv ent_map mod `orElse` []
- -- Making a Map here ensures that (a) we remove duplicates
- -- when we have usages on several subordinates of a single parent,
- -- and (b) that the usages emerge in a canonical order, which
- -- is why we use Map rather than OccEnv: Map works
- -- using Ord on the OccNames, which is a lexicographic ordering.
- ent_hashs :: Map OccName Fingerprint
- ent_hashs = Map.fromList (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 = is_direct_import
- {- True
- Even if we used 'import M ()', we have to register a
- usage on the export list because we are sensitive to
- changes in orphan instances/rules.
- False
- In GHC 6.8.x we always returned true, and in
- fact it recorded a dependency on *all* the
- modules underneath in the dependency tree. This
- happens to make orphans work right, but is too
- expensive: it'll read too many interface files.
- The 'isNothing maybe_iface' check above saved us
- from generating many of these usages (at least in
- one-shot mode), but that's even more bogus!
- -}
- \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] -> [IfaceExport] -- Sort to make canonical
- mkIfaceExports exports
- = sortBy stableAvailCmp (map sort_subs exports)
- where
- sort_subs :: AvailInfo -> AvailInfo
- sort_subs (Avail n) = Avail n
- sort_subs (AvailTC n []) = AvailTC n []
- sort_subs (AvailTC n (m:ms))
- | n==m = AvailTC n (m:sortBy stableNameCmp ms)
- | otherwise = AvailTC n (sortBy stableNameCmp (m:ms))
- -- Maintain the AvailTC Invariant
- \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.
- Note [Internal used_names]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~
- Most of the used_names are External Names, but we can have Internal
- Names too: see Note [Binders in Template Haskell] in Convert, and
- Trac #5362 for an example. Such Names are always
- - Such Names are always for locally-defined things, for which we
- don't gather usage info, so we can just ignore them in ent_map
- - They are always System Names, hence the assert, just as a double check.
- %************************************************************************
- %* *
- Load the old interface file for this module (unless
- we have it already), and check whether it is up to date
- %* *
- %************************************************************************
- \begin{code}
- data RecompileRequired
- = UpToDate
- -- ^ everything is up to date, recompilation is not required
- | MustCompile
- -- ^ The .hs file has been touched, or the .o/.hi file does not exist
- | RecompBecause String
- -- ^ The .o/.hi files are up to date, but something else has changed
- -- to force recompilation; the String says what (one-line summary)
- deriving Eq
- recompileRequired :: RecompileRequired -> Bool
- recompileRequired UpToDate = False
- recompileRequired _ = True
- -- | Top level function to check if the version of an old interface file
- -- is equivalent to the current source file the user asked us to compile.
- -- If the same, we can avoid recompilation. We return a tuple where the
- -- first element is a bool saying if we should recompile the object file
- -- and the second is maybe the interface file, where Nothng means to
- -- rebuild the interface file not use the exisitng one.
- checkOldIface :: HscEnv
- -> ModSummary
- -> SourceModified
- -> Maybe ModIface -- Old interface from compilation manager, if any
- -> 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)
- initIfaceCheck 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 False
- case read_result of
- Failed err -> do
- traceIf (text "FYI: cannont read old interface file:" $$ nest 4 err)
- return Nothing
- Succeeded iface -> do
- traceIf (text "Read the interface file" <+> text iface_path)
- return $ Just iface
- src_changed
- | dopt 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
- -- If the source has changed and we're in interactive mode,
- -- avoid reading an interface; just return the one we might
- -- have been supplied with.
- True | not (isObjectTarget $ hscTarget dflags) ->
- return (MustCompile, maybe_iface)
- -- Try and read the old interface for the current module
- -- from the .hi file left from the last time we compiled it
- True -> do
- maybe_iface' <- getIface
- return (MustCompile, maybe_iface')
- False -> do
- maybe_iface' <- getIface
- case maybe_iface' of
- -- We can't retrieve the iface
- Nothing -> return (MustCompile, Nothing)
- -- We have got the old iface; check its versions
- -- even in the SourceUnmodifiedAndStable case we
- -- should check versions because some packages
- -- might have changed or gone away.
- …
Large files files are truncated, but you can click here to view the full file