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, addRules, 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 addRules :: Id -> CoreRules -> [CoreRule] -> CoreRules
351 addRule :: Id -> CoreRules -> CoreRule -> CoreRules
353 -- Add a new rule to an existing bunch of rules.
354 -- The rules are for the given Id; the Id argument is needed only
355 -- so that we can exclude the Id from its own RHS free-var set
357 -- Insert the new rule just before a rule that is *less specific*
358 -- than the new one; or at the end if there isn't such a one.
359 -- In this way we make sure that when looking up, the first match
360 -- is the most specific.
362 -- We make no check for rules that unify without one dominating
363 -- the other. Arguably this would be a bug.
365 addRules id rules rule_list = foldl (addRule id) rules rule_list
367 addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _)
368 = Rules (rule:rules) rhs_fvs
369 -- Put it at the start for lack of anything better
371 addRule id (Rules rules rhs_fvs) rule
372 = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
374 new_rule = occurAnalyseRule rule
375 new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id
377 -- Don't include the Id in its own rhs free-var set.
378 -- Otherwise the occurrence analyser makes bindings recursive
379 -- that shoudn't be. E.g.
380 -- RULE: f (f x y) z ==> f x (f y z)
382 insertRule rules new_rule@(Rule _ _ tpl_vars tpl_args _)
385 tpl_var_set = mkInScopeSet (mkVarSet tpl_vars)
386 -- Actually we should probably include the free vars of tpl_args,
387 -- but I can't be bothered
390 go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
391 | otherwise = rule : go rules
393 new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args)
395 addIdSpecialisations :: Id -> [CoreRule] -> Id
396 addIdSpecialisations id rules
397 = setIdSpecialisation id new_specs
399 new_specs = addRules id (idSpecialisation id) rules
403 %************************************************************************
405 \subsection{Looking up a rule}
407 %************************************************************************
410 lookupRule :: (Activation -> Bool)
412 -> RuleBase -- Ids from other modules
413 -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
414 lookupRule is_active in_scope rules fn args
415 = case idSpecialisation fn' of
416 Rules rules _ -> matchRules is_active in_scope rules args
418 fn' | isLocalId fn = fn
419 | Just ext_fn <- lookupVarSet (ruleBaseIds rules) fn = ext_fn
424 %************************************************************************
426 \subsection{Checking a program for failing rule applications}
428 %************************************************************************
430 -----------------------------------------------------
432 -----------------------------------------------------
434 We want to know what sites have rules that could have fired but didn't.
435 This pass runs over the tree (without changing it) and reports such.
437 NB: we assume that this follows a run of the simplifier, so every Id
438 occurrence (including occurrences of imported Ids) is decorated with
439 all its (active) rules. No need to construct a rule base or anything
443 ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc
444 -- Report partial matches for rules beginning
445 -- with the specified string
446 ruleCheckProgram phase rule_pat binds
448 = text "Rule check results: no rule application sites"
450 = vcat [text "Rule check results:",
452 vcat [ p $$ line | p <- bagToList results ]
455 results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
456 line = text (replicate 20 '-')
458 type RuleCheckEnv = (CompilerPhase, String) -- Phase and Pattern
460 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
461 -- The Bag returned has one SDoc for each call site found
462 ruleCheckBind env (NonRec b r) = ruleCheck env r
463 ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (b,r) <- prs]
465 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
466 ruleCheck env (Var v) = emptyBag
467 ruleCheck env (Lit l) = emptyBag
468 ruleCheck env (Type ty) = emptyBag
469 ruleCheck env (App f a) = ruleCheckApp env (App f a) []
470 ruleCheck env (Note n e) = ruleCheck env e
471 ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
472 ruleCheck env (Lam b e) = ruleCheck env e
473 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
474 unionManyBags [ruleCheck env r | (_,_,r) <- as]
476 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
477 ruleCheckApp env (Var f) as = ruleCheckFun env f as
478 ruleCheckApp env other as = ruleCheck env other
482 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
483 -- Produce a report for all rules matching the predicate
484 -- saying why it doesn't match the specified application
486 ruleCheckFun (phase, pat) fn args
487 | null name_match_rules = emptyBag
488 | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules)
490 name_match_rules = case idSpecialisation fn of
491 Rules rules _ -> filter match rules
492 match rule = pat `isPrefixOf` unpackFS (ruleName rule)
494 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
495 ruleAppCheck_help phase fn args rules
496 = -- The rules match the pattern, so we want to print something
497 vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
498 vcat (map check_rule rules)]
501 i_args = args `zip` [1::Int ..]
503 check_rule rule = rule_herald rule <> colon <+> rule_info rule
505 rule_herald (BuiltinRule name _) =
506 ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
507 rule_herald (Rule name _ _ _ _) =
508 ptext SLIT("Rule") <+> doubleQuotes (ftext name)
511 | Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args
512 = text "matches (which is very peculiar!)"
514 rule_info (BuiltinRule name fn) = text "does not match"
516 rule_info (Rule name act rule_bndrs rule_args _)
517 | not (isActive phase act) = text "active only in later phase"
518 | n_args < n_rule_args = text "too few arguments"
519 | n_mismatches == n_rule_args = text "no arguments match"
520 | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not"
521 | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
523 n_rule_args = length rule_args
524 n_mismatches = length mismatches
525 mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
526 not (isJust (match_fn rule_arg arg))]
528 lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars
529 match_fn rule_arg arg = match menv emptySubstEnv rule_arg arg
531 in_scope = lhs_fvs `unionVarSet` exprFreeVars arg
532 menv = ME { me_env = mkRnEnv2 (mkInScopeSet in_scope)
533 , me_tmpls = mkVarSet rule_bndrs }
537 %************************************************************************
539 \subsection{Getting the rules ready}
541 %************************************************************************
544 data RuleBase = RuleBase
545 IdSet -- Ids with their rules in their specialisations
546 -- Held as a set, so that it can simply be the initial
547 -- in-scope set in the simplifier
548 -- This representation is a bit cute, and I wonder if we should
549 -- change it to use (IdEnv CoreRule) which seems a bit more natural
551 ruleBaseIds (RuleBase ids) = ids
552 emptyRuleBase = RuleBase emptyVarSet
554 extendRuleBaseList :: RuleBase -> [IdCoreRule] -> RuleBase
555 extendRuleBaseList rule_base new_guys
556 = foldl extendRuleBase rule_base new_guys
558 extendRuleBase :: RuleBase -> IdCoreRule -> RuleBase
559 extendRuleBase (RuleBase rule_ids) (IdCoreRule id _ rule)
560 = RuleBase (extendVarSet rule_ids new_id)
562 new_id = setIdSpecialisation id (addRule id old_rules rule)
563 old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id))
564 -- Get the old rules from rule_ids if the Id is already there, but
565 -- if not, use the Id from the incoming rule. If may be a PrimOpId,
566 -- in which case it may have rules in its belly already. Seems
567 -- dreadfully hackoid.
569 pprRuleBase :: RuleBase -> SDoc
570 pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]