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