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, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
  24                           substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet,
  25                           bindSubstList, unBindSubstList, substInScope, uniqAway
  26                         )
  27 import Id               ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
  28 import Var              ( isId )
  29 import VarSet
  30 import VarEnv
  31 import TcType           ( mkTyVarTy )
  32 import qualified TcType ( match )
  33 import BasicTypes       ( Activation, CompilerPhase, isActive )
  34
  35 import Outputable
  36 import FastString
  37 import Maybe            ( isJust, isNothing, fromMaybe )
  38 import Util             ( sortLe )
  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 (sortLe le_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 le_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 mkVarArg :: CoreBndr -> CoreArg
 376 mkVarArg v | isId v    = Var v
 377            | otherwise = Type (mkTyVarTy v)
 378 \end{code}
 379
 380 Matching Core types: use the matcher in TcType.
 381 Notice that we treat newtypes as opaque.  For example, suppose
 382 we have a specialised version of a function at a newtype, say
 383         newtype T = MkT Int
 384 We only want to replace (f T) with f', not (f Int).
 385
 386 \begin{code}
 387 ----------------------------------------
 388 match_ty ty1 ty2 tpl_vars kont subst
 389   = TcType.match ty1 ty2 tpl_vars kont' (substEnv subst)
 390   where
 391     kont' senv = kont (setSubstEnv subst senv)
 392 \end{code}
 393
 394
 395
 396 %************************************************************************
 397 %*                                                                      *
 398 \subsection{Adding a new rule}
 399 %*                                                                      *
 400 %************************************************************************
 401
 402 \begin{code}
 403 addRule :: Id -> CoreRules -> CoreRule -> CoreRules
 404
 405 -- Add a new rule to an existing bunch of rules.
 406 -- The rules are for the given Id; the Id argument is needed only
 407 -- so that we can exclude the Id from its own RHS free-var set
 408
 409 -- Insert the new rule just before a rule that is *less specific*
 410 -- than the new one; or at the end if there isn't such a one.
 411 -- In this way we make sure that when looking up, the first match
 412 -- is the most specific.
 413 --
 414 -- We make no check for rules that unify without one dominating
 415 -- the other.   Arguably this would be a bug.
 416
 417 addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _)
 418   = Rules (rule:rules) rhs_fvs
 419         -- Put it at the start for lack of anything better
 420
 421 addRule id (Rules rules rhs_fvs) rule
 422   = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
 423   where
 424     new_rule    = occurAnalyseRule rule
 425     new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id
 426         -- Hack alert!
 427         -- Don't include the Id in its own rhs free-var set.
 428         -- Otherwise the occurrence analyser makes bindings recursive
 429         -- that shoudn't be.  E.g.
 430         --      RULE:  f (f x y) z  ==>  f x (f y z)
 431
 432 insertRule rules new_rule@(Rule _ _ tpl_vars tpl_args _)
 433   = go rules
 434   where
 435     tpl_var_set = mkInScopeSet (mkVarSet tpl_vars)
 436         -- Actually we should probably include the free vars of tpl_args,
 437         -- but I can't be bothered
 438
 439     go []                                       = [new_rule]
 440     go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
 441                     | otherwise                 = rule : go rules
 442
 443     new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args)
 444
 445 addIdSpecialisations :: Id -> [CoreRule] -> Id
 446 addIdSpecialisations id rules
 447   = setIdSpecialisation id new_specs
 448   where
 449     new_specs = foldl (addRule id) (idSpecialisation id) rules
 450 \end{code}
 451
 452
 453 %************************************************************************
 454 %*                                                                      *
 455 \subsection{Looking up a rule}
 456 %*                                                                      *
 457 %************************************************************************
 458
 459 \begin{code}
 460 lookupRule :: (Activation -> Bool) -> InScopeSet
 461            -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
 462 lookupRule is_active in_scope fn args
 463   = case idSpecialisation fn of
 464         Rules rules _ -> matchRules is_active in_scope rules args
 465 \end{code}
 466
 467
 468 %************************************************************************
 469 %*                                                                      *
 470 \subsection{Checking a program for failing rule applications}
 471 %*                                                                      *
 472 %************************************************************************
 473
 474 -----------------------------------------------------
 475                         Game plan
 476 -----------------------------------------------------
 477
 478 We want to know what sites have rules that could have fired but didn't.
 479 This pass runs over the tree (without changing it) and reports such.
 480
 481 NB: we assume that this follows a run of the simplifier, so every Id
 482 occurrence (including occurrences of imported Ids) is decorated with
 483 all its (active) rules.  No need to construct a rule base or anything
 484 like that.
 485
 486 \begin{code}
 487 ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc
 488 -- Report partial matches for rules beginning
 489 -- with the specified string
 490 ruleCheckProgram phase rule_pat binds
 491   | isEmptyBag results
 492   = text "Rule check results: no rule application sites"
 493   | otherwise
 494   = vcat [text "Rule check results:",
 495           line,
 496           vcat [ p $$ line | p <- bagToList results ]
 497          ]
 498   where
 499     results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
 500     line = text (replicate 20 '-')
 501
 502 type RuleCheckEnv = (CompilerPhase, String)     -- Phase and Pattern
 503
 504 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
 505    -- The Bag returned has one SDoc for each call site found
 506 ruleCheckBind env (NonRec b r) = ruleCheck env r
 507 ruleCheckBind env (Rec prs)    = unionManyBags [ruleCheck env r | (b,r) <- prs]
 508
 509 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
 510 ruleCheck env (Var v)       = emptyBag
 511 ruleCheck env (Lit l)       = emptyBag
 512 ruleCheck env (Type ty)     = emptyBag
 513 ruleCheck env (App f a)     = ruleCheckApp env (App f a) []
 514 ruleCheck env (Note n e)    = ruleCheck env e
 515 ruleCheck env (Let bd e)    = ruleCheckBind env bd `unionBags` ruleCheck env e
 516 ruleCheck env (Lam b e)     = ruleCheck env e
 517 ruleCheck env (Case e _ as) = ruleCheck env e `unionBags`
 518                               unionManyBags [ruleCheck env r | (_,_,r) <- as]
 519
 520 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
 521 ruleCheckApp env (Var f) as   = ruleCheckFun env f as
 522 ruleCheckApp env other as     = ruleCheck env other
 523 \end{code}
 524
 525 \begin{code}
 526 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
 527 -- Produce a report for all rules matching the predicate
 528 -- saying why it doesn't match the specified application
 529
 530 ruleCheckFun (phase, pat) fn args
 531   | null name_match_rules = emptyBag
 532   | otherwise             = unitBag (ruleAppCheck_help phase fn args name_match_rules)
 533   where
 534     name_match_rules = case idSpecialisation fn of
 535                           Rules rules _ -> filter match rules
 536     match rule = pat `isPrefixOf` unpackFS (ruleName rule)
 537
 538 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
 539 ruleAppCheck_help phase fn args rules
 540   =     -- The rules match the pattern, so we want to print something
 541     vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
 542           vcat (map check_rule rules)]
 543   where
 544     n_args = length args
 545     i_args = args `zip` [1::Int ..]
 546
 547     check_rule rule = rule_herald rule <> colon <+> rule_info rule
 548
 549     rule_herald (BuiltinRule name _) =
 550         ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
 551     rule_herald (Rule name _ _ _ _)  =
 552         ptext SLIT("Rule") <+> doubleQuotes (ftext name)
 553
 554     rule_info rule
 555         | Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args
 556         = text "matches (which is very peculiar!)"
 557
 558     rule_info (BuiltinRule name fn) = text "does not match"
 559
 560     rule_info (Rule name act rule_bndrs rule_args _)
 561         | not (isActive phase act)    = text "active only in later phase"
 562         | n_args < n_rule_args        = text "too few arguments"
 563         | n_mismatches == n_rule_args = text "no arguments match"
 564         | n_mismatches == 0           = text "all arguments match (considered individually), but the rule as a whole does not"
 565         | otherwise                   = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
 566         where
 567           n_rule_args  = length rule_args
 568           n_mismatches = length mismatches
 569           mismatches   = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
 570                               not (isJust (match_fn rule_arg arg))]
 571
 572           bndr_set              = mkVarSet rule_bndrs
 573           match_fn rule_arg arg = match rule_arg arg bndr_set (\s -> Just ()) emptySubst
 574 \end{code}
 575
 576
 577 %************************************************************************
 578 %*                                                                      *
 579 \subsection{Getting the rules ready}
 580 %*                                                                      *
 581 %************************************************************************
 582
 583 \begin{code}
 584 data RuleBase = RuleBase
 585                     IdSet       -- Ids with their rules in their specialisations
 586                                 -- Held as a set, so that it can simply be the initial
 587                                 -- in-scope set in the simplifier
 588         -- This representation is a bit cute, and I wonder if we should
 589         -- change it to use (IdEnv CoreRule) which seems a bit more natural
 590
 591 ruleBaseIds (RuleBase ids) = ids
 592 emptyRuleBase = RuleBase emptyVarSet
 593
 594 extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase
 595 extendRuleBaseList rule_base new_guys
 596   = foldl extendRuleBase rule_base new_guys
 597
 598 extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase
 599 extendRuleBase (RuleBase rule_ids) (id, rule)
 600   = RuleBase (extendVarSet rule_ids new_id)
 601   where
 602     new_id    = setIdSpecialisation id (addRule id old_rules rule)
 603     old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id))
 604         -- Get the old rules from rule_ids if the Id is already there, but
 605         -- if not, use the Id from the incoming rule.  If may be a PrimOpId,
 606         -- in which case it may have rules in its belly already.  Seems
 607         -- dreadfully hackoid.
 608
 609 pprRuleBase :: RuleBase -> SDoc
 610 pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]
 611 \end{code}