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