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, eqExprX )
36 import PprCore ( pprRules )
37 import Type ( Type, TvSubstEnv )
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 Note [Overall plumbing for rules]
61 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
63 * The ModGuts initially contains mg_rules :: [CoreRule] of rules
64 declared in this module. During the core-to-core pipeline,
65 locally-declared rules for locally-declared Ids are attached to the
66 IdInfo for that Id, so the mg_rules field of ModGuts now only
67 contains locally-declared rules for *imported* Ids. TidyPgm restores
68 the original setup, so that the ModGuts again has *all* the
69 locally-declared rules. See Note [Attach rules to local ids] in
72 * The HomePackageTable contains a ModDetails for each home package
73 module. Each contains md_rules :: [CoreRule] of rules declared in
74 that module. The HomePackageTable grows as ghc --make does its
75 up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules
76 are treated by the "external" route, discussed next, regardless of
77 which package they come from.
79 * The ExternalPackageState has a single eps_rule_base :: RuleBase for
80 Ids in other packages. This RuleBase simply grow monotonically, as
81 ghc --make compiles one module after another.
83 During simplification, interface files may get demand-loaded,
84 as the simplifier explores the unfoldings for Ids it has in
85 its hand. (Via an unsafePerformIO; the EPS is really a cache.)
86 That in turn may make the EPS rule-base grow. In contrast, the
87 HPT never grows in this way.
89 * The result of all this is that during Core-to-Core optimisation
90 there are four sources of rules:
92 (a) Rules in the IdInfo of the Id they are a rule for. These are
93 easy: fast to look up, and if you apply a substitution then
94 it'll be applied to the IdInfo as a matter of course.
96 (b) Rules declared in this module for imported Ids, kept in the
97 ModGuts. If you do a substitution, you'd better apply the
98 substitution to these. There are seldom many of these.
100 (c) Rules declared in the HomePackageTable. These never change.
102 (d) Rules in the ExternalPackageTable. These can grow in response
103 to lazy demand-loading of interfaces.
105 * At the moment (c) is carried in a reader-monad way by the CoreMonad.
106 The HomePackageTable doesn't have a single RuleBase because technically
107 we should only be able to "see" rules "below" this module; so we
108 generate a RuleBase for (c) by combing rules from all the modules
109 "below" us. That's whye we can't just select the home-package RuleBase
112 [NB: we are inconsistent here. We should do the same for external
113 pacakges, but we don't. Same for type-class instances.]
115 * So in the outer simplifier loop, we combine (b-d) into a single
117 (b) from the ModGuts,
118 (c) from the CoreMonad, and
119 (d) from its mutable variable
120 [Of coures this means that we won't see new EPS rules that come in
121 during a single simplifier iteration, but that probably does not
125 %************************************************************************
127 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
129 %************************************************************************
131 A @CoreRule@ holds details of one rule for an @Id@, which
132 includes its specialisations.
134 For example, if a rule for @f@ contains the mapping:
136 forall a b d. [Type (List a), Type b, Var d] ===> f' a b
138 then when we find an application of f to matching types, we simply replace
139 it by the matching RHS:
141 f (List Int) Bool dict ===> f' Int Bool
143 All the stuff about how many dictionaries to discard, and what types
144 to apply the specialised function to, are handled by the fact that the
145 Rule contains a template for the result of the specialisation.
147 There is one more exciting case, which is dealt with in exactly the same
148 way. If the specialised value is unboxed then it is lifted at its
149 definition site and unlifted at its uses. For example:
151 pi :: forall a. Num a => a
153 might have a specialisation
155 [Int#] ===> (case pi' of Lift pi# -> pi#)
157 where pi' :: Lift Int# is the specialised version of pi.
160 mkLocalRule :: RuleName -> Activation
161 -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
162 -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
163 -- compiled. See also 'CoreSyn.CoreRule'
164 mkLocalRule = mkRule True
166 mkRule :: Bool -> RuleName -> Activation
167 -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
168 -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
169 -- compiled. See also 'CoreSyn.CoreRule'
170 mkRule is_local name act fn bndrs args rhs
171 = Rule { ru_name = name, ru_fn = fn, ru_act = act,
172 ru_bndrs = bndrs, ru_args = args,
173 ru_rhs = occurAnalyseExpr rhs,
174 ru_rough = roughTopNames args,
175 ru_local = is_local }
178 roughTopNames :: [CoreExpr] -> [Maybe Name]
179 -- ^ Find the \"top\" free names of several expressions.
180 -- Such names are either:
182 -- 1. The function finally being applied to in an application chain
183 -- (if that name is a GlobalId: see "Var#globalvslocal"), or
185 -- 2. The 'TyCon' if the expression is a 'Type'
187 -- This is used for the fast-match-check for rules;
188 -- if the top names don't match, the rest can't
189 roughTopNames args = map roughTopName args
191 roughTopName :: CoreExpr -> Maybe Name
192 roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
193 Just (tc,_) -> Just (getName tc)
195 roughTopName (App f _) = roughTopName f
196 roughTopName (Var f) | isGlobalId f = Just (idName f)
197 | otherwise = Nothing
198 roughTopName _ = Nothing
200 ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
201 -- ^ @ruleCantMatch tpl actual@ returns True only if @actual@
202 -- definitely can't match @tpl@ by instantiating @tpl@.
203 -- It's only a one-way match; unlike instance matching we
204 -- don't consider unification.
207 -- @ruleCantMatch [Nothing] [Just n2] = False@
208 -- Reason: a template variable can be instantiated by a constant
210 -- @ruleCantMatch [Just n1] [Nothing] = False@
211 -- Reason: a local variable @v@ in the actuals might [_$_]
213 ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as
214 ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as
215 ruleCantMatch _ _ = False
219 pprRulesForUser :: [CoreRule] -> SDoc
220 -- (a) tidy the rules
221 -- (b) sort them into order based on the rule name
222 -- (c) suppress uniques (unless -dppr-debug is on)
223 -- This combination makes the output stable so we can use in testing
224 -- It's here rather than in PprCore because it calls tidyRules
225 pprRulesForUser rules
226 = withPprStyle defaultUserStyle $
229 tidyRules emptyTidyEnv rules
231 le_rule r1 r2 = ru_name r1 <= ru_name r2
235 %************************************************************************
237 SpecInfo: the rules in an IdInfo
239 %************************************************************************
242 -- | Make a 'SpecInfo' containing a number of 'CoreRule's, suitable
243 -- for putting into an 'IdInfo'
244 mkSpecInfo :: [CoreRule] -> SpecInfo
245 mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules)
247 extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
248 extendSpecInfo (SpecInfo rs1 fvs1) rs2
249 = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
251 addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
252 addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2)
253 = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
255 addIdSpecialisations :: Id -> [CoreRule] -> Id
256 addIdSpecialisations id []
258 addIdSpecialisations id rules
259 = setIdSpecialisation id $
260 extendSpecInfo (idSpecialisation id) rules
262 -- | Gather all the rules for locally bound identifiers from the supplied bindings
263 rulesOfBinds :: [CoreBind] -> [CoreRule]
264 rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
266 getRules :: RuleBase -> Id -> [CoreRule]
267 -- See Note [Where rules are found]
268 getRules rule_base fn
269 = idCoreRules fn ++ imp_rules
271 imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []
274 Note [Where rules are found]
275 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
276 The rules for an Id come from two places:
277 (a) the ones it is born with, stored inside the Id iself (idCoreRules fn),
278 (b) rules added in other modules, stored in the global RuleBase (imp_rules)
280 It's tempting to think that
281 - LocalIds have only (a)
282 - non-LocalIds have only (b)
284 but that isn't quite right:
286 - PrimOps and ClassOps are born with a bunch of rules inside the Id,
287 even when they are imported
289 - The rules in PrelRules.builtinRules should be active even
290 in the module defining the Id (when it's a LocalId), but
291 the rules are kept in the global RuleBase
294 %************************************************************************
298 %************************************************************************
301 -- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules
302 type RuleBase = NameEnv [CoreRule]
303 -- The rules are are unordered;
304 -- we sort out any overlaps on lookup
306 emptyRuleBase :: RuleBase
307 emptyRuleBase = emptyNameEnv
309 mkRuleBase :: [CoreRule] -> RuleBase
310 mkRuleBase rules = extendRuleBaseList emptyRuleBase rules
312 extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
313 extendRuleBaseList rule_base new_guys
314 = foldl extendRuleBase rule_base new_guys
316 unionRuleBase :: RuleBase -> RuleBase -> RuleBase
317 unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2
319 extendRuleBase :: RuleBase -> CoreRule -> RuleBase
320 extendRuleBase rule_base rule
321 = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule
323 pprRuleBase :: RuleBase -> SDoc
324 pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
325 | rs <- nameEnvElts rules ]
329 %************************************************************************
331 \subsection{Matching}
333 %************************************************************************
335 Note [Extra args in rule matching]
336 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
337 If we find a matching rule, we return (Just (rule, rhs)),
338 but the rule firing has only consumed as many of the input args
339 as the ruleArity says. It's up to the caller to keep track
340 of any left-over args. E.g. if you call
341 lookupRule ... f [e1, e2, e3]
342 and it returns Just (r, rhs), where r has ruleArity 2
343 then the real rewrite is
344 f e1 e2 e3 ==> rhs e3
346 You might think it'd be cleaner for lookupRule to deal with the
347 leftover arguments, by applying 'rhs' to them, but the main call
348 in the Simplifier works better as it is. Reason: the 'args' passed
349 to lookupRule are the result of a lazy substitution
352 -- | The main rule matching function. Attempts to apply all (active)
353 -- supplied rules to this instance of an application in a given
354 -- context, returning the rule applied and the resulting expression if
356 lookupRule :: (Activation -> Bool) -- When rule is active
357 -> IdUnfoldingFun -- When Id can be unfolded
360 -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
362 -- See Note [Extra args in rule matching]
363 -- See comments on matchRule
364 lookupRule is_active id_unf in_scope fn args rules
365 = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
368 (m:ms) -> Just (findBest (fn,args) m ms)
370 rough_args = map roughTopName args
372 go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
374 go ms (r:rs) = case (matchRule is_active id_unf in_scope args rough_args r) of
375 Just e -> go ((r,e):ms) rs
376 Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$
377 -- ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] )
380 findBest :: (Id, [CoreExpr])
381 -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
382 -- All these pairs matched the expression
383 -- Return the pair the the most specific rule
384 -- The (fn,args) is just for overlap reporting
386 findBest _ (rule,ans) [] = (rule,ans)
387 findBest target (rule1,ans1) ((rule2,ans2):prs)
388 | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
389 | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
390 | debugIsOn = let pp_rule rule
391 | opt_PprStyle_Debug = ppr rule
392 | otherwise = doubleQuotes (ftext (ru_name rule))
393 in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
394 (vcat [if opt_PprStyle_Debug then
395 ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args)
397 ptext (sLit "Rule 1:") <+> pp_rule rule1,
398 ptext (sLit "Rule 2:") <+> pp_rule rule2]) $
399 findBest target (rule1,ans1) prs
400 | otherwise = findBest target (rule1,ans1) prs
404 isMoreSpecific :: CoreRule -> CoreRule -> Bool
405 isMoreSpecific (BuiltinRule {}) _ = True
406 isMoreSpecific _ (BuiltinRule {}) = False
407 isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
408 (Rule { ru_bndrs = bndrs2, ru_args = args2 })
409 = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1)
411 id_unfolding_fun _ = NoUnfolding -- Don't expand in templates
412 in_scope = mkInScopeSet (mkVarSet bndrs1)
413 -- Actually we should probably include the free vars
414 -- of rule1's args, but I can't be bothered
416 noBlackList :: Activation -> Bool
417 noBlackList _ = False -- Nothing is black listed
419 matchRule :: (Activation -> Bool) -> IdUnfoldingFun
421 -> [CoreExpr] -> [Maybe Name]
422 -> CoreRule -> Maybe CoreExpr
424 -- If (matchRule rule args) returns Just (name,rhs)
425 -- then (f args) matches the rule, and the corresponding
426 -- rewritten RHS is rhs
428 -- The bndrs and rhs is occurrence-analysed
433 -- forall f g x. map f (map g x) ==> map (f . g) x
435 -- CoreRule "map/map"
436 -- [f,g,x] -- tpl_vars
437 -- [f,map g x] -- tpl_args
438 -- map (f.g) x) -- rhs
440 -- Then the call: matchRule the_rule [e1,map e2 e3]
441 -- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
443 -- Any 'surplus' arguments in the input are simply put on the end
446 matchRule _is_active id_unf _in_scope args _rough_args
447 (BuiltinRule { ru_try = match_fn })
448 -- Built-in rules can't be switched off, it seems
449 = case match_fn id_unf args of
450 Just expr -> Just expr
453 matchRule is_active id_unf in_scope args rough_args
454 (Rule { ru_act = act, ru_rough = tpl_tops,
455 ru_bndrs = tpl_vars, ru_args = tpl_args,
457 | not (is_active act) = Nothing
458 | ruleCantMatch tpl_tops rough_args = Nothing
460 = case matchN id_unf in_scope tpl_vars tpl_args args of
462 Just (binds, tpl_vals) -> Just (mkLets binds $
463 rule_fn `mkApps` tpl_vals)
465 rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
466 -- We could do this when putting things into the rulebase, I guess
470 -- For a given match template and context, find bindings to wrap around
471 -- the entire result and what should be substituted for each template variable.
472 -- Fail if there are two few actual arguments from the target to match the template
473 matchN :: IdUnfoldingFun
474 -> InScopeSet -- ^ In-scope variables
475 -> [Var] -- ^ Match template type variables
476 -> [CoreExpr] -- ^ Match template
477 -> [CoreExpr] -- ^ Target; can have more elements than the template
478 -> Maybe ([CoreBind],
481 matchN id_unf in_scope tmpl_vars tmpl_es target_es
482 = do { (tv_subst, id_subst, binds)
483 <- go init_menv emptySubstEnv tmpl_es target_es
484 ; return (fromOL binds,
485 map (lookup_tmpl tv_subst id_subst) tmpl_vars') }
487 (init_rn_env, tmpl_vars') = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars
488 -- See Note [Template binders]
490 init_menv = ME { me_tmpls = mkVarSet tmpl_vars', me_env = init_rn_env }
492 go _ subst [] _ = Just subst
493 go _ _ _ [] = Nothing -- Fail if too few actual args
494 go menv subst (t:ts) (e:es) = do { subst1 <- match id_unf menv subst t e
495 ; go menv subst1 ts es }
497 lookup_tmpl :: TvSubstEnv -> IdSubstEnv -> Var -> CoreExpr
498 lookup_tmpl tv_subst id_subst tmpl_var'
499 | isTyVar tmpl_var' = case lookupVarEnv tv_subst tmpl_var' of
501 Nothing -> unbound tmpl_var'
502 | otherwise = case lookupVarEnv id_subst tmpl_var' of
504 _ -> unbound tmpl_var'
506 unbound var = pprPanic "Template variable unbound in rewrite rule"
507 (ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es)
510 Note [Template binders]
511 ~~~~~~~~~~~~~~~~~~~~~~~
512 Consider the following match:
513 Template: forall x. f x
515 This should succeed, because the template variable 'x' has
516 nothing to do with the 'x' in the target.
518 On reflection, this case probably does just work, but this might not
519 Template: forall x. f (\x.x)
521 Here we want to clone when we find the \x, but to know that x must be in scope
523 To achive this, we use rnBndrL to rename the template variables if
524 necessary; the renamed ones are the tmpl_vars'
527 ---------------------------------------------
528 The inner workings of matching
529 ---------------------------------------------
532 -- These two definitions are not the same as in Subst,
533 -- but they simple and direct, and purely local to this module
535 -- * The domain of the TvSubstEnv and IdSubstEnv are the template
536 -- variables passed into the match.
538 -- * The (OrdList CoreBind) in a SubstEnv are the bindings floated out
539 -- from nested matches; see the Let case of match, below
541 type SubstEnv = (TvSubstEnv, IdSubstEnv, OrdList CoreBind)
542 type IdSubstEnv = IdEnv CoreExpr
544 emptySubstEnv :: SubstEnv
545 emptySubstEnv = (emptyVarEnv, emptyVarEnv, nilOL)
548 -- At one stage I tried to match even if there are more
549 -- template args than real args.
551 -- I now think this is probably a bad idea.
552 -- Should the template (map f xs) match (map g)? I think not.
553 -- For a start, in general eta expansion wastes work.
557 match :: IdUnfoldingFun
560 -> CoreExpr -- Template
561 -> CoreExpr -- Target
564 -- See the notes with Unify.match, which matches types
565 -- Everything is very similar for terms
567 -- Interesting examples:
569 -- \x->f against \f->f
570 -- When we meet the lambdas we must remember to rename f to f' in the
571 -- second expresion. The RnEnv2 does that.
574 -- forall a. \b->b against \a->3
575 -- We must rename the \a. Otherwise when we meet the lambdas we
576 -- might substitute [a/b] in the template, and then erroneously
577 -- succeed in matching what looks like the template variable 'a' against 3.
579 -- The Var case follows closely what happens in Unify.match
580 match idu menv subst (Var v1) e2
581 | Just subst <- match_var idu menv subst v1 e2
584 match idu menv subst (Note _ e1) e2 = match idu menv subst e1 e2
585 match idu menv subst e1 (Note _ e2) = match idu menv subst e1 e2
586 -- Ignore notes in both template and thing to be matched
587 -- See Note [Notes in RULE matching]
589 match id_unfolding_fun menv subst e1 (Var v2) -- Note [Expanding variables]
590 | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables]
591 , Just e2' <- expandUnfolding_maybe (id_unfolding_fun v2')
592 = match id_unfolding_fun (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2'
594 v2' = lookupRnInScope rn_env v2
596 -- Notice that we look up v2 in the in-scope set
597 -- See Note [Lookup in-scope]
598 -- No need to apply any renaming first (hence no rnOccR)
599 -- because of the not-inRnEnvR
601 match idu menv (tv_subst, id_subst, binds) e1 (Let bind e2)
602 | all freshly_bound bndrs -- See Note [Matching lets]
603 , not (any (inRnEnvR rn_env) bind_fvs)
604 = match idu (menv { me_env = rn_env' })
605 (tv_subst, id_subst, binds `snocOL` bind')
609 bndrs = bindersOf bind
610 bind_fvs = varSetElems (bindFreeVars bind)
611 freshly_bound x = not (x `rnInScope` rn_env)
614 rn_env' = extendRnInScopeList rn_env bndrs
616 match _ _ subst (Lit lit1) (Lit lit2)
620 match idu menv subst (App f1 a1) (App f2 a2)
621 = do { subst' <- match idu menv subst f1 f2
622 ; match idu menv subst' a1 a2 }
624 match idu menv subst (Lam x1 e1) (Lam x2 e2)
625 = match idu menv' subst e1 e2
627 menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
629 -- This rule does eta expansion
630 -- (\x.M) ~ N iff M ~ N x
631 -- It's important that this is *after* the let rule,
632 -- so that (\x.M) ~ (let y = e in \y.N)
633 -- does the let thing, and then gets the lam/lam rule above
634 match idu menv subst (Lam x1 e1) e2
635 = match idu menv' subst e1 (App e2 (varToCoreExpr new_x))
637 (rn_env', new_x) = rnBndrL (me_env menv) x1
638 menv' = menv { me_env = rn_env' }
640 -- Eta expansion the other way
641 -- M ~ (\y.N) iff M y ~ N
642 match idu menv subst e1 (Lam x2 e2)
643 = match idu menv' subst (App e1 (varToCoreExpr new_x)) e2
645 (rn_env', new_x) = rnBndrR (me_env menv) x2
646 menv' = menv { me_env = rn_env' }
648 match idu menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
649 = do { subst1 <- match_ty menv subst ty1 ty2
650 ; subst2 <- match idu menv subst1 e1 e2
651 ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
652 ; match_alts idu menv' subst2 alts1 alts2 -- Alts are both sorted
655 match _ menv subst (Type ty1) (Type ty2)
656 = match_ty menv subst ty1 ty2
658 match idu menv subst (Cast e1 co1) (Cast e2 co2)
659 = do { subst1 <- match_ty menv subst co1 co2
660 ; match idu menv subst1 e1 e2 }
662 -- Everything else fails
663 match _ _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
666 ------------------------------------------
667 match_var :: IdUnfoldingFun
671 -> CoreExpr -- Target
673 match_var idu menv subst@(tv_subst, id_subst, binds) v1 e2
674 | v1' `elemVarSet` me_tmpls menv
675 = case lookupVarEnv id_subst v1' of
676 Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
677 -> Nothing -- Occurs check failure
678 -- e.g. match forall a. (\x-> a x) against (\y. y y)
680 | otherwise -- No renaming to do on e2, because no free var
681 -- of e2 is in the rnEnvR of the envt
682 -- Note [Matching variable types]
683 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
684 -- However, we must match the *types*; e.g.
685 -- forall (c::Char->Int) (x::Char).
686 -- f (c x) = "RULE FIRED"
687 -- We must only match on args that have the right type
688 -- It's actually quite difficult to come up with an example that shows
689 -- you need type matching, esp since matching is left-to-right, so type
690 -- args get matched first. But it's possible (e.g. simplrun008) and
691 -- this is the Right Thing to do
692 -> do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst (idType v1') (exprType e2)
693 -- c.f. match_ty below
694 ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) }
696 Just e1' | eqExprX idu (nukeRnEnvL rn_env) e1' e2
702 | otherwise -- v1 is not a template variable; check for an exact match with e2
704 Var v2 | v1' == rnOccR rn_env v2 -> Just subst
709 v1' = rnOccL rn_env v1
710 -- If the template is
711 -- forall x. f x (\x -> x) = ...
712 -- Then the x inside the lambda isn't the
713 -- template x, so we must rename first!
716 ------------------------------------------
717 match_alts :: IdUnfoldingFun
720 -> [CoreAlt] -- Template
721 -> [CoreAlt] -- Target
723 match_alts _ _ subst [] []
725 match_alts idu menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
727 = do { subst1 <- match idu menv' subst r1 r2
728 ; match_alts idu menv subst1 alts1 alts2 }
731 menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 }
737 Matching Core types: use the matcher in TcType.
738 Notice that we treat newtypes as opaque. For example, suppose
739 we have a specialised version of a function at a newtype, say
741 We only want to replace (f T) with f', not (f Int).
744 ------------------------------------------
750 match_ty menv (tv_subst, id_subst, binds) ty1 ty2
751 = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
752 ; return (tv_subst', id_subst, binds) }
755 Note [Expanding variables]
756 ~~~~~~~~~~~~~~~~~~~~~~~~~~
757 Here is another Very Important rule: if the term being matched is a
758 variable, we expand it so long as its unfolding is "expandable". (Its
759 occurrence information is not necessarily up to date, so we don't use
760 it.) By "expandable" we mean a WHNF or a "constructor-like" application.
761 This is the key reason for "constructor-like" Ids. If we have
762 {-# NOINLINE [1] CONLIKE g #-}
763 {-# RULE f (g x) = h x #-}
765 let v = g 3 in ....(f v)....
766 we want to make the rule fire, to replace (f v) with (h 3).
768 Note [Do not expand locally-bound variables]
769 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
770 Do *not* expand locally-bound variables, else there's a worry that the
771 unfolding might mention variables that are themselves renamed.
773 case x of y { (p,q) -> ...y... }
774 Don't expand 'y' to (p,q) because p,q might themselves have been
775 renamed. Essentially we only expand unfoldings that are "outside"
778 Hence, (a) the guard (not (isLocallyBoundR v2))
779 (b) when we expand we nuke the renaming envt (nukeRnEnvR).
781 Note [Notes in RULE matching]
782 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
783 Look through Notes in both template and expression being matched. In
784 particular, we don't want to be confused by InlineMe notes. Maybe we
785 should be more careful about profiling notes, but for now I'm just
786 riding roughshod over them. cf Note [Notes in call patterns] in
791 Matching a let-expression. Consider
792 RULE forall x. f (g x) = <rhs>
793 and target expression
794 f (let { w=R } in g E))
795 Then we'd like the rule to match, to generate
796 let { w=R } in (\x. <rhs>) E
797 In effect, we want to float the let-binding outward, to enable
798 the match to happen. This is the WHOLE REASON for accumulating
799 bindings in the SubstEnv
801 We can only do this if
802 (a) Widening the scope of w does not capture any variables
803 We use a conservative test: w is not already in scope
804 If not, we clone the binders, and substitute
805 (b) The free variables of R are not bound by the part of the
806 target expression outside the let binding; e.g.
807 f (\v. let w = v+1 in g E)
808 Here we obviously cannot float the let-binding for w.
810 You may think rule (a) would never apply, because rule matching is
811 mostly invoked from the simplifier, when we have just run substExpr
812 over the argument, so there will be no shadowing anyway.
813 The fly in the ointment is that the forall'd variables of the
814 RULE itself are considered in scope.
816 I though of various ways to solve (a). One plan was to
817 clone the binders if they are in scope. But watch out!
818 (let x=y+1 in let z=x+1 in (z,z)
819 --> should match (p,p) but watch out that
820 the use of x on z's rhs is OK!
821 If we clone x, then the let-binding for 'z' is then caught by (b),
822 at least unless we elaborate the RnEnv stuff a bit.
824 So for we simply fail to match unless both (a) and (b) hold.
826 Other cases to think about
827 (let x=y+1 in \x. (x,x))
828 --> let x=y+1 in (\x1. (x1,x1))
829 (\x. let x = y+1 in (x,x))
830 --> let x1 = y+1 in (\x. (x1,x1)
831 (let x=y+1 in (x,x), let x=y-1 in (x,x))
832 --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1))
835 Note [Lookup in-scope]
836 ~~~~~~~~~~~~~~~~~~~~~~
837 Consider this example
838 foo :: Int -> Maybe Int -> Int
840 foo m (Just n) = foo (m-n) (Just n)
842 SpecConstr sees this fragment:
844 case w_smT of wild_Xf [Just A] {
845 Data.Maybe.Nothing -> lvl_smf;
846 Data.Maybe.Just n_acT [Just S(L)] ->
847 case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->
848 \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
851 and correctly generates the rule
853 RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#
854 sc_snn :: GHC.Prim.Int#}
855 \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
856 = \$s\$wfoo_sno y_amr sc_snn ;]
858 BUT we must ensure that this rule matches in the original function!
859 Note that the call to \$wfoo is
860 \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
862 During matching we expand wild_Xf to (Just n_acT). But then we must also
863 expand n_acT to (I# y_amr). And we can only do that if we look up n_acT
864 in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding
867 That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
870 %************************************************************************
872 Rule-check the program
874 %************************************************************************
876 We want to know what sites have rules that could have fired but didn't.
877 This pass runs over the tree (without changing it) and reports such.
880 -- | Report partial matches for rules beginning with the specified
881 -- string for the purposes of error reporting
882 ruleCheckProgram :: CompilerPhase -- ^ Rule activation test
883 -> String -- ^ Rule pattern
884 -> RuleBase -- ^ Database of rules
885 -> [CoreBind] -- ^ Bindings to check in
886 -> SDoc -- ^ Resulting check message
887 ruleCheckProgram phase rule_pat rule_base binds
889 = text "Rule check results: no rule application sites"
891 = vcat [text "Rule check results:",
893 vcat [ p $$ line | p <- bagToList results ]
896 env = RuleCheckEnv { rc_is_active = isActive phase
897 , rc_id_unf = idUnfolding -- Not quite right
898 -- Should use activeUnfolding
899 , rc_pattern = rule_pat
900 , rc_rule_base = rule_base }
901 results = unionManyBags (map (ruleCheckBind env) binds)
902 line = text (replicate 20 '-')
904 data RuleCheckEnv = RuleCheckEnv {
905 rc_is_active :: Activation -> Bool,
906 rc_id_unf :: IdUnfoldingFun,
907 rc_pattern :: String,
908 rc_rule_base :: RuleBase
911 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
912 -- The Bag returned has one SDoc for each call site found
913 ruleCheckBind env (NonRec _ r) = ruleCheck env r
914 ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs]
916 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
917 ruleCheck _ (Var _) = emptyBag
918 ruleCheck _ (Lit _) = emptyBag
919 ruleCheck _ (Type _) = emptyBag
920 ruleCheck env (App f a) = ruleCheckApp env (App f a) []
921 ruleCheck env (Note _ e) = ruleCheck env e
922 ruleCheck env (Cast e _) = ruleCheck env e
923 ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
924 ruleCheck env (Lam _ e) = ruleCheck env e
925 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
926 unionManyBags [ruleCheck env r | (_,_,r) <- as]
928 ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc
929 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
930 ruleCheckApp env (Var f) as = ruleCheckFun env f as
931 ruleCheckApp env other _ = ruleCheck env other
935 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
936 -- Produce a report for all rules matching the predicate
937 -- saying why it doesn't match the specified application
939 ruleCheckFun env fn args
940 | null name_match_rules = emptyBag
941 | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules)
943 name_match_rules = filter match (getRules (rc_rule_base env) fn)
944 match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
946 ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
947 ruleAppCheck_help env fn args rules
948 = -- The rules match the pattern, so we want to print something
949 vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
950 vcat (map check_rule rules)]
953 i_args = args `zip` [1::Int ..]
954 rough_args = map roughTopName args
956 check_rule rule = rule_herald rule <> colon <+> rule_info rule
958 rule_herald (BuiltinRule { ru_name = name })
959 = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name)
960 rule_herald (Rule { ru_name = name })
961 = ptext (sLit "Rule") <+> doubleQuotes (ftext name)
964 | Just _ <- matchRule noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule
965 = text "matches (which is very peculiar!)"
967 rule_info (BuiltinRule {}) = text "does not match"
969 rule_info (Rule { ru_act = act,
970 ru_bndrs = rule_bndrs, ru_args = rule_args})
971 | not (rc_is_active env act) = text "active only in later phase"
972 | n_args < n_rule_args = text "too few arguments"
973 | n_mismatches == n_rule_args = text "no arguments match"
974 | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not"
975 | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
977 n_rule_args = length rule_args
978 n_mismatches = length mismatches
979 mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
980 not (isJust (match_fn rule_arg arg))]
982 lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars
983 match_fn rule_arg arg = match (rc_id_unf env) menv emptySubstEnv rule_arg arg
985 in_scope = lhs_fvs `unionVarSet` exprFreeVars arg
986 menv = ME { me_env = mkRnEnv2 (mkInScopeSet in_scope)
987 , me_tmpls = mkVarSet rule_bndrs }