Rules.hs 48.4 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

4
\section[CoreRules]{Transformation rules}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

7 8
{-# LANGUAGE CPP #-}

batterseapower's avatar
batterseapower committed
9 10
-- | Functions for collecting together and applying rewrite rules to a module.
-- The 'CoreRule' datatype itself is declared elsewhere.
11
module Rules (
12 13 14 15 16 17
        -- ** Constructing
        emptyRuleBase, mkRuleBase, extendRuleBaseList,
        unionRuleBase, pprRuleBase,

        -- ** Checking rule applications
        ruleCheckProgram,
18

19 20
        -- ** Manipulating 'RuleInfo' rules
        mkRuleInfo, extendRuleInfo, addRuleInfo,
21 22 23 24 25
        addIdSpecialisations,

        -- * Misc. CoreRule helpers
        rulesOfBinds, getRules, pprRulesForUser,

26
        lookupRule, mkRule, roughTopNames
27 28 29 30
    ) where

#include "HsVersions.h"

31
import CoreSyn          -- All of it
32
import Module           ( Module, ModuleSet, elemModuleSet )
33
import CoreSubst
34
import CoreOpt          ( exprIsLambda_maybe )
35
import CoreFVs          ( exprFreeVars, exprsFreeVars, bindFreeVars
niteria's avatar
niteria committed
36
                        , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )
Peter Wortmann's avatar
Peter Wortmann committed
37
import CoreUtils        ( exprType, eqExpr, mkTick, mkTicks,
lukemaurer's avatar
lukemaurer committed
38 39
                          stripTicksTopT, stripTicksTopE,
                          isJoinBind )
40
import PprCore          ( pprRules )
41
import Type             ( Type, substTy, mkTCvSubst )
42
import TcType           ( tcSplitTyConApp_maybe )
Ben Gamari's avatar
Ben Gamari committed
43
import TysWiredIn       ( anyTypeOfKind )
44
import Coercion
45
import CoreTidy         ( tidyRules )
46
import Id
47
import IdInfo           ( RuleInfo( RuleInfo ) )
48
import Var
49
import VarEnv
50
import VarSet
51
import Name             ( Name, NamedThing(..), nameIsLocalOrFrom )
52
import NameSet
53
import NameEnv
54
import UniqFM
Richard Eisenberg's avatar
Richard Eisenberg committed
55
import Unify            ( ruleMatchTyKiX )
56
import BasicTypes       ( Activation, CompilerPhase, isActive, pprRuleName )
57
import DynFlags         ( DynFlags )
58
import Outputable
59
import FastString
60
import Maybes
61
import Bag
62
import Util
63
import Data.List
64
import Data.Ord
65
import Control.Monad    ( guard )
66

Austin Seipp's avatar
Austin Seipp committed
67
{-
68 69
Note [Overall plumbing for rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
70 71
* After the desugarer:
   - The ModGuts initially contains mg_rules :: [CoreRule] of
72
     locally-declared rules for imported Ids.
73 74 75
   - Locally-declared rules for locally-declared Ids are attached to
     the IdInfo for that Id.  See Note [Attach rules to local ids] in
     DsBinds
76

77 78
* TidyPgm strips off all the rules from local Ids and adds them to
  mg_rules, so that the ModGuts has *all* the locally-declared rules.
79 80 81 82 83 84 85 86 87 88 89 90 91

* The HomePackageTable contains a ModDetails for each home package
  module.  Each contains md_rules :: [CoreRule] of rules declared in
  that module.  The HomePackageTable grows as ghc --make does its
  up-sweep.  In batch mode (ghc -c), the HPT is empty; all imported modules
  are treated by the "external" route, discussed next, regardless of
  which package they come from.

* The ExternalPackageState has a single eps_rule_base :: RuleBase for
  Ids in other packages.  This RuleBase simply grow monotonically, as
  ghc --make compiles one module after another.

  During simplification, interface files may get demand-loaded,
92
  as the simplifier explores the unfoldings for Ids it has in
93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
  its hand.  (Via an unsafePerformIO; the EPS is really a cache.)
  That in turn may make the EPS rule-base grow.  In contrast, the
  HPT never grows in this way.

* The result of all this is that during Core-to-Core optimisation
  there are four sources of rules:

    (a) Rules in the IdInfo of the Id they are a rule for.  These are
        easy: fast to look up, and if you apply a substitution then
        it'll be applied to the IdInfo as a matter of course.

    (b) Rules declared in this module for imported Ids, kept in the
        ModGuts. If you do a substitution, you'd better apply the
        substitution to these.  There are seldom many of these.

    (c) Rules declared in the HomePackageTable.  These never change.

    (d) Rules in the ExternalPackageTable. These can grow in response
        to lazy demand-loading of interfaces.

* At the moment (c) is carried in a reader-monad way by the CoreMonad.
  The HomePackageTable doesn't have a single RuleBase because technically
  we should only be able to "see" rules "below" this module; so we
  generate a RuleBase for (c) by combing rules from all the modules
117
  "below" us.  That's why we can't just select the home-package RuleBase
118 119 120
  from HscEnv.

  [NB: we are inconsistent here.  We should do the same for external
Gabor Greif's avatar
Gabor Greif committed
121
  packages, but we don't.  Same for type-class instances.]
122 123

* So in the outer simplifier loop, we combine (b-d) into a single
124 125
  RuleBase, reading
     (b) from the ModGuts,
126 127 128 129 130 131 132
     (c) from the CoreMonad, and
     (d) from its mutable variable
  [Of coures this means that we won't see new EPS rules that come in
  during a single simplifier iteration, but that probably does not
  matter.]


Austin Seipp's avatar
Austin Seipp committed
133 134
************************************************************************
*                                                                      *
135
\subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
Austin Seipp's avatar
Austin Seipp committed
136 137
*                                                                      *
************************************************************************
138 139 140 141 142 143

A @CoreRule@ holds details of one rule for an @Id@, which
includes its specialisations.

For example, if a rule for @f@ contains the mapping:
\begin{verbatim}
144
        forall a b d. [Type (List a), Type b, Var d]  ===>  f' a b
145 146 147 148
\end{verbatim}
then when we find an application of f to matching types, we simply replace
it by the matching RHS:
\begin{verbatim}
149
        f (List Int) Bool dict ===>  f' Int Bool
150 151 152 153 154 155 156 157 158
\end{verbatim}
All the stuff about how many dictionaries to discard, and what types
to apply the specialised function to, are handled by the fact that the
Rule contains a template for the result of the specialisation.

There is one more exciting case, which is dealt with in exactly the same
way.  If the specialised value is unboxed then it is lifted at its
definition site and unlifted at its uses.  For example:

159
        pi :: forall a. Num a => a
160 161 162

might have a specialisation

163
        [Int#] ===>  (case pi' of Lift pi# -> pi#)
164 165

where pi' :: Lift Int# is the specialised version of pi.
Austin Seipp's avatar
Austin Seipp committed
166
-}
167

168
mkRule :: Module -> Bool -> Bool -> RuleName -> Activation
169
       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
170
-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
171
-- compiled. See also 'CoreSyn.CoreRule'
172
mkRule this_mod is_auto is_local name act fn bndrs args rhs
173
  = Rule { ru_name = name, ru_fn = fn, ru_act = act,
174
           ru_bndrs = bndrs, ru_args = args,
175
           ru_rhs = rhs,
176
           ru_rough = roughTopNames args,
177 178
           ru_origin = this_mod,
           ru_orphan = orph,
179
           ru_auto = is_auto, ru_local = is_local }
180 181 182 183
  where
        -- Compute orphanhood.  See Note [Orphans] in InstEnv
        -- A rule is an orphan only if none of the variables
        -- mentioned on its left-hand side are locally defined
184
    lhs_names = extendNameSet (exprsOrphNames args) fn
185

186 187 188 189
        -- Since rules get eventually attached to one of the free names
        -- from the definition when compiling the ABI hash, we should make
        -- it deterministic. This chooses the one with minimal OccName
        -- as opposed to uniq value.
190
    local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names
191
    orph = chooseOrphanAnchor local_lhs_names
192 193 194

--------------
roughTopNames :: [CoreExpr] -> [Maybe Name]
195
-- ^ Find the \"top\" free names of several expressions.
batterseapower's avatar
batterseapower committed
196 197 198 199 200 201 202
-- Such names are either:
--
-- 1. The function finally being applied to in an application chain
--    (if that name is a GlobalId: see "Var#globalvslocal"), or
--
-- 2. The 'TyCon' if the expression is a 'Type'
--
203 204
-- This is used for the fast-match-check for rules;
--      if the top names don't match, the rest can't
205 206 207 208
roughTopNames args = map roughTopName args

roughTopName :: CoreExpr -> Maybe Name
roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
209 210
                               Just (tc,_) -> Just (getName tc)
                               Nothing     -> Nothing
211
roughTopName (Coercion _) = Nothing
Ian Lynagh's avatar
Ian Lynagh committed
212
roughTopName (App f _) = roughTopName f
213
roughTopName (Var f)   | isGlobalId f   -- Note [Care with roughTopName]
214 215
                       , isDataConWorkId f || idArity f > 0
                       = Just (idName f)
Peter Wortmann's avatar
Peter Wortmann committed
216 217
roughTopName (Tick t e) | tickishFloatable t
                        = roughTopName e
Ian Lynagh's avatar
Ian Lynagh committed
218
roughTopName _ = Nothing
219 220

ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
batterseapower's avatar
batterseapower committed
221
-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@
222 223
-- definitely can't match @tpl@ by instantiating @tpl@.
-- It's only a one-way match; unlike instance matching we
batterseapower's avatar
batterseapower committed
224
-- don't consider unification.
225
--
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
226
-- Notice that [_$_]
227
--      @ruleCantMatch [Nothing] [Just n2] = False@
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
228 229
--      Reason: a template variable can be instantiated by a constant
-- Also:
230
--      @ruleCantMatch [Just n1] [Nothing] = False@
batterseapower's avatar
batterseapower committed
231
--      Reason: a local variable @v@ in the actuals might [_$_]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
232

233
ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as
Ian Lynagh's avatar
Ian Lynagh committed
234
ruleCantMatch (_       : ts) (_       : as) = ruleCantMatch ts as
235
ruleCantMatch _              _              = False
236

Austin Seipp's avatar
Austin Seipp committed
237
{-
238 239 240 241 242 243
Note [Care with roughTopName]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
    module M where { x = a:b }
    module N where { ...f x...
                     RULE f (p:q) = ... }
244
You'd expect the rule to match, because the matcher can
245 246 247 248 249
look through the unfolding of 'x'.  So we must avoid roughTopName
returning 'M.x' for the call (f x), or else it'll say "can't match"
and we won't even try!!

However, suppose we have
250 251
         RULE g (M.h x) = ...
         foo = ...(g (M.k v))....
252 253 254
where k is a *function* exported by M.  We never really match
functions (lambdas) except by name, so in this case it seems like
a good idea to treat 'M.k' as a roughTopName of the call.
Austin Seipp's avatar
Austin Seipp committed
255
-}
256

Sylvain Henry's avatar
Sylvain Henry committed
257
pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc
258 259 260 261 262
-- (a) tidy the rules
-- (b) sort them into order based on the rule name
-- (c) suppress uniques (unless -dppr-debug is on)
-- This combination makes the output stable so we can use in testing
-- It's here rather than in PprCore because it calls tidyRules
Sylvain Henry's avatar
Sylvain Henry committed
263 264
pprRulesForUser dflags rules
  = withPprStyle (defaultUserStyle dflags) $
265
    pprRules $
266
    sortBy (comparing ruleName) $
267
    tidyRules emptyTidyEnv rules
268

Austin Seipp's avatar
Austin Seipp committed
269 270 271
{-
************************************************************************
*                                                                      *
272
                RuleInfo: the rules in an IdInfo
Austin Seipp's avatar
Austin Seipp committed
273 274 275
*                                                                      *
************************************************************************
-}
276

277
-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable
batterseapower's avatar
batterseapower committed
278
-- for putting into an 'IdInfo'
279
mkRuleInfo :: [CoreRule] -> RuleInfo
280
mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules)
281

282 283
extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo
extendRuleInfo (RuleInfo rs1 fvs1) rs2
284
  = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1)
285

286 287
addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo
addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2)
288
  = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2)
289 290

addIdSpecialisations :: Id -> [CoreRule] -> Id
291 292
addIdSpecialisations id []
  = id
293 294
addIdSpecialisations id rules
  = setIdSpecialisation id $
295
    extendRuleInfo (idSpecialisation id) rules
296

batterseapower's avatar
batterseapower committed
297
-- | Gather all the rules for locally bound identifiers from the supplied bindings
298 299
rulesOfBinds :: [CoreBind] -> [CoreRule]
rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
300

301
getRules :: RuleEnv -> Id -> [CoreRule]
302
-- See Note [Where rules are found]
303 304
getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn
  = idCoreRules fn ++ filter (ruleIsVisible orphs) imp_rules
305 306
  where
    imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []
307

308 309 310 311 312
ruleIsVisible :: ModuleSet -> CoreRule -> Bool
ruleIsVisible _ BuiltinRule{} = True
ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin }
    = notOrphan orph || origin `elemModuleSet` vis_orphs

Austin Seipp's avatar
Austin Seipp committed
313
{-
314 315 316 317 318 319
Note [Where rules are found]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The rules for an Id come from two places:
  (a) the ones it is born with, stored inside the Id iself (idCoreRules fn),
  (b) rules added in other modules, stored in the global RuleBase (imp_rules)

320
It's tempting to think that
321 322 323 324 325 326 327 328 329
     - LocalIds have only (a)
     - non-LocalIds have only (b)

but that isn't quite right:

     - PrimOps and ClassOps are born with a bunch of rules inside the Id,
       even when they are imported

     - The rules in PrelRules.builtinRules should be active even
330
       in the module defining the Id (when it's a LocalId), but
331 332
       the rules are kept in the global RuleBase

333

Austin Seipp's avatar
Austin Seipp committed
334 335
************************************************************************
*                                                                      *
336
                RuleBase
Austin Seipp's avatar
Austin Seipp committed
337 338 339
*                                                                      *
************************************************************************
-}
340

341
-- RuleBase itself is defined in CoreSyn, along with CoreRule
342

Ian Lynagh's avatar
Ian Lynagh committed
343
emptyRuleBase :: RuleBase
344 345 346 347 348 349 350 351 352 353 354 355 356 357
emptyRuleBase = emptyNameEnv

mkRuleBase :: [CoreRule] -> RuleBase
mkRuleBase rules = extendRuleBaseList emptyRuleBase rules

extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList rule_base new_guys
  = foldl extendRuleBase rule_base new_guys

unionRuleBase :: RuleBase -> RuleBase -> RuleBase
unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2

extendRuleBase :: RuleBase -> CoreRule -> RuleBase
extendRuleBase rule_base rule
358
  = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule
359 360

pprRuleBase :: RuleBase -> SDoc
361 362 363
pprRuleBase rules = pprUFM rules $ \rss ->
  vcat [ pprRules (tidyRules emptyTidyEnv rs)
       | rs <- rss ]
364

Austin Seipp's avatar
Austin Seipp committed
365 366 367
{-
************************************************************************
*                                                                      *
368
                        Matching
Austin Seipp's avatar
Austin Seipp committed
369 370 371
*                                                                      *
************************************************************************
-}
372

373 374 375 376
-- | The main rule matching function. Attempts to apply all (active)
-- supplied rules to this instance of an application in a given
-- context, returning the rule applied and the resulting expression if
-- successful.
377 378 379 380
lookupRule :: DynFlags -> InScopeEnv
           -> (Activation -> Bool)      -- When rule is active
           -> Id -> [CoreExpr]
           -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
381 382

-- See Note [Extra args in rule matching]
383
-- See comments on matchRule
384
lookupRule dflags in_scope is_active fn args rules
385
  = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
386
    case go [] rules of
387
        []     -> Nothing
Peter Wortmann's avatar
Peter Wortmann committed
388
        (m:ms) -> Just (findBest (fn,args') m ms)
389 390 391
  where
    rough_args = map roughTopName args

Peter Wortmann's avatar
Peter Wortmann committed
392 393 394 395 396 397
    -- Strip ticks from arguments, see note [Tick annotations in RULE
    -- matching]. We only collect ticks if a rule actually matches -
    -- this matters for performance tests.
    args' = map (stripTicksTopE tickishFloatable) args
    ticks = concatMap (stripTicksTopT tickishFloatable) args

398
    go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
Peter Wortmann's avatar
Peter Wortmann committed
399 400 401 402 403 404 405 406 407 408 409
    go ms [] = ms
    go ms (r:rs)
      | Just e <- matchRule dflags in_scope is_active fn args' rough_args r
      = go ((r,mkTicks ticks e):ms) rs
      | otherwise
      = -- pprTrace "match failed" (ppr r $$ ppr args $$
        --   ppr [ (arg_id, unfoldingTemplate unf)
        --       | Var arg_id <- args
        --       , let unf = idUnfolding arg_id
        --       , isCheapUnfolding unf] )
        go ms rs
410 411

findBest :: (Id, [CoreExpr])
412
         -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
413 414 415 416
-- All these pairs matched the expression
-- Return the pair the the most specific rule
-- The (fn,args) is just for overlap reporting

Ian Lynagh's avatar
Ian Lynagh committed
417
findBest _      (rule,ans)   [] = (rule,ans)
418 419
findBest target (rule1,ans1) ((rule2,ans2):prs)
  | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
420
  | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
Sylvain Henry's avatar
Sylvain Henry committed
421 422
  | debugIsOn = let pp_rule rule = sdocWithPprDebug $ \dbg -> if dbg
                        then ppr rule
423
                        else doubleQuotes (ftext (ruleName rule))
424
                in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
Sylvain Henry's avatar
Sylvain Henry committed
425 426 427 428 429 430
                         (vcat [ sdocWithPprDebug $ \dbg -> if dbg
                                   then text "Expression to match:" <+> ppr fn
                                        <+> sep (map ppr args)
                                   else empty
                               , text "Rule 1:" <+> pp_rule rule1
                               , text "Rule 2:" <+> pp_rule rule2]) $
431
                findBest target (rule1,ans1) prs
432
  | otherwise = findBest target (rule1,ans1) prs
433 434 435 436
  where
    (fn,args) = target

isMoreSpecific :: CoreRule -> CoreRule -> Bool
437 438 439 440 441
-- This tests if one rule is more specific than another
-- We take the view that a BuiltinRule is less specific than
-- anything else, because we want user-define rules to "win"
-- In particular, class ops have a built-in rule, but we
-- any user-specific rules to win
442
--   eg (Trac #4397)
443 444 445 446 447 448
--      truncate :: (RealFrac a, Integral b) => a -> b
--      {-# RULES "truncate/Double->Int" truncate = double2Int #-}
--      double2Int :: Double -> Int
--   We want the specific RULE to beat the built-in class-op rule
isMoreSpecific (BuiltinRule {}) _                = False
isMoreSpecific (Rule {})        (BuiltinRule {}) = True
449
isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
450 451
               (Rule { ru_bndrs = bndrs2, ru_args = args2, ru_name = rule_name2 })
  = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1)
452
  where
453
   id_unfolding_fun _ = NoUnfolding     -- Don't expand in templates
454
   in_scope = mkInScopeSet (mkVarSet bndrs1)
455 456
        -- Actually we should probably include the free vars
        -- of rule1's args, but I can't be bothered
457

458
noBlackList :: Activation -> Bool
459
noBlackList _ = False           -- Nothing is black listed
460

Austin Seipp's avatar
Austin Seipp committed
461
{-
462 463
Note [Extra args in rule matching]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
464
If we find a matching rule, we return (Just (rule, rhs)),
465 466 467
but the rule firing has only consumed as many of the input args
as the ruleArity says.  It's up to the caller to keep track
of any left-over args.  E.g. if you call
468
        lookupRule ... f [e1, e2, e3]
469 470
and it returns Just (r, rhs), where r has ruleArity 2
then the real rewrite is
471
        f e1 e2 e3 ==> rhs e3
472 473 474 475 476

You might think it'd be cleaner for lookupRule to deal with the
leftover arguments, by applying 'rhs' to them, but the main call
in the Simplifier works better as it is.  Reason: the 'args' passed
to lookupRule are the result of a lazy substitution
Austin Seipp's avatar
Austin Seipp committed
477
-}
478

479
------------------------------------
480 481
matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool)
          -> Id -> [CoreExpr] -> [Maybe Name]
482
          -> CoreRule -> Maybe CoreExpr
483

484
-- If (matchRule rule args) returns Just (name,rhs)
485
-- then (f args) matches the rule, and the corresponding
486
-- rewritten RHS is rhs
487
--
488
-- The returned expression is occurrence-analysed
489
--
490
--      Example
491 492
--
-- The rule
493
--      forall f g x. map f (map g x) ==> map (f . g) x
494
-- is stored
495 496 497 498 499
--      CoreRule "map/map"
--               [f,g,x]                -- tpl_vars
--               [f,map g x]            -- tpl_args
--               map (f.g) x)           -- rhs
--
500
-- Then the call: matchRule the_rule [e1,map e2 e3]
501
--        = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
502 503 504 505
--
-- Any 'surplus' arguments in the input are simply put on the end
-- of the output.

506
matchRule dflags rule_env _is_active fn args _rough_args
507
          (BuiltinRule { ru_try = match_fn })
508
-- Built-in rules can't be switched off, it seems
509
  = case match_fn dflags rule_env fn args of
510
        Nothing   -> Nothing
511
        Just expr -> Just expr
512

513
matchRule _ in_scope is_active _ args rough_args
514 515
          (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops
                , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs })
516
  | not (is_active act)               = Nothing
517
  | ruleCantMatch tpl_tops rough_args = Nothing
518
  | otherwise
519
  = case matchN in_scope rule_name tpl_vars tpl_args args of
520 521 522
        Nothing                        -> Nothing
        Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $
                                               rule_fn `mkApps` tpl_vals)
523
  where
524
    rule_fn = mkLams tpl_vars rhs
525

526
---------------------------------------
527
matchN  :: InScopeEnv
528
        -> RuleName -> [Var] -> [CoreExpr]
529 530 531 532
        -> [CoreExpr]           -- ^ Target; can have more elements than the template
        -> Maybe (BindWrapper,  -- Floated bindings; see Note [Matching lets]
                  [CoreExpr])
-- For a given match template and context, find bindings to wrap around
533 534
-- the entire result and what should be substituted for each template variable.
-- Fail if there are two few actual arguments from the target to match the template
535

536
matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es
537
  = do  { subst <- go init_menv emptyRuleSubst tmpl_es target_es
538 539
        ; let (_, matched_es) = mapAccumL lookup_tmpl subst tmpl_vars
        ; return (rs_binds subst, matched_es) }
540
  where
541 542
    init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars)
                  -- See Note [Template binders]
543

544
    init_menv = RV { rv_tmpls = mkVarSet tmpl_vars, rv_lcl = init_rn_env
545 546
                   , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env)
                   , rv_unf = id_unf }
547 548 549

    go _    subst []     _      = Just subst
    go _    _     _      []     = Nothing       -- Fail if too few actual args
550
    go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
551
                                     ; go menv subst1 ts es }
552

553 554 555 556 557
    lookup_tmpl :: RuleSubst -> Var -> (RuleSubst, CoreExpr)
    lookup_tmpl rs@(RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tmpl_var
        | isId tmpl_var
        = case lookupVarEnv id_subst tmpl_var of
             Just e -> (rs, e)
558 559 560 561 562
             Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var
                     , let co_expr = Coercion refl_co
                     -> (rs { rs_id_subst = extendVarEnv id_subst tmpl_var co_expr }, co_expr)
                     | otherwise
                     -> unbound tmpl_var
563 564 565 566
        | otherwise
        = case lookupVarEnv tv_subst tmpl_var of
             Just ty -> (rs, Type ty)
             Nothing -> (rs { rs_tv_subst = extendVarEnv tv_subst tmpl_var fake_ty }, Type fake_ty)
567
                        -- See Note [Unbound RULE binders]
568 569
        where
          fake_ty = anyTypeOfKind kind
570 571 572 573
          cv_subst = to_co_env id_subst
          kind = Type.substTy (mkTCvSubst in_scope (tv_subst, cv_subst))
                              (tyVarKind tmpl_var)

niteria's avatar
niteria committed
574 575 576
          to_co_env env = nonDetFoldUFM_Directly to_co emptyVarEnv env
            -- It's OK to use nonDetFoldUFM_Directly because we forget the
            -- order immediately by creating a new env
577 578 579 580 581 582
          to_co uniq expr env
            | Just co <- exprToCoercion_maybe expr
            = extendVarEnv_Directly env uniq co

            | otherwise
            = env
583 584

    unbound var = pprPanic "Template variable unbound in rewrite rule" $
585 586 587 588 589
                  vcat [ text "Variable:" <+> ppr var
                       , text "Rule" <+> pprRuleName rule_name
                       , text "Rule bndrs:" <+> ppr tmpl_vars
                       , text "LHS args:" <+> ppr tmpl_es
                       , text "Actual args:" <+> ppr target_es ]
590

591 592 593 594 595 596 597 598
{- Note [Unbound RULE binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It can be the case that the binder in a rule is not actually
bound on the LHS:

* Type variables.  Type synonyms with phantom args can give rise to
  unbound template type variables.  Consider this (Trac #10689,
  simplCore/should_compile/T10689):
599 600 601 602 603 604 605 606 607

    type Foo a b = b

    f :: Eq a => a -> Bool
    f x = x==x

    {-# RULES "foo" forall (x :: Foo a Char). f x = True #-}
    finkle = f 'c'

608 609
  The rule looks like
    forall (a::*) (d::Eq Char) (x :: Foo a Char).
610 611
         f (Foo a Char) d x = True

612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632
  Matching the rule won't bind 'a', and legitimately so.  We fudge by
  pretending that 'a' is bound to (Any :: *).

* Coercion variables.  On the LHS of a RULE for a local binder
  we might have
    RULE forall (c :: a~b). f (x |> c) = e
  Now, if that binding is inlined, so that a=b=Int, we'd get
    RULE forall (c :: Int~Int). f (x |> c) = e
  and now when we simpilfy the LHS (Simplify.simplRule) we
  optCoercion will turn that 'c' into Refl:
    RULE forall (c :: Int~Int). f (x |> <Int>) = e
  and then perhaps drop it altogether.  Now 'c' is unbound.

  It's tricky to be sure this never happens, so instead I
  say it's OK to have an unbound coercion binder in a RULE
  provided its type is (c :: t~t).  Then, when the RULE
  fires we can substitute <t> for c.

  This actually happened (in a RULE for a local function)
  in Trac #13410, and also in test T10602.

633

634 635
Note [Template binders]
~~~~~~~~~~~~~~~~~~~~~~~
636
Consider the following match (example 1):
637
        Template:  forall x.  f x
638 639 640
        Target:               f (x+1)
This should succeed, because the template variable 'x' has nothing to
do with the 'x' in the target.
641

642
Likewise this one (example 2):
643
        Template:  forall x. f (\x.x)
644 645 646 647 648 649 650 651 652 653
        Target:              f (\y.y)

We achieve this simply by:
  * Adding forall'd template binders to the in-scope set

This works even if the template binder are already in scope
(in the target) because

  * The RuleSubst rs_tv_subst, rs_id_subst maps LHS template vars to
    the target world.  It is not applied recursively.
654

655 656 657 658 659 660
  * Having the template vars in the in-scope set ensures that in
    example 2 above, the (\x.x) is cloned to (\x'. x').

In the past we used rnBndrL to clone the template variables if
they were already in scope.  But (a) that's not necessary and (b)
it complicate the fancy footwork for Note [Unbound template type variables]
661

662

Austin Seipp's avatar
Austin Seipp committed
663 664
************************************************************************
*                                                                      *
665
                   The main matcher
Austin Seipp's avatar
Austin Seipp committed
666
*                                                                      *
667
********************************************************************* -}
668

669 670 671
-- * The domain of the TvSubstEnv and IdSubstEnv are the template
--   variables passed into the match.
--
672
-- * The BindWrapper in a RuleSubst are the bindings floated out
673 674
--   from nested matches; see the Let case of match, below
--
Austin Seipp's avatar
Austin Seipp committed
675
data RuleMatchEnv
676 677 678 679 680 681 682 683
  = RV { rv_tmpls :: VarSet          -- Template variables
       , rv_lcl   :: RnEnv2          -- Renamings for *local bindings*
                                     --   (lambda/case)
       , rv_fltR  :: Subst           -- Renamings for floated let-bindings
                                     --   domain disjoint from envR of rv_lcl
                                     -- See Note [Matching lets]
       , rv_unf :: IdUnfoldingFun
       }
684

685 686 687
rvInScopeEnv :: RuleMatchEnv -> InScopeEnv
rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv)

688 689 690 691 692 693
data RuleSubst = RS { rs_tv_subst :: TvSubstEnv   -- Range is the
                    , rs_id_subst :: IdSubstEnv   --   template variables
                    , rs_binds    :: BindWrapper  -- Floated bindings
                    , rs_bndrs    :: VarSet       -- Variables bound by floated lets
                    }

694 695 696 697
type BindWrapper = CoreExpr -> CoreExpr
  -- See Notes [Matching lets] and [Matching cases]
  -- we represent the floated bindings as a core-to-core function

698 699 700
emptyRuleSubst :: RuleSubst
emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv
                    , rs_binds = \e -> e, rs_bndrs = emptyVarSet }
701

702 703
--      At one stage I tried to match even if there are more
--      template args than real args.
704

705 706 707 708
--      I now think this is probably a bad idea.
--      Should the template (map f xs) match (map g)?  I think not.
--      For a start, in general eta expansion wastes work.
--      SLPJ July 99
709 710


711
match :: RuleMatchEnv
712
      -> RuleSubst
713 714
      -> CoreExpr               -- Template
      -> CoreExpr               -- Target
715
      -> Maybe RuleSubst
716

Peter Wortmann's avatar
Peter Wortmann committed
717 718 719 720 721 722 723 724
-- We look through certain ticks. See note [Tick annotations in RULE matching]
match renv subst e1 (Tick t e2)
  | tickishFloatable t
  = match renv subst' e1 e2
  where subst' = subst { rs_binds = rs_binds subst . mkTick t }
match _ _ e@Tick{} _
  = pprPanic "Tick in rule" (ppr e)

725 726
-- See the notes with Unify.match, which matches types
-- Everything is very similar for terms
727

728 729
-- Interesting examples:
-- Consider matching
730
--      \x->f      against    \f->f
731
-- When we meet the lambdas we must remember to rename f to f' in the
Gabor Greif's avatar
Gabor Greif committed
732
-- second expression.  The RnEnv2 does that.
733
--
734 735 736 737
-- Consider matching
--      forall a. \b->b    against   \a->3
-- We must rename the \a.  Otherwise when we meet the lambdas we
-- might substitute [a/b] in the template, and then erroneously
738 739 740
-- succeed in matching what looks like the template variable 'a' against 3.

-- The Var case follows closely what happens in Unify.match
741
match renv subst (Var v1)    e2 = match_var renv subst v1 e2
742

743
match renv subst e1 (Var v2)      -- Note [Expanding variables]
744
  | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables]
745 746
  , Just e2' <- expandUnfolding_maybe (rv_unf renv v2')
  = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2'
747
  where
748
    v2'    = lookupRnInScope rn_env v2
749
    rn_env = rv_lcl renv
750 751 752 753
        -- Notice that we look up v2 in the in-scope set
        -- See Note [Lookup in-scope]
        -- No need to apply any renaming first (hence no rnOccR)
        -- because of the not-inRnEnvR
754

755
match renv subst e1 (Let bind e2)
756
  | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $
lukemaurer's avatar
lukemaurer committed
757 758
    not (isJoinBind bind) -- can't float join point out of argument position
  , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets]
759 760 761
  = match (renv { rv_fltR = flt_subst' })
          (subst { rs_binds = rs_binds subst . Let bind'
                 , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs })
762
          e1 e2
763
  where
764 765 766
    flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst)
    (flt_subst', bind') = substBind flt_subst bind
    new_bndrs = bindersOf bind'
767 768

{- Disabled: see Note [Matching cases] below
769
match renv (tv_subst, id_subst, binds) e1
770
      (Case scrut case_bndr ty [(con, alt_bndrs, rhs)])
771
  | exprOkForSpeculation scrut  -- See Note [Matching cases]
772
  , okToFloat rn_env bndrs (exprFreeVars scrut)
773
  = match (renv { me_env = rn_env' })
774
          (tv_subst, id_subst, binds . case_wrap)
775
          e1 rhs
776
  where
777
    rn_env   = me_env renv
778 779 780 781
    rn_env'  = extendRnInScopeList rn_env bndrs
    bndrs    = case_bndr : alt_bndrs
    case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')]
-}
782

783
match _ subst (Lit lit1) (Lit lit2)
784
  | lit1 == lit2
785
  = Just subst
786

787
match renv subst (App f1 a1) (App f2 a2)
788 789
  = do  { subst' <- match renv subst f1 f2
        ; match renv subst' a1 a2 }
790

791
match renv subst (Lam x1 e1) e2
Peter Wortmann's avatar
Peter Wortmann committed
792
  | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2
793 794
  = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2
                     , rv_fltR = delBndr (rv_fltR renv) x2 }
Peter Wortmann's avatar
Peter Wortmann committed
795 796
        subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts }
    in  match renv' subst' e1 e2
797

798
match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
799 800
  = do  { subst1 <- match_ty renv subst ty1 ty2
        ; subst2 <- match renv subst1 e1 e2
801 802
        ; let renv' = rnMatchBndr2 renv subst x1 x2
        ; match_alts renv' subst2 alts1 alts2   -- Alts are both sorted
803
        }
804

805 806
match renv subst (Type ty1) (Type ty2)
  = match_ty renv subst ty1 ty2
807 808
match renv subst (Coercion co1) (Coercion co2)
  = match_co renv subst co1 co2
809

810
match renv subst (Cast e1 co1) (Cast e2 co2)
811 812
  = do  { subst1 <- match_co renv subst co1 co2
        ; match renv subst1 e1 e2 }
813

814
-- Everything else fails
815 816 817
match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
                    Nothing

818
-------------
819
match_co :: RuleMatchEnv
820 821 822 823
         -> RuleSubst
         -> Coercion
         -> Coercion
         -> Maybe RuleSubst
824 825 826 827 828 829 830 831 832 833 834 835 836 837
match_co renv subst co1 co2
  | Just cv <- getCoVar_maybe co1
  = match_var renv subst cv (Coercion co2)
  | Just (ty1, r1) <- isReflCo_maybe co1
  = do { (ty2, r2) <- isReflCo_maybe co2
       ; guard (r1 == r2)
       ; match_ty renv subst ty1 ty2 }
match_co renv subst co1 co2
  | Just (tc1, cos1) <- splitTyConAppCo_maybe co1
  = case splitTyConAppCo_maybe co2 of
      Just (tc2, cos2)
        |  tc1 == tc2
        -> match_cos renv subst cos1 cos2
      _ -> Nothing
Ben Gamari's avatar
Ben Gamari committed
838 839 840 841 842 843
match_co renv subst co1 co2
  | Just (arg1, res1) <- splitFunCo_maybe co1
  = case splitFunCo_maybe co2 of
      Just (arg2, res2)
        -> match_cos renv subst [arg1, res1] [arg2, res2]
      _ -> Nothing
844
match_co _ _ _co1 _co2
845
    -- Currently just deals with CoVarCo, TyConAppCo and Refl
Ben Gamari's avatar
Ben Gamari committed
846
#if defined(DEBUG)
847 848 849 850
  = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing
#else
  = Nothing
#endif
851 852 853 854 855 856 857

match_cos :: RuleMatchEnv
         -> RuleSubst
         -> [Coercion]
         -> [Coercion]
         -> Maybe RuleSubst
match_cos renv subst (co1:cos1) (co2:cos2) =
858 859
  do { subst' <- match_co renv subst co1 co2
     ; match_cos renv subst' cos1 cos2 }
860 861 862
match_cos _ subst [] [] = Just subst
match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing

863
-------------
864
rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv
865 866 867 868 869 870 871 872 873
rnMatchBndr2 renv subst x1 x2
  = renv { rv_lcl  = rnBndr2 rn_env x1 x2
         , rv_fltR = delBndr (rv_fltR renv) x2 }
  where
    rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst)
    -- Typically this is a no-op, but it may matter if
    -- there are some floated let-bindings

------------------------------------------
874
match_alts :: RuleMatchEnv
875 876 877 878
           -> RuleSubst
           -> [CoreAlt]         -- Template
           -> [CoreAlt]         -- Target
           -> Maybe RuleSubst
879 880 881 882 883 884 885 886 887 888 889 890
match_alts _ subst [] []
  = return subst
match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
  | c1 == c2
  = do  { subst1 <- match renv' subst r1 r2
        ; match_alts renv subst1 alts1 alts2 }
  where
    renv' = foldl mb renv (vs1 `zip` vs2)
    mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2

match_alts _ _ _ _
  = Nothing
891

892
------------------------------------------
893 894
okToFloat :: RnEnv2 -> VarSet -> Bool
okToFloat rn_env bind_fvs
895
  = allVarSet not_captured bind_fvs
896 897 898
  where
    not_captured fv = not (inRnEnvR rn_env fv)

899
------------------------------------------
900
match_var :: RuleMatchEnv
901 902 903 904
          -> RuleSubst
          -> Var                -- Template
          -> CoreExpr        -- Target
          -> Maybe RuleSubst
905 906 907 908 909 910 911 912 913 914