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, roughTopNames
30 #include "HsVersions.h"
32 import CoreSyn -- All of it
34 import OccurAnal ( occurAnalyseExpr )
35 import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )
36 import CoreUtils ( exprType, eqExpr )
37 import PprCore ( pprRules )
39 import TcType ( tcSplitTyConApp_maybe )
40 import CoreTidy ( tidyRules )
42 import IdInfo ( SpecInfo( SpecInfo ) )
46 import Name ( Name, NamedThing(..) )
48 import Unify ( ruleMatchTyX, MatchEnv(..) )
49 import BasicTypes ( Activation, CompilerPhase, isActive )
50 import StaticFlags ( opt_PprStyle_Debug )
60 Note [Overall plumbing for rules]
61 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
62 * After the desugarer:
63 - The ModGuts initially contains mg_rules :: [CoreRule] of
64 locally-declared rules for imported Ids.
65 - Locally-declared rules for locally-declared Ids are attached to
66 the IdInfo for that Id. See Note [Attach rules to local ids] in
69 * TidyPgm strips off all the rules from local Ids and adds them to
70 mg_rules, so that the ModGuts has *all* the locally-declared rules.
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 why 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 mkRule :: Bool -> Bool -> 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 mkRule is_auto is_local name act fn bndrs args rhs
165 = Rule { ru_name = name, ru_fn = fn, ru_act = act,
166 ru_bndrs = bndrs, ru_args = args,
167 ru_rhs = occurAnalyseExpr rhs,
168 ru_rough = roughTopNames args,
169 ru_auto = is_auto, ru_local = is_local }
172 roughTopNames :: [CoreExpr] -> [Maybe Name]
173 -- ^ Find the \"top\" free names of several expressions.
174 -- Such names are either:
176 -- 1. The function finally being applied to in an application chain
177 -- (if that name is a GlobalId: see "Var#globalvslocal"), or
179 -- 2. The 'TyCon' if the expression is a 'Type'
181 -- This is used for the fast-match-check for rules;
182 -- if the top names don't match, the rest can't
183 roughTopNames args = map roughTopName args
185 roughTopName :: CoreExpr -> Maybe Name
186 roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
187 Just (tc,_) -> Just (getName tc)
189 roughTopName (App f _) = roughTopName f
190 roughTopName (Var f) | isGlobalId f = Just (idName f)
191 | otherwise = Nothing
192 roughTopName _ = Nothing
194 ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
195 -- ^ @ruleCantMatch tpl actual@ returns True only if @actual@
196 -- definitely can't match @tpl@ by instantiating @tpl@.
197 -- It's only a one-way match; unlike instance matching we
198 -- don't consider unification.
201 -- @ruleCantMatch [Nothing] [Just n2] = False@
202 -- Reason: a template variable can be instantiated by a constant
204 -- @ruleCantMatch [Just n1] [Nothing] = False@
205 -- Reason: a local variable @v@ in the actuals might [_$_]
207 ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as
208 ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as
209 ruleCantMatch _ _ = False
213 pprRulesForUser :: [CoreRule] -> SDoc
214 -- (a) tidy the rules
215 -- (b) sort them into order based on the rule name
216 -- (c) suppress uniques (unless -dppr-debug is on)
217 -- This combination makes the output stable so we can use in testing
218 -- It's here rather than in PprCore because it calls tidyRules
219 pprRulesForUser rules
220 = withPprStyle defaultUserStyle $
223 tidyRules emptyTidyEnv rules
225 le_rule r1 r2 = ru_name r1 <= ru_name r2
229 %************************************************************************
231 SpecInfo: the rules in an IdInfo
233 %************************************************************************
236 -- | Make a 'SpecInfo' containing a number of 'CoreRule's, suitable
237 -- for putting into an 'IdInfo'
238 mkSpecInfo :: [CoreRule] -> SpecInfo
239 mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules)
241 extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
242 extendSpecInfo (SpecInfo rs1 fvs1) rs2
243 = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
245 addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
246 addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2)
247 = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
249 addIdSpecialisations :: Id -> [CoreRule] -> Id
250 addIdSpecialisations id []
252 addIdSpecialisations id rules
253 = setIdSpecialisation id $
254 extendSpecInfo (idSpecialisation id) rules
256 -- | Gather all the rules for locally bound identifiers from the supplied bindings
257 rulesOfBinds :: [CoreBind] -> [CoreRule]
258 rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
260 getRules :: RuleBase -> Id -> [CoreRule]
261 -- See Note [Where rules are found]
262 getRules rule_base fn
263 = idCoreRules fn ++ imp_rules
265 imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []
268 Note [Where rules are found]
269 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
270 The rules for an Id come from two places:
271 (a) the ones it is born with, stored inside the Id iself (idCoreRules fn),
272 (b) rules added in other modules, stored in the global RuleBase (imp_rules)
274 It's tempting to think that
275 - LocalIds have only (a)
276 - non-LocalIds have only (b)
278 but that isn't quite right:
280 - PrimOps and ClassOps are born with a bunch of rules inside the Id,
281 even when they are imported
283 - The rules in PrelRules.builtinRules should be active even
284 in the module defining the Id (when it's a LocalId), but
285 the rules are kept in the global RuleBase
288 %************************************************************************
292 %************************************************************************
295 -- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules
296 type RuleBase = NameEnv [CoreRule]
297 -- The rules are are unordered;
298 -- we sort out any overlaps on lookup
300 emptyRuleBase :: RuleBase
301 emptyRuleBase = emptyNameEnv
303 mkRuleBase :: [CoreRule] -> RuleBase
304 mkRuleBase rules = extendRuleBaseList emptyRuleBase rules
306 extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
307 extendRuleBaseList rule_base new_guys
308 = foldl extendRuleBase rule_base new_guys
310 unionRuleBase :: RuleBase -> RuleBase -> RuleBase
311 unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2
313 extendRuleBase :: RuleBase -> CoreRule -> RuleBase
314 extendRuleBase rule_base rule
315 = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule
317 pprRuleBase :: RuleBase -> SDoc
318 pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
319 | rs <- nameEnvElts rules ]
323 %************************************************************************
327 %************************************************************************
330 -- | The main rule matching function. Attempts to apply all (active)
331 -- supplied rules to this instance of an application in a given
332 -- context, returning the rule applied and the resulting expression if
334 lookupRule :: (Activation -> Bool) -- When rule is active
335 -> IdUnfoldingFun -- When Id can be unfolded
338 -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
340 -- See Note [Extra args in rule matching]
341 -- See comments on matchRule
342 lookupRule is_active id_unf in_scope fn args rules
343 = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
346 (m:ms) -> Just (findBest (fn,args) m ms)
348 rough_args = map roughTopName args
350 go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
352 go ms (r:rs) = case (matchRule is_active id_unf in_scope args rough_args r) of
353 Just e -> go ((r,e):ms) rs
354 Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$
355 -- ppr [ (arg_id, unfoldingTemplate unf)
356 -- | Var arg_id <- args
357 -- , let unf = idUnfolding arg_id
358 -- , isCheapUnfolding unf] )
361 findBest :: (Id, [CoreExpr])
362 -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
363 -- All these pairs matched the expression
364 -- Return the pair the the most specific rule
365 -- The (fn,args) is just for overlap reporting
367 findBest _ (rule,ans) [] = (rule,ans)
368 findBest target (rule1,ans1) ((rule2,ans2):prs)
369 | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
370 | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
371 | debugIsOn = let pp_rule rule
372 | opt_PprStyle_Debug = ppr rule
373 | otherwise = doubleQuotes (ftext (ru_name rule))
374 in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
375 (vcat [if opt_PprStyle_Debug then
376 ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args)
378 ptext (sLit "Rule 1:") <+> pp_rule rule1,
379 ptext (sLit "Rule 2:") <+> pp_rule rule2]) $
380 findBest target (rule1,ans1) prs
381 | otherwise = findBest target (rule1,ans1) prs
385 isMoreSpecific :: CoreRule -> CoreRule -> Bool
386 -- This tests if one rule is more specific than another
387 -- We take the view that a BuiltinRule is less specific than
388 -- anything else, because we want user-define rules to "win"
389 -- In particular, class ops have a built-in rule, but we
390 -- any user-specific rules to win
392 -- truncate :: (RealFrac a, Integral b) => a -> b
393 -- {-# RULES "truncate/Double->Int" truncate = double2Int #-}
394 -- double2Int :: Double -> Int
395 -- We want the specific RULE to beat the built-in class-op rule
396 isMoreSpecific (BuiltinRule {}) _ = False
397 isMoreSpecific (Rule {}) (BuiltinRule {}) = True
398 isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
399 (Rule { ru_bndrs = bndrs2, ru_args = args2 })
400 = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1)
402 id_unfolding_fun _ = NoUnfolding -- Don't expand in templates
403 in_scope = mkInScopeSet (mkVarSet bndrs1)
404 -- Actually we should probably include the free vars
405 -- of rule1's args, but I can't be bothered
407 noBlackList :: Activation -> Bool
408 noBlackList _ = False -- Nothing is black listed
411 Note [Extra args in rule matching]
412 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
413 If we find a matching rule, we return (Just (rule, rhs)),
414 but the rule firing has only consumed as many of the input args
415 as the ruleArity says. It's up to the caller to keep track
416 of any left-over args. E.g. if you call
417 lookupRule ... f [e1, e2, e3]
418 and it returns Just (r, rhs), where r has ruleArity 2
419 then the real rewrite is
420 f e1 e2 e3 ==> rhs e3
422 You might think it'd be cleaner for lookupRule to deal with the
423 leftover arguments, by applying 'rhs' to them, but the main call
424 in the Simplifier works better as it is. Reason: the 'args' passed
425 to lookupRule are the result of a lazy substitution
428 ------------------------------------
429 matchRule :: (Activation -> Bool) -> IdUnfoldingFun
431 -> [CoreExpr] -> [Maybe Name]
432 -> CoreRule -> Maybe CoreExpr
434 -- If (matchRule rule args) returns Just (name,rhs)
435 -- then (f args) matches the rule, and the corresponding
436 -- rewritten RHS is rhs
438 -- The bndrs and rhs is occurrence-analysed
443 -- forall f g x. map f (map g x) ==> map (f . g) x
445 -- CoreRule "map/map"
446 -- [f,g,x] -- tpl_vars
447 -- [f,map g x] -- tpl_args
448 -- map (f.g) x) -- rhs
450 -- Then the call: matchRule the_rule [e1,map e2 e3]
451 -- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
453 -- Any 'surplus' arguments in the input are simply put on the end
456 matchRule _is_active id_unf _in_scope args _rough_args
457 (BuiltinRule { ru_try = match_fn })
458 -- Built-in rules can't be switched off, it seems
459 = case match_fn id_unf args of
460 Just expr -> Just expr
463 matchRule is_active id_unf in_scope args rough_args
464 (Rule { ru_act = act, ru_rough = tpl_tops,
465 ru_bndrs = tpl_vars, ru_args = tpl_args,
467 | not (is_active act) = Nothing
468 | ruleCantMatch tpl_tops rough_args = Nothing
470 = case matchN id_unf in_scope tpl_vars tpl_args args of
472 Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $
473 rule_fn `mkApps` tpl_vals)
475 rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
476 -- We could do this when putting things into the rulebase, I guess
478 ---------------------------------------
479 matchN :: IdUnfoldingFun
480 -> InScopeSet -- ^ In-scope variables
481 -> [Var] -- ^ Match template type variables
482 -> [CoreExpr] -- ^ Match template
483 -> [CoreExpr] -- ^ Target; can have more elements than the template
484 -> Maybe (BindWrapper, -- Floated bindings; see Note [Matching lets]
486 -- For a given match template and context, find bindings to wrap around
487 -- the entire result and what should be substituted for each template variable.
488 -- Fail if there are two few actual arguments from the target to match the template
490 matchN id_unf in_scope tmpl_vars tmpl_es target_es
491 = do { subst <- go init_menv emptyRuleSubst tmpl_es target_es
492 ; return (rs_binds subst,
493 map (lookup_tmpl subst) tmpl_vars') }
495 (init_rn_env, tmpl_vars') = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars
496 -- See Note [Template binders]
498 init_menv = RV { rv_tmpls = mkVarSet tmpl_vars', rv_lcl = init_rn_env
499 , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env)
502 go _ subst [] _ = Just subst
503 go _ _ _ [] = Nothing -- Fail if too few actual args
504 go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
505 ; go menv subst1 ts es }
507 lookup_tmpl :: RuleSubst -> Var -> CoreExpr
508 lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tmpl_var'
509 | isId tmpl_var' = case lookupVarEnv id_subst tmpl_var' of
511 _ -> unbound tmpl_var'
512 | otherwise = case lookupVarEnv tv_subst tmpl_var' of
514 Nothing -> unbound tmpl_var'
516 unbound var = pprPanic "Template variable unbound in rewrite rule"
517 (ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es)
520 Note [Template binders]
521 ~~~~~~~~~~~~~~~~~~~~~~~
522 Consider the following match:
523 Template: forall x. f x
525 This should succeed, because the template variable 'x' has
526 nothing to do with the 'x' in the target.
528 On reflection, this case probably does just work, but this might not
529 Template: forall x. f (\x.x)
531 Here we want to clone when we find the \x, but to know that x must be in scope
533 To achive this, we use rnBndrL to rename the template variables if
534 necessary; the renamed ones are the tmpl_vars'
537 %************************************************************************
541 %************************************************************************
543 ---------------------------------------------
544 The inner workings of matching
545 ---------------------------------------------
548 -- * The domain of the TvSubstEnv and IdSubstEnv are the template
549 -- variables passed into the match.
551 -- * The BindWrapper in a RuleSubst are the bindings floated out
552 -- from nested matches; see the Let case of match, below
554 data RuleEnv = RV { rv_tmpls :: VarSet -- Template variables
555 , rv_lcl :: RnEnv2 -- Renamings for *local bindings*
557 , rv_fltR :: Subst -- Renamings for floated let-bindings
558 -- domain disjoint from envR of rv_lcl
559 -- See Note [Matching lets]
560 , rv_unf :: IdUnfoldingFun
563 data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the
564 , rs_id_subst :: IdSubstEnv -- template variables
565 , rs_binds :: BindWrapper -- Floated bindings
566 , rs_bndrs :: VarSet -- Variables bound by floated lets
569 type BindWrapper = CoreExpr -> CoreExpr
570 -- See Notes [Matching lets] and [Matching cases]
571 -- we represent the floated bindings as a core-to-core function
573 emptyRuleSubst :: RuleSubst
574 emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv
575 , rs_binds = \e -> e, rs_bndrs = emptyVarSet }
577 -- At one stage I tried to match even if there are more
578 -- template args than real args.
580 -- I now think this is probably a bad idea.
581 -- Should the template (map f xs) match (map g)? I think not.
582 -- For a start, in general eta expansion wastes work.
588 -> CoreExpr -- Template
589 -> CoreExpr -- Target
592 -- See the notes with Unify.match, which matches types
593 -- Everything is very similar for terms
595 -- Interesting examples:
597 -- \x->f against \f->f
598 -- When we meet the lambdas we must remember to rename f to f' in the
599 -- second expresion. The RnEnv2 does that.
602 -- forall a. \b->b against \a->3
603 -- We must rename the \a. Otherwise when we meet the lambdas we
604 -- might substitute [a/b] in the template, and then erroneously
605 -- succeed in matching what looks like the template variable 'a' against 3.
607 -- The Var case follows closely what happens in Unify.match
608 match renv subst (Var v1) e2
609 | Just subst <- match_var renv subst v1 e2
612 match renv subst (Note _ e1) e2 = match renv subst e1 e2
613 match renv subst e1 (Note _ e2) = match renv subst e1 e2
614 -- Ignore notes in both template and thing to be matched
615 -- See Note [Notes in RULE matching]
617 match renv subst e1 (Var v2) -- Note [Expanding variables]
618 | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables]
619 , Just e2' <- expandUnfolding_maybe (rv_unf renv v2')
620 = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2'
622 v2' = lookupRnInScope rn_env v2
624 -- Notice that we look up v2 in the in-scope set
625 -- See Note [Lookup in-scope]
626 -- No need to apply any renaming first (hence no rnOccR)
627 -- because of the not-inRnEnvR
629 match renv subst e1 (Let bind e2)
630 | okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets]
631 = match (renv { rv_fltR = flt_subst' })
632 (subst { rs_binds = rs_binds subst . Let bind'
633 , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs })
636 flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst)
637 (flt_subst', bind') = substBind flt_subst bind
638 new_bndrs = bindersOf bind'
640 {- Disabled: see Note [Matching cases] below
641 match renv (tv_subst, id_subst, binds) e1
642 (Case scrut case_bndr ty [(con, alt_bndrs, rhs)])
643 | exprOkForSpeculation scrut -- See Note [Matching cases]
644 , okToFloat rn_env bndrs (exprFreeVars scrut)
645 = match (renv { me_env = rn_env' })
646 (tv_subst, id_subst, binds . case_wrap)
650 rn_env' = extendRnInScopeList rn_env bndrs
651 bndrs = case_bndr : alt_bndrs
652 case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')]
655 match _ subst (Lit lit1) (Lit lit2)
659 match renv subst (App f1 a1) (App f2 a2)
660 = do { subst' <- match renv subst f1 f2
661 ; match renv subst' a1 a2 }
663 match renv subst (Lam x1 e1) (Lam x2 e2)
664 = match renv' subst e1 e2
666 renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2
667 , rv_fltR = delBndr (rv_fltR renv) x2 }
669 -- This rule does eta expansion
670 -- (\x.M) ~ N iff M ~ N x
671 -- It's important that this is *after* the let rule,
672 -- so that (\x.M) ~ (let y = e in \y.N)
673 -- does the let thing, and then gets the lam/lam rule above
674 match renv subst (Lam x1 e1) e2
675 = match renv' subst e1 (App e2 (varToCoreExpr new_x))
677 (rn_env', new_x) = rnEtaL (rv_lcl renv) x1
678 renv' = renv { rv_lcl = rn_env' }
680 -- Eta expansion the other way
681 -- M ~ (\y.N) iff M y ~ N
682 match renv subst e1 (Lam x2 e2)
683 = match renv' subst (App e1 (varToCoreExpr new_x)) e2
685 (rn_env', new_x) = rnEtaR (rv_lcl renv) x2
686 renv' = renv { rv_lcl = rn_env' }
688 match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
689 = do { subst1 <- match_ty renv subst ty1 ty2
690 ; subst2 <- match renv subst1 e1 e2
691 ; let renv' = rnMatchBndr2 renv subst x1 x2
692 ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted
695 match renv subst (Type ty1) (Type ty2)
696 = match_ty renv subst ty1 ty2
698 match renv subst (Cast e1 co1) (Cast e2 co2)
699 = do { subst1 <- match_ty renv subst co1 co2
700 ; match renv subst1 e1 e2 }
702 -- Everything else fails
703 match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
706 rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv
707 rnMatchBndr2 renv subst x1 x2
708 = renv { rv_lcl = rnBndr2 rn_env x1 x2
709 , rv_fltR = delBndr (rv_fltR renv) x2 }
711 rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst)
712 -- Typically this is a no-op, but it may matter if
713 -- there are some floated let-bindings
715 ------------------------------------------
716 match_alts :: RuleEnv
718 -> [CoreAlt] -- Template
719 -> [CoreAlt] -- Target
721 match_alts _ subst [] []
723 match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
725 = do { subst1 <- match renv' subst r1 r2
726 ; match_alts renv subst1 alts1 alts2 }
728 renv' = foldl mb renv (vs1 `zip` vs2)
729 mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2
734 ------------------------------------------
735 okToFloat :: RnEnv2 -> VarSet -> Bool
736 okToFloat rn_env bind_fvs
737 = foldVarSet ((&&) . not_captured) True bind_fvs
739 not_captured fv = not (inRnEnvR rn_env fv)
741 ------------------------------------------
745 -> CoreExpr -- Target
747 match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env })
749 | v1' `elemVarSet` tmpls
750 = match_tmpl_var renv subst v1' e2
752 | otherwise -- v1' is not a template variable; check for an exact match with e2
753 = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR
754 Var v2 | v1' == rnOccR rn_env v2
757 | Var v2' <- lookupIdSubst (text "match_var") flt_env v2
764 v1' = rnOccL rn_env v1
765 -- If the template is
766 -- forall x. f x (\x -> x) = ...
767 -- Then the x inside the lambda isn't the
768 -- template x, so we must rename first!
770 ------------------------------------------
771 match_tmpl_var :: RuleEnv
774 -> CoreExpr -- Target
777 match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env })
778 subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs })
780 | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
781 = Nothing -- Occurs check failure
782 -- e.g. match forall a. (\x-> a x) against (\y. y y)
784 | Just e1' <- lookupVarEnv id_subst v1'
785 = if eqExpr (rnInScopeSet rn_env) e1' e2'
790 = -- Note [Matching variable types]
791 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
792 -- However, we must match the *types*; e.g.
793 -- forall (c::Char->Int) (x::Char).
794 -- f (c x) = "RULE FIRED"
795 -- We must only match on args that have the right type
796 -- It's actually quite difficult to come up with an example that shows
797 -- you need type matching, esp since matching is left-to-right, so type
798 -- args get matched first. But it's possible (e.g. simplrun008) and
799 -- this is the Right Thing to do
800 do { subst' <- match_ty renv subst (idType v1') (exprType e2)
801 ; return (subst' { rs_id_subst = id_subst' }) }
803 -- e2' is the result of applying flt_env to e2
804 e2' | isEmptyVarSet let_bndrs = e2
805 | otherwise = substExpr (text "match_tmpl_var") flt_env e2
807 id_subst' = extendVarEnv (rs_id_subst subst) v1' e2'
808 -- No further renaming to do on e2',
809 -- because no free var of e2' is in the rnEnvR of the envt
811 ------------------------------------------
817 -- Matching Core types: use the matcher in TcType.
818 -- Notice that we treat newtypes as opaque. For example, suppose
819 -- we have a specialised version of a function at a newtype, say
820 -- newtype T = MkT Int
821 -- We only want to replace (f T) with f', not (f Int).
823 match_ty renv subst ty1 ty2
824 = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
825 ; return (subst { rs_tv_subst = tv_subst' }) }
827 tv_subst = rs_tv_subst subst
828 menv = ME { me_tmpls = rv_tmpls renv, me_env = rv_lcl renv }
831 Note [Expanding variables]
832 ~~~~~~~~~~~~~~~~~~~~~~~~~~
833 Here is another Very Important rule: if the term being matched is a
834 variable, we expand it so long as its unfolding is "expandable". (Its
835 occurrence information is not necessarily up to date, so we don't use
836 it.) By "expandable" we mean a WHNF or a "constructor-like" application.
837 This is the key reason for "constructor-like" Ids. If we have
838 {-# NOINLINE [1] CONLIKE g #-}
839 {-# RULE f (g x) = h x #-}
841 let v = g 3 in ....(f v)....
842 we want to make the rule fire, to replace (f v) with (h 3).
844 Note [Do not expand locally-bound variables]
845 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
846 Do *not* expand locally-bound variables, else there's a worry that the
847 unfolding might mention variables that are themselves renamed.
849 case x of y { (p,q) -> ...y... }
850 Don't expand 'y' to (p,q) because p,q might themselves have been
851 renamed. Essentially we only expand unfoldings that are "outside"
854 Hence, (a) the guard (not (isLocallyBoundR v2))
855 (b) when we expand we nuke the renaming envt (nukeRnEnvR).
857 Note [Notes in RULE matching]
858 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
859 Look through Notes in both template and expression being matched. In
860 particular, we don't want to be confused by InlineMe notes. Maybe we
861 should be more careful about profiling notes, but for now I'm just
862 riding roughshod over them. cf Note [Notes in call patterns] in
867 Matching a let-expression. Consider
868 RULE forall x. f (g x) = <rhs>
869 and target expression
870 f (let { w=R } in g E))
871 Then we'd like the rule to match, to generate
872 let { w=R } in (\x. <rhs>) E
873 In effect, we want to float the let-binding outward, to enable
874 the match to happen. This is the WHOLE REASON for accumulating
875 bindings in the RuleSubst
877 We can only do this if the free variables of R are not bound by the
878 part of the target expression outside the let binding; e.g.
879 f (\v. let w = v+1 in g E)
880 Here we obviously cannot float the let-binding for w. Hence the
883 There are a couple of tricky points.
884 (a) What if floating the binding captures a variable?
885 f (let v = x+1 in v) v
887 let v = x+1 in f (x+1) v
889 (b) What if two non-nested let bindings bind the same variable?
890 f (let v = e1 in b1) (let v = e2 in b2)
892 let v = e1 in let v = e2 in (f b2 b2)
893 See testsuite test "RuleFloatLet".
895 Our cunning plan is this:
896 * Along with the growing substitution for template variables
897 we maintain a growing set of floated let-bindings (rs_binds)
898 plus the set of variables thus bound.
900 * The RnEnv2 in the MatchEnv binds only the local binders
901 in the term (lambdas, case)
903 * When we encounter a let in the term to be matched, we
904 check that does not mention any locally bound (lambda, case)
905 variables. If so we fail
907 * We use CoreSubst.substBind to freshen the binding, using an
908 in-scope set that is the original in-scope variables plus the
909 rs_bndrs (currently floated let-bindings). So in (a) above
910 we'll freshen the 'v' binding; in (b) above we'll freshen
911 the *second* 'v' binding.
913 * We apply that freshening substitution, in a lexically-scoped
914 way to the term, although lazily; this is the rv_fltR field.
917 Note [Matching cases]
918 ~~~~~~~~~~~~~~~~~~~~~
919 {- NOTE: This idea is currently disabled. It really only works if
920 the primops involved are OkForSpeculation, and, since
921 they have side effects readIntOfAddr and touch are not.
922 Maybe we'll get back to this later . -}
925 f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->
926 case touch# fp s# of { _ ->
928 This happened in a tight loop generated by stream fusion that
929 Roman encountered. We'd like to treat this just like the let
930 case, because the primops concerned are ok-for-speculation.
931 That is, we'd like to behave as if it had been
932 case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->
933 case touch# fp s# of { _ ->
936 Note [Lookup in-scope]
937 ~~~~~~~~~~~~~~~~~~~~~~
938 Consider this example
939 foo :: Int -> Maybe Int -> Int
941 foo m (Just n) = foo (m-n) (Just n)
943 SpecConstr sees this fragment:
945 case w_smT of wild_Xf [Just A] {
946 Data.Maybe.Nothing -> lvl_smf;
947 Data.Maybe.Just n_acT [Just S(L)] ->
948 case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->
949 \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
952 and correctly generates the rule
954 RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#
955 sc_snn :: GHC.Prim.Int#}
956 \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
957 = \$s\$wfoo_sno y_amr sc_snn ;]
959 BUT we must ensure that this rule matches in the original function!
960 Note that the call to \$wfoo is
961 \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
963 During matching we expand wild_Xf to (Just n_acT). But then we must also
964 expand n_acT to (I# y_amr). And we can only do that if we look up n_acT
965 in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding
968 That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
971 %************************************************************************
973 Rule-check the program
975 %************************************************************************
977 We want to know what sites have rules that could have fired but didn't.
978 This pass runs over the tree (without changing it) and reports such.
981 -- | Report partial matches for rules beginning with the specified
982 -- string for the purposes of error reporting
983 ruleCheckProgram :: CompilerPhase -- ^ Rule activation test
984 -> String -- ^ Rule pattern
985 -> RuleBase -- ^ Database of rules
986 -> [CoreBind] -- ^ Bindings to check in
987 -> SDoc -- ^ Resulting check message
988 ruleCheckProgram phase rule_pat rule_base binds
990 = text "Rule check results: no rule application sites"
992 = vcat [text "Rule check results:",
994 vcat [ p $$ line | p <- bagToList results ]
997 env = RuleCheckEnv { rc_is_active = isActive phase
998 , rc_id_unf = idUnfolding -- Not quite right
999 -- Should use activeUnfolding
1000 , rc_pattern = rule_pat
1001 , rc_rule_base = rule_base }
1002 results = unionManyBags (map (ruleCheckBind env) binds)
1003 line = text (replicate 20 '-')
1005 data RuleCheckEnv = RuleCheckEnv {
1006 rc_is_active :: Activation -> Bool,
1007 rc_id_unf :: IdUnfoldingFun,
1008 rc_pattern :: String,
1009 rc_rule_base :: RuleBase
1012 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
1013 -- The Bag returned has one SDoc for each call site found
1014 ruleCheckBind env (NonRec _ r) = ruleCheck env r
1015 ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs]
1017 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
1018 ruleCheck _ (Var _) = emptyBag
1019 ruleCheck _ (Lit _) = emptyBag
1020 ruleCheck _ (Type _) = emptyBag
1021 ruleCheck env (App f a) = ruleCheckApp env (App f a) []
1022 ruleCheck env (Note _ e) = ruleCheck env e
1023 ruleCheck env (Cast e _) = ruleCheck env e
1024 ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
1025 ruleCheck env (Lam _ e) = ruleCheck env e
1026 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
1027 unionManyBags [ruleCheck env r | (_,_,r) <- as]
1029 ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc
1030 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
1031 ruleCheckApp env (Var f) as = ruleCheckFun env f as
1032 ruleCheckApp env other _ = ruleCheck env other
1036 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
1037 -- Produce a report for all rules matching the predicate
1038 -- saying why it doesn't match the specified application
1040 ruleCheckFun env fn args
1041 | null name_match_rules = emptyBag
1042 | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules)
1044 name_match_rules = filter match (getRules (rc_rule_base env) fn)
1045 match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
1047 ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
1048 ruleAppCheck_help env fn args rules
1049 = -- The rules match the pattern, so we want to print something
1050 vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
1051 vcat (map check_rule rules)]
1053 n_args = length args
1054 i_args = args `zip` [1::Int ..]
1055 rough_args = map roughTopName args
1057 check_rule rule = rule_herald rule <> colon <+> rule_info rule
1059 rule_herald (BuiltinRule { ru_name = name })
1060 = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name)
1061 rule_herald (Rule { ru_name = name })
1062 = ptext (sLit "Rule") <+> doubleQuotes (ftext name)
1065 | Just _ <- matchRule noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule
1066 = text "matches (which is very peculiar!)"
1068 rule_info (BuiltinRule {}) = text "does not match"
1070 rule_info (Rule { ru_act = act,
1071 ru_bndrs = rule_bndrs, ru_args = rule_args})
1072 | not (rc_is_active env act) = text "active only in later phase"
1073 | n_args < n_rule_args = text "too few arguments"
1074 | n_mismatches == n_rule_args = text "no arguments match"
1075 | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not"
1076 | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
1078 n_rule_args = length rule_args
1079 n_mismatches = length mismatches
1080 mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
1081 not (isJust (match_fn rule_arg arg))]
1083 lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars
1084 match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg
1086 in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg)
1087 renv = RV { rv_lcl = mkRnEnv2 in_scope
1088 , rv_tmpls = mkVarSet rule_bndrs
1089 , rv_fltR = mkEmptySubst in_scope
1090 , rv_unf = rc_id_unf env }