From b2d9ef8482638a91e68acdd19ecfe24db0458049 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 6 May 2010 16:27:19 +0000 Subject: [PATCH] Make tcg_dus behave more sanely; fixes a mkUsageInfo panic The tcg_dus field used to contain *uses* of type and class decls, but not *defs*. That was inconsistent, and it really went wrong for Template Haskell bracket. What happened was that foo = [d| data A = A f :: A -> A f x = x |] would find a "use" of A when processing the top level of the module, which in turn led to a mkUsageInfo panic in MkIface. The cause was the fact that the tcg_dus for the nested quote didn't have defs for A. --- compiler/basicTypes/NameSet.lhs | 9 +++--- compiler/rename/RnBinds.lhs | 4 +-- compiler/rename/RnExpr.lhs | 9 +++--- compiler/rename/RnSource.lhs | 59 ++++++++++++++++++++------------------- 4 files changed, 43 insertions(+), 38 deletions(-) diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs index c46127c..e2acaf7 100644 --- a/compiler/basicTypes/NameSet.lhs +++ b/compiler/basicTypes/NameSet.lhs @@ -154,6 +154,7 @@ type Uses = NameSet type DefUse = (Maybe Defs, Uses) -- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' +-- In a single (def, use) pair, the defs also scope over the uses type DefUses = [DefUse] emptyDUs :: DefUses @@ -174,16 +175,16 @@ duDefs dus = foldr get emptyNameSet dus get (Nothing, _u1) d2 = d2 get (Just d1, _u1) d2 = d1 `unionNameSets` d2 -duUses :: DefUses -> Uses +allUses :: DefUses -> Uses -- ^ Just like 'allUses', but 'Defs' are not eliminated from the 'Uses' returned -duUses dus = foldr get emptyNameSet dus +allUses dus = foldr get emptyNameSet dus where get (_d1, u1) u2 = u1 `unionNameSets` u2 -allUses :: DefUses -> Uses +duUses :: DefUses -> Uses -- ^ Collect all 'Uses', regardless of whether the group is itself used, -- but remove 'Defs' on the way -allUses dus +duUses dus = foldr get emptyNameSet dus where get (Nothing, rhs_uses) uses = rhs_uses `unionNameSets` uses diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index bf4257d..8749711 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -352,9 +352,9 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside ; let -- The variables "used" in the val binds are: - -- (1) the uses of the binds (duUses) + -- (1) the uses of the binds (allUses) -- (2) the FVs of the thing-inside - all_uses = duUses dus `plusFV` result_fvs + all_uses = allUses dus `plusFV` result_fvs -- Note [Unused binding hack] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Note that *in contrast* to the above reporting of diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 490faec..620b1fe 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -618,8 +618,9 @@ rnBracket (DecBrL decls) setStage thRnBrack $ rnSrcDecls group - -- Discard the tcg_env; it contains only extra info about fixity - ; return (DecBrG group', allUses (tcg_dus tcg_env)) } + -- Discard the tcg_env; it contains only extra info about fixity + ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env)))) + ; return (DecBrG group', duUses (tcg_dus tcg_env)) } rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" \end{code} @@ -994,8 +995,8 @@ rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do (binds', du_binds) <- -- fixities and unused are handled above in rn_rec_stmts_and_then rnValBindsRHS (mkNameSet all_bndrs) binds' - return [(duDefs du_binds, duUses du_binds, - emptyNameSet, L loc (LetStmt (HsValBinds binds')))] + return [(duDefs du_binds, allUses du_binds, + emptyNameSet, L loc (LetStmt (HsValBinds binds')))] -- no RecStmt case becuase they get flattened above when doing the LHSes rn_rec_stmt _ stmt@(L _ (RecStmt {})) _ diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 5d23110..a152a18 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -86,17 +86,17 @@ Checks the @(..)@ etc constraints in the export list. -- does NOT assume that anything is in scope already rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) -- Rename a HsGroup; used for normal source files *and* hs-boot files -rnSrcDecls group@(HsGroup {hs_valds = val_decls, - hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_derivds = deriv_decls, - hs_fixds = fix_decls, - hs_warnds = warn_decls, - hs_annds = ann_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_docs = docs }) +rnSrcDecls group@(HsGroup { hs_valds = val_decls, + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = warn_decls, + hs_annds = ann_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_docs = docs }) = do { -- (A) Process the fixity declarations, creating a mapping from -- FastStrings to FixItems. @@ -178,30 +178,33 @@ rnSrcDecls group@(HsGroup {hs_valds = val_decls, rn_docs <- mapM (wrapLocM rnDocDecl) docs ; -- (I) Compute the results and return - let {rn_group = HsGroup { hs_valds = rn_val_decls, - hs_tyclds = rn_tycl_decls, - hs_instds = rn_inst_decls, + let {rn_group = HsGroup { hs_valds = rn_val_decls, + hs_tyclds = rn_tycl_decls, + hs_instds = rn_inst_decls, hs_derivds = rn_deriv_decls, - hs_fixds = rn_fix_decls, - hs_warnds = [], -- warns are returned in the tcg_env + hs_fixds = rn_fix_decls, + hs_warnds = [], -- warns are returned in the tcg_env -- (see below) not in the HsGroup hs_fords = rn_foreign_decls, - hs_annds = rn_ann_decls, + hs_annds = rn_ann_decls, hs_defds = rn_default_decls, hs_ruleds = rn_rule_decls, hs_docs = rn_docs } ; - other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, - src_fvs5, src_fvs6, src_fvs7] ; - src_dus = bind_dus `plusDU` usesOnly other_fvs; - -- Note: src_dus will contain *uses* for locally-defined types - -- and classes, but no *defs* for them. (Because rnTyClDecl - -- returns only the uses.) This is a little - -- surprising but it doesn't actually matter at all. - - final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus) - in -- we return the deprecs in the env, not in the HsGroup above - tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; + tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ; + ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ; + other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ; + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, + src_fvs5, src_fvs6, src_fvs7] ; + -- It is tiresome to gather the binders from type and class decls + + src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ; + -- Instance decls may have occurrences of things bound in bind_dus + -- so we must put other_fvs last + + final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus) + in -- we return the deprecs in the env, not in the HsGroup above + tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; } ; traceRn (text "finish rnSrc" <+> ppr rn_group) ; -- 1.7.10.4