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 PprCore ( pprCoreRule )
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 )
37 import Maybe ( isJust, isNothing, fromMaybe )
38 import Util ( sortLt )
40 import List ( isPrefixOf )
44 %************************************************************************
46 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
48 %************************************************************************
50 A @CoreRule@ holds details of one rule for an @Id@, which
51 includes its specialisations.
53 For example, if a rule for @f@ contains the mapping:
55 forall a b d. [Type (List a), Type b, Var d] ===> f' a b
57 then when we find an application of f to matching types, we simply replace
58 it by the matching RHS:
60 f (List Int) Bool dict ===> f' Int Bool
62 All the stuff about how many dictionaries to discard, and what types
63 to apply the specialised function to, are handled by the fact that the
64 Rule contains a template for the result of the specialisation.
66 There is one more exciting case, which is dealt with in exactly the same
67 way. If the specialised value is unboxed then it is lifted at its
68 definition site and unlifted at its uses. For example:
70 pi :: forall a. Num a => a
72 might have a specialisation
74 [Int#] ===> (case pi' of Lift pi# -> pi#)
76 where pi' :: Lift Int# is the specialised version of pi.
79 %************************************************************************
83 %************************************************************************
86 matchRules :: (Activation -> Bool) -> InScopeSet
87 -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
88 -- See comments on matchRule
89 matchRules is_active in_scope [] args = Nothing
90 matchRules is_active in_scope (rule:rules) args
91 = case matchRule is_active in_scope rule args of
92 Just result -> Just result
93 Nothing -> matchRules is_active in_scope rules args
95 noBlackList :: Activation -> Bool
96 noBlackList act = False -- Nothing is black listed
98 matchRule :: (Activation -> Bool) -> InScopeSet
99 -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
101 -- If (matchRule rule args) returns Just (name,rhs)
102 -- then (f args) matches the rule, and the corresponding
103 -- rewritten RHS is rhs
105 -- The bndrs and rhs is occurrence-analysed
110 -- forall f g x. map f (map g x) ==> map (f . g) x
112 -- CoreRule "map/map"
113 -- [f,g,x] -- tpl_vars
114 -- [f,map g x] -- tpl_args
115 -- map (f.g) x) -- rhs
117 -- Then the call: matchRule the_rule [e1,map e2 e3]
118 -- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
120 -- Any 'surplus' arguments in the input are simply put on the end
124 -- A1. No top-level variable is bound in the target
125 -- A2. No template variable is bound in the target
126 -- A3. No lambda bound template variable is free in any subexpression of the target
128 -- To see why A1 is necessary, consider matching
129 -- \x->f against \f->f
130 -- When we meet the lambdas we substitute [f/x] in the template (a no-op),
131 -- and then erroneously succeed in matching f against f.
133 -- To see why A2 is needed consider matching
134 -- forall a. \b->b against \a->3
135 -- When we meet the lambdas we substitute [a/b] in the template, and then
136 -- erroneously succeed in matching what looks like the template variable 'a' against 3.
138 -- A3 is needed to validate the rule that says
141 -- (\x->E) matches (\x->F x)
144 matchRule is_active in_scope rule@(BuiltinRule name match_fn) args
145 = case match_fn args of
146 Just expr -> Just (name,expr)
149 matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args
150 | not (is_active act)
153 = go tpl_args args emptySubst
154 -- We used to use the in_scope set, but I don't think that's necessary
155 -- After all, the result is going to be simplified again with that in_scope set
157 tpl_var_set = mkVarSet tpl_vars
159 -----------------------
161 go (tpl_arg:tpl_args) (arg:args) subst = match tpl_arg arg tpl_var_set (go tpl_args args) subst
163 -- Two easy ways to terminate
164 go [] [] subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars)
165 go [] args subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars `mkApps` args)
167 -- One tiresome way to terminate: check for excess unmatched
168 -- template arguments
169 go tpl_args [] subst = Nothing -- Failure
172 -----------------------
173 app_match subst fn vs = foldl go fn vs
175 senv = substEnv subst
176 go fn v = case lookupSubstEnv senv v of
177 Just (DoneEx ex) -> fn `App` ex
178 Just (DoneTy ty) -> fn `App` Type ty
179 -- Substitution should bind them all!
182 -----------------------
183 {- The code below tries to match even if there are more
184 template args than real args.
186 I now think this is probably a bad idea.
187 Should the template (map f xs) match (map g)? I think not.
188 For a start, in general eta expansion wastes work.
191 = case eta_complete tpl_args (mkVarSet leftovers) of
192 Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs),
193 mk_result_args subst done)
194 Nothing -> Nothing -- Failure
196 (done, leftovers) = partition (\v -> isJust (lookupSubstEnv subst_env v))
197 (map zapOccInfo tpl_vars)
199 subst_env = substEnv subst
201 -----------------------
202 eta_complete [] vars = ASSERT( isEmptyVarSet vars )
204 eta_complete (Type ty:tpl_args) vars
205 = case getTyVar_maybe ty of
206 Just tv | tv `elemVarSet` vars
207 -> case eta_complete tpl_args (vars `delVarSet` tv) of
208 Just vars' -> Just (tv:vars')
212 eta_complete (Var v:tpl_args) vars
213 | v `elemVarSet` vars
214 = case eta_complete tpl_args (vars `delVarSet` v) of
215 Just vars' -> Just (v:vars')
218 eta_complete other vars = Nothing
221 zapOccInfo bndr | isTyVar bndr = bndr
222 | otherwise = zapLamIdInfo bndr
227 type Matcher result = VarSet -- Template variables
228 -> (Subst -> Maybe result) -- Continuation if success
229 -> Subst -> Maybe result -- Substitution so far -> result
230 -- The *SubstEnv* in these Substs apply to the TEMPLATE only
232 -- The *InScopeSet* in these Substs gives variables bound so far in the
233 -- target term. So when matching forall a. (\x. a x) against (\y. y y)
234 -- while processing the body of the lambdas, the in-scope set will be {y}.
235 -- That lets us do the occurs-check when matching 'a' against 'y'
237 match :: CoreExpr -- Template
238 -> CoreExpr -- Target
243 match (Var v1) e2 tpl_vars kont subst
244 = case lookupSubst subst v1 of
245 Nothing | v1 `elemVarSet` tpl_vars -- v1 is a template variable
246 -> if (any (`isInScope` subst) (varSetElems (exprFreeVars e2))) then
247 match_fail -- Occurs check failure
248 -- e.g. match forall a. (\x-> a x) against (\y. y y)
250 kont (extendSubst subst v1 (DoneEx e2))
253 | eqExpr (Var v1) e2 -> kont subst
254 -- v1 is not a template variable, so it must be a global constant
256 Just (DoneEx e2') | eqExpr e2' e2 -> kont subst
260 match (Lit lit1) (Lit lit2) tpl_vars kont subst
264 match (App f1 a1) (App f2 a2) tpl_vars kont subst
265 = match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst
267 match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
268 = bind [x1] [x2] (match e1 e2) tpl_vars kont subst
270 -- This rule does eta expansion
271 -- (\x.M) ~ N iff M ~ N x
273 match (Lam x1 e1) e2 tpl_vars kont subst
274 = bind [x1] [x1] (match e1 (App e2 (mkVarArg x1))) tpl_vars kont subst
276 -- Eta expansion the other way
277 -- M ~ (\y.N) iff \y.M y ~ \y.N
279 -- Remembering that by (A), y can't be free in M, we get this
280 match e1 (Lam x2 e2) tpl_vars kont subst
281 = bind [new_id] [x2] (match (App e1 (mkVarArg new_id)) e2) tpl_vars kont subst
283 new_id = uniqAway (substInScope subst) x2
284 -- This uniqAway is actually needed. Here's the example:
285 -- rule: foldr (mapFB (:) f) [] = mapList
286 -- target: foldr (\x. mapFB k f x) []
288 -- k = \x. mapFB ... x
289 -- The first \x is ok, but when we inline k, hoping it might
290 -- match (:) we find a second \x.
292 match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
293 = match e1 e2 tpl_vars case_kont subst
295 case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLt lt_alt alts2))
298 match (Type ty1) (Type ty2) tpl_vars kont subst
299 = match_ty ty1 ty2 tpl_vars kont subst
301 match (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
303 = (match_ty to1 to2 tpl_vars $
304 match_ty from1 from2 tpl_vars $
305 match e1 e2 tpl_vars kont) subst
308 {- I don't buy this let-rule any more
309 The let rule fails on matching
310 forall f,x,xs. f (x:xs)
312 f (let y = e in (y:[]))
313 because we just get x->y, which is bogus.
315 -- This is an interesting rule: we simply ignore lets in the
316 -- term being matched against! The unfolding inside it is (by assumption)
317 -- already inside any occurrences of the bound variables, so we'll expand
318 -- them when we encounter them. Meanwhile, we can't get false matches because
319 -- (also by assumption) the term being matched has no shadowing.
320 match e1 (Let bind e2) tpl_vars kont subst
321 = match e1 e2 tpl_vars kont subst
324 -- Here is another important rule: if the term being matched is a
325 -- variable, we expand it so long as its unfolding is a WHNF
326 -- (Its occurrence information is not necessarily up to date,
327 -- so we don't use it.)
328 match e1 (Var v2) tpl_vars kont subst
329 | isCheapUnfolding unfolding
330 = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst
332 unfolding = idUnfolding v2
335 -- We can't cope with lets in the template
337 match e1 e2 tpl_vars kont subst = match_fail
340 ------------------------------------------
341 match_alts [] [] tpl_vars kont subst
343 match_alts ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) tpl_vars kont subst
345 = bind vs1 vs2 (match r1 r2) tpl_vars
346 (match_alts alts1 alts2 tpl_vars kont)
348 match_alts alts1 alts2 tpl_vars kont subst = match_fail
350 lt_alt (con1, _, _) (con2, _, _) = con1 < con2
352 ----------------------------------------
353 bind :: [CoreBndr] -- Template binders
354 -> [CoreBndr] -- Target binders
357 -- This makes uses of assumption (A) above. For example,
359 -- Template: (\x.y) (y is free)
360 -- Target : (\y.y) (y is bound)
361 -- We rename x to y in the template... but then erroneously
362 -- match y against y. But this can't happen because of (A)
363 bind vs1 vs2 matcher tpl_vars kont subst
364 = WARN( not (all not_in_subst vs1), bug_msg )
365 matcher tpl_vars kont' subst'
367 kont' subst'' = kont (unBindSubstList subst'' vs1 vs2)
368 subst' = bindSubstList subst vs1 vs2
370 -- The unBindSubst relies on no shadowing in the template
371 not_in_subst v = isNothing (lookupSubst subst v)
372 bug_msg = sep [ppr vs1, ppr vs2]
374 ----------------------------------------
375 matches [] [] tpl_vars kont subst
377 matches (e:es) (e':es') tpl_vars kont subst
378 = match e e' tpl_vars (matches es es' tpl_vars kont) subst
379 matches es es' tpl_vars kont subst
382 ----------------------------------------
383 mkVarArg :: CoreBndr -> CoreArg
384 mkVarArg v | isId v = Var v
385 | otherwise = Type (mkTyVarTy v)
388 Matching Core types: use the matcher in TcType.
389 Notice that we treat newtypes as opaque. For example, suppose
390 we have a specialised version of a function at a newtype, say
392 We only want to replace (f T) with f', not (f Int).
395 ----------------------------------------
396 match_ty ty1 ty2 tpl_vars kont subst
397 = TcType.match ty1 ty2 tpl_vars kont' (substEnv subst)
399 kont' senv = kont (setSubstEnv subst senv)
404 %************************************************************************
406 \subsection{Adding a new rule}
408 %************************************************************************
411 addRule :: Id -> CoreRules -> CoreRule -> CoreRules
413 -- Add a new rule to an existing bunch of rules.
414 -- The rules are for the given Id; the Id argument is needed only
415 -- so that we can exclude the Id from its own RHS free-var set
417 -- Insert the new rule just before a rule that is *less specific*
418 -- than the new one; or at the end if there isn't such a one.
419 -- In this way we make sure that when looking up, the first match
420 -- is the most specific.
422 -- We make no check for rules that unify without one dominating
423 -- the other. Arguably this would be a bug.
425 addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _)
426 = Rules (rule:rules) rhs_fvs
427 -- Put it at the start for lack of anything better
429 addRule id (Rules rules rhs_fvs) rule
430 = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
432 new_rule = occurAnalyseRule rule
433 new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id
435 -- Don't include the Id in its own rhs free-var set.
436 -- Otherwise the occurrence analyser makes bindings recursive
437 -- that shoudn't be. E.g.
438 -- RULE: f (f x y) z ==> f x (f y z)
440 insertRule rules new_rule@(Rule _ _ tpl_vars tpl_args _)
443 tpl_var_set = mkInScopeSet (mkVarSet tpl_vars)
444 -- Actually we should probably include the free vars of tpl_args,
445 -- but I can't be bothered
448 go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
449 | otherwise = rule : go rules
451 new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args)
453 addIdSpecialisations :: Id -> [CoreRule] -> Id
454 addIdSpecialisations id rules
455 = setIdSpecialisation id new_specs
457 new_specs = foldl (addRule id) (idSpecialisation id) rules
461 %************************************************************************
463 \subsection{Looking up a rule}
465 %************************************************************************
468 lookupRule :: (Activation -> Bool) -> InScopeSet
469 -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
470 lookupRule is_active in_scope fn args
471 = case idSpecialisation fn of
472 Rules rules _ -> matchRules is_active in_scope rules args
476 %************************************************************************
478 \subsection{Checking a program for failing rule applications}
480 %************************************************************************
482 -----------------------------------------------------
484 -----------------------------------------------------
486 We want to know what sites have rules that could have fired but didn't.
487 This pass runs over the tree (without changing it) and reports such.
489 NB: we assume that this follows a run of the simplifier, so every Id
490 occurrence (including occurrences of imported Ids) is decorated with
491 all its (active) rules. No need to construct a rule base or anything
495 ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc
496 -- Report partial matches for rules beginning
497 -- with the specified string
498 ruleCheckProgram phase rule_pat binds
500 = text "Rule check results: no rule application sites"
502 = vcat [text "Rule check results:",
504 vcat [ p $$ line | p <- bagToList results ]
507 results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
508 line = text (replicate 20 '-')
510 type RuleCheckEnv = (CompilerPhase, String) -- Phase and Pattern
512 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
513 -- The Bag returned has one SDoc for each call site found
514 ruleCheckBind env (NonRec b r) = ruleCheck env r
515 ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (b,r) <- prs]
517 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
518 ruleCheck env (Var v) = emptyBag
519 ruleCheck env (Lit l) = emptyBag
520 ruleCheck env (Type ty) = emptyBag
521 ruleCheck env (App f a) = ruleCheckApp env (App f a) []
522 ruleCheck env (Note n e) = ruleCheck env e
523 ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
524 ruleCheck env (Lam b e) = ruleCheck env e
525 ruleCheck env (Case e _ as) = ruleCheck env e `unionBags`
526 unionManyBags [ruleCheck env r | (_,_,r) <- as]
528 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
529 ruleCheckApp env (Var f) as = ruleCheckFun env f as
530 ruleCheckApp env other as = ruleCheck env other
534 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
535 -- Produce a report for all rules matching the predicate
536 -- saying why it doesn't match the specified application
538 ruleCheckFun (phase, pat) fn args
539 | null name_match_rules = emptyBag
540 | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules)
542 name_match_rules = case idSpecialisation fn of
543 Rules rules _ -> filter match rules
544 match rule = pat `isPrefixOf` _UNPK_ (ruleName rule)
546 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
547 ruleAppCheck_help phase fn args rules
548 = -- The rules match the pattern, so we want to print something
549 vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
550 vcat (map check_rule rules)]
553 i_args = args `zip` [1::Int ..]
555 check_rule rule = rule_herald rule <> colon <+> rule_info rule
557 rule_herald (BuiltinRule name _) = text "Builtin rule" <+> doubleQuotes (ptext name)
558 rule_herald (Rule name _ _ _ _) = text "Rule" <+> doubleQuotes (ptext name)
561 | Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args
562 = text "matches (which is very peculiar!)"
564 rule_info (BuiltinRule name fn) = text "does not match"
566 rule_info (Rule name act rule_bndrs rule_args _)
567 | not (isActive phase act) = text "active only in later phase"
568 | n_args < n_rule_args = text "too few arguments"
569 | n_mismatches == n_rule_args = text "no arguments match"
570 | n_mismatches == 0 = text "all arguments match (considered individually), but the rule as a whole does not"
571 | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
573 n_rule_args = length rule_args
574 n_mismatches = length mismatches
575 mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
576 not (isJust (match_fn rule_arg arg))]
578 bndr_set = mkVarSet rule_bndrs
579 match_fn rule_arg arg = match rule_arg arg bndr_set (\s -> Just ()) emptySubst
583 %************************************************************************
585 \subsection{Getting the rules ready}
587 %************************************************************************
590 data RuleBase = RuleBase
591 IdSet -- Ids with their rules in their specialisations
592 -- Held as a set, so that it can simply be the initial
593 -- in-scope set in the simplifier
595 IdSet -- Ids (whether local or imported) mentioned on
596 -- LHS of some rule; these should be black listed
598 -- This representation is a bit cute, and I wonder if we should
599 -- change it to use (IdEnv CoreRule) which seems a bit more natural
601 ruleBaseIds (RuleBase ids _) = ids
602 ruleBaseFVs (RuleBase _ fvs) = fvs
604 emptyRuleBase = RuleBase emptyVarSet emptyVarSet
606 addRuleBaseFVs :: RuleBase -> IdSet -> RuleBase
607 addRuleBaseFVs (RuleBase rules fvs) extra_fvs
608 = RuleBase rules (fvs `unionVarSet` extra_fvs)
610 extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase
611 extendRuleBaseList rule_base new_guys
612 = foldl extendRuleBase rule_base new_guys
614 extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase
615 extendRuleBase (RuleBase rule_ids rule_fvs) (id, rule)
616 = RuleBase (extendVarSet rule_ids new_id)
617 (rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
619 new_id = setIdSpecialisation id (addRule id old_rules rule)
621 old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id))
622 -- Get the old rules from rule_ids if the Id is already there, but
623 -- if not, use the Id from the incoming rule. If may be a PrimOpId,
624 -- in which case it may have rules in its belly already. Seems
625 -- dreadfully hackoid.
627 lhs_fvs = ruleLhsFreeIds rule
628 -- Finds *all* the free Ids of the LHS, not just
629 -- locally defined ones!!
631 pprRuleBase :: RuleBase -> SDoc
632 pprRuleBase (RuleBase rules _) = vcat [ pprCoreRule (ppr id) rs
633 | id <- varSetElems rules,
634 rs <- rulesRules $ idSpecialisation id ]