%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\begin{code}
-module MkIface (
- mkUsageInfo, -- Construct the usage info for a module
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+module MkIface (
+ mkUsedNames,
+ mkDependencies,
mkIface, -- Build a ModIface from a ModGuts,
-- including computing version information
+ mkIfaceTc,
+
writeIfaceFile, -- Write the interface file
- checkOldIface -- See if recompilation is required, by
+ checkOldIface, -- See if recompilation is required, by
-- comparing version information
+
+ tyThingToIfaceDecl -- Converting things to their Iface equivalents
) where
\end{code}
compiled:
import B <n> ;
to record the fact that A does import B indirectly. This is used to decide
-to look to look for B.hi rather than B.hi-boot when compiling a module that
+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.
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 -- 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 IfaceType
+import LoadIface
+import Id
+import IdInfo
+import NewDemand
import CoreSyn
-import Class ( classExtraBigSig, classTyCon )
-import TyCon ( TyCon, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon,
- isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
- isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
- tyConHasGenerics, tyConArgVrcs, 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(..),
- ModSummary(..), msHiFilePath,
- mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache,
- typeEnvElts,
- GenAvailInfo(..), availName,
- ExternalPackageState(..),
- Usage(..), IsBootInterface,
- Deprecs(..), IfaceDeprecs, Deprecations,
- lookupIfaceByModule
- )
-
-
-import DynFlags ( GhcMode(..), DynFlag(..), dopt )
-import Name ( Name, nameModule, nameOccName, nameParent,
- isExternalName, isInternalName, nameParent_maybe, isWiredInName,
- isImplicitName, NamedThing(..) )
+import HscTypes
+import Finder
+import DynFlags
+import VarEnv
+import Var
+import Name
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 OccName
import Module
+import BinIface
+import Unique
+import ErrUtils
+import Digraph
+import SrcLoc
+import PackageConfig hiding ( Version )
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 UniqFM
-import PackageConfig ( PackageId )
+import BasicTypes hiding ( SuccessFlag(..) )
+import LazyUniqFM
+import Util hiding ( eqListBy )
import FiniteMap
import FastString
+import Maybes
+import ListSetOps
-import Monad ( when )
-import List ( insert )
-import Maybes ( orElse, mapCatMaybes, isNothing, isJust,
- expectJust, catMaybes, MaybeErr(..) )
+import Control.Monad
+import Data.List
+import Data.IORef
+import System.FilePath
\end{code}
\begin{code}
mkIface :: HscEnv
-> Maybe ModIface -- The old interface, if we have it
- -> ModGuts -- Usages, deprecations, etc
-> ModDetails -- The trimmed, tidied interface
+ -> ModGuts -- Usages, deprecations, etc
-> 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 })
+mkIface hsc_env maybe_old_iface 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_deprecs = deprecs,
+ mg_hpc_info = hpc_info }
+ = mkIface_ hsc_env maybe_old_iface
+ this_mod is_boot used_names deps rdr_env
+ fix_env deprecs 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 ModIface -- The old interface, if we have it
+ -> ModDetails -- gotten from mkBootModDetails, probably
+ -> TcGblEnv -- Usages, deprecations, etc
+ -> IO (ModIface,
+ Bool)
+mkIfaceTc hsc_env maybe_old_iface 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_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_iface
+ this_mod (isHsBoot hsc_src) used_names deps rdr_env
+ fix_env deprecs 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.)
+
+ dir_imp_mods = imp_mods imports
+
+ -- Modules don't compare lexicographically usually,
+ -- but we want them to do so here.
+ le_mod :: Module -> Module -> Bool
+ le_mod m1 m2 = moduleNameFS (moduleName m1)
+ <= moduleNameFS (moduleName m2)
+
+ le_dep_mod :: (ModuleName, IsBootInterface)
+ -> (ModuleName, IsBootInterface) -> Bool
+ le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2
+
+
+ pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports)
+ | otherwise = imp_dep_pkgs imports
+
+ return Deps { dep_mods = sortLe le_dep_mod dep_mods,
+ dep_pkgs = sortLe (<=) pkgs,
+ dep_orphs = sortLe le_mod (imp_orphs imports),
+ dep_finsts = sortLe le_mod (imp_finsts imports) }
+ -- sort to get into canonical order
+
+
+mkIface_ hsc_env maybe_old_iface
+ this_mod is_boot used_names deps rdr_env fix_env src_deprecs hpc_info
+ dir_imp_mods
+ ModDetails{ md_insts = insts,
+ md_fam_insts = fam_insts,
+ md_rules = rules,
+ md_vect_info = vect_info,
+ md_types = type_env,
+ md_exports = exports }
-- 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
+ = do {eps <- hscEPS hsc_env
+
+ ; usages <- mkUsageInfo hsc_env dir_imp_mods (dep_mods deps) used_names
- ; 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
+ ; 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]
- ; deprecs = mkIfaceDeprec src_deprecs
- ; iface_rules = map (coreRuleToIfaceRule ext_nm_lhs ext_nm_rhs) rules
- ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts
+ ; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
+ ; deprecs = src_deprecs
+ ; iface_rules = map (coreRuleToIfaceRule this_mod) rules
+ ; iface_insts = map instanceToIfaceInst insts
+ ; iface_fam_insts = map famInstToIfaceFamInst fam_insts
+ ; iface_vect_info = flattenVectInfo vect_info
; intermediate_iface = ModIface {
mi_module = this_mod,
mi_deps = deps,
mi_usages = usages,
mi_exports = mkIfaceExports exports,
+
+ -- Sort these lexicographically, so that
+ -- the result is stable across compilations
mi_insts = sortLe le_inst iface_insts,
+ mi_fam_insts= sortLe le_fam_inst iface_fam_insts,
mi_rules = sortLe le_rule iface_rules,
+
+ mi_vect_info = iface_vect_info,
+
mi_fixities = fixities,
mi_deprecs = deprecs,
mi_globals = Just rdr_env,
mi_rule_vers = initialVersion,
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_hpc = isHpcUsed hpc_info,
-- And build the cached values
mi_dep_fn = mkIfaceDepCache deprecs,
mi_fix_fn = mkIfaceFixCache fixities }
-- Add version information
+ ; ext_ver_fn = mkParentVerFun hsc_env eps
; (new_iface, no_change_at_all, pp_diffs, pp_orphs)
- = _scc_ "versioninfo"
- addVersionInfo maybe_old_iface intermediate_iface decls
+ = {-# SCC "versioninfo" #-}
+ addVersionInfo ext_ver_fn maybe_old_iface
+ intermediate_iface decls
}
-- Debug printing
; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
(pprModIface new_iface)
- ; return (new_iface, no_change_at_all) }
+ -- bug #1617: on reload we weren't updating the PrintUnqualified
+ -- correctly. This stems from the fact that the interface had
+ -- not changed, so addVersionInfo returns the old ModIface
+ -- with the old GlobalRdrEnv (mi_globals).
+ ; let final_iface = new_iface{ mi_globals = Just rdr_env }
+
+ ; return (final_iface, no_change_at_all) }
where
- r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
- i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2
+ 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_ver_fn field in each ModIface.
+-- Given a Name, it finds the ModIface, and then uses mi_ver_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
+mkParentVerFun
+ :: HscEnv -- needed to look up versions
+ -> ExternalPackageState -- ditto
+ -> (Name -> (OccName,Version))
+mkParentVerFun hsc_env eps
+ = \name ->
+ let
+ mod = nameModule name
+ occ = nameOccName name
+ iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
+ pprPanic "lookupVers2" (ppr mod <+> ppr occ)
+ in
+ mi_ver_fn iface occ `orElse`
+ pprPanic "lookupVers1" (ppr mod <+> ppr occ)
where
- mod = nameModule name
- occ = nameOccName name
+ hpt = hsc_HPT hsc_env
+ pit = eps_PIT eps
-
------------------------------
+-----------------------------------------------------------------------------
-- 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
+addVersionInfo
+ :: (Name -> (OccName,Version)) -- lookup parents and versions of names
+ -> Maybe ModIface -- The old interface, read from M.hi
+ -> ModIface -- The new interface (lacking decls)
+ -> [IfaceDecl] -- The new decls
+ -> (ModIface, -- Updated interface
+ Bool, -- True <=> no changes at all; no need to write Iface
+ SDoc, -- Differences
+ Maybe SDoc) -- Warnings about orphans
+
+addVersionInfo ver_fn Nothing new_iface new_decls
-- No old interface, so definitely write a new one!
- = (new_iface { mi_orphan = anyNothing ifInstOrph (mi_insts new_iface)
- || anyNothing ifRuleOrph (mi_rules new_iface),
- mi_decls = [(initialVersion, decl) | decl <- new_decls],
- mi_ver_fn = \n -> Just initialVersion },
+ = (new_iface { mi_orphan = not (null orph_insts && null orph_rules)
+ , mi_finsts = not . null $ mi_fam_insts new_iface
+ , mi_decls = [(initialVersion, decl) | decl <- new_decls]
+ , mi_ver_fn = mkIfaceVerCache (zip (repeat initialVersion)
+ new_decls)
+ },
False,
ptext SLIT("No old interface file"),
pprOrphans orph_insts orph_rules)
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,
+addVersionInfo ver_fn (Just old_iface@(ModIface {
+ mi_mod_vers = old_mod_vers,
mi_exp_vers = old_exp_vers,
mi_rule_vers = old_rule_vers,
mi_decls = old_decls,
mi_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 }
+ | no_change_at_all
+ = (old_iface, True, ptext SLIT("Interface file unchanged"), pp_orphs)
+ | otherwise
+ = (final_iface, False, vcat [ptext SLIT("Interface file has changed"),
+ nest 2 pp_diffs], pp_orphs)
+ where
+ final_iface = new_iface {
+ mi_mod_vers = bump_unless no_output_change old_mod_vers,
+ mi_exp_vers = bump_unless no_export_change old_exp_vers,
+ mi_rule_vers = bump_unless no_rule_change old_rule_vers,
+ mi_orphan = not (null new_orph_rules && null new_orph_insts),
+ mi_finsts = not . null $ mi_fam_insts new_iface,
+ mi_decls = decls_w_vers,
+ mi_ver_fn = mkIfaceVerCache decls_w_vers }
decls_w_vers = [(add_vers decl, decl) | decl <- new_decls]
-------------------
- (old_non_orph_insts, old_orph_insts) = mkOrphMap ifInstOrph (mi_insts old_iface)
- (new_non_orph_insts, new_orph_insts) = mkOrphMap ifInstOrph (mi_insts new_iface)
+ (old_non_orph_insts, old_orph_insts) =
+ mkOrphMap ifInstOrph (mi_insts old_iface)
+ (new_non_orph_insts, new_orph_insts) =
+ mkOrphMap ifInstOrph (mi_insts new_iface)
+ old_fam_insts = mi_fam_insts old_iface
+ new_fam_insts = mi_fam_insts new_iface
same_insts occ = eqMaybeBy (eqListBy eqIfInst)
(lookupOccEnv old_non_orph_insts occ)
(lookupOccEnv new_non_orph_insts occ)
- (old_non_orph_rules, old_orph_rules) = mkOrphMap ifRuleOrph (mi_rules old_iface)
- (new_non_orph_rules, new_orph_rules) = mkOrphMap ifRuleOrph (mi_rules new_iface)
+ (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_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_rule_change = not (changedWrtNames changed_occs (eqListBy eqIfRule old_orph_rules new_orph_rules)
+ || changedWrtNames changed_occs (eqListBy eqIfInst old_orph_insts new_orph_insts)
+ || changedWrtNames changed_occs (eqListBy eqIfFamInst old_fam_insts new_fam_insts))
no_deprec_change = mi_deprecs new_iface == mi_deprecs old_iface
-- If the usages havn't changed either, we don't need to write the interface file
no_other_changes = mi_usages new_iface == mi_usages old_iface &&
- mi_deps new_iface == mi_deps old_iface
+ mi_deps new_iface == mi_deps old_iface &&
+ mi_hpc new_iface == mi_hpc old_iface
no_change_at_all = no_output_change && no_other_changes
pp_diffs = vcat [pp_change no_export_change "Export list"
-------------------
-- 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
+ 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)
+ | otherwise = snd (expectJust "add_vers" (old_decl_vers occ))
-- If it's unchanged, there jolly well
where -- should be an old version number
occ = ifName decl
-------------------
- changed_occs :: OccSet
- changed_occs = computeChangedOccs eq_info
-
+ -- Deciding which declarations have changed
+
+ -- For each local decl, the IfaceEq gives the list of things that
+ -- must be unchanged for the declaration as a whole to be unchanged.
eq_info :: [(OccName, IfaceEq)]
eq_info = map check_eq new_decls
- check_eq new_decl | Just old_decl <- lookupOccEnv old_decl_env occ
- = (occ, new_decl `eqIfDecl` old_decl &&&
- eq_indirects new_decl)
- | otherwise {- No corresponding old decl -}
- = (occ, NotEqual)
- where
- occ = ifName new_decl
+ 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
eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules
eq_ind_occ occ = same_fixity occ &&& same_rules occ
eq_ind_occs = foldr ((&&&) . eq_ind_occ) Equal
-
+
+ -- The Occs of declarations that changed.
+ changed_occs :: OccSet
+ changed_occs = computeChangedOccs ver_fn (mi_module new_iface)
+ (mi_usages old_iface) eq_info
+
-------------------
-- Diffs
pp_decl_diffs :: SDoc -- Nothing => no changes
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:"),
+ Just (EqBut names) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:") <> ppr names,
nest 2 (braces (fsep (map ppr (occSetElts
(occs `intersectOccSet` changed_occs)))))]
+ where occs = mkOccSet (map nameOccName (nameSetToList names))
Just NotEqual
| Just old_decl <- lookupOccEnv old_decl_env occ
-> vcat [ptext SLIT("Old:") <+> ppr old_decl,
pp_orphs = pprOrphans new_orph_insts new_orph_rules
+
pprOrphans insts rules
| null insts && null rules = Nothing
| otherwise
2 (vcat (map ppr rules))
]
-computeChangedOccs :: [(OccName, IfaceEq)] -> OccSet
-computeChangedOccs eq_info
+computeChangedOccs
+ :: (Name -> (OccName,Version)) -- get parents and versions
+ -> Module -- This module
+ -> [Usage] -- Usages from old iface
+ -> [(OccName, IfaceEq)] -- decl names, equality conditions
+ -> OccSet -- set of things that have changed
+computeChangedOccs ver_fn this_module old_usages eq_info
= foldl add_changes emptyOccSet (stronglyConnComp edges)
where
- edges :: [((OccName,IfaceEq), Unique, [Unique])]
+
+ -- return True if an external name has changed
+ name_changed :: Name -> Bool
+ name_changed nm
+ | isWiredInName nm -- Wired-in things don't get into interface
+ = False -- files and hence don't get into the ver_fn
+ | Just ents <- lookupUFM usg_modmap (moduleName mod),
+ Just v <- lookupUFM ents parent_occ
+ = v < new_version
+ | modulePackageId mod == this_pkg
+ = WARN(True, ptext SLIT("computeChangedOccs") <+> ppr nm) True
+ -- should really be a panic, see #1959. The problem is that the usages doesn't
+ -- contain all the names that might be referred to by unfoldings. So as a
+ -- conservative workaround we just assume these names have changed.
+ | otherwise = False -- must be in another package
+ where
+ mod = nameModule nm
+ (parent_occ, new_version) = ver_fn nm
+
+ this_pkg = modulePackageId this_module
+
+ -- Turn the usages from the old ModIface into a mapping
+ usg_modmap = listToUFM [ (usg_name usg, listToUFM (usg_entities usg))
+ | usg <- old_usages ]
+
+ get_local_eq_info :: GenIfaceEq Name -> GenIfaceEq OccName
+ get_local_eq_info Equal = Equal
+ get_local_eq_info NotEqual = NotEqual
+ get_local_eq_info (EqBut ns) = foldNameSet f Equal ns
+ where f name eq | nameModule name == this_module =
+ EqBut (unitOccSet (nameOccName name)) `and_occifeq` eq
+ | name_changed name = NotEqual
+ | otherwise = eq
+
+ local_eq_infos = mapSnd get_local_eq_info eq_info
+
+ edges :: [((OccName, OccIfaceEq), Unique, [Unique])]
edges = [ (node, getUnique occ, map getUnique occs)
- | node@(occ, iface_eq) <- eq_info
+ | node@(occ, iface_eq) <- local_eq_infos
, let occs = case iface_eq of
EqBut occ_set -> occSetElts occ_set
other -> [] ]
-- Changes in declarations
- add_changes :: OccSet -> SCC (OccName, IfaceEq) -> OccSet
+ add_changes :: OccSet -> SCC (OccName, OccIfaceEq) -> OccSet
add_changes so_far (AcyclicSCC (occ, iface_eq))
- | changedWrt so_far iface_eq -- This one has changed
+ | 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)
+ | changedWrt so_far (foldr1 and_occifeq iface_eqs)
+ -- One of this group has changed
+ = extendOccSetList so_far occs
+ where (occs, iface_eqs) = unzip pairs
add_changes so_far other = so_far
-changedWrt :: OccSet -> IfaceEq -> Bool
+type OccIfaceEq = GenIfaceEq OccName
+
+changedWrt :: OccSet -> OccIfaceEq -> Bool
changedWrt so_far Equal = False
changedWrt so_far NotEqual = True
changedWrt so_far (EqBut kids) = so_far `intersectsOccSet` kids
+changedWrtNames :: OccSet -> IfaceEq -> Bool
+changedWrtNames so_far Equal = False
+changedWrtNames so_far NotEqual = True
+changedWrtNames so_far (EqBut kids) =
+ so_far `intersectsOccSet` mkOccSet (map nameOccName (nameSetToList kids))
+
+and_occifeq :: OccIfaceEq -> OccIfaceEq -> OccIfaceEq
+Equal `and_occifeq` x = x
+NotEqual `and_occifeq` x = NotEqual
+EqBut nms `and_occifeq` Equal = EqBut nms
+EqBut nms `and_occifeq` NotEqual = NotEqual
+EqBut nms1 `and_occifeq` EqBut nms2 = EqBut (nms1 `unionOccSets` nms2)
+
----------------------
-- mkOrphMap partitions instance decls or rules into
-- (a) an OccEnv for ones that are not orphans,
= (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs)
| otherwise = (non_orphs, d:orphs)
-anyNothing :: (a -> Maybe b) -> [a] -> Bool
-anyNothing p [] = False
-anyNothing p (x:xs) = isNothing (p x) || anyNothing p xs
-
-----------------------
-mkIfaceDeprec :: Deprecations -> IfaceDeprecs
-mkIfaceDeprec NoDeprecs = NoDeprecs
-mkIfaceDeprec (DeprecAll t) = DeprecAll t
-mkIfaceDeprec (DeprecSome env) = DeprecSome (sortLe (<=) (nameEnvElts env))
-
----------------------
bump_unless :: Bool -> Version -> Version
bump_unless True v = v -- True <=> no change
\begin{code}
mkUsageInfo :: HscEnv
- -> ModuleEnv (Module, Bool, SrcSpan)
+ -> ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)])
-> [(ModuleName, IsBootInterface)]
-> NameSet -> IO [Usage]
mkUsageInfo hsc_env dir_imp_mods dep_mods used_names
-- 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
+mk_usage_info :: PackageIfaceTable
+ -> HscEnv
+ -> ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)])
+ -> [(ModuleName, IsBootInterface)]
+ -> NameSet
+ -> [Usage]
+mk_usage_info pit hsc_env dir_imp_mods dep_mods used_names
= mapCatMaybes mkUsage dep_mods
-- ToDo: do we need to sort into canonical order?
where
hpt = hsc_HPT hsc_env
dflags = hsc_dflags hsc_env
- 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
- ]
-
-- ent_map groups together all the things imported and used
-- from a particular module in this package
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]
+ add_mv name mv_map
+ | isWiredInName name = mv_map -- ignore wired-in names
+ | otherwise
+ = case nameModule_maybe name of
+ Nothing -> mv_map -- ignore internal names
+ Just mod -> extendModuleEnv_C add_item mv_map mod [occ]
where
occ = nameOccName name
- 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
+ Just (_, xs) -> any (\(_, no_imp, _) -> not no_imp) xs
+ Nothing -> True
-- 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)
+ -- c) is a home-package orphan or family-instance module (need to
+ -- recompile if its instance decls change: rules_vers)
mkUsage :: (ModuleName, IsBootInterface) -> Maybe Usage
mkUsage (mod_name, _)
| isNothing maybe_iface -- We can't depend on it if we didn't
|| (null used_occs -- load its interface.
&& isNothing export_vers
- && not orphan_mod)
+ && not orphan_mod
+ && not finsts_mod)
= Nothing -- Record no usage info
| otherwise
= Just (Usage { usg_name = mod_name,
usg_mod = mod_vers,
usg_exports = export_vers,
- usg_entities = ent_vers,
+ usg_entities = fmToList ent_vers,
usg_rules = rules_vers })
where
maybe_iface = lookupIfaceByModule dflags hpt pit mod
Just iface = maybe_iface
orphan_mod = mi_orphan iface
+ finsts_mod = mi_finsts iface
version_env = mi_ver_fn iface
mod_vers = mi_mod_vers iface
rules_vers = mi_rule_vers iface
export_vers | depend_on_exports mod = Just (mi_exp_vers iface)
| 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_vers :: FiniteMap OccName Version
+ ent_vers = listToFM (map lookup_occ used_occs)
+
+ lookup_occ occ =
+ case version_env occ of
+ Nothing -> pprTrace "hmm, strange" (ppr mod <+> ppr occ) $
+ (occ, initialVersion) -- does this ever happen?
+ Just (parent, version) -> (parent, version)
\end{code}
\begin{code}
-mkIfaceExports :: NameSet -> [(Module, [GenAvailInfo OccName])]
+mkIfaceExports :: [AvailInfo]
+ -> [(Module, [GenAvailInfo OccName])]
-- Group by module and sort by occurrence
-- This keeps the list in canonical order
-mkIfaceExports exports
- = [ (mod, eltsUFM avails)
+mkIfaceExports exports
+ = [ (mod, eltsFM avails)
| (mod, avails) <- fmToList groupFM
]
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)
+ = add_one env (nameModule n) (Avail (nameOccName n))
+
+ add env (AvailTC tc 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.
+
%************************************************************************
%* *
}
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
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)
+ ; recomp <- checkDependencies hsc_env mod_summary iface
+ ; if recomp then return outOfDate else do {
+
-- Source code unchanged and no errors yet... carry on
-- First put the dependent-module info, read from the old interface, into the envt,
-- (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 _ mod) = do
+ find_res <- liftIO $ findImportedModule hsc_env mod Nothing
+ case find_res of
+ Found _ mod
+ | pkg == this_pkg
+ -> if moduleName mod `notElem` map fst prev_dep_mods
+ then do traceHiDiffs $
+ text "imported module " <> quotes (ppr mod) <>
+ text " not among previous dependencies"
+ return outOfDate
+ else
+ return upToDate
+ | otherwise
+ -> if pkg `notElem` prev_dep_pkgs
+ then do traceHiDiffs $
+ text "imported module " <> quotes (ppr mod) <>
+ text " is from package " <> quotes (ppr pkg) <>
+ text ", which is not among previous dependencies"
+ return outOfDate
+ else
+ return upToDate
+ where pkg = modulePackageId mod
+ _otherwise -> return outOfDate
+
checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
-- Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
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_`
+ = do -- Load the imported interface is possible
+ let doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]
+ traceHiDiffs (text "Checking usages for module" <+> ppr mod_name)
- let
- mod = mkModule this_pkg mod_name
- in
- loadInterface doc_str mod ImportBySystem `thenM` \ mb_iface ->
+ let mod = mkModule this_pkg mod_name
+
+ 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
new_rule_vers = mi_rule_vers iface
in
-- CHECK MODULE
- checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile ->
+ checkModuleVersion old_mod_vers new_mod_vers >>= \ recompile ->
if not recompile then
- returnM upToDate
+ return upToDate
else
-- CHECK EXPORT LIST
else
-- CHECK ITEMS ONE BY ONE
- checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenM` \ recompile ->
+ checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] >>= \ recompile ->
if recompile then
- returnM outOfDate -- This one failed, so just bail out now
+ 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"))
}
Nothing -> -- We used it before, but it ain't there now
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
+ Just (_, new_vers) -- It's there, but is it up to date?
+ | new_vers == old_vers -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers))
+ return upToDate
| otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name)
old_vers new_vers
-up_to_date msg = traceHiDiffs msg `thenM_` returnM upToDate
-out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate
+up_to_date msg = traceHiDiffs msg >> return upToDate
+out_of_date msg = traceHiDiffs msg >> return outOfDate
out_of_date_vers msg old_vers new_vers
= out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers])
----------------------
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}
%************************************************************************
%************************************************************************
\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),
+tyThingToIfaceDecl (AnId id)
+ = IfaceId { ifName = getOccName id,
+ ifType = toIfaceType (idType 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),
- ifVrcs = tyConArgVrcs tycon }
+ 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
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty
- toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map 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,
- ifVrcs = tyConArgVrcs tycon,
- ifSynRhs = toIfaceType ext syn_ty }
+ = IfaceSyn { ifName = getOccName tycon,
+ ifTyVars = toIfaceTvBndrs tyvars,
+ ifOpenSyn = syn_isOpen,
+ ifSynRhs = toIfaceType syn_tyki,
+ 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,
- ifVrcs = tyConArgVrcs 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,
- ifVrcs = tyConArgVrcs tycon }
-
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
tyvars = tyConTyVars tycon
- syn_ty = synTyConRhs tycon
-
- ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
- ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
- ifaceConDecls AbstractTyCon = IfAbstractTyCon
+ (syn_isOpen, syn_tyki) = case synTyConRhs tycon of
+ OpenSynTyCon ki _ -> (True , ki)
+ SynonymTyCon ty -> (False, ty)
+
+ ifaceConDecls (NewTyCon { data_con = con }) =
+ IfNewTyCon (ifaceConDecl con)
+ ifaceConDecls (DataTyCon { data_cons = cons }) =
+ IfDataTyCon (map ifaceConDecl cons)
+ ifaceConDecls OpenTyCon {} = IfOpenDataTyCon
+ ifaceConDecls AbstractTyCon = IfAbstractTyCon
-- The last case happens when a TyCon has been trimmed during tidying
-- Furthermore, tyThingToIfaceDecl is also used
-- in TcRnDriver for GHCi, when browsing a module, in which case the
ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con),
ifConEqSpec = to_eq_spec (dataConEqSpec data_con),
- ifConCtxt = toIfaceContext 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]
+
+ famInstToIface Nothing = Nothing
+ famInstToIface (Just (famTyCon, instTys)) =
+ Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
-tyThingToIfaceDecl ext (ADataCon dc)
+tyThingToIfaceDecl (ADataCon dc)
= pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
+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 ispec@(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 = nameModule dfun_name
+ is_local name = nameIsLocalOrFrom mod name
+
+ -- Compute orphanhood. See Note [Orphans] in IfaceSyn
+ (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
+ -- Slightly awkward: we need the Class to get the fundeps
+ (tvs, fds) = classTvsFds cls
+ arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
+ orph | is_local cls_name = Just (nameOccName cls_name)
+ | all isJust mb_ns = head mb_ns
+ | otherwise = Nothing
+
+ mb_ns :: [Maybe OccName] -- One for each fundep; a locally-defined name
+ -- that is not in the "determined" arguments
+ mb_ns | null fds = [choose_one arg_names]
+ | otherwise = map do_one fds
+ do_one (ltvs,rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
+ , not (tv `elem` rtvs)]
+
+ choose_one :: [NameSet] -> Maybe OccName
+ choose_one nss = case nameSetToList (unionManyNameSets nss) of
+ [] -> Nothing
+ (n:ns) -> Just (nameOccName n)
--------------------------
-toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem]
-toIfaceIdInfo ext id_info
+famInstToIfaceFamInst :: FamInst -> IfaceFamInst
+famInstToIfaceFamInst fi@(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 = IfLetBndr (occNameFS (getOccName id))
+ (toIfaceType (idType id))
+ prag_info
+ where
+ -- Stripped-down version of tcIfaceIdInfo
+ -- Change this if you want to export more IdInfo for
+ -- non-top-level Ids. Don't forget to change
+ -- CoreTidy.tidyLetBndr too!
+ --
+ -- See Note [IdInfo on nested let-bindings] in IfaceSyn
+ id_info = idInfo id
+ inline_prag = inlinePragInfo id_info
+ prag_info | isAlwaysActive inline_prag = NoInfo
+ | otherwise = HasInfo [HsInline inline_prag]
+
+--------------------------
+toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
+toIfaceIdInfo id_info
= catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
inline_hsinfo, wrkr_hsinfo, unfold_hsinfo]
where
------------ Worker --------------
work_info = workerInfo id_info
- has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
+ has_worker = workerExists work_info
wrkr_hsinfo = case work_info of
HasWorker work_id wrap_arity ->
- Just (HsWorker (ext (idName work_id)) wrap_arity)
+ Just (HsWorker ((idName work_id)) wrap_arity)
NoWorker -> Nothing
------------ Unfolding --------------
-- unconditional NOINLINE, etc. See TidyPgm.addExternal
unfold_hsinfo | no_unfolding = Nothing
| has_worker = Nothing -- Unfolding is implicit
- | otherwise = Just (HsUnfold (toIfaceExpr ext rhs))
+ | otherwise = Just (HsUnfold (toIfaceExpr rhs))
------------ Inline prag --------------
inline_prag = inlinePragInfo id_info
| otherwise = Just (HsInline inline_prag)
--------------------------
-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 mod (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:ns) -> Just (nameOccName n)
+ [] -> Nothing
-bogusIfaceRule :: IfaceExtName -> IfaceRule
+bogusIfaceRule :: Name -> IfaceRule
bogusIfaceRule id_name
= 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) (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 (SCC cc) = IfaceSCC cc
+toIfaceNote InlineMe = IfaceInlineMe
+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 (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 getOccName bs, toIfaceExpr ext r)
+toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
---------------------
toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
- | otherwise = IfaceDataAlt (getOccName dc)
+ | otherwise = IfaceDataAlt (getName dc)
where
tc = dataConTyCon dc
toIfaceCon DEFAULT = IfaceDefault
---------------------
-toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as)
-toIfaceApp ext (Var v) as
+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
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
+ other -> 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 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 (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}
projects / ghc-hetmet.git / blobdiff