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