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 -- | Functions for collecting together and applying rewrite rules to a module.
   8 -- The 'CoreRule' datatype itself is declared elsewhere.
   9 module Rules (
  10         -- * RuleBase
  11         RuleBase,
  12
  13         -- ** Constructing
  14         emptyRuleBase, mkRuleBase, extendRuleBaseList,
  15         unionRuleBase, pprRuleBase,
  16
  17         -- ** Checking rule applications
  18         ruleCheckProgram,
  19
  20         -- ** Manipulating 'SpecInfo' rules
  21         mkSpecInfo, extendSpecInfo, addSpecInfo,
  22         addIdSpecialisations,
  23
  24         -- * Misc. CoreRule helpers
  25         rulesOfBinds, getRules, pprRulesForUser,
  26
  27         lookupRule, mkRule, roughTopNames
  28     ) where
  29
  30 #include "HsVersions.h"
  31
  32 import CoreSyn          -- All of it
  33 import CoreSubst
  34 import OccurAnal        ( occurAnalyseExpr )
  35 import CoreFVs          ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )
  36 import CoreUtils        ( exprType, eqExpr )
  37 import PprCore          ( pprRules )
  38 import Type             ( Type )
  39 import TcType           ( tcSplitTyConApp_maybe )
  40 import Coercion
  41 import CoreTidy         ( tidyRules )
  42 import Id
  43 import IdInfo           ( SpecInfo( SpecInfo ) )
  44 import VarEnv
  45 import VarSet
  46 import Name             ( Name, NamedThing(..) )
  47 import NameEnv
  48 import Unify            ( ruleMatchTyX, MatchEnv(..) )
  49 import BasicTypes       ( Activation, CompilerPhase, isActive )
  50 import StaticFlags      ( opt_PprStyle_Debug )
  51 import Outputable
  52 import FastString
  53 import Maybes
  54 import Bag
  55 import Util
  56 import Data.List
  57 \end{code}
  58
  59 Note [Overall plumbing for rules]
  60 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  61 * After the desugarer:
  62    - The ModGuts initially contains mg_rules :: [CoreRule] of
  63      locally-declared rules for imported Ids.
  64    - Locally-declared rules for locally-declared Ids are attached to
  65      the IdInfo for that Id.  See Note [Attach rules to local ids] in
  66      DsBinds
  67
  68 * TidyPgm strips off all the rules from local Ids and adds them to
  69   mg_rules, so that the ModGuts has *all* the locally-declared rules.
  70
  71 * The HomePackageTable contains a ModDetails for each home package
  72   module.  Each contains md_rules :: [CoreRule] of rules declared in
  73   that module.  The HomePackageTable grows as ghc --make does its
  74   up-sweep.  In batch mode (ghc -c), the HPT is empty; all imported modules
  75   are treated by the "external" route, discussed next, regardless of
  76   which package they come from.
  77
  78 * The ExternalPackageState has a single eps_rule_base :: RuleBase for
  79   Ids in other packages.  This RuleBase simply grow monotonically, as
  80   ghc --make compiles one module after another.
  81
  82   During simplification, interface files may get demand-loaded,
  83   as the simplifier explores the unfoldings for Ids it has in
  84   its hand.  (Via an unsafePerformIO; the EPS is really a cache.)
  85   That in turn may make the EPS rule-base grow.  In contrast, the
  86   HPT never grows in this way.
  87
  88 * The result of all this is that during Core-to-Core optimisation
  89   there are four sources of rules:
  90
  91     (a) Rules in the IdInfo of the Id they are a rule for.  These are
  92         easy: fast to look up, and if you apply a substitution then
  93         it'll be applied to the IdInfo as a matter of course.
  94
  95     (b) Rules declared in this module for imported Ids, kept in the
  96         ModGuts. If you do a substitution, you'd better apply the
  97         substitution to these.  There are seldom many of these.
  98
  99     (c) Rules declared in the HomePackageTable.  These never change.
 100
 101     (d) Rules in the ExternalPackageTable. These can grow in response
 102         to lazy demand-loading of interfaces.
 103
 104 * At the moment (c) is carried in a reader-monad way by the CoreMonad.
 105   The HomePackageTable doesn't have a single RuleBase because technically
 106   we should only be able to "see" rules "below" this module; so we
 107   generate a RuleBase for (c) by combing rules from all the modules
 108   "below" us.  That's why we can't just select the home-package RuleBase
 109   from HscEnv.
 110
 111   [NB: we are inconsistent here.  We should do the same for external
 112   pacakges, but we don't.  Same for type-class instances.]
 113
 114 * So in the outer simplifier loop, we combine (b-d) into a single
 115   RuleBase, reading
 116      (b) from the ModGuts,
 117      (c) from the CoreMonad, and
 118      (d) from its mutable variable
 119   [Of coures this means that we won't see new EPS rules that come in
 120   during a single simplifier iteration, but that probably does not
 121   matter.]
 122
 123
 124 %************************************************************************
 125 %*                                                                      *
 126 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
 127 %*                                                                      *
 128 %************************************************************************
 129
 130 A @CoreRule@ holds details of one rule for an @Id@, which
 131 includes its specialisations.
 132
 133 For example, if a rule for @f@ contains the mapping:
 134 \begin{verbatim}
 135         forall a b d. [Type (List a), Type b, Var d]  ===>  f' a b
 136 \end{verbatim}
 137 then when we find an application of f to matching types, we simply replace
 138 it by the matching RHS:
 139 \begin{verbatim}
 140         f (List Int) Bool dict ===>  f' Int Bool
 141 \end{verbatim}
 142 All the stuff about how many dictionaries to discard, and what types
 143 to apply the specialised function to, are handled by the fact that the
 144 Rule contains a template for the result of the specialisation.
 145
 146 There is one more exciting case, which is dealt with in exactly the same
 147 way.  If the specialised value is unboxed then it is lifted at its
 148 definition site and unlifted at its uses.  For example:
 149
 150         pi :: forall a. Num a => a
 151
 152 might have a specialisation
 153
 154         [Int#] ===>  (case pi' of Lift pi# -> pi#)
 155
 156 where pi' :: Lift Int# is the specialised version of pi.
 157
 158 \begin{code}
 159 mkRule :: Bool -> Bool -> RuleName -> Activation
 160        -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
 161 -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
 162 -- compiled. See also 'CoreSyn.CoreRule'
 163 mkRule is_auto is_local name act fn bndrs args rhs
 164   = Rule { ru_name = name, ru_fn = fn, ru_act = act,
 165            ru_bndrs = bndrs, ru_args = args,
 166            ru_rhs = occurAnalyseExpr rhs,
 167            ru_rough = roughTopNames args,
 168            ru_auto = is_auto, ru_local = is_local }
 169
 170 --------------
 171 roughTopNames :: [CoreExpr] -> [Maybe Name]
 172 -- ^ Find the \"top\" free names of several expressions.
 173 -- Such names are either:
 174 --
 175 -- 1. The function finally being applied to in an application chain
 176 --    (if that name is a GlobalId: see "Var#globalvslocal"), or
 177 --
 178 -- 2. The 'TyCon' if the expression is a 'Type'
 179 --
 180 -- This is used for the fast-match-check for rules;
 181 --      if the top names don't match, the rest can't
 182 roughTopNames args = map roughTopName args
 183
 184 roughTopName :: CoreExpr -> Maybe Name
 185 roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
 186                                Just (tc,_) -> Just (getName tc)
 187                                Nothing     -> Nothing
 188 roughTopName (Coercion _) = Nothing
 189 roughTopName (App f _) = roughTopName f
 190 roughTopName (Var f)   | isGlobalId f   -- Note [Care with roughTopName]
 191                        , isDataConWorkId f || idArity f > 0
 192                        = Just (idName f)
 193 roughTopName _ = Nothing
 194
 195 ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
 196 -- ^ @ruleCantMatch tpl actual@ returns True only if @actual@
 197 -- definitely can't match @tpl@ by instantiating @tpl@.
 198 -- It's only a one-way match; unlike instance matching we
 199 -- don't consider unification.
 200 --
 201 -- Notice that [_$_]
 202 --      @ruleCantMatch [Nothing] [Just n2] = False@
 203 --      Reason: a template variable can be instantiated by a constant
 204 -- Also:
 205 --      @ruleCantMatch [Just n1] [Nothing] = False@
 206 --      Reason: a local variable @v@ in the actuals might [_$_]
 207
 208 ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as
 209 ruleCantMatch (_       : ts) (_       : as) = ruleCantMatch ts as
 210 ruleCantMatch _              _              = False
 211 \end{code}
 212
 213 Note [Care with roughTopName]
 214 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 215 Consider this
 216     module M where { x = a:b }
 217     module N where { ...f x...
 218                      RULE f (p:q) = ... }
 219 You'd expect the rule to match, because the matcher can
 220 look through the unfolding of 'x'.  So we must avoid roughTopName
 221 returning 'M.x' for the call (f x), or else it'll say "can't match"
 222 and we won't even try!!
 223
 224 However, suppose we have
 225          RULE g (M.h x) = ...
 226          foo = ...(g (M.k v))....
 227 where k is a *function* exported by M.  We never really match
 228 functions (lambdas) except by name, so in this case it seems like
 229 a good idea to treat 'M.k' as a roughTopName of the call.
 230
 231
 232 \begin{code}
 233 pprRulesForUser :: [CoreRule] -> SDoc
 234 -- (a) tidy the rules
 235 -- (b) sort them into order based on the rule name
 236 -- (c) suppress uniques (unless -dppr-debug is on)
 237 -- This combination makes the output stable so we can use in testing
 238 -- It's here rather than in PprCore because it calls tidyRules
 239 pprRulesForUser rules
 240   = withPprStyle defaultUserStyle $
 241     pprRules $
 242     sortLe le_rule  $
 243     tidyRules emptyTidyEnv rules
 244   where
 245     le_rule r1 r2 = ru_name r1 <= ru_name r2
 246 \end{code}
 247
 248
 249 %************************************************************************
 250 %*                                                                      *
 251                 SpecInfo: the rules in an IdInfo
 252 %*                                                                      *
 253 %************************************************************************
 254
 255 \begin{code}
 256 -- | Make a 'SpecInfo' containing a number of 'CoreRule's, suitable
 257 -- for putting into an 'IdInfo'
 258 mkSpecInfo :: [CoreRule] -> SpecInfo
 259 mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules)
 260
 261 extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
 262 extendSpecInfo (SpecInfo rs1 fvs1) rs2
 263   = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
 264
 265 addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
 266 addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2)
 267   = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
 268
 269 addIdSpecialisations :: Id -> [CoreRule] -> Id
 270 addIdSpecialisations id []
 271   = id
 272 addIdSpecialisations id rules
 273   = setIdSpecialisation id $
 274     extendSpecInfo (idSpecialisation id) rules
 275
 276 -- | Gather all the rules for locally bound identifiers from the supplied bindings
 277 rulesOfBinds :: [CoreBind] -> [CoreRule]
 278 rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
 279
 280 getRules :: RuleBase -> Id -> [CoreRule]
 281 -- See Note [Where rules are found]
 282 getRules rule_base fn
 283   = idCoreRules fn ++ imp_rules
 284   where
 285     imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []
 286 \end{code}
 287
 288 Note [Where rules are found]
 289 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 290 The rules for an Id come from two places:
 291   (a) the ones it is born with, stored inside the Id iself (idCoreRules fn),
 292   (b) rules added in other modules, stored in the global RuleBase (imp_rules)
 293
 294 It's tempting to think that
 295      - LocalIds have only (a)
 296      - non-LocalIds have only (b)
 297
 298 but that isn't quite right:
 299
 300      - PrimOps and ClassOps are born with a bunch of rules inside the Id,
 301        even when they are imported
 302
 303      - The rules in PrelRules.builtinRules should be active even
 304        in the module defining the Id (when it's a LocalId), but
 305        the rules are kept in the global RuleBase
 306
 307
 308 %************************************************************************
 309 %*                                                                      *
 310                 RuleBase
 311 %*                                                                      *
 312 %************************************************************************
 313
 314 \begin{code}
 315 -- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules
 316 type RuleBase = NameEnv [CoreRule]
 317         -- The rules are are unordered;
 318         -- we sort out any overlaps on lookup
 319
 320 emptyRuleBase :: RuleBase
 321 emptyRuleBase = emptyNameEnv
 322
 323 mkRuleBase :: [CoreRule] -> RuleBase
 324 mkRuleBase rules = extendRuleBaseList emptyRuleBase rules
 325
 326 extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
 327 extendRuleBaseList rule_base new_guys
 328   = foldl extendRuleBase rule_base new_guys
 329
 330 unionRuleBase :: RuleBase -> RuleBase -> RuleBase
 331 unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2
 332
 333 extendRuleBase :: RuleBase -> CoreRule -> RuleBase
 334 extendRuleBase rule_base rule
 335   = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule
 336
 337 pprRuleBase :: RuleBase -> SDoc
 338 pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
 339                          | rs <- nameEnvElts rules ]
 340 \end{code}
 341
 342
 343 %************************************************************************
 344 %*                                                                      *
 345                         Matching
 346 %*                                                                      *
 347 %************************************************************************
 348
 349 \begin{code}
 350 -- | The main rule matching function. Attempts to apply all (active)
 351 -- supplied rules to this instance of an application in a given
 352 -- context, returning the rule applied and the resulting expression if
 353 -- successful.
 354 lookupRule :: (Activation -> Bool)      -- When rule is active
 355             -> IdUnfoldingFun           -- When Id can be unfolded
 356             -> InScopeSet
 357             -> Id -> [CoreExpr]
 358             -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
 359
 360 -- See Note [Extra args in rule matching]
 361 -- See comments on matchRule
 362 lookupRule is_active id_unf in_scope fn args rules
 363   = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
 364     case go [] rules of
 365         []     -> Nothing
 366         (m:ms) -> Just (findBest (fn,args) m ms)
 367   where
 368     rough_args = map roughTopName args
 369
 370     go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
 371     go ms []           = ms
 372     go ms (r:rs) = case (matchRule is_active id_unf in_scope args rough_args r) of
 373                         Just e  -> go ((r,e):ms) rs
 374                         Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$
 375                                    --   ppr [ (arg_id, unfoldingTemplate unf)
 376                                    --       | Var arg_id <- args
 377                                    --       , let unf = idUnfolding arg_id
 378                                    --       , isCheapUnfolding unf] )
 379                                    go ms rs
 380
 381 findBest :: (Id, [CoreExpr])
 382          -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
 383 -- All these pairs matched the expression
 384 -- Return the pair the the most specific rule
 385 -- The (fn,args) is just for overlap reporting
 386
 387 findBest _      (rule,ans)   [] = (rule,ans)
 388 findBest target (rule1,ans1) ((rule2,ans2):prs)
 389   | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
 390   | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
 391   | debugIsOn = let pp_rule rule
 392                         | opt_PprStyle_Debug = ppr rule
 393                         | otherwise          = doubleQuotes (ftext (ru_name rule))
 394                 in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
 395                          (vcat [if opt_PprStyle_Debug then
 396                                    ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args)
 397                                 else empty,
 398                                 ptext (sLit "Rule 1:") <+> pp_rule rule1,
 399                                 ptext (sLit "Rule 2:") <+> pp_rule rule2]) $
 400                 findBest target (rule1,ans1) prs
 401   | otherwise = findBest target (rule1,ans1) prs
 402   where
 403     (fn,args) = target
 404
 405 isMoreSpecific :: CoreRule -> CoreRule -> Bool
 406 -- This tests if one rule is more specific than another
 407 -- We take the view that a BuiltinRule is less specific than
 408 -- anything else, because we want user-define rules to "win"
 409 -- In particular, class ops have a built-in rule, but we
 410 -- any user-specific rules to win
 411 --   eg (Trac #4397)
 412 --      truncate :: (RealFrac a, Integral b) => a -> b
 413 --      {-# RULES "truncate/Double->Int" truncate = double2Int #-}
 414 --      double2Int :: Double -> Int
 415 --   We want the specific RULE to beat the built-in class-op rule
 416 isMoreSpecific (BuiltinRule {}) _                = False
 417 isMoreSpecific (Rule {})        (BuiltinRule {}) = True
 418 isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
 419                (Rule { ru_bndrs = bndrs2, ru_args = args2 })
 420   = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1)
 421   where
 422    id_unfolding_fun _ = NoUnfolding     -- Don't expand in templates
 423    in_scope = mkInScopeSet (mkVarSet bndrs1)
 424         -- Actually we should probably include the free vars
 425         -- of rule1's args, but I can't be bothered
 426
 427 noBlackList :: Activation -> Bool
 428 noBlackList _ = False           -- Nothing is black listed
 429 \end{code}
 430
 431 Note [Extra args in rule matching]
 432 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 433 If we find a matching rule, we return (Just (rule, rhs)),
 434 but the rule firing has only consumed as many of the input args
 435 as the ruleArity says.  It's up to the caller to keep track
 436 of any left-over args.  E.g. if you call
 437         lookupRule ... f [e1, e2, e3]
 438 and it returns Just (r, rhs), where r has ruleArity 2
 439 then the real rewrite is
 440         f e1 e2 e3 ==> rhs e3
 441
 442 You might think it'd be cleaner for lookupRule to deal with the
 443 leftover arguments, by applying 'rhs' to them, but the main call
 444 in the Simplifier works better as it is.  Reason: the 'args' passed
 445 to lookupRule are the result of a lazy substitution
 446
 447 \begin{code}
 448 ------------------------------------
 449 matchRule :: (Activation -> Bool) -> IdUnfoldingFun
 450           -> InScopeSet
 451           -> [CoreExpr] -> [Maybe Name]
 452           -> CoreRule -> Maybe CoreExpr
 453
 454 -- If (matchRule rule args) returns Just (name,rhs)
 455 -- then (f args) matches the rule, and the corresponding
 456 -- rewritten RHS is rhs
 457 --
 458 -- The bndrs and rhs is occurrence-analysed
 459 --
 460 --      Example
 461 --
 462 -- The rule
 463 --      forall f g x. map f (map g x) ==> map (f . g) x
 464 -- is stored
 465 --      CoreRule "map/map"
 466 --               [f,g,x]                -- tpl_vars
 467 --               [f,map g x]            -- tpl_args
 468 --               map (f.g) x)           -- rhs
 469 --
 470 -- Then the call: matchRule the_rule [e1,map e2 e3]
 471 --        = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
 472 --
 473 -- Any 'surplus' arguments in the input are simply put on the end
 474 -- of the output.
 475
 476 matchRule _is_active id_unf _in_scope args _rough_args
 477           (BuiltinRule { ru_try = match_fn })
 478 -- Built-in rules can't be switched off, it seems
 479   = case match_fn id_unf args of
 480         Just expr -> Just expr
 481         Nothing   -> Nothing
 482
 483 matchRule is_active id_unf in_scope args rough_args
 484           (Rule { ru_act = act, ru_rough = tpl_tops,
 485                   ru_bndrs = tpl_vars, ru_args = tpl_args,
 486                   ru_rhs = rhs })
 487   | not (is_active act)               = Nothing
 488   | ruleCantMatch tpl_tops rough_args = Nothing
 489   | otherwise
 490   = case matchN id_unf in_scope tpl_vars tpl_args args of
 491         Nothing                        -> Nothing
 492         Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $
 493                                                rule_fn `mkApps` tpl_vals)
 494   where
 495     rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
 496         -- We could do this when putting things into the rulebase, I guess
 497
 498 ---------------------------------------
 499 matchN  :: IdUnfoldingFun
 500         -> InScopeSet           -- ^ In-scope variables
 501         -> [Var]                -- ^ Match template type variables
 502         -> [CoreExpr]           -- ^ Match template
 503         -> [CoreExpr]           -- ^ Target; can have more elements than the template
 504         -> Maybe (BindWrapper,  -- Floated bindings; see Note [Matching lets]
 505                   [CoreExpr])
 506 -- For a given match template and context, find bindings to wrap around
 507 -- the entire result and what should be substituted for each template variable.
 508 -- Fail if there are two few actual arguments from the target to match the template
 509
 510 matchN id_unf in_scope tmpl_vars tmpl_es target_es
 511   = do  { subst <- go init_menv emptyRuleSubst tmpl_es target_es
 512         ; return (rs_binds subst,
 513                   map (lookup_tmpl subst) tmpl_vars') }
 514   where
 515     (init_rn_env, tmpl_vars') = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars
 516         -- See Note [Template binders]
 517
 518     init_menv = RV { rv_tmpls = mkVarSet tmpl_vars', rv_lcl = init_rn_env
 519                    , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env)
 520                    , rv_unf = id_unf }
 521
 522     go _    subst []     _      = Just subst
 523     go _    _     _      []     = Nothing       -- Fail if too few actual args
 524     go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
 525                                      ; go menv subst1 ts es }
 526
 527     lookup_tmpl :: RuleSubst -> Var -> CoreExpr
 528     lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tmpl_var'
 529         | isId tmpl_var' = case lookupVarEnv id_subst tmpl_var' of
 530                              Just e -> e
 531                              _      -> unbound tmpl_var'
 532         | otherwise      = case lookupVarEnv tv_subst tmpl_var' of
 533                              Just ty -> Type ty
 534                              Nothing -> unbound tmpl_var'
 535
 536     unbound var = pprPanic "Template variable unbound in rewrite rule"
 537                         (ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es)
 538 \end{code}
 539
 540 Note [Template binders]
 541 ~~~~~~~~~~~~~~~~~~~~~~~
 542 Consider the following match:
 543         Template:  forall x.  f x
 544         Target:     f (x+1)
 545 This should succeed, because the template variable 'x' has
 546 nothing to do with the 'x' in the target.
 547
 548 On reflection, this case probably does just work, but this might not
 549         Template:  forall x. f (\x.x)
 550         Target:    f (\y.y)
 551 Here we want to clone when we find the \x, but to know that x must be in scope
 552
 553 To achive this, we use rnBndrL to rename the template variables if
 554 necessary; the renamed ones are the tmpl_vars'
 555
 556
 557 %************************************************************************
 558 %*                                                                      *
 559                    The main matcher
 560 %*                                                                      *
 561 %************************************************************************
 562
 563         ---------------------------------------------
 564                 The inner workings of matching
 565         ---------------------------------------------
 566
 567 \begin{code}
 568 -- * The domain of the TvSubstEnv and IdSubstEnv are the template
 569 --   variables passed into the match.
 570 --
 571 -- * The BindWrapper in a RuleSubst are the bindings floated out
 572 --   from nested matches; see the Let case of match, below
 573 --
 574 data RuleEnv = RV { rv_tmpls :: VarSet          -- Template variables
 575                   , rv_lcl   :: RnEnv2          -- Renamings for *local bindings*
 576                                                 --   (lambda/case)
 577                   , rv_fltR  :: Subst           -- Renamings for floated let-bindings
 578                                                 --   domain disjoint from envR of rv_lcl
 579                                                 -- See Note [Matching lets]
 580                   , rv_unf :: IdUnfoldingFun
 581                   }
 582
 583 data RuleSubst = RS { rs_tv_subst :: TvSubstEnv   -- Range is the
 584                     , rs_id_subst :: IdSubstEnv   --   template variables
 585                     , rs_binds    :: BindWrapper  -- Floated bindings
 586                     , rs_bndrs    :: VarSet       -- Variables bound by floated lets
 587                     }
 588
 589 type BindWrapper = CoreExpr -> CoreExpr
 590   -- See Notes [Matching lets] and [Matching cases]
 591   -- we represent the floated bindings as a core-to-core function
 592
 593 emptyRuleSubst :: RuleSubst
 594 emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv
 595                     , rs_binds = \e -> e, rs_bndrs = emptyVarSet }
 596
 597 --      At one stage I tried to match even if there are more
 598 --      template args than real args.
 599
 600 --      I now think this is probably a bad idea.
 601 --      Should the template (map f xs) match (map g)?  I think not.
 602 --      For a start, in general eta expansion wastes work.
 603 --      SLPJ July 99
 604
 605
 606 match :: RuleEnv
 607       -> RuleSubst
 608       -> CoreExpr               -- Template
 609       -> CoreExpr               -- Target
 610       -> Maybe RuleSubst
 611
 612 -- See the notes with Unify.match, which matches types
 613 -- Everything is very similar for terms
 614
 615 -- Interesting examples:
 616 -- Consider matching
 617 --      \x->f      against    \f->f
 618 -- When we meet the lambdas we must remember to rename f to f' in the
 619 -- second expresion.  The RnEnv2 does that.
 620 --
 621 -- Consider matching
 622 --      forall a. \b->b    against   \a->3
 623 -- We must rename the \a.  Otherwise when we meet the lambdas we
 624 -- might substitute [a/b] in the template, and then erroneously
 625 -- succeed in matching what looks like the template variable 'a' against 3.
 626
 627 -- The Var case follows closely what happens in Unify.match
 628 match renv subst (Var v1)    e2 = match_var renv subst v1 e2
 629 match renv subst (Note _ e1) e2 = match renv subst e1 e2
 630 match renv subst e1 (Note _ e2) = match renv subst e1 e2
 631       -- Ignore notes in both template and thing to be matched
 632       -- See Note [Notes in RULE matching]
 633
 634 match renv subst e1 (Var v2)      -- Note [Expanding variables]
 635   | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables]
 636   , Just e2' <- expandUnfolding_maybe (rv_unf renv v2')
 637   = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2'
 638   where
 639     v2'    = lookupRnInScope rn_env v2
 640     rn_env = rv_lcl renv
 641         -- Notice that we look up v2 in the in-scope set
 642         -- See Note [Lookup in-scope]
 643         -- No need to apply any renaming first (hence no rnOccR)
 644         -- because of the not-inRnEnvR
 645
 646 match renv subst e1 (Let bind e2)
 647   | okToFloat (rv_lcl renv) (bindFreeVars bind)        -- See Note [Matching lets]
 648   = match (renv { rv_fltR = flt_subst' })
 649           (subst { rs_binds = rs_binds subst . Let bind'
 650                  , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs })
 651           e1 e2
 652   where
 653     flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst)
 654     (flt_subst', bind') = substBind flt_subst bind
 655     new_bndrs = bindersOf bind'
 656
 657 {- Disabled: see Note [Matching cases] below
 658 match renv (tv_subst, id_subst, binds) e1
 659       (Case scrut case_bndr ty [(con, alt_bndrs, rhs)])
 660   | exprOkForSpeculation scrut  -- See Note [Matching cases]
 661   , okToFloat rn_env bndrs (exprFreeVars scrut)
 662   = match (renv { me_env = rn_env' })
 663           (tv_subst, id_subst, binds . case_wrap)
 664           e1 rhs
 665   where
 666     rn_env   = me_env renv
 667     rn_env'  = extendRnInScopeList rn_env bndrs
 668     bndrs    = case_bndr : alt_bndrs
 669     case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')]
 670 -}
 671
 672 match _ subst (Lit lit1) (Lit lit2)
 673   | lit1 == lit2
 674   = Just subst
 675
 676 match renv subst (App f1 a1) (App f2 a2)
 677   = do  { subst' <- match renv subst f1 f2
 678         ; match renv subst' a1 a2 }
 679
 680 match renv subst (Lam x1 e1) (Lam x2 e2)
 681   = match renv' subst e1 e2
 682   where
 683     renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2
 684                  , rv_fltR = delBndr (rv_fltR renv) x2 }
 685
 686 -- This rule does eta expansion
 687 --              (\x.M)  ~  N    iff     M  ~  N x
 688 -- It's important that this is *after* the let rule,
 689 -- so that      (\x.M)  ~  (let y = e in \y.N)
 690 -- does the let thing, and then gets the lam/lam rule above
 691 match renv subst (Lam x1 e1) e2
 692   = match renv' subst e1 (App e2 (varToCoreExpr new_x))
 693   where
 694     (rn_env', new_x) = rnEtaL (rv_lcl renv) x1
 695     renv' = renv { rv_lcl = rn_env' }
 696
 697 -- Eta expansion the other way
 698 --      M  ~  (\y.N)    iff   M y     ~  N
 699 match renv subst e1 (Lam x2 e2)
 700   = match renv' subst (App e1 (varToCoreExpr new_x)) e2
 701   where
 702     (rn_env', new_x) = rnEtaR (rv_lcl renv) x2
 703     renv' = renv { rv_lcl = rn_env' }
 704
 705 match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
 706   = do  { subst1 <- match_ty renv subst ty1 ty2
 707         ; subst2 <- match renv subst1 e1 e2
 708         ; let renv' = rnMatchBndr2 renv subst x1 x2
 709         ; match_alts renv' subst2 alts1 alts2   -- Alts are both sorted
 710         }
 711
 712 match renv subst (Type ty1) (Type ty2)
 713   = match_ty renv subst ty1 ty2
 714 match renv subst (Coercion co1) (Coercion co2)
 715   = match_co renv subst co1 co2
 716
 717 match renv subst (Cast e1 co1) (Cast e2 co2)
 718   = do  { subst1 <- match_co renv subst co1 co2
 719         ; match renv subst1 e1 e2 }
 720
 721 -- Everything else fails
 722 match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
 723                     Nothing
 724
 725 -------------
 726 match_co :: RuleEnv
 727          -> RuleSubst
 728          -> Coercion
 729          -> Coercion
 730          -> Maybe RuleSubst
 731 match_co renv subst (CoVarCo cv) co
 732   = match_var renv subst cv (Coercion co)
 733 match_co _ _ co1 _
 734   = pprTrace "match_co baling out" (ppr co1) Nothing
 735
 736 -------------
 737 rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv
 738 rnMatchBndr2 renv subst x1 x2
 739   = renv { rv_lcl  = rnBndr2 rn_env x1 x2
 740          , rv_fltR = delBndr (rv_fltR renv) x2 }
 741   where
 742     rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst)
 743     -- Typically this is a no-op, but it may matter if
 744     -- there are some floated let-bindings
 745
 746 ------------------------------------------
 747 match_alts :: RuleEnv
 748            -> RuleSubst
 749            -> [CoreAlt]         -- Template
 750            -> [CoreAlt]         -- Target
 751            -> Maybe RuleSubst
 752 match_alts _ subst [] []
 753   = return subst
 754 match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
 755   | c1 == c2
 756   = do  { subst1 <- match renv' subst r1 r2
 757         ; match_alts renv subst1 alts1 alts2 }
 758   where
 759     renv' = foldl mb renv (vs1 `zip` vs2)
 760     mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2
 761
 762 match_alts _ _ _ _
 763   = Nothing
 764
 765 ------------------------------------------
 766 okToFloat :: RnEnv2 -> VarSet -> Bool
 767 okToFloat rn_env bind_fvs
 768   = foldVarSet ((&&) . not_captured) True bind_fvs
 769   where
 770     not_captured fv = not (inRnEnvR rn_env fv)
 771
 772 ------------------------------------------
 773 match_var :: RuleEnv
 774           -> RuleSubst
 775           -> Var                -- Template
 776           -> CoreExpr        -- Target
 777           -> Maybe RuleSubst
 778 match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env })
 779           subst v1 e2
 780   | v1' `elemVarSet` tmpls
 781   = match_tmpl_var renv subst v1' e2
 782
 783   | otherwise   -- v1' is not a template variable; check for an exact match with e2
 784   = case e2 of  -- Remember, envR of rn_env is disjoint from rv_fltR
 785        Var v2 | v1' == rnOccR rn_env v2
 786               -> Just subst
 787
 788               | Var v2' <- lookupIdSubst (text "match_var") flt_env v2
 789               , v1' == v2'
 790               -> Just subst
 791
 792        _ -> Nothing
 793
 794   where
 795     v1' = rnOccL rn_env v1
 796         -- If the template is
 797         --      forall x. f x (\x -> x) = ...
 798         -- Then the x inside the lambda isn't the
 799         -- template x, so we must rename first!
 800
 801 ------------------------------------------
 802 match_tmpl_var :: RuleEnv
 803                -> RuleSubst
 804                -> Var                -- Template
 805                -> CoreExpr              -- Target
 806                -> Maybe RuleSubst
 807
 808 match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env })
 809                subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs })
 810                v1' e2
 811   | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
 812   = Nothing     -- Occurs check failure
 813                 -- e.g. match forall a. (\x-> a x) against (\y. y y)
 814
 815   | Just e1' <- lookupVarEnv id_subst v1'
 816   = if eqExpr (rnInScopeSet rn_env) e1' e2'
 817     then Just subst
 818     else Nothing
 819
 820   | otherwise
 821   =             -- Note [Matching variable types]
 822                 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 823                 -- However, we must match the *types*; e.g.
 824                 --   forall (c::Char->Int) (x::Char).
 825                 --      f (c x) = "RULE FIRED"
 826                 -- We must only match on args that have the right type
 827                 -- It's actually quite difficult to come up with an example that shows
 828                 -- you need type matching, esp since matching is left-to-right, so type
 829                 -- args get matched first.  But it's possible (e.g. simplrun008) and
 830                 -- this is the Right Thing to do
 831     do { subst' <- match_ty renv subst (idType v1') (exprType e2)
 832        ; return (subst' { rs_id_subst = id_subst' }) }
 833   where
 834     -- e2' is the result of applying flt_env to e2
 835     e2' | isEmptyVarSet let_bndrs = e2
 836         | otherwise = substExpr (text "match_tmpl_var") flt_env e2
 837
 838     id_subst' = extendVarEnv (rs_id_subst subst) v1' e2'
 839          -- No further renaming to do on e2',
 840          -- because no free var of e2' is in the rnEnvR of the envt
 841
 842 ------------------------------------------
 843 match_ty :: RuleEnv
 844          -> RuleSubst
 845          -> Type                -- Template
 846          -> Type                -- Target
 847          -> Maybe RuleSubst
 848 -- Matching Core types: use the matcher in TcType.
 849 -- Notice that we treat newtypes as opaque.  For example, suppose
 850 -- we have a specialised version of a function at a newtype, say
 851 --      newtype T = MkT Int
 852 -- We only want to replace (f T) with f', not (f Int).
 853
 854 match_ty renv subst ty1 ty2
 855   = do  { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
 856         ; return (subst { rs_tv_subst = tv_subst' }) }
 857   where
 858     tv_subst = rs_tv_subst subst
 859     menv = ME { me_tmpls = rv_tmpls renv, me_env = rv_lcl renv }
 860 \end{code}
 861
 862 Note [Expanding variables]
 863 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 864 Here is another Very Important rule: if the term being matched is a
 865 variable, we expand it so long as its unfolding is "expandable". (Its
 866 occurrence information is not necessarily up to date, so we don't use
 867 it.)  By "expandable" we mean a WHNF or a "constructor-like" application.
 868 This is the key reason for "constructor-like" Ids.  If we have
 869      {-# NOINLINE [1] CONLIKE g #-}
 870      {-# RULE f (g x) = h x #-}
 871 then in the term
 872    let v = g 3 in ....(f v)....
 873 we want to make the rule fire, to replace (f v) with (h 3).
 874
 875 Note [Do not expand locally-bound variables]
 876 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 877 Do *not* expand locally-bound variables, else there's a worry that the
 878 unfolding might mention variables that are themselves renamed.
 879 Example
 880           case x of y { (p,q) -> ...y... }
 881 Don't expand 'y' to (p,q) because p,q might themselves have been
 882 renamed.  Essentially we only expand unfoldings that are "outside"
 883 the entire match.
 884
 885 Hence, (a) the guard (not (isLocallyBoundR v2))
 886        (b) when we expand we nuke the renaming envt (nukeRnEnvR).
 887
 888 Note [Notes in RULE matching]
 889 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 890 Look through Notes in both template and expression being matched.  In
 891 particular, we don't want to be confused by InlineMe notes.  Maybe we
 892 should be more careful about profiling notes, but for now I'm just
 893 riding roughshod over them.  cf Note [Notes in call patterns] in
 894 SpecConstr
 895
 896 Note [Matching lets]
 897 ~~~~~~~~~~~~~~~~~~~~
 898 Matching a let-expression.  Consider
 899         RULE forall x.  f (g x) = <rhs>
 900 and target expression
 901         f (let { w=R } in g E))
 902 Then we'd like the rule to match, to generate
 903         let { w=R } in (\x. <rhs>) E
 904 In effect, we want to float the let-binding outward, to enable
 905 the match to happen.  This is the WHOLE REASON for accumulating
 906 bindings in the RuleSubst
 907
 908 We can only do this if the free variables of R are not bound by the
 909 part of the target expression outside the let binding; e.g.
 910         f (\v. let w = v+1 in g E)
 911 Here we obviously cannot float the let-binding for w.  Hence the
 912 use of okToFloat.
 913
 914 There are a couple of tricky points.
 915   (a) What if floating the binding captures a variable?
 916         f (let v = x+1 in v) v
 917       --> NOT!
 918         let v = x+1 in f (x+1) v
 919
 920   (b) What if two non-nested let bindings bind the same variable?
 921         f (let v = e1 in b1) (let v = e2 in b2)
 922       --> NOT!
 923         let v = e1 in let v = e2 in (f b2 b2)
 924       See testsuite test "RuleFloatLet".
 925
 926 Our cunning plan is this:
 927   * Along with the growing substitution for template variables
 928     we maintain a growing set of floated let-bindings (rs_binds)
 929     plus the set of variables thus bound.
 930
 931   * The RnEnv2 in the MatchEnv binds only the local binders
 932     in the term (lambdas, case)
 933
 934   * When we encounter a let in the term to be matched, we
 935     check that does not mention any locally bound (lambda, case)
 936     variables.  If so we fail
 937
 938   * We use CoreSubst.substBind to freshen the binding, using an
 939     in-scope set that is the original in-scope variables plus the
 940     rs_bndrs (currently floated let-bindings).  So in (a) above
 941     we'll freshen the 'v' binding; in (b) above we'll freshen
 942     the *second* 'v' binding.
 943
 944   * We apply that freshening substitution, in a lexically-scoped
 945     way to the term, although lazily; this is the rv_fltR field.
 946
 947
 948 Note [Matching cases]
 949 ~~~~~~~~~~~~~~~~~~~~~
 950 {- NOTE: This idea is currently disabled.  It really only works if
 951          the primops involved are OkForSpeculation, and, since
 952          they have side effects readIntOfAddr and touch are not.
 953          Maybe we'll get back to this later .  -}
 954
 955 Consider
 956    f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->
 957       case touch# fp s# of { _ ->
 958       I# n# } } )
 959 This happened in a tight loop generated by stream fusion that
 960 Roman encountered.  We'd like to treat this just like the let
 961 case, because the primops concerned are ok-for-speculation.
 962 That is, we'd like to behave as if it had been
 963    case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->
 964    case touch# fp s# of { _ ->
 965    f (I# n# } } )
 966
 967 Note [Lookup in-scope]
 968 ~~~~~~~~~~~~~~~~~~~~~~
 969 Consider this example
 970         foo :: Int -> Maybe Int -> Int
 971         foo 0 (Just n) = n
 972         foo m (Just n) = foo (m-n) (Just n)
 973
 974 SpecConstr sees this fragment:
 975
 976         case w_smT of wild_Xf [Just A] {
 977           Data.Maybe.Nothing -> lvl_smf;
 978           Data.Maybe.Just n_acT [Just S(L)] ->
 979             case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->
 980             \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
 981             }};
 982
 983 and correctly generates the rule
 984
 985         RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#
 986                                           sc_snn :: GHC.Prim.Int#}
 987           \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
 988           = \$s\$wfoo_sno y_amr sc_snn ;]
 989
 990 BUT we must ensure that this rule matches in the original function!
 991 Note that the call to \$wfoo is
 992             \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
 993
 994 During matching we expand wild_Xf to (Just n_acT).  But then we must also
 995 expand n_acT to (I# y_amr).  And we can only do that if we look up n_acT
 996 in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding
 997 at all.
 998
 999 That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
1000 is so important.
1001
1002 %************************************************************************
1003 %*                                                                      *
1004                    Rule-check the program
1005 %*                                                                      *
1006 %************************************************************************
1007
1008    We want to know what sites have rules that could have fired but didn't.
1009    This pass runs over the tree (without changing it) and reports such.
1010
1011 \begin{code}
1012 -- | Report partial matches for rules beginning with the specified
1013 -- string for the purposes of error reporting
1014 ruleCheckProgram :: CompilerPhase               -- ^ Rule activation test
1015                  -> String                      -- ^ Rule pattern
1016                  -> RuleBase                    -- ^ Database of rules
1017                  -> [CoreBind]                  -- ^ Bindings to check in
1018                  -> SDoc                        -- ^ Resulting check message
1019 ruleCheckProgram phase rule_pat rule_base binds
1020   | isEmptyBag results
1021   = text "Rule check results: no rule application sites"
1022   | otherwise
1023   = vcat [text "Rule check results:",
1024           line,
1025           vcat [ p $$ line | p <- bagToList results ]
1026          ]
1027   where
1028     env = RuleCheckEnv { rc_is_active = isActive phase
1029                        , rc_id_unf    = idUnfolding     -- Not quite right
1030                                                         -- Should use activeUnfolding
1031                        , rc_pattern   = rule_pat
1032                        , rc_rule_base = rule_base }
1033     results = unionManyBags (map (ruleCheckBind env) binds)
1034     line = text (replicate 20 '-')
1035
1036 data RuleCheckEnv = RuleCheckEnv {
1037     rc_is_active :: Activation -> Bool,
1038     rc_id_unf  :: IdUnfoldingFun,
1039     rc_pattern :: String,
1040     rc_rule_base :: RuleBase
1041 }
1042
1043 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
1044    -- The Bag returned has one SDoc for each call site found
1045 ruleCheckBind env (NonRec _ r) = ruleCheck env r
1046 ruleCheckBind env (Rec prs)    = unionManyBags [ruleCheck env r | (_,r) <- prs]
1047
1048 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
1049 ruleCheck _   (Var _)       = emptyBag
1050 ruleCheck _   (Lit _)       = emptyBag
1051 ruleCheck _   (Type _)      = emptyBag
1052 ruleCheck _   (Coercion _)  = emptyBag
1053 ruleCheck env (App f a)     = ruleCheckApp env (App f a) []
1054 ruleCheck env (Note _ e)    = ruleCheck env e
1055 ruleCheck env (Cast e _)    = ruleCheck env e
1056 ruleCheck env (Let bd e)    = ruleCheckBind env bd `unionBags` ruleCheck env e
1057 ruleCheck env (Lam _ e)     = ruleCheck env e
1058 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
1059                                 unionManyBags [ruleCheck env r | (_,_,r) <- as]
1060
1061 ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc
1062 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
1063 ruleCheckApp env (Var f) as   = ruleCheckFun env f as
1064 ruleCheckApp env other _      = ruleCheck env other
1065 \end{code}
1066
1067 \begin{code}
1068 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
1069 -- Produce a report for all rules matching the predicate
1070 -- saying why it doesn't match the specified application
1071
1072 ruleCheckFun env fn args
1073   | null name_match_rules = emptyBag
1074   | otherwise             = unitBag (ruleAppCheck_help env fn args name_match_rules)
1075   where
1076     name_match_rules = filter match (getRules (rc_rule_base env) fn)
1077     match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
1078
1079 ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
1080 ruleAppCheck_help env fn args rules
1081   =     -- The rules match the pattern, so we want to print something
1082     vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
1083           vcat (map check_rule rules)]
1084   where
1085     n_args = length args
1086     i_args = args `zip` [1::Int ..]
1087     rough_args = map roughTopName args
1088
1089     check_rule rule = rule_herald rule <> colon <+> rule_info rule
1090
1091     rule_herald (BuiltinRule { ru_name = name })
1092         = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name)
1093     rule_herald (Rule { ru_name = name })
1094         = ptext (sLit "Rule") <+> doubleQuotes (ftext name)
1095
1096     rule_info rule
1097         | Just _ <- matchRule noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule
1098         = text "matches (which is very peculiar!)"
1099
1100     rule_info (BuiltinRule {}) = text "does not match"
1101
1102     rule_info (Rule { ru_act = act,
1103                       ru_bndrs = rule_bndrs, ru_args = rule_args})
1104         | not (rc_is_active env act)  = text "active only in later phase"
1105         | n_args < n_rule_args        = text "too few arguments"
1106         | n_mismatches == n_rule_args = text "no arguments match"
1107         | n_mismatches == 0           = text "all arguments match (considered individually), but rule as a whole does not"
1108         | otherwise                   = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
1109         where
1110           n_rule_args  = length rule_args
1111           n_mismatches = length mismatches
1112           mismatches   = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
1113                               not (isJust (match_fn rule_arg arg))]
1114
1115           lhs_fvs = exprsFreeVars rule_args     -- Includes template tyvars
1116           match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg
1117                 where
1118                   in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg)
1119                   renv = RV { rv_lcl   = mkRnEnv2 in_scope
1120                             , rv_tmpls = mkVarSet rule_bndrs
1121                             , rv_fltR  = mkEmptySubst in_scope
1122                             , rv_unf   = rc_id_unf env }
1123 \end{code}
1124