Make rule printing wobble less

a) When generating specialisations, include the types in the name
   of the rule, to avoid having rules with duplicate names.
   (The rule name is used to put rules in canonical order for
   fingerprinting.)

b) In Specialise and SpecConstr use a new function Rules.pprRulesForUser
   to print rules in canonical order.  This reduces unnecessary wobbling
   in test output, notably in T2486

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 0303833..66442eb 100644 (file)
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -29,7 +29,7 @@ module Rules (
        addIdSpecialisations, 
        
        -- * Misc. CoreRule helpers
-        rulesOfBinds,
+        rulesOfBinds, pprRulesForUser,
         
         lookupRule, mkLocalRule, roughTopNames
     ) where
@@ -152,6 +152,22 @@ ruleCantMatch (t       : ts) (a       : as) = ruleCantMatch ts as
 ruleCantMatch ts            as             = False
 \end{code}
 
+\begin{code}
+pprRulesForUser :: [CoreRule] -> SDoc
+-- (a) tidy the rules
+-- (b) sort them into order based on the rule name
+-- (c) suppress uniques (unless -dppr-debug is on)
+-- This combination makes the output stable so we can use in testing
+-- It's here rather than in PprCore because it calls tidyRules
+pprRulesForUser rules
+  = withPprStyle defaultUserStyle $
+    pprRules $
+    sortLe le_rule  $
+    tidyRules emptyTidyEnv rules
+  where 
+    le_rule r1 r2 = ru_name r1 <= ru_name r2
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *
@@ -168,7 +184,6 @@ mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules)
 extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
 extendSpecInfo (SpecInfo rs1 fvs1) rs2
   = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
-
 addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
 addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2) 
   = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index a52de10..7eb3529 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,7 +33,6 @@ import Var
 import VarEnv
 import VarSet
 import Name
-import Rules           ( addIdSpecialisations, mkLocalRule, rulesOfBinds )
 import OccName         ( mkSpecOcc )
 import ErrUtils                ( dumpIfSet_dyn )
 import DynFlags                ( DynFlags(..), DynFlag(..) )
@@ -463,8 +461,7 @@ specConstrProgram dflags us binds
        endPass dflags "SpecConstr" Opt_D_dump_spec binds'
 
        dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
-                 (withPprStyle defaultUserStyle $
-                  pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
+                     (pprRulesForUser (rulesOfBinds binds'))
 
        return binds'
   where

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index b424e4a..3564c27 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -28,12 +28,10 @@ import CoreSubst    ( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst,
 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(..)
@@ -588,8 +586,7 @@ specProgram dflags us binds = do
        endPass dflags "Specialise" Opt_D_dump_spec binds'
 
        dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
-                 (withPprStyle defaultUserStyle $
-                  pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
+                     (pprRulesForUser (rulesOfBinds binds'))
 
        return binds'
   where
@@ -866,7 +863,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
@@ -885,7 +884,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')