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