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