compiler/specialise/Rules.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[CoreRules]{Transformation rules}
   5
   6 \begin{code}
   7 module Rules (
   8         RuleBase, emptyRuleBase, mkRuleBase, extendRuleBaseList,
   9         unionRuleBase, pprRuleBase, ruleCheckProgram,
  10
  11         mkSpecInfo, extendSpecInfo, addSpecInfo,
  12         rulesOfBinds, addIdSpecialisations,
  13
  14         lookupRule, mkLocalRule, roughTopNames
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 import CoreSyn          -- All of it
  20 import OccurAnal        ( occurAnalyseExpr )
  21 import CoreFVs          ( exprFreeVars, exprsFreeVars, rulesRhsFreeVars )
  22 import CoreUnfold       ( isCheapUnfolding, unfoldingTemplate )
  23 import CoreUtils        ( tcEqExprX )
  24 import PprCore          ( pprRules )
  25 import Type             ( TvSubstEnv )
  26 import TcType           ( tcSplitTyConApp_maybe )
  27 import CoreTidy         ( tidyRules )
  28 import Id               ( Id, idUnfolding, isLocalId, isGlobalId, idName,
  29                           idSpecialisation, idCoreRules, setIdSpecialisation )
  30 import IdInfo           ( SpecInfo( SpecInfo ) )
  31 import Var              ( Var )
  32 import VarEnv           ( IdEnv, InScopeSet, emptyTidyEnv,
  33                           emptyInScopeSet, mkInScopeSet, extendInScopeSetList,
  34                           emptyVarEnv, lookupVarEnv, extendVarEnv,
  35                           nukeRnEnvL, mkRnEnv2, rnOccR, rnOccL, inRnEnvR,
  36                           rnBndrR, rnBndr2, rnBndrL, rnBndrs2 )
  37 import VarSet
  38 import Name             ( Name, NamedThing(..), nameOccName )
  39 import NameEnv
  40 import Unify            ( ruleMatchTyX, MatchEnv(..) )
  41 import BasicTypes       ( Activation, CompilerPhase, isActive )
  42 import Outputable
  43 import FastString
  44 import Maybes           ( isJust, orElse )
  45 import Bag
  46 import Util             ( singleton )
  47 import List             ( isPrefixOf )
  48 \end{code}
  49
  50
  51 %************************************************************************
  52 %*                                                                      *
  53 \subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
  54 %*                                                                      *
  55 %************************************************************************
  56
  57 A @CoreRule@ holds details of one rule for an @Id@, which
  58 includes its specialisations.
  59
  60 For example, if a rule for @f@ contains the mapping:
  61 \begin{verbatim}
  62         forall a b d. [Type (List a), Type b, Var d]  ===>  f' a b
  63 \end{verbatim}
  64 then when we find an application of f to matching types, we simply replace
  65 it by the matching RHS:
  66 \begin{verbatim}
  67         f (List Int) Bool dict ===>  f' Int Bool
  68 \end{verbatim}
  69 All the stuff about how many dictionaries to discard, and what types
  70 to apply the specialised function to, are handled by the fact that the
  71 Rule contains a template for the result of the specialisation.
  72
  73 There is one more exciting case, which is dealt with in exactly the same
  74 way.  If the specialised value is unboxed then it is lifted at its
  75 definition site and unlifted at its uses.  For example:
  76
  77         pi :: forall a. Num a => a
  78
  79 might have a specialisation
  80
  81         [Int#] ===>  (case pi' of Lift pi# -> pi#)
  82
  83 where pi' :: Lift Int# is the specialised version of pi.
  84
  85 \begin{code}
  86 mkLocalRule :: RuleName -> Activation
  87             -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
  88 -- Used to make CoreRule for an Id defined in this module
  89 mkLocalRule name act fn bndrs args rhs
  90   = Rule { ru_name = name, ru_fn = fn, ru_act = act,
  91            ru_bndrs = bndrs, ru_args = args,
  92            ru_rhs = rhs, ru_rough = roughTopNames args,
  93            ru_orph = Just (nameOccName fn), ru_local = True }
  94
  95 --------------
  96 roughTopNames :: [CoreExpr] -> [Maybe Name]
  97 roughTopNames args = map roughTopName args
  98
  99 roughTopName :: CoreExpr -> Maybe Name
 100 -- Find the "top" free name of an expression
 101 -- a) the function in an App chain (if a GlobalId)
 102 -- b) the TyCon in a type
 103 -- This is used for the fast-match-check for rules;
 104 --      if the top names don't match, the rest can't
 105 roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
 106                           Just (tc,_) -> Just (getName tc)
 107                           Nothing     -> Nothing
 108 roughTopName (App f a) = roughTopName f
 109 roughTopName (Var f) | isGlobalId f = Just (idName f)
 110                      | otherwise    = Nothing
 111 roughTopName other = Nothing
 112
 113 ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
 114 -- (ruleCantMatch tpl actual) returns True only if 'actual'
 115 -- definitely can't match 'tpl' by instantiating 'tpl'.
 116 -- It's only a one-way match; unlike instance matching we
 117 -- don't consider unification
 118 --
 119 -- Notice that there is no case
 120 --      ruleCantMatch (Just n1 : ts) (Nothing : as) = True
 121 -- Reason: a local variable 'v' in the actuals might
 122 --         have an unfolding which is a global.
 123 --         This quite often happens with case scrutinees.
 124 ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as
 125 ruleCantMatch (t       : ts) (a       : as) = ruleCantMatch ts as
 126 ruleCantMatch ts             as             = False
 127 \end{code}
 128
 129
 130 %************************************************************************
 131 %*                                                                      *
 132                 SpecInfo: the rules in an IdInfo
 133 %*                                                                      *
 134 %************************************************************************
 135
 136 \begin{code}
 137 mkSpecInfo :: [CoreRule] -> SpecInfo
 138 mkSpecInfo rules = SpecInfo rules (rulesRhsFreeVars rules)
 139
 140 extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
 141 extendSpecInfo (SpecInfo rs1 fvs1) rs2
 142   = SpecInfo (rs2 ++ rs1) (rulesRhsFreeVars rs2 `unionVarSet` fvs1)
 143
 144 addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
 145 addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2)
 146   = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
 147
 148 addIdSpecialisations :: Id -> [CoreRule] -> Id
 149 addIdSpecialisations id rules
 150   = setIdSpecialisation id $
 151     extendSpecInfo (idSpecialisation id) rules
 152
 153 rulesOfBinds :: [CoreBind] -> [CoreRule]
 154 rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
 155 \end{code}
 156
 157
 158 %************************************************************************
 159 %*                                                                      *
 160                 RuleBase
 161 %*                                                                      *
 162 %************************************************************************
 163
 164 \begin{code}
 165 type RuleBase = NameEnv [CoreRule]
 166         -- Maps (the name of) an Id to its rules
 167         -- The rules are are unordered;
 168         -- we sort out any overlaps on lookup
 169
 170 emptyRuleBase = emptyNameEnv
 171
 172 mkRuleBase :: [CoreRule] -> RuleBase
 173 mkRuleBase rules = extendRuleBaseList emptyRuleBase rules
 174
 175 extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
 176 extendRuleBaseList rule_base new_guys
 177   = foldl extendRuleBase rule_base new_guys
 178
 179 unionRuleBase :: RuleBase -> RuleBase -> RuleBase
 180 unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2
 181
 182 extendRuleBase :: RuleBase -> CoreRule -> RuleBase
 183 extendRuleBase rule_base rule
 184   = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule
 185
 186 pprRuleBase :: RuleBase -> SDoc
 187 pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
 188                          | rs <- nameEnvElts rules ]
 189 \end{code}
 190
 191
 192 %************************************************************************
 193 %*                                                                      *
 194 \subsection{Matching}
 195 %*                                                                      *
 196 %************************************************************************
 197
 198 \begin{code}
 199 lookupRule :: (Activation -> Bool) -> InScopeSet
 200            -> RuleBase  -- Imported rules
 201            -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
 202 lookupRule is_active in_scope rule_base fn args
 203   = matchRules is_active in_scope fn args rules
 204   where
 205         -- The rules for an Id come from two places:
 206         --      (a) the ones it is born with (idCoreRules fn)
 207         --      (b) rules added in subsequent modules (extra_rules)
 208         -- PrimOps, for example, are born with a bunch of rules under (a)
 209     rules = extra_rules ++ idCoreRules fn
 210     extra_rules | isLocalId fn = []
 211                 | otherwise    = lookupNameEnv rule_base (idName fn) `orElse` []
 212
 213 matchRules :: (Activation -> Bool) -> InScopeSet
 214            -> Id -> [CoreExpr]
 215            -> [CoreRule] -> Maybe (RuleName, CoreExpr)
 216 -- See comments on matchRule
 217 matchRules is_active in_scope fn args rules
 218   = case go [] rules of
 219         []     -> Nothing
 220         (m:ms) -> Just (case findBest (fn,args) m ms of
 221                           (rule, ans) -> (ru_name rule, ans))
 222   where
 223     rough_args = map roughTopName args
 224
 225     go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
 226     go ms []           = ms
 227     go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of
 228                         Just e  -> go ((r,e):ms) rs
 229                         Nothing -> go ms         rs
 230
 231 findBest :: (Id, [CoreExpr])
 232          -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
 233 -- All these pairs matched the expression
 234 -- Return the pair the the most specific rule
 235 -- The (fn,args) is just for overlap reporting
 236
 237 findBest target (rule,ans)   [] = (rule,ans)
 238 findBest target (rule1,ans1) ((rule2,ans2):prs)
 239   | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
 240   | rule2 `isMoreSpecific` rule1 = findBest target (rule1,ans1) prs
 241 #ifdef DEBUG
 242   | otherwise = pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
 243                          (vcat [ptext SLIT("Expression to match:") <+> ppr fn <+> sep (map ppr args),
 244                                 ptext SLIT("Rule 1:") <+> ppr rule1,
 245                                 ptext SLIT("Rule 2:") <+> ppr rule2]) $
 246                 findBest target (rule1,ans1) prs
 247 #else
 248   | otherwise = findBest target (rule1,ans1) prs
 249 #endif
 250   where
 251     (fn,args) = target
 252
 253 isMoreSpecific :: CoreRule -> CoreRule -> Bool
 254 isMoreSpecific (BuiltinRule {}) r2 = True
 255 isMoreSpecific r1 (BuiltinRule {}) = False
 256 isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
 257                (Rule { ru_bndrs = bndrs2, ru_args = args2 })
 258   = isJust (matchN in_scope bndrs2 args2 args1)
 259   where
 260    in_scope = mkInScopeSet (mkVarSet bndrs1)
 261         -- Actually we should probably include the free vars
 262         -- of rule1's args, but I can't be bothered
 263
 264 noBlackList :: Activation -> Bool
 265 noBlackList act = False         -- Nothing is black listed
 266
 267 matchRule :: (Activation -> Bool) -> InScopeSet
 268           -> [CoreExpr] -> [Maybe Name]
 269           -> CoreRule -> Maybe CoreExpr
 270
 271 -- If (matchRule rule args) returns Just (name,rhs)
 272 -- then (f args) matches the rule, and the corresponding
 273 -- rewritten RHS is rhs
 274 --
 275 -- The bndrs and rhs is occurrence-analysed
 276 --
 277 --      Example
 278 --
 279 -- The rule
 280 --      forall f g x. map f (map g x) ==> map (f . g) x
 281 -- is stored
 282 --      CoreRule "map/map"
 283 --               [f,g,x]                -- tpl_vars
 284 --               [f,map g x]            -- tpl_args
 285 --               map (f.g) x)           -- rhs
 286 --
 287 -- Then the call: matchRule the_rule [e1,map e2 e3]
 288 --        = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
 289 --
 290 -- Any 'surplus' arguments in the input are simply put on the end
 291 -- of the output.
 292
 293 matchRule is_active in_scope args rough_args
 294           (BuiltinRule { ru_name = name, ru_try = match_fn })
 295   = case match_fn args of
 296         Just expr -> Just expr
 297         Nothing   -> Nothing
 298
 299 matchRule is_active in_scope args rough_args
 300           (Rule { ru_name = rn, ru_act = act, ru_rough = tpl_tops,
 301                   ru_bndrs = tpl_vars, ru_args = tpl_args,
 302                   ru_rhs = rhs })
 303   | not (is_active act)               = Nothing
 304   | ruleCantMatch tpl_tops rough_args = Nothing
 305   | otherwise
 306   = case matchN in_scope tpl_vars tpl_args args of
 307         Nothing                    -> Nothing
 308         Just (tpl_vals, leftovers) -> Just (rule_fn
 309                                             `mkApps` tpl_vals
 310                                             `mkApps` leftovers)
 311   where
 312     rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
 313         -- We could do this when putting things into the rulebase, I guess
 314 \end{code}
 315
 316 \begin{code}
 317 matchN  :: InScopeSet
 318         -> [Var]                -- Template tyvars
 319         -> [CoreExpr]           -- Template
 320         -> [CoreExpr]           -- Target; can have more elts than template
 321         -> Maybe ([CoreExpr],   -- What is substituted for each template var
 322                   [CoreExpr])   -- Leftover target exprs
 323
 324 matchN in_scope tmpl_vars tmpl_es target_es
 325   = do  { (subst, leftover_es) <- go init_menv emptySubstEnv tmpl_es target_es
 326         ; return (map (lookup_tmpl subst) tmpl_vars, leftover_es) }
 327   where
 328     init_menv = ME { me_tmpls = mkVarSet tmpl_vars, me_env = init_rn_env }
 329     init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars)
 330
 331     go menv subst []     es     = Just (subst, es)
 332     go menv subst ts     []     = Nothing       -- Fail if too few actual args
 333     go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
 334                                      ; go menv subst1 ts es }
 335
 336     lookup_tmpl :: (TvSubstEnv, IdSubstEnv) -> Var -> CoreExpr
 337     lookup_tmpl (tv_subst, id_subst) tmpl_var
 338         | isTyVar tmpl_var = case lookupVarEnv tv_subst tmpl_var of
 339                                 Just ty         -> Type ty
 340                                 Nothing         -> unbound tmpl_var
 341         | otherwise        = case lookupVarEnv id_subst tmpl_var of
 342                                 Just e -> e
 343                                 other  -> unbound tmpl_var
 344
 345     unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var)
 346 \end{code}
 347
 348
 349         ---------------------------------------------
 350                 The inner workings of matching
 351         ---------------------------------------------
 352
 353 \begin{code}
 354 -- These two definitions are not the same as in Subst,
 355 -- but they simple and direct, and purely local to this module
 356 -- The third, for TvSubstEnv, is the same as in VarEnv, but repeated here
 357 -- for uniformity with IdSubstEnv
 358 type SubstEnv   = (TvSubstEnv, IdSubstEnv)
 359 type IdSubstEnv = IdEnv    CoreExpr
 360
 361 emptySubstEnv :: SubstEnv
 362 emptySubstEnv = (emptyVarEnv, emptyVarEnv)
 363
 364
 365 --      At one stage I tried to match even if there are more
 366 --      template args than real args.
 367
 368 --      I now think this is probably a bad idea.
 369 --      Should the template (map f xs) match (map g)?  I think not.
 370 --      For a start, in general eta expansion wastes work.
 371 --      SLPJ July 99
 372
 373
 374 match :: MatchEnv
 375       -> SubstEnv
 376       -> CoreExpr               -- Template
 377       -> CoreExpr               -- Target
 378       -> Maybe SubstEnv
 379
 380 -- See the notes with Unify.match, which matches types
 381 -- Everything is very similar for terms
 382
 383 -- Interesting examples:
 384 -- Consider matching
 385 --      \x->f      against    \f->f
 386 -- When we meet the lambdas we must remember to rename f to f' in the
 387 -- second expresion.  The RnEnv2 does that.
 388 --
 389 -- Consider matching
 390 --      forall a. \b->b    against   \a->3
 391 -- We must rename the \a.  Otherwise when we meet the lambdas we
 392 -- might substitute [a/b] in the template, and then erroneously
 393 -- succeed in matching what looks like the template variable 'a' against 3.
 394
 395 -- The Var case follows closely what happens in Unify.match
 396 match menv subst@(tv_subst, id_subst) (Var v1) e2
 397   | v1 `elemVarSet` me_tmpls menv
 398   = case lookupVarEnv id_subst v1' of
 399         Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
 400                 -> Nothing      -- Occurs check failure
 401                 -- e.g. match forall a. (\x-> a x) against (\y. y y)
 402
 403                 | otherwise
 404                 -> Just (tv_subst, extendVarEnv id_subst v1 e2)
 405
 406         Just e2' | tcEqExprX (nukeRnEnvL rn_env) e2' e2
 407                  -> Just subst
 408
 409         other -> Nothing
 410
 411   |     -- v1 is not a template variable; check for an exact match with e2
 412     Var v2 <- e2, v1' == rnOccR rn_env v2
 413   = Just subst
 414
 415   where
 416     rn_env = me_env menv
 417     v1'    = rnOccL rn_env v1
 418
 419 -- Here is another important rule: if the term being matched is a
 420 -- variable, we expand it so long as its unfolding is a WHNF
 421 -- (Its occurrence information is not necessarily up to date,
 422 --  so we don't use it.)
 423 match menv subst e1 (Var v2)
 424   | isCheapUnfolding unfolding
 425   = match menv subst e1 (unfoldingTemplate unfolding)
 426   where
 427     unfolding = idUnfolding v2
 428
 429 match menv subst (Lit lit1) (Lit lit2)
 430   | lit1 == lit2
 431   = Just subst
 432
 433 match menv subst (App f1 a1) (App f2 a2)
 434   = do  { subst' <- match menv subst f1 f2
 435         ; match menv subst' a1 a2 }
 436
 437 match menv subst (Lam x1 e1) (Lam x2 e2)
 438   = match menv' subst e1 e2
 439   where
 440     menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
 441
 442 -- This rule does eta expansion
 443 --              (\x.M)  ~  N    iff     M  ~  N x
 444 match menv subst (Lam x1 e1) e2
 445   = match menv' subst e1 (App e2 (varToCoreExpr new_x))
 446   where
 447     (rn_env', new_x) = rnBndrL (me_env menv) x1
 448     menv' = menv { me_env = rn_env' }
 449
 450 -- Eta expansion the other way
 451 --      M  ~  (\y.N)    iff   M y     ~  N
 452 match menv subst e1 (Lam x2 e2)
 453   = match menv' subst (App e1 (varToCoreExpr new_x)) e2
 454   where
 455     (rn_env', new_x) = rnBndrR (me_env menv) x2
 456     menv' = menv { me_env = rn_env' }
 457
 458 match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
 459   = do  { subst1 <- match_ty menv subst ty1 ty2
 460         ; subst2 <- match menv subst1 e1 e2
 461         ; let menv' = menv { me_env = rnBndr2 (me_env menv) x2 x2 }
 462         ; match_alts menv' subst2 alts1 alts2   -- Alts are both sorted
 463         }
 464
 465 match menv subst (Type ty1) (Type ty2)
 466   = match_ty menv subst ty1 ty2
 467
 468 match menv subst (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
 469   = do  { subst1 <- match_ty menv subst  to1   to2
 470         ; subst2 <- match_ty menv subst1 from1 from2
 471         ; match menv subst2 e1 e2 }
 472
 473 -- This is an interesting rule: we simply ignore lets in the
 474 -- term being matched against!  The unfolding inside it is (by assumption)
 475 -- already inside any occurrences of the bound variables, so we'll expand
 476 -- them when we encounter them.
 477 match menv subst e1 (Let (NonRec x2 r2) e2)
 478   = match menv' subst e1 e2
 479   where
 480     menv' = menv { me_env = fst (rnBndrR (me_env menv) x2) }
 481         -- It's important to do this renaming. For example:
 482         -- Matching
 483         --      forall f,x,xs. f (x:xs)
 484         --   against
 485         --      f (let y = e in (y:[]))
 486         -- We must not get success with x->y!  Instead, we
 487         -- need an occurs check.
 488
 489 -- Everything else fails
 490 match menv subst e1 e2 = Nothing
 491
 492 ------------------------------------------
 493 match_alts :: MatchEnv
 494       -> SubstEnv
 495       -> [CoreAlt]              -- Template
 496       -> [CoreAlt]              -- Target
 497       -> Maybe SubstEnv
 498 match_alts menv subst [] []
 499   = return subst
 500 match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
 501   | c1 == c2
 502   = do  { subst1 <- match menv' subst r1 r2
 503         ; match_alts menv subst1 alts1 alts2 }
 504   where
 505     menv' :: MatchEnv
 506     menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 }
 507
 508 match_alts menv subst alts1 alts2
 509   = Nothing
 510 \end{code}
 511
 512 Matching Core types: use the matcher in TcType.
 513 Notice that we treat newtypes as opaque.  For example, suppose
 514 we have a specialised version of a function at a newtype, say
 515         newtype T = MkT Int
 516 We only want to replace (f T) with f', not (f Int).
 517
 518 \begin{code}
 519 ------------------------------------------
 520 match_ty menv (tv_subst, id_subst) ty1 ty2
 521   = do  { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
 522         ; return (tv_subst', id_subst) }
 523 \end{code}
 524
 525
 526 %************************************************************************
 527 %*                                                                      *
 528 \subsection{Checking a program for failing rule applications}
 529 %*                                                                      *
 530 %************************************************************************
 531
 532 -----------------------------------------------------
 533                         Game plan
 534 -----------------------------------------------------
 535
 536 We want to know what sites have rules that could have fired but didn't.
 537 This pass runs over the tree (without changing it) and reports such.
 538
 539 NB: we assume that this follows a run of the simplifier, so every Id
 540 occurrence (including occurrences of imported Ids) is decorated with
 541 all its (active) rules.  No need to construct a rule base or anything
 542 like that.
 543
 544 \begin{code}
 545 ruleCheckProgram :: CompilerPhase -> String -> [CoreBind] -> SDoc
 546 -- Report partial matches for rules beginning
 547 -- with the specified string
 548 ruleCheckProgram phase rule_pat binds
 549   | isEmptyBag results
 550   = text "Rule check results: no rule application sites"
 551   | otherwise
 552   = vcat [text "Rule check results:",
 553           line,
 554           vcat [ p $$ line | p <- bagToList results ]
 555          ]
 556   where
 557     results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
 558     line = text (replicate 20 '-')
 559
 560 type RuleCheckEnv = (CompilerPhase, String)     -- Phase and Pattern
 561
 562 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
 563    -- The Bag returned has one SDoc for each call site found
 564 ruleCheckBind env (NonRec b r) = ruleCheck env r
 565 ruleCheckBind env (Rec prs)    = unionManyBags [ruleCheck env r | (b,r) <- prs]
 566
 567 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
 568 ruleCheck env (Var v)       = emptyBag
 569 ruleCheck env (Lit l)       = emptyBag
 570 ruleCheck env (Type ty)     = emptyBag
 571 ruleCheck env (App f a)     = ruleCheckApp env (App f a) []
 572 ruleCheck env (Note n e)    = ruleCheck env e
 573 ruleCheck env (Let bd e)    = ruleCheckBind env bd `unionBags` ruleCheck env e
 574 ruleCheck env (Lam b e)     = ruleCheck env e
 575 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
 576                                 unionManyBags [ruleCheck env r | (_,_,r) <- as]
 577
 578 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
 579 ruleCheckApp env (Var f) as   = ruleCheckFun env f as
 580 ruleCheckApp env other as     = ruleCheck env other
 581 \end{code}
 582
 583 \begin{code}
 584 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
 585 -- Produce a report for all rules matching the predicate
 586 -- saying why it doesn't match the specified application
 587
 588 ruleCheckFun (phase, pat) fn args
 589   | null name_match_rules = emptyBag
 590   | otherwise             = unitBag (ruleAppCheck_help phase fn args name_match_rules)
 591   where
 592     name_match_rules = filter match (idCoreRules fn)
 593     match rule = pat `isPrefixOf` unpackFS (ruleName rule)
 594
 595 ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
 596 ruleAppCheck_help phase fn args rules
 597   =     -- The rules match the pattern, so we want to print something
 598     vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
 599           vcat (map check_rule rules)]
 600   where
 601     n_args = length args
 602     i_args = args `zip` [1::Int ..]
 603     rough_args = map roughTopName args
 604
 605     check_rule rule = rule_herald rule <> colon <+> rule_info rule
 606
 607     rule_herald (BuiltinRule { ru_name = name })
 608         = ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name)
 609     rule_herald (Rule { ru_name = name })
 610         = ptext SLIT("Rule") <+> doubleQuotes (ftext name)
 611
 612     rule_info rule
 613         | Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule
 614         = text "matches (which is very peculiar!)"
 615
 616     rule_info (BuiltinRule {}) = text "does not match"
 617
 618     rule_info (Rule { ru_name = name, ru_act = act,
 619                       ru_bndrs = rule_bndrs, ru_args = rule_args})
 620         | not (isActive phase act)    = text "active only in later phase"
 621         | n_args < n_rule_args        = text "too few arguments"
 622         | n_mismatches == n_rule_args = text "no arguments match"
 623         | n_mismatches == 0           = text "all arguments match (considered individually), but rule as a whole does not"
 624         | otherwise                   = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
 625         where
 626           n_rule_args  = length rule_args
 627           n_mismatches = length mismatches
 628           mismatches   = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
 629                               not (isJust (match_fn rule_arg arg))]
 630
 631           lhs_fvs = exprsFreeVars rule_args     -- Includes template tyvars
 632           match_fn rule_arg arg = match menv emptySubstEnv rule_arg arg
 633                 where
 634                   in_scope = lhs_fvs `unionVarSet` exprFreeVars arg
 635                   menv = ME { me_env   = mkRnEnv2 (mkInScopeSet in_scope)
 636                             , me_tmpls = mkVarSet rule_bndrs }
 637 \end{code}
 638