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