%
-% (c) The University of Glasgow 2006
+% (c) The University of Glasgow 2006-2008
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
module MkIface (
- mkUsageInfo, -- Construct the usage info for a module
-
+ 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
\end{code}
-----------------------------------------------
- MkIface.lhs deals with versioning
+ Recompilation checking
-----------------------------------------------
-Here's the version-related info in an interface file
+A complete description of how recompilation checking works can be
+found in the wiki commentary:
- module Foo 8 -- module-version
- 3 -- export-list-version
- 2 -- rule-version
- Usages: -- Version info for what this compilation of Foo imported
- Baz 3 -- Module version
- [4] -- The export-list version if Foo depended on it
- (g,2) -- Function and its version
- (T,1) -- Type and its version
+ http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
- <version> f :: Int -> Int {- Unfolding: \x -> Wib.t[2] x -}
- -- The [2] says that f's unfolding
- -- mentions verison 2 of Wib.t
-
- -----------------------------------------------
- Basic idea
- -----------------------------------------------
+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
- version number of each free variable of the module
+ fingerprint of each free variable of the module
- * In mkIface, we compute the version number of each exported thing A.f
- by comparing its A.f's info with its new info, and bumping its
- version number if it differs. If A.f mentions B.g, and B.g's version
- number has changed, then we count A.f as having changed too.
+ * 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 version info for all each thing recorded in mi_usages
-
-
-Fixities
-~~~~~~~~
-We count A.f as changing if its fixity changes
-
-Rules
-~~~~~
-If a rule changes, we want to recompile any module that might be
-affected by that rule. For non-orphan rules, this is relatively easy.
-If module M defines f, and a rule for f, just arrange that the version
-number for M.f changes if any of the rules for M.f change. Any module
-that does not depend on M.f can't be affected by the rule-change
-either.
-
-Orphan rules (ones whose 'head function' is not defined in M) are
-harder. Here's what we do.
-
- * We have a per-module orphan-rule version number which changes if
- any orphan rule changes. (It's unaffected by non-orphan rules.)
-
- * We record usage info for any orphan module 'below' this one,
- giving the orphan-rule version number. We recompile if this
- changes.
-
-The net effect is that if an orphan rule changes, we recompile every
-module above it. That's very conservative, but it's devilishly hard
-to know what it might affect, so we just have to be conservative.
-
-Instance decls
-~~~~~~~~~~~~~~
-In an iface file we have
- module A where
- instance Eq a => Eq [a] = dfun29
- dfun29 :: ...
-
-We have a version number for dfun29, covering its unfolding
-etc. Suppose we are compiling a module M that imports A only
-indirectly. If typechecking M uses this instance decl, we record the
-dependency on A.dfun29 as if it were a free variable of the module
-(via the tcg_inst_usages accumulator). That means that A will appear
-in M's usage list. If the shape of the instance declaration changes,
-then so will dfun29's version, triggering a recompilation.
-
-Adding an instance declaration, or changing an instance decl that is
-not currently used, is more tricky. (This really only makes a
-difference when we have overlapping instance decls, because then the
-new instance decl might kick in to override the old one.) We handle
-this in a very similar way that we handle rules above.
-
- * For non-orphan instance decls, identify one locally-defined tycon/class
- mentioned in the decl. Treat the instance decl as part of the defn of that
- tycon/class, so that if the shape of the instance decl changes, so does the
- tycon/class; that in turn will force recompilation of anything that uses
- that tycon/class.
-
- * For orphan instance decls, act the same way as for orphan rules.
- Indeed, we use the same global orphan-rule version number.
-
-mkUsageInfo
-~~~~~~~~~~~
-mkUsageInfo figures out what the ``usage information'' for this
-moudule is; that is, what it must record in its interface file as the
-things it uses.
-
-We produce a line for every module B below the module, A, currently being
-compiled:
- import B <n> ;
-to record the fact that A does import B indirectly. This is used to decide
-to look to look for B.hi rather than B.hi-boot when compiling a module that
-imports A. This line says that A imports B, but uses nothing in it.
-So we'll get an early bale-out when compiling A if B's version changes.
-
-The usage information records:
-
-\begin{itemize}
-\item (a) anything reachable from its body code
-\item (b) any module exported with a @module Foo@
-\item (c) anything reachable from an exported item
-\end{itemize}
-
-Why (b)? Because if @Foo@ changes then this module's export list
-will change, so we must recompile this module at least as far as
-making a new interface file --- but in practice that means complete
-recompilation.
-
-Why (c)? Consider this:
-\begin{verbatim}
- module A( f, g ) where | module B( f ) where
- import B( f ) | f = h 3
- g = ... | h = ...
-\end{verbatim}
-
-Here, @B.f@ isn't used in A. Should we nevertheless record @B.f@ in
-@A@'s usages? Our idea is that we aren't going to touch A.hi if it is
-*identical* to what it was before. If anything about @B.f@ changes
-than anyone who imports @A@ should be recompiled in case they use
-@B.f@ (they'll get an early exit if they don't). So, if anything
-about @B.f@ changes we'd better make sure that something in A.hi
-changes, and the convenient way to do that is to record the version
-number @B.f@ in A.hi in the usage list. If B.f changes that'll force a
-complete recompiation of A, which is overkill but it's the only way to
-write a new, slightly different, A.hi.
-
-But the example is tricker. Even if @B.f@ doesn't change at all,
-@B.h@ may do so, and this change may not be reflected in @f@'s version
-number. But with -O, a module that imports A must be recompiled if
-@B.h@ changes! So A must record a dependency on @B.h@. So we treat
-the occurrence of @B.f@ in the export list *just as if* it were in the
-code of A, and thereby haul in all the stuff reachable from it.
-
- *** Conclusion: if A mentions B.f in its export list,
- behave just as if A mentioned B.f in its source code,
- and slurp in B.f and all its transitive closure ***
-
-[NB: If B was compiled with -O, but A isn't, we should really *still*
-haul in all the unfoldings for B, in case the module that imports A *is*
-compiled with -O. I think this is the case.]
-
+ the actual fingerprint for all each thing recorded in mi_usages
\begin{code}
#include "HsVersions.h"
import IdInfo
import NewDemand
import CoreSyn
+import CoreFVs
import Class
import TyCon
import DataCon
import Type
import TcType
-import TysPrim
import InstEnv
import FamInstEnv
import TcRnMonad
import HscTypes
-
+import Finder
import DynFlags
+import VarEnv
+import Var
import Name
+import RdrName
import NameEnv
import NameSet
import OccName
import Module
import BinIface
-import Unique
import ErrUtils
import Digraph
import SrcLoc
-import PackageConfig hiding ( Version )
import Outputable
import BasicTypes hiding ( SuccessFlag(..) )
-import UniqFM
+import LazyUniqFM
+import Unique
import Util hiding ( eqListBy )
import FiniteMap
import FastString
import Maybes
+import ListSetOps
+import Binary
+import Fingerprint
+import Bag
+import Panic
import Control.Monad
import Data.List
+import Data.IORef
+import System.FilePath
+import System.Exit ( exitWith, ExitCode(..) )
\end{code}
\begin{code}
mkIface :: HscEnv
- -> Maybe ModIface -- The old interface, if we have it
- -> ModGuts -- Usages, deprecations, etc
+ -> Maybe Fingerprint -- The old fingerprint, if we have it
-> ModDetails -- The trimmed, tidied interface
- -> IO (ModIface, -- The new one, complete with decls and versions
- Bool) -- True <=> there was an old Iface, and the new one
- -- is identical, so no need to write it
+ -> ModGuts -- Usages, deprecations, etc
+ -> IO (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_iface
- (ModGuts{ mg_module = this_mod,
+mkIface hsc_env maybe_old_fingerprint mod_details
+ ModGuts{ mg_module = this_mod,
mg_boot = is_boot,
- mg_usages = usages,
+ 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_deprecs = src_deprecs })
- (ModDetails{ md_insts = insts,
+ 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
+
+-- | 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
+ -> ModDetails -- gotten from mkBootModDetails, probably
+ -> TcGblEnv -- Usages, deprecations, etc
+ -> IO (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 -- What dfuns are used
+ 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 -- Whether TH is used
+ 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.)
+
+ -- Modules don't compare lexicographically usually,
+ -- but we want them to do so here.
+ le_mod :: Module -> Module -> Bool
+ le_mod m1 m2 = moduleNameFS (moduleName m1)
+ <= moduleNameFS (moduleName m2)
+
+ le_dep_mod :: (ModuleName, IsBootInterface)
+ -> (ModuleName, IsBootInterface) -> Bool
+ le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2
+
+
+ pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
+ | otherwise = imp_dep_pkgs imports
+
+ return Deps { dep_mods = sortLe le_dep_mod dep_mods,
+ dep_pkgs = sortLe (<=) pkgs,
+ dep_orphs = sortLe le_mod (imp_orphs imports),
+ dep_finsts = sortLe le_mod (imp_finsts imports) }
+ -- sort to get into canonical order
+
+
+mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
+ -> NameSet -> Dependencies -> GlobalRdrEnv
+ -> NameEnv FixItem -> Warnings -> HpcInfo
+ -> ImportedMods
+ -> ModDetails
+ -> IO (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_vect_info = vect_info,
md_types = type_env,
- md_exports = exports })
-
+ 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 { eps <- hscEPS hsc_env
+ = do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names
+
; let { entities = typeEnvElts type_env ;
decls = [ tyThingToIfaceDecl entity
| entity <- entities,
- not (isImplicitTyThing entity
- || isWiredInName (getName entity)) ]
- -- Don't put implicit Ids and class tycons in
- -- the interface file, Nor wired-in things; the
- -- compiler knows about them anyhow
-
- ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env]
- ; deprecs = mkIfaceDeprec src_deprecs
- ; iface_rules = map coreRuleToIfaceRule rules
+ 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
; intermediate_iface = ModIface {
mi_module = this_mod,
mi_deps = deps,
mi_usages = usages,
mi_exports = mkIfaceExports exports,
+
+ -- Sort these lexicographically, so that
+ -- the result is stable across compilations
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_deprecs = deprecs,
+ mi_warns = warns,
mi_globals = Just rdr_env,
-- Left out deliberately: filled in by addVersionInfo
- mi_mod_vers = initialVersion,
- mi_exp_vers = initialVersion,
- mi_rule_vers = initialVersion,
+ mi_iface_hash = fingerprint0,
+ mi_mod_hash = fingerprint0,
+ mi_exp_hash = fingerprint0,
+ mi_orphan_hash = fingerprint0,
mi_orphan = False, -- Always set by addVersionInfo, but
-- it's a strict field, so we can't omit it.
mi_finsts = False, -- Ditto
mi_decls = deliberatelyOmitted "decls",
- mi_ver_fn = deliberatelyOmitted "ver_fn",
+ mi_hash_fn = deliberatelyOmitted "hash_fn",
+ mi_hpc = isHpcUsed hpc_info,
-- And build the cached values
- mi_dep_fn = mkIfaceDepCache deprecs,
+ mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities }
+ }
- -- Add version information
- ; ext_ver_fn = mkParentVerFun hsc_env eps
- ; (new_iface, no_change_at_all, pp_diffs, pp_orphs)
- = _scc_ "versioninfo"
- addVersionInfo ext_ver_fn maybe_old_iface
+ ; (new_iface, no_change_at_all)
+ <- {-# SCC "versioninfo" #-}
+ addFingerprints hsc_env maybe_old_fingerprint
intermediate_iface decls
- }
- -- Debug printing
- ; when (isJust pp_orphs && dopt Opt_WarnOrphans dflags)
- (printDump (expectJust "mkIface" pp_orphs))
- ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
+ -- Warn about orphans
+ ; let orph_warnings --- Laziness means no work done unless -fwarn-orphans
+ | 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) ]
+
+ ; when (not (isEmptyBag orph_warnings))
+ (do { printErrorsAndWarnings dflags errs_and_warns -- XXX
+ ; when (errorsFound dflags errs_and_warns)
+ (exitWith (ExitFailure 1)) })
+
+-- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
+
+ -- Debug printing
; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
(pprModIface new_iface)
- ; return (new_iface, no_change_at_all) }
+ -- bug #1617: on reload we weren't updating the PrintUnqualified
+ -- correctly. This stems from the fact that the interface had
+ -- not changed, so addVersionInfo returns the old ModIface
+ -- with the old GlobalRdrEnv (mi_globals).
+ ; let final_iface = new_iface{ mi_globals = Just rdr_env }
+
+ ; return (final_iface, no_change_at_all) }
where
- r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
- i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2
- i1 `le_fam_inst` i2 = ifFamInstTyConOcc i1 <= ifFamInstTyConOcc i2
+ 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
+ -- Compare lexicographically by OccName, *not* by unique, because
+ -- the latter is not stable across compilations
+ le_occ n1 n2 = nameOccName n1 <= nameOccName n2
dflags = hsc_dflags hsc_env
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
- ifFamInstTyConOcc = nameOccName . ifaceTyConName . ifFamInstTyCon
+ 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 (directoryOf hi_file_path)
+ = do createDirectoryHierarchy (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_ver_fn field in each ModIface.
--- Given a Name, it finds the ModIface, and then uses mi_ver_fn to get
+-- 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.
-mkParentVerFun
+mkHashFun
:: HscEnv -- needed to look up versions
-> ExternalPackageState -- ditto
- -> (Name -> (OccName,Version))
-mkParentVerFun hsc_env eps
+ -> (Name -> Fingerprint)
+mkHashFun hsc_env eps
= \name ->
let
- mod = nameModule name
+ 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
- mi_ver_fn iface occ `orElse`
- pprPanic "lookupVers1" (ppr mod <+> ppr occ)
+ snd (mi_hash_fn iface occ `orElse`
+ pprPanic "lookupVers1" (ppr mod <+> ppr occ))
where
hpt = hsc_HPT hsc_env
pit = eps_PIT eps
------------------------------------------------------------------------------
--- Compute version numbers for local decls
-
-addVersionInfo
- :: (Name -> (OccName,Version)) -- lookup parents and versions of names
- -> Maybe ModIface -- The old interface, read from M.hi
- -> ModIface -- The new interface (lacking decls)
- -> [IfaceDecl] -- The new decls
- -> (ModIface, -- Updated interface
- Bool, -- True <=> no changes at all; no need to write Iface
- SDoc, -- Differences
- Maybe SDoc) -- Warnings about orphans
-
-addVersionInfo ver_fn Nothing new_iface new_decls
--- No old interface, so definitely write a new one!
- = (new_iface { mi_orphan = anyNothing ifInstOrph (mi_insts new_iface)
- || anyNothing ifRuleOrph (mi_rules new_iface)
- , mi_finsts = not . null $ mi_fam_insts new_iface
- , mi_decls = [(initialVersion, decl) | decl <- new_decls]
- , mi_ver_fn = mkIfaceVerCache (zip (repeat initialVersion)
- new_decls)
- },
- False,
- ptext SLIT("No old interface file"),
- pprOrphans orph_insts orph_rules)
- where
- orph_insts = filter (isNothing . ifInstOrph) (mi_insts new_iface)
- orph_rules = filter (isNothing . ifRuleOrph) (mi_rules new_iface)
-
-addVersionInfo ver_fn (Just old_iface@(ModIface {
- mi_mod_vers = old_mod_vers,
- mi_exp_vers = old_exp_vers,
- mi_rule_vers = old_rule_vers,
- mi_decls = old_decls,
- mi_ver_fn = old_decl_vers,
- mi_fix_fn = old_fixities }))
- new_iface@(ModIface { mi_fix_fn = new_fixities })
- new_decls
- | no_change_at_all
- = (old_iface, True, ptext SLIT("Interface file unchanged"), pp_orphs)
- | otherwise
- = (final_iface, False, vcat [ptext SLIT("Interface file has changed"),
- nest 2 pp_diffs], pp_orphs)
- where
- final_iface = new_iface {
- mi_mod_vers = bump_unless no_output_change old_mod_vers,
- mi_exp_vers = bump_unless no_export_change old_exp_vers,
- mi_rule_vers = bump_unless no_rule_change old_rule_vers,
- mi_orphan = not (null new_orph_rules && null new_orph_insts),
- mi_finsts = not . null $ mi_fam_insts new_iface,
- mi_decls = decls_w_vers,
- mi_ver_fn = mkIfaceVerCache decls_w_vers }
-
- decls_w_vers = [(add_vers decl, decl) | decl <- new_decls]
-
- -------------------
- (old_non_orph_insts, old_orph_insts) =
- mkOrphMap ifInstOrph (mi_insts old_iface)
- (new_non_orph_insts, new_orph_insts) =
- mkOrphMap ifInstOrph (mi_insts new_iface)
- old_fam_insts = mi_fam_insts old_iface
- new_fam_insts = mi_fam_insts new_iface
- same_insts occ = eqMaybeBy (eqListBy eqIfInst)
- (lookupOccEnv old_non_orph_insts occ)
- (lookupOccEnv new_non_orph_insts occ)
-
- (old_non_orph_rules, old_orph_rules) =
- mkOrphMap ifRuleOrph (mi_rules old_iface)
- (new_non_orph_rules, new_orph_rules) =
- mkOrphMap ifRuleOrph (mi_rules new_iface)
- same_rules occ = eqMaybeBy (eqListBy eqIfRule)
- (lookupOccEnv old_non_orph_rules occ)
- (lookupOccEnv new_non_orph_rules occ)
- -------------------
- -- Computing what changed
- no_output_change = no_decl_change && no_rule_change &&
- no_export_change && no_deprec_change
- no_export_change = mi_exports new_iface == mi_exports old_iface
- -- Kept sorted
- no_decl_change = isEmptyOccSet changed_occs
- no_rule_change = not (changedWrtNames changed_occs (eqListBy eqIfRule old_orph_rules new_orph_rules)
- || changedWrtNames changed_occs (eqListBy eqIfInst old_orph_insts new_orph_insts)
- || changedWrtNames changed_occs (eqListBy eqIfFamInst old_fam_insts new_fam_insts))
- no_deprec_change = mi_deprecs new_iface == mi_deprecs old_iface
-
- -- If the usages havn't changed either, we don't need to write the interface file
- no_other_changes = mi_usages new_iface == mi_usages old_iface &&
- mi_deps new_iface == mi_deps old_iface
- no_change_at_all = no_output_change && no_other_changes
-
- pp_diffs = vcat [pp_change no_export_change "Export list"
- (ppr old_exp_vers <+> arrow <+> ppr (mi_exp_vers final_iface)),
- pp_change no_rule_change "Rules"
- (ppr old_rule_vers <+> arrow <+> ppr (mi_rule_vers final_iface)),
- pp_change no_deprec_change "Deprecations" empty,
- pp_change no_other_changes "Usages" empty,
- pp_decl_diffs]
- pp_change True what info = empty
- pp_change False what info = text what <+> ptext SLIT("changed") <+> info
-
- -------------------
- old_decl_env = mkOccEnv [(ifName decl, decl) | (_,decl) <- old_decls]
- same_fixity n = bool (old_fixities n == new_fixities n)
-
- -------------------
- -- Adding version info
- new_version = bumpVersion old_mod_vers
- -- Start from the old module version, not from
- -- zero so that if you remove f, and then add
- -- it again, you don't thereby reduce f's
- -- version number
-
- add_vers decl | occ `elemOccSet` changed_occs = new_version
- | otherwise = snd (expectJust "add_vers" (old_decl_vers occ))
- -- If it's unchanged, there jolly well
- where -- should be an old version number
- occ = ifName decl
-
- -------------------
- -- Deciding which declarations have changed
-
- -- For each local decl, the IfaceEq gives the list of things that
- -- must be unchanged for the declaration as a whole to be unchanged.
- eq_info :: [(OccName, IfaceEq)]
- eq_info = map check_eq new_decls
- check_eq new_decl
- | Just old_decl <- lookupOccEnv old_decl_env occ
- = (occ, new_decl `eqIfDecl` old_decl &&& eq_indirects new_decl)
- | otherwise {- No corresponding old decl -}
- = (occ, NotEqual)
+-- ---------------------------------------------------------------------------
+-- 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 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
+
+ -- 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 <- ifaceDeclSubBndrs 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
+ = 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)) -- (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 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'
+ -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
+ let stable_abis = sortBy cmp_abiNames abis
+ -- put the cycle in a canonical order
+ 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
- occ = ifName new_decl
-
- eq_indirects :: IfaceDecl -> IfaceEq
- -- When seeing if two decls are the same, remember to
- -- check whether any relevant fixity or rules have changed
- eq_indirects (IfaceId {ifName = occ}) = eq_ind_occ occ
- eq_indirects (IfaceClass {ifName = cls_occ, ifSigs = sigs})
- = same_insts cls_occ &&&
- eq_ind_occs [op | IfaceClassOp op _ _ <- sigs]
- eq_indirects (IfaceData {ifName = tc_occ, ifCons = cons})
- = same_insts tc_occ &&& same_fixity tc_occ &&& -- The TyCon can have a fixity too
- eq_ind_occs (map ifConOcc (visibleIfConDecls cons))
- eq_indirects other = Equal -- Synonyms and foreign declarations
-
- eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules
- eq_ind_occ occ = same_fixity occ &&& same_rules occ
- eq_ind_occs = foldr ((&&&) . eq_ind_occ) Equal
-
- -- The Occs of declarations that changed.
- changed_occs :: OccSet
- changed_occs = computeChangedOccs ver_fn (mi_module new_iface)
- (mi_usages old_iface) eq_info
-
- -------------------
- -- Diffs
- pp_decl_diffs :: SDoc -- Nothing => no changes
- pp_decl_diffs
- | isEmptyOccSet changed_occs = empty
- | otherwise
- = vcat [ptext SLIT("Changed occs:") <+> ppr (occSetElts changed_occs),
- ptext SLIT("Version change for these decls:"),
- nest 2 (vcat (map show_change new_decls))]
-
- eq_env = mkOccEnv eq_info
- show_change new_decl
- | not (occ `elemOccSet` changed_occs) = empty
- | otherwise
- = vcat [ppr occ <+> ppr (old_decl_vers occ) <+> arrow <+> ppr new_version,
- nest 2 why]
- where
- occ = ifName new_decl
- why = case lookupOccEnv eq_env occ of
- Just (EqBut names) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:"),
- nest 2 (braces (fsep (map ppr (occSetElts
- (occs `intersectOccSet` changed_occs)))))]
- where occs = mkOccSet (map nameOccName (nameSetToList names))
- Just NotEqual
- | Just old_decl <- lookupOccEnv old_decl_env occ
- -> vcat [ptext SLIT("Old:") <+> ppr old_decl,
- ptext SLIT("New:") <+> ppr new_decl]
- | otherwise
- -> ppr occ <+> ptext SLIT("only in new interface")
- other -> pprPanic "MkIface.show_change" (ppr occ)
-
- pp_orphs = pprOrphans new_orph_insts new_orph_rules
-
-
-pprOrphans insts rules
- | null insts && null rules = Nothing
- | otherwise
- = Just $ vcat [
- if null insts then empty else
- hang (ptext SLIT("Warning: orphan instances:"))
- 2 (vcat (map ppr insts)),
- if null rules then empty else
- hang (ptext SLIT("Warning: orphan rules:"))
- 2 (vcat (map ppr rules))
- ]
+ 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
+
+ -- 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 dependeny 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 dflags (mk_put_name local_env)
+ (map IfaceInstABI orph_insts, orph_rules, fam_insts)
+
+ -- the export list hash doesn't depend on the fingerprints of
+ -- the Names it mentions, only the Names themselves, hence putNameLiterally.
+ export_hash <- computeFingerprint dflags putNameLiterally
+ (mi_exports iface0, orphan_hash, dep_orphan_hashes)
+
+ -- put the declarations in a canonical order, sorted by OccName
+ let sorted_decls = eltsFM $ listToFM $
+ [(ifName d, e) | e@(_, d) <- decls_w_hashes]
+
+ -- the ABI hash depends on:
+ -- - decls
+ -- - export list
+ -- - orphans
+ -- - deprecations
+ -- - XXX vect info?
+ mod_hash <- computeFingerprint dflags putNameLiterally
+ (map fst sorted_decls,
+ export_hash,
+ orphan_hash,
+ mi_warns iface0)
+
+ -- The interface hash depends on:
+ -- - the ABI hash, plus
+ -- - usages
+ -- - deps
+ -- - hpc
+ 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)
-computeChangedOccs
- :: (Name -> (OccName,Version)) -- get parents and versions
- -> Module -- This module
- -> [Usage] -- Usages from old iface
- -> [(OccName, IfaceEq)] -- decl names, equality conditions
- -> OccSet -- set of things that have changed
-computeChangedOccs ver_fn this_module old_usages eq_info
- = foldl add_changes emptyOccSet (stronglyConnComp edges)
where
-
- -- return True if an external name has changed
- name_changed :: Name -> Bool
- name_changed nm
- | Just ents <- lookupUFM usg_modmap (moduleName mod)
- = case lookupUFM ents parent_occ of
- Nothing -> pprPanic "computeChangedOccs" (ppr nm)
- Just v -> v < new_version
- | otherwise = False -- must be in another package
- where
- mod = nameModule nm
- (parent_occ, new_version) = ver_fn nm
-
- -- Turn the usages from the old ModIface into a mapping
- usg_modmap = listToUFM [ (usg_mod usg, listToUFM (usg_entities usg))
- | usg <- old_usages ]
-
- get_local_eq_info :: GenIfaceEq NameSet -> GenIfaceEq OccSet
- get_local_eq_info Equal = Equal
- get_local_eq_info NotEqual = NotEqual
- get_local_eq_info (EqBut ns) = foldNameSet f Equal ns
- where f name eq | nameModule name == this_module =
- EqBut (unitOccSet (nameOccName name)) `and_occifeq` eq
- | name_changed name = NotEqual
- | otherwise = eq
-
- local_eq_infos = mapSnd get_local_eq_info eq_info
-
- edges :: [((OccName, OccIfaceEq), Unique, [Unique])]
- edges = [ (node, getUnique occ, map getUnique occs)
- | node@(occ, iface_eq) <- local_eq_infos
- , let occs = case iface_eq of
- EqBut occ_set -> occSetElts occ_set
- other -> [] ]
-
- -- Changes in declarations
- add_changes :: OccSet -> SCC (OccName, OccIfaceEq) -> OccSet
- add_changes so_far (AcyclicSCC (occ, iface_eq))
- | changedWrt so_far iface_eq -- This one has changed
- = extendOccSet so_far occ
- add_changes so_far (CyclicSCC pairs)
- | changedWrt so_far (foldr1 and_occifeq iface_eqs)
- -- One of this group has changed
- = extendOccSetList so_far occs
- where (occs, iface_eqs) = unzip pairs
- add_changes so_far other = so_far
-
-type OccIfaceEq = GenIfaceEq OccSet
-
-changedWrt :: OccSet -> OccIfaceEq -> Bool
-changedWrt so_far Equal = False
-changedWrt so_far NotEqual = True
-changedWrt so_far (EqBut kids) = so_far `intersectsOccSet` kids
-
-changedWrtNames :: OccSet -> IfaceEq -> Bool
-changedWrtNames so_far Equal = False
-changedWrtNames so_far NotEqual = True
-changedWrtNames so_far (EqBut kids) =
- so_far `intersectsOccSet` mkOccSet (map nameOccName (nameSetToList kids))
-
-and_occifeq :: OccIfaceEq -> OccIfaceEq -> OccIfaceEq
-Equal `and_occifeq` x = x
-NotEqual `and_occifeq` x = NotEqual
-EqBut nms `and_occifeq` Equal = EqBut nms
-EqBut nms `and_occifeq` NotEqual = NotEqual
-EqBut nms1 `and_occifeq` EqBut nms2 = EqBut (nms1 `unionOccSets` nms2)
+ 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)
+ -- ToDo: shouldn't we be splitting fam_insts into orphans and
+ -- non-orphans?
+ 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) }
+
+-- The ABI of a declaration consists of:
+ -- 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).
+ -- the fixity of the identifier
+ -- 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.
+ -- for Ids: rules
+ -- for classes: instances, fixity & rules for methods
+ -- for datatypes: instances, fixity & rules for constrs
+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 [IfaceInstABI] [(Fixity,[IfaceRule])]
+ | 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 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 insts methods) = do
+ putByte bh 3; put_ bh insts; put_ bh methods
+ put_ bh IfaceOtherDeclExtras = do
+ putByte bh 4
+
+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
+ (map IfaceInstABI $ lookupOccEnvL inst_env n)
+ [id_extras op | IfaceClassOp op _ _ <- sigs]
+ _other -> IfaceOtherDeclExtras
+ where
+ n = ifName decl
+ id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
+
+--
+-- When hashing an instance, we hash only its structure, not the
+-- fingerprints of the things it mentions. See the section on instances
+-- in the commentary,
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
+--
+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` []
+
+-- 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 }
+
+computeFingerprint :: Binary a
+ => DynFlags
+ -> (BinHandle -> Name -> IO ())
+ -> a
+ -> IO Fingerprint
+
+computeFingerprint _dflags put_name a = do
+ bh <- openBinMem (3*1024) -- just less than a block
+ ud <- newWriteState put_name putFS
+ bh <- return $ setUserData bh ud
+ put_ bh a
+ fingerprintBinMem bh
+
+{-
+-- 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 :: 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)
+ -- 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
| Just occ <- get_key d
= (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs)
| otherwise = (non_orphs, d:orphs)
-
-anyNothing :: (a -> Maybe b) -> [a] -> Bool
-anyNothing p [] = False
-anyNothing p (x:xs) = isNothing (p x) || anyNothing p xs
-
-----------------------
-mkIfaceDeprec :: Deprecations -> IfaceDeprecs
-mkIfaceDeprec NoDeprecs = NoDeprecs
-mkIfaceDeprec (DeprecAll t) = DeprecAll t
-mkIfaceDeprec (DeprecSome env) = DeprecSome (sortLe (<=) (nameEnvElts env))
-
-----------------------
-bump_unless :: Bool -> Version -> Version
-bump_unless True v = v -- True <=> no change
-bump_unless False v = bumpVersion v
\end{code}
%*********************************************************
%* *
-\subsection{Keeping track of what we've slurped, and version numbers}
+\subsection{Keeping track of what we've slurped, and fingerprints}
%* *
%*********************************************************
\begin{code}
-mkUsageInfo :: HscEnv
- -> ModuleEnv (Module, Bool, SrcSpan)
- -> [(ModuleName, IsBootInterface)]
- -> NameSet -> IO [Usage]
-mkUsageInfo hsc_env dir_imp_mods dep_mods used_names
+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
- dir_imp_mods dep_mods used_names
+ ; let usages = mk_usage_info (eps_PIT eps) hsc_env this_mod
+ dir_imp_mods used_names
; 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.
-mk_usage_info pit hsc_env dir_imp_mods dep_mods used_names
- = mapCatMaybes mkUsage dep_mods
- -- ToDo: do we need to sort into canonical order?
+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
+ -- canonical order is imported, to avoid interface-file
+ -- wobblage.
-- ent_map groups together all the things imported and used
- -- from a particular module in this package
+ -- from a particular module
ent_map :: ModuleEnv [OccName]
ent_map = foldNameSet add_mv emptyModuleEnv used_names
- add_mv name mv_map
+ where
+ add_mv name mv_map
| isWiredInName name = mv_map -- ignore wired-in names
| otherwise
= case nameModule_maybe name of
- Nothing -> mv_map -- ignore internal names
- Just mod -> extendModuleEnv_C add_item mv_map mod [occ]
- where
- occ = nameOccName name
- add_item occs _ = occ:occs
-
- depend_on_exports mod = case lookupModuleEnv dir_imp_mods mod of
- Just (_,no_imp,_) -> not no_imp
- Nothing -> True
+ Nothing -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map
+ Just mod -> extendModuleEnv_C (++) mv_map mod [occ]
+ where occ = nameOccName name
-- We want to create a Usage for a home module if
- -- a) we used something from; has something in used_names
- -- b) we imported all of it, even if we used nothing from it
- -- (need to recompile if its export list changes: export_vers)
- -- c) is a home-package orphan or family-instance module (need to
- -- recompile if its instance decls change: rules_vers)
- mkUsage :: (ModuleName, IsBootInterface) -> Maybe Usage
- mkUsage (mod_name, _)
- | isNothing maybe_iface -- We can't depend on it if we didn't
- || (null used_occs -- load its interface.
- && isNothing export_vers
- && not orphan_mod
+ -- 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 }
+ -- 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 (Usage { usg_name = mod_name,
- usg_mod = mod_vers,
- usg_exports = export_vers,
- usg_entities = fmToList ent_vers,
- usg_rules = rules_vers })
+ = 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
-- In one-shot mode, the interfaces for home-package
-- modules accumulate in the PIT not HPT. Sigh.
- mod = mkModule (thisPackage dflags) mod_name
+ is_direct_import = mod `elemModuleEnv` direct_imports
Just iface = maybe_iface
- orphan_mod = mi_orphan iface
finsts_mod = mi_finsts iface
- version_env = mi_ver_fn iface
- mod_vers = mi_mod_vers iface
- rules_vers = mi_rule_vers iface
- export_vers | depend_on_exports mod = Just (mi_exp_vers 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` []
-- and (b) that the usages emerge in a canonical order, which
-- is why we use FiniteMap rather than OccEnv: FiniteMap works
-- using Ord on the OccNames, which is a lexicographic ordering.
- ent_vers :: FiniteMap OccName Version
- ent_vers = listToFM (map lookup_occ used_occs)
+ ent_hashs :: FiniteMap OccName Fingerprint
+ ent_hashs = listToFM (map lookup_occ used_occs)
lookup_occ occ =
- case version_env occ of
- Nothing -> pprTrace "hmm, strange" (ppr mod <+> ppr occ) $
- (occ, initialVersion) -- does this ever happen?
- Just (parent, version) -> (parent, version)
+ 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
+ -- 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.
+ Nothing -> False
+ -- In GHC 6.8.x the above line read "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}
| (mod, avails) <- fmToList groupFM
]
where
+ -- Group by the module where the exported entities are defined
+ -- (which may not be the same for all Names in an Avail)
-- Deliberately use FiniteMap rather than UniqFM so we
-- get a canonical ordering
groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
groupFM = foldl add emptyModuleEnv exports
- add env avail
- = extendModuleEnv_C add_avail env mod (unitFM avail_fs avail_occ)
+ 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)
+
+ -- NB: we should not get T(X) and T(Y) in the export list
+ -- else the plusFM will simply discard one! They
+ -- should have been combined by now.
+ 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
- avail_occ = availToOccs avail
- mod = nameModule (availName avail)
- avail_fs = occNameFS (availName avail_occ)
- add_avail avail_fm _ = addToFM avail_fm avail_fs avail_occ
-
- availToOccs (Avail n) = Avail (nameOccName n)
- availToOccs (AvailTC tc ns) = AvailTC (nameOccName tc) (map nameOccName ns)
+ tc_occ = nameOccName tc
+ mods = nub (map nameModule ns)
+ -- Usually just one, but see Note [Original module]
+
+ add_for_mod env mod
+ = add_one env mod (AvailTC tc_occ (sort names_from_mod))
+ -- NB. sort the children, we need a canonical order
+ 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.
+
%************************************************************************
%* *
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 -- CHECK WHETHER THE SOURCE HAS CHANGED
- { ifM (not source_unchanged)
+ { when (not source_unchanged)
(traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
-- 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.
- ; ghc_mode <- getGhcMode
- ; if (ghc_mode == Interactive || ghc_mode == JustTypecheck)
- && not source_unchanged then
+ ; 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 -- Use the one we already have
{ traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
- ; recomp <- checkVersions hsc_env source_unchanged old_iface
+ ; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface
; return (recomp, Just old_iface) }
; Nothing -> do
-- We have got the old iface; check its versions
{ traceIf (text "Read the interface file" <+> text iface_path)
- ; recomp <- checkVersions hsc_env source_unchanged iface
- ; returnM (recomp, Just iface)
+ ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
+ ; return (recomp, Just iface)
}}}}}
+
\end{code}
@recompileRequired@ is called from the HscMain. It checks whether
\begin{code}
type RecompileRequired = Bool
+upToDate, outOfDate :: Bool
upToDate = False -- Recompile not required
outOfDate = True -- Recompile required
checkVersions :: HscEnv
-> Bool -- True <=> source unchanged
+ -> ModSummary
-> ModIface -- Old interface
-> IfG RecompileRequired
-checkVersions hsc_env source_unchanged iface
+checkVersions hsc_env source_unchanged mod_summary iface
| not source_unchanged
- = returnM outOfDate
+ = return outOfDate
| otherwise
= do { traceHiDiffs (text "Considering whether compilation is required for" <+>
ppr (mi_module iface) <> colon)
- -- Source code unchanged and no errors yet... carry on
+ ; recomp <- checkDependencies hsc_env mod_summary iface
+ ; if recomp then return outOfDate else do {
- -- First put the dependent-module info, read from the old interface, into the envt,
- -- so that when we look for interfaces we look for the right one (.hi or .hi-boot)
+ -- Source code unchanged and no errors yet... carry on
+ --
+ -- First put the dependent-module info, read from the old
+ -- interface, into the envt, so that when we look for
+ -- interfaces we look for the right one (.hi or .hi-boot)
--
-- It's just temporary because either the usage check will succeed
-- (in which case we are done with this module) or it'll fail (in which
-- We do this regardless of compilation mode, although in --make mode
-- all the dependent modules should be in the HPT already, so it's
-- quite redundant
- ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
+ 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
-- This is a bit of a hack really
mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
mod_deps = mkModDeps (dep_mods (mi_deps iface))
+
+-- If the direct imports of this module are resolved to targets that
+-- are not among the dependencies of the previous interface file,
+-- then we definitely need to recompile. This catches cases like
+-- - an exposed package has been upgraded
+-- - we are compiling with different package flags
+-- - a home module that was shadowing a package module has been removed
+-- - a new home module has been added that shadows a package module
+-- See bug #1372.
+--
+-- Returns True if recompilation is required.
+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 _ mod) = do
+ find_res <- liftIO $ findImportedModule hsc_env mod Nothing
+ 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 -- Load the imported interface if possible
+ 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
+ -- Load the interface, but don't complain on failure;
+ -- Instead, get an Either back which we can test
+
+ case mb_iface of
+ Failed _ -> (out_of_date (sep [ptext (sLit "Couldn't load interface for module"),
+ ppr mod]))
+ -- Couldn't find or parse a module mentioned in the
+ -- old interface file. Don't complain: it might
+ -- just be that the current module doesn't need that
+ -- import and it's been deleted
+ Succeeded iface -> continue iface
+
+
checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
-- Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
-- whether M needs to be recompiled.
-checkModUsage this_pkg (Usage { usg_name = mod_name, usg_mod = old_mod_vers,
- usg_rules = old_rule_vers,
- usg_exports = maybe_old_export_vers,
- usg_entities = old_decl_vers })
- = -- Load the imported interface is possible
- let
- doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]
- in
- traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_`
+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)
+ -- We only track the ABI hash of package modules, rather than
+ -- individual entity usages, so if the ABI hash changes we must
+ -- recompile. This is safe but may entail more recompilation when
+ -- a dependent package has changed.
+
+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
- mod = mkModule this_pkg mod_name
- in
- loadInterface doc_str mod ImportBySystem `thenM` \ mb_iface ->
- -- Load the interface, but don't complain on failure;
- -- Instead, get an Either back which we can test
+ new_mod_hash = mi_mod_hash iface
+ new_decl_hash = mi_hash_fn iface
+ new_export_hash = mi_exp_hash iface
- case mb_iface of {
- Failed exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"),
- ppr mod_name]));
- -- Couldn't find or parse a module mentioned in the
- -- old interface file. Don't complain -- it might just be that
- -- the current module doesn't need that import and it's been deleted
-
- Succeeded iface ->
- let
- new_mod_vers = mi_mod_vers iface
- new_decl_vers = mi_ver_fn iface
- new_export_vers = mi_exp_vers iface
- new_rule_vers = mi_rule_vers iface
- in
-- CHECK MODULE
- checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile ->
- if not recompile then
- returnM upToDate
- else
+ recompile <- checkModuleFingerprint old_mod_hash new_mod_hash
+ if not recompile then return upToDate else do
-- CHECK EXPORT LIST
- if checkExportList maybe_old_export_vers new_export_vers then
- out_of_date_vers (ptext SLIT(" Export list changed"))
- (expectJust "checkModUsage" maybe_old_export_vers)
- new_export_vers
- else
-
- -- CHECK RULES
- if old_rule_vers /= new_rule_vers then
- out_of_date_vers (ptext SLIT(" Rules changed"))
- old_rule_vers new_rule_vers
- else
+ checkMaybeHash maybe_old_export_hash new_export_hash
+ (ptext (sLit " Export list changed")) $ do
-- CHECK ITEMS ONE BY ONE
- checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenM` \ recompile ->
- if recompile then
- returnM outOfDate -- This one failed, so just bail out now
- else
- up_to_date (ptext SLIT(" Great! The bits I use are up to date"))
- }
+ recompile <- checkList [ checkEntityUsage new_decl_hash u
+ | u <- old_decl_hash]
+ if recompile
+ then return outOfDate -- This one failed, so just bail out now
+ else up_to_date (ptext (sLit " Great! The bits I use are up to date"))
------------------------
-checkModuleVersion old_mod_vers new_mod_vers
- | new_mod_vers == old_mod_vers
- = up_to_date (ptext SLIT("Module version unchanged"))
+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_vers (ptext SLIT(" Module version has changed"))
- old_mod_vers new_mod_vers
+ = out_of_date_hash (ptext (sLit " Module fingerprint has changed"))
+ old_mod_hash new_mod_hash
------------------------
-checkExportList Nothing new_vers = upToDate
-checkExportList (Just v) new_vers = v /= new_vers
+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 new_vers (name,old_vers)
- = case new_vers name of
+checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint))
+ -> (OccName, Fingerprint)
+ -> IfG Bool
+checkEntityUsage new_hash (name,old_hash)
+ = case new_hash name of
Nothing -> -- We used it before, but it ain't there now
- out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])
+ out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
- Just (_, new_vers) -- It's there, but is it up to date?
- | new_vers == old_vers -> traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_`
- returnM upToDate
- | otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name)
- old_vers new_vers
+ Just (_, new_hash) -- It's there, but is it up to date?
+ | 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 msg = traceHiDiffs msg `thenM_` returnM upToDate
-out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate
-out_of_date_vers msg old_vers new_vers
- = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers])
+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
-- This helper is used in two places
-checkList [] = returnM upToDate
-checkList (check:checks) = check `thenM` \ recompile ->
- if recompile then
- returnM outOfDate
- else
- checkList checks
+checkList [] = return upToDate
+checkList (check:checks) = do recompile <- check
+ if recompile
+ then return outOfDate
+ else checkList checks
\end{code}
%************************************************************************
tyThingToIfaceDecl (ATyCon tycon)
| isSynTyCon tycon
- = IfaceSyn { ifName = getOccName tycon,
- ifTyVars = toIfaceTvBndrs tyvars,
- ifOpenSyn = syn_isOpen,
- ifSynRhs = toIfaceType syn_tyki }
+ = IfaceSyn { ifName = getOccName tycon,
+ ifTyVars = toIfaceTvBndrs tyvars,
+ ifSynRhs = syn_rhs,
+ ifSynKind = syn_ki,
+ ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
+ }
| isAlgTyCon tycon
= IfaceData { ifName = getOccName tycon,
= IfaceForeign { ifName = getOccName tycon,
ifExtName = tyConExtName tycon }
- | isPrimTyCon tycon || isFunTyCon tycon
- -- Needed in GHCi for ':info Int#', for example
- = IfaceData { ifName = getOccName tycon,
- ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
- ifCtxt = [],
- ifCons = IfAbstractTyCon,
- ifGadtSyntax = False,
- ifGeneric = False,
- ifRec = NonRecursive,
- ifFamInst = Nothing }
-
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
tyvars = tyConTyVars tycon
- (syn_isOpen, syn_tyki) = case synTyConRhs tycon of
- OpenSynTyCon ki -> (True , ki)
- SynonymTyCon ty -> (False, ty)
+ (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 }) =
+ ifaceConDecls (NewTyCon { data_con = con }) =
IfNewTyCon (ifaceConDecl con)
- ifaceConDecls (DataTyCon { data_cons = cons }) =
+ ifaceConDecls (DataTyCon { data_cons = cons }) =
IfDataTyCon (map ifaceConDecl cons)
- ifaceConDecls OpenDataTyCon = IfOpenDataTyCon
- ifaceConDecls OpenNewTyCon = IfOpenNewTyCon
- ifaceConDecls AbstractTyCon = IfAbstractTyCon
+ ifaceConDecls OpenTyCon {} = IfOpenDataTyCon
+ ifaceConDecls AbstractTyCon = IfAbstractTyCon
-- The last case happens when a TyCon has been trimmed during tidying
-- Furthermore, tyThingToIfaceDecl is also used
-- in TcRnDriver for GHCi, when browsing a module, in which case the
ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con),
ifConEqSpec = to_eq_spec (dataConEqSpec data_con),
- ifConCtxt = toIfaceContext (dataConTheta data_con),
+ ifConCtxt = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
ifConArgTys = map toIfaceType (dataConOrigArgTys data_con),
ifConFields = map getOccName
(dataConFieldLabels data_con),
= pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
+getFS :: NamedThing a => a -> FastString
getFS x = occNameFS (getOccName x)
--------------------------
instanceToIfaceInst :: Instance -> IfaceInst
-instanceToIfaceInst ispec@(Instance { is_dfun = dfun_id, is_flag = oflag,
- is_cls = cls, is_tcs = mb_tcs,
- is_orph = orph })
- = IfaceInst { ifDFun = getName dfun_id,
+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,
+ 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
+
+ -- Compute orphanhood. See Note [Orphans] in IfaceSyn
+ (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
+ -- Slightly awkward: we need the Class to get the fundeps
+ (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] -- One for each fundep; a locally-defined name
+ -- that is not in the "determined" arguments
+ 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 fi@(FamInst { fi_tycon = tycon,
- fi_fam = fam, fi_tcs = mb_tcs })
+famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
+ fi_fam = fam,
+ fi_tcs = mb_tcs })
= IfaceFamInst { ifFamInstTyCon = toIfaceTyCon tycon
, ifFamInstFam = fam
, ifFamInstTys = map do_rough mb_tcs }
do_rough (Just n) = Just (toIfaceTyCon_name n)
--------------------------
+toIfaceLetBndr :: Id -> IfaceLetBndr
+toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
+ (toIfaceType (idType id))
+ prag_info
+ where
+ -- Stripped-down version of tcIfaceIdInfo
+ -- Change this if you want to export more IdInfo for
+ -- non-top-level Ids. Don't forget to change
+ -- CoreTidy.tidyLetBndr too!
+ --
+ -- See Note [IdInfo on nested let-bindings] in IfaceSyn
+ id_info = idInfo id
+ inline_prag = inlinePragInfo id_info
+ prag_info | isAlwaysActive inline_prag = NoInfo
+ | otherwise = HasInfo [HsInline inline_prag]
+
+--------------------------
toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
toIfaceIdInfo id_info
= catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
------------ Worker --------------
work_info = workerInfo id_info
- has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
+ has_worker = workerExists work_info
wrkr_hsinfo = case work_info of
HasWorker work_id wrap_arity ->
Just (HsWorker ((idName work_id)) wrap_arity)
| otherwise = Just (HsInline inline_prag)
--------------------------
-coreRuleToIfaceRule :: CoreRule -> IfaceRule
-coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})
+coreRuleToIfaceRule :: Module -> 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_orph = orph })
+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,
do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
do_arg arg = toIfaceExpr arg
+ -- Compute orphanhood. See Note [Orphans] in IfaceSyn
+ -- A rule is an orphan only if none of the variables
+ -- mentioned on its left-hand side are locally defined
+ lhs_names = fn : nameSetToList (exprsFreeNames args)
+ -- No need to delete bndrs, because
+ -- exprsFreeNames finds only External names
+
+ 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,
+ = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
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 (NonRec b r) = IfaceNonRec (toIfaceIdBndr b) (toIfaceExpr r)
-toIfaceBind (Rec prs) = IfaceRec [(toIfaceIdBndr b, toIfaceExpr r) | (b,r) <- prs]
+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
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
tup_args = map toIfaceExpr val_args
tc = dataConTyCon dc
- other -> mkIfaceApps (toIfaceVar v) as
+ _ -> 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
---------------------
| Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
-- Foreign calls have special syntax
| isExternalName name = IfaceExt name
+ | Just (TickBox m ix) <- isTickBoxOp_maybe v
+ = IfaceTick m ix
| otherwise = IfaceLcl (getFS name)
where
name = idName v
projects / ghc-hetmet.git / blobdiff