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
addIdSpecialisations,
-- * Misc. CoreRule helpers
addIdSpecialisations,
-- * Misc. CoreRule helpers
+ rulesOfBinds, pprRulesForUser,
lookupRule, mkLocalRule, roughTopNames
) where
lookupRule, mkLocalRule, roughTopNames
) where
ruleCantMatch ts as = False
\end{code}
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}
+
%************************************************************************
%* *
%************************************************************************
%* *
extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
extendSpecInfo (SpecInfo rs1 fvs1) rs2
= SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
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)
addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2)
= SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
import CoreUnfold ( couldBeSmallEnoughToInline )
import CoreLint ( showPass, endPass )
import CoreFVs ( exprsFreeVars )
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 WwLib ( mkWorkerArgs )
import DataCon ( dataConRepArity, dataConUnivTyVars )
import Coercion
import Type hiding( substTy )
import Id ( Id, idName, idType, isDataConWorkId_maybe, idArity,
mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
import Type hiding( substTy )
import Id ( Id, idName, idType, isDataConWorkId_maybe, idArity,
mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
import VarEnv
import VarSet
import Name
import VarEnv
import VarSet
import Name
-import Rules ( addIdSpecialisations, mkLocalRule, rulesOfBinds )
import OccName ( mkSpecOcc )
import ErrUtils ( dumpIfSet_dyn )
import DynFlags ( DynFlags(..), DynFlag(..) )
import OccName ( mkSpecOcc )
import ErrUtils ( dumpIfSet_dyn )
import DynFlags ( DynFlags(..), DynFlag(..) )
endPass dflags "SpecConstr" Opt_D_dump_spec binds'
dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
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'))
import VarSet
import VarEnv
import CoreSyn
import VarSet
import VarEnv
import CoreSyn
import CoreUtils ( applyTypeToArgs, mkPiTypes )
import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars )
import CoreUtils ( applyTypeToArgs, mkPiTypes )
import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars )
-import CoreTidy ( tidyRules )
import CoreLint ( showPass, endPass )
import CoreLint ( showPass, endPass )
-import Rules ( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds )
-import PprCore ( pprRules )
import UniqSupply ( UniqSupply,
UniqSM, initUs_,
MonadUnique(..)
import UniqSupply ( UniqSupply,
UniqSM, initUs_,
MonadUnique(..)
endPass dflags "Specialise" Opt_D_dump_spec binds'
dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
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'))
where
mk_ty_arg rhs_tyvar Nothing = Type (mkTyVarTy rhs_tyvar)
mk_ty_arg _ (Just ty) = Type ty
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
(rhs_subst', rhs_dicts') <- cloneBinders rhs_subst rhs_dicts
let
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
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')
inline_prag -- Note [Auto-specialisation and RULES]
(idName fn)
(poly_tyvars ++ rhs_dicts')