1{- 2(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 3 4\section[CoreRules]{Transformation rules} 5-} 6 7{-# LANGUAGE CPP #-} 8 9-- | Functions for collecting together and applying rewrite rules to a module. 10-- The 'CoreRule' datatype itself is declared elsewhere. 11module Rules ( 12 -- ** Constructing 13 emptyRuleBase, mkRuleBase, extendRuleBaseList, 14 unionRuleBase, pprRuleBase, 15 16 -- ** Checking rule applications 17 ruleCheckProgram, 18 19 -- ** Manipulating 'RuleInfo' rules 20 mkRuleInfo, extendRuleInfo, addRuleInfo, 21 addIdSpecialisations, 22 23 -- * Misc. CoreRule helpers 24 rulesOfBinds, getRules, pprRulesForUser, 25 26 lookupRule, mkRule, roughTopNames 27 ) where 28 29#include "HsVersions.h" 30 31import GhcPrelude 32 33import CoreSyn -- All of it 34import Module ( Module, ModuleSet, elemModuleSet ) 35import CoreSubst 36import CoreOpt ( exprIsLambda_maybe ) 37import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars 38 , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) 39import CoreUtils ( exprType, eqExpr, mkTick, mkTicks, 40 stripTicksTopT, stripTicksTopE, 41 isJoinBind ) 42import PprCore ( pprRules ) 43import Type ( Type, TCvSubst, extendTvSubst, extendCvSubst 44 , mkEmptyTCvSubst, substTy ) 45import TcType ( tcSplitTyConApp_maybe ) 46import TysWiredIn ( anyTypeOfKind ) 47import Coercion 48import CoreTidy ( tidyRules ) 49import Id 50import IdInfo ( RuleInfo( RuleInfo ) ) 51import Var 52import VarEnv 53import VarSet 54import Name ( Name, NamedThing(..), nameIsLocalOrFrom ) 55import NameSet 56import NameEnv 57import UniqFM 58import Unify ( ruleMatchTyKiX ) 59import BasicTypes 60import DynFlags ( DynFlags ) 61import Outputable 62import FastString 63import Maybes 64import Bag 65import Util 66import Data.List 67import Data.Ord 68import Control.Monad ( guard ) 69 70{- 71Note [Overall plumbing for rules] 72~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 73* After the desugarer: 74 - The ModGuts initially contains mg_rules :: [CoreRule] of 75 locally-declared rules for imported Ids. 76 - Locally-declared rules for locally-declared Ids are attached to 77 the IdInfo for that Id. See Note [Attach rules to local ids] in 78 DsBinds 79 80* TidyPgm strips off all the rules from local Ids and adds them to 81 mg_rules, so that the ModGuts has *all* the locally-declared rules. 82 83* The HomePackageTable contains a ModDetails for each home package 84 module. Each contains md_rules :: [CoreRule] of rules declared in 85 that module. The HomePackageTable grows as ghc --make does its 86 up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules 87 are treated by the "external" route, discussed next, regardless of 88 which package they come from. 89 90* The ExternalPackageState has a single eps_rule_base :: RuleBase for 91 Ids in other packages. This RuleBase simply grow monotonically, as 92 ghc --make compiles one module after another. 93 94 During simplification, interface files may get demand-loaded, 95 as the simplifier explores the unfoldings for Ids it has in 96 its hand. (Via an unsafePerformIO; the EPS is really a cache.) 97 That in turn may make the EPS rule-base grow. In contrast, the 98 HPT never grows in this way. 99 100* The result of all this is that during Core-to-Core optimisation 101 there are four sources of rules: 102 103 (a) Rules in the IdInfo of the Id they are a rule for. These are 104 easy: fast to look up, and if you apply a substitution then 105 it'll be applied to the IdInfo as a matter of course. 106 107 (b) Rules declared in this module for imported Ids, kept in the 108 ModGuts. If you do a substitution, you'd better apply the 109 substitution to these. There are seldom many of these. 110 111 (c) Rules declared in the HomePackageTable. These never change. 112 113 (d) Rules in the ExternalPackageTable. These can grow in response 114 to lazy demand-loading of interfaces. 115 116* At the moment (c) is carried in a reader-monad way by the CoreMonad. 117 The HomePackageTable doesn't have a single RuleBase because technically 118 we should only be able to "see" rules "below" this module; so we 119 generate a RuleBase for (c) by combing rules from all the modules 120 "below" us. That's why we can't just select the home-package RuleBase 121 from HscEnv. 122 123 [NB: we are inconsistent here. We should do the same for external 124 packages, but we don't. Same for type-class instances.] 125 126* So in the outer simplifier loop, we combine (b-d) into a single 127 RuleBase, reading 128 (b) from the ModGuts, 129 (c) from the CoreMonad, and 130 (d) from its mutable variable 131 [Of coures this means that we won't see new EPS rules that come in 132 during a single simplifier iteration, but that probably does not 133 matter.] 134 135 136************************************************************************ 137* * 138\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} 139* * 140************************************************************************ 141 142A @CoreRule@ holds details of one rule for an @Id@, which 143includes its specialisations. 144 145For example, if a rule for @f@ contains the mapping: 146\begin{verbatim} 147 forall a b d. [Type (List a), Type b, Var d] ===> f' a b 148\end{verbatim} 149then when we find an application of f to matching types, we simply replace 150it by the matching RHS: 151\begin{verbatim} 152 f (List Int) Bool dict ===> f' Int Bool 153\end{verbatim} 154All the stuff about how many dictionaries to discard, and what types 155to apply the specialised function to, are handled by the fact that the 156Rule contains a template for the result of the specialisation. 157 158There is one more exciting case, which is dealt with in exactly the same 159way. If the specialised value is unboxed then it is lifted at its 160definition site and unlifted at its uses. For example: 161 162 pi :: forall a. Num a => a 163 164might have a specialisation 165 166 [Int#] ===> (case pi' of Lift pi# -> pi#) 167 168where pi' :: Lift Int# is the specialised version of pi. 169-} 170 171mkRule :: Module -> Bool -> Bool -> RuleName -> Activation 172 -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule 173-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being 174-- compiled. See also 'CoreSyn.CoreRule' 175mkRule this_mod is_auto is_local name act fn bndrs args rhs 176 = Rule { ru_name = name, ru_fn = fn, ru_act = act, 177 ru_bndrs = bndrs, ru_args = args, 178 ru_rhs = rhs, 179 ru_rough = roughTopNames args, 180 ru_origin = this_mod, 181 ru_orphan = orph, 182 ru_auto = is_auto, ru_local = is_local } 183 where 184 -- Compute orphanhood. See Note [Orphans] in InstEnv 185 -- A rule is an orphan only if none of the variables 186 -- mentioned on its left-hand side are locally defined 187 lhs_names = extendNameSet (exprsOrphNames args) fn 188 189 -- Since rules get eventually attached to one of the free names 190 -- from the definition when compiling the ABI hash, we should make 191 -- it deterministic. This chooses the one with minimal OccName 192 -- as opposed to uniq value. 193 local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names 194 orph = chooseOrphanAnchor local_lhs_names 195 196-------------- 197roughTopNames :: [CoreExpr] -> [Maybe Name] 198-- ^ Find the \"top\" free names of several expressions. 199-- Such names are either: 200-- 201-- 1. The function finally being applied to in an application chain 202-- (if that name is a GlobalId: see "Var#globalvslocal"), or 203-- 204-- 2. The 'TyCon' if the expression is a 'Type' 205-- 206-- This is used for the fast-match-check for rules; 207-- if the top names don't match, the rest can't 208roughTopNames args = map roughTopName args 209 210roughTopName :: CoreExpr -> Maybe Name 211roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of 212 Just (tc,_) -> Just (getName tc) 213 Nothing -> Nothing 214roughTopName (Coercion _) = Nothing 215roughTopName (App f _) = roughTopName f 216roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] 217 , isDataConWorkId f || idArity f > 0 218 = Just (idName f) 219roughTopName (Tick t e) | tickishFloatable t 220 = roughTopName e 221roughTopName _ = Nothing 222 223ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool 224-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ 225-- definitely can't match @tpl@ by instantiating @tpl@. 226-- It's only a one-way match; unlike instance matching we 227-- don't consider unification. 228-- 229-- Notice that [_$_] 230-- @ruleCantMatch [Nothing] [Just n2] = False@ 231-- Reason: a template variable can be instantiated by a constant 232-- Also: 233-- @ruleCantMatch [Just n1] [Nothing] = False@ 234-- Reason: a local variable @v@ in the actuals might [_$_] 235 236ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as 237ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as 238ruleCantMatch _ _ = False 239 240{- 241Note [Care with roughTopName] 242~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 243Consider this 244 module M where { x = a:b } 245 module N where { ...f x... 246 RULE f (p:q) = ... } 247You'd expect the rule to match, because the matcher can 248look through the unfolding of 'x'. So we must avoid roughTopName 249returning 'M.x' for the call (f x), or else it'll say "can't match" 250and we won't even try!! 251 252However, suppose we have 253 RULE g (M.h x) = ... 254 foo = ...(g (M.k v)).... 255where k is a *function* exported by M. We never really match 256functions (lambdas) except by name, so in this case it seems like 257a good idea to treat 'M.k' as a roughTopName of the call. 258-} 259 260pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc 261-- (a) tidy the rules 262-- (b) sort them into order based on the rule name 263-- (c) suppress uniques (unless -dppr-debug is on) 264-- This combination makes the output stable so we can use in testing 265-- It's here rather than in PprCore because it calls tidyRules 266pprRulesForUser dflags rules 267 = withPprStyle (defaultUserStyle dflags) $ 268 pprRules $ 269 sortBy (comparing ruleName) $ 270 tidyRules emptyTidyEnv rules 271 272{- 273************************************************************************ 274* * 275 RuleInfo: the rules in an IdInfo 276* * 277************************************************************************ 278-} 279 280-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable 281-- for putting into an 'IdInfo' 282mkRuleInfo :: [CoreRule] -> RuleInfo 283mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules) 284 285extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo 286extendRuleInfo (RuleInfo rs1 fvs1) rs2 287 = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1) 288 289addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo 290addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2) 291 = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2) 292 293addIdSpecialisations :: Id -> [CoreRule] -> Id 294addIdSpecialisations id rules 295 | null rules 296 = id 297 | otherwise 298 = setIdSpecialisation id $ 299 extendRuleInfo (idSpecialisation id) rules 300 301-- | Gather all the rules for locally bound identifiers from the supplied bindings 302rulesOfBinds :: [CoreBind] -> [CoreRule] 303rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds 304 305getRules :: RuleEnv -> Id -> [CoreRule] 306-- See Note [Where rules are found] 307getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn 308 = idCoreRules fn ++ filter (ruleIsVisible orphs) imp_rules 309 where 310 imp_rules = lookupNameEnv rule_base (idName fn) `orElse` [] 311 312ruleIsVisible :: ModuleSet -> CoreRule -> Bool 313ruleIsVisible _ BuiltinRule{} = True 314ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin } 315 = notOrphan orph || origin `elemModuleSet` vis_orphs 316 317{- Note [Where rules are found] 318~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 319The rules for an Id come from two places: 320 (a) the ones it is born with, stored inside the Id iself (idCoreRules fn), 321 (b) rules added in other modules, stored in the global RuleBase (imp_rules) 322 323It's tempting to think that 324 - LocalIds have only (a) 325 - non-LocalIds have only (b) 326 327but that isn't quite right: 328 329 - PrimOps and ClassOps are born with a bunch of rules inside the Id, 330 even when they are imported 331 332 - The rules in PrelRules.builtinRules should be active even 333 in the module defining the Id (when it's a LocalId), but 334 the rules are kept in the global RuleBase 335 336 337************************************************************************ 338* * 339 RuleBase 340* * 341************************************************************************ 342-} 343 344-- RuleBase itself is defined in CoreSyn, along with CoreRule 345 346emptyRuleBase :: RuleBase 347emptyRuleBase = emptyNameEnv 348 349mkRuleBase :: [CoreRule] -> RuleBase 350mkRuleBase rules = extendRuleBaseList emptyRuleBase rules 351 352extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase 353extendRuleBaseList rule_base new_guys 354 = foldl' extendRuleBase rule_base new_guys 355 356unionRuleBase :: RuleBase -> RuleBase -> RuleBase 357unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2 358 359extendRuleBase :: RuleBase -> CoreRule -> RuleBase 360extendRuleBase rule_base rule 361 = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule 362 363pprRuleBase :: RuleBase -> SDoc 364pprRuleBase rules = pprUFM rules $ \rss -> 365 vcat [ pprRules (tidyRules emptyTidyEnv rs) 366 | rs <- rss ] 367 368{- 369************************************************************************ 370* * 371 Matching 372* * 373************************************************************************ 374-} 375 376-- | The main rule matching function. Attempts to apply all (active) 377-- supplied rules to this instance of an application in a given 378-- context, returning the rule applied and the resulting expression if 379-- successful. 380lookupRule :: DynFlags -> InScopeEnv 381 -> (Activation -> Bool) -- When rule is active 382 -> Id -> [CoreExpr] 383 -> [CoreRule] -> Maybe (CoreRule, CoreExpr) 384 385-- See Note [Extra args in rule matching] 386-- See comments on matchRule 387lookupRule dflags in_scope is_active fn args rules 388 = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ 389 case go [] rules of 390 [] -> Nothing 391 (m:ms) -> Just (findBest (fn,args') m ms) 392 where 393 rough_args = map roughTopName args 394 395 -- Strip ticks from arguments, see note [Tick annotations in RULE 396 -- matching]. We only collect ticks if a rule actually matches - 397 -- this matters for performance tests. 398 args' = map (stripTicksTopE tickishFloatable) args 399 ticks = concatMap (stripTicksTopT tickishFloatable) args 400 401 go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] 402 go ms [] = ms 403 go ms (r:rs) 404 | Just e <- matchRule dflags in_scope is_active fn args' rough_args r 405 = go ((r,mkTicks ticks e):ms) rs 406 | otherwise 407 = -- pprTrace "match failed" (ppr r $$ ppr args $$ 408 -- ppr [ (arg_id, unfoldingTemplate unf) 409 -- | Var arg_id <- args 410 -- , let unf = idUnfolding arg_id 411 -- , isCheapUnfolding unf] ) 412 go ms rs 413 414findBest :: (Id, [CoreExpr]) 415 -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) 416-- All these pairs matched the expression 417-- Return the pair the most specific rule 418-- The (fn,args) is just for overlap reporting 419 420findBest _ (rule,ans) [] = (rule,ans) 421findBest target (rule1,ans1) ((rule2,ans2):prs) 422 | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs 423 | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs 424 | debugIsOn = let pp_rule rule 425 = ifPprDebug (ppr rule) 426 (doubleQuotes (ftext (ruleName rule))) 427 in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" 428 (vcat [ whenPprDebug $ 429 text "Expression to match:" <+> ppr fn 430 <+> sep (map ppr args) 431 , text "Rule 1:" <+> pp_rule rule1 432 , text "Rule 2:" <+> pp_rule rule2]) $ 433 findBest target (rule1,ans1) prs 434 | otherwise = findBest target (rule1,ans1) prs 435 where 436 (fn,args) = target 437 438isMoreSpecific :: CoreRule -> CoreRule -> Bool 439-- This tests if one rule is more specific than another 440-- We take the view that a BuiltinRule is less specific than 441-- anything else, because we want user-define rules to "win" 442-- In particular, class ops have a built-in rule, but we 443-- any user-specific rules to win 444-- eg (#4397) 445-- truncate :: (RealFrac a, Integral b) => a -> b 446-- {-# RULES "truncate/Double->Int" truncate = double2Int #-} 447-- double2Int :: Double -> Int 448-- We want the specific RULE to beat the built-in class-op rule 449isMoreSpecific (BuiltinRule {}) _ = False 450isMoreSpecific (Rule {}) (BuiltinRule {}) = True 451isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) 452 (Rule { ru_bndrs = bndrs2, ru_args = args2 453 , ru_name = rule_name2, ru_rhs = rhs }) 454 = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1 rhs) 455 where 456 id_unfolding_fun _ = NoUnfolding -- Don't expand in templates 457 in_scope = mkInScopeSet (mkVarSet bndrs1) 458 -- Actually we should probably include the free vars 459 -- of rule1's args, but I can't be bothered 460 461noBlackList :: Activation -> Bool 462noBlackList _ = False -- Nothing is black listed 463 464{- 465Note [Extra args in rule matching] 466~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 467If we find a matching rule, we return (Just (rule, rhs)), 468but the rule firing has only consumed as many of the input args 469as the ruleArity says. It's up to the caller to keep track 470of any left-over args. E.g. if you call 471 lookupRule ... f [e1, e2, e3] 472and it returns Just (r, rhs), where r has ruleArity 2 473then the real rewrite is 474 f e1 e2 e3 ==> rhs e3 475 476You might think it'd be cleaner for lookupRule to deal with the 477leftover arguments, by applying 'rhs' to them, but the main call 478in the Simplifier works better as it is. Reason: the 'args' passed 479to lookupRule are the result of a lazy substitution 480-} 481 482------------------------------------ 483matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool) 484 -> Id -> [CoreExpr] -> [Maybe Name] 485 -> CoreRule -> Maybe CoreExpr 486 487-- If (matchRule rule args) returns Just (name,rhs) 488-- then (f args) matches the rule, and the corresponding 489-- rewritten RHS is rhs 490-- 491-- The returned expression is occurrence-analysed 492-- 493-- Example 494-- 495-- The rule 496-- forall f g x. map f (map g x) ==> map (f . g) x 497-- is stored 498-- CoreRule "map/map" 499-- [f,g,x] -- tpl_vars 500-- [f,map g x] -- tpl_args 501-- map (f.g) x) -- rhs 502-- 503-- Then the call: matchRule the_rule [e1,map e2 e3] 504-- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) 505-- 506-- Any 'surplus' arguments in the input are simply put on the end 507-- of the output. 508 509matchRule dflags rule_env _is_active fn args _rough_args 510 (BuiltinRule { ru_try = match_fn }) 511-- Built-in rules can't be switched off, it seems 512 = case match_fn dflags rule_env fn args of 513 Nothing -> Nothing 514 Just expr -> Just expr 515 516matchRule _ in_scope is_active _ args rough_args 517 (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops 518 , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) 519 | not (is_active act) = Nothing 520 | ruleCantMatch tpl_tops rough_args = Nothing 521 | otherwise = matchN in_scope rule_name tpl_vars tpl_args args rhs 522 523--------------------------------------- 524matchN :: InScopeEnv 525 -> RuleName -> [Var] -> [CoreExpr] 526 -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template 527 -> Maybe CoreExpr 528-- For a given match template and context, find bindings to wrap around 529-- the entire result and what should be substituted for each template variable. 530-- Fail if there are two few actual arguments from the target to match the template 531 532matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs 533 = do { rule_subst <- go init_menv emptyRuleSubst tmpl_es target_es 534 ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) 535 (mkEmptyTCvSubst in_scope) $ 536 tmpl_vars `zip` tmpl_vars1 537 bind_wrapper = rs_binds rule_subst 538 -- Floated bindings; see Note [Matching lets] 539 ; return (bind_wrapper $ 540 mkLams tmpl_vars rhs `mkApps` matched_es) } 541 where 542 (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars 543 -- See Note [Cloning the template binders] 544 545 init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1 546 , rv_lcl = init_rn_env 547 , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) 548 , rv_unf = id_unf } 549 550 go _ subst [] _ = Just subst 551 go _ _ _ [] = Nothing -- Fail if too few actual args 552 go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e 553 ; go menv subst1 ts es } 554 555 lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr) 556 -- Need to return a RuleSubst solely for the benefit of mk_fake_ty 557 lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) 558 tcv_subst (tmpl_var, tmpl_var1) 559 | isId tmpl_var1 560 = case lookupVarEnv id_subst tmpl_var1 of 561 Just e | Coercion co <- e 562 -> (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) 563 | otherwise 564 -> (tcv_subst, e) 565 Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1 566 , let co = Coercion.substCo tcv_subst refl_co 567 -> -- See Note [Unbound RULE binders] 568 (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) 569 | otherwise 570 -> unbound tmpl_var 571 572 | otherwise 573 = (Type.extendTvSubst tcv_subst tmpl_var1 ty', Type ty') 574 where 575 ty' = case lookupVarEnv tv_subst tmpl_var1 of 576 Just ty -> ty 577 Nothing -> fake_ty -- See Note [Unbound RULE binders] 578 fake_ty = anyTypeOfKind (Type.substTy tcv_subst (tyVarKind tmpl_var1)) 579 -- This substitution is the sole reason we accumulate 580 -- TCvSubst in lookup_tmpl 581 582 unbound tmpl_var 583 = pprPanic "Template variable unbound in rewrite rule" $ 584 vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) 585 , text "Rule" <+> pprRuleName rule_name 586 , text "Rule bndrs:" <+> ppr tmpl_vars 587 , text "LHS args:" <+> ppr tmpl_es 588 , text "Actual args:" <+> ppr target_es ] 589 590 591{- Note [Unbound RULE binders] 592~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 593It can be the case that the binder in a rule is not actually 594bound on the LHS: 595 596* Type variables. Type synonyms with phantom args can give rise to 597 unbound template type variables. Consider this (#10689, 598 simplCore/should_compile/T10689): 599 600 type Foo a b = b 601 602 f :: Eq a => a -> Bool 603 f x = x==x 604 605 {-# RULES "foo" forall (x :: Foo a Char). f x = True #-} 606 finkle = f 'c' 607 608 The rule looks like 609 forall (a::*) (d::Eq Char) (x :: Foo a Char). 610 f (Foo a Char) d x = True 611 612 Matching the rule won't bind 'a', and legitimately so. We fudge by 613 pretending that 'a' is bound to (Any :: *). 614 615* Coercion variables. On the LHS of a RULE for a local binder 616 we might have 617 RULE forall (c :: a~b). f (x |> c) = e 618 Now, if that binding is inlined, so that a=b=Int, we'd get 619 RULE forall (c :: Int~Int). f (x |> c) = e 620 and now when we simplify the LHS (Simplify.simplRule) we 621 optCoercion (look at the CoVarCo case) will turn that 'c' into Refl: 622 RULE forall (c :: Int~Int). f (x |> <Int>) = e 623 and then perhaps drop it altogether. Now 'c' is unbound. 624 625 It's tricky to be sure this never happens, so instead I 626 say it's OK to have an unbound coercion binder in a RULE 627 provided its type is (c :: t~t). Then, when the RULE 628 fires we can substitute <t> for c. 629 630 This actually happened (in a RULE for a local function) 631 in #13410, and also in test T10602. 632 633Note [Cloning the template binders] 634~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 635Consider the following match (example 1): 636 Template: forall x. f x 637 Target: f (x+1) 638This should succeed, because the template variable 'x' has nothing to 639do with the 'x' in the target. 640 641Likewise this one (example 2): 642 Template: forall x. f (\x.x) 643 Target: f (\y.y) 644 645We achieve this simply by using rnBndrL to clone the template 646binders if they are already in scope. 647 648------ Historical note ------- 649At one point I tried simply adding the template binders to the 650in-scope set /without/ cloning them, but that failed in a horribly 651obscure way in #14777. Problem was that during matching we look 652up target-term variables in the in-scope set (see Note [Lookup 653in-scope]). If a target-term variable happens to name-clash with a 654template variable, that lookup will find the template variable, which 655is /utterly/ bogus. In #14777, this transformed a term variable 656into a type variable, and then crashed when we wanted its idInfo. 657------ End of historical note ------- 658 659 660************************************************************************ 661* * 662 The main matcher 663* * 664********************************************************************* -} 665 666-- * The domain of the TvSubstEnv and IdSubstEnv are the template 667-- variables passed into the match. 668-- 669-- * The BindWrapper in a RuleSubst are the bindings floated out 670-- from nested matches; see the Let case of match, below 671-- 672data RuleMatchEnv 673 = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings* 674 -- (lambda/case) 675 , rv_tmpls :: VarSet -- Template variables 676 -- (after applying envL of rv_lcl) 677 , rv_fltR :: Subst -- Renamings for floated let-bindings 678 -- (domain disjoint from envR of rv_lcl) 679 -- See Note [Matching lets] 680 , rv_unf :: IdUnfoldingFun 681 } 682 683rvInScopeEnv :: RuleMatchEnv -> InScopeEnv 684rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) 685 686data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the 687 , rs_id_subst :: IdSubstEnv -- template variables 688 , rs_binds :: BindWrapper -- Floated bindings 689 , rs_bndrs :: VarSet -- Variables bound by floated lets 690 } 691 692type BindWrapper = CoreExpr -> CoreExpr 693 -- See Notes [Matching lets] and [Matching cases] 694 -- we represent the floated bindings as a core-to-core function 695 696emptyRuleSubst :: RuleSubst 697emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv 698 , rs_binds = \e -> e, rs_bndrs = emptyVarSet } 699 700-- At one stage I tried to match even if there are more 701-- template args than real args. 702 703-- I now think this is probably a bad idea. 704-- Should the template (map f xs) match (map g)? I think not. 705-- For a start, in general eta expansion wastes work. 706-- SLPJ July 99 707 708match :: RuleMatchEnv 709 -> RuleSubst 710 -> CoreExpr -- Template 711 -> CoreExpr -- Target 712 -> Maybe RuleSubst 713 714-- We look through certain ticks. See Note [Tick annotations in RULE matching] 715match renv subst e1 (Tick t e2) 716 | tickishFloatable t 717 = match renv subst' e1 e2 718 where subst' = subst { rs_binds = rs_binds subst . mkTick t } 719match renv subst (Tick t e1) e2 720 -- Ignore ticks in rule template. 721 | tickishFloatable t 722 = match renv subst e1 e2 723match _ _ e@Tick{} _ 724 = pprPanic "Tick in rule" (ppr e) 725 726-- See the notes with Unify.match, which matches types 727-- Everything is very similar for terms 728 729-- Interesting examples: 730-- Consider matching 731-- \x->f against \f->f 732-- When we meet the lambdas we must remember to rename f to f' in the 733-- second expression. The RnEnv2 does that. 734-- 735-- Consider matching 736-- forall a. \b->b against \a->3 737-- We must rename the \a. Otherwise when we meet the lambdas we 738-- might substitute [a/b] in the template, and then erroneously 739-- succeed in matching what looks like the template variable 'a' against 3. 740 741-- The Var case follows closely what happens in Unify.match 742match renv subst (Var v1) e2 743 = match_var renv subst v1 e2 744 745match renv subst e1 (Var v2) -- Note [Expanding variables] 746 | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] 747 , Just e2' <- expandUnfolding_maybe (rv_unf renv v2') 748 = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' 749 where 750 v2' = lookupRnInScope rn_env v2 751 rn_env = rv_lcl renv 752 -- Notice that we look up v2 in the in-scope set 753 -- See Note [Lookup in-scope] 754 -- No need to apply any renaming first (hence no rnOccR) 755 -- because of the not-inRnEnvR 756 757match renv subst e1 (Let bind e2) 758 | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ 759 not (isJoinBind bind) -- can't float join point out of argument position 760 , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] 761 = match (renv { rv_fltR = flt_subst' }) 762 (subst { rs_binds = rs_binds subst . Let bind' 763 , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs }) 764 e1 e2 765 where 766 flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst) 767 (flt_subst', bind') = substBind flt_subst bind 768 new_bndrs = bindersOf bind' 769 770{- Disabled: see Note [Matching cases] below 771match renv (tv_subst, id_subst, binds) e1 772 (Case scrut case_bndr ty [(con, alt_bndrs, rhs)]) 773 | exprOkForSpeculation scrut -- See Note [Matching cases] 774 , okToFloat rn_env bndrs (exprFreeVars scrut) 775 = match (renv { me_env = rn_env' }) 776 (tv_subst, id_subst, binds . case_wrap) 777 e1 rhs 778 where 779 rn_env = me_env renv 780 rn_env' = extendRnInScopeList rn_env bndrs 781 bndrs = case_bndr : alt_bndrs 782 case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')] 783-} 784 785match _ subst (Lit lit1) (Lit lit2) 786 | lit1 == lit2 787 = Just subst 788 789match renv subst (App f1 a1) (App f2 a2) 790 = do { subst' <- match renv subst f1 f2 791 ; match renv subst' a1 a2 } 792 793match renv subst (Lam x1 e1) e2 794 | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2 795 = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 796 , rv_fltR = delBndr (rv_fltR renv) x2 } 797 subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } 798 in match renv' subst' e1 e2 799 800match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) 801 = do { subst1 <- match_ty renv subst ty1 ty2 802 ; subst2 <- match renv subst1 e1 e2 803 ; let renv' = rnMatchBndr2 renv subst x1 x2 804 ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted 805 } 806 807match renv subst (Type ty1) (Type ty2) 808 = match_ty renv subst ty1 ty2 809match renv subst (Coercion co1) (Coercion co2) 810 = match_co renv subst co1 co2 811 812match renv subst (Cast e1 co1) (Cast e2 co2) 813 = do { subst1 <- match_co renv subst co1 co2 814 ; match renv subst1 e1 e2 } 815 816-- Everything else fails 817match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ 818 Nothing 819 820------------- 821match_co :: RuleMatchEnv 822 -> RuleSubst 823 -> Coercion 824 -> Coercion 825 -> Maybe RuleSubst 826match_co renv subst co1 co2 827 | Just cv <- getCoVar_maybe co1 828 = match_var renv subst cv (Coercion co2) 829 | Just (ty1, r1) <- isReflCo_maybe co1 830 = do { (ty2, r2) <- isReflCo_maybe co2 831 ; guard (r1 == r2) 832 ; match_ty renv subst ty1 ty2 } 833match_co renv subst co1 co2 834 | Just (tc1, cos1) <- splitTyConAppCo_maybe co1 835 = case splitTyConAppCo_maybe co2 of 836 Just (tc2, cos2) 837 | tc1 == tc2 838 -> match_cos renv subst cos1 cos2 839 _ -> Nothing 840match_co renv subst co1 co2 841 | Just (arg1, res1) <- splitFunCo_maybe co1 842 = case splitFunCo_maybe co2 of 843 Just (arg2, res2) 844 -> match_cos renv subst [arg1, res1] [arg2, res2] 845 _ -> Nothing 846match_co _ _ _co1 _co2 847 -- Currently just deals with CoVarCo, TyConAppCo and Refl 848#if defined(DEBUG) 849 = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing 850#else 851 = Nothing 852#endif 853 854match_cos :: RuleMatchEnv 855 -> RuleSubst 856 -> [Coercion] 857 -> [Coercion] 858 -> Maybe RuleSubst 859match_cos renv subst (co1:cos1) (co2:cos2) = 860 do { subst' <- match_co renv subst co1 co2 861 ; match_cos renv subst' cos1 cos2 } 862match_cos _ subst [] [] = Just subst 863match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing 864 865------------- 866rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv 867rnMatchBndr2 renv subst x1 x2 868 = renv { rv_lcl = rnBndr2 rn_env x1 x2 869 , rv_fltR = delBndr (rv_fltR renv) x2 } 870 where 871 rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst) 872 -- Typically this is a no-op, but it may matter if 873 -- there are some floated let-bindings 874 875------------------------------------------ 876match_alts :: RuleMatchEnv 877 -> RuleSubst 878 -> [CoreAlt] -- Template 879 -> [CoreAlt] -- Target 880 -> Maybe RuleSubst 881match_alts _ subst [] [] 882 = return subst 883match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) 884 | c1 == c2 885 = do { subst1 <- match renv' subst r1 r2 886 ; match_alts renv subst1 alts1 alts2 } 887 where 888 renv' = foldl' mb renv (vs1 `zip` vs2) 889 mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2 890 891match_alts _ _ _ _ 892 = Nothing 893 894------------------------------------------ 895okToFloat :: RnEnv2 -> VarSet -> Bool 896okToFloat rn_env bind_fvs 897 = allVarSet not_captured bind_fvs 898 where 899 not_captured fv = not (inRnEnvR rn_env fv) 900 901------------------------------------------ 902match_var :: RuleMatchEnv 903 -> RuleSubst 904 -> Var -- Template 905 -> CoreExpr -- Target 906 -> Maybe RuleSubst 907match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) 908 subst v1 e2 909 | v1' `elemVarSet` tmpls 910 = match_tmpl_var renv subst v1' e2 911 912 | otherwise -- v1' is not a template variable; check for an exact match with e2 913 = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR 914 Var v2 | v1' == rnOccR rn_env v2 915 -> Just subst 916 917 | Var v2' <- lookupIdSubst (text "match_var") flt_env v2 918 , v1' == v2' 919 -> Just subst 920 921 _ -> Nothing 922 923 where 924 v1' = rnOccL rn_env v1 925 -- If the template is 926 -- forall x. f x (\x -> x) = ... 927 -- Then the x inside the lambda isn't the 928 -- template x, so we must rename first! 929 930------------------------------------------ 931match_tmpl_var :: RuleMatchEnv 932 -> RuleSubst 933 -> Var -- Template 934 -> CoreExpr -- Target 935 -> Maybe RuleSubst 936 937match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) 938 subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) 939 v1' e2 940 | any (inRnEnvR rn_env) (exprFreeVarsList e2) 941 = Nothing -- Occurs check failure 942 -- e.g. match forall a. (\x-> a x) against (\y. y y) 943 944 | Just e1' <- lookupVarEnv id_subst v1' 945 = if eqExpr (rnInScopeSet rn_env) e1' e2' 946 then Just subst 947 else Nothing 948 949 | otherwise 950 = -- Note [Matching variable types] 951 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 952 -- However, we must match the *types*; e.g. 953 -- forall (c::Char->Int) (x::Char). 954 -- f (c x) = "RULE FIRED" 955 -- We must only match on args that have the right type 956 -- It's actually quite difficult to come up with an example that shows 957 -- you need type matching, esp since matching is left-to-right, so type 958 -- args get matched first. But it's possible (e.g. simplrun008) and 959 -- this is the Right Thing to do 960 do { subst' <- match_ty renv subst (idType v1') (exprType e2) 961 ; return (subst' { rs_id_subst = id_subst' }) } 962 where 963 -- e2' is the result of applying flt_env to e2 964 e2' | isEmptyVarSet let_bndrs = e2 965 | otherwise = substExpr (text "match_tmpl_var") flt_env e2 966 967 id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' 968 -- No further renaming to do on e2', 969 -- because no free var of e2' is in the rnEnvR of the envt 970 971------------------------------------------ 972match_ty :: RuleMatchEnv 973 -> RuleSubst 974 -> Type -- Template 975 -> Type -- Target 976 -> Maybe RuleSubst 977-- Matching Core types: use the matcher in TcType. 978-- Notice that we treat newtypes as opaque. For example, suppose 979-- we have a specialised version of a function at a newtype, say 980-- newtype T = MkT Int 981-- We only want to replace (f T) with f', not (f Int). 982 983match_ty renv subst ty1 ty2 984 = do { tv_subst' 985 <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2 986 ; return (subst { rs_tv_subst = tv_subst' }) } 987 where 988 tv_subst = rs_tv_subst subst 989 990{- 991Note [Expanding variables] 992~~~~~~~~~~~~~~~~~~~~~~~~~~ 993Here is another Very Important rule: if the term being matched is a 994variable, we expand it so long as its unfolding is "expandable". (Its 995occurrence information is not necessarily up to date, so we don't use 996it.) By "expandable" we mean a WHNF or a "constructor-like" application. 997This is the key reason for "constructor-like" Ids. If we have 998 {-# NOINLINE [1] CONLIKE g #-} 999 {-# RULE f (g x) = h x #-} 1000then in the term 1001 let v = g 3 in ....(f v).... 1002we want to make the rule fire, to replace (f v) with (h 3). 1003 1004Note [Do not expand locally-bound variables] 1005~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1006Do *not* expand locally-bound variables, else there's a worry that the 1007unfolding might mention variables that are themselves renamed. 1008Example 1009 case x of y { (p,q) -> ...y... } 1010Don't expand 'y' to (p,q) because p,q might themselves have been 1011renamed. Essentially we only expand unfoldings that are "outside" 1012the entire match. 1013 1014Hence, (a) the guard (not (isLocallyBoundR v2)) 1015 (b) when we expand we nuke the renaming envt (nukeRnEnvR). 1016 1017Note [Tick annotations in RULE matching] 1018~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1019 1020We used to unconditionally look through ticks in both template and 1021expression being matched. This is actually illegal for counting or 1022cost-centre-scoped ticks, because we have no place to put them without 1023changing entry counts and/or costs. So now we just fail the match in 1024these cases. 1025 1026On the other hand, where we are allowed to insert new cost into the 1027tick scope, we can float them upwards to the rule application site. 1028 1029Moreover, we may encounter ticks in the template of a rule. There are a few 1030ways in which these may be introduced (e.g. #18162, #17619). Such ticks are 1031ignored by the matcher. See Note [Simplifying rules] in 1032GHC.Core.Opt.Simplify.Utils for details. 1033 1034cf Note [Notes in call patterns] in GHC.Core.Opt.SpecConstr 1035 1036Note [Matching lets] 1037~~~~~~~~~~~~~~~~~~~~ 1038Matching a let-expression. Consider 1039 RULE forall x. f (g x) = <rhs> 1040and target expression 1041 f (let { w=R } in g E)) 1042Then we'd like the rule to match, to generate 1043 let { w=R } in (\x. <rhs>) E 1044In effect, we want to float the let-binding outward, to enable 1045the match to happen. This is the WHOLE REASON for accumulating 1046bindings in the RuleSubst 1047 1048We can only do this if the free variables of R are not bound by the 1049part of the target expression outside the let binding; e.g. 1050 f (\v. let w = v+1 in g E) 1051Here we obviously cannot float the let-binding for w. Hence the 1052use of okToFloat. 1053 1054There are a couple of tricky points. 1055 (a) What if floating the binding captures a variable? 1056 f (let v = x+1 in v) v 1057 --> NOT! 1058 let v = x+1 in f (x+1) v 1059 1060 (b) What if two non-nested let bindings bind the same variable? 1061 f (let v = e1 in b1) (let v = e2 in b2) 1062 --> NOT! 1063 let v = e1 in let v = e2 in (f b2 b2) 1064 See testsuite test "RuleFloatLet". 1065 1066Our cunning plan is this: 1067 * Along with the growing substitution for template variables 1068 we maintain a growing set of floated let-bindings (rs_binds) 1069 plus the set of variables thus bound. 1070 1071 * The RnEnv2 in the MatchEnv binds only the local binders 1072 in the term (lambdas, case) 1073 1074 * When we encounter a let in the term to be matched, we 1075 check that does not mention any locally bound (lambda, case) 1076 variables. If so we fail 1077 1078 * We use CoreSubst.substBind to freshen the binding, using an 1079 in-scope set that is the original in-scope variables plus the 1080 rs_bndrs (currently floated let-bindings). So in (a) above 1081 we'll freshen the 'v' binding; in (b) above we'll freshen 1082 the *second* 'v' binding. 1083 1084 * We apply that freshening substitution, in a lexically-scoped 1085 way to the term, although lazily; this is the rv_fltR field. 1086 1087 1088Note [Matching cases] 1089~~~~~~~~~~~~~~~~~~~~~ 1090{- NOTE: This idea is currently disabled. It really only works if 1091 the primops involved are OkForSpeculation, and, since 1092 they have side effects readIntOfAddr and touch are not. 1093 Maybe we'll get back to this later . -} 1094 1095Consider 1096 f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> 1097 case touch# fp s# of { _ -> 1098 I# n# } } ) 1099This happened in a tight loop generated by stream fusion that 1100Roman encountered. We'd like to treat this just like the let 1101case, because the primops concerned are ok-for-speculation. 1102That is, we'd like to behave as if it had been 1103 case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> 1104 case touch# fp s# of { _ -> 1105 f (I# n# } } ) 1106 1107Note [Lookup in-scope] 1108~~~~~~~~~~~~~~~~~~~~~~ 1109Consider this example 1110 foo :: Int -> Maybe Int -> Int 1111 foo 0 (Just n) = n 1112 foo m (Just n) = foo (m-n) (Just n) 1113 1114SpecConstr sees this fragment: 1115 1116 case w_smT of wild_Xf [Just A] { 1117 Data.Maybe.Nothing -> lvl_smf; 1118 Data.Maybe.Just n_acT [Just S(L)] -> 1119 case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> 1120 $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf 1121 }}; 1122 1123and correctly generates the rule 1124 1125 RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# 1126 sc_snn :: GHC.Prim.Int#} 1127 $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) 1128 = $s$wfoo_sno y_amr sc_snn ;] 1129 1130BUT we must ensure that this rule matches in the original function! 1131Note that the call to $wfoo is 1132 $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf 1133 1134During matching we expand wild_Xf to (Just n_acT). But then we must also 1135expand n_acT to (I# y_amr). And we can only do that if we look up n_acT 1136in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding 1137at all. 1138 1139That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' 1140is so important. 1141 1142 1143************************************************************************ 1144* * 1145 Rule-check the program 1146* * 1147************************************************************************ 1148 1149 We want to know what sites have rules that could have fired but didn't. 1150 This pass runs over the tree (without changing it) and reports such. 1151-} 1152 1153-- | Report partial matches for rules beginning with the specified 1154-- string for the purposes of error reporting 1155ruleCheckProgram :: CompilerPhase -- ^ Rule activation test 1156 -> String -- ^ Rule pattern 1157 -> (Id -> [CoreRule]) -- ^ Rules for an Id 1158 -> CoreProgram -- ^ Bindings to check in 1159 -> SDoc -- ^ Resulting check message 1160ruleCheckProgram phase rule_pat rules binds 1161 | isEmptyBag results 1162 = text "Rule check results: no rule application sites" 1163 | otherwise 1164 = vcat [text "Rule check results:", 1165 line, 1166 vcat [ p $$ line | p <- bagToList results ] 1167 ] 1168 where 1169 env = RuleCheckEnv { rc_is_active = isActive phase 1170 , rc_id_unf = idUnfolding -- Not quite right 1171 -- Should use activeUnfolding 1172 , rc_pattern = rule_pat 1173 , rc_rules = rules } 1174 results = unionManyBags (map (ruleCheckBind env) binds) 1175 line = text (replicate 20 '-') 1176 1177data RuleCheckEnv = RuleCheckEnv { 1178 rc_is_active :: Activation -> Bool, 1179 rc_id_unf :: IdUnfoldingFun, 1180 rc_pattern :: String, 1181 rc_rules :: Id -> [CoreRule] 1182} 1183 1184ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc 1185 -- The Bag returned has one SDoc for each call site found 1186ruleCheckBind env (NonRec _ r) = ruleCheck env r 1187ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] 1188 1189ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc 1190ruleCheck _ (Var _) = emptyBag 1191ruleCheck _ (Lit _) = emptyBag 1192ruleCheck _ (Type _) = emptyBag 1193ruleCheck _ (Coercion _) = emptyBag 1194ruleCheck env (App f a) = ruleCheckApp env (App f a) [] 1195ruleCheck env (Tick _ e) = ruleCheck env e 1196ruleCheck env (Cast e _) = ruleCheck env e 1197ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e 1198ruleCheck env (Lam _ e) = ruleCheck env e 1199ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` 1200 unionManyBags [ruleCheck env r | (_,_,r) <- as] 1201 1202ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc 1203ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) 1204ruleCheckApp env (Var f) as = ruleCheckFun env f as 1205ruleCheckApp env other _ = ruleCheck env other 1206 1207ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc 1208-- Produce a report for all rules matching the predicate 1209-- saying why it doesn't match the specified application 1210 1211ruleCheckFun env fn args 1212 | null name_match_rules = emptyBag 1213 | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) 1214 where 1215 name_match_rules = filter match (rc_rules env fn) 1216 match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) 1217 1218ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc 1219ruleAppCheck_help env fn args rules 1220 = -- The rules match the pattern, so we want to print something 1221 vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), 1222 vcat (map check_rule rules)] 1223 where 1224 n_args = length args 1225 i_args = args `zip` [1::Int ..] 1226 rough_args = map roughTopName args 1227 1228 check_rule rule = sdocWithDynFlags $ \dflags -> 1229 rule_herald rule <> colon <+> rule_info dflags rule 1230 1231 rule_herald (BuiltinRule { ru_name = name }) 1232 = text "Builtin rule" <+> doubleQuotes (ftext name) 1233 rule_herald (Rule { ru_name = name }) 1234 = text "Rule" <+> doubleQuotes (ftext name) 1235 1236 rule_info dflags rule 1237 | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env) 1238 noBlackList fn args rough_args rule 1239 = text "matches (which is very peculiar!)" 1240 1241 rule_info _ (BuiltinRule {}) = text "does not match" 1242 1243 rule_info _ (Rule { ru_act = act, 1244 ru_bndrs = rule_bndrs, ru_args = rule_args}) 1245 | not (rc_is_active env act) = text "active only in later phase" 1246 | n_args < n_rule_args = text "too few arguments" 1247 | n_mismatches == n_rule_args = text "no arguments match" 1248 | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" 1249 | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" 1250 where 1251 n_rule_args = length rule_args 1252 n_mismatches = length mismatches 1253 mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, 1254 not (isJust (match_fn rule_arg arg))] 1255 1256 lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars 1257 match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg 1258 where 1259 in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) 1260 renv = RV { rv_lcl = mkRnEnv2 in_scope 1261 , rv_tmpls = mkVarSet rule_bndrs 1262 , rv_fltR = mkEmptySubst in_scope 1263 , rv_unf = rc_id_unf env } 1264