X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnBinds.lhs;h=265a03899648ab0e9f74f5a6fcfd075f326e170f;hb=ab6f7888dfc275d3e8528465ecb058e2f2e8d8a3;hp=fae6ae8e52ee5bddd12bf7c31ba873ddd1e19fcc;hpb=c2def8304ba7c48c4a3e652a63f136ebcd453674;p=ghc-hetmet.git

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index fae6ae8..265a038 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -317,10 +317,11 @@ rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) = do
    sigs' <- renameSigs (Just (mkNameSet bound_names)) okBindSig sigs
    -- rename the RHSes
    binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
-   let (anal_binds, anal_dus) = depAnalBinds binds_w_dus
-       (valbind', valbind'_dus) = (ValBindsOut anal_binds sigs',
-                                   usesOnly (hsSigsFVs sigs') `plusDU` anal_dus)
-   return (valbind', valbind'_dus)
+   case depAnalBinds binds_w_dus of
+       (anal_binds, anal_dus) ->
+           do let valbind' = ValBindsOut anal_binds sigs'
+                  valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus
+              return (valbind', valbind'_dus)
 
 rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b)
 
@@ -494,11 +495,13 @@ rnBind _ trim (L loc (PatBind { pat_lhs = pat,
 
 	; (grhss', fvs) <- rnGRHSs PatBindRhs grhss
 		-- No scoped type variables for pattern bindings
+	; let fvs' = trim fvs
 
-	; return (L loc (PatBind { pat_lhs = pat, 
+	; fvs' `seq` -- See Note [Free-variable space leak]
+      return (L loc (PatBind { pat_lhs = pat,
                                   pat_rhs = grhss', 
 				     pat_rhs_ty = placeHolderType, 
-                                  bind_fvs = trim fvs }), 
+                                  bind_fvs = fvs' }),
 		  bndrs, pat_fvs `plusFV` fvs) }
 
 rnBind sig_fn 
@@ -516,20 +519,35 @@ rnBind sig_fn
 	; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
 				-- bindSigTyVars tests for Opt_ScopedTyVars
 			     rnMatchGroup (FunRhs plain_name inf) matches
+	; let fvs' = trim fvs
 
 	; checkPrecMatch inf plain_name matches'
 
-	; return (L loc (FunBind { fun_id = name, 
+	; fvs' `seq` -- See Note [Free-variable space leak]
+      return (L loc (FunBind { fun_id = name,
                                   fun_infix = inf, 
                                   fun_matches = matches',
-				     bind_fvs = trim fvs, 
+				     bind_fvs = fvs',
                                   fun_co_fn = idHsWrapper, 
                                   fun_tick = Nothing }), 
 		  [plain_name], fvs)
       }
 
 rnBind _ _ b = pprPanic "rnBind" (ppr b)
-		
+
+{-
+Note [Free-variable space leak]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have
+    fvs' = trim fvs
+and we seq fvs' before turning it as part of a record.
+
+The reason is that trim is sometimes something like
+    \xs -> intersectNameSet (mkNameSet bound_names) xs
+and we don't want to retain the list bound_names. This showed up in
+trac ticket #1136.
+-}
+
 ---------------------
 depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
 	     -> ([(RecFlag, LHsBinds Name)], DefUses)
@@ -787,9 +805,9 @@ lookupSigOccRn mb_names sig v
 
 \begin{code}
 rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
-rnMatchGroup ctxt (MatchGroup ms _) = do
-    (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms
-    return (MatchGroup new_ms placeHolderType, ms_fvs)
+rnMatchGroup ctxt (MatchGroup ms _) 
+  = do { (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms
+       ; return (MatchGroup new_ms placeHolderType, ms_fvs) }
 
 rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
 rnMatch ctxt  = wrapLocFstM (rnMatch' ctxt)