X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=564d3a4a7d695aa1c78c6d2654b5e4cfb420df56;hp=7901f7c5142325b9ca5a7e702e050e305394d46e;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hpb=e8a591c1a3dbdeccec2dd2aacccd7435004b0d51 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 7901f7c..564d3a4 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % @@ -175,75 +176,48 @@ compiled with -O. I think this is the case.] \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(..), 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 HscTypes + +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 BasicTypes hiding ( SuccessFlag(..) ) import UniqFM -import PackageConfig ( PackageId ) +import Util hiding ( eqListBy ) import FiniteMap import FastString +import Maybes -import Monad ( when ) -import List ( insert ) -import Maybes ( orElse, mapCatMaybes, isNothing, isJust, - expectJust, catMaybes, MaybeErr(..) ) +import Control.Monad +import Data.List \end{code} @@ -264,17 +238,20 @@ mkIface :: HscEnv -- 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{ 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, + mg_hpc_info = hpc_info }) + (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 @@ -282,20 +259,23 @@ mkIface hsc_env maybe_old_iface -- 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 + ; 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 + ; 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,8 +283,15 @@ 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_globals = Just rdr_env, @@ -315,17 +302,21 @@ mkIface hsc_env maybe_old_iface 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 + addVersionInfo ext_ver_fn maybe_old_iface + intermediate_iface decls } -- Debug printing @@ -337,91 +328,87 @@ mkIface hsc_env maybe_old_iface ; return (new_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 +writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO () +writeIfaceFile dflags location new_iface = do createDirectoryHierarchy (directoryOf hi_file_path) - writeBinIface hi_file_path new_iface + 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) @@ -429,7 +416,8 @@ addVersionInfo Nothing new_iface new_decls 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, @@ -437,29 +425,38 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_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 } + | 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) @@ -467,15 +464,18 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, -- 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" @@ -494,28 +494,32 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, ------------------- -- 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 @@ -532,7 +536,12 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, 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 @@ -552,9 +561,10 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, 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, @@ -565,6 +575,7 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, pp_orphs = pprOrphans new_orph_insts new_orph_rules + pprOrphans insts rules | null insts && null rules = Nothing | otherwise @@ -577,32 +588,82 @@ pprOrphans insts rules 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 + | Just ents <- lookupUFM usg_modmap (moduleName mod) + = case lookupUFM ents parent_occ of + Nothing -> pprPanic "computeChangedOccs" (ppr nm) + Just v -> v < new_version + | otherwise = False -- must be in another package + where + mod = nameModule nm + (parent_occ, new_version) = ver_fn nm + + -- Turn the usages from the old ModIface into a mapping + usg_modmap = listToUFM [ (usg_mod usg, listToUFM (usg_entities usg)) + | usg <- old_usages ] + + get_local_eq_info :: GenIfaceEq NameSet -> GenIfaceEq OccSet + get_local_eq_info Equal = Equal + get_local_eq_info NotEqual = NotEqual + get_local_eq_info (EqBut ns) = foldNameSet f Equal ns + where f name eq | nameModule name == this_module = + EqBut (unitOccSet (nameOccName name)) `and_occifeq` eq + | name_changed name = NotEqual + | otherwise = eq + + local_eq_infos = mapSnd get_local_eq_info eq_info + + edges :: [((OccName, OccIfaceEq), Unique, [Unique])] edges = [ (node, getUnique occ, map getUnique occs) - | node@(occ, iface_eq) <- 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 OccSet + +changedWrt :: OccSet -> OccIfaceEq -> Bool changedWrt so_far Equal = False changedWrt so_far NotEqual = True changedWrt so_far (EqBut kids) = so_far `intersectsOccSet` kids +changedWrtNames :: OccSet -> IfaceEq -> Bool +changedWrtNames so_far Equal = False +changedWrtNames so_far NotEqual = True +changedWrtNames so_far (EqBut kids) = + so_far `intersectsOccSet` mkOccSet (map nameOccName (nameSetToList kids)) + +and_occifeq :: OccIfaceEq -> OccIfaceEq -> OccIfaceEq +Equal `and_occifeq` x = x +NotEqual `and_occifeq` x = NotEqual +EqBut nms `and_occifeq` Equal = EqBut nms +EqBut nms `and_occifeq` NotEqual = NotEqual +EqBut nms1 `and_occifeq` EqBut nms2 = EqBut (nms1 `unionOccSets` nms2) + ---------------------- -- mkOrphMap partitions instance decls or rules into -- (a) an OccEnv for ones that are not orphans, @@ -622,10 +683,6 @@ mkOrphMap get_key decls = (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 @@ -660,28 +717,25 @@ 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 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 @@ -692,21 +746,22 @@ mk_usage_info pit hsc_env dir_imp_mods dep_mods proto_used_names -- 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 @@ -717,46 +772,55 @@ mk_usage_info pit hsc_env dir_imp_mods dep_mods proto_used_names 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 + -- Deliberately use FiniteMap rather than UniqFM so we -- get a canonical ordering - groupFM = foldl add emptyModuleEnv (nameSetToList exports) + groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) + groupFM = foldl add emptyModuleEnv exports - add env name = extendModuleEnv_C add_avail env mod - (unitUFM avail_fs avail) + add env avail + = extendModuleEnv_C add_avail env mod (unitFM avail_fs avail_occ) 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) + avail_occ = availToOccs avail + mod = nameModule (availName avail) + avail_fs = occNameFS (availName avail_occ) + add_avail avail_fm _ = addToFM avail_fm avail_fs avail_occ + + availToOccs (Avail n) = Avail (nameOccName n) + availToOccs (AvailTC tc ns) = AvailTC (nameOccName tc) (map nameOccName ns) \end{code} @@ -785,44 +849,41 @@ checkOldIface hsc_env mod_summary source_unchanged maybe_iface } 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 + { ifM (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 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 iface + ; returnM (recomp, Just iface) + }}}}} \end{code} @recompileRequired@ is called from the HscMain. It checks whether @@ -855,7 +916,9 @@ checkVersions hsc_env source_unchanged iface -- (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 + -- 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) @@ -949,7 +1012,7 @@ checkEntityUsage new_vers (name,old_vers) 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? + 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) @@ -978,34 +1041,36 @@ 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), +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) } 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 +1080,44 @@ 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 = 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, - 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) + OpenSynTyCon ki _ -> (True , ki) + SynonymTyCon ty -> (False, 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 @@ -1072,34 +1129,93 @@ tyThingToIfaceDecl ext (ATyCon tycon) 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 (dataConTheta 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) + +-------------------------- +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) -------------------------- -toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] -toIfaceIdInfo ext id_info +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 @@ -1125,7 +1241,7 @@ toIfaceIdInfo ext 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) + Just (HsWorker ((idName work_id)) wrap_arity) NoWorker -> Nothing ------------ Unfolding -------------- @@ -1138,7 +1254,7 @@ toIfaceIdInfo ext id_info -- 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 @@ -1149,63 +1265,72 @@ toIfaceIdInfo ext 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) (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 (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 (occNameFS.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 @@ -1213,8 +1338,8 @@ 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 (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 +1347,24 @@ 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 + 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 (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}