2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreRules]{Transformation rules}
8 RuleBase, emptyRuleBase,
10 ruleBaseIds, pprRuleBase, ruleCheckProgram,
12 lookupRule, addRule, addIdSpecialisations
15 #include "HsVersions.h"
17 import CoreSyn -- All of it
18 import OccurAnal ( occurAnalyseRule )
19 import CoreFVs ( exprFreeVars, exprsFreeVars, ruleRhsFreeVars )
20 import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
21 import CoreUtils ( tcEqExprX )
22 import CoreTidy ( pprTidyIdRules )
23 import Subst ( IdSubstEnv, SubstResult(..) )
24 import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
28 import TcType ( TvSubstEnv )
29 import Unify ( tcMatchTyX, MatchEnv(..) )
30 import BasicTypes ( Activation, CompilerPhase, isActive )
34 import Maybe ( isJust, fromMaybe )
36 import List ( isPrefixOf )
40 %************************************************************************
42 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
44 %************************************************************************
46 A @CoreRule@ holds details of one rule for an @Id@, which
47 includes its specialisations.
49 For example, if a rule for @f@ contains the mapping:
51 forall a b d. [Type (List a), Type b, Var d] ===> f' a b
53 then when we find an application of f to matching types, we simply replace
54 it by the matching RHS:
56 f (List Int) Bool dict ===> f' Int Bool
58 All the stuff about how many dictionaries to discard, and what types
59 to apply the specialised function to, are handled by the fact that the
60 Rule contains a template for the result of the specialisation.
62 There is one more exciting case, which is dealt with in exactly the same
63 way. If the specialised value is unboxed then it is lifted at its
64 definition site and unlifted at its uses. For example:
66 pi :: forall a. Num a => a
68 might have a specialisation
70 [Int#] ===> (case pi' of Lift pi# -> pi#)
72 where pi' :: Lift Int# is the specialised version of pi.
75 %************************************************************************
79 %************************************************************************
82 matchRules :: (Activation -> Bool) -> InScopeSet
83 -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
84 -- See comments on matchRule
85 matchRules is_active in_scope [] args = Nothing
86 matchRules is_active in_scope (rule:rules) args
87 = case matchRule is_active in_scope rule args of
88 Just result -> Just result
89 Nothing -> matchRules is_active in_scope rules args
91 noBlackList :: Activation -> Bool
92 noBlackList act = False -- Nothing is black listed
94 matchRule :: (Activation -> Bool) -> InScopeSet
95 -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
97 -- If (matchRule rule args) returns Just (name,rhs)
98 -- then (f args) matches the rule, and the corresponding
99 -- rewritten RHS is rhs
101 -- The bndrs and rhs is occurrence-analysed
106 -- forall f g x. map f (map g x) ==> map (f . g) x
108 -- CoreRule "map/map"
109 -- [f,g,x] -- tpl_vars
110 -- [f,map g x] -- tpl_args
111 -- map (f.g) x) -- rhs
113 -- Then the call: matchRule the_rule [e1,map e2 e3]
114 -- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
116 -- Any 'surplus' arguments in the input are simply put on the end
119 matchRule is_active in_scope rule@(BuiltinRule name match_fn) args
120 = case match_fn args of
121 Just expr -> Just (name,expr)
124 matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args
125 | not (is_active act)
128 = case matchN in_scope tpl_vars tpl_args args of
129 Just (tpl_vals, leftovers) -> Just (rn, mkLams tpl_vars rhs `mkApps` tpl_vals `mkApps` leftovers)
135 -> [Var] -- Template tyvars
136 -> [CoreExpr] -- Template
137 -> [CoreExpr] -- Target; can have more elts than template
138 -> Maybe ([CoreExpr], -- What is substituted for each template var
139 [CoreExpr]) -- Leftover target exprs
141 matchN in_scope tmpl_vars tmpl_es target_es
142 = do { (subst, leftover_es) <- go init_menv emptySubstEnv tmpl_es target_es
143 ; return (map (lookup_tmpl subst) tmpl_vars, leftover_es) }
145 init_menv = ME { me_tmpls = mkVarSet tmpl_vars, me_env = init_rn_env }
146 init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars)
148 go menv subst [] es = Just (subst, es)
149 go menv subst ts [] = Nothing -- Fail if too few actual args
150 go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
151 ; go menv subst1 ts es }
153 lookup_tmpl :: (TvSubstEnv, IdSubstEnv) -> Var -> CoreExpr
154 lookup_tmpl (tv_subst, id_subst) tmpl_var
155 | isTyVar tmpl_var = case lookupVarEnv tv_subst tmpl_var of
157 Nothing -> unbound tmpl_var
158 | otherwise = case lookupVarEnv id_subst tmpl_var of
160 other -> unbound tmpl_var
162 unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var)
164 emptySubstEnv :: (TvSubstEnv, IdSubstEnv)
165 emptySubstEnv = (emptyVarEnv, emptyVarEnv)
168 -- At one stage I tried to match even if there are more
169 -- template args than real args.
171 -- I now think this is probably a bad idea.
172 -- Should the template (map f xs) match (map g)? I think not.
173 -- For a start, in general eta expansion wastes work.
178 -> (TvSubstEnv, IdSubstEnv)
179 -> CoreExpr -- Template
180 -> CoreExpr -- Target
181 -> Maybe (TvSubstEnv, IdSubstEnv)
183 -- See the notes with Unify.match, which matches types
184 -- Everything is very similar for terms
186 -- Interesting examples:
188 -- \x->f against \f->f
189 -- When we meet the lambdas we must remember to rename f to f' in the
190 -- second expresion. The RnEnv2 does that.
193 -- forall a. \b->b against \a->3
194 -- We must rename the \a. Otherwise when we meet the lambdas we
195 -- might substitute [a/b] in the template, and then erroneously
196 -- succeed in matching what looks like the template variable 'a' against 3.
198 -- The Var case follows closely what happens in Unify.match
199 match menv subst@(tv_subst, id_subst) (Var v1) e2
200 | v1 `elemVarSet` me_tmpls menv
201 = case lookupVarEnv id_subst v1' of
202 Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
203 -> Nothing -- Occurs check failure
204 -- e.g. match forall a. (\x-> a x) against (\y. y y)
207 -> Just (tv_subst, extendVarEnv id_subst v1 (DoneEx e2))
209 Just (DoneEx e2') | tcEqExprX (nukeRnEnvL rn_env) e2' e2
214 | otherwise -- v1 is not a template variable
216 Var v2 | v1' == rnOccR rn_env v2 -> Just subst
220 v1' = rnOccL rn_env v1
222 -- Here is another important rule: if the term being matched is a
223 -- variable, we expand it so long as its unfolding is a WHNF
224 -- (Its occurrence information is not necessarily up to date,
225 -- so we don't use it.)
226 match menv subst e1 (Var v2)
227 | isCheapUnfolding unfolding
228 = match menv subst e1 (unfoldingTemplate unfolding)
230 unfolding = idUnfolding v2
232 match menv subst (Lit lit1) (Lit lit2)
236 match menv subst (App f1 a1) (App f2 a2)
237 = do { subst' <- match menv subst f1 f2
238 ; match menv subst' a1 a2 }
240 match menv subst (Lam x1 e1) (Lam x2 e2)
241 = match menv' subst e1 e2
243 menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
245 -- This rule does eta expansion
246 -- (\x.M) ~ N iff M ~ N x
247 match menv subst (Lam x1 e1) e2
248 = match menv' subst e1 (App e2 (varToCoreExpr new_x))
250 (rn_env', new_x) = rnBndrL (me_env menv) x1
251 menv' = menv { me_env = rn_env' }
253 -- Eta expansion the other way
254 -- M ~ (\y.N) iff M y ~ N
255 match menv subst e1 (Lam x2 e2)
256 = match menv' subst (App e1 (varToCoreExpr new_x)) e2
258 (rn_env', new_x) = rnBndrR (me_env menv) x2
259 menv' = menv { me_env = rn_env' }
261 match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
262 = do { subst1 <- match_ty menv subst ty1 ty2
263 ; subst2 <- match menv subst1 e1 e2
264 ; let menv' = menv { me_env = rnBndr2 (me_env menv) x2 x2 }
265 ; match_alts menv' subst2 alts1 alts2 -- Alts are both sorted
268 match menv subst (Type ty1) (Type ty2)
269 = match_ty menv subst ty1 ty2
271 match menv subst (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
272 = do { subst1 <- match_ty menv subst to1 to2
273 ; subst2 <- match_ty menv subst1 from1 from2
274 ; match menv subst2 e1 e2 }
276 -- This is an interesting rule: we simply ignore lets in the
277 -- term being matched against! The unfolding inside it is (by assumption)
278 -- already inside any occurrences of the bound variables, so we'll expand
279 -- them when we encounter them.
280 match menv subst e1 (Let (NonRec x2 r2) e2)
281 = match menv' subst e1 e2
283 menv' = menv { me_env = fst (rnBndrR (me_env menv) x2) }
284 -- It's important to do this renaming. For example:
286 -- forall f,x,xs. f (x:xs)
288 -- f (let y = e in (y:[]))
289 -- We must not get success with x->y! Instead, we
290 -- need an occurs check.
292 -- Everything else fails
293 match menv subst e1 e2 = Nothing
295 ------------------------------------------
296 match_alts :: MatchEnv
297 -> (TvSubstEnv, IdSubstEnv)
298 -> [CoreAlt] -- Template
299 -> [CoreAlt] -- Target
300 -> Maybe (TvSubstEnv, IdSubstEnv)
301 match_alts menv subst [] []
303 match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
305 = do { subst1 <- match menv' subst r1 r2
306 ; match_alts menv subst1 alts1 alts2 }
309 menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 }
311 match_alts menv subst alts1 alts2
315 Matching Core types: use the matcher in TcType.
316 Notice that we treat newtypes as opaque. For example, suppose
317 we have a specialised version of a function at a newtype, say
319 We only want to replace (f T) with f', not (f Int).
322 ------------------------------------------
323 match_ty menv (tv_subst, id_subst) ty1 ty2
324 = do { tv_subst' <- Unify.tcMatchTyX menv tv_subst ty1 ty2
325 ; return (tv_subst', id_subst) }
329 %************************************************************************
331 \subsection{Adding a new rule}
333 %************************************************************************
336 addRule :: Id -> CoreRules -> CoreRule -> CoreRules
338 -- Add a new rule to an existing bunch of rules.
339 -- The rules are for the given Id; the Id argument is needed only
340 -- so that we can exclude the Id from its own RHS free-var set
342 -- Insert the new rule just before a rule that is *less specific*
343 -- than the new one; or at the end if there isn't such a one.
344 -- In this way we make sure that when looking up, the first match
345 -- is the most specific.
347 -- We make no check for rules that unify without one dominating
348 -- the other. Arguably this would be a bug.
350 addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _)
351 = Rules (rule:rules) rhs_fvs
352 -- Put it at the start for lack of anything better
354 addRule id (Rules rules rhs_fvs) rule
355 = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
357 new_rule = occurAnalyseRule rule
358 new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id
360 -- Don't include the Id in its own rhs free-var set.
361 -- Otherwise the occurrence analyser makes bindings recursive
362 -- that shoudn't be. E.g.
363 -- RULE: f (f x y) z ==> f x (f y z)
365 insertRule rules new_rule@(Rule _ _ tpl_vars tpl_args _)
368 tpl_var_set = mkInScopeSet (mkVarSet tpl_vars)
369 -- Actually we should probably include the free vars of tpl_args,
370 -- but I can't be bothered
373 go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
374 | otherwise = rule : go rules
376 new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args)
378 addIdSpecialisations :: Id -> [CoreRule] -> Id
379 addIdSpecialisations id rules
380 = setIdSpecialisation id new_specs
382 new_specs = foldl (addRule id) (idSpecialisation id) rules
386 %************************************************************************
388 \subsection{Looking up a rule}
390 %************************************************************************
393 lookupRule :: (Activation -> Bool) -> InScopeSet
394 -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
395 lookupRule is_active in_scope fn args
396 = case idSpecialisation fn of
397 Rules rules _ -> matchRules is_active in_scope rules args
401 %************************************************************************
403 \subsection{Checking a program for failing rule applications}
405 %************************************************************************
407 -----------------------------------------------------
409 -----------------------------------------------------
411 We want to know what sites have rules that could have fired but didn't.
412 This pass runs over the tree (without changing it) and reports such.
414 NB: we assume that this follows a run of the simplifier, so every Id
415 occurrence (including occurrences of imported Ids) is decorated with
416 all its (active) rules. No need to construct a rule base or anything
420 ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc
421 -- Report partial matches for rules beginning
422 -- with the specified string
423 ruleCheckProgram phase rule_pat binds
425 = text "Rule check results: no rule application sites"
427 = vcat [text "Rule check results:",
429 vcat [ p $$ line | p <- bagToList results ]
432 results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
433 line = text (replicate 20 '-')
435 type RuleCheckEnv = (CompilerPhase, String) -- Phase and Pattern
437 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
438 -- The Bag returned has one SDoc for each call site found
439 ruleCheckBind env (NonRec b r) = ruleCheck env r
440 ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (b,r) <- prs]
442 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
443 ruleCheck env (Var v) = emptyBag
444 ruleCheck env (Lit l) = emptyBag
445 ruleCheck env (Type ty) = emptyBag
446 ruleCheck env (App f a) = ruleCheckApp env (App f a) []
447 ruleCheck env (Note n e) = ruleCheck env e
448 ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
449 ruleCheck env (Lam b e) = ruleCheck env e
450 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
451 unionManyBags [ruleCheck env r | (_,_,r) <- as]
453 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
454 ruleCheckApp env (Var f) as = ruleCheckFun env f as
455 ruleCheckApp env other as = ruleCheck env other
459 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
460 -- Produce a report for all rules matching the predicate
461 -- saying why it doesn't match the specified application
463 ruleCheckFun (phase, pat) fn args
464 | null name_match_rules = emptyBag
465 | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules)
467 name_match_rules = case idSpecialisation fn of
468 Rules rules _ -> filter match rules
469 match rule = pat `isPrefixOf` unpackFS (ruleName rule)
471 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
472 ruleAppCheck_help phase fn args rules
473 = -- The rules match the pattern, so we want to print something
474 vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
475 vcat (map check_rule rules)]
478 i_args = args `zip` [1::Int ..]
480 check_rule rule = rule_herald rule <> colon <+> rule_info rule
482 rule_herald (BuiltinRule name _) =
483 ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
484 rule_herald (Rule name _ _ _ _) =
485 ptext SLIT("Rule") <+> doubleQuotes (ftext name)
488 | Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args
489 = text "matches (which is very peculiar!)"
491 rule_info (BuiltinRule name fn) = text "does not match"
493 rule_info (Rule name act rule_bndrs rule_args _)
494 | not (isActive phase act) = text "active only in later phase"
495 | n_args < n_rule_args = text "too few arguments"
496 | n_mismatches == n_rule_args = text "no arguments match"
497 | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not"
498 | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
500 n_rule_args = length rule_args
501 n_mismatches = length mismatches
502 mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
503 not (isJust (match_fn rule_arg arg))]
505 lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars
506 match_fn rule_arg arg = match menv emptySubstEnv rule_arg arg
508 in_scope = lhs_fvs `unionVarSet` exprFreeVars arg
509 menv = ME { me_env = mkRnEnv2 (mkInScopeSet in_scope)
510 , me_tmpls = mkVarSet rule_bndrs }
514 %************************************************************************
516 \subsection{Getting the rules ready}
518 %************************************************************************
521 data RuleBase = RuleBase
522 IdSet -- Ids with their rules in their specialisations
523 -- Held as a set, so that it can simply be the initial
524 -- in-scope set in the simplifier
525 -- This representation is a bit cute, and I wonder if we should
526 -- change it to use (IdEnv CoreRule) which seems a bit more natural
528 ruleBaseIds (RuleBase ids) = ids
529 emptyRuleBase = RuleBase emptyVarSet
531 extendRuleBaseList :: RuleBase -> [IdCoreRule] -> RuleBase
532 extendRuleBaseList rule_base new_guys
533 = foldl extendRuleBase rule_base new_guys
535 extendRuleBase :: RuleBase -> IdCoreRule -> RuleBase
536 extendRuleBase (RuleBase rule_ids) (IdCoreRule id _ rule)
537 = RuleBase (extendVarSet rule_ids new_id)
539 new_id = setIdSpecialisation id (addRule id old_rules rule)
540 old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id))
541 -- Get the old rules from rule_ids if the Id is already there, but
542 -- if not, use the Id from the incoming rule. If may be a PrimOpId,
543 -- in which case it may have rules in its belly already. Seems
544 -- dreadfully hackoid.
546 pprRuleBase :: RuleBase -> SDoc
547 pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]