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
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 )
59 Note [Overall plumbing for rules]
60 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
61 * After the desugarer:
62 - The ModGuts initially contains mg_rules :: [CoreRule] of
63 locally-declared rules for imported Ids.
64 - Locally-declared rules for locally-declared Ids are attached to
65 the IdInfo for that Id. See Note [Attach rules to local ids] in
68 * TidyPgm strips off all the rules from local Ids and adds them to
69 mg_rules, so that the ModGuts has *all* the locally-declared rules.
71 * The HomePackageTable contains a ModDetails for each home package
72 module. Each contains md_rules :: [CoreRule] of rules declared in
73 that module. The HomePackageTable grows as ghc --make does its
74 up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules
75 are treated by the "external" route, discussed next, regardless of
76 which package they come from.
78 * The ExternalPackageState has a single eps_rule_base :: RuleBase for
79 Ids in other packages. This RuleBase simply grow monotonically, as
80 ghc --make compiles one module after another.
82 During simplification, interface files may get demand-loaded,
83 as the simplifier explores the unfoldings for Ids it has in
84 its hand. (Via an unsafePerformIO; the EPS is really a cache.)
85 That in turn may make the EPS rule-base grow. In contrast, the
86 HPT never grows in this way.
88 * The result of all this is that during Core-to-Core optimisation
89 there are four sources of rules:
91 (a) Rules in the IdInfo of the Id they are a rule for. These are
92 easy: fast to look up, and if you apply a substitution then
93 it'll be applied to the IdInfo as a matter of course.
95 (b) Rules declared in this module for imported Ids, kept in the
96 ModGuts. If you do a substitution, you'd better apply the
97 substitution to these. There are seldom many of these.
99 (c) Rules declared in the HomePackageTable. These never change.
101 (d) Rules in the ExternalPackageTable. These can grow in response
102 to lazy demand-loading of interfaces.
104 * At the moment (c) is carried in a reader-monad way by the CoreMonad.
105 The HomePackageTable doesn't have a single RuleBase because technically
106 we should only be able to "see" rules "below" this module; so we
107 generate a RuleBase for (c) by combing rules from all the modules
108 "below" us. That's why we can't just select the home-package RuleBase
111 [NB: we are inconsistent here. We should do the same for external
112 pacakges, but we don't. Same for type-class instances.]
114 * So in the outer simplifier loop, we combine (b-d) into a single
116 (b) from the ModGuts,
117 (c) from the CoreMonad, and
118 (d) from its mutable variable
119 [Of coures this means that we won't see new EPS rules that come in
120 during a single simplifier iteration, but that probably does not
124 %************************************************************************
126 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
128 %************************************************************************
130 A @CoreRule@ holds details of one rule for an @Id@, which
131 includes its specialisations.
133 For example, if a rule for @f@ contains the mapping:
135 forall a b d. [Type (List a), Type b, Var d] ===> f' a b
137 then when we find an application of f to matching types, we simply replace
138 it by the matching RHS:
140 f (List Int) Bool dict ===> f' Int Bool
142 All the stuff about how many dictionaries to discard, and what types
143 to apply the specialised function to, are handled by the fact that the
144 Rule contains a template for the result of the specialisation.
146 There is one more exciting case, which is dealt with in exactly the same
147 way. If the specialised value is unboxed then it is lifted at its
148 definition site and unlifted at its uses. For example:
150 pi :: forall a. Num a => a
152 might have a specialisation
154 [Int#] ===> (case pi' of Lift pi# -> pi#)
156 where pi' :: Lift Int# is the specialised version of pi.
159 mkRule :: Bool -> Bool -> RuleName -> Activation
160 -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
161 -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
162 -- compiled. See also 'CoreSyn.CoreRule'
163 mkRule is_auto is_local name act fn bndrs args rhs
164 = Rule { ru_name = name, ru_fn = fn, ru_act = act,
165 ru_bndrs = bndrs, ru_args = args,
166 ru_rhs = occurAnalyseExpr rhs,
167 ru_rough = roughTopNames args,
168 ru_auto = is_auto, ru_local = is_local }
171 roughTopNames :: [CoreExpr] -> [Maybe Name]
172 -- ^ Find the \"top\" free names of several expressions.
173 -- Such names are either:
175 -- 1. The function finally being applied to in an application chain
176 -- (if that name is a GlobalId: see "Var#globalvslocal"), or
178 -- 2. The 'TyCon' if the expression is a 'Type'
180 -- This is used for the fast-match-check for rules;
181 -- if the top names don't match, the rest can't
182 roughTopNames args = map roughTopName args
184 roughTopName :: CoreExpr -> Maybe Name
185 roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
186 Just (tc,_) -> Just (getName tc)
188 roughTopName (App f _) = roughTopName f
189 roughTopName (Var f) | isGlobalId f = Just (idName f)
190 | otherwise = Nothing
191 roughTopName _ = Nothing
193 ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
194 -- ^ @ruleCantMatch tpl actual@ returns True only if @actual@
195 -- definitely can't match @tpl@ by instantiating @tpl@.
196 -- It's only a one-way match; unlike instance matching we
197 -- don't consider unification.
200 -- @ruleCantMatch [Nothing] [Just n2] = False@
201 -- Reason: a template variable can be instantiated by a constant
203 -- @ruleCantMatch [Just n1] [Nothing] = False@
204 -- Reason: a local variable @v@ in the actuals might [_$_]
206 ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as
207 ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as
208 ruleCantMatch _ _ = False
212 pprRulesForUser :: [CoreRule] -> SDoc
213 -- (a) tidy the rules
214 -- (b) sort them into order based on the rule name
215 -- (c) suppress uniques (unless -dppr-debug is on)
216 -- This combination makes the output stable so we can use in testing
217 -- It's here rather than in PprCore because it calls tidyRules
218 pprRulesForUser rules
219 = withPprStyle defaultUserStyle $
222 tidyRules emptyTidyEnv rules
224 le_rule r1 r2 = ru_name r1 <= ru_name r2
228 %************************************************************************
230 SpecInfo: the rules in an IdInfo
232 %************************************************************************
235 -- | Make a 'SpecInfo' containing a number of 'CoreRule's, suitable
236 -- for putting into an 'IdInfo'
237 mkSpecInfo :: [CoreRule] -> SpecInfo
238 mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules)
240 extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
241 extendSpecInfo (SpecInfo rs1 fvs1) rs2
242 = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
244 addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
245 addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2)
246 = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
248 addIdSpecialisations :: Id -> [CoreRule] -> Id
249 addIdSpecialisations id []
251 addIdSpecialisations id rules
252 = setIdSpecialisation id $
253 extendSpecInfo (idSpecialisation id) rules
255 -- | Gather all the rules for locally bound identifiers from the supplied bindings
256 rulesOfBinds :: [CoreBind] -> [CoreRule]
257 rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
259 getRules :: RuleBase -> Id -> [CoreRule]
260 -- See Note [Where rules are found]
261 getRules rule_base fn
262 = idCoreRules fn ++ imp_rules
264 imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []
267 Note [Where rules are found]
268 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
269 The rules for an Id come from two places:
270 (a) the ones it is born with, stored inside the Id iself (idCoreRules fn),
271 (b) rules added in other modules, stored in the global RuleBase (imp_rules)
273 It's tempting to think that
274 - LocalIds have only (a)
275 - non-LocalIds have only (b)
277 but that isn't quite right:
279 - PrimOps and ClassOps are born with a bunch of rules inside the Id,
280 even when they are imported
282 - The rules in PrelRules.builtinRules should be active even
283 in the module defining the Id (when it's a LocalId), but
284 the rules are kept in the global RuleBase
287 %************************************************************************
291 %************************************************************************
294 -- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules
295 type RuleBase = NameEnv [CoreRule]
296 -- The rules are are unordered;
297 -- we sort out any overlaps on lookup
299 emptyRuleBase :: RuleBase
300 emptyRuleBase = emptyNameEnv
302 mkRuleBase :: [CoreRule] -> RuleBase
303 mkRuleBase rules = extendRuleBaseList emptyRuleBase rules
305 extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
306 extendRuleBaseList rule_base new_guys
307 = foldl extendRuleBase rule_base new_guys
309 unionRuleBase :: RuleBase -> RuleBase -> RuleBase
310 unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2
312 extendRuleBase :: RuleBase -> CoreRule -> RuleBase
313 extendRuleBase rule_base rule
314 = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule
316 pprRuleBase :: RuleBase -> SDoc
317 pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
318 | rs <- nameEnvElts rules ]
322 %************************************************************************
326 %************************************************************************
329 -- | The main rule matching function. Attempts to apply all (active)
330 -- supplied rules to this instance of an application in a given
331 -- context, returning the rule applied and the resulting expression if
333 lookupRule :: (Activation -> Bool) -- When rule is active
334 -> IdUnfoldingFun -- When Id can be unfolded
337 -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
339 -- See Note [Extra args in rule matching]
340 -- See comments on matchRule
341 lookupRule is_active id_unf in_scope fn args rules
342 = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
345 (m:ms) -> Just (findBest (fn,args) m ms)
347 rough_args = map roughTopName args
349 go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
351 go ms (r:rs) = case (matchRule is_active id_unf in_scope args rough_args r) of
352 Just e -> go ((r,e):ms) rs
353 Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$
354 -- ppr [ (arg_id, unfoldingTemplate unf)
355 -- | Var arg_id <- args
356 -- , let unf = idUnfolding arg_id
357 -- , isCheapUnfolding unf] )
360 findBest :: (Id, [CoreExpr])
361 -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
362 -- All these pairs matched the expression
363 -- Return the pair the the most specific rule
364 -- The (fn,args) is just for overlap reporting
366 findBest _ (rule,ans) [] = (rule,ans)
367 findBest target (rule1,ans1) ((rule2,ans2):prs)
368 | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
369 | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
370 | debugIsOn = let pp_rule rule
371 | opt_PprStyle_Debug = ppr rule
372 | otherwise = doubleQuotes (ftext (ru_name rule))
373 in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
374 (vcat [if opt_PprStyle_Debug then
375 ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args)
377 ptext (sLit "Rule 1:") <+> pp_rule rule1,
378 ptext (sLit "Rule 2:") <+> pp_rule rule2]) $
379 findBest target (rule1,ans1) prs
380 | otherwise = findBest target (rule1,ans1) prs
384 isMoreSpecific :: CoreRule -> CoreRule -> Bool
385 -- This tests if one rule is more specific than another
386 -- We take the view that a BuiltinRule is less specific than
387 -- anything else, because we want user-define rules to "win"
388 -- In particular, class ops have a built-in rule, but we
389 -- any user-specific rules to win
391 -- truncate :: (RealFrac a, Integral b) => a -> b
392 -- {-# RULES "truncate/Double->Int" truncate = double2Int #-}
393 -- double2Int :: Double -> Int
394 -- We want the specific RULE to beat the built-in class-op rule
395 isMoreSpecific (BuiltinRule {}) _ = False
396 isMoreSpecific (Rule {}) (BuiltinRule {}) = True
397 isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
398 (Rule { ru_bndrs = bndrs2, ru_args = args2 })
399 = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1)
401 id_unfolding_fun _ = NoUnfolding -- Don't expand in templates
402 in_scope = mkInScopeSet (mkVarSet bndrs1)
403 -- Actually we should probably include the free vars
404 -- of rule1's args, but I can't be bothered
406 noBlackList :: Activation -> Bool
407 noBlackList _ = False -- Nothing is black listed
410 Note [Extra args in rule matching]
411 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
412 If we find a matching rule, we return (Just (rule, rhs)),
413 but the rule firing has only consumed as many of the input args
414 as the ruleArity says. It's up to the caller to keep track
415 of any left-over args. E.g. if you call
416 lookupRule ... f [e1, e2, e3]
417 and it returns Just (r, rhs), where r has ruleArity 2
418 then the real rewrite is
419 f e1 e2 e3 ==> rhs e3
421 You might think it'd be cleaner for lookupRule to deal with the
422 leftover arguments, by applying 'rhs' to them, but the main call
423 in the Simplifier works better as it is. Reason: the 'args' passed
424 to lookupRule are the result of a lazy substitution
427 ------------------------------------
428 matchRule :: (Activation -> Bool) -> IdUnfoldingFun
430 -> [CoreExpr] -> [Maybe Name]
431 -> CoreRule -> Maybe CoreExpr
433 -- If (matchRule rule args) returns Just (name,rhs)
434 -- then (f args) matches the rule, and the corresponding
435 -- rewritten RHS is rhs
437 -- The bndrs and rhs is occurrence-analysed
442 -- forall f g x. map f (map g x) ==> map (f . g) x
444 -- CoreRule "map/map"
445 -- [f,g,x] -- tpl_vars
446 -- [f,map g x] -- tpl_args
447 -- map (f.g) x) -- rhs
449 -- Then the call: matchRule the_rule [e1,map e2 e3]
450 -- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
452 -- Any 'surplus' arguments in the input are simply put on the end
455 matchRule _is_active id_unf _in_scope args _rough_args
456 (BuiltinRule { ru_try = match_fn })
457 -- Built-in rules can't be switched off, it seems
458 = case match_fn id_unf args of
459 Just expr -> Just expr
462 matchRule is_active id_unf in_scope args rough_args
463 (Rule { ru_act = act, ru_rough = tpl_tops,
464 ru_bndrs = tpl_vars, ru_args = tpl_args,
466 | not (is_active act) = Nothing
467 | ruleCantMatch tpl_tops rough_args = Nothing
469 = case matchN id_unf in_scope tpl_vars tpl_args args of
471 Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $
472 rule_fn `mkApps` tpl_vals)
474 rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
475 -- We could do this when putting things into the rulebase, I guess
477 ---------------------------------------
478 matchN :: IdUnfoldingFun
479 -> InScopeSet -- ^ In-scope variables
480 -> [Var] -- ^ Match template type variables
481 -> [CoreExpr] -- ^ Match template
482 -> [CoreExpr] -- ^ Target; can have more elements than the template
483 -> Maybe (BindWrapper, -- Floated bindings; see Note [Matching lets]
485 -- For a given match template and context, find bindings to wrap around
486 -- the entire result and what should be substituted for each template variable.
487 -- Fail if there are two few actual arguments from the target to match the template
489 matchN id_unf in_scope tmpl_vars tmpl_es target_es
490 = do { (tv_subst, id_subst, binds)
491 <- go init_menv emptySubstEnv tmpl_es target_es
493 map (lookup_tmpl tv_subst id_subst) tmpl_vars') }
495 (init_rn_env, tmpl_vars') = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars
496 -- See Note [Template binders]
498 init_menv = ME { me_tmpls = mkVarSet tmpl_vars', me_env = init_rn_env }
500 go _ subst [] _ = Just subst
501 go _ _ _ [] = Nothing -- Fail if too few actual args
502 go menv subst (t:ts) (e:es) = do { subst1 <- match id_unf menv subst t e
503 ; go menv subst1 ts es }
505 lookup_tmpl :: TvSubstEnv -> IdSubstEnv -> Var -> CoreExpr
506 lookup_tmpl tv_subst id_subst tmpl_var'
507 | isTyCoVar tmpl_var' = case lookupVarEnv tv_subst tmpl_var' of
509 Nothing -> unbound tmpl_var'
510 | otherwise = case lookupVarEnv id_subst tmpl_var' of
512 _ -> unbound tmpl_var'
514 unbound var = pprPanic "Template variable unbound in rewrite rule"
515 (ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es)
518 Note [Template binders]
519 ~~~~~~~~~~~~~~~~~~~~~~~
520 Consider the following match:
521 Template: forall x. f x
523 This should succeed, because the template variable 'x' has
524 nothing to do with the 'x' in the target.
526 On reflection, this case probably does just work, but this might not
527 Template: forall x. f (\x.x)
529 Here we want to clone when we find the \x, but to know that x must be in scope
531 To achive this, we use rnBndrL to rename the template variables if
532 necessary; the renamed ones are the tmpl_vars'
535 ---------------------------------------------
536 The inner workings of matching
537 ---------------------------------------------
540 -- These two definitions are not the same as in Subst,
541 -- but they simple and direct, and purely local to this module
543 -- * The domain of the TvSubstEnv and IdSubstEnv are the template
544 -- variables passed into the match.
546 -- * The BindWrapper in a SubstEnv are the bindings floated out
547 -- from nested matches; see the Let case of match, below
549 type SubstEnv = (TvSubstEnv, IdSubstEnv, BindWrapper)
551 type BindWrapper = CoreExpr -> CoreExpr
552 -- See Notes [Matching lets] and [Matching cases]
553 -- we represent the floated bindings as a core-to-core function
555 type IdSubstEnv = IdEnv CoreExpr
557 emptySubstEnv :: SubstEnv
558 emptySubstEnv = (emptyVarEnv, emptyVarEnv, \e -> e)
560 -- At one stage I tried to match even if there are more
561 -- template args than real args.
563 -- I now think this is probably a bad idea.
564 -- Should the template (map f xs) match (map g)? I think not.
565 -- For a start, in general eta expansion wastes work.
569 match :: IdUnfoldingFun
572 -> CoreExpr -- Template
573 -> CoreExpr -- Target
576 -- See the notes with Unify.match, which matches types
577 -- Everything is very similar for terms
579 -- Interesting examples:
581 -- \x->f against \f->f
582 -- When we meet the lambdas we must remember to rename f to f' in the
583 -- second expresion. The RnEnv2 does that.
586 -- forall a. \b->b against \a->3
587 -- We must rename the \a. Otherwise when we meet the lambdas we
588 -- might substitute [a/b] in the template, and then erroneously
589 -- succeed in matching what looks like the template variable 'a' against 3.
591 -- The Var case follows closely what happens in Unify.match
592 match idu menv subst (Var v1) e2
593 | Just subst <- match_var idu menv subst v1 e2
596 match idu menv subst (Note _ e1) e2 = match idu menv subst e1 e2
597 match idu menv subst e1 (Note _ e2) = match idu menv subst e1 e2
598 -- Ignore notes in both template and thing to be matched
599 -- See Note [Notes in RULE matching]
601 match id_unfolding_fun menv subst e1 (Var v2) -- Note [Expanding variables]
602 | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables]
603 , Just e2' <- expandUnfolding_maybe (id_unfolding_fun v2')
604 = match id_unfolding_fun (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2'
606 v2' = lookupRnInScope rn_env v2
608 -- Notice that we look up v2 in the in-scope set
609 -- See Note [Lookup in-scope]
610 -- No need to apply any renaming first (hence no rnOccR)
611 -- because of the not-inRnEnvR
613 match idu menv (tv_subst, id_subst, binds) e1 (Let bind e2)
614 | okToFloat rn_env bndrs (bindFreeVars bind) -- See Note [Matching lets]
615 = match idu (menv { me_env = rn_env' })
616 (tv_subst, id_subst, binds . Let bind)
620 rn_env' = extendRnInScopeList rn_env bndrs
621 bndrs = bindersOf bind
623 {- Disabled: see Note [Matching cases] below
624 match idu menv (tv_subst, id_subst, binds) e1
625 (Case scrut case_bndr ty [(con, alt_bndrs, rhs)])
626 | exprOkForSpeculation scrut -- See Note [Matching cases]
627 , okToFloat rn_env bndrs (exprFreeVars scrut)
628 = match idu (menv { me_env = rn_env' })
629 (tv_subst, id_subst, binds . case_wrap)
633 rn_env' = extendRnInScopeList rn_env bndrs
634 bndrs = case_bndr : alt_bndrs
635 case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')]
638 match _ _ subst (Lit lit1) (Lit lit2)
642 match idu menv subst (App f1 a1) (App f2 a2)
643 = do { subst' <- match idu menv subst f1 f2
644 ; match idu menv subst' a1 a2 }
646 match idu menv subst (Lam x1 e1) (Lam x2 e2)
647 = match idu menv' subst e1 e2
649 menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
651 -- This rule does eta expansion
652 -- (\x.M) ~ N iff M ~ N x
653 -- It's important that this is *after* the let rule,
654 -- so that (\x.M) ~ (let y = e in \y.N)
655 -- does the let thing, and then gets the lam/lam rule above
656 match idu menv subst (Lam x1 e1) e2
657 = match idu menv' subst e1 (App e2 (varToCoreExpr new_x))
659 (rn_env', new_x) = rnEtaL (me_env menv) x1
660 menv' = menv { me_env = rn_env' }
662 -- Eta expansion the other way
663 -- M ~ (\y.N) iff M y ~ N
664 match idu menv subst e1 (Lam x2 e2)
665 = match idu menv' subst (App e1 (varToCoreExpr new_x)) e2
667 (rn_env', new_x) = rnEtaR (me_env menv) x2
668 menv' = menv { me_env = rn_env' }
670 match idu menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
671 = do { subst1 <- match_ty menv subst ty1 ty2
672 ; subst2 <- match idu menv subst1 e1 e2
673 ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
674 ; match_alts idu menv' subst2 alts1 alts2 -- Alts are both sorted
677 match _ menv subst (Type ty1) (Type ty2)
678 = match_ty menv subst ty1 ty2
680 match idu menv subst (Cast e1 co1) (Cast e2 co2)
681 = do { subst1 <- match_ty menv subst co1 co2
682 ; match idu menv subst1 e1 e2 }
684 -- Everything else fails
685 match _ _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
688 ------------------------------------------
689 okToFloat :: RnEnv2 -> [Var] -> VarSet -> Bool
690 okToFloat rn_env bndrs bind_fvs
691 = all freshly_bound bndrs
692 && foldVarSet ((&&) . not_captured) True bind_fvs
694 freshly_bound x = not (x `rnInScope` rn_env)
695 not_captured fv = not (inRnEnvR rn_env fv)
697 ------------------------------------------
698 match_var :: IdUnfoldingFun
702 -> CoreExpr -- Target
704 match_var idu menv subst@(tv_subst, id_subst, binds) v1 e2
705 | v1' `elemVarSet` me_tmpls menv
706 = case lookupVarEnv id_subst v1' of
707 Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
708 -> Nothing -- Occurs check failure
709 -- e.g. match forall a. (\x-> a x) against (\y. y y)
711 | otherwise -- No renaming to do on e2, because no free var
712 -- of e2 is in the rnEnvR of the envt
713 -- Note [Matching variable types]
714 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
715 -- However, we must match the *types*; e.g.
716 -- forall (c::Char->Int) (x::Char).
717 -- f (c x) = "RULE FIRED"
718 -- We must only match on args that have the right type
719 -- It's actually quite difficult to come up with an example that shows
720 -- you need type matching, esp since matching is left-to-right, so type
721 -- args get matched first. But it's possible (e.g. simplrun008) and
722 -- this is the Right Thing to do
723 -> do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst (idType v1') (exprType e2)
724 -- c.f. match_ty below
725 ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) }
727 Just e1' | eqExprX idu (nukeRnEnvL rn_env) e1' e2
733 | otherwise -- v1 is not a template variable; check for an exact match with e2
735 Var v2 | v1' == rnOccR rn_env v2 -> Just subst
740 v1' = rnOccL rn_env v1
741 -- If the template is
742 -- forall x. f x (\x -> x) = ...
743 -- Then the x inside the lambda isn't the
744 -- template x, so we must rename first!
747 ------------------------------------------
748 match_alts :: IdUnfoldingFun
751 -> [CoreAlt] -- Template
752 -> [CoreAlt] -- Target
754 match_alts _ _ subst [] []
756 match_alts idu menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
758 = do { subst1 <- match idu menv' subst r1 r2
759 ; match_alts idu menv subst1 alts1 alts2 }
762 menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 }
767 ------------------------------------------
773 -- Matching Core types: use the matcher in TcType.
774 -- Notice that we treat newtypes as opaque. For example, suppose
775 -- we have a specialised version of a function at a newtype, say
776 -- newtype T = MkT Int
777 -- We only want to replace (f T) with f', not (f Int).
779 match_ty menv (tv_subst, id_subst, binds) ty1 ty2
780 = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
781 ; return (tv_subst', id_subst, binds) }
784 Note [Expanding variables]
785 ~~~~~~~~~~~~~~~~~~~~~~~~~~
786 Here is another Very Important rule: if the term being matched is a
787 variable, we expand it so long as its unfolding is "expandable". (Its
788 occurrence information is not necessarily up to date, so we don't use
789 it.) By "expandable" we mean a WHNF or a "constructor-like" application.
790 This is the key reason for "constructor-like" Ids. If we have
791 {-# NOINLINE [1] CONLIKE g #-}
792 {-# RULE f (g x) = h x #-}
794 let v = g 3 in ....(f v)....
795 we want to make the rule fire, to replace (f v) with (h 3).
797 Note [Do not expand locally-bound variables]
798 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
799 Do *not* expand locally-bound variables, else there's a worry that the
800 unfolding might mention variables that are themselves renamed.
802 case x of y { (p,q) -> ...y... }
803 Don't expand 'y' to (p,q) because p,q might themselves have been
804 renamed. Essentially we only expand unfoldings that are "outside"
807 Hence, (a) the guard (not (isLocallyBoundR v2))
808 (b) when we expand we nuke the renaming envt (nukeRnEnvR).
810 Note [Notes in RULE matching]
811 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
812 Look through Notes in both template and expression being matched. In
813 particular, we don't want to be confused by InlineMe notes. Maybe we
814 should be more careful about profiling notes, but for now I'm just
815 riding roughshod over them. cf Note [Notes in call patterns] in
820 Matching a let-expression. Consider
821 RULE forall x. f (g x) = <rhs>
822 and target expression
823 f (let { w=R } in g E))
824 Then we'd like the rule to match, to generate
825 let { w=R } in (\x. <rhs>) E
826 In effect, we want to float the let-binding outward, to enable
827 the match to happen. This is the WHOLE REASON for accumulating
828 bindings in the SubstEnv
830 We can only do this if
831 (a) Widening the scope of w does not capture any variables
832 We use a conservative test: w is not already in scope
833 If not, we clone the binders, and substitute
834 (b) The free variables of R are not bound by the part of the
835 target expression outside the let binding; e.g.
836 f (\v. let w = v+1 in g E)
837 Here we obviously cannot float the let-binding for w.
839 You may think rule (a) would never apply, because rule matching is
840 mostly invoked from the simplifier, when we have just run substExpr
841 over the argument, so there will be no shadowing anyway.
842 The fly in the ointment is that the forall'd variables of the
843 RULE itself are considered in scope.
845 I though of various ways to solve (a). One plan was to
846 clone the binders if they are in scope. But watch out!
847 (let x=y+1 in let z=x+1 in (z,z)
848 --> should match (p,p) but watch out that
849 the use of x on z's rhs is OK!
850 If we clone x, then the let-binding for 'z' is then caught by (b),
851 at least unless we elaborate the RnEnv stuff a bit.
853 So for we simply fail to match unless both (a) and (b) hold.
855 Other cases to think about
856 (let x=y+1 in \x. (x,x))
857 --> let x=y+1 in (\x1. (x1,x1))
858 (\x. let x = y+1 in (x,x))
859 --> let x1 = y+1 in (\x. (x1,x1)
860 (let x=y+1 in (x,x), let x=y-1 in (x,x))
861 --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1))
863 Note [Matching cases]
864 ~~~~~~~~~~~~~~~~~~~~~
865 {- NOTE: This idea is currently disabled. It really only works if
866 the primops involved are OkForSpeculation, and, since
867 they have side effects readIntOfAddr and touch are not.
868 Maybe we'll get back to this later . -}
871 f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->
872 case touch# fp s# of { _ ->
874 This happened in a tight loop generated by stream fusion that
875 Roman encountered. We'd like to treat this just like the let
876 case, because the primops concerned are ok-for-speculation.
877 That is, we'd like to behave as if it had been
878 case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->
879 case touch# fp s# of { _ ->
882 Note [Lookup in-scope]
883 ~~~~~~~~~~~~~~~~~~~~~~
884 Consider this example
885 foo :: Int -> Maybe Int -> Int
887 foo m (Just n) = foo (m-n) (Just n)
889 SpecConstr sees this fragment:
891 case w_smT of wild_Xf [Just A] {
892 Data.Maybe.Nothing -> lvl_smf;
893 Data.Maybe.Just n_acT [Just S(L)] ->
894 case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->
895 \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
898 and correctly generates the rule
900 RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#
901 sc_snn :: GHC.Prim.Int#}
902 \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
903 = \$s\$wfoo_sno y_amr sc_snn ;]
905 BUT we must ensure that this rule matches in the original function!
906 Note that the call to \$wfoo is
907 \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
909 During matching we expand wild_Xf to (Just n_acT). But then we must also
910 expand n_acT to (I# y_amr). And we can only do that if we look up n_acT
911 in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding
914 That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
917 %************************************************************************
919 Rule-check the program
921 %************************************************************************
923 We want to know what sites have rules that could have fired but didn't.
924 This pass runs over the tree (without changing it) and reports such.
927 -- | Report partial matches for rules beginning with the specified
928 -- string for the purposes of error reporting
929 ruleCheckProgram :: CompilerPhase -- ^ Rule activation test
930 -> String -- ^ Rule pattern
931 -> RuleBase -- ^ Database of rules
932 -> [CoreBind] -- ^ Bindings to check in
933 -> SDoc -- ^ Resulting check message
934 ruleCheckProgram phase rule_pat rule_base binds
936 = text "Rule check results: no rule application sites"
938 = vcat [text "Rule check results:",
940 vcat [ p $$ line | p <- bagToList results ]
943 env = RuleCheckEnv { rc_is_active = isActive phase
944 , rc_id_unf = idUnfolding -- Not quite right
945 -- Should use activeUnfolding
946 , rc_pattern = rule_pat
947 , rc_rule_base = rule_base }
948 results = unionManyBags (map (ruleCheckBind env) binds)
949 line = text (replicate 20 '-')
951 data RuleCheckEnv = RuleCheckEnv {
952 rc_is_active :: Activation -> Bool,
953 rc_id_unf :: IdUnfoldingFun,
954 rc_pattern :: String,
955 rc_rule_base :: RuleBase
958 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
959 -- The Bag returned has one SDoc for each call site found
960 ruleCheckBind env (NonRec _ r) = ruleCheck env r
961 ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs]
963 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
964 ruleCheck _ (Var _) = emptyBag
965 ruleCheck _ (Lit _) = emptyBag
966 ruleCheck _ (Type _) = emptyBag
967 ruleCheck env (App f a) = ruleCheckApp env (App f a) []
968 ruleCheck env (Note _ e) = ruleCheck env e
969 ruleCheck env (Cast e _) = ruleCheck env e
970 ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
971 ruleCheck env (Lam _ e) = ruleCheck env e
972 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
973 unionManyBags [ruleCheck env r | (_,_,r) <- as]
975 ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc
976 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
977 ruleCheckApp env (Var f) as = ruleCheckFun env f as
978 ruleCheckApp env other _ = ruleCheck env other
982 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
983 -- Produce a report for all rules matching the predicate
984 -- saying why it doesn't match the specified application
986 ruleCheckFun env fn args
987 | null name_match_rules = emptyBag
988 | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules)
990 name_match_rules = filter match (getRules (rc_rule_base env) fn)
991 match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
993 ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
994 ruleAppCheck_help env fn args rules
995 = -- The rules match the pattern, so we want to print something
996 vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
997 vcat (map check_rule rules)]
1000 i_args = args `zip` [1::Int ..]
1001 rough_args = map roughTopName args
1003 check_rule rule = rule_herald rule <> colon <+> rule_info rule
1005 rule_herald (BuiltinRule { ru_name = name })
1006 = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name)
1007 rule_herald (Rule { ru_name = name })
1008 = ptext (sLit "Rule") <+> doubleQuotes (ftext name)
1011 | Just _ <- matchRule noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule
1012 = text "matches (which is very peculiar!)"
1014 rule_info (BuiltinRule {}) = text "does not match"
1016 rule_info (Rule { ru_act = act,
1017 ru_bndrs = rule_bndrs, ru_args = rule_args})
1018 | not (rc_is_active env act) = text "active only in later phase"
1019 | n_args < n_rule_args = text "too few arguments"
1020 | n_mismatches == n_rule_args = text "no arguments match"
1021 | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not"
1022 | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
1024 n_rule_args = length rule_args
1025 n_mismatches = length mismatches
1026 mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
1027 not (isJust (match_fn rule_arg arg))]
1029 lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars
1030 match_fn rule_arg arg = match (rc_id_unf env) menv emptySubstEnv rule_arg arg
1032 in_scope = lhs_fvs `unionVarSet` exprFreeVars arg
1033 menv = ME { me_env = mkRnEnv2 (mkInScopeSet in_scope)
1034 , me_tmpls = mkVarSet rule_bndrs }