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