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