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, expandId,
  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 )
  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) -> InScopeSet
 292             -> Id -> [CoreExpr]
 293             -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
 294
 295 -- See Note [Extra args in rule matching]
 296 -- See comments on matchRule
 297 lookupRule is_active in_scope fn args rules
 298   = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
 299     case go [] rules of
 300         []     -> Nothing
 301         (m:ms) -> Just (findBest (fn,args) m ms)
 302   where
 303     rough_args = map roughTopName args
 304
 305     go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
 306     go ms []           = ms
 307     go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of
 308                         Just e  -> go ((r,e):ms) rs
 309                         Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$
 310                                    --   ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] )
 311                                    go ms         rs
 312
 313 findBest :: (Id, [CoreExpr])
 314          -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
 315 -- All these pairs matched the expression
 316 -- Return the pair the the most specific rule
 317 -- The (fn,args) is just for overlap reporting
 318
 319 findBest _      (rule,ans)   [] = (rule,ans)
 320 findBest target (rule1,ans1) ((rule2,ans2):prs)
 321   | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
 322   | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
 323   | debugIsOn = let pp_rule rule
 324                         | opt_PprStyle_Debug = ppr rule
 325                         | otherwise          = doubleQuotes (ftext (ru_name rule))
 326                 in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
 327                          (vcat [if opt_PprStyle_Debug then
 328                                    ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args)
 329                                 else empty,
 330                                 ptext (sLit "Rule 1:") <+> pp_rule rule1,
 331                                 ptext (sLit "Rule 2:") <+> pp_rule rule2]) $
 332                 findBest target (rule1,ans1) prs
 333   | otherwise = findBest target (rule1,ans1) prs
 334   where
 335     (fn,args) = target
 336
 337 isMoreSpecific :: CoreRule -> CoreRule -> Bool
 338 isMoreSpecific (BuiltinRule {}) _ = True
 339 isMoreSpecific _ (BuiltinRule {}) = False
 340 isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
 341                (Rule { ru_bndrs = bndrs2, ru_args = args2 })
 342   = isJust (matchN in_scope bndrs2 args2 args1)
 343   where
 344    in_scope = mkInScopeSet (mkVarSet bndrs1)
 345         -- Actually we should probably include the free vars
 346         -- of rule1's args, but I can't be bothered
 347
 348 noBlackList :: Activation -> Bool
 349 noBlackList _ = False           -- Nothing is black listed
 350
 351 matchRule :: (Activation -> Bool) -> InScopeSet
 352           -> [CoreExpr] -> [Maybe Name]
 353           -> CoreRule -> Maybe CoreExpr
 354
 355 -- If (matchRule rule args) returns Just (name,rhs)
 356 -- then (f args) matches the rule, and the corresponding
 357 -- rewritten RHS is rhs
 358 --
 359 -- The bndrs and rhs is occurrence-analysed
 360 --
 361 --      Example
 362 --
 363 -- The rule
 364 --      forall f g x. map f (map g x) ==> map (f . g) x
 365 -- is stored
 366 --      CoreRule "map/map"
 367 --               [f,g,x]                -- tpl_vars
 368 --               [f,map g x]            -- tpl_args
 369 --               map (f.g) x)           -- rhs
 370 --
 371 -- Then the call: matchRule the_rule [e1,map e2 e3]
 372 --        = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
 373 --
 374 -- Any 'surplus' arguments in the input are simply put on the end
 375 -- of the output.
 376
 377 matchRule _is_active _in_scope args _rough_args
 378           (BuiltinRule { ru_try = match_fn })
 379 -- Built-in rules can't be switched off, it seems
 380   = case match_fn args of
 381         Just expr -> Just expr
 382         Nothing   -> Nothing
 383
 384 matchRule is_active in_scope args rough_args
 385           (Rule { ru_act = act, ru_rough = tpl_tops,
 386                   ru_bndrs = tpl_vars, ru_args = tpl_args,
 387                   ru_rhs = rhs })
 388   | not (is_active act)               = Nothing
 389   | ruleCantMatch tpl_tops rough_args = Nothing
 390   | otherwise
 391   = case matchN in_scope tpl_vars tpl_args args of
 392         Nothing                -> Nothing
 393         Just (binds, tpl_vals) -> Just (mkLets binds $
 394                                         rule_fn `mkApps` tpl_vals)
 395   where
 396     rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
 397         -- We could do this when putting things into the rulebase, I guess
 398 \end{code}
 399
 400 \begin{code}
 401 -- For a given match template and context, find bindings to wrap around
 402 -- the entire result and what should be substituted for each template variable.
 403 -- Fail if there are two few actual arguments from the target to match the template
 404 matchN  :: InScopeSet           -- ^ In-scope variables
 405         -> [Var]                -- ^ Match template type variables
 406         -> [CoreExpr]           -- ^ Match template
 407         -> [CoreExpr]           -- ^ Target; can have more elements than the template
 408         -> Maybe ([CoreBind],
 409                   [CoreExpr])
 410
 411 matchN in_scope tmpl_vars tmpl_es target_es
 412   = do  { (tv_subst, id_subst, binds)
 413                 <- go init_menv emptySubstEnv tmpl_es target_es
 414         ; return (fromOL binds,
 415                   map (lookup_tmpl tv_subst id_subst) tmpl_vars') }
 416   where
 417     (init_rn_env, tmpl_vars') = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars
 418         -- See Note [Template binders]
 419
 420     init_menv = ME { me_tmpls = mkVarSet tmpl_vars', me_env = init_rn_env }
 421
 422     go _    subst []     _      = Just subst
 423     go _    _     _      []     = Nothing       -- Fail if too few actual args
 424     go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
 425                                      ; go menv subst1 ts es }
 426
 427     lookup_tmpl :: TvSubstEnv -> IdSubstEnv -> Var -> CoreExpr
 428     lookup_tmpl tv_subst id_subst tmpl_var'
 429         | isTyVar tmpl_var' = case lookupVarEnv tv_subst tmpl_var' of
 430                                 Just ty         -> Type ty
 431                                 Nothing         -> unbound tmpl_var'
 432         | otherwise         = case lookupVarEnv id_subst tmpl_var' of
 433                                 Just e -> e
 434                                 _      -> unbound tmpl_var'
 435
 436     unbound var = pprPanic "Template variable unbound in rewrite rule"
 437                         (ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es)
 438 \end{code}
 439
 440 Note [Template binders]
 441 ~~~~~~~~~~~~~~~~~~~~~~~
 442 Consider the following match:
 443         Template:  forall x.  f x
 444         Target:     f (x+1)
 445 This should succeed, because the template variable 'x' has
 446 nothing to do with the 'x' in the target.
 447
 448 On reflection, this case probably does just work, but this might not
 449         Template:  forall x. f (\x.x)
 450         Target:    f (\y.y)
 451 Here we want to clone when we find the \x, but to know that x must be in scope
 452
 453 To achive this, we use rnBndrL to rename the template variables if
 454 necessary; the renamed ones are the tmpl_vars'
 455
 456
 457         ---------------------------------------------
 458                 The inner workings of matching
 459         ---------------------------------------------
 460
 461 \begin{code}
 462 -- These two definitions are not the same as in Subst,
 463 -- but they simple and direct, and purely local to this module
 464 --
 465 -- * The domain of the TvSubstEnv and IdSubstEnv are the template
 466 --   variables passed into the match.
 467 --
 468 -- * The (OrdList CoreBind) in a SubstEnv are the bindings floated out
 469 --   from nested matches; see the Let case of match, below
 470 --
 471 type SubstEnv   = (TvSubstEnv, IdSubstEnv, OrdList CoreBind)
 472 type IdSubstEnv = IdEnv CoreExpr
 473
 474 emptySubstEnv :: SubstEnv
 475 emptySubstEnv = (emptyVarEnv, emptyVarEnv, nilOL)
 476
 477
 478 --      At one stage I tried to match even if there are more
 479 --      template args than real args.
 480
 481 --      I now think this is probably a bad idea.
 482 --      Should the template (map f xs) match (map g)?  I think not.
 483 --      For a start, in general eta expansion wastes work.
 484 --      SLPJ July 99
 485
 486
 487 match :: MatchEnv
 488       -> SubstEnv
 489       -> CoreExpr               -- Template
 490       -> CoreExpr               -- Target
 491       -> Maybe SubstEnv
 492
 493 -- See the notes with Unify.match, which matches types
 494 -- Everything is very similar for terms
 495
 496 -- Interesting examples:
 497 -- Consider matching
 498 --      \x->f      against    \f->f
 499 -- When we meet the lambdas we must remember to rename f to f' in the
 500 -- second expresion.  The RnEnv2 does that.
 501 --
 502 -- Consider matching
 503 --      forall a. \b->b    against   \a->3
 504 -- We must rename the \a.  Otherwise when we meet the lambdas we
 505 -- might substitute [a/b] in the template, and then erroneously
 506 -- succeed in matching what looks like the template variable 'a' against 3.
 507
 508 -- The Var case follows closely what happens in Unify.match
 509 match menv subst (Var v1) e2
 510   | Just subst <- match_var menv subst v1 e2
 511   = Just subst
 512
 513 match menv subst (Note _ e1) e2 = match menv subst e1 e2
 514 match menv subst e1 (Note _ e2) = match menv subst e1 e2
 515       -- Ignore notes in both template and thing to be matched
 516       -- See Note [Notes in RULE matching]
 517
 518 match menv subst e1 (Var v2)      -- Note [Expanding variables]
 519   | not (locallyBoundR rn_env v2) -- Note [Do not expand locally-bound variables]
 520   , Just e2' <- expandId v2'
 521   = match (menv { me_env = nukeRnEnvR rn_env }) subst e1 e2'
 522   where
 523     v2'    = lookupRnInScope rn_env v2
 524     rn_env = me_env menv
 525         -- Notice that we look up v2 in the in-scope set
 526         -- See Note [Lookup in-scope]
 527         -- No need to apply any renaming first (hence no rnOccR)
 528         -- becuase of the not-locallyBoundR
 529
 530 match menv (tv_subst, id_subst, binds) e1 (Let bind e2)
 531   | all freshly_bound bndrs     -- See Note [Matching lets]
 532   , not (any (locallyBoundR rn_env) bind_fvs)
 533   = match (menv { me_env = rn_env' })
 534           (tv_subst, id_subst, binds `snocOL` bind')
 535           e1 e2'
 536   where
 537     rn_env   = me_env menv
 538     bndrs    = bindersOf  bind
 539     bind_fvs = varSetElems (bindFreeVars bind)
 540     freshly_bound x = not (x `rnInScope` rn_env)
 541     bind'   = bind
 542     e2'     = e2
 543     rn_env' = extendRnInScopeList rn_env bndrs
 544
 545 match _ subst (Lit lit1) (Lit lit2)
 546   | lit1 == lit2
 547   = Just subst
 548
 549 match menv subst (App f1 a1) (App f2 a2)
 550   = do  { subst' <- match menv subst f1 f2
 551         ; match menv subst' a1 a2 }
 552
 553 match menv subst (Lam x1 e1) (Lam x2 e2)
 554   = match menv' subst e1 e2
 555   where
 556     menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
 557
 558 -- This rule does eta expansion
 559 --              (\x.M)  ~  N    iff     M  ~  N x
 560 -- It's important that this is *after* the let rule,
 561 -- so that      (\x.M)  ~  (let y = e in \y.N)
 562 -- does the let thing, and then gets the lam/lam rule above
 563 match menv subst (Lam x1 e1) e2
 564   = match menv' subst e1 (App e2 (varToCoreExpr new_x))
 565   where
 566     (rn_env', new_x) = rnBndrL (me_env menv) x1
 567     menv' = menv { me_env = rn_env' }
 568
 569 -- Eta expansion the other way
 570 --      M  ~  (\y.N)    iff   M y     ~  N
 571 match menv subst e1 (Lam x2 e2)
 572   = match menv' subst (App e1 (varToCoreExpr new_x)) e2
 573   where
 574     (rn_env', new_x) = rnBndrR (me_env menv) x2
 575     menv' = menv { me_env = rn_env' }
 576
 577 match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
 578   = do  { subst1 <- match_ty menv subst ty1 ty2
 579         ; subst2 <- match menv subst1 e1 e2
 580         ; let menv' = menv { me_env = rnBndr2 (me_env menv) x1 x2 }
 581         ; match_alts menv' subst2 alts1 alts2   -- Alts are both sorted
 582         }
 583
 584 match menv subst (Type ty1) (Type ty2)
 585   = match_ty menv subst ty1 ty2
 586
 587 match menv subst (Cast e1 co1) (Cast e2 co2)
 588   = do  { subst1 <- match_ty menv subst co1 co2
 589         ; match menv subst1 e1 e2 }
 590
 591 -- Everything else fails
 592 match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
 593                          Nothing
 594
 595 ------------------------------------------
 596 match_var :: MatchEnv
 597           -> SubstEnv
 598           -> Var                -- Template
 599           -> CoreExpr           -- Target
 600           -> Maybe SubstEnv
 601 match_var menv subst@(tv_subst, id_subst, binds) v1 e2
 602   | v1' `elemVarSet` me_tmpls menv
 603   = case lookupVarEnv id_subst v1' of
 604         Nothing | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
 605                 -> Nothing      -- Occurs check failure
 606                 -- e.g. match forall a. (\x-> a x) against (\y. y y)
 607
 608                 | otherwise     -- No renaming to do on e2, because no free var
 609                                 -- of e2 is in the rnEnvR of the envt
 610                 -- Note [Matching variable types]
 611                 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 612                 -- However, we must match the *types*; e.g.
 613                 --   forall (c::Char->Int) (x::Char).
 614                 --      f (c x) = "RULE FIRED"
 615                 -- We must only match on args that have the right type
 616                 -- It's actually quite difficult to come up with an example that shows
 617                 -- you need type matching, esp since matching is left-to-right, so type
 618                 -- args get matched first.  But it's possible (e.g. simplrun008) and
 619                 -- this is the Right Thing to do
 620                 -> do   { tv_subst' <- Unify.ruleMatchTyX menv tv_subst (idType v1') (exprType e2)
 621                                                 -- c.f. match_ty below
 622                         ; return (tv_subst', extendVarEnv id_subst v1' e2, binds) }
 623
 624         Just e1' | eqExpr (nukeRnEnvL rn_env) e1' e2
 625                  -> Just subst
 626
 627                  | otherwise
 628                  -> Nothing
 629
 630   | otherwise   -- v1 is not a template variable; check for an exact match with e2
 631   = case e2 of
 632        Var v2 | v1' == rnOccR rn_env v2 -> Just subst
 633        _                                -> Nothing
 634
 635   where
 636     rn_env = me_env menv
 637     v1'    = rnOccL rn_env v1
 638         -- If the template is
 639         --      forall x. f x (\x -> x) = ...
 640         -- Then the x inside the lambda isn't the
 641         -- template x, so we must rename first!
 642
 643
 644 ------------------------------------------
 645 match_alts :: MatchEnv
 646       -> SubstEnv
 647       -> [CoreAlt]              -- Template
 648       -> [CoreAlt]              -- Target
 649       -> Maybe SubstEnv
 650 match_alts _ subst [] []
 651   = return subst
 652 match_alts menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
 653   | c1 == c2
 654   = do  { subst1 <- match menv' subst r1 r2
 655         ; match_alts menv subst1 alts1 alts2 }
 656   where
 657     menv' :: MatchEnv
 658     menv' = menv { me_env = rnBndrs2 (me_env menv) vs1 vs2 }
 659
 660 match_alts _ _ _ _
 661   = Nothing
 662 \end{code}
 663
 664 Matching Core types: use the matcher in TcType.
 665 Notice that we treat newtypes as opaque.  For example, suppose
 666 we have a specialised version of a function at a newtype, say
 667         newtype T = MkT Int
 668 We only want to replace (f T) with f', not (f Int).
 669
 670 \begin{code}
 671 ------------------------------------------
 672 match_ty :: MatchEnv
 673          -> SubstEnv
 674          -> Type                -- Template
 675          -> Type                -- Target
 676          -> Maybe SubstEnv
 677 match_ty menv (tv_subst, id_subst, binds) ty1 ty2
 678   = do  { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
 679         ; return (tv_subst', id_subst, binds) }
 680 \end{code}
 681
 682 Note [Expanding variables]
 683 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 684 Here is another Very Important rule: if the term being matched is a
 685 variable, we expand it so long as its unfolding is "expandable". (Its
 686 occurrence information is not necessarily up to date, so we don't use
 687 it.)  By "expandable" we mean a WHNF or a "constructor-like" application.
 688 This is the key reason for "constructor-like" Ids.  If we have
 689      {-# NOINLINE [1] CONLIKE g #-}
 690      {-# RULE f (g x) = h x #-}
 691 then in the term
 692    let v = g 3 in ....(f v)....
 693 we want to make the rule fire, to replace (f v) with (h 3).
 694
 695 Note [Do not expand locally-bound variables]
 696 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 697 Do *not* expand locally-bound variables, else there's a worry that the
 698 unfolding might mention variables that are themselves renamed.
 699 Example
 700           case x of y { (p,q) -> ...y... }
 701 Don't expand 'y' to (p,q) because p,q might themselves have been
 702 renamed.  Essentially we only expand unfoldings that are "outside"
 703 the entire match.
 704
 705 Hence, (a) the guard (not (isLocallyBoundR v2))
 706        (b) when we expand we nuke the renaming envt (nukeRnEnvR).
 707
 708 Note [Notes in RULE matching]
 709 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 710 Look through Notes in both template and expression being matched.  In
 711 particular, we don't want to be confused by InlineMe notes.  Maybe we
 712 should be more careful about profiling notes, but for now I'm just
 713 riding roughshod over them.  cf Note [Notes in call patterns] in
 714 SpecConstr
 715
 716 Note [Matching lets]
 717 ~~~~~~~~~~~~~~~~~~~~
 718 Matching a let-expression.  Consider
 719         RULE forall x.  f (g x) = <rhs>
 720 and target expression
 721         f (let { w=R } in g E))
 722 Then we'd like the rule to match, to generate
 723         let { w=R } in (\x. <rhs>) E
 724 In effect, we want to float the let-binding outward, to enable
 725 the match to happen.  This is the WHOLE REASON for accumulating
 726 bindings in the SubstEnv
 727
 728 We can only do this if
 729         (a) Widening the scope of w does not capture any variables
 730             We use a conservative test: w is not already in scope
 731             If not, we clone the binders, and substitute
 732         (b) The free variables of R are not bound by the part of the
 733             target expression outside the let binding; e.g.
 734                 f (\v. let w = v+1 in g E)
 735             Here we obviously cannot float the let-binding for w.
 736
 737 You may think rule (a) would never apply, because rule matching is
 738 mostly invoked from the simplifier, when we have just run substExpr
 739 over the argument, so there will be no shadowing anyway.
 740 The fly in the ointment is that the forall'd variables of the
 741 RULE itself are considered in scope.
 742
 743 I though of various ways to solve (a).  One plan was to
 744 clone the binders if they are in scope.  But watch out!
 745         (let x=y+1 in let z=x+1 in (z,z)
 746                 --> should match (p,p) but watch out that
 747                     the use of x on z's rhs is OK!
 748 If we clone x, then the let-binding for 'z' is then caught by (b),
 749 at least unless we elaborate the RnEnv stuff a bit.
 750
 751 So for we simply fail to match unless both (a) and (b) hold.
 752
 753 Other cases to think about
 754         (let x=y+1 in \x. (x,x))
 755                 --> let x=y+1 in (\x1. (x1,x1))
 756         (\x. let x = y+1 in (x,x))
 757                 --> let x1 = y+1 in (\x. (x1,x1)
 758         (let x=y+1 in (x,x), let x=y-1 in (x,x))
 759                 --> let x=y+1 in let x1=y-1 in ((x,x),(x1,x1))
 760
 761
 762 Note [Lookup in-scope]
 763 ~~~~~~~~~~~~~~~~~~~~~~
 764 Consider this example
 765         foo :: Int -> Maybe Int -> Int
 766         foo 0 (Just n) = n
 767         foo m (Just n) = foo (m-n) (Just n)
 768
 769 SpecConstr sees this fragment:
 770
 771         case w_smT of wild_Xf [Just A] {
 772           Data.Maybe.Nothing -> lvl_smf;
 773           Data.Maybe.Just n_acT [Just S(L)] ->
 774             case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->
 775             \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
 776             }};
 777
 778 and correctly generates the rule
 779
 780         RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#
 781                                           sc_snn :: GHC.Prim.Int#}
 782           \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
 783           = \$s\$wfoo_sno y_amr sc_snn ;]
 784
 785 BUT we must ensure that this rule matches in the original function!
 786 Note that the call to \$wfoo is
 787             \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
 788
 789 During matching we expand wild_Xf to (Just n_acT).  But then we must also
 790 expand n_acT to (I# y_amr).  And we can only do that if we look up n_acT
 791 in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding
 792 at all.
 793
 794 That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
 795 is so important.
 796
 797 \begin{code}
 798 eqExpr :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
 799 -- ^ A kind of shallow equality used in rule matching, so does
 800 -- /not/ look through newtypes or predicate types
 801
 802 eqExpr env (Var v1) (Var v2)
 803   | rnOccL env v1 == rnOccR env v2
 804   = True
 805
 806 -- The next two rules expand non-local variables
 807 -- C.f. Note [Expanding variables]
 808 -- and  Note [Do not expand locally-bound variables]
 809 eqExpr env (Var v1) e2
 810   | not (locallyBoundL env v1)
 811   , Just e1' <- expandId (lookupRnInScope env v1)
 812   = eqExpr (nukeRnEnvL env) e1' e2
 813
 814 eqExpr env e1 (Var v2)
 815   | not (locallyBoundR env v2)
 816   , Just e2' <- expandId (lookupRnInScope env v2)
 817   = eqExpr (nukeRnEnvR env) e1 e2'
 818
 819 eqExpr _   (Lit lit1)    (Lit lit2)    = lit1 == lit2
 820 eqExpr env (App f1 a1)   (App f2 a2)   = eqExpr env f1 f2 && eqExpr env a1 a2
 821 eqExpr env (Lam v1 e1)   (Lam v2 e2)   = eqExpr (rnBndr2 env v1 v2) e1 e2
 822 eqExpr env (Note n1 e1)  (Note n2 e2)  = eq_note env n1 n2 && eqExpr env e1 e2
 823 eqExpr env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && eqExpr env e1 e2
 824 eqExpr env (Type t1)     (Type t2)     = tcEqTypeX env t1 t2
 825
 826 eqExpr env (Let (NonRec v1 r1) e1)
 827            (Let (NonRec v2 r2) e2) =  eqExpr env r1 r2
 828                                    && eqExpr (rnBndr2 env v1 v2) e1 e2
 829 eqExpr env (Let (Rec ps1) e1)
 830            (Let (Rec ps2) e2)      =  equalLength ps1 ps2
 831                                    && and (zipWith eq_rhs ps1 ps2)
 832                                    && eqExpr env' e1 e2
 833                                    where
 834                                       env' = foldl2 rn_bndr2 env ps2 ps2
 835                                       rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
 836                                       eq_rhs       (_,r1) (_,r2) = eqExpr env' r1 r2
 837 eqExpr env (Case e1 v1 t1 a1)
 838            (Case e2 v2 t2 a2) =  eqExpr env e1 e2
 839                               && tcEqTypeX env t1 t2
 840                               && equalLength a1 a2
 841                               && and (zipWith (eq_alt env') a1 a2)
 842                               where
 843                                 env' = rnBndr2 env v1 v2
 844
 845 eqExpr _   _             _             = False
 846
 847 eq_alt :: RnEnv2 -> CoreAlt -> CoreAlt -> Bool
 848 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && eqExpr (rnBndrs2 env vs1  vs2) r1 r2
 849
 850 eq_note :: RnEnv2 -> Note -> Note -> Bool
 851 eq_note _ (SCC cc1)     (SCC cc2)      = cc1 == cc2
 852 eq_note _ (CoreNote s1) (CoreNote s2)  = s1 == s2
 853 eq_note _ _             _              = False
 854 \end{code}
 855
 856 Auxiliary functions
 857
 858 \begin{code}
 859 locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool
 860 locallyBoundL rn_env v = inRnEnvL rn_env v
 861 locallyBoundR rn_env v = inRnEnvR rn_env v
 862
 863
 864 expandId :: Id -> Maybe CoreExpr
 865 expandId id
 866   | isExpandableUnfolding unfolding = Just (unfoldingTemplate unfolding)
 867   | otherwise                       = Nothing
 868   where
 869     unfolding = idUnfolding id
 870 \end{code}
 871
 872 %************************************************************************
 873 %*                                                                      *
 874                    Rule-check the program
 875 %*                                                                      *
 876 %************************************************************************
 877
 878    We want to know what sites have rules that could have fired but didn't.
 879    This pass runs over the tree (without changing it) and reports such.
 880
 881 \begin{code}
 882 -- | Report partial matches for rules beginning with the specified
 883 -- string for the purposes of error reporting
 884 ruleCheckProgram :: (Activation -> Bool)    -- ^ Rule activation test
 885                  -> String                      -- ^ Rule pattern
 886                  -> RuleBase                    -- ^ Database of rules
 887                  -> [CoreBind]                  -- ^ Bindings to check in
 888                  -> SDoc                        -- ^ Resulting check message
 889 ruleCheckProgram is_active rule_pat rule_base binds
 890   | isEmptyBag results
 891   = text "Rule check results: no rule application sites"
 892   | otherwise
 893   = vcat [text "Rule check results:",
 894           line,
 895           vcat [ p $$ line | p <- bagToList results ]
 896          ]
 897   where
 898     results = unionManyBags (map (ruleCheckBind (RuleCheckEnv is_active rule_pat rule_base)) binds)
 899     line = text (replicate 20 '-')
 900
 901 data RuleCheckEnv = RuleCheckEnv {
 902     rc_is_active :: Activation -> Bool,
 903     rc_pattern :: String,
 904     rc_rule_base :: RuleBase
 905 }
 906
 907 ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
 908    -- The Bag returned has one SDoc for each call site found
 909 ruleCheckBind env (NonRec _ r) = ruleCheck env r
 910 ruleCheckBind env (Rec prs)    = unionManyBags [ruleCheck env r | (_,r) <- prs]
 911
 912 ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
 913 ruleCheck _   (Var _)       = emptyBag
 914 ruleCheck _   (Lit _)       = emptyBag
 915 ruleCheck _   (Type _)      = emptyBag
 916 ruleCheck env (App f a)     = ruleCheckApp env (App f a) []
 917 ruleCheck env (Note _ e)    = ruleCheck env e
 918 ruleCheck env (Cast e _)    = ruleCheck env e
 919 ruleCheck env (Let bd e)    = ruleCheckBind env bd `unionBags` ruleCheck env e
 920 ruleCheck env (Lam _ e)     = ruleCheck env e
 921 ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
 922                                 unionManyBags [ruleCheck env r | (_,_,r) <- as]
 923
 924 ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc
 925 ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
 926 ruleCheckApp env (Var f) as   = ruleCheckFun env f as
 927 ruleCheckApp env other _      = ruleCheck env other
 928 \end{code}
 929
 930 \begin{code}
 931 ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
 932 -- Produce a report for all rules matching the predicate
 933 -- saying why it doesn't match the specified application
 934
 935 ruleCheckFun env fn args
 936   | null name_match_rules = emptyBag
 937   | otherwise             = unitBag (ruleAppCheck_help (rc_is_active env) fn args name_match_rules)
 938   where
 939     name_match_rules = filter match (getRules (rc_rule_base env) fn)
 940     match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
 941
 942 ruleAppCheck_help :: (Activation -> Bool) -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
 943 ruleAppCheck_help is_active fn args rules
 944   =     -- The rules match the pattern, so we want to print something
 945     vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
 946           vcat (map check_rule rules)]
 947   where
 948     n_args = length args
 949     i_args = args `zip` [1::Int ..]
 950     rough_args = map roughTopName args
 951
 952     check_rule rule = rule_herald rule <> colon <+> rule_info rule
 953
 954     rule_herald (BuiltinRule { ru_name = name })
 955         = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name)
 956     rule_herald (Rule { ru_name = name })
 957         = ptext (sLit "Rule") <+> doubleQuotes (ftext name)
 958
 959     rule_info rule
 960         | Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule
 961         = text "matches (which is very peculiar!)"
 962
 963     rule_info (BuiltinRule {}) = text "does not match"
 964
 965     rule_info (Rule { ru_act = act,
 966                       ru_bndrs = rule_bndrs, ru_args = rule_args})
 967         | not (is_active act)    = text "active only in later phase"
 968         | n_args < n_rule_args        = text "too few arguments"
 969         | n_mismatches == n_rule_args = text "no arguments match"
 970         | n_mismatches == 0           = text "all arguments match (considered individually), but rule as a whole does not"
 971         | otherwise                   = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
 972         where
 973           n_rule_args  = length rule_args
 974           n_mismatches = length mismatches
 975           mismatches   = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
 976                               not (isJust (match_fn rule_arg arg))]
 977
 978           lhs_fvs = exprsFreeVars rule_args     -- Includes template tyvars
 979           match_fn rule_arg arg = match menv emptySubstEnv rule_arg arg
 980                 where
 981                   in_scope = lhs_fvs `unionVarSet` exprFreeVars arg
 982                   menv = ME { me_env   = mkRnEnv2 (mkInScopeSet in_scope)
 983                             , me_tmpls = mkVarSet rule_bndrs }
 984 \end{code}
 985