From 61f93d4611724685c5808bcfd41e3d3e0f3aa94f Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Thu, 2 Dec 2010 12:23:49 +0000 Subject: [PATCH] Fix a recomp bug: make classes/datatypes depend directly on DFuns (#4469) And remove the old mechanism of recording dfun uses separately, because it didn't work. This wiki page describes recompilation avoidance and fingerprinting. I'll update it to describe the new method and what went wrong with the old method: http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance --- compiler/deSugar/Desugar.lhs | 2 +- compiler/iface/MkIface.lhs | 44 +++++++++++++------------------------- compiler/typecheck/TcRnMonad.lhs | 6 ++---- compiler/typecheck/TcRnTypes.lhs | 19 +++++----------- compiler/typecheck/TcSMonad.lhs | 28 +++--------------------- 5 files changed, 26 insertions(+), 73 deletions(-) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 073e873..60dec30 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -137,7 +137,7 @@ deSugar hsc_env ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps - ; used_names <- mkUsedNames tcg_env + ; let used_names = mkUsedNames tcg_env ; deps <- mkDependencies tcg_env ; let mod_guts = ModGuts { diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 0d59216..98a606e 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -153,7 +153,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details tcg_hpc = other_hpc_info } = do - used_names <- mkUsedNames tc_result + let used_names = mkUsedNames tc_result deps <- mkDependencies tc_result let hpc_info = emptyHpcInfo other_hpc_info mkIface_ hsc_env maybe_old_fingerprint @@ -161,13 +161,8 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details fix_env warns hpc_info (imp_mods imports) mod_details -mkUsedNames :: TcGblEnv -> IO NameSet -mkUsedNames - TcGblEnv{ tcg_inst_uses = dfun_uses_var, - tcg_dus = dus - } - = do { dfun_uses <- readIORef dfun_uses_var -- What dfuns are used - ; return (allUses dus `unionNameSets` dfun_uses) } +mkUsedNames :: TcGblEnv -> NameSet +mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus mkDependencies :: TcGblEnv -> IO Dependencies mkDependencies @@ -515,7 +510,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods orphan_hash <- computeFingerprint dflags (mk_put_name local_env) - (map IfaceInstABI orph_insts, orph_rules, fam_insts) + (map ifDFun orph_insts, orph_rules, fam_insts) -- the export list hash doesn't depend on the fingerprints of -- the Names it mentions, only the Names themselves, hence putNameLiterally. @@ -630,8 +625,8 @@ The ABI of a declaration consists of: Items (c)-(f) are not stored in the IfaceDecl, but instead appear elsewhere in the interface file. But they are *fingerprinted* with -the Id itself. This is done by grouping (c)-(f) in IfaceDeclExtras, -and fingerprinting that as part of the Id. +the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras, +and fingerprinting that as part of the declaration. \begin{code} type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras) @@ -657,10 +652,10 @@ freeNamesDeclABI (_mod, decl, extras) = freeNamesDeclExtras :: IfaceDeclExtras -> NameSet freeNamesDeclExtras (IfaceIdExtras _ rules) = unionManyNameSets (map freeNamesIfRule rules) -freeNamesDeclExtras (IfaceDataExtras _ _insts subs) - = unionManyNameSets (map freeNamesSub subs) -freeNamesDeclExtras (IfaceClassExtras _ _insts subs) - = unionManyNameSets (map freeNamesSub subs) +freeNamesDeclExtras (IfaceDataExtras _ insts subs) + = unionManyNameSets (mkNameSet insts : map freeNamesSub subs) +freeNamesDeclExtras (IfaceClassExtras _ insts subs) + = unionManyNameSets (mkNameSet insts : map freeNamesSub subs) freeNamesDeclExtras (IfaceSynExtras _) = emptyNameSet freeNamesDeclExtras IfaceOtherDeclExtras @@ -713,11 +708,11 @@ declExtras fix_fn rule_env inst_env decl (lookupOccEnvL rule_env n) IfaceData{ifCons=cons} -> IfaceDataExtras (fix_fn n) - (map IfaceInstABI $ lookupOccEnvL inst_env n) + (map ifDFun $ lookupOccEnvL inst_env n) (map (id_extras . ifConOcc) (visibleIfConDecls cons)) IfaceClass{ifSigs=sigs} -> IfaceClassExtras (fix_fn n) - (map IfaceInstABI $ lookupOccEnvL inst_env n) + (map ifDFun $ lookupOccEnvL inst_env n) [id_extras op | IfaceClassOp op _ _ <- sigs] IfaceSyn{} -> IfaceSynExtras (fix_fn n) _other -> IfaceOtherDeclExtras @@ -726,19 +721,10 @@ declExtras fix_fn rule_env inst_env decl id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ) -- --- When hashing an instance, we hash only its structure, not the --- fingerprints of the things it mentions. See the section on instances --- in the commentary, --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance +-- When hashing an instance, we hash only the DFunId, because that +-- depends on all the information about the instance. -- -newtype IfaceInstABI = IfaceInstABI IfaceInst - -instance Binary IfaceInstABI where - get = panic "no get for IfaceInstABI" - put_ bh (IfaceInstABI inst) = do - let ud = getUserData bh - bh' = setUserData bh (ud{ ud_put_name = putNameLiterally }) - put_ bh' inst +type IfaceInstABI = IfExtName lookupOccEnvL :: OccEnv [v] -> OccName -> [v] lookupOccEnvL env k = lookupOccEnv env k `orElse` [] diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 65128ba..92fa190 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -71,8 +71,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this = do { errs_var <- newIORef (emptyBag, emptyBag) ; meta_var <- newIORef initTyVarUnique ; tvs_var <- newIORef emptyVarSet ; - dfuns_var <- newIORef emptyNameSet ; - keep_var <- newIORef emptyNameSet ; + keep_var <- newIORef emptyNameSet ; used_rdr_var <- newIORef Set.empty ; th_var <- newIORef False ; lie_var <- newIORef emptyBag ; @@ -97,8 +96,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_type_env_var = type_env_var, tcg_inst_env = emptyInstEnv, tcg_fam_inst_env = emptyFamInstEnv, - tcg_inst_uses = dfuns_var, - tcg_th_used = th_var, + tcg_th_used = th_var, tcg_exports = [], tcg_imports = emptyImportAvails, tcg_used_rdrnames = used_rdr_var, diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 387961a..721f078 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -217,22 +217,13 @@ data TcGblEnv -- -- * Top-level variables appearing free in a TH bracket - tcg_inst_uses :: TcRef NameSet, - -- ^ Home-package Dfuns actually used. - -- - -- Used to generate version dependencies This records usages, rather - -- like tcg_dus, but it has to be a mutable variable so it can be - -- augmented when we look up an instance. These uses of dfuns are - -- rather like the free variables of the program, but are implicit - -- instead of explicit. - - tcg_th_used :: TcRef Bool, + tcg_th_used :: TcRef Bool, -- ^ @True@ <=> Template Haskell syntax used. -- - -- We need this so that we can generate a dependency on the Template - -- Haskell package, becuase the desugarer is going to emit loads of - -- references to TH symbols. It's rather like tcg_inst_uses; the - -- reference is implicit rather than explicit, so we have to zap a + -- We need this so that we can generate a dependency on the + -- Template Haskell package, becuase the desugarer is going + -- to emit loads of references to TH symbols. The reference + -- is implicit rather than explicit, so we have to zap a -- mutable variable. tcg_dfun_n :: TcRef OccSet, diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 85b5847..7b7a9f4 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -87,14 +87,11 @@ import InstEnv import FamInst import FamInstEnv -import NameSet ( addOneToNameSet ) - import qualified TcRnMonad as TcM import qualified TcMType as TcM import qualified TcEnv as TcM ( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys ) import TcType -import Module import DynFlags import Coercion @@ -952,8 +949,7 @@ matchClass clas tys text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) -- Record that this dfun is needed - ; record_dfun_usage dfun_id - ; return $ MatchInstSingle (dfun_id, inst_tys) + ; return $ MatchInstSingle (dfun_id, inst_tys) } ; (matches, unifs) -- More than one matches -> do { traceTcS "matchClass multiple matches, deferring choice" @@ -964,26 +960,8 @@ matchClass clas tys } } } - where record_dfun_usage :: Id -> TcS () - record_dfun_usage dfun_id - = do { hsc_env <- getTopEnv - ; let dfun_name = idName dfun_id - dfun_mod = ASSERT( isExternalName dfun_name ) - nameModule dfun_name - ; if isInternalName dfun_name || -- Internal name => defined in this module - modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env) - then return () -- internal, or in another package - else do updInstUses dfun_id - } - - updInstUses :: Id -> TcS () - updInstUses dfun_id - = do { tcg_env <- getGblEnv - ; wrapTcS $ TcM.updMutVar (tcg_inst_uses tcg_env) - (`addOneToNameSet` idName dfun_id) - } - -matchFam :: TyCon + +matchFam :: TyCon -> [Type] -> TcS (MatchInstResult (TyCon, [Type])) matchFam tycon args -- 1.7.10.4