1% 2% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 3% 4\section[CoreRules]{Transformation rules} 5 6\begin{code} 7{-# OPTIONS -w #-} 8{-# LANGUAGE PatternGuards #-} 9-- The above warning supression flag is a temporary kludge. 10-- While working on this module you are encouraged to remove it and fix 11-- any warnings in the module. See 12-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings 13-- for details 14 15-- | Functions for collecting together and applying rewrite rules to a module. 16-- The 'CoreRule' datatype itself is declared elsewhere. 17module Rules ( 18 -- * RuleBase 19 RuleBase, 20 21 -- ** Constructing 22 emptyRuleBase, mkRuleBase, extendRuleBaseList, 23 unionRuleBase, pprRuleBase, 24 25 -- ** Checking rule applications 26 ruleCheckProgram, 27 28 -- ** Manipulating 'SpecInfo' rules 29 mkSpecInfo, extendSpecInfo, addSpecInfo, 30 addIdSpecialisations, 31 32 -- * Misc. CoreRule helpers 33 rulesOfBinds, getRules, pprRulesForUser, 34 35 lookupRule, mkLocalRule, roughTopNames 36 ) where 37 38-- #include "HsVersions.h" 39 40import CoreSyn -- All of it 41import OccurAnal ( occurAnalyseExpr ) 42import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars ) 43import CoreUtils ( tcEqExprX, exprType ) 44import PprCore ( pprRules ) 45import Type ( Type, TvSubstEnv ) 46import Coercion ( coercionKind ) 47import TcType ( tcSplitTyConApp_maybe ) 48import CoreTidy ( tidyRules ) 49import Id 50import IdInfo ( SpecInfo( SpecInfo ) ) 51import Var ( Var ) 52import VarEnv 53import VarSet 54import Name ( Name, NamedThing(..) ) 55import NameEnv 56import Unify ( ruleMatchTyX, MatchEnv(..) ) 57import BasicTypes ( Activation ) 58import StaticFlags ( opt_PprStyle_Debug ) 59import Outputable 60import FastString 61import Maybes 62import OrdList 63import Bag 64import Util 65import Data.List 66\end{code} 67 68 69%************************************************************************ 70%* * 71\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} 72%* * 73%************************************************************************ 74 75A @CoreRule@ holds details of one rule for an @Id@, which 76includes its specialisations. 77 78For example, if a rule for @f@ contains the mapping: 79\begin{verbatim} 80 forall a b d. [Type (List a), Type b, Var d] ===> f' a b 81\end{verbatim} 82then when we find an application of f to matching types, we simply replace 83it by the matching RHS: 84\begin{verbatim} 85 f (List Int) Bool dict ===> f' Int Bool 86\end{verbatim} 87All the stuff about how many dictionaries to discard, and what types 88to apply the specialised function to, are handled by the fact that the 89Rule contains a template for the result of the specialisation. 90 91There is one more exciting case, which is dealt with in exactly the same 92way. If the specialised value is unboxed then it is lifted at its 93definition site and unlifted at its uses. For example: 94 95 pi :: forall a. Num a => a 96 97might have a specialisation 98 99 [Int#] ===> (case pi' of Lift pi# -> pi#) 100 101where pi' :: Lift Int# is the specialised version of pi. 102 103\begin{code} 104mkLocalRule :: RuleName -> Activation 105 -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule 106-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being 107-- compiled. See also 'CoreSyn.CoreRule' 108mkLocalRule name act fn bndrs args rhs 109 = Rule { ru_name = name, ru_fn = fn, ru_act = act, 110 ru_bndrs = bndrs, ru_args = args, 111 ru_rhs = rhs, ru_rough = roughTopNames args, 112 ru_local = True } 113 114-------------- 115roughTopNames :: [CoreExpr] -> [Maybe Name] 116-- ^ Find the \"top\" free names of several expressions. 117-- Such names are either: 118-- 119-- 1. The function finally being applied to in an application chain 120-- (if that name is a GlobalId: see "Var#globalvslocal"), or 121-- 122-- 2. The 'TyCon' if the expression is a 'Type' 123-- 124-- This is used for the fast-match-check for rules; 125-- if the top names don't match, the rest can't 126roughTopNames args = map roughTopName args 127 128roughTopName :: CoreExpr -> Maybe Name 129roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of 130 Just (tc,_) -> Just (getName tc) 131 Nothing -> Nothing 132roughTopName (App f a) = roughTopName f 133roughTopName (Var f) | isGlobalId f = Just (idName f) 134 | otherwise = Nothing 135roughTopName other = Nothing 136 137ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool 138-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ 139-- definitely can't match @tpl@ by instantiating @tpl@. 140-- It's only a one-way match; unlike instance matching we 141-- don't consider unification. 142-- 143-- Notice that [_$_] 144-- @ruleCantMatch [Nothing] [Just n2] = False@ 145-- Reason: a template variable can be instantiated by a constant 146-- Also: 147-- @ruleCantMatch [Just n1] [Nothing] = False@ 148-- Reason: a local variable @v@ in the actuals might [_$_] 149 150ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as 151ruleCantMatch (t : ts) (a : as) = ruleCantMatch ts as 152ruleCantMatch ts as = False 153\end{code} 154 155\begin{code} 156pprRulesForUser :: [CoreRule] -> SDoc 157-- (a) tidy the rules 158-- (b) sort them into order based on the rule name 159-- (c) suppress uniques (unless -dppr-debug is on) 160-- This combination makes the output stable so we can use in testing 161-- It's here rather than in PprCore because it calls tidyRules 162pprRulesForUser rules 163 = withPprStyle defaultUserStyle $ 164 pprRules $ 165 sortLe le_rule $ 166 tidyRules emptyTidyEnv rules 167 where 168 le_rule r1 r2 = ru_name r1 <= ru_name r2 169\end{code} 170 171 172%************************************************************************ 173%* * 174 SpecInfo: the rules in an IdInfo 175%* * 176%************************************************************************ 177 178\begin{code} 179-- | Make a 'SpecInfo' containing a number of 'CoreRule's, suitable 180-- for putting into an 'IdInfo' 181mkSpecInfo :: [CoreRule] -> SpecInfo 182mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules) 183 184extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo 185extendSpecInfo (SpecInfo rs1 fvs1) rs2 186 = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1) 187 188addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo 189addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2) 190 = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2) 191 192addIdSpecialisations :: Id -> [CoreRule] -> Id 193addIdSpecialisations id [] 194 = id 195addIdSpecialisations id rules 196 = setIdSpecialisation id $ 197 extendSpecInfo (idSpecialisation id) rules 198 199-- | Gather all the rules for locally bound identifiers from the supplied bindings 200rulesOfBinds :: [CoreBind] -> [CoreRule] 201rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds 202 203getRules :: RuleBase -> Id -> [CoreRule] 204 -- The rules for an Id come from two places: 205 -- (a) the ones it is born with (idCoreRules fn) 206 -- (b) rules added in subsequent modules (extra_rules) 207 -- PrimOps, for example, are born with a bunch of rules under (a) 208getRules rule_base fn 209 | isLocalId fn = idCoreRules fn 210 | otherwise = WARN( not (isPrimOpId fn) && notNull (idCoreRules fn), 211 ppr fn <+> ppr (idCoreRules fn) ) 212 idCoreRules fn ++ (lookupNameEnv rule_base (idName fn) `orElse` []) 213 -- Only PrimOpIds have rules inside themselves, and perhaps more besides 214\end{code} 215 216 217%************************************************************************ 218%* * 219 RuleBase 220%* * 221%************************************************************************ 222 223\begin{code} 224-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules 225type RuleBase = NameEnv [CoreRule] 226 -- The rules are are unordered; 227 -- we sort out any overlaps on lookup 228 229emptyRuleBase = emptyNameEnv 230 231mkRuleBase :: [CoreRule] -> RuleBase 232mkRuleBase rules = extendRuleBaseList emptyRuleBase rules 233 234extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase 235extendRuleBaseList rule_base new_guys 236 = foldl extendRuleBase rule_base new_guys 237 238unionRuleBase :: RuleBase -> RuleBase -> RuleBase 239unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2 240 241extendRuleBase :: RuleBase -> CoreRule -> RuleBase 242extendRuleBase rule_base rule 243 = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule 244 245pprRuleBase :: RuleBase -> SDoc 246pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) 247 | rs <- nameEnvElts rules ] 248\end{code} 249 250 251%************************************************************************ 252%* * 253\subsection{Matching} 254%* * 255%************************************************************************ 256 257Note [Extra args in rule matching] 258~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 259If we find a matching rule, we return (Just (rule, rhs)), 260but the rule firing has only consumed as many of the input args 261as the ruleArity says. It's up to the caller to keep track 262of any left-over args. E.g. if you call 263 lookupRule ... f [e1, e2, e3] 264and it returns Just (r, rhs), where r has ruleArity 2 265then the real rewrite is 266 f e1 e2 e3 ==> rhs e3 267 268You might think it'd be cleaner for lookupRule to deal with the 269leftover arguments, by applying 'rhs' to them, but the main call 270in the Simplifier works better as it is. Reason: the 'args' passed 271to lookupRule are the result of a lazy substitution 272 273\begin{code} 274-- | The main rule matching function. Attempts to apply all (active) 275-- supplied rules to this instance of an application in a given 276-- context, returning the rule applied and the resulting expression if 277-- successful. 278lookupRule :: (Activation -> Bool) -> InScopeSet 279 -> Id -> [CoreExpr] 280 -> [CoreRule] -> Maybe (CoreRule, CoreExpr) 281 282-- See Note [Extra args in rule matching] 283-- See comments on matchRule 284lookupRule is_active in_scope fn args rules 285 = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $ 286 case go [] rules of 287 [] -> Nothing 288 (m:ms) -> Just (findBest (fn,args) m ms) 289 where 290 rough_args = map roughTopName args 291 292 go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] 293 go ms [] = ms 294 go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of 295 Just e -> go ((r,e):ms) rs 296 Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$ 297 -- ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] ) 298 go ms rs 299 300findBest :: (Id, [CoreExpr]) 301 -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) 302-- All these pairs matched the expression 303-- Return the pair the the most specific rule 304-- The (fn,args) is just for overlap reporting 305 306findBest target (rule,ans) [] = (rule,ans) 307findBest target (rule1,ans1) ((rule2,ans2):prs) 308 | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs 309 | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs 310 | debugIsOn = let pp_rule rule 311 | opt_PprStyle_Debug = ppr rule 312 | otherwise = doubleQuotes (ftext (ru_name rule)) 313 in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" 314 (vcat [if opt_PprStyle_Debug then 315 ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args) 316 else empty, 317 ptext (sLit "Rule 1:") <+> pp_rule rule1, 318 ptext (sLit "Rule 2:") <+> pp_rule rule2]) $ 319 findBest target (rule1,ans1) prs 320 | otherwise = findBest target (rule1,ans1) prs 321 where 322 (fn,args) = target 323 324isMoreSpecific :: CoreRule -> CoreRule -> Bool 325isMoreSpecific (BuiltinRule {}) r2 = True 326isMoreSpecific r1 (BuiltinRule {}) = False 327isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) 328 (Rule { ru_bndrs = bndrs2, ru_args = args2 }) 329 = isJust (matchN in_scope bndrs2 args2 args1) 330 where 331 in_scope = mkInScopeSet (mkVarSet bndrs1) 332 -- Actually we should probably include the free vars 333 -- of rule1's args, but I can't be bothered 334 335noBlackList :: Activation -> Bool 336noBlackList act = False -- Nothing is black listed 337 338matchRule :: (Activation -> Bool) -> InScopeSet 339 -> [CoreExpr] -> [Maybe Name] 340 -> CoreRule -> Maybe CoreExpr 341 342-- If (matchRule rule args) returns Just (name,rhs) 343-- then (f args) matches the rule, and the corresponding 344-- rewritten RHS is rhs 345-- 346-- The bndrs and rhs is occurrence-analysed 347-- 348-- Example 349-- 350-- The rule 351-- forall f g x. map f (map g x) ==> map (f . g) x 352-- is stored 353-- CoreRule "map/map" 354-- [f,g,x] -- tpl_vars 355-- [f,map g x] -- tpl_args 356-- map (f.g) x) -- rhs 357-- 358-- Then the call: matchRule the_rule [e1,map e2 e3] 359-- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) 360-- 361-- Any 'surplus' arguments in the input are simply put on the end 362-- of the output. 363 364matchRule is_active in_scope args rough_args 365 (BuiltinRule { ru_name = name, ru_try = match_fn }) 366 = case match_fn args of 367 Just expr -> Just expr 368 Nothing -> Nothing 369 370matchRule is_active in_scope args rough_args 371 (Rule { ru_name = rn, ru_act = act, ru_rough = tpl_tops, 372 ru_bndrs = tpl_vars, ru_args = tpl_args, 373 ru_rhs = rhs }) 374 | not (is_active act) = Nothing 375 | ruleCantMatch tpl_tops rough_args = Nothing 376 | otherwise 377 = case matchN in_scope tpl_vars tpl_args args of 378 Nothing -> Nothing 379 Just (binds, tpl_vals) -> Just (mkLets binds $ 380 rule_fn `mkApps` tpl_vals) 381 where 382 rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs) 383 -- We could do this when putting things into the rulebase, I guess 384\end{code} 385 386\begin{code} 387-- For a given match template and context, find bindings to wrap around 388-- the entire result and what should be substituted for each template variable. 389-- Fail if there are two few actual arguments from the target to match the template 390matchN :: InScopeSet -- ^ In-scope variables 391 -> [Var] -- ^ Match template type variables 392 -> [CoreExpr] -- ^ Match template 393 -> [CoreExpr] -- ^ Target; can have more elements than the template 394 -> Maybe ([CoreBind], 395 [CoreExpr]) 396 397matchN in_scope tmpl_vars tmpl_es target_es 398 = do { (tv_subst, id_subst, binds) 399 <- go init_menv emptySubstEnv tmpl_es target_es 400 ; return (fromOL binds, 401 map (lookup_tmpl tv_subst id_subst) tmpl_vars') } 402 where 403 (init_rn_env, tmpl_vars') = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars 404 -- See Note [Template binders] 405 406 init_menv = ME { me_tmpls = mkVarSet tmpl_vars', me_env = init_rn_env } 407 408 go menv subst [] es = Just subst 409 go menv subst ts [] = Nothing -- Fail if too few actual args 410 go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e 411 ; go menv subst1 ts es } 412 413 lookup_tmpl :: TvSubstEnv -> IdSubstEnv -> Var -> CoreExpr 414 lookup_tmpl tv_subst id_subst tmpl_var' 415 | isTyVar tmpl_var' = case lookupVarEnv tv_subst tmpl_var' of 416 Just ty -> Type ty 417 Nothing -> unbound tmpl_var' 418 | otherwise = case lookupVarEnv id_subst tmpl_var' of 419 Just e -> e 420 other -> unbound tmpl_var' 421 422 unbound var = pprPanic "Template variable unbound in rewrite rule" 423 (ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es) 424\end{code} 425 426Note [Template binders] 427~~~~~~~~~~~~~~~~~~~~~~~ 428Consider the following match: 429 Template: forall x. f x 430 Target: f (x+1) 431This should succeed, because the template variable 'x' has 432nothing to do with the 'x' in the target. 433 434On reflection, this case probably does just work, but this might not 435 Template: forall x. f (\x.x) 436 Target: f (\y.y) 437Here we want to clone when we find the \x, but to know that x must be in scope 438 439To achive this, we use rnBndrL to rename the template variables if 440necessary; the renamed ones are the tmpl_vars' 441 442 443 --------------------------------------------- 444 The inner workings of matching 445 --------------------------------------------- 446 447\begin{code} 448-- These two definitions are not the same as in Subst, 449-- but they simple and direct, and purely local to this module 450-- 451-- * The domain of the TvSubstEnv and IdSubstEnv are the template 452-- variables passed into the match. 453-- 454-- * The (OrdList CoreBind) in a SubstEnv are the bindings floated out 455-- from nested matches; see the Let case of match, below 456-- 457type SubstEnv = (TvSubstEnv, IdSubstEnv, OrdList CoreBind) 458type IdSubstEnv = IdEnv CoreExpr 459 460emptySubstEnv :: SubstEnv 461emptySubstEnv = (emptyVarEnv, emptyVarEnv, nilOL) 462 463 464-- At one stage I tried to match even if there are more 465-- template args than real args. 466 467-- I now think this is probably a bad idea. 468-- Should the template (map f xs) match (map g)? I think not. 469-- For a start, in general eta expansion wastes work. 470-- SLPJ July 99 471 472 473match :: MatchEnv 474 -> SubstEnv 475 -> CoreExpr -- Template 476 -> CoreExpr -- Target 477 -> Maybe SubstEnv 478 479-- See the notes with Unify.match, which matches types 480-- Everything is very similar for terms 481 482-- Interesting examples: 483-- Consider matching 484-- \x->f against \f->f 485-- When we meet the lambdas we must remember to rename f to f' in the 486-- second expresion. The RnEnv2 does that. 487-- 488-- Consider matching 489-- forall a. \b->b against \a->3 490-- We must rename the \a. Otherwise when we meet the lambdas we 491-- might substitute [a/b] in the template, and then erroneously 492-- succeed in matching what looks like the template variable 'a' against 3. 493 494-- The Var case follows closely what happens in Unify.match 495match menv subst (Var v1) e2 496 | Just subst <- match_var menv subst v1 e2 497 = Just subst 498 499match menv subst e1 (Note n e2) 500 = match menv subst e1 e2 501 -- Note [Notes in RULE matching] 502 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 503 -- Look through Notes. In particular, we don't want to 504 -- be confused by InlineMe notes. Maybe we should be more 505 -- careful about profiling notes, but for now I'm just 506 -- riding roughshod over them. 507 --- See Note [Notes in call patterns] in SpecConstr 508 509-- Here is another important rule: if the term being matched is a 510-- variable, we expand it so long as its unfolding is a WHNF 511-- (Its occurrence information is not necessarily up to date, 512-- so we don't use it.) 513match menv subst e1 (Var v2) 514 | isCheapUnfolding unfolding 515 = match menv subst e1 (unfoldingTemplate unfolding) 516 where 517 rn_env = me_env menv 518 unfolding = idUnfolding (lookupRnInScope rn_env (rnOccR rn_env v2)) 519 -- Notice that we look up v2 in the in-scope set 520 -- See Note [Lookup in-scope] 521 -- Remember to apply any renaming first (hence rnOccR) 522 523-- Note [Matching lets] 524-- ~~~~~~~~~~~~~~~~~~~~ 525-- Matching a let-expression. Consider 526-- RULE forall x. f (g x) = <rhs> 527-- and target expression 528-- f (let { w=R } in g E)) 529-- Then we'd like the rule to match, to generate 530-- let { w=R } in (\x. <rhs>) E 531-- In effect, we want to float the let-binding outward, to enable 532-- the match to happen. This is the WHOLE REASON for accumulating 533-- bindings in the SubstEnv 534-- 535-- We can only do this if 536-- (a) Widening the scope of w does not capture any variables 537-- We use a conservative test: w is not already in scope 538-- If not, we clone the binders, and substitute 539-- (b) The free variables of R are not bound by the part of the 540-- target expression outside the let binding; e.g. 541-- f (\v. let w = v+1 in g E) 542-- Here we obviously cannot float the let-binding for w. 543-- 544-- You may think rule (a) would never apply, because rule matching is 545-- mostly invoked from the simplifier, when we have just run substExpr 546-- over the argument, so there will be no shadowing anyway. 547-- The fly in the ointment is that the forall'd variables of the 548-- RULE itself are considered in scope. 549-- 550-- I though of various cheapo ways to solve this tiresome problem, 551-- but ended up doing the straightforward thing, which is to 552-- clone the binders if they are in scope. It's tiresome, and 553-- potentially inefficient, because of the calls to substExpr, 554-- but I don't think it'll happen much in pracice. 555 556{- Cases to think about 557 (let x=y+1 in \x. (x,x)) 558 --> let x=y+1 in (\x1. (x1,x1)) 559 (\x. let x = y+1 in (x,x)) 560 --> let x1 = y+1 in (\x. (x1,x1) 561 (let x=y+1 in (x,x), let x=y-1 in (x,x)) 562 --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1)) 563 564Watch out! 565 (let x=y+1 in let z=x+1 in (z,z) 566 --> matches (p,p) but watch out that the use of 567 x on z's rhs is OK! 568I'm removing the cloning because that makes the above case 569fail, because the inner let looks as if it has locally-bound vars -} 570 571match menv subst@(tv_subst, id_subst, binds) e1 (Let bind e2) 572 | all freshly_bound bndrs, 573 not (any locally_bound bind_fvs) 574 = match (menv { me_env = rn_env' }) 575 (tv_subst, id_subst, binds `snocOL` bind') 576 e1 e2' 577 where 578 rn_env = me_env menv 579 bndrs = bindersOf bind 580 bind_fvs = varSetElems (bindFreeVars bind) 581 locally_bound x = inRnEnvR rn_env x 582 freshly_bound x = not (x `rnInScope` rn_env) 583 bind' = bind 584 e2' = e2 585 rn_env' = extendRnInScopeList rn_env bndrs 586{- 587 (rn_env', bndrs') = mapAccumL rnBndrR rn_env bndrs 588 s_prs = [(bndr, Var bndr') | (bndr,bndr') <- zip bndrs bndrs', bndr /= bndr'] 589 subst = mkSubst (rnInScopeSet rn_env) emptyVarEnv (mkVarEnv s_prs) 590 (bind', e2') | null s_prs = (bind, e2) 591 | otherwise = (s_bind, substExpr subst e2) 592 s_bind = case bind of 593 NonRec {} -> NonRec (head bndrs') (head rhss) 594 Rec {} -> Rec (bndrs' `zip` map (substExpr subst) rhss) 595-} 596 597match menv subst (Lit lit1) (Lit lit2) 598 | lit1 == lit2 599 = Just subst 600 601match menv subst (App f1 a1) (App f2 a2) 602 = do { subst' <- match menv subst f1 f2 603 ; match menv subst' a1 a2 } 604 605match menv subst (Lam x1 e1) (Lam x2 e2) 606 = match menv' subst e1 e2 607 where 608 menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } 609 610-- This rule does eta expansion 611-- (\x.M) ~ N iff M ~ N x 612-- It's important that this is *after* the let rule, 613-- so that (\x.M) ~ (let y = e in \y.N) 614-- does the let thing, and then gets the lam/lam rule above 615match menv subst (Lam x1 e1) e2 616 = match menv' subst e1 (App e2 (varToCoreExpr new_x)) 617 where 618 (rn_env', new_x) = rnBndrL (me_env menv) x1 619 menv' = menv { me_env = rn_env' } 620 621-- Eta expansion the other way 622-- M ~ (\y.N) iff M y ~ N 623match menv subst e1 (Lam x2 e2) 624 = match menv' subst (App e1 (varToCoreExpr new_x)) e2 625 where 626 (rn_env', new_x) = rnBndrR (me_env menv) x2 627 menv' = menv { me_env = rn_env' } 628 629match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) 630 = do { subst1 <- match_ty menv subst ty1 ty2 631 ; subst2 <- match menv subst1 e1 e2 632 ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 } 633 ; match_alts menv' subst2 alts1 alts2 -- Alts are both sorted 634 } 635 636match menv subst (Type ty1) (Type ty2) 637 = match_ty menv subst ty1 ty2 638 639match menv subst (Cast e1 co1) (Cast e2 co2) 640 = do { subst1 <- match_ty menv subst co1 co2 641 ; match menv subst1 e1 e2 } 642 643{- REMOVING OLD CODE: I think that the above handling for let is 644 better than the stuff here, which looks 645 pretty suspicious to me. SLPJ Sept 06 646-- This is an interesting rule: we simply ignore lets in the 647-- term being matched against! The unfolding inside it is (by assumption) 648-- already inside any occurrences of the bound variables, so we'll expand 649-- them when we encounter them. This gives a chance of matching 650-- forall x,y. f (g (x,y)) 651-- against 652-- f (let v = (a,b) in g v) 653 654match menv subst e1 (Let bind e2) 655 = match (menv { me_env = rn_env' }) subst e1 e2 656 where 657 (rn_env', _bndrs') = mapAccumL rnBndrR (me_env menv) (bindersOf bind) 658 -- It's important to do this renaming, so that the bndrs 659 -- are brought into the local scope. For example: 660 -- Matching 661 -- forall f,x,xs. f (x:xs) 662 -- against 663 -- f (let y = e in (y:[])) 664 -- We must not get success with x->y! So we record that y is 665 -- locally bound (with rnBndrR), and proceed. The Var case 666 -- will fail when trying to bind x->y 667-} 668 669-- Everything else fails 670match menv subst e1 e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr e1) $$ (text "e2:" <+> ppr e2)) $ 671 Nothing 672 673------------------------------------------ 674match_var :: MatchEnv 675 -> SubstEnv 676 -> Var -- Template 677 -> CoreExpr -- Target 678 -> Maybe SubstEnv 679match_var menv subst@(tv_subst, id_subst, binds) v1 e2 680 | v1' `elemVarSet` me_tmpls menv 681 = case lookupVarEnv id_subst v1' of 682 Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2)) 683 -> Nothing -- Occurs check failure 684 -- e.g. match forall a. (\x-> a x) against (\y. y y) 685 686 | otherwise -- No renaming to do on e2, because no free var 687 -- of e2 is in the rnEnvR of the envt 688 -- Note [Matching variable types] 689 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 690 -- However, we must match the *types*; e.g. 691 -- forall (c::Char->Int) (x::Char). 692 -- f (c x) = "RULE FIRED" 693 -- We must only match on args that have the right type 694 -- It's actually quite difficult to come up with an example that shows 695 -- you need type matching, esp since matching is left-to-right, so type 696 -- args get matched first. But it's possible (e.g. simplrun008) and 697 -- this is the Right Thing to do 698 -> do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst (idType v1') (exprType e2) 699 -- c.f. match_ty below 700 ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) } 701 702 Just e1' | tcEqExprX (nukeRnEnvL rn_env) e1' e2 703 -> Just subst 704 705 | otherwise 706 -> Nothing 707 708 | otherwise -- v1 is not a template variable; check for an exact match with e2 709 = case e2 of 710 Var v2 | v1' == rnOccR rn_env v2 -> Just subst 711 other -> Nothing 712 713 where 714 rn_env = me_env menv 715 v1' = rnOccL rn_env v1 716 -- If the template is 717 -- forall x. f x (\x -> x) = ... 718 -- Then the x inside the lambda isn't the 719 -- template x, so we must rename first! 720 721 722------------------------------------------ 723match_alts :: MatchEnv 724 -> SubstEnv 725 -> [CoreAlt] -- Template 726 -> [CoreAlt] -- Target 727 -> Maybe SubstEnv 728match_alts menv subst [] [] 729 = return subst 730match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) 731 | c1 == c2 732 = do { subst1 <- match menv' subst r1 r2 733 ; match_alts menv subst1 alts1 alts2 } 734 where 735 menv' :: MatchEnv 736 menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 } 737 738match_alts menv subst alts1 alts2 739 = Nothing 740\end{code} 741 742Matching Core types: use the matcher in TcType. 743Notice that we treat newtypes as opaque. For example, suppose 744we have a specialised version of a function at a newtype, say 745 newtype T = MkT Int 746We only want to replace (f T) with f', not (f Int). 747 748\begin{code} 749------------------------------------------ 750match_ty :: MatchEnv 751 -> SubstEnv 752 -> Type -- Template 753 -> Type -- Target 754 -> Maybe SubstEnv 755match_ty menv (tv_subst, id_subst, binds) ty1 ty2 756 = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2 757 ; return (tv_subst', id_subst, binds) } 758\end{code} 759 760 761Note [Lookup in-scope] 762~~~~~~~~~~~~~~~~~~~~~~ 763Consider this example 764 foo :: Int -> Maybe Int -> Int 765 foo 0 (Just n) = n 766 foo m (Just n) = foo (m-n) (Just n) 767 768SpecConstr sees this fragment: 769 770 case w_smT of wild_Xf [Just A] { 771 Data.Maybe.Nothing -> lvl_smf; 772 Data.Maybe.Just n_acT [Just S(L)] -> 773 case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> 774 \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf 775 }}; 776 777and correctly generates the rule 778 779 RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# 780 sc_snn :: GHC.Prim.Int#} 781 \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) 782 = \$s\$wfoo_sno y_amr sc_snn ;] 783 784BUT we must ensure that this rule matches in the original function! 785Note that the call to \$wfoo is 786 \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf 787 788During matching we expand wild_Xf to (Just n_acT). But then we must also 789expand n_acT to (I# y_amr). And we can only do that if we look up n_acT 790in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding 791at all. 792 793That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' 794is so important. 795 796 797%************************************************************************ 798%* * 799\subsection{Checking a program for failing rule applications} 800%* * 801%************************************************************************ 802 803----------------------------------------------------- 804 Game plan 805----------------------------------------------------- 806 807We want to know what sites have rules that could have fired but didn't. 808This pass runs over the tree (without changing it) and reports such. 809 810\begin{code} 811-- | Report partial matches for rules beginning with the specified 812-- string for the purposes of error reporting 813ruleCheckProgram :: (Activation -> Bool) -- ^ Rule activation test 814 -> String -- ^ Rule pattern 815 -> RuleBase -- ^ Database of rules 816 -> [CoreBind] -- ^ Bindings to check in 817 -> SDoc -- ^ Resulting check message 818ruleCheckProgram is_active rule_pat rule_base binds 819 | isEmptyBag results 820 = text "Rule check results: no rule application sites" 821 | otherwise 822 = vcat [text "Rule check results:", 823 line, 824 vcat [ p $$ line | p <- bagToList results ] 825 ] 826 where 827 results = unionManyBags (map (ruleCheckBind (RuleCheckEnv is_active rule_pat rule_base)) binds) 828 line = text (replicate 20 '-') 829 830data RuleCheckEnv = RuleCheckEnv { 831 rc_is_active :: Activation -> Bool, 832 rc_pattern :: String, 833 rc_rule_base :: RuleBase 834} 835 836ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc 837 -- The Bag returned has one SDoc for each call site found 838ruleCheckBind env (NonRec b r) = ruleCheck env r 839ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (b,r) <- prs] 840 841ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc 842ruleCheck env (Var v) = emptyBag 843ruleCheck env (Lit l) = emptyBag 844ruleCheck env (Type ty) = emptyBag 845ruleCheck env (App f a) = ruleCheckApp env (App f a) [] 846ruleCheck env (Note n e) = ruleCheck env e 847ruleCheck env (Cast e co) = ruleCheck env e 848ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e 849ruleCheck env (Lam b e) = ruleCheck env e 850ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` 851 unionManyBags [ruleCheck env r | (_,_,r) <- as] 852 853ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) 854ruleCheckApp env (Var f) as = ruleCheckFun env f as 855ruleCheckApp env other as = ruleCheck env other 856\end{code} 857 858\begin{code} 859ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc 860-- Produce a report for all rules matching the predicate 861-- saying why it doesn't match the specified application 862 863ruleCheckFun env fn args 864 | null name_match_rules = emptyBag 865 | otherwise = unitBag (ruleAppCheck_help (rc_is_active env) fn args name_match_rules) 866 where 867 name_match_rules = filter match (getRules (rc_rule_base env) fn) 868 match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) 869 870ruleAppCheck_help :: (Activation -> Bool) -> Id -> [CoreExpr] -> [CoreRule] -> SDoc 871ruleAppCheck_help is_active fn args rules 872 = -- The rules match the pattern, so we want to print something 873 vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), 874 vcat (map check_rule rules)] 875 where 876 n_args = length args 877 i_args = args `zip` [1::Int ..] 878 rough_args = map roughTopName args 879 880 check_rule rule = rule_herald rule <> colon <+> rule_info rule 881 882 rule_herald (BuiltinRule { ru_name = name }) 883 = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name) 884 rule_herald (Rule { ru_name = name }) 885 = ptext (sLit "Rule") <+> doubleQuotes (ftext name) 886 887 rule_info rule 888 | Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule 889 = text "matches (which is very peculiar!)" 890 891 rule_info (BuiltinRule {}) = text "does not match" 892 893 rule_info (Rule { ru_name = name, ru_act = act, 894 ru_bndrs = rule_bndrs, ru_args = rule_args}) 895 | not (is_active act) = text "active only in later phase" 896 | n_args < n_rule_args = text "too few arguments" 897 | n_mismatches == n_rule_args = text "no arguments match" 898 | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" 899 | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" 900 where 901 n_rule_args = length rule_args 902 n_mismatches = length mismatches 903 mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, 904 not (isJust (match_fn rule_arg arg))] 905 906 lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars 907 match_fn rule_arg arg = match menv emptySubstEnv rule_arg arg 908 where 909 in_scope = lhs_fvs `unionVarSet` exprFreeVars arg 910 menv = ME { me_env = mkRnEnv2 (mkInScopeSet in_scope) 911 , me_tmpls = mkVarSet rule_bndrs } 912\end{code} 913 914