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 )
23 import CoreTidy ( pprTidyIdRules )
24 import Id ( Id, idUnfolding, isLocalId, idSpecialisation, setIdSpecialisation )
28 import Unify ( tcMatchTyX, MatchEnv(..) )
29 import BasicTypes ( Activation, CompilerPhase, isActive )
33 import Maybe ( isJust, fromMaybe )
35 import List ( isPrefixOf )
39 %************************************************************************
41 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
43 %************************************************************************
45 A @CoreRule@ holds details of one rule for an @Id@, which
46 includes its specialisations.
48 For example, if a rule for @f@ contains the mapping:
50 forall a b d. [Type (List a), Type b, Var d] ===> f' a b
52 then when we find an application of f to matching types, we simply replace
53 it by the matching RHS:
55 f (List Int) Bool dict ===> f' Int Bool
57 All the stuff about how many dictionaries to discard, and what types
58 to apply the specialised function to, are handled by the fact that the
59 Rule contains a template for the result of the specialisation.
61 There is one more exciting case, which is dealt with in exactly the same
62 way. If the specialised value is unboxed then it is lifted at its
63 definition site and unlifted at its uses. For example:
65 pi :: forall a. Num a => a
67 might have a specialisation
69 [Int#] ===> (case pi' of Lift pi# -> pi#)
71 where pi' :: Lift Int# is the specialised version of pi.
74 %************************************************************************
78 %************************************************************************
81 matchRules :: (Activation -> Bool) -> InScopeSet
82 -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
83 -- See comments on matchRule
84 matchRules is_active in_scope [] args = Nothing
85 matchRules is_active in_scope (rule:rules) args
86 = case matchRule is_active in_scope rule args of
87 Just result -> Just result
88 Nothing -> matchRules is_active in_scope rules args
90 noBlackList :: Activation -> Bool
91 noBlackList act = False -- Nothing is black listed
93 matchRule :: (Activation -> Bool) -> InScopeSet
94 -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
96 -- If (matchRule rule args) returns Just (name,rhs)
97 -- then (f args) matches the rule, and the corresponding
98 -- rewritten RHS is rhs
100 -- The bndrs and rhs is occurrence-analysed
105 -- forall f g x. map f (map g x) ==> map (f . g) x
107 -- CoreRule "map/map"
108 -- [f,g,x] -- tpl_vars
109 -- [f,map g x] -- tpl_args
110 -- map (f.g) x) -- rhs
112 -- Then the call: matchRule the_rule [e1,map e2 e3]
113 -- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
115 -- Any 'surplus' arguments in the input are simply put on the end
118 matchRule is_active in_scope rule@(BuiltinRule name match_fn) args
119 = case match_fn args of
120 Just expr -> Just (name,expr)
123 matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args
124 | not (is_active act)
127 = case matchN in_scope tpl_vars tpl_args args of
128 Just (tpl_vals, leftovers) -> Just (rn, mkLams tpl_vars rhs `mkApps` tpl_vals `mkApps` leftovers)
134 -> [Var] -- Template tyvars
135 -> [CoreExpr] -- Template
136 -> [CoreExpr] -- Target; can have more elts than template
137 -> Maybe ([CoreExpr], -- What is substituted for each template var
138 [CoreExpr]) -- Leftover target exprs
140 matchN in_scope tmpl_vars tmpl_es target_es
141 = do { (subst, leftover_es) <- go init_menv emptySubstEnv tmpl_es target_es
142 ; return (map (lookup_tmpl subst) tmpl_vars, leftover_es) }
144 init_menv = ME { me_tmpls = mkVarSet tmpl_vars, me_env = init_rn_env }
145 init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars)
147 go menv subst [] es = Just (subst, es)
148 go menv subst ts [] = Nothing -- Fail if too few actual args
149 go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
150 ; go menv subst1 ts es }
152 lookup_tmpl :: (TvSubstEnv, IdSubstEnv) -> Var -> CoreExpr
153 lookup_tmpl (tv_subst, id_subst) tmpl_var
154 | isTyVar tmpl_var = case lookupVarEnv tv_subst tmpl_var of
156 Nothing -> unbound tmpl_var
157 | otherwise = case lookupVarEnv id_subst tmpl_var of
159 other -> unbound tmpl_var
161 unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var)
165 ---------------------------------------------
166 The inner workings of matching
167 ---------------------------------------------
170 -- These two definitions are not the same as in Subst,
171 -- but they simple and direct, and purely local to this module
172 -- The third, for TvSubstEnv, is the same as in VarEnv, but repeated here
173 -- for uniformity with IdSubstEnv
174 type SubstEnv = (TvSubstEnv, IdSubstEnv)
175 type IdSubstEnv = IdEnv CoreExpr
176 type TvSubstEnv = TyVarEnv Type
178 emptySubstEnv :: SubstEnv
179 emptySubstEnv = (emptyVarEnv, emptyVarEnv)
182 -- At one stage I tried to match even if there are more
183 -- template args than real args.
185 -- I now think this is probably a bad idea.
186 -- Should the template (map f xs) match (map g)? I think not.
187 -- For a start, in general eta expansion wastes work.
193 -> CoreExpr -- Template
194 -> CoreExpr -- Target
197 -- See the notes with Unify.match, which matches types
198 -- Everything is very similar for terms
200 -- Interesting examples:
202 -- \x->f against \f->f
203 -- When we meet the lambdas we must remember to rename f to f' in the
204 -- second expresion. The RnEnv2 does that.
207 -- forall a. \b->b against \a->3
208 -- We must rename the \a. Otherwise when we meet the lambdas we
209 -- might substitute [a/b] in the template, and then erroneously
210 -- succeed in matching what looks like the template variable 'a' against 3.
212 -- The Var case follows closely what happens in Unify.match
213 match menv subst@(tv_subst, id_subst) (Var v1) e2
214 | v1 `elemVarSet` me_tmpls menv
215 = case lookupVarEnv id_subst v1' of
216 Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
217 -> Nothing -- Occurs check failure
218 -- e.g. match forall a. (\x-> a x) against (\y. y y)
221 -> Just (tv_subst, extendVarEnv id_subst v1 e2)
223 Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2
228 | otherwise -- v1 is not a template variable
230 Var v2 | v1' == rnOccR rn_env v2 -> Just subst
234 v1' = rnOccL rn_env v1
236 -- Here is another important rule: if the term being matched is a
237 -- variable, we expand it so long as its unfolding is a WHNF
238 -- (Its occurrence information is not necessarily up to date,
239 -- so we don't use it.)
240 match menv subst e1 (Var v2)
241 | isCheapUnfolding unfolding
242 = match menv subst e1 (unfoldingTemplate unfolding)
244 unfolding = idUnfolding v2
246 match menv subst (Lit lit1) (Lit lit2)
250 match menv subst (App f1 a1) (App f2 a2)
251 = do { subst' <- match menv subst f1 f2
252 ; match menv subst' a1 a2 }
254 match menv subst (Lam x1 e1) (Lam x2 e2)
255 = match menv' subst e1 e2
257 menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
259 -- This rule does eta expansion
260 -- (\x.M) ~ N iff M ~ N x
261 match menv subst (Lam x1 e1) e2
262 = match menv' subst e1 (App e2 (varToCoreExpr new_x))
264 (rn_env', new_x) = rnBndrL (me_env menv) x1
265 menv' = menv { me_env = rn_env' }
267 -- Eta expansion the other way
268 -- M ~ (\y.N) iff M y ~ N
269 match menv subst e1 (Lam x2 e2)
270 = match menv' subst (App e1 (varToCoreExpr new_x)) e2
272 (rn_env', new_x) = rnBndrR (me_env menv) x2
273 menv' = menv { me_env = rn_env' }
275 match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
276 = do { subst1 <- match_ty menv subst ty1 ty2
277 ; subst2 <- match menv subst1 e1 e2
278 ; let menv' = menv { me_env = rnBndr2 (me_env menv) x2 x2 }
279 ; match_alts menv' subst2 alts1 alts2 -- Alts are both sorted
282 match menv subst (Type ty1) (Type ty2)
283 = match_ty menv subst ty1 ty2
285 match menv subst (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
286 = do { subst1 <- match_ty menv subst to1 to2
287 ; subst2 <- match_ty menv subst1 from1 from2
288 ; match menv subst2 e1 e2 }
290 -- This is an interesting rule: we simply ignore lets in the
291 -- term being matched against! The unfolding inside it is (by assumption)
292 -- already inside any occurrences of the bound variables, so we'll expand
293 -- them when we encounter them.
294 match menv subst e1 (Let (NonRec x2 r2) e2)
295 = match menv' subst e1 e2
297 menv' = menv { me_env = fst (rnBndrR (me_env menv) x2) }
298 -- It's important to do this renaming. For example:
300 -- forall f,x,xs. f (x:xs)
302 -- f (let y = e in (y:[]))
303 -- We must not get success with x->y! Instead, we
304 -- need an occurs check.
306 -- Everything else fails
307 match menv subst e1 e2 = Nothing
309 ------------------------------------------
310 match_alts :: MatchEnv
312 -> [CoreAlt] -- Template
313 -> [CoreAlt] -- Target
315 match_alts menv subst [] []
317 match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
319 = do { subst1 <- match menv' subst r1 r2
320 ; match_alts menv subst1 alts1 alts2 }
323 menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 }
325 match_alts menv subst alts1 alts2
329 Matching Core types: use the matcher in TcType.
330 Notice that we treat newtypes as opaque. For example, suppose
331 we have a specialised version of a function at a newtype, say
333 We only want to replace (f T) with f', not (f Int).
336 ------------------------------------------
337 match_ty menv (tv_subst, id_subst) ty1 ty2
338 = do { tv_subst' <- Unify.tcMatchTyX menv tv_subst ty1 ty2
339 ; return (tv_subst', id_subst) }
343 %************************************************************************
345 \subsection{Adding a new rule}
347 %************************************************************************
350 addRule :: Id -> CoreRules -> CoreRule -> CoreRules
352 -- Add a new rule to an existing bunch of rules.
353 -- The rules are for the given Id; the Id argument is needed only
354 -- so that we can exclude the Id from its own RHS free-var set
356 -- Insert the new rule just before a rule that is *less specific*
357 -- than the new one; or at the end if there isn't such a one.
358 -- In this way we make sure that when looking up, the first match
359 -- is the most specific.
361 -- We make no check for rules that unify without one dominating
362 -- the other. Arguably this would be a bug.
364 addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _)
365 = Rules (rule:rules) rhs_fvs
366 -- Put it at the start for lack of anything better
368 addRule id (Rules rules rhs_fvs) rule
369 = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
371 new_rule = occurAnalyseRule rule
372 new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id
374 -- Don't include the Id in its own rhs free-var set.
375 -- Otherwise the occurrence analyser makes bindings recursive
376 -- that shoudn't be. E.g.
377 -- RULE: f (f x y) z ==> f x (f y z)
379 insertRule rules new_rule@(Rule _ _ tpl_vars tpl_args _)
382 tpl_var_set = mkInScopeSet (mkVarSet tpl_vars)
383 -- Actually we should probably include the free vars of tpl_args,
384 -- but I can't be bothered
387 go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
388 | otherwise = rule : go rules
390 new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args)
392 addIdSpecialisations :: Id -> [CoreRule] -> Id
393 addIdSpecialisations id rules
394 = setIdSpecialisation id new_specs
396 new_specs = foldl (addRule id) (idSpecialisation id) rules
400 %************************************************************************
402 \subsection{Looking up a rule}
404 %************************************************************************
407 lookupRule :: (Activation -> Bool)
409 -> RuleBase -- Ids from other modules
410 -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
411 lookupRule is_active in_scope rules fn args
412 = case idSpecialisation fn' of
413 Rules rules _ -> matchRules is_active in_scope rules args
415 fn' | isLocalId fn = fn
416 | Just ext_fn <- lookupVarSet (ruleBaseIds rules) fn = ext_fn
421 %************************************************************************
423 \subsection{Checking a program for failing rule applications}
425 %************************************************************************
427 -----------------------------------------------------
429 -----------------------------------------------------
431 We want to know what sites have rules that could have fired but didn't.
432 This pass runs over the tree (without changing it) and reports such.
434 NB: we assume that this follows a run of the simplifier, so every Id
435 occurrence (including occurrences of imported Ids) is decorated with
436 all its (active) rules. No need to construct a rule base or anything
440 ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc
441 -- Report partial matches for rules beginning
442 -- with the specified string
443 ruleCheckProgram phase rule_pat binds
445 = text "Rule check results: no rule application sites"
447 = vcat [text "Rule check results:",
449 vcat [ p $$ line | p <- bagToList results ]
452 results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
453 line = text (replicate 20 '-')
455 type RuleCheckEnv = (CompilerPhase, String) -- Phase and Pattern
457 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
458 -- The Bag returned has one SDoc for each call site found
459 ruleCheckBind env (NonRec b r) = ruleCheck env r
460 ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (b,r) <- prs]
462 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
463 ruleCheck env (Var v) = emptyBag
464 ruleCheck env (Lit l) = emptyBag
465 ruleCheck env (Type ty) = emptyBag
466 ruleCheck env (App f a) = ruleCheckApp env (App f a) []
467 ruleCheck env (Note n e) = ruleCheck env e
468 ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
469 ruleCheck env (Lam b e) = ruleCheck env e
470 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
471 unionManyBags [ruleCheck env r | (_,_,r) <- as]
473 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
474 ruleCheckApp env (Var f) as = ruleCheckFun env f as
475 ruleCheckApp env other as = ruleCheck env other
479 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
480 -- Produce a report for all rules matching the predicate
481 -- saying why it doesn't match the specified application
483 ruleCheckFun (phase, pat) fn args
484 | null name_match_rules = emptyBag
485 | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules)
487 name_match_rules = case idSpecialisation fn of
488 Rules rules _ -> filter match rules
489 match rule = pat `isPrefixOf` unpackFS (ruleName rule)
491 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
492 ruleAppCheck_help phase fn args rules
493 = -- The rules match the pattern, so we want to print something
494 vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
495 vcat (map check_rule rules)]
498 i_args = args `zip` [1::Int ..]
500 check_rule rule = rule_herald rule <> colon <+> rule_info rule
502 rule_herald (BuiltinRule name _) =
503 ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
504 rule_herald (Rule name _ _ _ _) =
505 ptext SLIT("Rule") <+> doubleQuotes (ftext name)
508 | Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args
509 = text "matches (which is very peculiar!)"
511 rule_info (BuiltinRule name fn) = text "does not match"
513 rule_info (Rule name act rule_bndrs rule_args _)
514 | not (isActive phase act) = text "active only in later phase"
515 | n_args < n_rule_args = text "too few arguments"
516 | n_mismatches == n_rule_args = text "no arguments match"
517 | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not"
518 | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
520 n_rule_args = length rule_args
521 n_mismatches = length mismatches
522 mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
523 not (isJust (match_fn rule_arg arg))]
525 lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars
526 match_fn rule_arg arg = match menv emptySubstEnv rule_arg arg
528 in_scope = lhs_fvs `unionVarSet` exprFreeVars arg
529 menv = ME { me_env = mkRnEnv2 (mkInScopeSet in_scope)
530 , me_tmpls = mkVarSet rule_bndrs }
534 %************************************************************************
536 \subsection{Getting the rules ready}
538 %************************************************************************
541 data RuleBase = RuleBase
542 IdSet -- Ids with their rules in their specialisations
543 -- Held as a set, so that it can simply be the initial
544 -- in-scope set in the simplifier
545 -- This representation is a bit cute, and I wonder if we should
546 -- change it to use (IdEnv CoreRule) which seems a bit more natural
548 ruleBaseIds (RuleBase ids) = ids
549 emptyRuleBase = RuleBase emptyVarSet
551 extendRuleBaseList :: RuleBase -> [IdCoreRule] -> RuleBase
552 extendRuleBaseList rule_base new_guys
553 = foldl extendRuleBase rule_base new_guys
555 extendRuleBase :: RuleBase -> IdCoreRule -> RuleBase
556 extendRuleBase (RuleBase rule_ids) (IdCoreRule id _ rule)
557 = RuleBase (extendVarSet rule_ids new_id)
559 new_id = setIdSpecialisation id (addRule id old_rules rule)
560 old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id))
561 -- Get the old rules from rule_ids if the Id is already there, but
562 -- if not, use the Id from the incoming rule. If may be a PrimOpId,
563 -- in which case it may have rules in its belly already. Seems
564 -- dreadfully hackoid.
566 pprRuleBase :: RuleBase -> SDoc
567 pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]