2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreRules]{Transformation rules}
8 RuleBase, emptyRuleBase,
9 extendRuleBase, extendRuleBaseList, addRuleBaseFVs,
10 ruleBaseIds, ruleBaseFVs,
11 pprRuleBase, ruleCheckProgram,
13 lookupRule, addRule, addIdSpecialisations
16 #include "HsVersions.h"
18 import CoreSyn -- All of it
19 import OccurAnal ( occurAnalyseRule )
20 import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleLhsFreeIds )
21 import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
22 import CoreUtils ( eqExpr )
23 import CoreTidy ( pprTidyIdRules )
24 import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
25 substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet,
26 bindSubstList, unBindSubstList, substInScope, uniqAway
28 import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
32 import TcType ( mkTyVarTy )
33 import qualified TcType ( match )
34 import BasicTypes ( Activation, CompilerPhase, isActive )
38 import Maybe ( isJust, isNothing, fromMaybe )
39 import Util ( sortLt )
41 import List ( isPrefixOf )
45 %************************************************************************
47 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
49 %************************************************************************
51 A @CoreRule@ holds details of one rule for an @Id@, which
52 includes its specialisations.
54 For example, if a rule for @f@ contains the mapping:
56 forall a b d. [Type (List a), Type b, Var d] ===> f' a b
58 then when we find an application of f to matching types, we simply replace
59 it by the matching RHS:
61 f (List Int) Bool dict ===> f' Int Bool
63 All the stuff about how many dictionaries to discard, and what types
64 to apply the specialised function to, are handled by the fact that the
65 Rule contains a template for the result of the specialisation.
67 There is one more exciting case, which is dealt with in exactly the same
68 way. If the specialised value is unboxed then it is lifted at its
69 definition site and unlifted at its uses. For example:
71 pi :: forall a. Num a => a
73 might have a specialisation
75 [Int#] ===> (case pi' of Lift pi# -> pi#)
77 where pi' :: Lift Int# is the specialised version of pi.
80 %************************************************************************
84 %************************************************************************
87 matchRules :: (Activation -> Bool) -> InScopeSet
88 -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
89 -- See comments on matchRule
90 matchRules is_active in_scope [] args = Nothing
91 matchRules is_active in_scope (rule:rules) args
92 = case matchRule is_active in_scope rule args of
93 Just result -> Just result
94 Nothing -> matchRules is_active in_scope rules args
96 noBlackList :: Activation -> Bool
97 noBlackList act = False -- Nothing is black listed
99 matchRule :: (Activation -> Bool) -> InScopeSet
100 -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
102 -- If (matchRule rule args) returns Just (name,rhs)
103 -- then (f args) matches the rule, and the corresponding
104 -- rewritten RHS is rhs
106 -- The bndrs and rhs is occurrence-analysed
111 -- forall f g x. map f (map g x) ==> map (f . g) x
113 -- CoreRule "map/map"
114 -- [f,g,x] -- tpl_vars
115 -- [f,map g x] -- tpl_args
116 -- map (f.g) x) -- rhs
118 -- Then the call: matchRule the_rule [e1,map e2 e3]
119 -- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
121 -- Any 'surplus' arguments in the input are simply put on the end
125 -- A1. No top-level variable is bound in the target
126 -- A2. No template variable is bound in the target
127 -- A3. No lambda bound template variable is free in any subexpression of the target
129 -- To see why A1 is necessary, consider matching
130 -- \x->f against \f->f
131 -- When we meet the lambdas we substitute [f/x] in the template (a no-op),
132 -- and then erroneously succeed in matching f against f.
134 -- To see why A2 is needed consider matching
135 -- forall a. \b->b against \a->3
136 -- When we meet the lambdas we substitute [a/b] in the template, and then
137 -- erroneously succeed in matching what looks like the template variable 'a' against 3.
139 -- A3 is needed to validate the rule that says
142 -- (\x->E) matches (\x->F x)
145 matchRule is_active in_scope rule@(BuiltinRule name match_fn) args
146 = case match_fn args of
147 Just expr -> Just (name,expr)
150 matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args
151 | not (is_active act)
154 = go tpl_args args emptySubst
155 -- We used to use the in_scope set, but I don't think that's necessary
156 -- After all, the result is going to be simplified again with that in_scope set
158 tpl_var_set = mkVarSet tpl_vars
160 -----------------------
162 go (tpl_arg:tpl_args) (arg:args) subst = match tpl_arg arg tpl_var_set (go tpl_args args) subst
164 -- Two easy ways to terminate
165 go [] [] subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars)
166 go [] args subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars `mkApps` args)
168 -- One tiresome way to terminate: check for excess unmatched
169 -- template arguments
170 go tpl_args [] subst = Nothing -- Failure
173 -----------------------
174 app_match subst fn vs = foldl go fn vs
176 senv = substEnv subst
177 go fn v = case lookupSubstEnv senv v of
178 Just (DoneEx ex) -> fn `App` ex
179 Just (DoneTy ty) -> fn `App` Type ty
180 -- Substitution should bind them all!
183 -----------------------
184 {- The code below tries to match even if there are more
185 template args than real args.
187 I now think this is probably a bad idea.
188 Should the template (map f xs) match (map g)? I think not.
189 For a start, in general eta expansion wastes work.
192 = case eta_complete tpl_args (mkVarSet leftovers) of
193 Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs),
194 mk_result_args subst done)
195 Nothing -> Nothing -- Failure
197 (done, leftovers) = partition (\v -> isJust (lookupSubstEnv subst_env v))
198 (map zapOccInfo tpl_vars)
200 subst_env = substEnv subst
202 -----------------------
203 eta_complete [] vars = ASSERT( isEmptyVarSet vars )
205 eta_complete (Type ty:tpl_args) vars
206 = case getTyVar_maybe ty of
207 Just tv | tv `elemVarSet` vars
208 -> case eta_complete tpl_args (vars `delVarSet` tv) of
209 Just vars' -> Just (tv:vars')
213 eta_complete (Var v:tpl_args) vars
214 | v `elemVarSet` vars
215 = case eta_complete tpl_args (vars `delVarSet` v) of
216 Just vars' -> Just (v:vars')
219 eta_complete other vars = Nothing
222 zapOccInfo bndr | isTyVar bndr = bndr
223 | otherwise = zapLamIdInfo bndr
228 type Matcher result = VarSet -- Template variables
229 -> (Subst -> Maybe result) -- Continuation if success
230 -> Subst -> Maybe result -- Substitution so far -> result
231 -- The *SubstEnv* in these Substs apply to the TEMPLATE only
233 -- The *InScopeSet* in these Substs gives variables bound so far in the
234 -- target term. So when matching forall a. (\x. a x) against (\y. y y)
235 -- while processing the body of the lambdas, the in-scope set will be {y}.
236 -- That lets us do the occurs-check when matching 'a' against 'y'
238 match :: CoreExpr -- Template
239 -> CoreExpr -- Target
244 match (Var v1) e2 tpl_vars kont subst
245 = case lookupSubst subst v1 of
246 Nothing | v1 `elemVarSet` tpl_vars -- v1 is a template variable
247 -> if (any (`isInScope` subst) (varSetElems (exprFreeVars e2))) then
248 match_fail -- Occurs check failure
249 -- e.g. match forall a. (\x-> a x) against (\y. y y)
251 kont (extendSubst subst v1 (DoneEx e2))
254 | eqExpr (Var v1) e2 -> kont subst
255 -- v1 is not a template variable, so it must be a global constant
257 Just (DoneEx e2') | eqExpr e2' e2 -> kont subst
261 match (Lit lit1) (Lit lit2) tpl_vars kont subst
265 match (App f1 a1) (App f2 a2) tpl_vars kont subst
266 = match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst
268 match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
269 = bind [x1] [x2] (match e1 e2) tpl_vars kont subst
271 -- This rule does eta expansion
272 -- (\x.M) ~ N iff M ~ N x
274 match (Lam x1 e1) e2 tpl_vars kont subst
275 = bind [x1] [x1] (match e1 (App e2 (mkVarArg x1))) tpl_vars kont subst
277 -- Eta expansion the other way
278 -- M ~ (\y.N) iff \y.M y ~ \y.N
280 -- Remembering that by (A), y can't be free in M, we get this
281 match e1 (Lam x2 e2) tpl_vars kont subst
282 = bind [new_id] [x2] (match (App e1 (mkVarArg new_id)) e2) tpl_vars kont subst
284 new_id = uniqAway (substInScope subst) x2
285 -- This uniqAway is actually needed. Here's the example:
286 -- rule: foldr (mapFB (:) f) [] = mapList
287 -- target: foldr (\x. mapFB k f x) []
289 -- k = \x. mapFB ... x
290 -- The first \x is ok, but when we inline k, hoping it might
291 -- match (:) we find a second \x.
293 match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
294 = match e1 e2 tpl_vars case_kont subst
296 case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLt lt_alt alts2))
299 match (Type ty1) (Type ty2) tpl_vars kont subst
300 = match_ty ty1 ty2 tpl_vars kont subst
302 match (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
304 = (match_ty to1 to2 tpl_vars $
305 match_ty from1 from2 tpl_vars $
306 match e1 e2 tpl_vars kont) subst
309 {- I don't buy this let-rule any more
310 The let rule fails on matching
311 forall f,x,xs. f (x:xs)
313 f (let y = e in (y:[]))
314 because we just get x->y, which is bogus.
316 -- This is an interesting rule: we simply ignore lets in the
317 -- term being matched against! The unfolding inside it is (by assumption)
318 -- already inside any occurrences of the bound variables, so we'll expand
319 -- them when we encounter them. Meanwhile, we can't get false matches because
320 -- (also by assumption) the term being matched has no shadowing.
321 match e1 (Let bind e2) tpl_vars kont subst
322 = match e1 e2 tpl_vars kont subst
325 -- Here is another important rule: if the term being matched is a
326 -- variable, we expand it so long as its unfolding is a WHNF
327 -- (Its occurrence information is not necessarily up to date,
328 -- so we don't use it.)
329 match e1 (Var v2) tpl_vars kont subst
330 | isCheapUnfolding unfolding
331 = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst
333 unfolding = idUnfolding v2
336 -- We can't cope with lets in the template
338 match e1 e2 tpl_vars kont subst = match_fail
341 ------------------------------------------
342 match_alts [] [] tpl_vars kont subst
344 match_alts ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) tpl_vars kont subst
346 = bind vs1 vs2 (match r1 r2) tpl_vars
347 (match_alts alts1 alts2 tpl_vars kont)
349 match_alts alts1 alts2 tpl_vars kont subst = match_fail
351 lt_alt (con1, _, _) (con2, _, _) = con1 < con2
353 ----------------------------------------
354 bind :: [CoreBndr] -- Template binders
355 -> [CoreBndr] -- Target binders
358 -- This makes uses of assumption (A) above. For example,
360 -- Template: (\x.y) (y is free)
361 -- Target : (\y.y) (y is bound)
362 -- We rename x to y in the template... but then erroneously
363 -- match y against y. But this can't happen because of (A)
364 bind vs1 vs2 matcher tpl_vars kont subst
365 = WARN( not (all not_in_subst vs1), bug_msg )
366 matcher tpl_vars kont' subst'
368 kont' subst'' = kont (unBindSubstList subst'' vs1 vs2)
369 subst' = bindSubstList subst vs1 vs2
371 -- The unBindSubst relies on no shadowing in the template
372 not_in_subst v = isNothing (lookupSubst subst v)
373 bug_msg = sep [ppr vs1, ppr vs2]
375 ----------------------------------------
376 matches [] [] tpl_vars kont subst
378 matches (e:es) (e':es') tpl_vars kont subst
379 = match e e' tpl_vars (matches es es' tpl_vars kont) subst
380 matches es es' tpl_vars kont subst
383 ----------------------------------------
384 mkVarArg :: CoreBndr -> CoreArg
385 mkVarArg v | isId v = Var v
386 | otherwise = Type (mkTyVarTy v)
389 Matching Core types: use the matcher in TcType.
390 Notice that we treat newtypes as opaque. For example, suppose
391 we have a specialised version of a function at a newtype, say
393 We only want to replace (f T) with f', not (f Int).
396 ----------------------------------------
397 match_ty ty1 ty2 tpl_vars kont subst
398 = TcType.match ty1 ty2 tpl_vars kont' (substEnv subst)
400 kont' senv = kont (setSubstEnv subst senv)
405 %************************************************************************
407 \subsection{Adding a new rule}
409 %************************************************************************
412 addRule :: Id -> CoreRules -> CoreRule -> CoreRules
414 -- Add a new rule to an existing bunch of rules.
415 -- The rules are for the given Id; the Id argument is needed only
416 -- so that we can exclude the Id from its own RHS free-var set
418 -- Insert the new rule just before a rule that is *less specific*
419 -- than the new one; or at the end if there isn't such a one.
420 -- In this way we make sure that when looking up, the first match
421 -- is the most specific.
423 -- We make no check for rules that unify without one dominating
424 -- the other. Arguably this would be a bug.
426 addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _)
427 = Rules (rule:rules) rhs_fvs
428 -- Put it at the start for lack of anything better
430 addRule id (Rules rules rhs_fvs) rule
431 = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
433 new_rule = occurAnalyseRule rule
434 new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id
436 -- Don't include the Id in its own rhs free-var set.
437 -- Otherwise the occurrence analyser makes bindings recursive
438 -- that shoudn't be. E.g.
439 -- RULE: f (f x y) z ==> f x (f y z)
441 insertRule rules new_rule@(Rule _ _ tpl_vars tpl_args _)
444 tpl_var_set = mkInScopeSet (mkVarSet tpl_vars)
445 -- Actually we should probably include the free vars of tpl_args,
446 -- but I can't be bothered
449 go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
450 | otherwise = rule : go rules
452 new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args)
454 addIdSpecialisations :: Id -> [CoreRule] -> Id
455 addIdSpecialisations id rules
456 = setIdSpecialisation id new_specs
458 new_specs = foldl (addRule id) (idSpecialisation id) rules
462 %************************************************************************
464 \subsection{Looking up a rule}
466 %************************************************************************
469 lookupRule :: (Activation -> Bool) -> InScopeSet
470 -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
471 lookupRule is_active in_scope fn args
472 = case idSpecialisation fn of
473 Rules rules _ -> matchRules is_active in_scope rules args
477 %************************************************************************
479 \subsection{Checking a program for failing rule applications}
481 %************************************************************************
483 -----------------------------------------------------
485 -----------------------------------------------------
487 We want to know what sites have rules that could have fired but didn't.
488 This pass runs over the tree (without changing it) and reports such.
490 NB: we assume that this follows a run of the simplifier, so every Id
491 occurrence (including occurrences of imported Ids) is decorated with
492 all its (active) rules. No need to construct a rule base or anything
496 ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc
497 -- Report partial matches for rules beginning
498 -- with the specified string
499 ruleCheckProgram phase rule_pat binds
501 = text "Rule check results: no rule application sites"
503 = vcat [text "Rule check results:",
505 vcat [ p $$ line | p <- bagToList results ]
508 results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
509 line = text (replicate 20 '-')
511 type RuleCheckEnv = (CompilerPhase, String) -- Phase and Pattern
513 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
514 -- The Bag returned has one SDoc for each call site found
515 ruleCheckBind env (NonRec b r) = ruleCheck env r
516 ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (b,r) <- prs]
518 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
519 ruleCheck env (Var v) = emptyBag
520 ruleCheck env (Lit l) = emptyBag
521 ruleCheck env (Type ty) = emptyBag
522 ruleCheck env (App f a) = ruleCheckApp env (App f a) []
523 ruleCheck env (Note n e) = ruleCheck env e
524 ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
525 ruleCheck env (Lam b e) = ruleCheck env e
526 ruleCheck env (Case e _ as) = ruleCheck env e `unionBags`
527 unionManyBags [ruleCheck env r | (_,_,r) <- as]
529 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
530 ruleCheckApp env (Var f) as = ruleCheckFun env f as
531 ruleCheckApp env other as = ruleCheck env other
535 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
536 -- Produce a report for all rules matching the predicate
537 -- saying why it doesn't match the specified application
539 ruleCheckFun (phase, pat) fn args
540 | null name_match_rules = emptyBag
541 | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules)
543 name_match_rules = case idSpecialisation fn of
544 Rules rules _ -> filter match rules
545 match rule = pat `isPrefixOf` unpackFS (ruleName rule)
547 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
548 ruleAppCheck_help phase fn args rules
549 = -- The rules match the pattern, so we want to print something
550 vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
551 vcat (map check_rule rules)]
554 i_args = args `zip` [1::Int ..]
556 check_rule rule = rule_herald rule <> colon <+> rule_info rule
558 rule_herald (BuiltinRule name _) =
559 ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
560 rule_herald (Rule name _ _ _ _) =
561 ptext SLIT("Rule") <+> doubleQuotes (ftext name)
564 | Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args
565 = text "matches (which is very peculiar!)"
567 rule_info (BuiltinRule name fn) = text "does not match"
569 rule_info (Rule name act rule_bndrs rule_args _)
570 | not (isActive phase act) = text "active only in later phase"
571 | n_args < n_rule_args = text "too few arguments"
572 | n_mismatches == n_rule_args = text "no arguments match"
573 | n_mismatches == 0 = text "all arguments match (considered individually), but the rule as a whole does not"
574 | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
576 n_rule_args = length rule_args
577 n_mismatches = length mismatches
578 mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
579 not (isJust (match_fn rule_arg arg))]
581 bndr_set = mkVarSet rule_bndrs
582 match_fn rule_arg arg = match rule_arg arg bndr_set (\s -> Just ()) emptySubst
586 %************************************************************************
588 \subsection{Getting the rules ready}
590 %************************************************************************
593 data RuleBase = RuleBase
594 IdSet -- Ids with their rules in their specialisations
595 -- Held as a set, so that it can simply be the initial
596 -- in-scope set in the simplifier
598 IdSet -- Ids (whether local or imported) mentioned on
599 -- LHS of some rule; these should be black listed
601 -- This representation is a bit cute, and I wonder if we should
602 -- change it to use (IdEnv CoreRule) which seems a bit more natural
604 ruleBaseIds (RuleBase ids _) = ids
605 ruleBaseFVs (RuleBase _ fvs) = fvs
607 emptyRuleBase = RuleBase emptyVarSet emptyVarSet
609 addRuleBaseFVs :: RuleBase -> IdSet -> RuleBase
610 addRuleBaseFVs (RuleBase rules fvs) extra_fvs
611 = RuleBase rules (fvs `unionVarSet` extra_fvs)
613 extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase
614 extendRuleBaseList rule_base new_guys
615 = foldl extendRuleBase rule_base new_guys
617 extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase
618 extendRuleBase (RuleBase rule_ids rule_fvs) (id, rule)
619 = RuleBase (extendVarSet rule_ids new_id)
620 (rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
622 new_id = setIdSpecialisation id (addRule id old_rules rule)
624 old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id))
625 -- Get the old rules from rule_ids if the Id is already there, but
626 -- if not, use the Id from the incoming rule. If may be a PrimOpId,
627 -- in which case it may have rules in its belly already. Seems
628 -- dreadfully hackoid.
630 lhs_fvs = ruleLhsFreeIds rule
631 -- Finds *all* the free Ids of the LHS, not just
632 -- locally defined ones!!
634 pprRuleBase :: RuleBase -> SDoc
635 pprRuleBase (RuleBase rules _) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]