2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreRules]{Transformation rules}
8 RuleBase, emptyRuleBase,
9 extendRuleBase, extendRuleBaseList,
10 ruleBaseIds, getLocalRules,
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 )
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, idIsFrom, idUnfolding, idSpecialisation, setIdSpecialisation )
32 import TcType ( mkTyVarTy )
33 import qualified TcType ( match )
34 import BasicTypes ( Activation, CompilerPhase, isActive )
35 import Module ( Module )
39 import Maybe ( isJust, isNothing, fromMaybe )
40 import Util ( sortLt )
42 import List ( isPrefixOf, partition )
46 %************************************************************************
48 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
50 %************************************************************************
52 A @CoreRule@ holds details of one rule for an @Id@, which
53 includes its specialisations.
55 For example, if a rule for @f@ contains the mapping:
57 forall a b d. [Type (List a), Type b, Var d] ===> f' a b
59 then when we find an application of f to matching types, we simply replace
60 it by the matching RHS:
62 f (List Int) Bool dict ===> f' Int Bool
64 All the stuff about how many dictionaries to discard, and what types
65 to apply the specialised function to, are handled by the fact that the
66 Rule contains a template for the result of the specialisation.
68 There is one more exciting case, which is dealt with in exactly the same
69 way. If the specialised value is unboxed then it is lifted at its
70 definition site and unlifted at its uses. For example:
72 pi :: forall a. Num a => a
74 might have a specialisation
76 [Int#] ===> (case pi' of Lift pi# -> pi#)
78 where pi' :: Lift Int# is the specialised version of pi.
81 %************************************************************************
85 %************************************************************************
88 matchRules :: (Activation -> Bool) -> InScopeSet
89 -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
90 -- See comments on matchRule
91 matchRules is_active in_scope [] args = Nothing
92 matchRules is_active in_scope (rule:rules) args
93 = case matchRule is_active in_scope rule args of
94 Just result -> Just result
95 Nothing -> matchRules is_active in_scope rules args
97 noBlackList :: Activation -> Bool
98 noBlackList act = False -- Nothing is black listed
100 matchRule :: (Activation -> Bool) -> InScopeSet
101 -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
103 -- If (matchRule rule args) returns Just (name,rhs)
104 -- then (f args) matches the rule, and the corresponding
105 -- rewritten RHS is rhs
107 -- The bndrs and rhs is occurrence-analysed
112 -- forall f g x. map f (map g x) ==> map (f . g) x
114 -- CoreRule "map/map"
115 -- [f,g,x] -- tpl_vars
116 -- [f,map g x] -- tpl_args
117 -- map (f.g) x) -- rhs
119 -- Then the call: matchRule the_rule [e1,map e2 e3]
120 -- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
122 -- Any 'surplus' arguments in the input are simply put on the end
126 -- A1. No top-level variable is bound in the target
127 -- A2. No template variable is bound in the target
128 -- A3. No lambda bound template variable is free in any subexpression of the target
130 -- To see why A1 is necessary, consider matching
131 -- \x->f against \f->f
132 -- When we meet the lambdas we substitute [f/x] in the template (a no-op),
133 -- and then erroneously succeed in matching f against f.
135 -- To see why A2 is needed consider matching
136 -- forall a. \b->b against \a->3
137 -- When we meet the lambdas we substitute [a/b] in the template, and then
138 -- erroneously succeed in matching what looks like the template variable 'a' against 3.
140 -- A3 is needed to validate the rule that says
143 -- (\x->E) matches (\x->F x)
146 matchRule is_active in_scope rule@(BuiltinRule name match_fn) args
147 = case match_fn args of
148 Just expr -> Just (name,expr)
151 matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args
152 | not (is_active act)
155 = go tpl_args args emptySubst
156 -- We used to use the in_scope set, but I don't think that's necessary
157 -- After all, the result is going to be simplified again with that in_scope set
159 tpl_var_set = mkVarSet tpl_vars
161 -----------------------
163 go (tpl_arg:tpl_args) (arg:args) subst = match tpl_arg arg tpl_var_set (go tpl_args args) subst
165 -- Two easy ways to terminate
166 go [] [] subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars)
167 go [] args subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars `mkApps` args)
169 -- One tiresome way to terminate: check for excess unmatched
170 -- template arguments
171 go tpl_args [] subst = Nothing -- Failure
174 -----------------------
175 app_match subst fn vs = foldl go fn vs
177 senv = substEnv subst
178 go fn v = case lookupSubstEnv senv v of
179 Just (DoneEx ex) -> fn `App` ex
180 Just (DoneTy ty) -> fn `App` Type ty
181 -- Substitution should bind them all!
184 -----------------------
185 {- The code below tries to match even if there are more
186 template args than real args.
188 I now think this is probably a bad idea.
189 Should the template (map f xs) match (map g)? I think not.
190 For a start, in general eta expansion wastes work.
193 = case eta_complete tpl_args (mkVarSet leftovers) of
194 Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs),
195 mk_result_args subst done)
196 Nothing -> Nothing -- Failure
198 (done, leftovers) = partition (\v -> isJust (lookupSubstEnv subst_env v))
199 (map zapOccInfo tpl_vars)
201 subst_env = substEnv subst
203 -----------------------
204 eta_complete [] vars = ASSERT( isEmptyVarSet vars )
206 eta_complete (Type ty:tpl_args) vars
207 = case getTyVar_maybe ty of
208 Just tv | tv `elemVarSet` vars
209 -> case eta_complete tpl_args (vars `delVarSet` tv) of
210 Just vars' -> Just (tv:vars')
214 eta_complete (Var v:tpl_args) vars
215 | v `elemVarSet` vars
216 = case eta_complete tpl_args (vars `delVarSet` v) of
217 Just vars' -> Just (v:vars')
220 eta_complete other vars = Nothing
223 zapOccInfo bndr | isTyVar bndr = bndr
224 | otherwise = zapLamIdInfo bndr
229 type Matcher result = VarSet -- Template variables
230 -> (Subst -> Maybe result) -- Continuation if success
231 -> Subst -> Maybe result -- Substitution so far -> result
232 -- The *SubstEnv* in these Substs apply to the TEMPLATE only
234 -- The *InScopeSet* in these Substs gives variables bound so far in the
235 -- target term. So when matching forall a. (\x. a x) against (\y. y y)
236 -- while processing the body of the lambdas, the in-scope set will be {y}.
237 -- That lets us do the occurs-check when matching 'a' against 'y'
239 match :: CoreExpr -- Template
240 -> CoreExpr -- Target
245 match (Var v1) e2 tpl_vars kont subst
246 = case lookupSubst subst v1 of
247 Nothing | v1 `elemVarSet` tpl_vars -- v1 is a template variable
248 -> if (any (`isInScope` subst) (varSetElems (exprFreeVars e2))) then
249 match_fail -- Occurs check failure
250 -- e.g. match forall a. (\x-> a x) against (\y. y y)
252 kont (extendSubst subst v1 (DoneEx e2))
255 | eqExpr (Var v1) e2 -> kont subst
256 -- v1 is not a template variable, so it must be a global constant
258 Just (DoneEx e2') | eqExpr e2' e2 -> kont subst
262 match (Lit lit1) (Lit lit2) tpl_vars kont subst
266 match (App f1 a1) (App f2 a2) tpl_vars kont subst
267 = match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst
269 match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
270 = bind [x1] [x2] (match e1 e2) tpl_vars kont subst
272 -- This rule does eta expansion
273 -- (\x.M) ~ N iff M ~ N x
275 match (Lam x1 e1) e2 tpl_vars kont subst
276 = bind [x1] [x1] (match e1 (App e2 (mkVarArg x1))) tpl_vars kont subst
278 -- Eta expansion the other way
279 -- M ~ (\y.N) iff \y.M y ~ \y.N
281 -- Remembering that by (A), y can't be free in M, we get this
282 match e1 (Lam x2 e2) tpl_vars kont subst
283 = bind [new_id] [x2] (match (App e1 (mkVarArg new_id)) e2) tpl_vars kont subst
285 new_id = uniqAway (substInScope subst) x2
286 -- This uniqAway is actually needed. Here's the example:
287 -- rule: foldr (mapFB (:) f) [] = mapList
288 -- target: foldr (\x. mapFB k f x) []
290 -- k = \x. mapFB ... x
291 -- The first \x is ok, but when we inline k, hoping it might
292 -- match (:) we find a second \x.
294 match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
295 = match e1 e2 tpl_vars case_kont subst
297 case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLt lt_alt alts2))
300 match (Type ty1) (Type ty2) tpl_vars kont subst
301 = match_ty ty1 ty2 tpl_vars kont subst
303 match (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
305 = (match_ty to1 to2 tpl_vars $
306 match_ty from1 from2 tpl_vars $
307 match e1 e2 tpl_vars kont) subst
310 {- I don't buy this let-rule any more
311 The let rule fails on matching
312 forall f,x,xs. f (x:xs)
314 f (let y = e in (y:[]))
315 because we just get x->y, which is bogus.
317 -- This is an interesting rule: we simply ignore lets in the
318 -- term being matched against! The unfolding inside it is (by assumption)
319 -- already inside any occurrences of the bound variables, so we'll expand
320 -- them when we encounter them. Meanwhile, we can't get false matches because
321 -- (also by assumption) the term being matched has no shadowing.
322 match e1 (Let bind e2) tpl_vars kont subst
323 = match e1 e2 tpl_vars kont subst
326 -- Here is another important rule: if the term being matched is a
327 -- variable, we expand it so long as its unfolding is a WHNF
328 -- (Its occurrence information is not necessarily up to date,
329 -- so we don't use it.)
330 match e1 (Var v2) tpl_vars kont subst
331 | isCheapUnfolding unfolding
332 = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst
334 unfolding = idUnfolding v2
337 -- We can't cope with lets in the template
339 match e1 e2 tpl_vars kont subst = match_fail
342 ------------------------------------------
343 match_alts [] [] tpl_vars kont subst
345 match_alts ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) tpl_vars kont subst
347 = bind vs1 vs2 (match r1 r2) tpl_vars
348 (match_alts alts1 alts2 tpl_vars kont)
350 match_alts alts1 alts2 tpl_vars kont subst = match_fail
352 lt_alt (con1, _, _) (con2, _, _) = con1 < con2
354 ----------------------------------------
355 bind :: [CoreBndr] -- Template binders
356 -> [CoreBndr] -- Target binders
359 -- This makes uses of assumption (A) above. For example,
361 -- Template: (\x.y) (y is free)
362 -- Target : (\y.y) (y is bound)
363 -- We rename x to y in the template... but then erroneously
364 -- match y against y. But this can't happen because of (A)
365 bind vs1 vs2 matcher tpl_vars kont subst
366 = WARN( not (all not_in_subst vs1), bug_msg )
367 matcher tpl_vars kont' subst'
369 kont' subst'' = kont (unBindSubstList subst'' vs1 vs2)
370 subst' = bindSubstList subst vs1 vs2
372 -- The unBindSubst relies on no shadowing in the template
373 not_in_subst v = isNothing (lookupSubst subst v)
374 bug_msg = sep [ppr vs1, ppr vs2]
376 ----------------------------------------
377 mkVarArg :: CoreBndr -> CoreArg
378 mkVarArg v | isId v = Var v
379 | otherwise = Type (mkTyVarTy v)
382 Matching Core types: use the matcher in TcType.
383 Notice that we treat newtypes as opaque. For example, suppose
384 we have a specialised version of a function at a newtype, say
386 We only want to replace (f T) with f', not (f Int).
389 ----------------------------------------
390 match_ty ty1 ty2 tpl_vars kont subst
391 = TcType.match ty1 ty2 tpl_vars kont' (substEnv subst)
393 kont' senv = kont (setSubstEnv subst senv)
398 %************************************************************************
400 \subsection{Adding a new rule}
402 %************************************************************************
405 addRule :: Id -> CoreRules -> CoreRule -> CoreRules
407 -- Add a new rule to an existing bunch of rules.
408 -- The rules are for the given Id; the Id argument is needed only
409 -- so that we can exclude the Id from its own RHS free-var set
411 -- Insert the new rule just before a rule that is *less specific*
412 -- than the new one; or at the end if there isn't such a one.
413 -- In this way we make sure that when looking up, the first match
414 -- is the most specific.
416 -- We make no check for rules that unify without one dominating
417 -- the other. Arguably this would be a bug.
419 addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _)
420 = Rules (rule:rules) rhs_fvs
421 -- Put it at the start for lack of anything better
423 addRule id (Rules rules rhs_fvs) rule
424 = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
426 new_rule = occurAnalyseRule rule
427 new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id
429 -- Don't include the Id in its own rhs free-var set.
430 -- Otherwise the occurrence analyser makes bindings recursive
431 -- that shoudn't be. E.g.
432 -- RULE: f (f x y) z ==> f x (f y z)
434 insertRule rules new_rule@(Rule _ _ tpl_vars tpl_args _)
437 tpl_var_set = mkInScopeSet (mkVarSet tpl_vars)
438 -- Actually we should probably include the free vars of tpl_args,
439 -- but I can't be bothered
442 go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
443 | otherwise = rule : go rules
445 new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args)
447 addIdSpecialisations :: Id -> [CoreRule] -> Id
448 addIdSpecialisations id rules
449 = setIdSpecialisation id new_specs
451 new_specs = foldl (addRule id) (idSpecialisation id) rules
455 %************************************************************************
457 \subsection{Looking up a rule}
459 %************************************************************************
462 lookupRule :: (Activation -> Bool) -> InScopeSet
463 -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
464 lookupRule is_active in_scope fn args
465 = case idSpecialisation fn of
466 Rules rules _ -> matchRules is_active in_scope rules args
470 %************************************************************************
472 \subsection{Checking a program for failing rule applications}
474 %************************************************************************
476 -----------------------------------------------------
478 -----------------------------------------------------
480 We want to know what sites have rules that could have fired but didn't.
481 This pass runs over the tree (without changing it) and reports such.
483 NB: we assume that this follows a run of the simplifier, so every Id
484 occurrence (including occurrences of imported Ids) is decorated with
485 all its (active) rules. No need to construct a rule base or anything
489 ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc
490 -- Report partial matches for rules beginning
491 -- with the specified string
492 ruleCheckProgram phase rule_pat binds
494 = text "Rule check results: no rule application sites"
496 = vcat [text "Rule check results:",
498 vcat [ p $$ line | p <- bagToList results ]
501 results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
502 line = text (replicate 20 '-')
504 type RuleCheckEnv = (CompilerPhase, String) -- Phase and Pattern
506 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
507 -- The Bag returned has one SDoc for each call site found
508 ruleCheckBind env (NonRec b r) = ruleCheck env r
509 ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (b,r) <- prs]
511 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
512 ruleCheck env (Var v) = emptyBag
513 ruleCheck env (Lit l) = emptyBag
514 ruleCheck env (Type ty) = emptyBag
515 ruleCheck env (App f a) = ruleCheckApp env (App f a) []
516 ruleCheck env (Note n e) = ruleCheck env e
517 ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
518 ruleCheck env (Lam b e) = ruleCheck env e
519 ruleCheck env (Case e _ as) = ruleCheck env e `unionBags`
520 unionManyBags [ruleCheck env r | (_,_,r) <- as]
522 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
523 ruleCheckApp env (Var f) as = ruleCheckFun env f as
524 ruleCheckApp env other as = ruleCheck env other
528 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
529 -- Produce a report for all rules matching the predicate
530 -- saying why it doesn't match the specified application
532 ruleCheckFun (phase, pat) fn args
533 | null name_match_rules = emptyBag
534 | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules)
536 name_match_rules = case idSpecialisation fn of
537 Rules rules _ -> filter match rules
538 match rule = pat `isPrefixOf` unpackFS (ruleName rule)
540 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
541 ruleAppCheck_help phase fn args rules
542 = -- The rules match the pattern, so we want to print something
543 vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
544 vcat (map check_rule rules)]
547 i_args = args `zip` [1::Int ..]
549 check_rule rule = rule_herald rule <> colon <+> rule_info rule
551 rule_herald (BuiltinRule name _) =
552 ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
553 rule_herald (Rule name _ _ _ _) =
554 ptext SLIT("Rule") <+> doubleQuotes (ftext name)
557 | Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args
558 = text "matches (which is very peculiar!)"
560 rule_info (BuiltinRule name fn) = text "does not match"
562 rule_info (Rule name act rule_bndrs rule_args _)
563 | not (isActive phase act) = text "active only in later phase"
564 | n_args < n_rule_args = text "too few arguments"
565 | n_mismatches == n_rule_args = text "no arguments match"
566 | n_mismatches == 0 = text "all arguments match (considered individually), but the rule as a whole does not"
567 | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
569 n_rule_args = length rule_args
570 n_mismatches = length mismatches
571 mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
572 not (isJust (match_fn rule_arg arg))]
574 bndr_set = mkVarSet rule_bndrs
575 match_fn rule_arg arg = match rule_arg arg bndr_set (\s -> Just ()) emptySubst
579 %************************************************************************
581 \subsection{Getting the rules ready}
583 %************************************************************************
586 data RuleBase = RuleBase
587 IdSet -- Ids with their rules in their specialisations
588 -- Held as a set, so that it can simply be the initial
589 -- in-scope set in the simplifier
590 -- This representation is a bit cute, and I wonder if we should
591 -- change it to use (IdEnv CoreRule) which seems a bit more natural
593 ruleBaseIds (RuleBase ids) = ids
594 emptyRuleBase = RuleBase emptyVarSet
596 extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase
597 extendRuleBaseList rule_base new_guys
598 = foldl extendRuleBase rule_base new_guys
600 extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase
601 extendRuleBase (RuleBase rule_ids) (id, rule)
602 = RuleBase (extendVarSet rule_ids new_id)
604 new_id = setIdSpecialisation id (addRule id old_rules rule)
605 old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id))
606 -- Get the old rules from rule_ids if the Id is already there, but
607 -- if not, use the Id from the incoming rule. If may be a PrimOpId,
608 -- in which case it may have rules in its belly already. Seems
609 -- dreadfully hackoid.
611 getLocalRules :: Module -> RuleBase -> (IdSet, -- Ids with local rules
612 RuleBase) -- Non-local rules
613 -- Get the rules for locally-defined Ids out of the RuleBase
614 -- If we miss any rules for Ids defined here, then we end up
615 -- giving the local decl a new Unique (because the in-scope-set is (hackily) the
616 -- same as the non-local-rule-id set, so the Id looks as if it's in scope
617 -- and hence should be cloned), and now the binding for the class method
618 -- doesn't have the same Unique as the one in the Class and the tc-env
619 -- Example: class Foo a where
621 -- {-# RULES "op" op x = x #-}
623 -- NB we can't use isLocalId, because isLocalId isn't true of class methods.
624 getLocalRules this_mod (RuleBase ids)
625 = (mkVarSet local_ids, RuleBase (mkVarSet imp_ids))
627 (local_ids, imp_ids) = partition (idIsFrom this_mod) (varSetElems ids)
629 pprRuleBase :: RuleBase -> SDoc
630 pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]