X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=ce6f4a30ab6e8b00aed6e7d6e05e7ce5f2315584;hp=1ea7592d5ebbce05b733244b06e0191175071032;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=392834a3ef2e08e253fa3f76302564d63dc48a1e diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 1ea7592..ce6f4a3 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1,5 +1,5 @@ % -% (c) The University of Glasgow 2006 +% (c) The University of Glasgow 2006-2008 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % @@ -22,28 +22,19 @@ module MkIface ( \end{code} ----------------------------------------------- - MkIface.lhs deals with versioning + Recompilation checking ----------------------------------------------- -Here's the fingerprint-related info in an interface file +A complete description of how recompilation checking works can be +found in the wiki commentary: - module Foo xxxxxxxxxxxxxxxx -- module fingerprint - yyyyyyyyyyyyyyyy -- export list fingerprint - zzzzzzzzzzzzzzzz -- rule fingerprint - Usages: -- Version info for what this compilation of Foo imported - Baz xxxxxxxxxxxxxxxx -- Module version - [yyyyyyyyyyyyyyyy] -- The export-list version - -- ( if Foo depended on it) - (g,zzzzzzzzzzzzzzzz) -- Function and its version - (T,wwwwwwwwwwwwwwww) -- Type and its version + http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance - f :: Int -> Int {- Unfolding: \x -> Wib.t x -} - - ----------------------------------------------- - 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 fingerprint of each free variable of the module @@ -56,137 +47,15 @@ Basic idea: * In checkOldIface we compare the mi_usages for the module with the actual fingerprint 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 fingerprint -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 fingerprint 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 fingerprint. 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 fingerprint 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 fingerprint, 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 ; -to record the fact that A does import B indirectly. This is used to decide -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 fingerprint 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.] - -SimonM [30/11/2007]: I believe the above is all out of date; the -current implementation doesn't do it this way. Instead, when any of -the dependencies of a declaration changes, the version of the -declaration itself changes. - \begin{code} #include "HsVersions.h" import IfaceSyn -import IfaceType import LoadIface import Id import IdInfo -import NewDemand +import Demand +import Annotations import CoreSyn import CoreFVs import Class @@ -197,6 +66,7 @@ import TcType import InstEnv import FamInstEnv import TcRnMonad +import HsSyn import HscTypes import Finder import DynFlags @@ -206,7 +76,6 @@ import Name import RdrName import NameEnv import NameSet -import OccName import Module import BinIface import ErrUtils @@ -214,7 +83,7 @@ import Digraph import SrcLoc import Outputable import BasicTypes hiding ( SuccessFlag(..) ) -import LazyUniqFM +import UniqFM import Unique import Util hiding ( eqListBy ) import FiniteMap @@ -223,7 +92,7 @@ import Maybes import ListSetOps import Binary import Fingerprint -import Panic +import Bag import Control.Monad import Data.List @@ -244,8 +113,9 @@ mkIface :: HscEnv -> Maybe Fingerprint -- The old fingerprint, if we have it -> ModDetails -- The trimmed, tidied interface -> ModGuts -- Usages, deprecations, etc - -> IO (ModIface, -- The new one - Bool) -- True <=> there was an old Iface, and the + -> 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 @@ -257,12 +127,12 @@ mkIface hsc_env maybe_old_fingerprint mod_details mg_dir_imps = dir_imp_mods, mg_rdr_env = rdr_env, mg_fix_env = fix_env, - mg_deprecs = deprecs, + 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 deprecs hpc_info dir_imp_mods mod_details - + 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'). @@ -270,15 +140,14 @@ mkIfaceTc :: HscEnv -> Maybe Fingerprint -- The old fingerprint, if we have it -> ModDetails -- gotten from mkBootModDetails, probably -> TcGblEnv -- Usages, deprecations, etc - -> IO (ModIface, - Bool) + -> IO (Messages, Maybe (ModIface, Bool)) mkIfaceTc hsc_env maybe_old_fingerprint mod_details tc_result@TcGblEnv{ tcg_mod = this_mod, tcg_src = hsc_src, tcg_imports = imports, tcg_rdr_env = rdr_env, tcg_fix_env = fix_env, - tcg_deprecs = deprecs, + tcg_warns = warns, tcg_hpc = other_hpc_info } = do @@ -287,7 +156,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details 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 deprecs hpc_info (imp_mods imports) mod_details + fix_env warns hpc_info (imp_mods imports) mod_details mkUsedNames :: TcGblEnv -> IO NameSet @@ -295,9 +164,8 @@ 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) + = do { dfun_uses <- readIORef dfun_uses_var -- What dfuns are used + ; return (allUses dus `unionNameSets` dfun_uses) } mkDependencies :: TcGblEnv -> IO Dependencies mkDependencies @@ -316,39 +184,29 @@ mkDependencies -- 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) } + return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods, + dep_pkgs = sortBy stablePackageIdCmp pkgs, + dep_orphs = sortBy stableModuleCmp (imp_orphs imports), + dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } -- sort to get into canonical order - + -- NB. remember to use lexicographic ordering mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface -> NameSet -> Dependencies -> GlobalRdrEnv - -> NameEnv FixItem -> Deprecations -> HpcInfo + -> NameEnv FixItem -> Warnings -> HpcInfo -> ImportedMods -> ModDetails - -> IO (ModIface, Bool) + -> IO (Messages, Maybe (ModIface, Bool)) mkIface_ hsc_env maybe_old_fingerprint - this_mod is_boot used_names deps rdr_env fix_env src_deprecs hpc_info + this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info dir_imp_mods ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, + md_anns = anns, md_vect_info = vect_info, md_types = type_env, md_exports = exports } @@ -371,7 +229,7 @@ mkIface_ hsc_env maybe_old_fingerprint -- Sigh: see Note [Root-main Id] in TcRnDriver ; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] - ; deprecs = src_deprecs + ; warns = src_warns ; iface_rules = map (coreRuleToIfaceRule this_mod) rules ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts @@ -393,7 +251,8 @@ mkIface_ hsc_env maybe_old_fingerprint mi_vect_info = iface_vect_info, mi_fixities = fixities, - mi_deprecs = deprecs, + mi_warns = warns, + mi_anns = mkIfaceAnnotations anns, mi_globals = Just rdr_env, -- Left out deliberately: filled in by addVersionInfo @@ -409,21 +268,35 @@ mkIface_ hsc_env maybe_old_fingerprint 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 } } - ; (new_iface, no_change_at_all, pp_orphs) + ; (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)) + -- 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) ] + + ; if errorsFound dflags errs_and_warns + then return ( errs_and_warns, Nothing ) + else do { -- 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) @@ -433,7 +306,7 @@ mkIface_ hsc_env maybe_old_fingerprint -- with the old GlobalRdrEnv (mi_globals). ; let final_iface = new_iface{ mi_globals = Just rdr_env } - ; return (final_iface, no_change_at_all) } + ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }} where r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2 @@ -484,7 +357,7 @@ mkHashFun 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) @@ -504,15 +377,14 @@ addFingerprints -> ModIface -- The new interface (lacking decls) -> [IfaceDecl] -- The new decls -> IO (ModIface, -- Updated interface - Bool, -- True <=> no changes at all; + Bool) -- True <=> no changes at all; -- no need to write Iface - Maybe SDoc) -- Warnings about orphans 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 + -- 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 @@ -526,8 +398,9 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls , let out = localOccs $ freeNamesDeclABI abi ] + name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n localOccs = map (getUnique . getParent . getOccName) - . filter ((== this_mod) . nameModule) + . filter ((== this_mod) . name_module) . nameSetToList where getParent occ = lookupOccEnv parent_map occ `orElse` occ @@ -541,7 +414,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls where n = ifName d -- strongly-connected groups of declarations, in dependency order - groups = stronglyConnComp edges + groups = stronglyConnCompFromEdgedVertices edges global_hash_fn = mkHashFun hsc_env eps @@ -557,7 +430,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls | isWiredInName name = putNameLiterally bh name -- wired-in names don't have fingerprints | otherwise - = let hash | nameModule name /= this_mod = global_hash_fn name + = 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" @@ -622,7 +496,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls 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 + -- 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 @@ -637,7 +511,12 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- 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) + (mi_exports iface0, + orphan_hash, + dep_orphan_hashes, + dep_pkgs (mi_deps iface0)) + -- dep_pkgs: see "Package Version Changes" on + -- wiki/Commentary/Compiler/RecompilationAvoidance -- put the declarations in a canonical order, sorted by OccName let sorted_decls = eltsFM $ listToFM $ @@ -653,7 +532,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls (map fst sorted_decls, export_hash, orphan_hash, - mi_deprecs iface0) + mi_warns iface0) -- The interface hash depends on: -- - the ABI hash, plus @@ -679,7 +558,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls mi_decls = sorted_decls, mi_hash_fn = lookupOccEnv local_env } -- - return (final_iface, no_change_at_all, pp_orphs) + return (final_iface, no_change_at_all) where this_mod = mi_module iface0 @@ -691,7 +570,6 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- non-orphans? fam_insts = mi_fam_insts iface0 fix_fn = mi_fix_fn iface0 - pp_orphs = pprOrphans orph_insts orph_rules getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] @@ -715,20 +593,47 @@ sortDependencies d dep_pkgs = sortBy (compare `on` packageIdFS) (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). --- 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 + (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 Id itself. This is done by grouping (c)-(f) in IfaceDeclExtras, +and fingerprinting that as part of the Id. + +\begin{code} type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras) +data IfaceDeclExtras + = IfaceIdExtras Fixity [IfaceRule] + | IfaceDataExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])] + | IfaceClassExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])] + | IfaceSynExtras Fixity + | IfaceOtherDeclExtras + abiDecl :: IfaceDeclABI -> IfaceDecl abiDecl (_, decl, _) = decl @@ -740,35 +645,52 @@ 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) +freeNamesDeclExtras (IfaceClassExtras _ _insts subs) = unionManyNameSets (map freeNamesSub subs) +freeNamesDeclExtras (IfaceSynExtras _) + = emptyNameSet freeNamesDeclExtras IfaceOtherDeclExtras = emptyNameSet freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules) +instance Outputable IfaceDeclExtras where + ppr IfaceOtherDeclExtras = empty + ppr (IfaceIdExtras fix rules) = ppr_id_extras fix rules + ppr (IfaceSynExtras fix) = ppr fix + 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 "") + +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 insts methods) = do - putByte bh 3; put_ bh insts; put_ bh methods + put_ bh (IfaceClassExtras fix insts methods) = do + putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods + put_ bh (IfaceSynExtras fix) = do + putByte bh 4; put_ bh fix put_ bh IfaceOtherDeclExtras = do - putByte bh 4 + putByte bh 5 declExtras :: (OccName -> Fixity) -> OccEnv [IfaceRule] @@ -785,19 +707,21 @@ declExtras fix_fn rule_env inst_env decl (map IfaceInstABI $ lookupOccEnvL inst_env n) (map (id_extras . ifConOcc) (visibleIfConDecls cons)) IfaceClass{ifSigs=sigs} -> - IfaceClassExtras + IfaceClassExtras (fix_fn n) (map IfaceInstABI $ lookupOccEnvL inst_env n) [id_extras op | IfaceClassOp op _ _ <- sigs] + IfaceSyn{} -> IfaceSynExtras (fix_fn n) _other -> IfaceOtherDeclExtras where n = ifName decl id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ) --- When hashing an instance, we omit the DFun. This is because if a --- DFun is used it will already have a separate entry in the usages --- list, and we don't want changes to the DFun to cause the hash of --- the instnace to change - that would cause unnecessary changes to --- orphans, for example. +-- +-- 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 @@ -813,9 +737,9 @@ 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 = do - put_ bh $! nameModule name - put_ bh $! nameOccName name +putNameLiterally bh name = ASSERT( isExternalName name ) + do { put_ bh $! nameModule name + ; put_ bh $! nameOccName name } computeFingerprint :: Binary a => DynFlags @@ -850,18 +774,19 @@ oldMD5 dflags bh = do return $! readHexFingerprint hash_str -} -pprOrphans :: [IfaceInst] -> [IfaceRule] -> Maybe SDoc -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)) - ] +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 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 @@ -879,17 +804,16 @@ mkOrphMap get_key decls where go (non_orphs, orphs) d | Just occ <- get_key d - = (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs) + = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs) | otherwise = (non_orphs, d:orphs) \end{code} -%********************************************************* -%* * -\subsection{Keeping track of what we've slurped, and fingerprints} -%* * -%********************************************************* - +%************************************************************************ +%* * + Keeping track of what we've slurped, and fingerprints +%* * +%************************************************************************ \begin{code} mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> IO [Usage] @@ -932,7 +856,10 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names | otherwise = case nameModule_maybe name of Nothing -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map - Just mod -> extendModuleEnv_C (++) mv_map mod [occ] + Just mod -> -- We use this fiddly lambda function rather than + -- (++) as the argument to extendModuleEnv_C to + -- avoid quadratic behaviour (trac #2680) + extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ] where occ = nameOccName name -- We want to create a Usage for a home module if @@ -1014,13 +941,28 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names \end{code} \begin{code} +mkIfaceAnnotations :: [Annotation] -> [IfaceAnnotation] +mkIfaceAnnotations = map mkIfaceAnnotation + +mkIfaceAnnotation :: Annotation -> IfaceAnnotation +mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = IfaceAnnotation { + ifAnnotatedTarget = fmap nameOccName target, + ifAnnotatedValue = serialized + } +\end{code} + +\begin{code} mkIfaceExports :: [AvailInfo] -> [(Module, [GenAvailInfo OccName])] - -- Group by module and sort by occurrence - -- This keeps the list in canonical order + -- Group by module and sort by occurrence mkIfaceExports exports = [ (mod, eltsFM avails) - | (mod, avails) <- fmToList groupFM + | (mod, avails) <- sortBy (stableModuleCmp `on` fst) + (moduleEnvToList groupFM) + -- NB. the fmToList is in a random order, + -- because Ord Module is not a predictable + -- ordering. Hence we perform a final sort + -- using the stable Module ordering. ] where -- Group by the module where the exported entities are defined @@ -1041,10 +983,12 @@ mkIfaceExports exports -- else the plusFM will simply discard one! They -- should have been combined by now. add env (Avail n) - = add_one env (nameModule n) (Avail (nameOccName n)) + = ASSERT( isExternalName n ) + add_one env (nameModule n) (Avail (nameOccName n)) add env (AvailTC tc ns) - = foldl add_for_mod env mods + = ASSERT( all isExternalName ns ) + foldl add_for_mod env mods where tc_occ = nameOccName tc mods = nub (map nameModule ns) @@ -1210,8 +1154,8 @@ checkDependencies hsc_env summary iface 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 + dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do + find_res <- liftIO $ findImportedModule hsc_env mod pkg case find_res of Found _ mod | pkg == this_pkg @@ -1246,13 +1190,13 @@ needInterface mod continue -- 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 + 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 @@ -1365,9 +1309,10 @@ tyThingToIfaceDecl :: TyThing -> IfaceDecl -- Reason: Iface stuff uses OccNames, and the conversion here does -- not do tidying on the way tyThingToIfaceDecl (AnId id) - = IfaceId { ifName = getOccName id, - ifType = toIfaceType (idType id), - ifIdInfo = info } + = IfaceId { ifName = getOccName id, + ifType = toIfaceType (idType id), + ifIdDetails = toIfaceIdDetails (idDetails id), + ifIdInfo = info } where info = case toIfaceIdInfo (idInfo id) of [] -> NoInfo @@ -1404,8 +1349,8 @@ tyThingToIfaceDecl (ATyCon tycon) | isSynTyCon tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifOpenSyn = syn_isOpen, - ifSynRhs = toIfaceType syn_tyki, + ifSynRhs = syn_rhs, + ifSynKind = syn_ki, ifFamInst = famInstToIface (tyConFamInst_maybe tycon) } @@ -1426,9 +1371,10 @@ tyThingToIfaceDecl (ATyCon tycon) | 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 }) = IfNewTyCon (ifaceConDecl con) @@ -1444,6 +1390,7 @@ tyThingToIfaceDecl (ATyCon tycon) ifaceConDecl data_con = IfCon { ifConOcc = getOccName (dataConName data_con), ifConInfix = dataConIsInfix data_con, + ifConWrapper = isJust (dataConWrapId_maybe data_con), ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con), ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), ifConEqSpec = to_eq_spec (dataConEqSpec data_con), @@ -1481,16 +1428,16 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, do_rough (Just n) = Just (toIfaceTyCon_name n) dfun_name = idName dfun_id - mod = nameModule dfun_name + 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) + (_, 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 + | all isJust mb_ns = ASSERT( not (null mb_ns) ) head mb_ns | otherwise = Nothing mb_ns :: [Maybe OccName] -- One for each fundep; a locally-defined name @@ -1531,14 +1478,24 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) -- 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] + prag_info | isDefaultInlinePragma inline_prag = NoInfo + | otherwise = HasInfo [HsInline inline_prag] -------------------------- +toIfaceIdDetails :: IdDetails -> IfaceIdDetails +toIfaceIdDetails VanillaId = IfVanillaId +toIfaceIdDetails (DFunId {}) = IfDFunId +toIfaceIdDetails (RecSelId { sel_naughty = n + , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n +toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) + IfVanillaId -- Unexpected + toIfaceIdInfo :: IdInfo -> [IfaceInfoItem] toIfaceIdInfo id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, - inline_hsinfo, wrkr_hsinfo, unfold_hsinfo] + inline_hsinfo, unfold_hsinfo] + -- NB: strictness must be before unfolding + -- See TcIface.tcUnfolding where ------------ Arity -------------- arity_info = arityInfo id_info @@ -1553,37 +1510,44 @@ toIfaceIdInfo id_info ------------ Strictness -------------- -- No point in explicitly exporting TopSig - strict_hsinfo = case newStrictnessInfo id_info of + strict_hsinfo = case strictnessInfo id_info of Just sig | not (isTopSig sig) -> Just (HsStrictness sig) _other -> Nothing - ------------ Worker -------------- - work_info = workerInfo id_info - has_worker = workerExists work_info - wrkr_hsinfo = case work_info of - HasWorker work_id wrap_arity -> - Just (HsWorker ((idName work_id)) wrap_arity) - NoWorker -> Nothing - ------------ Unfolding -------------- - -- The unfolding is redundant if there is a worker - unfold_info = unfoldingInfo id_info - rhs = unfoldingTemplate unfold_info - no_unfolding = neverUnfold unfold_info - -- The CoreTidy phase retains unfolding info iff - -- we want to expose the unfolding, taking into account - -- unconditional NOINLINE, etc. See TidyPgm.addExternal - unfold_hsinfo | no_unfolding = Nothing - | has_worker = Nothing -- Unfolding is implicit - | otherwise = Just (HsUnfold (toIfaceExpr rhs)) + unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) + loop_breaker = isNonRuleLoopBreaker (occInfo id_info) ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info - inline_hsinfo | isAlwaysActive inline_prag = Nothing - | no_unfolding && not has_worker = Nothing - -- If the iface file give no unfolding info, we - -- don't need to say when inlining is OK! - | otherwise = Just (HsInline inline_prag) + inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing + | otherwise = Just (HsInline inline_prag) + +-------------------------- +toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem +toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity + , uf_src = src, uf_guidance = guidance }) + = Just $ HsUnfold lb $ + case src of + InlineRule {} + -> case guidance of + UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok (toIfaceExpr rhs) + _other -> pprPanic "toIfUnfolding" (ppr unf) + InlineWrapper w -> IfWrapper arity (idName w) + InlineCompulsory -> IfCompulsory (toIfaceExpr rhs) + InlineRhs -> IfCoreUnfold (toIfaceExpr rhs) + -- Yes, even if guidance is UnfNever, expose the unfolding + -- If we didn't want to expose the unfolding, TidyPgm would + -- have stuck in NoUnfolding. For supercompilation we want + -- to see that unfolding! + +toIfUnfolding lb (DFunUnfolding _con ops) + = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops))) + -- No need to serialise the data constructor; + -- we can recover it from the type of the dfun + +toIfUnfolding _ _ + = Nothing -------------------------- coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule @@ -1640,7 +1604,6 @@ 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 ---------------------