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.

diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs
index c46127c..e2acaf7 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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) ;