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