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