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