From 10f18550c3684368b9d8e5b7adcccc14994cf170 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Thu, 21 Aug 2008 12:31:00 +0000
Subject: [PATCH] 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
---
 compiler/specialise/Rules.lhs      |   19 +++++++++++++++++--
 compiler/specialise/SpecConstr.lhs |    7 ++-----
 compiler/specialise/Specialise.lhs |   15 ++++++++-------
 3 files changed, 27 insertions(+), 14 deletions(-)

diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 0303833..66442eb 100644
--- 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
--- 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
--- 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')
-- 
1.7.10.4