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