2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreRules]{Transformation rules}
7 -- | Functions for collecting together and applying rewrite rules to a module.
8 -- The 'CoreRule' datatype itself is declared elsewhere.
14 emptyRuleBase, mkRuleBase, extendRuleBaseList,
15 unionRuleBase, pprRuleBase,
17 -- ** Checking rule applications
20 -- ** Manipulating 'SpecInfo' rules
21 mkSpecInfo, extendSpecInfo, addSpecInfo,
24 -- * Misc. CoreRule helpers
25 rulesOfBinds, getRules, pprRulesForUser,
27 lookupRule, mkRule, mkLocalRule, roughTopNames
30 #include "HsVersions.h"
32 import CoreSyn -- All of it
33 import OccurAnal ( occurAnalyseExpr )
34 import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )
35 import CoreUtils ( exprType )
36 import PprCore ( pprRules )
37 import Type ( Type, TvSubstEnv, tcEqTypeX )
38 import TcType ( tcSplitTyConApp_maybe )
39 import CoreTidy ( tidyRules )
41 import IdInfo ( SpecInfo( SpecInfo ) )
45 import Name ( Name, NamedThing(..) )
47 import Unify ( ruleMatchTyX, MatchEnv(..) )
48 import BasicTypes ( Activation, CompilerPhase, isActive )
49 import StaticFlags ( opt_PprStyle_Debug )
60 %************************************************************************
62 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
64 %************************************************************************
66 A @CoreRule@ holds details of one rule for an @Id@, which
67 includes its specialisations.
69 For example, if a rule for @f@ contains the mapping:
71 forall a b d. [Type (List a), Type b, Var d] ===> f' a b
73 then when we find an application of f to matching types, we simply replace
74 it by the matching RHS:
76 f (List Int) Bool dict ===> f' Int Bool
78 All the stuff about how many dictionaries to discard, and what types
79 to apply the specialised function to, are handled by the fact that the
80 Rule contains a template for the result of the specialisation.
82 There is one more exciting case, which is dealt with in exactly the same
83 way. If the specialised value is unboxed then it is lifted at its
84 definition site and unlifted at its uses. For example:
86 pi :: forall a. Num a => a
88 might have a specialisation
90 [Int#] ===> (case pi' of Lift pi# -> pi#)
92 where pi' :: Lift Int# is the specialised version of pi.
95 mkLocalRule :: RuleName -> Activation
96 -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
97 -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
98 -- compiled. See also 'CoreSyn.CoreRule'
99 mkLocalRule = mkRule True
101 mkRule :: Bool -> RuleName -> Activation
102 -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
103 -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
104 -- compiled. See also 'CoreSyn.CoreRule'
105 mkRule is_local name act fn bndrs args rhs
106 = Rule { ru_name = name, ru_fn = fn, ru_act = act,
107 ru_bndrs = bndrs, ru_args = args,
108 ru_rhs = occurAnalyseExpr rhs,
109 ru_rough = roughTopNames args,
110 ru_local = is_local }
113 roughTopNames :: [CoreExpr] -> [Maybe Name]
114 -- ^ Find the \"top\" free names of several expressions.
115 -- Such names are either:
117 -- 1. The function finally being applied to in an application chain
118 -- (if that name is a GlobalId: see "Var#globalvslocal"), or
120 -- 2. The 'TyCon' if the expression is a 'Type'
122 -- This is used for the fast-match-check for rules;
123 -- if the top names don't match, the rest can't
124 roughTopNames args = map roughTopName args
126 roughTopName :: CoreExpr -> Maybe Name
127 roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
128 Just (tc,_) -> Just (getName tc)
130 roughTopName (App f _) = roughTopName f
131 roughTopName (Var f) | isGlobalId f = Just (idName f)
132 | otherwise = Nothing
133 roughTopName _ = Nothing
135 ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
136 -- ^ @ruleCantMatch tpl actual@ returns True only if @actual@
137 -- definitely can't match @tpl@ by instantiating @tpl@.
138 -- It's only a one-way match; unlike instance matching we
139 -- don't consider unification.
142 -- @ruleCantMatch [Nothing] [Just n2] = False@
143 -- Reason: a template variable can be instantiated by a constant
145 -- @ruleCantMatch [Just n1] [Nothing] = False@
146 -- Reason: a local variable @v@ in the actuals might [_$_]
148 ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as
149 ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as
150 ruleCantMatch _ _ = False
154 pprRulesForUser :: [CoreRule] -> SDoc
155 -- (a) tidy the rules
156 -- (b) sort them into order based on the rule name
157 -- (c) suppress uniques (unless -dppr-debug is on)
158 -- This combination makes the output stable so we can use in testing
159 -- It's here rather than in PprCore because it calls tidyRules
160 pprRulesForUser rules
161 = withPprStyle defaultUserStyle $
164 tidyRules emptyTidyEnv rules
166 le_rule r1 r2 = ru_name r1 <= ru_name r2
170 %************************************************************************
172 SpecInfo: the rules in an IdInfo
174 %************************************************************************
177 -- | Make a 'SpecInfo' containing a number of 'CoreRule's, suitable
178 -- for putting into an 'IdInfo'
179 mkSpecInfo :: [CoreRule] -> SpecInfo
180 mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules)
182 extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
183 extendSpecInfo (SpecInfo rs1 fvs1) rs2
184 = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
186 addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
187 addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2)
188 = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
190 addIdSpecialisations :: Id -> [CoreRule] -> Id
191 addIdSpecialisations id []
193 addIdSpecialisations id rules
194 = setIdSpecialisation id $
195 extendSpecInfo (idSpecialisation id) rules
197 -- | Gather all the rules for locally bound identifiers from the supplied bindings
198 rulesOfBinds :: [CoreBind] -> [CoreRule]
199 rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
201 getRules :: RuleBase -> Id -> [CoreRule]
202 -- See Note [Where rules are found]
203 getRules rule_base fn
204 = idCoreRules fn ++ imp_rules
206 imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []
209 Note [Where rules are found]
210 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
211 The rules for an Id come from two places:
212 (a) the ones it is born with, stored inside the Id iself (idCoreRules fn),
213 (b) rules added in other modules, stored in the global RuleBase (imp_rules)
215 It's tempting to think that
216 - LocalIds have only (a)
217 - non-LocalIds have only (b)
219 but that isn't quite right:
221 - PrimOps and ClassOps are born with a bunch of rules inside the Id,
222 even when they are imported
224 - The rules in PrelRules.builtinRules should be active even
225 in the module defining the Id (when it's a LocalId), but
226 the rules are kept in the global RuleBase
229 %************************************************************************
233 %************************************************************************
236 -- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules
237 type RuleBase = NameEnv [CoreRule]
238 -- The rules are are unordered;
239 -- we sort out any overlaps on lookup
241 emptyRuleBase :: RuleBase
242 emptyRuleBase = emptyNameEnv
244 mkRuleBase :: [CoreRule] -> RuleBase
245 mkRuleBase rules = extendRuleBaseList emptyRuleBase rules
247 extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
248 extendRuleBaseList rule_base new_guys
249 = foldl extendRuleBase rule_base new_guys
251 unionRuleBase :: RuleBase -> RuleBase -> RuleBase
252 unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2
254 extendRuleBase :: RuleBase -> CoreRule -> RuleBase
255 extendRuleBase rule_base rule
256 = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule
258 pprRuleBase :: RuleBase -> SDoc
259 pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
260 | rs <- nameEnvElts rules ]
264 %************************************************************************
266 \subsection{Matching}
268 %************************************************************************
270 Note [Extra args in rule matching]
271 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
272 If we find a matching rule, we return (Just (rule, rhs)),
273 but the rule firing has only consumed as many of the input args
274 as the ruleArity says. It's up to the caller to keep track
275 of any left-over args. E.g. if you call
276 lookupRule ... f [e1, e2, e3]
277 and it returns Just (r, rhs), where r has ruleArity 2
278 then the real rewrite is
279 f e1 e2 e3 ==> rhs e3
281 You might think it'd be cleaner for lookupRule to deal with the
282 leftover arguments, by applying 'rhs' to them, but the main call
283 in the Simplifier works better as it is. Reason: the 'args' passed
284 to lookupRule are the result of a lazy substitution
287 -- | The main rule matching function. Attempts to apply all (active)
288 -- supplied rules to this instance of an application in a given
289 -- context, returning the rule applied and the resulting expression if
291 lookupRule :: (Activation -> Bool) -- When rule is active
292 -> IdUnfoldingFun -- When Id can be unfolded
295 -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
297 -- See Note [Extra args in rule matching]
298 -- See comments on matchRule
299 lookupRule is_active id_unf in_scope fn args rules
300 = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
303 (m:ms) -> Just (findBest (fn,args) m ms)
305 rough_args = map roughTopName args
307 go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
309 go ms (r:rs) = case (matchRule is_active id_unf in_scope args rough_args r) of
310 Just e -> go ((r,e):ms) rs
311 Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$
312 -- ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] )
315 findBest :: (Id, [CoreExpr])
316 -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
317 -- All these pairs matched the expression
318 -- Return the pair the the most specific rule
319 -- The (fn,args) is just for overlap reporting
321 findBest _ (rule,ans) [] = (rule,ans)
322 findBest target (rule1,ans1) ((rule2,ans2):prs)
323 | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
324 | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
325 | debugIsOn = let pp_rule rule
326 | opt_PprStyle_Debug = ppr rule
327 | otherwise = doubleQuotes (ftext (ru_name rule))
328 in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
329 (vcat [if opt_PprStyle_Debug then
330 ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args)
332 ptext (sLit "Rule 1:") <+> pp_rule rule1,
333 ptext (sLit "Rule 2:") <+> pp_rule rule2]) $
334 findBest target (rule1,ans1) prs
335 | otherwise = findBest target (rule1,ans1) prs
339 isMoreSpecific :: CoreRule -> CoreRule -> Bool
340 isMoreSpecific (BuiltinRule {}) _ = True
341 isMoreSpecific _ (BuiltinRule {}) = False
342 isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
343 (Rule { ru_bndrs = bndrs2, ru_args = args2 })
344 = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1)
346 id_unfolding_fun _ = NoUnfolding -- Don't expand in templates
347 in_scope = mkInScopeSet (mkVarSet bndrs1)
348 -- Actually we should probably include the free vars
349 -- of rule1's args, but I can't be bothered
351 noBlackList :: Activation -> Bool
352 noBlackList _ = False -- Nothing is black listed
354 matchRule :: (Activation -> Bool) -> IdUnfoldingFun
356 -> [CoreExpr] -> [Maybe Name]
357 -> CoreRule -> Maybe CoreExpr
359 -- If (matchRule rule args) returns Just (name,rhs)
360 -- then (f args) matches the rule, and the corresponding
361 -- rewritten RHS is rhs
363 -- The bndrs and rhs is occurrence-analysed
368 -- forall f g x. map f (map g x) ==> map (f . g) x
370 -- CoreRule "map/map"
371 -- [f,g,x] -- tpl_vars
372 -- [f,map g x] -- tpl_args
373 -- map (f.g) x) -- rhs
375 -- Then the call: matchRule the_rule [e1,map e2 e3]
376 -- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
378 -- Any 'surplus' arguments in the input are simply put on the end
381 matchRule _is_active id_unf _in_scope args _rough_args
382 (BuiltinRule { ru_try = match_fn })
383 -- Built-in rules can't be switched off, it seems
384 = case match_fn id_unf args of
385 Just expr -> Just expr
388 matchRule is_active id_unf in_scope args rough_args
389 (Rule { ru_act = act, ru_rough = tpl_tops,
390 ru_bndrs = tpl_vars, ru_args = tpl_args,
392 | not (is_active act) = Nothing
393 | ruleCantMatch tpl_tops rough_args = Nothing
395 = case matchN id_unf in_scope tpl_vars tpl_args args of
397 Just (binds, tpl_vals) -> Just (mkLets binds $
398 rule_fn `mkApps` tpl_vals)
400 rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
401 -- We could do this when putting things into the rulebase, I guess
405 -- For a given match template and context, find bindings to wrap around
406 -- the entire result and what should be substituted for each template variable.
407 -- Fail if there are two few actual arguments from the target to match the template
408 matchN :: IdUnfoldingFun
409 -> InScopeSet -- ^ In-scope variables
410 -> [Var] -- ^ Match template type variables
411 -> [CoreExpr] -- ^ Match template
412 -> [CoreExpr] -- ^ Target; can have more elements than the template
413 -> Maybe ([CoreBind],
416 matchN id_unf in_scope tmpl_vars tmpl_es target_es
417 = do { (tv_subst, id_subst, binds)
418 <- go init_menv emptySubstEnv tmpl_es target_es
419 ; return (fromOL binds,
420 map (lookup_tmpl tv_subst id_subst) tmpl_vars') }
422 (init_rn_env, tmpl_vars') = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars
423 -- See Note [Template binders]
425 init_menv = ME { me_tmpls = mkVarSet tmpl_vars', me_env = init_rn_env }
427 go _ subst [] _ = Just subst
428 go _ _ _ [] = Nothing -- Fail if too few actual args
429 go menv subst (t:ts) (e:es) = do { subst1 <- match id_unf menv subst t e
430 ; go menv subst1 ts es }
432 lookup_tmpl :: TvSubstEnv -> IdSubstEnv -> Var -> CoreExpr
433 lookup_tmpl tv_subst id_subst tmpl_var'
434 | isTyVar tmpl_var' = case lookupVarEnv tv_subst tmpl_var' of
436 Nothing -> unbound tmpl_var'
437 | otherwise = case lookupVarEnv id_subst tmpl_var' of
439 _ -> unbound tmpl_var'
441 unbound var = pprPanic "Template variable unbound in rewrite rule"
442 (ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es)
445 Note [Template binders]
446 ~~~~~~~~~~~~~~~~~~~~~~~
447 Consider the following match:
448 Template: forall x. f x
450 This should succeed, because the template variable 'x' has
451 nothing to do with the 'x' in the target.
453 On reflection, this case probably does just work, but this might not
454 Template: forall x. f (\x.x)
456 Here we want to clone when we find the \x, but to know that x must be in scope
458 To achive this, we use rnBndrL to rename the template variables if
459 necessary; the renamed ones are the tmpl_vars'
462 ---------------------------------------------
463 The inner workings of matching
464 ---------------------------------------------
467 -- These two definitions are not the same as in Subst,
468 -- but they simple and direct, and purely local to this module
470 -- * The domain of the TvSubstEnv and IdSubstEnv are the template
471 -- variables passed into the match.
473 -- * The (OrdList CoreBind) in a SubstEnv are the bindings floated out
474 -- from nested matches; see the Let case of match, below
476 type SubstEnv = (TvSubstEnv, IdSubstEnv, OrdList CoreBind)
477 type IdSubstEnv = IdEnv CoreExpr
479 emptySubstEnv :: SubstEnv
480 emptySubstEnv = (emptyVarEnv, emptyVarEnv, nilOL)
483 -- At one stage I tried to match even if there are more
484 -- template args than real args.
486 -- I now think this is probably a bad idea.
487 -- Should the template (map f xs) match (map g)? I think not.
488 -- For a start, in general eta expansion wastes work.
492 match :: IdUnfoldingFun
495 -> CoreExpr -- Template
496 -> CoreExpr -- Target
499 -- See the notes with Unify.match, which matches types
500 -- Everything is very similar for terms
502 -- Interesting examples:
504 -- \x->f against \f->f
505 -- When we meet the lambdas we must remember to rename f to f' in the
506 -- second expresion. The RnEnv2 does that.
509 -- forall a. \b->b against \a->3
510 -- We must rename the \a. Otherwise when we meet the lambdas we
511 -- might substitute [a/b] in the template, and then erroneously
512 -- succeed in matching what looks like the template variable 'a' against 3.
514 -- The Var case follows closely what happens in Unify.match
515 match idu menv subst (Var v1) e2
516 | Just subst <- match_var idu menv subst v1 e2
519 match idu menv subst (Note _ e1) e2 = match idu menv subst e1 e2
520 match idu menv subst e1 (Note _ e2) = match idu menv subst e1 e2
521 -- Ignore notes in both template and thing to be matched
522 -- See Note [Notes in RULE matching]
524 match id_unfolding_fun menv subst e1 (Var v2) -- Note [Expanding variables]
525 | not (locallyBoundR rn_env v2) -- Note [Do not expand locally-bound variables]
526 , Just e2' <- expandUnfolding (id_unfolding_fun v2')
527 = match id_unfolding_fun (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2'
529 v2' = lookupRnInScope rn_env v2
531 -- Notice that we look up v2 in the in-scope set
532 -- See Note [Lookup in-scope]
533 -- No need to apply any renaming first (hence no rnOccR)
534 -- becuase of the not-locallyBoundR
536 match idu menv (tv_subst, id_subst, binds) e1 (Let bind e2)
537 | all freshly_bound bndrs -- See Note [Matching lets]
538 , not (any (locallyBoundR rn_env) bind_fvs)
539 = match idu (menv { me_env = rn_env' })
540 (tv_subst, id_subst, binds `snocOL` bind')
544 bndrs = bindersOf bind
545 bind_fvs = varSetElems (bindFreeVars bind)
546 freshly_bound x = not (x `rnInScope` rn_env)
549 rn_env' = extendRnInScopeList rn_env bndrs
551 match _ _ subst (Lit lit1) (Lit lit2)
555 match idu menv subst (App f1 a1) (App f2 a2)
556 = do { subst' <- match idu menv subst f1 f2
557 ; match idu menv subst' a1 a2 }
559 match idu menv subst (Lam x1 e1) (Lam x2 e2)
560 = match idu menv' subst e1 e2
562 menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
564 -- This rule does eta expansion
565 -- (\x.M) ~ N iff M ~ N x
566 -- It's important that this is *after* the let rule,
567 -- so that (\x.M) ~ (let y = e in \y.N)
568 -- does the let thing, and then gets the lam/lam rule above
569 match idu menv subst (Lam x1 e1) e2
570 = match idu menv' subst e1 (App e2 (varToCoreExpr new_x))
572 (rn_env', new_x) = rnBndrL (me_env menv) x1
573 menv' = menv { me_env = rn_env' }
575 -- Eta expansion the other way
576 -- M ~ (\y.N) iff M y ~ N
577 match idu menv subst e1 (Lam x2 e2)
578 = match idu menv' subst (App e1 (varToCoreExpr new_x)) e2
580 (rn_env', new_x) = rnBndrR (me_env menv) x2
581 menv' = menv { me_env = rn_env' }
583 match idu menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
584 = do { subst1 <- match_ty menv subst ty1 ty2
585 ; subst2 <- match idu menv subst1 e1 e2
586 ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
587 ; match_alts idu menv' subst2 alts1 alts2 -- Alts are both sorted
590 match _ menv subst (Type ty1) (Type ty2)
591 = match_ty menv subst ty1 ty2
593 match idu menv subst (Cast e1 co1) (Cast e2 co2)
594 = do { subst1 <- match_ty menv subst co1 co2
595 ; match idu menv subst1 e1 e2 }
597 -- Everything else fails
598 match _ _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
601 ------------------------------------------
602 match_var :: IdUnfoldingFun
606 -> CoreExpr -- Target
608 match_var idu menv subst@(tv_subst, id_subst, binds) v1 e2
609 | v1' `elemVarSet` me_tmpls menv
610 = case lookupVarEnv id_subst v1' of
611 Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
612 -> Nothing -- Occurs check failure
613 -- e.g. match forall a. (\x-> a x) against (\y. y y)
615 | otherwise -- No renaming to do on e2, because no free var
616 -- of e2 is in the rnEnvR of the envt
617 -- Note [Matching variable types]
618 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
619 -- However, we must match the *types*; e.g.
620 -- forall (c::Char->Int) (x::Char).
621 -- f (c x) = "RULE FIRED"
622 -- We must only match on args that have the right type
623 -- It's actually quite difficult to come up with an example that shows
624 -- you need type matching, esp since matching is left-to-right, so type
625 -- args get matched first. But it's possible (e.g. simplrun008) and
626 -- this is the Right Thing to do
627 -> do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst (idType v1') (exprType e2)
628 -- c.f. match_ty below
629 ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) }
631 Just e1' | eqExpr idu (nukeRnEnvL rn_env) e1' e2
637 | otherwise -- v1 is not a template variable; check for an exact match with e2
639 Var v2 | v1' == rnOccR rn_env v2 -> Just subst
644 v1' = rnOccL rn_env v1
645 -- If the template is
646 -- forall x. f x (\x -> x) = ...
647 -- Then the x inside the lambda isn't the
648 -- template x, so we must rename first!
651 ------------------------------------------
652 match_alts :: IdUnfoldingFun
655 -> [CoreAlt] -- Template
656 -> [CoreAlt] -- Target
658 match_alts _ _ subst [] []
660 match_alts idu menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
662 = do { subst1 <- match idu menv' subst r1 r2
663 ; match_alts idu menv subst1 alts1 alts2 }
666 menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 }
672 Matching Core types: use the matcher in TcType.
673 Notice that we treat newtypes as opaque. For example, suppose
674 we have a specialised version of a function at a newtype, say
676 We only want to replace (f T) with f', not (f Int).
679 ------------------------------------------
685 match_ty menv (tv_subst, id_subst, binds) ty1 ty2
686 = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
687 ; return (tv_subst', id_subst, binds) }
690 Note [Expanding variables]
691 ~~~~~~~~~~~~~~~~~~~~~~~~~~
692 Here is another Very Important rule: if the term being matched is a
693 variable, we expand it so long as its unfolding is "expandable". (Its
694 occurrence information is not necessarily up to date, so we don't use
695 it.) By "expandable" we mean a WHNF or a "constructor-like" application.
696 This is the key reason for "constructor-like" Ids. If we have
697 {-# NOINLINE [1] CONLIKE g #-}
698 {-# RULE f (g x) = h x #-}
700 let v = g 3 in ....(f v)....
701 we want to make the rule fire, to replace (f v) with (h 3).
703 Note [Do not expand locally-bound variables]
704 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
705 Do *not* expand locally-bound variables, else there's a worry that the
706 unfolding might mention variables that are themselves renamed.
708 case x of y { (p,q) -> ...y... }
709 Don't expand 'y' to (p,q) because p,q might themselves have been
710 renamed. Essentially we only expand unfoldings that are "outside"
713 Hence, (a) the guard (not (isLocallyBoundR v2))
714 (b) when we expand we nuke the renaming envt (nukeRnEnvR).
716 Note [Notes in RULE matching]
717 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
718 Look through Notes in both template and expression being matched. In
719 particular, we don't want to be confused by InlineMe notes. Maybe we
720 should be more careful about profiling notes, but for now I'm just
721 riding roughshod over them. cf Note [Notes in call patterns] in
726 Matching a let-expression. Consider
727 RULE forall x. f (g x) = <rhs>
728 and target expression
729 f (let { w=R } in g E))
730 Then we'd like the rule to match, to generate
731 let { w=R } in (\x. <rhs>) E
732 In effect, we want to float the let-binding outward, to enable
733 the match to happen. This is the WHOLE REASON for accumulating
734 bindings in the SubstEnv
736 We can only do this if
737 (a) Widening the scope of w does not capture any variables
738 We use a conservative test: w is not already in scope
739 If not, we clone the binders, and substitute
740 (b) The free variables of R are not bound by the part of the
741 target expression outside the let binding; e.g.
742 f (\v. let w = v+1 in g E)
743 Here we obviously cannot float the let-binding for w.
745 You may think rule (a) would never apply, because rule matching is
746 mostly invoked from the simplifier, when we have just run substExpr
747 over the argument, so there will be no shadowing anyway.
748 The fly in the ointment is that the forall'd variables of the
749 RULE itself are considered in scope.
751 I though of various ways to solve (a). One plan was to
752 clone the binders if they are in scope. But watch out!
753 (let x=y+1 in let z=x+1 in (z,z)
754 --> should match (p,p) but watch out that
755 the use of x on z's rhs is OK!
756 If we clone x, then the let-binding for 'z' is then caught by (b),
757 at least unless we elaborate the RnEnv stuff a bit.
759 So for we simply fail to match unless both (a) and (b) hold.
761 Other cases to think about
762 (let x=y+1 in \x. (x,x))
763 --> let x=y+1 in (\x1. (x1,x1))
764 (\x. let x = y+1 in (x,x))
765 --> let x1 = y+1 in (\x. (x1,x1)
766 (let x=y+1 in (x,x), let x=y-1 in (x,x))
767 --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1))
770 Note [Lookup in-scope]
771 ~~~~~~~~~~~~~~~~~~~~~~
772 Consider this example
773 foo :: Int -> Maybe Int -> Int
775 foo m (Just n) = foo (m-n) (Just n)
777 SpecConstr sees this fragment:
779 case w_smT of wild_Xf [Just A] {
780 Data.Maybe.Nothing -> lvl_smf;
781 Data.Maybe.Just n_acT [Just S(L)] ->
782 case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->
783 \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
786 and correctly generates the rule
788 RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#
789 sc_snn :: GHC.Prim.Int#}
790 \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
791 = \$s\$wfoo_sno y_amr sc_snn ;]
793 BUT we must ensure that this rule matches in the original function!
794 Note that the call to \$wfoo is
795 \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
797 During matching we expand wild_Xf to (Just n_acT). But then we must also
798 expand n_acT to (I# y_amr). And we can only do that if we look up n_acT
799 in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding
802 That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
806 eqExpr :: IdUnfoldingFun -> RnEnv2 -> CoreExpr -> CoreExpr -> Bool
807 -- ^ A kind of shallow equality used in rule matching, so does
808 -- /not/ look through newtypes or predicate types
810 eqExpr _ env (Var v1) (Var v2)
811 | rnOccL env v1 == rnOccR env v2
814 -- The next two rules expand non-local variables
815 -- C.f. Note [Expanding variables]
816 -- and Note [Do not expand locally-bound variables]
817 eqExpr id_unfolding_fun env (Var v1) e2
818 | not (locallyBoundL env v1)
819 , Just e1' <- expandUnfolding (id_unfolding_fun (lookupRnInScope env v1))
820 = eqExpr id_unfolding_fun (nukeRnEnvL env) e1' e2
822 eqExpr id_unfolding_fun env e1 (Var v2)
823 | not (locallyBoundR env v2)
824 , Just e2' <- expandUnfolding (id_unfolding_fun (lookupRnInScope env v2))
825 = eqExpr id_unfolding_fun (nukeRnEnvR env) e1 e2'
827 eqExpr _ _ (Lit lit1) (Lit lit2) = lit1 == lit2
828 eqExpr idu env (App f1 a1) (App f2 a2) = eqExpr idu env f1 f2 && eqExpr idu env a1 a2
829 eqExpr idu env (Lam v1 e1) (Lam v2 e2) = eqExpr idu (rnBndr2 env v1 v2) e1 e2
830 eqExpr idu env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eqExpr idu env e1 e2
831 eqExpr idu env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && eqExpr idu env e1 e2
832 eqExpr _ env (Type t1) (Type t2) = tcEqTypeX env t1 t2
834 eqExpr idu env (Let (NonRec v1 r1) e1)
835 (Let (NonRec v2 r2) e2) = eqExpr idu env r1 r2
836 && eqExpr idu (rnBndr2 env v1 v2) e1 e2
837 eqExpr idu env (Let (Rec ps1) e1)
838 (Let (Rec ps2) e2) = equalLength ps1 ps2
839 && and (zipWith eq_rhs ps1 ps2)
840 && eqExpr idu env' e1 e2
842 env' = foldl2 rn_bndr2 env ps2 ps2
843 rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
844 eq_rhs (_,r1) (_,r2) = eqExpr idu env' r1 r2
845 eqExpr idu env (Case e1 v1 t1 a1)
846 (Case e2 v2 t2 a2) = eqExpr idu env e1 e2
847 && tcEqTypeX env t1 t2
849 && and (zipWith eq_alt a1 a2)
851 env' = rnBndr2 env v1 v2
852 eq_alt (c1,vs1,r1) (c2,vs2,r2)
853 = c1==c2 && eqExpr idu (rnBndrs2 env' vs1 vs2) r1 r2
854 eqExpr _ _ _ _ = False
856 eq_note :: RnEnv2 -> Note -> Note -> Bool
857 eq_note _ (SCC cc1) (SCC cc2) = cc1 == cc2
858 eq_note _ (CoreNote s1) (CoreNote s2) = s1 == s2
859 eq_note _ _ _ = False
865 locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool
866 locallyBoundL rn_env v = inRnEnvL rn_env v
867 locallyBoundR rn_env v = inRnEnvR rn_env v
870 expandUnfolding :: Unfolding -> Maybe CoreExpr
871 expandUnfolding unfolding
872 | isExpandableUnfolding unfolding = Just (unfoldingTemplate unfolding)
873 | otherwise = Nothing
876 %************************************************************************
878 Rule-check the program
880 %************************************************************************
882 We want to know what sites have rules that could have fired but didn't.
883 This pass runs over the tree (without changing it) and reports such.
886 -- | Report partial matches for rules beginning with the specified
887 -- string for the purposes of error reporting
888 ruleCheckProgram :: CompilerPhase -- ^ Rule activation test
889 -> String -- ^ Rule pattern
890 -> RuleBase -- ^ Database of rules
891 -> [CoreBind] -- ^ Bindings to check in
892 -> SDoc -- ^ Resulting check message
893 ruleCheckProgram phase rule_pat rule_base binds
895 = text "Rule check results: no rule application sites"
897 = vcat [text "Rule check results:",
899 vcat [ p $$ line | p <- bagToList results ]
902 env = RuleCheckEnv { rc_is_active = isActive phase
903 , rc_id_unf = idUnfolding -- Not quite right
904 -- Should use activeUnfolding
905 , rc_pattern = rule_pat
906 , rc_rule_base = rule_base }
907 results = unionManyBags (map (ruleCheckBind env) binds)
908 line = text (replicate 20 '-')
910 data RuleCheckEnv = RuleCheckEnv {
911 rc_is_active :: Activation -> Bool,
912 rc_id_unf :: IdUnfoldingFun,
913 rc_pattern :: String,
914 rc_rule_base :: RuleBase
917 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
918 -- The Bag returned has one SDoc for each call site found
919 ruleCheckBind env (NonRec _ r) = ruleCheck env r
920 ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs]
922 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
923 ruleCheck _ (Var _) = emptyBag
924 ruleCheck _ (Lit _) = emptyBag
925 ruleCheck _ (Type _) = emptyBag
926 ruleCheck env (App f a) = ruleCheckApp env (App f a) []
927 ruleCheck env (Note _ e) = ruleCheck env e
928 ruleCheck env (Cast e _) = ruleCheck env e
929 ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
930 ruleCheck env (Lam _ e) = ruleCheck env e
931 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
932 unionManyBags [ruleCheck env r | (_,_,r) <- as]
934 ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc
935 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
936 ruleCheckApp env (Var f) as = ruleCheckFun env f as
937 ruleCheckApp env other _ = ruleCheck env other
941 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
942 -- Produce a report for all rules matching the predicate
943 -- saying why it doesn't match the specified application
945 ruleCheckFun env fn args
946 | null name_match_rules = emptyBag
947 | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules)
949 name_match_rules = filter match (getRules (rc_rule_base env) fn)
950 match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
952 ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
953 ruleAppCheck_help env fn args rules
954 = -- The rules match the pattern, so we want to print something
955 vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
956 vcat (map check_rule rules)]
959 i_args = args `zip` [1::Int ..]
960 rough_args = map roughTopName args
962 check_rule rule = rule_herald rule <> colon <+> rule_info rule
964 rule_herald (BuiltinRule { ru_name = name })
965 = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name)
966 rule_herald (Rule { ru_name = name })
967 = ptext (sLit "Rule") <+> doubleQuotes (ftext name)
970 | Just _ <- matchRule noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule
971 = text "matches (which is very peculiar!)"
973 rule_info (BuiltinRule {}) = text "does not match"
975 rule_info (Rule { ru_act = act,
976 ru_bndrs = rule_bndrs, ru_args = rule_args})
977 | not (rc_is_active env act) = text "active only in later phase"
978 | n_args < n_rule_args = text "too few arguments"
979 | n_mismatches == n_rule_args = text "no arguments match"
980 | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not"
981 | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
983 n_rule_args = length rule_args
984 n_mismatches = length mismatches
985 mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
986 not (isJust (match_fn rule_arg arg))]
988 lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars
989 match_fn rule_arg arg = match (rc_id_unf env) menv emptySubstEnv rule_arg arg
991 in_scope = lhs_fvs `unionVarSet` exprFreeVars arg
992 menv = ME { me_env = mkRnEnv2 (mkInScopeSet in_scope)
993 , me_tmpls = mkVarSet rule_bndrs }