ghc/compiler/specialise/Rules.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[CoreRules]{Transformation rules}
   5
   6 \begin{code}
   7 module Rules (
   8         RuleBase, emptyRuleBase,
   9         extendRuleBaseList,
  10         ruleBaseIds, pprRuleBase, ruleCheckProgram,
  11
  12         lookupRule, addRule, addRules, addIdSpecialisations
  13     ) where
  14
  15 #include "HsVersions.h"
  16
  17 import CoreSyn          -- All of it
  18 import OccurAnal        ( occurAnalyseRule )
  19 import CoreFVs          ( exprFreeVars, exprsFreeVars, ruleRhsFreeVars )
  20 import CoreUnfold       ( isCheapUnfolding, unfoldingTemplate )
  21 import CoreUtils        ( tcEqExprX )
  22 import Type             ( Type )
  23 import CoreTidy         ( pprTidyIdRules )
  24 import Id               ( Id, idUnfolding, isLocalId, idSpecialisation, setIdSpecialisation )
  25 import Var              ( Var )
  26 import VarSet
  27 import VarEnv
  28 import Unify            ( tcMatchTyX, MatchEnv(..) )
  29 import BasicTypes       ( Activation, CompilerPhase, isActive )
  30
  31 import Outputable
  32 import FastString
  33 import Maybe            ( isJust, fromMaybe )
  34 import Bag
  35 import List             ( isPrefixOf )
  36 \end{code}
  37
  38
  39 %************************************************************************
  40 %*                                                                      *
  41 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 A @CoreRule@ holds details of one rule for an @Id@, which
  46 includes its specialisations.
  47
  48 For example, if a rule for @f@ contains the mapping:
  49 \begin{verbatim}
  50         forall a b d. [Type (List a), Type b, Var d]  ===>  f' a b
  51 \end{verbatim}
  52 then when we find an application of f to matching types, we simply replace
  53 it by the matching RHS:
  54 \begin{verbatim}
  55         f (List Int) Bool dict ===>  f' Int Bool
  56 \end{verbatim}
  57 All the stuff about how many dictionaries to discard, and what types
  58 to apply the specialised function to, are handled by the fact that the
  59 Rule contains a template for the result of the specialisation.
  60
  61 There is one more exciting case, which is dealt with in exactly the same
  62 way.  If the specialised value is unboxed then it is lifted at its
  63 definition site and unlifted at its uses.  For example:
  64
  65         pi :: forall a. Num a => a
  66
  67 might have a specialisation
  68
  69         [Int#] ===>  (case pi' of Lift pi# -> pi#)
  70
  71 where pi' :: Lift Int# is the specialised version of pi.
  72
  73
  74 %************************************************************************
  75 %*                                                                      *
  76 \subsection{Matching}
  77 %*                                                                      *
  78 %************************************************************************
  79
  80 \begin{code}
  81 matchRules :: (Activation -> Bool) -> InScopeSet
  82            -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
  83 -- See comments on matchRule
  84 matchRules is_active in_scope [] args = Nothing
  85 matchRules is_active in_scope (rule:rules) args
  86   = case matchRule is_active in_scope rule args of
  87         Just result -> Just result
  88         Nothing     -> matchRules is_active in_scope rules args
  89
  90 noBlackList :: Activation -> Bool
  91 noBlackList act = False         -- Nothing is black listed
  92
  93 matchRule :: (Activation -> Bool) -> InScopeSet
  94           -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
  95
  96 -- If (matchRule rule args) returns Just (name,rhs)
  97 -- then (f args) matches the rule, and the corresponding
  98 -- rewritten RHS is rhs
  99 --
 100 -- The bndrs and rhs is occurrence-analysed
 101 --
 102 --      Example
 103 --
 104 -- The rule
 105 --      forall f g x. map f (map g x) ==> map (f . g) x
 106 -- is stored
 107 --      CoreRule "map/map"
 108 --               [f,g,x]                -- tpl_vars
 109 --               [f,map g x]            -- tpl_args
 110 --               map (f.g) x)           -- rhs
 111 --
 112 -- Then the call: matchRule the_rule [e1,map e2 e3]
 113 --        = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
 114 --
 115 -- Any 'surplus' arguments in the input are simply put on the end
 116 -- of the output.
 117
 118 matchRule is_active in_scope rule@(BuiltinRule name match_fn) args
 119   = case match_fn args of
 120         Just expr -> Just (name,expr)
 121         Nothing   -> Nothing
 122
 123 matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args
 124   | not (is_active act)
 125   = Nothing
 126   | otherwise
 127   = case matchN in_scope tpl_vars tpl_args args of
 128         Just (tpl_vals, leftovers) -> Just (rn, mkLams tpl_vars rhs `mkApps` tpl_vals `mkApps` leftovers)
 129         Nothing                    -> Nothing
 130 \end{code}
 131
 132 \begin{code}
 133 matchN  :: InScopeSet
 134         -> [Var]                -- Template tyvars
 135         -> [CoreExpr]           -- Template
 136         -> [CoreExpr]           -- Target; can have more elts than template
 137         -> Maybe ([CoreExpr],   -- What is substituted for each template var
 138                   [CoreExpr])   -- Leftover target exprs
 139
 140 matchN in_scope tmpl_vars tmpl_es target_es
 141   = do  { (subst, leftover_es) <- go init_menv emptySubstEnv tmpl_es target_es
 142         ; return (map (lookup_tmpl subst) tmpl_vars, leftover_es) }
 143   where
 144     init_menv = ME { me_tmpls = mkVarSet tmpl_vars, me_env = init_rn_env }
 145     init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars)
 146
 147     go menv subst []     es     = Just (subst, es)
 148     go menv subst ts     []     = Nothing       -- Fail if too few actual args
 149     go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
 150                                      ; go menv subst1 ts es }
 151
 152     lookup_tmpl :: (TvSubstEnv, IdSubstEnv) -> Var -> CoreExpr
 153     lookup_tmpl (tv_subst, id_subst) tmpl_var
 154         | isTyVar tmpl_var = case lookupVarEnv tv_subst tmpl_var of
 155                                 Just ty         -> Type ty
 156                                 Nothing         -> unbound tmpl_var
 157         | otherwise        = case lookupVarEnv id_subst tmpl_var of
 158                                 Just e -> e
 159                                 other  -> unbound tmpl_var
 160
 161     unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var)
 162 \end{code}
 163
 164
 165         ---------------------------------------------
 166                 The inner workings of matching
 167         ---------------------------------------------
 168
 169 \begin{code}
 170 -- These two definitions are not the same as in Subst,
 171 -- but they simple and direct, and purely local to this module
 172 -- The third, for TvSubstEnv, is the same as in VarEnv, but repeated here
 173 -- for uniformity with IdSubstEnv
 174 type SubstEnv   = (TvSubstEnv, IdSubstEnv)
 175 type IdSubstEnv = IdEnv    CoreExpr
 176 type TvSubstEnv = TyVarEnv Type
 177
 178 emptySubstEnv :: SubstEnv
 179 emptySubstEnv = (emptyVarEnv, emptyVarEnv)
 180
 181
 182 --      At one stage I tried to match even if there are more
 183 --      template args than real args.
 184
 185 --      I now think this is probably a bad idea.
 186 --      Should the template (map f xs) match (map g)?  I think not.
 187 --      For a start, in general eta expansion wastes work.
 188 --      SLPJ July 99
 189
 190
 191 match :: MatchEnv
 192       -> SubstEnv
 193       -> CoreExpr               -- Template
 194       -> CoreExpr               -- Target
 195       -> Maybe SubstEnv
 196
 197 -- See the notes with Unify.match, which matches types
 198 -- Everything is very similar for terms
 199
 200 -- Interesting examples:
 201 -- Consider matching
 202 --      \x->f      against    \f->f
 203 -- When we meet the lambdas we must remember to rename f to f' in the
 204 -- second expresion.  The RnEnv2 does that.
 205 --
 206 -- Consider matching
 207 --      forall a. \b->b    against   \a->3
 208 -- We must rename the \a.  Otherwise when we meet the lambdas we
 209 -- might substitute [a/b] in the template, and then erroneously
 210 -- succeed in matching what looks like the template variable 'a' against 3.
 211
 212 -- The Var case follows closely what happens in Unify.match
 213 match menv subst@(tv_subst, id_subst) (Var v1) e2
 214   | v1 `elemVarSet` me_tmpls menv
 215   = case lookupVarEnv id_subst v1' of
 216         Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
 217                 -> Nothing      -- Occurs check failure
 218                 -- e.g. match forall a. (\x-> a x) against (\y. y y)
 219
 220                 | otherwise
 221                 -> Just (tv_subst, extendVarEnv id_subst v1 e2)
 222
 223         Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2
 224                  -> Just subst
 225
 226         other -> Nothing
 227
 228   | otherwise   -- v1 is not a template variable
 229   = case e2 of
 230         Var v2 | v1' == rnOccR rn_env v2 -> Just subst
 231         other                            -> Nothing
 232   where
 233     rn_env = me_env menv
 234     v1'    = rnOccL rn_env v1
 235
 236 -- Here is another important rule: if the term being matched is a
 237 -- variable, we expand it so long as its unfolding is a WHNF
 238 -- (Its occurrence information is not necessarily up to date,
 239 --  so we don't use it.)
 240 match menv subst e1 (Var v2)
 241   | isCheapUnfolding unfolding
 242   = match menv subst e1 (unfoldingTemplate unfolding)
 243   where
 244     unfolding = idUnfolding v2
 245
 246 match menv subst (Lit lit1) (Lit lit2)
 247   | lit1 == lit2
 248   = Just subst
 249
 250 match menv subst (App f1 a1) (App f2 a2)
 251   = do  { subst' <- match menv subst f1 f2
 252         ; match menv subst' a1 a2 }
 253
 254 match menv subst (Lam x1 e1) (Lam x2 e2)
 255   = match menv' subst e1 e2
 256   where
 257     menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
 258
 259 -- This rule does eta expansion
 260 --              (\x.M)  ~  N    iff     M  ~  N x
 261 match menv subst (Lam x1 e1) e2
 262   = match menv' subst e1 (App e2 (varToCoreExpr new_x))
 263   where
 264     (rn_env', new_x) = rnBndrL (me_env menv) x1
 265     menv' = menv { me_env = rn_env' }
 266
 267 -- Eta expansion the other way
 268 --      M  ~  (\y.N)    iff   M y     ~  N
 269 match menv subst e1 (Lam x2 e2)
 270   = match menv' subst (App e1 (varToCoreExpr new_x)) e2
 271   where
 272     (rn_env', new_x) = rnBndrR (me_env menv) x2
 273     menv' = menv { me_env = rn_env' }
 274
 275 match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
 276   = do  { subst1 <- match_ty menv subst ty1 ty2
 277         ; subst2 <- match menv subst1 e1 e2
 278         ; let menv' = menv { me_env = rnBndr2 (me_env menv) x2 x2 }
 279         ; match_alts menv' subst2 alts1 alts2   -- Alts are both sorted
 280         }
 281
 282 match menv subst (Type ty1) (Type ty2)
 283   = match_ty menv subst ty1 ty2
 284
 285 match menv subst (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
 286   = do  { subst1 <- match_ty menv subst  to1   to2
 287         ; subst2 <- match_ty menv subst1 from1 from2
 288         ; match menv subst2 e1 e2 }
 289
 290 -- This is an interesting rule: we simply ignore lets in the
 291 -- term being matched against!  The unfolding inside it is (by assumption)
 292 -- already inside any occurrences of the bound variables, so we'll expand
 293 -- them when we encounter them.
 294 match menv subst e1 (Let (NonRec x2 r2) e2)
 295   = match menv' subst e1 e2
 296   where
 297     menv' = menv { me_env = fst (rnBndrR (me_env menv) x2) }
 298         -- It's important to do this renaming. For example:
 299         -- Matching
 300         --      forall f,x,xs. f (x:xs)
 301         --   against
 302         --      f (let y = e in (y:[]))
 303         -- We must not get success with x->y!  Instead, we
 304         -- need an occurs check.
 305
 306 -- Everything else fails
 307 match menv subst e1 e2 = Nothing
 308
 309 ------------------------------------------
 310 match_alts :: MatchEnv
 311       -> SubstEnv
 312       -> [CoreAlt]              -- Template
 313       -> [CoreAlt]              -- Target
 314       -> Maybe SubstEnv
 315 match_alts menv subst [] []
 316   = return subst
 317 match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
 318   | c1 == c2
 319   = do  { subst1 <- match menv' subst r1 r2
 320         ; match_alts menv subst1 alts1 alts2 }
 321   where
 322     menv' :: MatchEnv
 323     menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 }
 324
 325 match_alts menv subst alts1 alts2
 326   = Nothing
 327 \end{code}
 328
 329 Matching Core types: use the matcher in TcType.
 330 Notice that we treat newtypes as opaque.  For example, suppose
 331 we have a specialised version of a function at a newtype, say
 332         newtype T = MkT Int
 333 We only want to replace (f T) with f', not (f Int).
 334
 335 \begin{code}
 336 ------------------------------------------
 337 match_ty menv (tv_subst, id_subst) ty1 ty2
 338   = do  { tv_subst' <- Unify.tcMatchTyX menv tv_subst ty1 ty2
 339         ; return (tv_subst', id_subst) }
 340 \end{code}
 341
 342
 343 %************************************************************************
 344 %*                                                                      *
 345 \subsection{Adding a new rule}
 346 %*                                                                      *
 347 %************************************************************************
 348
 349 \begin{code}
 350 addRules :: Id -> CoreRules -> [CoreRule] -> CoreRules
 351 addRule  :: Id -> CoreRules -> CoreRule -> CoreRules
 352
 353 -- Add a new rule to an existing bunch of rules.
 354 -- The rules are for the given Id; the Id argument is needed only
 355 -- so that we can exclude the Id from its own RHS free-var set
 356
 357 -- Insert the new rule just before a rule that is *less specific*
 358 -- than the new one; or at the end if there isn't such a one.
 359 -- In this way we make sure that when looking up, the first match
 360 -- is the most specific.
 361 --
 362 -- We make no check for rules that unify without one dominating
 363 -- the other.   Arguably this would be a bug.
 364
 365 addRules id rules rule_list = foldl (addRule id) rules rule_list
 366
 367 addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _)
 368   = Rules (rule:rules) rhs_fvs
 369         -- Put it at the start for lack of anything better
 370
 371 addRule id (Rules rules rhs_fvs) rule
 372   = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
 373   where
 374     new_rule    = occurAnalyseRule rule
 375     new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id
 376         -- Hack alert!
 377         -- Don't include the Id in its own rhs free-var set.
 378         -- Otherwise the occurrence analyser makes bindings recursive
 379         -- that shoudn't be.  E.g.
 380         --      RULE:  f (f x y) z  ==>  f x (f y z)
 381
 382 insertRule rules new_rule@(Rule _ _ tpl_vars tpl_args _)
 383   = go rules
 384   where
 385     tpl_var_set = mkInScopeSet (mkVarSet tpl_vars)
 386         -- Actually we should probably include the free vars of tpl_args,
 387         -- but I can't be bothered
 388
 389     go []                                       = [new_rule]
 390     go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
 391                     | otherwise                 = rule : go rules
 392
 393     new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args)
 394
 395 addIdSpecialisations :: Id -> [CoreRule] -> Id
 396 addIdSpecialisations id rules
 397   = setIdSpecialisation id new_specs
 398   where
 399     new_specs = addRules id (idSpecialisation id) rules
 400 \end{code}
 401
 402
 403 %************************************************************************
 404 %*                                                                      *
 405 \subsection{Looking up a rule}
 406 %*                                                                      *
 407 %************************************************************************
 408
 409 \begin{code}
 410 lookupRule :: (Activation -> Bool)
 411            -> InScopeSet
 412            -> RuleBase          -- Ids from other modules
 413            -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
 414 lookupRule is_active in_scope rules fn args
 415   = case idSpecialisation fn' of
 416         Rules rules _ -> matchRules is_active in_scope rules args
 417   where
 418     fn' | isLocalId fn                                       = fn
 419         | Just ext_fn <- lookupVarSet (ruleBaseIds rules) fn = ext_fn
 420         | otherwise                                          = fn
 421 \end{code}
 422
 423
 424 %************************************************************************
 425 %*                                                                      *
 426 \subsection{Checking a program for failing rule applications}
 427 %*                                                                      *
 428 %************************************************************************
 429
 430 -----------------------------------------------------
 431                         Game plan
 432 -----------------------------------------------------
 433
 434 We want to know what sites have rules that could have fired but didn't.
 435 This pass runs over the tree (without changing it) and reports such.
 436
 437 NB: we assume that this follows a run of the simplifier, so every Id
 438 occurrence (including occurrences of imported Ids) is decorated with
 439 all its (active) rules.  No need to construct a rule base or anything
 440 like that.
 441
 442 \begin{code}
 443 ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc
 444 -- Report partial matches for rules beginning
 445 -- with the specified string
 446 ruleCheckProgram phase rule_pat binds
 447   | isEmptyBag results
 448   = text "Rule check results: no rule application sites"
 449   | otherwise
 450   = vcat [text "Rule check results:",
 451           line,
 452           vcat [ p $$ line | p <- bagToList results ]
 453          ]
 454   where
 455     results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
 456     line = text (replicate 20 '-')
 457
 458 type RuleCheckEnv = (CompilerPhase, String)     -- Phase and Pattern
 459
 460 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
 461    -- The Bag returned has one SDoc for each call site found
 462 ruleCheckBind env (NonRec b r) = ruleCheck env r
 463 ruleCheckBind env (Rec prs)    = unionManyBags [ruleCheck env r | (b,r) <- prs]
 464
 465 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
 466 ruleCheck env (Var v)       = emptyBag
 467 ruleCheck env (Lit l)       = emptyBag
 468 ruleCheck env (Type ty)     = emptyBag
 469 ruleCheck env (App f a)     = ruleCheckApp env (App f a) []
 470 ruleCheck env (Note n e)    = ruleCheck env e
 471 ruleCheck env (Let bd e)    = ruleCheckBind env bd `unionBags` ruleCheck env e
 472 ruleCheck env (Lam b e)     = ruleCheck env e
 473 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
 474                                 unionManyBags [ruleCheck env r | (_,_,r) <- as]
 475
 476 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
 477 ruleCheckApp env (Var f) as   = ruleCheckFun env f as
 478 ruleCheckApp env other as     = ruleCheck env other
 479 \end{code}
 480
 481 \begin{code}
 482 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
 483 -- Produce a report for all rules matching the predicate
 484 -- saying why it doesn't match the specified application
 485
 486 ruleCheckFun (phase, pat) fn args
 487   | null name_match_rules = emptyBag
 488   | otherwise             = unitBag (ruleAppCheck_help phase fn args name_match_rules)
 489   where
 490     name_match_rules = case idSpecialisation fn of
 491                           Rules rules _ -> filter match rules
 492     match rule = pat `isPrefixOf` unpackFS (ruleName rule)
 493
 494 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
 495 ruleAppCheck_help phase fn args rules
 496   =     -- The rules match the pattern, so we want to print something
 497     vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
 498           vcat (map check_rule rules)]
 499   where
 500     n_args = length args
 501     i_args = args `zip` [1::Int ..]
 502
 503     check_rule rule = rule_herald rule <> colon <+> rule_info rule
 504
 505     rule_herald (BuiltinRule name _) =
 506         ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
 507     rule_herald (Rule name _ _ _ _)  =
 508         ptext SLIT("Rule") <+> doubleQuotes (ftext name)
 509
 510     rule_info rule
 511         | Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args
 512         = text "matches (which is very peculiar!)"
 513
 514     rule_info (BuiltinRule name fn) = text "does not match"
 515
 516     rule_info (Rule name act rule_bndrs rule_args _)
 517         | not (isActive phase act)    = text "active only in later phase"
 518         | n_args < n_rule_args        = text "too few arguments"
 519         | n_mismatches == n_rule_args = text "no arguments match"
 520         | n_mismatches == 0           = text "all arguments match (considered individually), but rule as a whole does not"
 521         | otherwise                   = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
 522         where
 523           n_rule_args  = length rule_args
 524           n_mismatches = length mismatches
 525           mismatches   = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
 526                               not (isJust (match_fn rule_arg arg))]
 527
 528           lhs_fvs = exprsFreeVars rule_args     -- Includes template tyvars
 529           match_fn rule_arg arg = match menv emptySubstEnv rule_arg arg
 530                 where
 531                   in_scope = lhs_fvs `unionVarSet` exprFreeVars arg
 532                   menv = ME { me_env   = mkRnEnv2 (mkInScopeSet in_scope)
 533                             , me_tmpls = mkVarSet rule_bndrs }
 534 \end{code}
 535
 536
 537 %************************************************************************
 538 %*                                                                      *
 539 \subsection{Getting the rules ready}
 540 %*                                                                      *
 541 %************************************************************************
 542
 543 \begin{code}
 544 data RuleBase = RuleBase
 545                     IdSet       -- Ids with their rules in their specialisations
 546                                 -- Held as a set, so that it can simply be the initial
 547                                 -- in-scope set in the simplifier
 548         -- This representation is a bit cute, and I wonder if we should
 549         -- change it to use (IdEnv CoreRule) which seems a bit more natural
 550
 551 ruleBaseIds (RuleBase ids) = ids
 552 emptyRuleBase = RuleBase emptyVarSet
 553
 554 extendRuleBaseList :: RuleBase -> [IdCoreRule] -> RuleBase
 555 extendRuleBaseList rule_base new_guys
 556   = foldl extendRuleBase rule_base new_guys
 557
 558 extendRuleBase :: RuleBase -> IdCoreRule -> RuleBase
 559 extendRuleBase (RuleBase rule_ids) (IdCoreRule id _ rule)
 560   = RuleBase (extendVarSet rule_ids new_id)
 561   where
 562     new_id    = setIdSpecialisation id (addRule id old_rules rule)
 563     old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id))
 564         -- Get the old rules from rule_ids if the Id is already there, but
 565         -- if not, use the Id from the incoming rule.  If may be a PrimOpId,
 566         -- in which case it may have rules in its belly already.  Seems
 567         -- dreadfully hackoid.
 568
 569 pprRuleBase :: RuleBase -> SDoc
 570 pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]
 571 \end{code}