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         extendRuleBase, extendRuleBaseList, addRuleBaseFVs,
  10         ruleBaseIds, ruleBaseFVs,
  11         pprRuleBase, ruleCheckProgram,
  12
  13         lookupRule, addRule, addIdSpecialisations
  14     ) where
  15
  16 #include "HsVersions.h"
  17
  18 import CoreSyn          -- All of it
  19 import OccurAnal        ( occurAnalyseRule )
  20 import CoreFVs          ( exprFreeVars, ruleRhsFreeVars, ruleLhsFreeIds )
  21 import CoreUnfold       ( isCheapUnfolding, unfoldingTemplate )
  22 import CoreUtils        ( eqExpr )
  23 import PprCore          ( pprCoreRule )
  24 import Subst            ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
  25                           substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet,
  26                           bindSubstList, unBindSubstList, substInScope, uniqAway
  27                         )
  28 import Id               ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
  29 import Var              ( isId )
  30 import VarSet
  31 import VarEnv
  32 import TcType           ( mkTyVarTy )
  33 import qualified TcType ( match )
  34
  35 import Outputable
  36 import Maybe            ( isJust, isNothing, fromMaybe )
  37 import Util             ( sortLt )
  38 import Bag
  39 import List             ( isPrefixOf )
  40 \end{code}
  41
  42
  43 %************************************************************************
  44 %*                                                                      *
  45 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
  46 %*                                                                      *
  47 %************************************************************************
  48
  49 A @CoreRule@ holds details of one rule for an @Id@, which
  50 includes its specialisations.
  51
  52 For example, if a rule for @f@ contains the mapping:
  53 \begin{verbatim}
  54         forall a b d. [Type (List a), Type b, Var d]  ===>  f' a b
  55 \end{verbatim}
  56 then when we find an application of f to matching types, we simply replace
  57 it by the matching RHS:
  58 \begin{verbatim}
  59         f (List Int) Bool dict ===>  f' Int Bool
  60 \end{verbatim}
  61 All the stuff about how many dictionaries to discard, and what types
  62 to apply the specialised function to, are handled by the fact that the
  63 Rule contains a template for the result of the specialisation.
  64
  65 There is one more exciting case, which is dealt with in exactly the same
  66 way.  If the specialised value is unboxed then it is lifted at its
  67 definition site and unlifted at its uses.  For example:
  68
  69         pi :: forall a. Num a => a
  70
  71 might have a specialisation
  72
  73         [Int#] ===>  (case pi' of Lift pi# -> pi#)
  74
  75 where pi' :: Lift Int# is the specialised version of pi.
  76
  77
  78 %************************************************************************
  79 %*                                                                      *
  80 \subsection{Matching}
  81 %*                                                                      *
  82 %************************************************************************
  83
  84 \begin{code}
  85 matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
  86 -- See comments on matchRule
  87 matchRules in_scope [] args = Nothing
  88 matchRules in_scope (rule:rules) args
  89   = case matchRule in_scope rule args of
  90         Just result -> Just result
  91         Nothing     -> matchRules in_scope rules args
  92
  93
  94 matchRule :: InScopeSet -> 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 -- ASSUMPTION (A):
 119 --      A1. No top-level variable is bound in the target
 120 --      A2. No template variable  is bound in the target
 121 --      A3. No lambda bound template variable is free in any subexpression of the target
 122 --
 123 -- To see why A1 is necessary, consider matching
 124 --      \x->f      against    \f->f
 125 -- When we meet the lambdas we substitute [f/x] in the template (a no-op),
 126 -- and then erroneously succeed in matching f against f.
 127 --
 128 -- To see why A2 is needed consider matching
 129 --      forall a. \b->b    against   \a->3
 130 -- When we meet the lambdas we substitute [a/b] in the template, and then
 131 -- erroneously succeed in matching what looks like the template variable 'a' against 3.
 132 --
 133 -- A3 is needed to validate the rule that says
 134 --      (\x->E) matches F
 135 -- if
 136 --      (\x->E) matches (\x->F x)
 137
 138
 139 matchRule in_scope rule@(BuiltinRule name match_fn) args
 140   = case match_fn args of
 141         Just expr -> Just (name,expr)
 142         Nothing   -> Nothing
 143
 144 matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args
 145   = go tpl_args args emptySubst
 146         -- We used to use the in_scope set, but I don't think that's necessary
 147         -- After all, the result is going to be simplified again with that in_scope set
 148  where
 149    tpl_var_set = mkVarSet tpl_vars
 150
 151    -----------------------
 152         -- Do the business
 153    go (tpl_arg:tpl_args) (arg:args) subst = match tpl_arg arg tpl_var_set (go tpl_args args) subst
 154
 155         -- Two easy ways to terminate
 156    go [] []         subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars)
 157    go [] args       subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars `mkApps` args)
 158
 159         -- One tiresome way to terminate: check for excess unmatched
 160         -- template arguments
 161    go tpl_args []   subst = Nothing     -- Failure
 162
 163
 164    -----------------------
 165    app_match subst fn vs = foldl go fn vs
 166         where
 167           senv    = substEnv subst
 168           go fn v = case lookupSubstEnv senv v of
 169                         Just (DoneEx ex)  -> fn `App` ex
 170                         Just (DoneTy ty)  -> fn `App` Type ty
 171                         -- Substitution should bind them all!
 172
 173
 174    -----------------------
 175 {-      The code below tries to match even if there are more
 176         template args than real args.
 177
 178         I now think this is probably a bad idea.
 179         Should the template (map f xs) match (map g)?  I think not.
 180         For a start, in general eta expansion wastes work.
 181         SLPJ July 99
 182
 183       = case eta_complete tpl_args (mkVarSet leftovers) of
 184             Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs),
 185                                      mk_result_args subst done)
 186             Nothing         -> Nothing  -- Failure
 187       where
 188         (done, leftovers) = partition (\v -> isJust (lookupSubstEnv subst_env v))
 189                                       (map zapOccInfo tpl_vars)
 190                 -- Zap the occ info
 191         subst_env = substEnv subst
 192
 193    -----------------------
 194    eta_complete [] vars = ASSERT( isEmptyVarSet vars )
 195                           Just []
 196    eta_complete (Type ty:tpl_args) vars
 197         = case getTyVar_maybe ty of
 198                 Just tv |  tv `elemVarSet` vars
 199                         -> case eta_complete tpl_args (vars `delVarSet` tv) of
 200                                 Just vars' -> Just (tv:vars')
 201                                 Nothing    -> Nothing
 202                 other   -> Nothing
 203
 204    eta_complete (Var v:tpl_args) vars
 205         | v `elemVarSet` vars
 206         = case eta_complete tpl_args (vars `delVarSet` v) of
 207                 Just vars' -> Just (v:vars')
 208                 Nothing    -> Nothing
 209
 210    eta_complete other vars = Nothing
 211
 212
 213 zapOccInfo bndr | isTyVar bndr = bndr
 214                 | otherwise    = zapLamIdInfo bndr
 215 -}
 216 \end{code}
 217
 218 \begin{code}
 219 type Matcher result =  VarSet                   -- Template variables
 220                     -> (Subst -> Maybe result)  -- Continuation if success
 221                     -> Subst  -> Maybe result   -- Substitution so far -> result
 222 -- The *SubstEnv* in these Substs apply to the TEMPLATE only
 223
 224 -- The *InScopeSet* in these Substs gives variables bound so far in the
 225 --      target term.  So when matching forall a. (\x. a x) against (\y. y y)
 226 --      while processing the body of the lambdas, the in-scope set will be {y}.
 227 --      That lets us do the occurs-check when matching 'a' against 'y'
 228
 229 match :: CoreExpr               -- Template
 230       -> CoreExpr               -- Target
 231       -> Matcher result
 232
 233 match_fail = Nothing
 234
 235 match (Var v1) e2 tpl_vars kont subst
 236   = case lookupSubst subst v1 of
 237         Nothing | v1 `elemVarSet` tpl_vars      -- v1 is a template variable
 238                 -> if (any (`isInScope` subst) (varSetElems (exprFreeVars e2))) then
 239                          match_fail             -- Occurs check failure
 240                                                 -- e.g. match forall a. (\x-> a x) against (\y. y y)
 241                    else
 242                          kont (extendSubst subst v1 (DoneEx e2))
 243
 244
 245                 | eqExpr (Var v1) e2       -> kont subst
 246                         -- v1 is not a template variable, so it must be a global constant
 247
 248         Just (DoneEx e2')  | eqExpr e2' e2 -> kont subst
 249
 250         other -> match_fail
 251
 252 match (Lit lit1) (Lit lit2) tpl_vars kont subst
 253   | lit1 == lit2
 254   = kont subst
 255
 256 match (App f1 a1) (App f2 a2) tpl_vars kont subst
 257   = match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst
 258
 259 match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
 260   = bind [x1] [x2] (match e1 e2) tpl_vars kont subst
 261
 262 -- This rule does eta expansion
 263 --              (\x.M)  ~  N    iff     M  ~  N x
 264 -- See assumption A3
 265 match (Lam x1 e1) e2 tpl_vars kont subst
 266   = bind [x1] [x1] (match e1 (App e2 (mkVarArg x1))) tpl_vars kont subst
 267
 268 -- Eta expansion the other way
 269 --      M  ~  (\y.N)    iff   \y.M y  ~  \y.N
 270 --                      iff   M y     ~  N
 271 -- Remembering that by (A), y can't be free in M, we get this
 272 match e1 (Lam x2 e2) tpl_vars kont subst
 273   = bind [new_id] [x2] (match (App e1 (mkVarArg new_id)) e2) tpl_vars kont subst
 274   where
 275     new_id = uniqAway (substInScope subst) x2
 276         -- This uniqAway is actually needed.  Here's the example:
 277         --  rule:       foldr (mapFB (:) f) [] = mapList
 278         --  target:     foldr (\x. mapFB k f x) []
 279         --            where
 280         --              k = \x. mapFB ... x
 281         -- The first \x is ok, but when we inline k, hoping it might
 282         -- match (:) we find a second \x.
 283
 284 match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
 285   = match e1 e2 tpl_vars case_kont subst
 286   where
 287     case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLt lt_alt alts2))
 288                                      tpl_vars kont subst
 289
 290 match (Type ty1) (Type ty2) tpl_vars kont subst
 291   = match_ty ty1 ty2 tpl_vars kont subst
 292
 293 match (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
 294       tpl_vars kont subst
 295   = (match_ty to1   to2   tpl_vars $
 296      match_ty from1 from2 tpl_vars $
 297      match e1 e2 tpl_vars kont) subst
 298
 299
 300 {-      I don't buy this let-rule any more
 301         The let rule fails on matching
 302                 forall f,x,xs. f (x:xs)
 303         against
 304                 f (let y = e in (y:[]))
 305         because we just get x->y, which is bogus.
 306
 307 -- This is an interesting rule: we simply ignore lets in the
 308 -- term being matched against!  The unfolding inside it is (by assumption)
 309 -- already inside any occurrences of the bound variables, so we'll expand
 310 -- them when we encounter them.  Meanwhile, we can't get false matches because
 311 -- (also by assumption) the term being matched has no shadowing.
 312 match e1 (Let bind e2) tpl_vars kont subst
 313   = match e1 e2 tpl_vars kont subst
 314 -}
 315
 316 -- Here is another important rule: if the term being matched is a
 317 -- variable, we expand it so long as its unfolding is a WHNF
 318 -- (Its occurrence information is not necessarily up to date,
 319 --  so we don't use it.)
 320 match e1 (Var v2) tpl_vars kont subst
 321   | isCheapUnfolding unfolding
 322   = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst
 323   where
 324     unfolding = idUnfolding v2
 325
 326
 327 -- We can't cope with lets in the template
 328
 329 match e1 e2 tpl_vars kont subst = match_fail
 330
 331
 332 ------------------------------------------
 333 match_alts [] [] tpl_vars kont subst
 334   = kont subst
 335 match_alts ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) tpl_vars kont subst
 336   | c1 == c2
 337   = bind vs1 vs2 (match r1 r2) tpl_vars
 338                  (match_alts alts1 alts2 tpl_vars kont)
 339                  subst
 340 match_alts alts1 alts2 tpl_vars kont subst = match_fail
 341
 342 lt_alt (con1, _, _) (con2, _, _) = con1 < con2
 343
 344 ----------------------------------------
 345 bind :: [CoreBndr]      -- Template binders
 346      -> [CoreBndr]      -- Target binders
 347      -> Matcher result
 348      -> Matcher result
 349 -- This makes uses of assumption (A) above.  For example,
 350 -- this would fail:
 351 --      Template: (\x.y)        (y is free)
 352 --      Target  : (\y.y)        (y is bound)
 353 -- We rename x to y in the template... but then erroneously
 354 -- match y against y.  But this can't happen because of (A)
 355 bind vs1 vs2 matcher tpl_vars kont subst
 356   = WARN( not (all not_in_subst vs1), bug_msg )
 357     matcher tpl_vars kont' subst'
 358   where
 359     kont' subst'' = kont (unBindSubstList subst'' vs1 vs2)
 360     subst'        = bindSubstList subst vs1 vs2
 361
 362         -- The unBindSubst relies on no shadowing in the template
 363     not_in_subst v = isNothing (lookupSubst subst v)
 364     bug_msg = sep [ppr vs1, ppr vs2]
 365
 366 ----------------------------------------
 367 matches [] [] tpl_vars kont subst
 368   = kont subst
 369 matches (e:es) (e':es') tpl_vars kont subst
 370   = match e e' tpl_vars (matches es es' tpl_vars kont) subst
 371 matches es es' tpl_vars kont subst
 372   = match_fail
 373
 374 ----------------------------------------
 375 mkVarArg :: CoreBndr -> CoreArg
 376 mkVarArg v | isId v    = Var v
 377            | otherwise = Type (mkTyVarTy v)
 378 \end{code}
 379
 380 Matching Core types: use the matcher in TcType.
 381 Notice that we treat newtypes as opaque.  For example, suppose
 382 we have a specialised version of a function at a newtype, say
 383         newtype T = MkT Int
 384 We only want to replace (f T) with f', not (f Int).
 385
 386 \begin{code}
 387 ----------------------------------------
 388 match_ty ty1 ty2 tpl_vars kont subst
 389   = TcType.match ty1 ty2 tpl_vars kont' (substEnv subst)
 390   where
 391     kont' senv = kont (setSubstEnv subst senv)
 392 \end{code}
 393
 394
 395
 396 %************************************************************************
 397 %*                                                                      *
 398 \subsection{Adding a new rule}
 399 %*                                                                      *
 400 %************************************************************************
 401
 402 \begin{code}
 403 addRule :: Id -> CoreRules -> CoreRule -> CoreRules
 404
 405 -- Add a new rule to an existing bunch of rules.
 406 -- The rules are for the given Id; the Id argument is needed only
 407 -- so that we can exclude the Id from its own RHS free-var set
 408
 409 -- Insert the new rule just before a rule that is *less specific*
 410 -- than the new one; or at the end if there isn't such a one.
 411 -- In this way we make sure that when looking up, the first match
 412 -- is the most specific.
 413 --
 414 -- We make no check for rules that unify without one dominating
 415 -- the other.   Arguably this would be a bug.
 416
 417 addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _)
 418   = Rules (rule:rules) rhs_fvs
 419         -- Put it at the start for lack of anything better
 420
 421 addRule id (Rules rules rhs_fvs) rule
 422   = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
 423   where
 424     new_rule    = occurAnalyseRule rule
 425     new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id
 426         -- Hack alert!
 427         -- Don't include the Id in its own rhs free-var set.
 428         -- Otherwise the occurrence analyser makes bindings recursive
 429         -- that shoudn't be.  E.g.
 430         --      RULE:  f (f x y) z  ==>  f x (f y z)
 431
 432 insertRule rules new_rule@(Rule _ tpl_vars tpl_args _)
 433   = go rules
 434   where
 435     tpl_var_set = mkInScopeSet (mkVarSet tpl_vars)
 436         -- Actually we should probably include the free vars of tpl_args,
 437         -- but I can't be bothered
 438
 439     go []                                       = [new_rule]
 440     go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
 441                     | otherwise                 = rule : go rules
 442
 443     new_is_more_specific rule = isJust (matchRule tpl_var_set rule tpl_args)
 444
 445 addIdSpecialisations :: Id -> [CoreRule] -> Id
 446 addIdSpecialisations id rules
 447   = setIdSpecialisation id new_specs
 448   where
 449     new_specs = foldl (addRule id) (idSpecialisation id) rules
 450 \end{code}
 451
 452
 453 %************************************************************************
 454 %*                                                                      *
 455 \subsection{Looking up a rule}
 456 %*                                                                      *
 457 %************************************************************************
 458
 459 \begin{code}
 460 lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
 461 lookupRule in_scope fn args
 462   = case idSpecialisation fn of
 463         Rules rules _ -> matchRules in_scope rules args
 464 \end{code}
 465
 466
 467 %************************************************************************
 468 %*                                                                      *
 469 \subsection{Checking a program for failing rule applications}
 470 %*                                                                      *
 471 %************************************************************************
 472
 473 -----------------------------------------------------
 474                         Game plan
 475 -----------------------------------------------------
 476
 477 We want to know what sites have rules that could have fired but didn't.
 478 This pass runs over the tree (without changing it) and reports such.
 479
 480 NB: we assume that this follows a run of the simplifier, so every Id
 481 occurrence (including occurrences of imported Ids) is decorated with
 482 all its (active) rules.  No need to construct a rule base or anything
 483 like that.
 484
 485 \begin{code}
 486 ruleCheckProgram :: String -> [CoreBind] -> SDoc
 487 -- Report partial matches for rules beginning
 488 -- with the specified string
 489 ruleCheckProgram rule_pat binds
 490   | isEmptyBag results
 491   = text "Rule check results: no rule application sites"
 492   | otherwise
 493   = vcat [text "Rule check results:",
 494           line,
 495           vcat [ p $$ line | p <- bagToList results ]
 496          ]
 497   where
 498     results = unionManyBags (map (ruleCheckBind rule_pat) binds)
 499     line = text (take 20 (repeat '-'))
 500
 501 type RuleCheckEnv = String      -- Pattern
 502
 503 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
 504    -- The Bag returned has one SDoc for each call site found
 505 ruleCheckBind env (NonRec b r) = ruleCheck env r
 506 ruleCheckBind env (Rec prs)    = unionManyBags [ruleCheck env r | (b,r) <- prs]
 507
 508 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
 509 ruleCheck env (Var v)       = emptyBag
 510 ruleCheck env (Lit l)       = emptyBag
 511 ruleCheck env (Type ty)     = emptyBag
 512 ruleCheck env (App f a)     = ruleCheckApp env (App f a) []
 513 ruleCheck env (Note n e)    = ruleCheck env e
 514 ruleCheck env (Let bd e)    = ruleCheckBind env bd `unionBags` ruleCheck env e
 515 ruleCheck env (Lam b e)     = ruleCheck env e
 516 ruleCheck env (Case e _ as) = ruleCheck env e `unionBags`
 517                               unionManyBags [ruleCheck env r | (_,_,r) <- as]
 518
 519 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
 520 ruleCheckApp env (Var f) as   = ruleCheckFun env f as
 521 ruleCheckApp env other as     = ruleCheck env other
 522
 523 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
 524 ruleCheckFun env fun args
 525   = ruleAppCheck match fun args
 526   where
 527     match rule_name = env `isPrefixOf` _UNPK_ rule_name
 528 \end{code}
 529
 530 \begin{code}
 531 ruleAppCheck :: (RuleName -> Bool) -> Id -> [CoreExpr] -> Bag SDoc
 532 -- Produce a report for all rules matching the predicate
 533 -- saying why it doesn't match the specified application
 534
 535 ruleAppCheck name_match fn args
 536   | null name_match_rules = emptyBag
 537   | otherwise             = unitBag (ruleAppCheck_help fn args name_match_rules)
 538   where
 539     name_match_rules = case idSpecialisation fn of
 540                           Rules rules _ -> filter match rules
 541     match rule = name_match (ruleName rule)
 542
 543 ruleAppCheck_help :: Id -> [CoreExpr] -> [CoreRule] -> SDoc
 544 ruleAppCheck_help fn args rules
 545   =     -- The rules match the pattern, so we want to print something
 546     vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
 547           vcat (map check_rule rules)]
 548   where
 549     n_args = length args
 550     i_args = args `zip` [1::Int ..]
 551
 552     check_rule rule = rule_herald rule <> colon <+> rule_info rule
 553
 554     rule_herald (BuiltinRule name _) = text "Builtin rule" <+> doubleQuotes (ptext name)
 555     rule_herald (Rule name _ _ _)    = text "Rule" <+> doubleQuotes (ptext name)
 556
 557     rule_info rule
 558         | Just (name,_) <- matchRule emptyInScopeSet rule args
 559         = text "matches (which is very peculiar!)"
 560
 561     rule_info (BuiltinRule name fn) = text "does not match"
 562
 563     rule_info (Rule name rule_bndrs rule_args _)
 564         | n_args < n_rule_args        = text "too few arguments"
 565         | n_mismatches == n_rule_args = text "no arguments match"
 566         | n_mismatches == 0           = text "all arguments match (considered individually), but the rule as a whole does not"
 567         | otherwise                   = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
 568         where
 569           n_rule_args  = length rule_args
 570           n_mismatches = length mismatches
 571           mismatches   = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
 572                               not (isJust (match_fn rule_arg arg))]
 573
 574           bndr_set              = mkVarSet rule_bndrs
 575           match_fn rule_arg arg = match rule_arg arg bndr_set (\s -> Just ()) emptySubst
 576 \end{code}
 577
 578
 579 %************************************************************************
 580 %*                                                                      *
 581 \subsection{Getting the rules ready}
 582 %*                                                                      *
 583 %************************************************************************
 584
 585 \begin{code}
 586 data RuleBase = RuleBase
 587                     IdSet       -- Ids with their rules in their specialisations
 588                                 -- Held as a set, so that it can simply be the initial
 589                                 -- in-scope set in the simplifier
 590
 591                     IdSet       -- Ids (whether local or imported) mentioned on
 592                                 -- LHS of some rule; these should be black listed
 593
 594         -- This representation is a bit cute, and I wonder if we should
 595         -- change it to use (IdEnv CoreRule) which seems a bit more natural
 596
 597 ruleBaseIds (RuleBase ids _) = ids
 598 ruleBaseFVs (RuleBase _ fvs) = fvs
 599
 600 emptyRuleBase = RuleBase emptyVarSet emptyVarSet
 601
 602 addRuleBaseFVs :: RuleBase -> IdSet -> RuleBase
 603 addRuleBaseFVs (RuleBase rules fvs) extra_fvs
 604   = RuleBase rules (fvs `unionVarSet` extra_fvs)
 605
 606 extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase
 607 extendRuleBaseList rule_base new_guys
 608   = foldl extendRuleBase rule_base new_guys
 609
 610 extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase
 611 extendRuleBase (RuleBase rule_ids rule_fvs) (id, rule)
 612   = RuleBase (extendVarSet rule_ids new_id)
 613              (rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
 614   where
 615     new_id = setIdSpecialisation id (addRule id old_rules rule)
 616
 617     old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id))
 618         -- Get the old rules from rule_ids if the Id is already there, but
 619         -- if not, use the Id from the incoming rule.  If may be a PrimOpId,
 620         -- in which case it may have rules in its belly already.  Seems
 621         -- dreadfully hackoid.
 622
 623     lhs_fvs = ruleLhsFreeIds rule
 624         -- Finds *all* the free Ids of the LHS, not just
 625         -- locally defined ones!!
 626
 627 pprRuleBase :: RuleBase -> SDoc
 628 pprRuleBase (RuleBase rules _) = vcat [ pprCoreRule (ppr id) rs
 629                                       | id <- varSetElems rules,
 630                                         rs <- rulesRules $ idSpecialisation id ]
 631 \end{code}