Fix two obscure bugs in rule matching
[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, Kind, 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 $
540 tmpl_vars `zip` tmpl_vars1
541 ; return (rs_binds subst, matched_es) }
542 where
543 (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars
544 -- See Note [Cloning the template binders]
545
546 init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1
547 , rv_lcl = init_rn_env
548 , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env)
549 , rv_unf = id_unf }
550
551 go _ subst [] _ = Just subst
552 go _ _ _ [] = Nothing -- Fail if too few actual args
553 go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
554 ; go menv subst1 ts es }
555
556 lookup_tmpl :: RuleSubst -> (InVar,OutVar) -> (RuleSubst, CoreExpr)
557 -- Need to return a RuleSubst solely for the benefit of mk_fake_ty
558 lookup_tmpl rs@(RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst })
559 (tmpl_var, tmpl_var1)
560 | isId tmpl_var1
561 = case lookupVarEnv id_subst tmpl_var1 of
562 Just e -> (rs, e)
563 Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1
564 , let co_expr = Coercion refl_co
565 id_subst' = extendVarEnv id_subst tmpl_var1 co_expr
566 rs' = rs { rs_id_subst = id_subst' }
567 -> (rs', co_expr) -- See Note [Unbound RULE binders]
568 | otherwise
569 -> unbound tmpl_var
570 | otherwise
571 = case lookupVarEnv tv_subst tmpl_var1 of
572 Just ty -> (rs, Type ty)
573 Nothing -> (rs', Type fake_ty) -- See Note [Unbound RULE binders]
574 where
575 rs' = rs { rs_tv_subst = extendVarEnv tv_subst tmpl_var1 fake_ty }
576 fake_ty = mk_fake_ty in_scope rs tmpl_var1
577 -- This call is the sole reason we accumulate
578 -- RuleSubst in lookup_tmpl
579
580 unbound tmpl_var
581 = pprPanic "Template variable unbound in rewrite rule" $
582 vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var)
583 , text "Rule" <+> pprRuleName rule_name
584 , text "Rule bndrs:" <+> ppr tmpl_vars
585 , text "LHS args:" <+> ppr tmpl_es
586 , text "Actual args:" <+> ppr target_es ]
587
588
589 mk_fake_ty :: InScopeSet -> RuleSubst -> TyVar -> Kind
590 -- Roughly:
591 -- mk_fake_ty subst tv = Any @(subst (tyVarKind tv))
592 -- That is: apply the substitution to the kind of the given tyvar,
593 -- and make an 'any' type of that kind.
594 -- Tiresomely, the RuleSubst is not well adapted to substTy, leading to
595 -- horrible impedence matching.
596 --
597 -- Happily, this function is seldom called
598 mk_fake_ty in_scope (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tmpl_var1
599 = anyTypeOfKind kind
600 where
601 kind = Type.substTy (mkTCvSubst in_scope (tv_subst, cv_subst))
602 (tyVarKind tmpl_var1)
603
604 cv_subst = to_co_env id_subst
605
606 to_co_env :: IdSubstEnv -> CvSubstEnv
607 to_co_env env = nonDetFoldUFM_Directly to_co emptyVarEnv env
608 -- It's OK to use nonDetFoldUFM_Directly because we forget the
609 -- order immediately by creating a new env
610
611 to_co uniq expr env
612 = case exprToCoercion_maybe expr of
613 Just co -> extendVarEnv_Directly env uniq co
614 Nothing -> env
615
616 {- Note [Unbound RULE binders]
617 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
618 It can be the case that the binder in a rule is not actually
619 bound on the LHS:
620
621 * Type variables. Type synonyms with phantom args can give rise to
622 unbound template type variables. Consider this (Trac #10689,
623 simplCore/should_compile/T10689):
624
625 type Foo a b = b
626
627 f :: Eq a => a -> Bool
628 f x = x==x
629
630 {-# RULES "foo" forall (x :: Foo a Char). f x = True #-}
631 finkle = f 'c'
632
633 The rule looks like
634 forall (a::*) (d::Eq Char) (x :: Foo a Char).
635 f (Foo a Char) d x = True
636
637 Matching the rule won't bind 'a', and legitimately so. We fudge by
638 pretending that 'a' is bound to (Any :: *).
639
640 * Coercion variables. On the LHS of a RULE for a local binder
641 we might have
642 RULE forall (c :: a~b). f (x |> c) = e
643 Now, if that binding is inlined, so that a=b=Int, we'd get
644 RULE forall (c :: Int~Int). f (x |> c) = e
645 and now when we simplify the LHS (Simplify.simplRule) we
646 optCoercion will turn that 'c' into Refl:
647 RULE forall (c :: Int~Int). f (x |> <Int>) = e
648 and then perhaps drop it altogether. Now 'c' is unbound.
649
650 It's tricky to be sure this never happens, so instead I
651 say it's OK to have an unbound coercion binder in a RULE
652 provided its type is (c :: t~t). Then, when the RULE
653 fires we can substitute <t> for c.
654
655 This actually happened (in a RULE for a local function)
656 in Trac #13410, and also in test T10602.
657
658
659 Note [Cloning the template binders]
660 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
661 Consider the following match (example 1):
662 Template: forall x. f x
663 Target: f (x+1)
664 This should succeed, because the template variable 'x' has nothing to
665 do with the 'x' in the target.
666
667 Likewise this one (example 2):
668 Template: forall x. f (\x.x)
669 Target: f (\y.y)
670
671 We achieve this simply by using rnBndrL to clone the template
672 binders if they are already in scope.
673
674 ------ Historical note -------
675 At one point I tried simply adding the template binders to the
676 in-scope set /without/ cloning them, but that failed in a horribly
677 obscure way in Trac #14777. Problem was that during matching we look
678 up target-term variables in the in-scope set (see Note [Lookup
679 in-scope]). If a target-term variable happens to name-clash with a
680 template variable, that lookup will find the template variable, which
681 is /uttterly/ bogus. In Trac #14777, this transformed a term variable
682 into a type variable, and then crashed when we wanted its idInfo.
683 ------ End of historical note -------
684
685
686 ************************************************************************
687 * *
688 The main matcher
689 * *
690 ********************************************************************* -}
691
692 -- * The domain of the TvSubstEnv and IdSubstEnv are the template
693 -- variables passed into the match.
694 --
695 -- * The BindWrapper in a RuleSubst are the bindings floated out
696 -- from nested matches; see the Let case of match, below
697 --
698 data RuleMatchEnv
699 = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings*
700 -- (lambda/case)
701 , rv_tmpls :: VarSet -- Template variables
702 -- (after applying envL of rv_lcl)
703 , rv_fltR :: Subst -- Renamings for floated let-bindings
704 -- (domain disjoint from envR of rv_lcl)
705 -- See Note [Matching lets]
706 , rv_unf :: IdUnfoldingFun
707 }
708
709 rvInScopeEnv :: RuleMatchEnv -> InScopeEnv
710 rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv)
711
712 data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the
713 , rs_id_subst :: IdSubstEnv -- template variables
714 , rs_binds :: BindWrapper -- Floated bindings
715 , rs_bndrs :: VarSet -- Variables bound by floated lets
716 }
717
718 type BindWrapper = CoreExpr -> CoreExpr
719 -- See Notes [Matching lets] and [Matching cases]
720 -- we represent the floated bindings as a core-to-core function
721
722 emptyRuleSubst :: RuleSubst
723 emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv
724 , rs_binds = \e -> e, rs_bndrs = emptyVarSet }
725
726 -- At one stage I tried to match even if there are more
727 -- template args than real args.
728
729 -- I now think this is probably a bad idea.
730 -- Should the template (map f xs) match (map g)? I think not.
731 -- For a start, in general eta expansion wastes work.
732 -- SLPJ July 99
733
734 match :: RuleMatchEnv
735 -> RuleSubst
736 -> CoreExpr -- Template
737 -> CoreExpr -- Target
738 -> Maybe RuleSubst
739
740 -- We look through certain ticks. See note [Tick annotations in RULE matching]
741 match renv subst e1 (Tick t e2)
742 | tickishFloatable t
743 = match renv subst' e1 e2
744 where subst' = subst { rs_binds = rs_binds subst . mkTick t }
745 match _ _ e@Tick{} _
746 = pprPanic "Tick in rule" (ppr e)
747
748 -- See the notes with Unify.match, which matches types
749 -- Everything is very similar for terms
750
751 -- Interesting examples:
752 -- Consider matching
753 -- \x->f against \f->f
754 -- When we meet the lambdas we must remember to rename f to f' in the
755 -- second expression. The RnEnv2 does that.
756 --
757 -- Consider matching
758 -- forall a. \b->b against \a->3
759 -- We must rename the \a. Otherwise when we meet the lambdas we
760 -- might substitute [a/b] in the template, and then erroneously
761 -- succeed in matching what looks like the template variable 'a' against 3.
762
763 -- The Var case follows closely what happens in Unify.match
764 match renv subst (Var v1) e2
765 = match_var renv subst v1 e2
766
767 match renv subst e1 (Var v2) -- Note [Expanding variables]
768 | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables]
769 , Just e2' <- expandUnfolding_maybe (rv_unf renv v2')
770 = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2'
771 where
772 v2' = lookupRnInScope rn_env v2
773 rn_env = rv_lcl renv
774 -- Notice that we look up v2 in the in-scope set
775 -- See Note [Lookup in-scope]
776 -- No need to apply any renaming first (hence no rnOccR)
777 -- because of the not-inRnEnvR
778
779 match renv subst e1 (Let bind e2)
780 | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $
781 not (isJoinBind bind) -- can't float join point out of argument position
782 , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets]
783 = match (renv { rv_fltR = flt_subst' })
784 (subst { rs_binds = rs_binds subst . Let bind'
785 , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs })
786 e1 e2
787 where
788 flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst)
789 (flt_subst', bind') = substBind flt_subst bind
790 new_bndrs = bindersOf bind'
791
792 {- Disabled: see Note [Matching cases] below
793 match renv (tv_subst, id_subst, binds) e1
794 (Case scrut case_bndr ty [(con, alt_bndrs, rhs)])
795 | exprOkForSpeculation scrut -- See Note [Matching cases]
796 , okToFloat rn_env bndrs (exprFreeVars scrut)
797 = match (renv { me_env = rn_env' })
798 (tv_subst, id_subst, binds . case_wrap)
799 e1 rhs
800 where
801 rn_env = me_env renv
802 rn_env' = extendRnInScopeList rn_env bndrs
803 bndrs = case_bndr : alt_bndrs
804 case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')]
805 -}
806
807 match _ subst (Lit lit1) (Lit lit2)
808 | lit1 == lit2
809 = Just subst
810
811 match renv subst (App f1 a1) (App f2 a2)
812 = do { subst' <- match renv subst f1 f2
813 ; match renv subst' a1 a2 }
814
815 match renv subst (Lam x1 e1) e2
816 | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2
817 = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2
818 , rv_fltR = delBndr (rv_fltR renv) x2 }
819 subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts }
820 in match renv' subst' e1 e2
821
822 match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
823 = do { subst1 <- match_ty renv subst ty1 ty2
824 ; subst2 <- match renv subst1 e1 e2
825 ; let renv' = rnMatchBndr2 renv subst x1 x2
826 ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted
827 }
828
829 match renv subst (Type ty1) (Type ty2)
830 = match_ty renv subst ty1 ty2
831 match renv subst (Coercion co1) (Coercion co2)
832 = match_co renv subst co1 co2
833
834 match renv subst (Cast e1 co1) (Cast e2 co2)
835 = do { subst1 <- match_co renv subst co1 co2
836 ; match renv subst1 e1 e2 }
837
838 -- Everything else fails
839 match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
840 Nothing
841
842 -------------
843 match_co :: RuleMatchEnv
844 -> RuleSubst
845 -> Coercion
846 -> Coercion
847 -> Maybe RuleSubst
848 match_co renv subst co1 co2
849 | Just cv <- getCoVar_maybe co1
850 = match_var renv subst cv (Coercion co2)
851 | Just (ty1, r1) <- isReflCo_maybe co1
852 = do { (ty2, r2) <- isReflCo_maybe co2
853 ; guard (r1 == r2)
854 ; match_ty renv subst ty1 ty2 }
855 match_co renv subst co1 co2
856 | Just (tc1, cos1) <- splitTyConAppCo_maybe co1
857 = case splitTyConAppCo_maybe co2 of
858 Just (tc2, cos2)
859 | tc1 == tc2
860 -> match_cos renv subst cos1 cos2
861 _ -> Nothing
862 match_co renv subst co1 co2
863 | Just (arg1, res1) <- splitFunCo_maybe co1
864 = case splitFunCo_maybe co2 of
865 Just (arg2, res2)
866 -> match_cos renv subst [arg1, res1] [arg2, res2]
867 _ -> Nothing
868 match_co _ _ _co1 _co2
869 -- Currently just deals with CoVarCo, TyConAppCo and Refl
870 #if defined(DEBUG)
871 = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing
872 #else
873 = Nothing
874 #endif
875
876 match_cos :: RuleMatchEnv
877 -> RuleSubst
878 -> [Coercion]
879 -> [Coercion]
880 -> Maybe RuleSubst
881 match_cos renv subst (co1:cos1) (co2:cos2) =
882 do { subst' <- match_co renv subst co1 co2
883 ; match_cos renv subst' cos1 cos2 }
884 match_cos _ subst [] [] = Just subst
885 match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing
886
887 -------------
888 rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv
889 rnMatchBndr2 renv subst x1 x2
890 = renv { rv_lcl = rnBndr2 rn_env x1 x2
891 , rv_fltR = delBndr (rv_fltR renv) x2 }
892 where
893 rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst)
894 -- Typically this is a no-op, but it may matter if
895 -- there are some floated let-bindings
896
897 ------------------------------------------
898 match_alts :: RuleMatchEnv
899 -> RuleSubst
900 -> [CoreAlt] -- Template
901 -> [CoreAlt] -- Target
902 -> Maybe RuleSubst
903 match_alts _ subst [] []
904 = return subst
905 match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
906 | c1 == c2
907 = do { subst1 <- match renv' subst r1 r2
908 ; match_alts renv subst1 alts1 alts2 }
909 where
910 renv' = foldl mb renv (vs1 `zip` vs2)
911 mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2
912
913 match_alts _ _ _ _
914 = Nothing
915
916 ------------------------------------------
917 okToFloat :: RnEnv2 -> VarSet -> Bool
918 okToFloat rn_env bind_fvs
919 = allVarSet not_captured bind_fvs
920 where
921 not_captured fv = not (inRnEnvR rn_env fv)
922
923 ------------------------------------------
924 match_var :: RuleMatchEnv
925 -> RuleSubst
926 -> Var -- Template
927 -> CoreExpr -- Target
928 -> Maybe RuleSubst
929 match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env })
930 subst v1 e2
931 | v1' `elemVarSet` tmpls
932 = match_tmpl_var renv subst v1' e2
933
934 | otherwise -- v1' is not a template variable; check for an exact match with e2
935 = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR
936 Var v2 | v1' == rnOccR rn_env v2
937 -> Just subst
938
939 | Var v2' <- lookupIdSubst (text "match_var") flt_env v2
940 , v1' == v2'
941 -> Just subst
942
943 _ -> Nothing
944
945 where
946 v1' = rnOccL rn_env v1
947 -- If the template is
948 -- forall x. f x (\x -> x) = ...
949 -- Then the x inside the lambda isn't the
950 -- template x, so we must rename first!
951
952 ------------------------------------------
953 match_tmpl_var :: RuleMatchEnv
954 -> RuleSubst
955 -> Var -- Template
956 -> CoreExpr -- Target
957 -> Maybe RuleSubst
958
959 match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env })
960 subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs })
961 v1' e2
962 | any (inRnEnvR rn_env) (exprFreeVarsList e2)
963 = Nothing -- Occurs check failure
964 -- e.g. match forall a. (\x-> a x) against (\y. y y)
965
966 | Just e1' <- lookupVarEnv id_subst v1'
967 = if eqExpr (rnInScopeSet rn_env) e1' e2'
968 then Just subst
969 else Nothing
970
971 | otherwise
972 = -- Note [Matching variable types]
973 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
974 -- However, we must match the *types*; e.g.
975 -- forall (c::Char->Int) (x::Char).
976 -- f (c x) = "RULE FIRED"
977 -- We must only match on args that have the right type
978 -- It's actually quite difficult to come up with an example that shows
979 -- you need type matching, esp since matching is left-to-right, so type
980 -- args get matched first. But it's possible (e.g. simplrun008) and
981 -- this is the Right Thing to do
982 do { subst' <- match_ty renv subst (idType v1') (exprType e2)
983 ; return (subst' { rs_id_subst = id_subst' }) }
984 where
985 -- e2' is the result of applying flt_env to e2
986 e2' | isEmptyVarSet let_bndrs = e2
987 | otherwise = substExpr (text "match_tmpl_var") flt_env e2
988
989 id_subst' = extendVarEnv (rs_id_subst subst) v1' e2'
990 -- No further renaming to do on e2',
991 -- because no free var of e2' is in the rnEnvR of the envt
992
993 ------------------------------------------
994 match_ty :: RuleMatchEnv
995 -> RuleSubst
996 -> Type -- Template
997 -> Type -- Target
998 -> Maybe RuleSubst
999 -- Matching Core types: use the matcher in TcType.
1000 -- Notice that we treat newtypes as opaque. For example, suppose
1001 -- we have a specialised version of a function at a newtype, say
1002 -- newtype T = MkT Int
1003 -- We only want to replace (f T) with f', not (f Int).
1004
1005 match_ty renv subst ty1 ty2
1006 = do { tv_subst'
1007 <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2
1008 ; return (subst { rs_tv_subst = tv_subst' }) }
1009 where
1010 tv_subst = rs_tv_subst subst
1011
1012 {-
1013 Note [Expanding variables]
1014 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1015 Here is another Very Important rule: if the term being matched is a
1016 variable, we expand it so long as its unfolding is "expandable". (Its
1017 occurrence information is not necessarily up to date, so we don't use
1018 it.) By "expandable" we mean a WHNF or a "constructor-like" application.
1019 This is the key reason for "constructor-like" Ids. If we have
1020 {-# NOINLINE [1] CONLIKE g #-}
1021 {-# RULE f (g x) = h x #-}
1022 then in the term
1023 let v = g 3 in ....(f v)....
1024 we want to make the rule fire, to replace (f v) with (h 3).
1025
1026 Note [Do not expand locally-bound variables]
1027 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1028 Do *not* expand locally-bound variables, else there's a worry that the
1029 unfolding might mention variables that are themselves renamed.
1030 Example
1031 case x of y { (p,q) -> ...y... }
1032 Don't expand 'y' to (p,q) because p,q might themselves have been
1033 renamed. Essentially we only expand unfoldings that are "outside"
1034 the entire match.
1035
1036 Hence, (a) the guard (not (isLocallyBoundR v2))
1037 (b) when we expand we nuke the renaming envt (nukeRnEnvR).
1038
1039 Note [Tick annotations in RULE matching]
1040 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1041
1042 We used to unconditionally look through Notes in both template and
1043 expression being matched. This is actually illegal for counting or
1044 cost-centre-scoped ticks, because we have no place to put them without
1045 changing entry counts and/or costs. So now we just fail the match in
1046 these cases.
1047
1048 On the other hand, where we are allowed to insert new cost into the
1049 tick scope, we can float them upwards to the rule application site.
1050
1051 cf Note [Notes in call patterns] in SpecConstr
1052
1053 Note [Matching lets]
1054 ~~~~~~~~~~~~~~~~~~~~
1055 Matching a let-expression. Consider
1056 RULE forall x. f (g x) = <rhs>
1057 and target expression
1058 f (let { w=R } in g E))
1059 Then we'd like the rule to match, to generate
1060 let { w=R } in (\x. <rhs>) E
1061 In effect, we want to float the let-binding outward, to enable
1062 the match to happen. This is the WHOLE REASON for accumulating
1063 bindings in the RuleSubst
1064
1065 We can only do this if the free variables of R are not bound by the
1066 part of the target expression outside the let binding; e.g.
1067 f (\v. let w = v+1 in g E)
1068 Here we obviously cannot float the let-binding for w. Hence the
1069 use of okToFloat.
1070
1071 There are a couple of tricky points.
1072 (a) What if floating the binding captures a variable?
1073 f (let v = x+1 in v) v
1074 --> NOT!
1075 let v = x+1 in f (x+1) v
1076
1077 (b) What if two non-nested let bindings bind the same variable?
1078 f (let v = e1 in b1) (let v = e2 in b2)
1079 --> NOT!
1080 let v = e1 in let v = e2 in (f b2 b2)
1081 See testsuite test "RuleFloatLet".
1082
1083 Our cunning plan is this:
1084 * Along with the growing substitution for template variables
1085 we maintain a growing set of floated let-bindings (rs_binds)
1086 plus the set of variables thus bound.
1087
1088 * The RnEnv2 in the MatchEnv binds only the local binders
1089 in the term (lambdas, case)
1090
1091 * When we encounter a let in the term to be matched, we
1092 check that does not mention any locally bound (lambda, case)
1093 variables. If so we fail
1094
1095 * We use CoreSubst.substBind to freshen the binding, using an
1096 in-scope set that is the original in-scope variables plus the
1097 rs_bndrs (currently floated let-bindings). So in (a) above
1098 we'll freshen the 'v' binding; in (b) above we'll freshen
1099 the *second* 'v' binding.
1100
1101 * We apply that freshening substitution, in a lexically-scoped
1102 way to the term, although lazily; this is the rv_fltR field.
1103
1104
1105 Note [Matching cases]
1106 ~~~~~~~~~~~~~~~~~~~~~
1107 {- NOTE: This idea is currently disabled. It really only works if
1108 the primops involved are OkForSpeculation, and, since
1109 they have side effects readIntOfAddr and touch are not.
1110 Maybe we'll get back to this later . -}
1111
1112 Consider
1113 f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->
1114 case touch# fp s# of { _ ->
1115 I# n# } } )
1116 This happened in a tight loop generated by stream fusion that
1117 Roman encountered. We'd like to treat this just like the let
1118 case, because the primops concerned are ok-for-speculation.
1119 That is, we'd like to behave as if it had been
1120 case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->
1121 case touch# fp s# of { _ ->
1122 f (I# n# } } )
1123
1124 Note [Lookup in-scope]
1125 ~~~~~~~~~~~~~~~~~~~~~~
1126 Consider this example
1127 foo :: Int -> Maybe Int -> Int
1128 foo 0 (Just n) = n
1129 foo m (Just n) = foo (m-n) (Just n)
1130
1131 SpecConstr sees this fragment:
1132
1133 case w_smT of wild_Xf [Just A] {
1134 Data.Maybe.Nothing -> lvl_smf;
1135 Data.Maybe.Just n_acT [Just S(L)] ->
1136 case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->
1137 $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
1138 }};
1139
1140 and correctly generates the rule
1141
1142 RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#
1143 sc_snn :: GHC.Prim.Int#}
1144 $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
1145 = $s$wfoo_sno y_amr sc_snn ;]
1146
1147 BUT we must ensure that this rule matches in the original function!
1148 Note that the call to $wfoo is
1149 $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
1150
1151 During matching we expand wild_Xf to (Just n_acT). But then we must also
1152 expand n_acT to (I# y_amr). And we can only do that if we look up n_acT
1153 in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding
1154 at all.
1155
1156 That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
1157 is so important.
1158
1159
1160 ************************************************************************
1161 * *
1162 Rule-check the program
1163 * *
1164 ************************************************************************
1165
1166 We want to know what sites have rules that could have fired but didn't.
1167 This pass runs over the tree (without changing it) and reports such.
1168 -}
1169
1170 -- | Report partial matches for rules beginning with the specified
1171 -- string for the purposes of error reporting
1172 ruleCheckProgram :: CompilerPhase -- ^ Rule activation test
1173 -> String -- ^ Rule pattern
1174 -> (Id -> [CoreRule]) -- ^ Rules for an Id
1175 -> CoreProgram -- ^ Bindings to check in
1176 -> SDoc -- ^ Resulting check message
1177 ruleCheckProgram phase rule_pat rules binds
1178 | isEmptyBag results
1179 = text "Rule check results: no rule application sites"
1180 | otherwise
1181 = vcat [text "Rule check results:",
1182 line,
1183 vcat [ p $$ line | p <- bagToList results ]
1184 ]
1185 where
1186 env = RuleCheckEnv { rc_is_active = isActive phase
1187 , rc_id_unf = idUnfolding -- Not quite right
1188 -- Should use activeUnfolding
1189 , rc_pattern = rule_pat
1190 , rc_rules = rules }
1191 results = unionManyBags (map (ruleCheckBind env) binds)
1192 line = text (replicate 20 '-')
1193
1194 data RuleCheckEnv = RuleCheckEnv {
1195 rc_is_active :: Activation -> Bool,
1196 rc_id_unf :: IdUnfoldingFun,
1197 rc_pattern :: String,
1198 rc_rules :: Id -> [CoreRule]
1199 }
1200
1201 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
1202 -- The Bag returned has one SDoc for each call site found
1203 ruleCheckBind env (NonRec _ r) = ruleCheck env r
1204 ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs]
1205
1206 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
1207 ruleCheck _ (Var _) = emptyBag
1208 ruleCheck _ (Lit _) = emptyBag
1209 ruleCheck _ (Type _) = emptyBag
1210 ruleCheck _ (Coercion _) = emptyBag
1211 ruleCheck env (App f a) = ruleCheckApp env (App f a) []
1212 ruleCheck env (Tick _ e) = ruleCheck env e
1213 ruleCheck env (Cast e _) = ruleCheck env e
1214 ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
1215 ruleCheck env (Lam _ e) = ruleCheck env e
1216 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
1217 unionManyBags [ruleCheck env r | (_,_,r) <- as]
1218
1219 ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc
1220 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
1221 ruleCheckApp env (Var f) as = ruleCheckFun env f as
1222 ruleCheckApp env other _ = ruleCheck env other
1223
1224 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
1225 -- Produce a report for all rules matching the predicate
1226 -- saying why it doesn't match the specified application
1227
1228 ruleCheckFun env fn args
1229 | null name_match_rules = emptyBag
1230 | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules)
1231 where
1232 name_match_rules = filter match (rc_rules env fn)
1233 match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
1234
1235 ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
1236 ruleAppCheck_help env fn args rules
1237 = -- The rules match the pattern, so we want to print something
1238 vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
1239 vcat (map check_rule rules)]
1240 where
1241 n_args = length args
1242 i_args = args `zip` [1::Int ..]
1243 rough_args = map roughTopName args
1244
1245 check_rule rule = sdocWithDynFlags $ \dflags ->
1246 rule_herald rule <> colon <+> rule_info dflags rule
1247
1248 rule_herald (BuiltinRule { ru_name = name })
1249 = text "Builtin rule" <+> doubleQuotes (ftext name)
1250 rule_herald (Rule { ru_name = name })
1251 = text "Rule" <+> doubleQuotes (ftext name)
1252
1253 rule_info dflags rule
1254 | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env)
1255 noBlackList fn args rough_args rule
1256 = text "matches (which is very peculiar!)"
1257
1258 rule_info _ (BuiltinRule {}) = text "does not match"
1259
1260 rule_info _ (Rule { ru_act = act,
1261 ru_bndrs = rule_bndrs, ru_args = rule_args})
1262 | not (rc_is_active env act) = text "active only in later phase"
1263 | n_args < n_rule_args = text "too few arguments"
1264 | n_mismatches == n_rule_args = text "no arguments match"
1265 | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not"
1266 | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
1267 where
1268 n_rule_args = length rule_args
1269 n_mismatches = length mismatches
1270 mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
1271 not (isJust (match_fn rule_arg arg))]
1272
1273 lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars
1274 match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg
1275 where
1276 in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg)
1277 renv = RV { rv_lcl = mkRnEnv2 in_scope
1278 , rv_tmpls = mkVarSet rule_bndrs
1279 , rv_fltR = mkEmptySubst in_scope
1280 , rv_unf = rc_id_unf env }