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