Allow type families to use GADT syntax (and be GADTs)

[ghc-hetmet.git] / compiler / rename / RnBinds.lhs

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 60d1a3e..23a22c9 100644 (file)
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -312,8 +312,6 @@ rnValBindsRHSGen :: (FreeVars -> FreeVars)  -- for trimming free var sets
 
 rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) = do
    -- rename the sigs
-   env <- getGblEnv
-   traceRn (ptext (sLit "Rename sigs") <+> ppr (tcg_rdr_env env))
    sigs' <- renameSigs (Just (mkNameSet bound_names)) okBindSig sigs
    -- rename the RHSes
    binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
@@ -495,11 +493,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 
@@ -517,20 +517,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)