Commit b2d9ef84 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent 302e2e29
......@@ -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
......
......@@ -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
......
......@@ -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 {})) _
......
......@@ -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) ;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment