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