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