From 311b1cdfc9b1c311cc53482c461c18cba8885b2a Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 13 Oct 2006 00:42:23 +0000 Subject: [PATCH] Keep track of family instance modules - Now each modules carries (1) a flag saying whether it contains family instance declarations and (2) a list of all modules further down in the import tree that contain family instance declarations. (The information is split into these two parts for the exact same reasons why the info about orphan modules is split, too.) - This is the first step to *optimised* overlap checking of family instances coming from imported modules. *** WARNING: This patch changes the interface file format! *** *** Recompile libraries and stage2 from scratch! *** --- compiler/deSugar/Desugar.lhs | 7 ++++--- compiler/iface/BinIface.hs | 9 ++++++++- compiler/iface/IfaceSyn.lhs | 5 ++++- compiler/iface/IfaceType.lhs | 1 + compiler/iface/LoadIface.lhs | 17 ++++++++++++----- compiler/iface/MkIface.lhs | 24 +++++++++++++++++------- compiler/main/HscTypes.lhs | 23 ++++++++++++++++++----- compiler/rename/RnNames.lhs | 14 ++++++++++---- compiler/typecheck/TcRnDriver.lhs | 13 +++++++++---- compiler/typecheck/TcRnTypes.lhs | 15 ++++++++++++--- 10 files changed, 95 insertions(+), 33 deletions(-) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 8fcaf9b..ab4ee74 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -139,9 +139,10 @@ deSugar hsc_env le_dep_mod :: (ModuleName, IsBootInterface) -> (ModuleName, IsBootInterface) -> Bool le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2 - deps = Deps { dep_mods = sortLe le_dep_mod dep_mods, - dep_pkgs = sortLe (<=) pkgs, - dep_orphs = sortLe le_mod (imp_orphs imports) } + deps = 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 mod_guts = ModGuts { diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index d47398c..ebb26c7 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -251,6 +251,7 @@ instance Binary ModIface where mi_boot = is_boot, mi_mod_vers = mod_vers, mi_orphan = orphan, + mi_finsts = hasFamInsts, mi_deps = deps, mi_usages = usages, mi_exports = exports, @@ -269,6 +270,7 @@ instance Binary ModIface where put_ bh is_boot put_ bh mod_vers put_ bh orphan + put_ bh hasFamInsts lazyPut bh deps lazyPut bh usages put_ bh exports @@ -305,6 +307,7 @@ instance Binary ModIface where is_boot <- get bh mod_vers <- get bh orphan <- get bh + hasFamInsts <- get bh deps <- lazyGet bh usages <- {-# SCC "bin_usages" #-} lazyGet bh exports <- {-# SCC "bin_exports" #-} get bh @@ -321,6 +324,7 @@ instance Binary ModIface where mi_boot = is_boot, mi_mod_vers = mod_vers, mi_orphan = orphan, + mi_finsts = hasFamInsts, mi_deps = deps, mi_usages = usages, mi_exports = exports, @@ -355,11 +359,14 @@ instance Binary Dependencies where put_ bh deps = do put_ bh (dep_mods deps) put_ bh (dep_pkgs deps) put_ bh (dep_orphs deps) + put_ bh (dep_finsts deps) get bh = do ms <- get bh ps <- get bh os <- get bh - return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os }) + fis <- get bh + return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, + dep_finsts = fis }) instance (Binary name) => Binary (GenAvailInfo name) where put_ bh (Avail aa) = do diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 4f37ca0..7efa029 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -17,7 +17,7 @@ module IfaceSyn ( -- Equality GenIfaceEq(..), IfaceEq, (&&&), bool, eqListBy, eqMaybeBy, - eqIfDecl, eqIfInst, eqIfRule, checkBootDecl, + eqIfDecl, eqIfInst, eqIfFamInst, eqIfRule, checkBootDecl, -- Pretty printing pprIfaceExpr, pprIfaceDeclHead @@ -649,6 +649,9 @@ eqWith = eq_ifTvBndrs emptyEqEnv eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2) -- All other changes are handled via the version info on the dfun +eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2) +-- All other changes are handled via the version info on the tycon + eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1) (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2) = bool (n1==n2 && a1==a2 && o1 == o2) &&& diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 8af258a..7615a91 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -81,6 +81,7 @@ data IfaceTyCon -- Abbreviations for common tycons with known names | IfaceTupTc Boxity Arity | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc | IfaceUbxTupleKindTc | IfaceArgTypeKindTc + deriving( Eq ) ifaceTyConName :: IfaceTyCon -> Name ifaceTyConName IfaceIntTc = intTyConName diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 4ef589d..fce5c1d 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -88,8 +88,10 @@ loadSrcInterface doc mod want_boot = do failWithTc (cannotFindInterface dflags mod err) -- | Load interfaces for a collection of orphan modules. -loadOrphanModules :: [Module] -> TcM () -loadOrphanModules mods +loadOrphanModules :: [Module] -- the modules + -> Bool -- these are family instance-modules + -> TcM () +loadOrphanModules mods isFamInstMod | null mods = returnM () | otherwise = initIfaceTcRn $ do { traceIf (text "Loading orphan modules:" <+> @@ -98,7 +100,9 @@ loadOrphanModules mods ; returnM () } where load mod = loadSysInterface (mk_doc mod) mod - mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module") + mk_doc mod + | isFamInstMod = ppr mod <+> ptext SLIT("is a family-instance module") + | otherwise = ppr mod <+> ptext SLIT("is a orphan-instance module") -- | Loads the interface for a given Name. loadInterfaceForName :: SDoc -> Name -> TcRn ModIface @@ -528,6 +532,7 @@ pprModIface iface <+> ppr (mi_module iface) <+> pp_boot <+> ppr (mi_mod_vers iface) <+> pp_sub_vers <+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty) + <+> (if mi_finsts iface then ptext SLIT("[family instance module]") else empty) <+> int opt_HiVersion <+> ptext SLIT("where") , vcat (map pprExport (mi_exports iface)) @@ -583,10 +588,12 @@ pprUsage usage pp_export_version (Just v) = int v pprDeps :: Dependencies -> SDoc -pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs}) +pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, + dep_finsts = finsts }) = vcat [ptext SLIT("module dependencies:") <+> fsep (map ppr_mod mods), ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs), - ptext SLIT("orphans:") <+> fsep (map ppr orphs) + ptext SLIT("orphans:") <+> fsep (map ppr orphs), + ptext SLIT("family instance modules:") <+> fsep (map ppr finsts) ] where ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index d9c993a..2f17fe7 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -289,6 +289,7 @@ 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", @@ -371,9 +372,12 @@ addVersionInfo 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 = mkIfaceVerCache (zip (repeat initialVersion) new_decls)}, + || anyNothing ifRuleOrph (mi_rules new_iface) + , mi_finsts = not . null $ mi_fam_insts new_iface + , mi_decls = [(initialVersion, decl) | decl <- new_decls] + , mi_ver_fn = mkIfaceVerCache (zip (repeat initialVersion) + new_decls) + }, False, ptext SLIT("No old interface file"), pprOrphans orph_insts orph_rules) @@ -401,6 +405,7 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { 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 } @@ -411,6 +416,8 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { 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) @@ -430,7 +437,8 @@ addVersionInfo ver_fn (Just old_iface@(ModIface { -- Kept sorted no_decl_change = isEmptyOccSet changed_occs no_rule_change = not (changedWrtNames changed_occs (eqListBy eqIfRule old_orph_rules new_orph_rules) - || changedWrtNames changed_occs (eqListBy eqIfInst old_orph_insts new_orph_insts)) + || changedWrtNames changed_occs (eqListBy 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 @@ -710,14 +718,15 @@ mk_usage_info pit hsc_env dir_imp_mods dep_mods 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 @@ -735,6 +744,7 @@ mk_usage_info pit hsc_env dir_imp_mods dep_mods 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 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 7e30d77..399184a 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -367,6 +367,7 @@ data ModIface mi_mod_vers :: !Version, -- Module version: changes when anything changes mi_orphan :: !WhetherHasOrphans, -- Whether this module has orphans + mi_finsts :: !WhetherHasFamInst, -- Whether module has family insts mi_boot :: !IsBootInterface, -- Read from an hi-boot file? mi_deps :: Dependencies, @@ -420,7 +421,8 @@ data ModIface mi_fam_insts :: [IfaceFamInst], -- Sorted mi_rules :: [IfaceRule], -- Sorted mi_rule_vers :: !Version, -- Version number for rules and - -- instances combined + -- instances (for classes and families) + -- combined -- Cached environments for easy lookup -- These are computed (lazily) from other fields @@ -550,6 +552,7 @@ emptyModIface mod = ModIface { mi_module = mod, mi_mod_vers = initialVersion, mi_orphan = False, + mi_finsts = False, mi_boot = False, mi_deps = noDependencies, mi_usages = [], @@ -904,22 +907,32 @@ type WhetherHasOrphans = Bool -- * a transformation rule in a module other than the one defining -- the function in the head of the rule. +type WhetherHasFamInst = Bool -- This module defines family instances? + type IsBootInterface = Bool -- Dependency info about modules and packages below this one -- in the import hierarchy. See TcRnTypes.ImportAvails for details. +-- The orphan modules in `dep_orphs' do *not* include family instance orphans, +-- as they are anyway included in `dep_finsts'. -- -- Invariant: the dependencies of a module M never includes M -- Invariant: the lists are unordered, with no duplicates data Dependencies - = Deps { dep_mods :: [(ModuleName,IsBootInterface)], -- Home-package module dependencies - dep_pkgs :: [PackageId], -- External package dependencies - dep_orphs :: [Module] } -- Orphan modules (whether home or external pkg) + = Deps { dep_mods :: [(ModuleName, -- Home-package module dependencies + IsBootInterface)] + , dep_pkgs :: [PackageId] -- External package dependencies + , dep_orphs :: [Module] -- Orphan modules (whether home or + -- external pkg) + , dep_finsts :: [Module] -- Modules that contain family + -- instances (whether home or + -- external pkg) + } deriving( Eq ) -- Equality used only for old/new comparison in MkIface.addVersionInfo noDependencies :: Dependencies -noDependencies = Deps [] [] [] +noDependencies = Deps [] [] [] [] data Usage = Usage { usg_name :: ModuleName, -- Name of the module diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index ec65f72..29468fd 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -163,10 +163,11 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot (warnRedundantSourceImport imp_mod_name) let - imp_mod = mi_module iface - deprecs = mi_deprecs iface - is_orph = mi_orphan iface - deps = mi_deps iface + imp_mod = mi_module iface + deprecs = mi_deprecs iface + is_orph = mi_orphan iface + has_finsts = mi_finsts iface + deps = mi_deps iface filtered_exports = filter not_this_mod (mi_exports iface) not_this_mod (mod,_) = mod /= this_mod @@ -211,6 +212,10 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot imp_mod : dep_orphs deps | otherwise = dep_orphs deps + finsts | has_finsts = ASSERT( not (imp_mod `elem` dep_finsts deps) ) + imp_mod : dep_finsts deps + | otherwise = dep_finsts deps + pkg = modulePackageId (mi_module iface) (dependent_mods, dependent_pkgs) @@ -244,6 +249,7 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot imp_env = unitUFM qual_mod_name filtered_avails, imp_mods = unitModuleEnv imp_mod (imp_mod, import_all, loc), imp_orphs = orphans, + imp_finsts = finsts, imp_dep_mods = mkModDeps dependent_mods, imp_dep_pkgs = dependent_pkgs, imp_parent = emptyNameEnv diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 8cb815f..c41367e 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -167,9 +167,11 @@ tcRnModule hsc_env hsc_src save_rn_syntax traceIf (text "rdr_env: " <+> ppr rdr_env) ; failIfErrsM ; - -- Load any orphan-module interfaces, so that - -- their rules and instance decls will be found - loadOrphanModules (imp_orphs imports) ; + -- Load any orphan-module and family instance-module + -- interfaces, so that their rules and instance decls will be + -- found. + loadOrphanModules (imp_orphs imports) False ; + loadOrphanModules (imp_finsts imports) True ; traceRn (text "rn1a") ; -- Rename and type check the declarations @@ -1098,9 +1100,12 @@ tcGetModuleExports :: Module -> TcM [AvailInfo] tcGetModuleExports mod = do let doc = ptext SLIT("context for compiling statements") iface <- initIfaceTcRn $ loadSysInterface doc mod - loadOrphanModules (dep_orphs (mi_deps iface)) + loadOrphanModules (dep_orphs (mi_deps iface)) False -- Load any orphan-module interfaces, -- so their instances are visible + loadOrphanModules (dep_finsts (mi_finsts iface)) True + -- Load any family instance-module interfaces, + -- so all family instances are visible ifaceExportNames (mi_exports iface) tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index ff1a9cc..2bb80bc 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -529,7 +529,12 @@ data ImportAvails -- modules imported from other packages. imp_orphs :: [Module], - -- Orphan modules below us in the import tree + -- Orphan modules below us in the import tree (and maybe + -- including us for imported modules) + + imp_finsts :: [Module], + -- Family instance modules below us in the import tree (and + -- maybe including us for imported modules) imp_parent :: NameEnv AvailInfo -- for the names in scope in this module, tells us @@ -550,21 +555,25 @@ emptyImportAvails = ImportAvails { imp_env = emptyUFM, imp_dep_mods = emptyUFM, imp_dep_pkgs = [], imp_orphs = [], + imp_finsts = [], imp_parent = emptyNameEnv } plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails plusImportAvails (ImportAvails { imp_env = env1, imp_mods = mods1, imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, - imp_orphs = orphs1, imp_parent = parent1 }) + imp_orphs = orphs1, imp_finsts = finsts1, + imp_parent = parent1 }) (ImportAvails { imp_env = env2, imp_mods = mods2, imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, - imp_orphs = orphs2, imp_parent = parent2 }) + imp_orphs = orphs2, imp_finsts = finsts2, + imp_parent = parent2 }) = ImportAvails { imp_env = plusUFM_C (++) env1 env2, imp_mods = mods1 `plusModuleEnv` mods2, imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, imp_orphs = orphs1 `unionLists` orphs2, + imp_finsts = finsts1 `unionLists` finsts2, imp_parent = plusNameEnv_C plus_avails parent1 parent2 } where plus_avails (AvailTC tc subs1) (AvailTC _ subs2) -- 1.7.10.4