Add $(strip) to a Makefile test

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

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index fb4dc71..bdd9a16 100644 (file)
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -22,11 +22,10 @@ import CoreUtils
 import CoreUnfold      ( couldBeSmallEnoughToInline )
 import CoreLint                ( showPass, endPass )
 import CoreFVs                 ( exprsFreeVars )
-import CoreTidy                ( tidyRules )
-import PprCore         ( pprRules )
 import WwLib           ( mkWorkerArgs )
 import DataCon         ( dataConRepArity, dataConUnivTyVars )
 import Coercion        
+import Rules
 import Type            hiding( substTy )
 import Id              ( Id, idName, idType, isDataConWorkId_maybe, idArity,
                          mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
@@ -34,10 +33,10 @@ import Var
 import VarEnv
 import VarSet
 import Name
-import Rules           ( addIdSpecialisations, mkLocalRule, rulesOfBinds )
 import OccName         ( mkSpecOcc )
 import ErrUtils                ( dumpIfSet_dyn )
 import DynFlags                ( DynFlags(..), DynFlag(..) )
+import StaticFlags     ( opt_PprStyle_Debug )
 import StaticFlags     ( opt_SpecInlineJoinPoints )
 import BasicTypes      ( Activation(..) )
 import Maybes          ( orElse, catMaybes, isJust, isNothing )
@@ -463,7 +462,7 @@ specConstrProgram dflags us binds
        endPass dflags "SpecConstr" 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
@@ -498,9 +497,9 @@ data ScEnv = SCE { sc_size  :: Maybe Int,   -- Size threshold
 
 ---------------------
 -- As we go, we apply a substitution (sc_subst) to the current term
-type InExpr = CoreExpr         -- *Before* applying the subst
+type InExpr = CoreExpr         -- _Before_ applying the subst
 
-type OutExpr = CoreExpr                -- *After* applying the subst
+type OutExpr = CoreExpr                -- _After_ applying the subst
 type OutId   = Id
 type OutVar  = Var
 
@@ -509,7 +508,7 @@ type HowBoundEnv = VarEnv HowBound  -- Domain is OutVars
 
 ---------------------
 type ValueEnv = IdEnv Value            -- Domain is OutIds
-data Value    = ConVal AltCon [CoreArg]        -- *Saturated* constructors
+data Value    = ConVal AltCon [CoreArg]        -- _Saturated_ constructors
              | LambdaVal               -- Inlinable lambdas or PAPs
 
 instance Outputable Value where
@@ -707,7 +706,7 @@ combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
 
 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
--- *Overwrite* the occurrence info for the scrutinee, if the scrutinee 
+-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
 -- is a variable, and an interesting variable
 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
@@ -1023,14 +1022,18 @@ specialise env bind_calls (fn, arg_bndrs, body, arg_occs)
        ; let spec_count' = length pats + spec_count
        ; case sc_count env of
            Just max | spec_count' > max
-               -> pprTrace "SpecConstr: too many specialisations for one function (see -fspec-constr-count):" 
-                        (vcat [ptext (sLit "Function:") <+> ppr fn,
-                               ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])])
-                        return (nullUsage, spec_info)
+               -> WARN( True, msg ) return (nullUsage, spec_info)
+               where
+                  msg = vcat [ sep [ ptext (sLit "SpecConstr: specialisation of") <+> quotes (ppr fn)
+                                   , nest 2 (ptext (sLit "limited by bound of")) <+> int max ]
+                             , ptext (sLit "Use -fspec-constr-count=n to set the bound")
+                             , extra ]
+                  extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
+                        | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
 
-           _normal_case -> do
-                               
-       { (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
+           _normal_case -> do {
+
+         (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
                                                 (pats `zip` [spec_count..])
 
        ; let spec_usg = combineUsages spec_usgs