X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=ce6f4a30ab6e8b00aed6e7d6e05e7ce5f2315584;hp=7901f7c5142325b9ca5a7e702e050e305394d46e;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=e8a591c1a3dbdeccec2dd2aacccd7435004b0d51 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 7901f7c..ce6f4a3 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1,14 +1,17 @@ % +% (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 @@ -19,231 +22,82 @@ module MkIface ( \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 - 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 ; -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 IfaceSyn -- All of it -import IfaceType ( toIfaceTvBndrs, toIfaceType, toIfaceContext ) -import LoadIface ( readIface, loadInterface, pprModIface ) -import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe ) -import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), - arityInfo, cafInfo, newStrictnessInfo, - workerInfo, unfoldingInfo, inlinePragInfo ) -import NewDemand ( isTopSig ) +import IfaceSyn +import LoadIface +import Id +import IdInfo +import Demand +import Annotations import CoreSyn -import Class ( classExtraBigSig, classTyCon ) -import TyCon ( TyCon, AlgTyConRhs(..), SynTyConRhs(..), - isRecursiveTyCon, isForeignTyCon, - isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, - isTupleTyCon, tupleTyConBoxity, tyConStupidTheta, - tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon, - tyConArity, tyConTyVars, algTyConRhs, tyConExtName ) -import DataCon ( dataConName, dataConFieldLabels, dataConStrictMarks, - dataConTyCon, dataConIsInfix, dataConUnivTyVars, dataConExTyVars, dataConEqSpec, - dataConTheta, dataConOrigArgTys ) -import Type ( TyThing(..), splitForAllTys, funResultTy ) -import TcType ( deNoteType ) -import TysPrim ( alphaTyVars ) -import InstEnv ( Instance(..) ) +import CoreFVs +import Class +import TyCon +import DataCon +import Type +import TcType +import InstEnv +import FamInstEnv import TcRnMonad -import HscTypes ( ModIface(..), ModDetails(..), - ModGuts(..), HscEnv(..), hscEPS, Dependencies(..), FixItem(..), - ModSummary(..), msHiFilePath, - mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, - typeEnvElts, - GenAvailInfo(..), availName, - ExternalPackageState(..), - Usage(..), IsBootInterface, - Deprecs(..), IfaceDeprecs, Deprecations, - lookupIfaceByModule - ) - - -import DynFlags ( GhcMode(..), DynFlags(..), DynFlag(..), dopt ) -import Name ( Name, nameModule, nameOccName, nameParent, - isExternalName, isInternalName, nameParent_maybe, isWiredInName, - isImplicitName, NamedThing(..) ) +import HsSyn +import HscTypes +import Finder +import DynFlags +import VarEnv +import Var +import Name +import RdrName import NameEnv import NameSet -import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, - extendOccEnv_C, - OccSet, emptyOccSet, elemOccSet, occSetElts, - extendOccSet, extendOccSetList, - isEmptyOccSet, intersectOccSet, intersectsOccSet, - occNameFS, isTcOcc ) import Module +import BinIface +import ErrUtils +import Digraph +import SrcLoc import Outputable -import BasicTypes ( Version, initialVersion, bumpVersion, isAlwaysActive, - Activation(..), RecFlag(..), boolToRecFlag ) -import Outputable -import Util ( createDirectoryHierarchy, directoryOf, sortLe, seqList, lengthIs ) -import BinIface ( writeBinIface ) -import Unique ( Unique, Uniquable(..) ) -import ErrUtils ( dumpIfSet_dyn, showPass ) -import Digraph ( stronglyConnComp, SCC(..) ) -import SrcLoc ( SrcSpan ) +import BasicTypes hiding ( SuccessFlag(..) ) import UniqFM -import PackageConfig ( PackageId ) +import Unique +import Util hiding ( eqListBy ) import FiniteMap import FastString - -import Monad ( when ) -import List ( insert ) -import Maybes ( orElse, mapCatMaybes, isNothing, isJust, - expectJust, catMaybes, MaybeErr(..) ) +import Maybes +import ListSetOps +import Binary +import Fingerprint +import Bag + +import Control.Monad +import Data.List +import Data.IORef +import System.FilePath \end{code} @@ -256,46 +110,130 @@ import Maybes ( orElse, mapCatMaybes, isNothing, isJust, \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 - -mkIface hsc_env maybe_old_iface - (ModGuts{ mg_module = this_mod, - mg_boot = is_boot, - mg_usages = usages, - mg_deps = deps, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_deprecs = src_deprecs }) - (ModDetails{ md_insts = insts, - md_rules = rules, - md_types = type_env, - md_exports = exports }) - + -> ModGuts -- Usages, deprecations, etc + -> IO (Messages, + Maybe (ModIface, -- The new one + Bool)) -- True <=> there was an old Iface, and the + -- new one is identical, so no need + -- to write it + +mkIface hsc_env maybe_old_fingerprint mod_details + ModGuts{ mg_module = this_mod, + mg_boot = is_boot, + mg_used_names = used_names, + mg_deps = deps, + mg_dir_imps = dir_imp_mods, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_warns = warns, + mg_hpc_info = hpc_info } + = mkIface_ hsc_env maybe_old_fingerprint + this_mod is_boot used_names deps rdr_env + fix_env warns hpc_info dir_imp_mods mod_details + +-- | 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 (Messages, Maybe (ModIface, Bool)) +mkIfaceTc hsc_env maybe_old_fingerprint mod_details + tc_result@TcGblEnv{ tcg_mod = this_mod, + tcg_src = hsc_src, + tcg_imports = imports, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_warns = warns, + tcg_hpc = other_hpc_info + } + = do + used_names <- mkUsedNames tc_result + deps <- mkDependencies tc_result + let hpc_info = emptyHpcInfo other_hpc_info + mkIface_ hsc_env maybe_old_fingerprint + this_mod (isHsBoot hsc_src) used_names deps rdr_env + fix_env warns hpc_info (imp_mods imports) mod_details + + +mkUsedNames :: TcGblEnv -> IO NameSet +mkUsedNames + TcGblEnv{ tcg_inst_uses = dfun_uses_var, + tcg_dus = dus + } + = do { dfun_uses <- readIORef dfun_uses_var -- 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.) + + pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) + | otherwise = imp_dep_pkgs imports + + return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods, + dep_pkgs = sortBy stablePackageIdCmp pkgs, + dep_orphs = sortBy stableModuleCmp (imp_orphs imports), + dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } + -- sort to get into canonical order + -- NB. remember to use lexicographic ordering + +mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface + -> NameSet -> Dependencies -> GlobalRdrEnv + -> NameEnv FixItem -> Warnings -> HpcInfo + -> ImportedMods + -> ModDetails + -> IO (Messages, Maybe (ModIface, Bool)) +mkIface_ hsc_env maybe_old_fingerprint + this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info + dir_imp_mods + ModDetails{ md_insts = insts, + md_fam_insts = fam_insts, + md_rules = rules, + md_anns = anns, + md_vect_info = vect_info, + md_types = type_env, + md_exports = exports } -- 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 - ; let { ext_nm_rhs = mkExtNameFn hsc_env eps this_mod - ; ext_nm_lhs = mkLhsNameFn this_mod - - ; decls = [ tyThingToIfaceDecl ext_nm_rhs thing - | thing <- typeEnvElts type_env, - let name = getName thing, - not (isImplicitName name || isWiredInName name) ] - -- 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 ext_nm_lhs ext_nm_rhs) rules - ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts + = do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names + + ; let { entities = typeEnvElts type_env ; + decls = [ tyThingToIfaceDecl entity + | entity <- entities, + let name = getName entity, + not (isImplicitTyThing entity), + -- 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, @@ -303,305 +241,552 @@ mkIface hsc_env maybe_old_iface 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_anns = mkIfaceAnnotations anns, 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 - ; (new_iface, no_change_at_all, pp_diffs, pp_orphs) - = _scc_ "versioninfo" - addVersionInfo maybe_old_iface 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) + ; (new_iface, no_change_at_all) + <- {-# SCC "versioninfo" #-} + addFingerprints hsc_env maybe_old_fingerprint + intermediate_iface decls + + -- 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) - ; 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 (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 <= ifDFun 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) + 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 :: ModLocation -> ModIface -> IO () -writeIfaceFile location new_iface - = do createDirectoryHierarchy (directoryOf hi_file_path) - writeBinIface hi_file_path new_iface +writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO () +writeIfaceFile dflags location new_iface + = do createDirectoryHierarchy (takeDirectory hi_file_path) + writeBinIface dflags hi_file_path new_iface where hi_file_path = ml_hi_file location ------------------------------ -mkExtNameFn :: HscEnv -> ExternalPackageState -> Module -> Name -> IfaceExtName -mkExtNameFn hsc_env eps this_mod - = ext_nm - where - hpt = hsc_HPT hsc_env - pit = eps_PIT eps - - ext_nm name - | mod == this_mod = case nameParent_maybe name of - Nothing -> LocalTop occ - Just par -> LocalTopSub occ (nameOccName par) - | isWiredInName name = ExtPkg mod occ - | is_home mod = HomePkg mod_name occ vers - | otherwise = ExtPkg mod occ - where - dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags - is_home mod = modulePackageId mod == this_pkg - - mod = nameModule name - mod_name = moduleName mod - occ = nameOccName name - par_occ = nameOccName (nameParent name) - -- The version of the *parent* is the one want - vers = lookupVersion mod par_occ - - lookupVersion :: Module -> OccName -> Version - -- Even though we're looking up a home-package thing, in - -- one-shot mode the imported interfaces may be in the PIT - lookupVersion mod occ - = mi_ver_fn iface occ `orElse` - pprPanic "lookupVers1" (ppr mod <+> ppr occ) - where - iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` - pprPanic "lookupVers2" (ppr mod <+> ppr occ) +-- ----------------------------------------------------------------------------- +-- Look up parents and versions of Names +-- This is like a global version of the mi_hash_fn field in each ModIface. +-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get +-- the parent and version info. ---------------------- --- mkLhsNameFn ignores versioning info altogether --- It is used for the LHS of instance decls and rules, where we --- there's no point in recording version info -mkLhsNameFn :: Module -> Name -> IfaceExtName -mkLhsNameFn this_mod name - | isInternalName name = pprTrace "mkLhsNameFn: unexpected internal" (ppr name) $ - LocalTop occ -- Should not happen - | mod == this_mod = LocalTop occ - | otherwise = ExtPkg mod occ +mkHashFun + :: HscEnv -- needed to look up versions + -> ExternalPackageState -- ditto + -> (Name -> Fingerprint) +mkHashFun hsc_env eps + = \name -> + let + mod = ASSERT2( isExternalName name, ppr name ) nameModule name + occ = nameOccName name + iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` + pprPanic "lookupVers2" (ppr mod <+> ppr occ) + in + snd (mi_hash_fn iface occ `orElse` + pprPanic "lookupVers1" (ppr mod <+> ppr occ)) where - mod = nameModule name - occ = nameOccName name + hpt = hsc_HPT hsc_env + pit = eps_PIT eps + +-- --------------------------------------------------------------------------- +-- Compute fingerprints for the interface + +addFingerprints + :: HscEnv + -> Maybe Fingerprint -- the old fingerprint, if any + -> ModIface -- The new interface (lacking decls) + -> [IfaceDecl] -- The new decls + -> IO (ModIface, -- Updated interface + Bool) -- True <=> no changes at all; + -- no need to write Iface + +addFingerprints hsc_env mb_old_fingerprint iface0 new_decls + = do + eps <- hscEPS hsc_env + let + -- The ABI of a declaration represents everything that is made + -- visible about the declaration that a client can depend on. + -- see IfaceDeclABI below. + declABI :: IfaceDecl -> IfaceDeclABI + declABI decl = (this_mod, decl, extras) + where extras = declExtras fix_fn non_orph_rules non_orph_insts decl + + edges :: [(IfaceDeclABI, Unique, [Unique])] + edges = [ (abi, getUnique (ifName decl), out) + | decl <- new_decls + , let abi = declABI decl + , let out = localOccs $ freeNamesDeclABI abi + ] + + name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n + localOccs = map (getUnique . getParent . getOccName) + . filter ((== this_mod) . name_module) + . nameSetToList + where getParent occ = lookupOccEnv parent_map occ `orElse` occ + + -- maps OccNames to their parents in the current module. + -- e.g. a reference to a constructor must be turned into a reference + -- to the TyCon for the purposes of calculating dependencies. + parent_map :: OccEnv OccName + parent_map = foldr extend emptyOccEnv new_decls + where extend d env = + extendOccEnvList env [ (b,n) | b <- 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 + 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 dependency tree. This is the way + -- that changes in orphans get propagated all the way up the + -- dependency tree. We only care about orphan modules in the current + -- package, because changes to orphans outside this package will be + -- tracked by the usage on the ABI hash of package modules that we import. + let orph_mods = filter ((== this_pkg) . modulePackageId) + $ dep_orphs sorted_deps + dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods + + orphan_hash <- computeFingerprint 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, + 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 $ + [(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) - ------------------------------ --- Compute version numbers for local decls - -addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi - -> ModIface -- The new interface decls (lacking decls) - -> [IfaceDecl] -- The new decls - -> (ModIface, - Bool, -- True <=> no changes at all; no need to write new Iface - SDoc, -- Differences - Maybe SDoc) -- Warnings about orphans - -addVersionInfo 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_decls = [(initialVersion, decl) | decl <- new_decls], - mi_ver_fn = \n -> Just initialVersion }, - 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 (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_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) - 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 (changedWrt changed_occs (eqListBy eqIfRule old_orph_rules new_orph_rules) - || changedWrt changed_occs (eqListBy eqIfInst old_orph_insts new_orph_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 = expectJust "add_vers" (old_decl_vers occ) - -- If it's unchanged, there jolly well - where -- should be an old version number - occ = ifName decl - - ------------------- - changed_occs :: OccSet - changed_occs = computeChangedOccs eq_info - - 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) - 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 - - ------------------- - -- 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 occs) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:"), - nest 2 (braces (fsep (map ppr (occSetElts - (occs `intersectOccSet` changed_occs)))))] - 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 + 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) } +\end{code} -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)) - ] -computeChangedOccs :: [(OccName, IfaceEq)] -> OccSet -computeChangedOccs eq_info - = foldl add_changes emptyOccSet (stronglyConnComp edges) +%************************************************************************ +%* * + The ABI of an IfaceDecl +%* * +%************************************************************************ + +Note [The ABI of an IfaceDecl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ABI of a declaration consists of: + + (a) the full name of the identifier (inc. module and package, + because these are used to construct the symbol name by which + the identifier is known externally). + + (b) the declaration itself, as exposed to clients. That is, the + definition of an Id is included in the fingerprint only if + it is made available as as unfolding in the interface. + + (c) the fixity of the identifier + (d) for Ids: rules + (e) for classes: instances, fixity & rules for methods + (f) for datatypes: instances, fixity & rules for constrs + +Items (c)-(f) are not stored in the IfaceDecl, but instead appear +elsewhere in the interface file. But they are *fingerprinted* with +the 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 + +cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering +cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare` + ifName (abiDecl abi2) + +freeNamesDeclABI :: IfaceDeclABI -> NameSet +freeNamesDeclABI (_mod, decl, extras) = + freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras + +freeNamesDeclExtras :: IfaceDeclExtras -> NameSet +freeNamesDeclExtras (IfaceIdExtras _ rules) + = unionManyNameSets (map freeNamesIfRule rules) +freeNamesDeclExtras (IfaceDataExtras _ _insts subs) + = unionManyNameSets (map freeNamesSub subs) +freeNamesDeclExtras (IfaceClassExtras _ _insts subs) + = unionManyNameSets (map freeNamesSub subs) +freeNamesDeclExtras (IfaceSynExtras _) + = emptyNameSet +freeNamesDeclExtras IfaceOtherDeclExtras + = emptyNameSet + +freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet +freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules) + +instance 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 fix insts methods) = do + putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods + put_ bh (IfaceSynExtras fix) = do + putByte bh 4; put_ bh fix + put_ bh IfaceOtherDeclExtras = do + putByte bh 5 + +declExtras :: (OccName -> Fixity) + -> OccEnv [IfaceRule] + -> OccEnv [IfaceInst] + -> IfaceDecl + -> IfaceDeclExtras + +declExtras fix_fn rule_env inst_env decl + = case decl of + IfaceId{} -> IfaceIdExtras (fix_fn n) + (lookupOccEnvL rule_env n) + IfaceData{ifCons=cons} -> + IfaceDataExtras (fix_fn n) + (map IfaceInstABI $ lookupOccEnvL inst_env n) + (map (id_extras . ifConOcc) (visibleIfConDecls cons)) + IfaceClass{ifSigs=sigs} -> + IfaceClassExtras (fix_fn n) + (map IfaceInstABI $ lookupOccEnvL inst_env n) + [id_extras op | IfaceClassOp op _ _ <- sigs] + IfaceSyn{} -> IfaceSynExtras (fix_fn n) + _other -> IfaceOtherDeclExtras where - edges :: [((OccName,IfaceEq), Unique, [Unique])] - edges = [ (node, getUnique occ, map getUnique occs) - | node@(occ, iface_eq) <- eq_info - , let occs = case iface_eq of - EqBut occ_set -> occSetElts occ_set - other -> [] ] - - -- Changes in declarations - add_changes :: OccSet -> SCC (OccName, IfaceEq) -> 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 (&&&) (map snd pairs)) -- One of this group has changed - = extendOccSetList so_far (map fst pairs) - add_changes so_far other = so_far - -changedWrt :: OccSet -> IfaceEq -> Bool -changedWrt so_far Equal = False -changedWrt so_far NotEqual = True -changedWrt so_far (EqBut kids) = so_far `intersectsOccSet` kids + 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 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 @@ -619,146 +804,218 @@ 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) - -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} -%* * -%********************************************************* - +%************************************************************************ +%* * + 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 proto_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_names = mkNameSet $ -- Eliminate duplicates - [ nameParent n -- Just record usage on the 'main' names - | n <- nameSetToList proto_used_names - , not (isWiredInName n) -- Don't record usages for wired-in names - , isExternalName n -- Ignore internal names - ] + 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 = extendModuleEnv_C add_item mv_map mod [occ] - where - occ = nameOccName name - mod = nameModule 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 + where + add_mv name mv_map + | isWiredInName name = mv_map -- ignore wired-in names + | otherwise + = case nameModule_maybe name of + Nothing -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map + 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 - -- 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 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 = 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 - 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) + finsts_mod = mi_finsts iface + hash_env = mi_hash_fn iface + mod_hash = mi_mod_hash iface + export_hash | depend_on_exports mod = Just (mi_exp_hash iface) | otherwise = Nothing - -- The sort is to put them into canonical order used_occs = lookupModuleEnv ent_map mod `orElse` [] - ent_vers :: [(OccName,Version)] - ent_vers = [ (occ, version_env occ `orElse` initialVersion) - | occ <- sortLe (<=) used_occs] + + -- Making a FiniteMap here ensures that (a) we remove duplicates + -- when we have usages on several subordinates of a single parent, + -- and (b) that the usages emerge in a canonical order, which + -- is why we use FiniteMap rather than OccEnv: FiniteMap works + -- using Ord on the OccNames, which is a lexicographic ordering. + ent_hashs :: FiniteMap OccName Fingerprint + ent_hashs = listToFM (map lookup_occ used_occs) + + lookup_occ occ = + case hash_env occ of + Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names) + Just r -> r + + depend_on_exports mod = + case lookupModuleEnv direct_imports mod of + Just _ -> True + -- 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} +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 :: NameSet -> [(Module, [GenAvailInfo OccName])] - -- Group by module and sort by occurrence - -- This keeps the list in canonical order -mkIfaceExports exports - = [ (mod, eltsUFM avails) - | (mod, avails) <- fmToList groupFM +mkIfaceExports :: [AvailInfo] + -> [(Module, [GenAvailInfo OccName])] + -- Group by module and sort by occurrence +mkIfaceExports exports + = [ (mod, eltsFM avails) + | (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 - groupFM :: ModuleEnv (UniqFM (GenAvailInfo OccName)) - -- Deliberately use the FastString so we + -- 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 = foldl add emptyModuleEnv (nameSetToList exports) - - add env name = extendModuleEnv_C add_avail env mod - (unitUFM avail_fs avail) + groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) + groupFM = foldl add emptyModuleEnv exports + + add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) + -> Module -> GenAvailInfo OccName + -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) + add_one env mod avail + = extendModuleEnv_C plusFM env mod + (unitFM (occNameFS (availName avail)) avail) + + -- 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 - occ = nameOccName name - mod = nameModule name - avail | Just p <- nameParent_maybe name = AvailTC (nameOccName p) [occ] - | isTcOcc occ = AvailTC occ [occ] - | otherwise = Avail occ - avail_fs = occNameFS (availName avail) - add_avail avail_fm _ = addToUFM_C add_item avail_fm avail_fs avail - - add_item (AvailTC p occs) _ = AvailTC p (List.insert occ occs) - add_item (Avail n) _ = pprPanic "MkIface.addAvail" (ppr n <+> ppr name) + 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. + %************************************************************************ %* * @@ -784,45 +1041,45 @@ checkOldIface hsc_env mod_summary source_unchanged maybe_iface 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 - = -- CHECK WHETHER THE SOURCE HAS CHANGED - ifM (not source_unchanged) - (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) - `thenM_` + = do -- CHECK WHETHER THE SOURCE HAS CHANGED + { 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. - getGhcMode `thenM` \ ghc_mode -> - if (ghc_mode == Interactive || ghc_mode == JustTypecheck) - && not source_unchanged then - returnM (outOfDate, maybe_iface) - else - - case maybe_iface of { - Just old_iface -> do -- Use the one we already have - recomp <- checkVersions hsc_env source_unchanged old_iface - return (recomp, Just old_iface) - - ; Nothing -> + ; 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 mod_summary old_iface + ; return (recomp, Just old_iface) } + + ; Nothing -> do -- Try and read the old interface for the current module -- from the .hi file left from the last time we compiled it - let - iface_path = msHiFilePath mod_summary - in - readIface (ms_mod mod_summary) iface_path False `thenM` \ read_result -> - case read_result of { - Failed err -> -- Old interface file not found, or garbled; give up - traceIf (text "FYI: cannot read old interface file:" - $$ nest 4 err) `thenM_` - returnM (outOfDate, Nothing) + { let iface_path = msHiFilePath mod_summary + ; read_result <- readIface (ms_mod mod_summary) iface_path False + ; case read_result of { + Failed err -> do -- Old interface file not found, or garbled; give up + { traceIf (text "FYI: cannot read old interface file:" + $$ nest 4 err) + ; return (outOfDate, Nothing) } - ; Succeeded iface -> + ; Succeeded iface -> do -- We have got the old iface; check its versions - checkVersions hsc_env source_unchanged iface `thenM` \ recomp -> - returnM (recomp, Just iface) - }} + { traceIf (text "Read the interface file" <+> text iface_path) + ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface + ; return (recomp, Just iface) + }}}}} + \end{code} @recompileRequired@ is called from the HscMain. It checks whether @@ -832,143 +1089,211 @@ check their versions. \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 -- case we'll compile the module from scratch anyhow). -- - -- We do this regardless of compilation mode - ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } + -- 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 } ; 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 _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do + find_res <- liftIO $ findImportedModule hsc_env mod pkg + case find_res of + Found _ mod + | pkg == this_pkg + -> if moduleName mod `notElem` map fst prev_dep_mods + then do traceHiDiffs $ + text "imported module " <> quotes (ppr mod) <> + text " not among previous dependencies" + return outOfDate + else + return upToDate + | otherwise + -> if pkg `notElem` prev_dep_pkgs + then do traceHiDiffs $ + text "imported module " <> quotes (ppr mod) <> + text " is from package " <> quotes (ppr pkg) <> + text ", which is not among previous dependencies" + return outOfDate + else + return upToDate + where pkg = modulePackageId mod + _otherwise -> return outOfDate + +needInterface :: Module -> (ModIface -> IfG RecompileRequired) + -> IfG RecompileRequired +needInterface mod continue + = do -- 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 - - 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 + new_mod_hash = mi_mod_hash iface + new_decl_hash = mi_hash_fn iface + new_export_hash = mi_exp_hash iface - 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} %************************************************************************ @@ -978,34 +1303,37 @@ checkList (check:checks) = check `thenM` \ recompile -> %************************************************************************ \begin{code} -tyThingToIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl +tyThingToIfaceDecl :: TyThing -> IfaceDecl -- Assumption: the thing is already tidied, so that locally-bound names -- (lambdas, for-alls) already have non-clashing OccNames -- Reason: Iface stuff uses OccNames, and the conversion here does -- not do tidying on the way -tyThingToIfaceDecl ext (AnId id) - = IfaceId { ifName = getOccName id, - ifType = toIfaceType ext (idType id), - ifIdInfo = info } +tyThingToIfaceDecl (AnId id) + = IfaceId { ifName = getOccName id, + ifType = toIfaceType (idType id), + ifIdDetails = toIfaceIdDetails (idDetails id), + ifIdInfo = info } where - info = case toIfaceIdInfo ext (idInfo id) of + info = case toIfaceIdInfo (idInfo id) of [] -> NoInfo items -> HasInfo items -tyThingToIfaceDecl ext (AClass clas) - = IfaceClass { ifCtxt = toIfaceContext ext sc_theta, +tyThingToIfaceDecl (AClass clas) + = IfaceClass { ifCtxt = toIfaceContext sc_theta, ifName = getOccName clas, ifTyVars = toIfaceTvBndrs clas_tyvars, ifFDs = map toIfaceFD clas_fds, + ifATs = map (tyThingToIfaceDecl . ATyCon) clas_ats, ifSigs = map toIfaceClassOp op_stuff, ifRec = boolToRecFlag (isRecursiveTyCon tycon) } where - (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas + (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) + = classExtraBigSig clas tycon = classTyCon clas toIfaceClassOp (sel_id, def_meth) = ASSERT(sel_tyvars == clas_tyvars) - IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty) + IfaceClassOp (getOccName sel_id) def_meth (toIfaceType op_ty) where -- Be careful when splitting the type, because of things -- like class Foo a where @@ -1015,52 +1343,45 @@ tyThingToIfaceDecl ext (AClass clas) (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) op_ty = funResultTy rho_ty - toIfaceFD (tvs1, tvs2) = (map (occNameFS.getOccName) tvs1, map (occNameFS.getOccName) tvs2) + toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2) -tyThingToIfaceDecl ext (ATyCon tycon) +tyThingToIfaceDecl (ATyCon tycon) | isSynTyCon tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifOpenSyn = syn_isOpen, - ifSynRhs = toIfaceType ext syn_tyki } + ifSynRhs = syn_rhs, + ifSynKind = syn_ki, + ifFamInst = famInstToIface (tyConFamInst_maybe tycon) + } | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifCtxt = toIfaceContext ext (tyConStupidTheta tycon), + ifCtxt = toIfaceContext (tyConStupidTheta tycon), ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifGeneric = tyConHasGenerics tycon } + ifGeneric = tyConHasGenerics tycon, + ifFamInst = famInstToIface (tyConFamInst_maybe tycon)} | isForeignTyCon 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} - | 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 @@ -1069,39 +1390,112 @@ tyThingToIfaceDecl ext (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), - ifConCtxt = toIfaceContext ext (dataConTheta data_con), - ifConArgTys = map (toIfaceType ext) (dataConOrigArgTys data_con), - ifConFields = map getOccName (dataConFieldLabels data_con), + ifConCtxt = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con), + ifConArgTys = map toIfaceType (dataConOrigArgTys data_con), + ifConFields = map getOccName + (dataConFieldLabels data_con), ifConStricts = dataConStrictMarks data_con } - to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec] + to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec] -tyThingToIfaceDecl ext (ADataCon dc) + famInstToIface Nothing = Nothing + famInstToIface (Just (famTyCon, instTys)) = + Just (toIfaceTyCon famTyCon, map toIfaceType instTys) + +tyThingToIfaceDecl (ADataCon dc) = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier +getFS :: NamedThing a => a -> FastString +getFS x = occNameFS (getOccName x) + -------------------------- -instanceToIfaceInst :: (Name -> IfaceExtName) -> Instance -> IfaceInst -instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag, - is_cls = cls, is_tcs = mb_tcs, - is_orph = orph }) - = IfaceInst { ifDFun = getOccName dfun_id, +instanceToIfaceInst :: Instance -> IfaceInst +instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, + is_cls = cls_name, is_tcs = mb_tcs }) + = ASSERT( cls_name == className cls ) + IfaceInst { ifDFun = dfun_name, ifOFlag = oflag, - ifInstCls = ext_lhs cls, + ifInstCls = cls_name, ifInstTys = map do_rough mb_tcs, ifInstOrph = orph } where do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) + 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 = ASSERT( not (null 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) -------------------------- -toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] -toIfaceIdInfo ext id_info +famInstToIfaceFamInst :: FamInst -> IfaceFamInst +famInstToIfaceFamInst (FamInst { fi_tycon = tycon, + fi_fam = fam, + fi_tcs = mb_tcs }) + = IfaceFamInst { ifFamInstTyCon = toIfaceTyCon tycon + , ifFamInstFam = fam + , ifFamInstTys = map do_rough mb_tcs } + where + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name n) + +-------------------------- +toIfaceLetBndr :: Id -> IfaceLetBndr +toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) + (toIfaceType (idType id)) + prag_info + where + -- 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 | 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 @@ -1116,96 +1510,116 @@ toIfaceIdInfo ext 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 = case work_info of { HasWorker _ _ -> True; other -> False } - wrkr_hsinfo = case work_info of - HasWorker work_id wrap_arity -> - Just (HsWorker (ext (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 ext 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 :: (Name -> IfaceExtName) -- For the LHS names - -> (Name -> IfaceExtName) -- For the RHS names - -> CoreRule -> IfaceRule -coreRuleToIfaceRule ext_lhs ext_rhs (BuiltinRule { ru_fn = fn}) +coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule +coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn}) = pprTrace "toHsRule: builtin" (ppr fn) $ - bogusIfaceRule (mkIfaceExtName fn) + bogusIfaceRule fn -coreRuleToIfaceRule ext_lhs ext_rhs - (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 ext_lhs) bndrs, - ifRuleHead = ext_lhs fn, + ifRuleBndrs = map toIfaceBndr bndrs, + ifRuleHead = fn, ifRuleArgs = map do_arg args, - ifRuleRhs = toIfaceExpr ext_rhs rhs, + ifRuleRhs = toIfaceExpr rhs, ifRuleOrph = orph } where -- For type args we must remove synonyms from the outermost -- level. Reason: so that when we read it back in we'll -- construct the same ru_rough field as we have right now; -- see tcIfaceRule - do_arg (Type ty) = IfaceType (toIfaceType ext_lhs (deNoteType ty)) - do_arg arg = toIfaceExpr ext_lhs arg + 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 :: IfaceExtName -> IfaceRule +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 :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr -toIfaceExpr ext (Var v) = toIfaceVar ext v -toIfaceExpr ext (Lit l) = IfaceLit l -toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty) -toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b) -toIfaceExpr ext (App f a) = toIfaceApp ext f [a] -toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (occNameFS (getOccName x)) (toIfaceType ext ty) (map (toIfaceAlt ext) as) -toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e) -toIfaceExpr ext (Cast e co) = IfaceCast (toIfaceExpr ext e) (toIfaceType ext co) -toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e) +toIfaceExpr :: CoreExpr -> IfaceExpr +toIfaceExpr (Var v) = toIfaceVar v +toIfaceExpr (Lit l) = IfaceLit l +toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) +toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b) +toIfaceExpr (App f a) = toIfaceApp f [a] +toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as) +toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) +toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceType co) +toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e) --------------------- -toIfaceNote ext (SCC cc) = IfaceSCC cc -toIfaceNote ext InlineMe = IfaceInlineMe -toIfaceNote ext (CoreNote s) = IfaceCoreNote s +toIfaceNote :: Note -> IfaceNote +toIfaceNote (SCC cc) = IfaceSCC cc +toIfaceNote (CoreNote s) = IfaceCoreNote s --------------------- -toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r) -toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext 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 ext (c,bs,r) = (toIfaceCon c, map (occNameFS.getOccName) bs, toIfaceExpr ext r) +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 (getOccName dc) + | otherwise = IfaceDataAlt (getName dc) where tc = dataConTyCon dc @@ -1213,8 +1627,9 @@ toIfaceCon (LitAlt l) = IfaceLitAlt l toIfaceCon DEFAULT = IfaceDefault --------------------- -toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as) -toIfaceApp ext (Var v) as +toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr +toIfaceApp (App f a) as = toIfaceApp f (a:as) +toIfaceApp (Var v) as = case isDataConWorkId_maybe v of -- We convert the *worker* for tuples into IfaceTuples Just dc | isTupleTyCon tc && saturated @@ -1222,22 +1637,25 @@ toIfaceApp ext (Var v) as where val_args = dropWhile isTypeArg as saturated = val_args `lengthIs` idArity v - tup_args = map (toIfaceExpr ext) val_args + tup_args = map toIfaceExpr val_args tc = dataConTyCon dc - other -> mkIfaceApps ext (toIfaceVar ext v) as + _ -> mkIfaceApps (toIfaceVar v) as -toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as +toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as -mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as +mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr +mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as --------------------- -toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr -toIfaceVar ext v - | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v)) +toIfaceVar :: Id -> IfaceExpr +toIfaceVar v + | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) -- Foreign calls have special syntax - | isExternalName name = IfaceExt (ext name) - | otherwise = IfaceLcl (occNameFS (nameOccName name)) + | isExternalName name = IfaceExt name + | Just (TickBox m ix) <- isTickBoxOp_maybe v + = IfaceTick m ix + | otherwise = IfaceLcl (getFS name) where name = idName v \end{code}