fix a space leak

[ghc-hetmet.git] / compiler / specialise / Specialise.lhs

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index a3b5dd6..7a37d02 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -25,15 +25,14 @@ import CoreSubst    ( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst,
                          substBndr, substBndrs, substTy, substInScope,
                          cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs
                        ) 
+import SimplUtils      ( interestingArg )
 import VarSet
 import VarEnv
 import CoreSyn
+import Rules
 import CoreUtils       ( applyTypeToArgs, mkPiTypes )
 import CoreFVs         ( exprFreeVars, exprsFreeVars, idFreeVars )
-import CoreTidy                ( tidyRules )
 import CoreLint                ( showPass, endPass )
-import Rules           ( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds )
-import PprCore         ( pprRules )
 import UniqSupply      ( UniqSupply,
                          UniqSM, initUs_,
                          MonadUnique(..)
@@ -488,8 +487,6 @@ of this is permanently ruled out.
 Still, this is no great hardship, because we intend to eliminate
 overloading altogether anyway!
 
-
-
 A note about non-tyvar dictionaries
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Some Ids have types like
@@ -514,7 +511,7 @@ Should we specialise wrt this compound-type dictionary?  We used to say
 But it is simpler and more uniform to specialise wrt these dicts too;
 and in future GHC is likely to support full fledged type signatures 
 like
-       f ;: Eq [(a,b)] => ...
+       f :: Eq [(a,b)] => ...
 
 
 %************************************************************************
@@ -588,7 +585,7 @@ specProgram dflags us binds = do
        endPass dflags "Specialise" Opt_D_dump_spec binds'
 
        dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
-                 (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
+                     (pprRulesForUser (rulesOfBinds binds'))
 
        return binds'
   where
@@ -865,7 +862,9 @@ specDefn subst calls (fn, rhs)
                       where
                         mk_ty_arg rhs_tyvar Nothing   = Type (mkTyVarTy rhs_tyvar)
                         mk_ty_arg _         (Just ty) = Type ty
-          rhs_subst  = extendTvSubstList subst (spec_tyvars `zip` [ty | Just ty <- call_ts])
+
+           spec_ty_args = [ty | Just ty <- call_ts]
+          rhs_subst  = extendTvSubstList subst (spec_tyvars `zip` spec_ty_args)
 
        (rhs_subst', rhs_dicts') <- cloneBinders rhs_subst rhs_dicts
        let
@@ -884,7 +883,9 @@ specDefn subst calls (fn, rhs)
        let
                -- The rule to put in the function's specialisation is:
                --      forall b,d, d1',d2'.  f t1 b t3 d d1' d2' = f1 b d  
-           spec_env_rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr fn)))
+          rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args))
+           spec_env_rule = mkLocalRule 
+                               rule_name
                                inline_prag     -- Note [Auto-specialisation and RULES]
                                (idName fn)
                                (poly_tyvars ++ rhs_dicts')
@@ -1089,6 +1090,7 @@ mkCallUDs subst f args
        --  *don't* say what the value of the implicit param is!
   || not (spec_tys `lengthIs` n_tyvars)
   || not ( dicts   `lengthIs` n_dicts)
+  || not (any interestingArg dicts)    -- Note [Interesting dictionary arguments]
   || maybeToBool (lookupRule (\_act -> True) (substInScope subst) emptyRuleBase f args)
        -- There's already a rule covering this call.  A typical case
        -- is where there's an explicit user-provided rule.  Then
@@ -1110,8 +1112,21 @@ mkCallUDs subst f args
     mk_spec_ty tyvar ty 
        | tyvar `elemVarSet` constrained_tyvars = Just ty
        | otherwise                             = Nothing
+\end{code}
 
-------------------------------------------------------------                   
+Note [Interesting dictionary arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+        \a.\d:Eq a.  let f = ... in ...(f d)...
+There really is not much point in specialising f wrt the dictionary d,
+because the code for the specialised f is not improved at all, because
+d is lambda-bound.  We simply get junk specialisations.
+
+We re-use the function SimplUtils.interestingArg function to determine
+what sort of dictionary arguments have *some* information in them.
+
+
+\begin{code}
 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
 plusUDs (MkUD {dict_binds = db1, calls = calls1, ud_fvs = fvs1})
        (MkUD {dict_binds = db2, calls = calls2, ud_fvs = fvs2})