compiler: de-lhs specialise/

Signed-off-by: Austin Seipp <austin@well-typed.com>

1 files changed, 1125 insertions, 0 deletions

diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs
new file mode 100644
index 0000000000..a768896763
--- /dev/null
+++ b/compiler/specialise/Rules.hs
@@ -0,0 +1,1125 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[CoreRules]{Transformation rules}
+-}
+
+{-# LANGUAGE CPP #-}
+
+-- | Functions for collecting together and applying rewrite rules to a module.
+-- The 'CoreRule' datatype itself is declared elsewhere.
+module Rules (
+        -- * RuleBase
+        RuleBase,
+
+        -- ** Constructing
+        emptyRuleBase, mkRuleBase, extendRuleBaseList,
+        unionRuleBase, pprRuleBase,
+
+        -- ** Checking rule applications
+        ruleCheckProgram,
+
+        -- ** Manipulating 'SpecInfo' rules
+        mkSpecInfo, extendSpecInfo, addSpecInfo,
+        addIdSpecialisations,
+
+        -- * Misc. CoreRule helpers
+        rulesOfBinds, getRules, pprRulesForUser,
+
+        lookupRule, mkRule, roughTopNames
+    ) where
+
+#include "HsVersions.h"
+
+import CoreSyn          -- All of it
+import CoreSubst
+import OccurAnal        ( occurAnalyseExpr )
+import CoreFVs          ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )
+import CoreUtils        ( exprType, eqExpr )
+import PprCore          ( pprRules )
+import Type             ( Type )
+import TcType           ( tcSplitTyConApp_maybe )
+import Coercion
+import CoreTidy         ( tidyRules )
+import Id
+import IdInfo           ( SpecInfo( SpecInfo ) )
+import VarEnv
+import VarSet
+import Name             ( Name, NamedThing(..) )
+import NameEnv
+import Unify            ( ruleMatchTyX, MatchEnv(..) )
+import BasicTypes       ( Activation, CompilerPhase, isActive )
+import StaticFlags      ( opt_PprStyle_Debug )
+import DynFlags         ( DynFlags )
+import Outputable
+import FastString
+import Maybes
+import Bag
+import Util
+import Data.List
+import Data.Ord
+
+{-
+Note [Overall plumbing for rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* After the desugarer:
+   - The ModGuts initially contains mg_rules :: [CoreRule] of
+     locally-declared rules for imported Ids.
+   - Locally-declared rules for locally-declared Ids are attached to
+     the IdInfo for that Id.  See Note [Attach rules to local ids] in
+     DsBinds
+
+* 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.
+
+* 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,
+  as the simplifier explores the unfoldings for Ids it has in
+  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
+  "below" us.  That's why we can't just select the home-package RuleBase
+  from HscEnv.
+
+  [NB: we are inconsistent here.  We should do the same for external
+  packages, but we don't.  Same for type-class instances.]
+
+* So in the outer simplifier loop, we combine (b-d) into a single
+  RuleBase, reading
+     (b) from the ModGuts,
+     (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.]
+
+
+************************************************************************
+*                                                                      *
+\subsection[specialisation-IdInfo]{Specialisation info about an @Id@}
+*                                                                      *
+************************************************************************
+
+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}
+        forall a b d. [Type (List a), Type b, Var d]  ===>  f' a b
+\end{verbatim}
+then when we find an application of f to matching types, we simply replace
+it by the matching RHS:
+\begin{verbatim}
+        f (List Int) Bool dict ===>  f' Int Bool
+\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:
+
+        pi :: forall a. Num a => a
+
+might have a specialisation
+
+        [Int#] ===>  (case pi' of Lift pi# -> pi#)
+
+where pi' :: Lift Int# is the specialised version of pi.
+-}
+
+mkRule :: Bool -> Bool -> RuleName -> Activation
+       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
+-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
+-- compiled. See also 'CoreSyn.CoreRule'
+mkRule is_auto is_local name act fn bndrs args rhs
+  = Rule { ru_name = name, ru_fn = fn, ru_act = act,
+           ru_bndrs = bndrs, ru_args = args,
+           ru_rhs = occurAnalyseExpr rhs,
+           ru_rough = roughTopNames args,
+           ru_auto = is_auto, ru_local = is_local }
+
+--------------
+roughTopNames :: [CoreExpr] -> [Maybe Name]
+-- ^ Find the \"top\" free names of several expressions.
+-- 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'
+--
+-- This is used for the fast-match-check for rules;
+--      if the top names don't match, the rest can't
+roughTopNames args = map roughTopName args
+
+roughTopName :: CoreExpr -> Maybe Name
+roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
+                               Just (tc,_) -> Just (getName tc)
+                               Nothing     -> Nothing
+roughTopName (Coercion _) = Nothing
+roughTopName (App f _) = roughTopName f
+roughTopName (Var f)   | isGlobalId f   -- Note [Care with roughTopName]
+                       , isDataConWorkId f || idArity f > 0
+                       = Just (idName f)
+roughTopName _ = Nothing
+
+ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
+-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@
+-- definitely can't match @tpl@ by instantiating @tpl@.
+-- It's only a one-way match; unlike instance matching we
+-- don't consider unification.
+--
+-- Notice that [_$_]
+--      @ruleCantMatch [Nothing] [Just n2] = False@
+--      Reason: a template variable can be instantiated by a constant
+-- Also:
+--      @ruleCantMatch [Just n1] [Nothing] = False@
+--      Reason: a local variable @v@ in the actuals might [_$_]
+
+ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as
+ruleCantMatch (_       : ts) (_       : as) = ruleCantMatch ts as
+ruleCantMatch _              _              = False
+
+{-
+Note [Care with roughTopName]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+    module M where { x = a:b }
+    module N where { ...f x...
+                     RULE f (p:q) = ... }
+You'd expect the rule to match, because the matcher can
+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
+         RULE g (M.h x) = ...
+         foo = ...(g (M.k v))....
+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.
+-}
+
+pprRulesForUser :: [CoreRule] -> SDoc
+-- (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
+pprRulesForUser rules
+  = withPprStyle defaultUserStyle $
+    pprRules $
+    sortBy (comparing ru_name) $
+    tidyRules emptyTidyEnv rules
+
+{-
+************************************************************************
+*                                                                      *
+                SpecInfo: the rules in an IdInfo
+*                                                                      *
+************************************************************************
+-}
+
+-- | Make a 'SpecInfo' containing a number of 'CoreRule's, suitable
+-- for putting into an 'IdInfo'
+mkSpecInfo :: [CoreRule] -> SpecInfo
+mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules)
+
+extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
+extendSpecInfo (SpecInfo rs1 fvs1) rs2
+  = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
+
+addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
+addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2)
+  = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
+
+addIdSpecialisations :: Id -> [CoreRule] -> Id
+addIdSpecialisations id []
+  = id
+addIdSpecialisations id rules
+  = setIdSpecialisation id $
+    extendSpecInfo (idSpecialisation id) rules
+
+-- | Gather all the rules for locally bound identifiers from the supplied bindings
+rulesOfBinds :: [CoreBind] -> [CoreRule]
+rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
+
+getRules :: RuleBase -> Id -> [CoreRule]
+-- See Note [Where rules are found]
+getRules rule_base fn
+  = idCoreRules fn ++ imp_rules
+  where
+    imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []
+
+{-
+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)
+
+It's tempting to think that
+     - 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
+       in the module defining the Id (when it's a LocalId), but
+       the rules are kept in the global RuleBase
+
+
+************************************************************************
+*                                                                      *
+                RuleBase
+*                                                                      *
+************************************************************************
+-}
+
+-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules
+type RuleBase = NameEnv [CoreRule]
+        -- The rules are are unordered;
+        -- we sort out any overlaps on lookup
+
+emptyRuleBase :: RuleBase
+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
+  = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule
+
+pprRuleBase :: RuleBase -> SDoc
+pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs)
+                         | rs <- nameEnvElts rules ]
+
+{-
+************************************************************************
+*                                                                      *
+                        Matching
+*                                                                      *
+************************************************************************
+-}
+
+-- | 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.
+lookupRule :: DynFlags -> InScopeEnv
+           -> (Activation -> Bool)      -- When rule is active
+           -> Id -> [CoreExpr]
+           -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
+
+-- See Note [Extra args in rule matching]
+-- See comments on matchRule
+lookupRule dflags in_scope is_active fn args rules
+  = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
+    case go [] rules of
+        []     -> Nothing
+        (m:ms) -> Just (findBest (fn,args) m ms)
+  where
+    rough_args = map roughTopName args
+
+    go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
+    go ms []           = ms
+    go ms (r:rs) = case (matchRule dflags in_scope is_active fn args rough_args r) of
+                        Just e  -> go ((r,e):ms) rs
+                        Nothing -> -- 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
+
+findBest :: (Id, [CoreExpr])
+         -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
+-- All these pairs matched the expression
+-- Return the pair the the most specific rule
+-- The (fn,args) is just for overlap reporting
+
+findBest _      (rule,ans)   [] = (rule,ans)
+findBest target (rule1,ans1) ((rule2,ans2):prs)
+  | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
+  | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
+  | debugIsOn = let pp_rule rule
+                        | opt_PprStyle_Debug = ppr rule
+                        | otherwise          = doubleQuotes (ftext (ru_name rule))
+                in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"
+                         (vcat [if opt_PprStyle_Debug then
+                                   ptext (sLit "Expression to match:") <+> ppr fn <+> sep (map ppr args)
+                                else empty,
+                                ptext (sLit "Rule 1:") <+> pp_rule rule1,
+                                ptext (sLit "Rule 2:") <+> pp_rule rule2]) $
+                findBest target (rule1,ans1) prs
+  | otherwise = findBest target (rule1,ans1) prs
+  where
+    (fn,args) = target
+
+isMoreSpecific :: CoreRule -> CoreRule -> Bool
+-- 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
+--   eg (Trac #4397)
+--      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
+isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
+               (Rule { ru_bndrs = bndrs2, ru_args = args2 })
+  = isJust (matchN (in_scope, id_unfolding_fun) bndrs2 args2 args1)
+  where
+   id_unfolding_fun _ = NoUnfolding     -- Don't expand in templates
+   in_scope = mkInScopeSet (mkVarSet bndrs1)
+        -- Actually we should probably include the free vars
+        -- of rule1's args, but I can't be bothered
+
+noBlackList :: Activation -> Bool
+noBlackList _ = False           -- Nothing is black listed
+
+{-
+Note [Extra args in rule matching]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we find a matching rule, we return (Just (rule, rhs)),
+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
+        lookupRule ... f [e1, e2, e3]
+and it returns Just (r, rhs), where r has ruleArity 2
+then the real rewrite is
+        f e1 e2 e3 ==> rhs e3
+
+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
+-}
+
+------------------------------------
+matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool)
+          -> Id -> [CoreExpr] -> [Maybe Name]
+          -> CoreRule -> Maybe CoreExpr
+
+-- If (matchRule rule args) returns Just (name,rhs)
+-- then (f args) matches the rule, and the corresponding
+-- rewritten RHS is rhs
+--
+-- The bndrs and rhs is occurrence-analysed
+--
+--      Example
+--
+-- The rule
+--      forall f g x. map f (map g x) ==> map (f . g) x
+-- is stored
+--      CoreRule "map/map"
+--               [f,g,x]                -- tpl_vars
+--               [f,map g x]            -- tpl_args
+--               map (f.g) x)           -- rhs
+--
+-- Then the call: matchRule the_rule [e1,map e2 e3]
+--        = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
+--
+-- Any 'surplus' arguments in the input are simply put on the end
+-- of the output.
+
+matchRule dflags rule_env _is_active fn args _rough_args
+          (BuiltinRule { ru_try = match_fn })
+-- Built-in rules can't be switched off, it seems
+  = case match_fn dflags rule_env fn args of
+        Just expr -> Just expr
+        Nothing   -> Nothing
+
+matchRule _ in_scope is_active _ args rough_args
+          (Rule { ru_act = act, ru_rough = tpl_tops
+                , ru_bndrs = tpl_vars, ru_args = tpl_args
+                , ru_rhs = rhs })
+  | not (is_active act)               = Nothing
+  | ruleCantMatch tpl_tops rough_args = Nothing
+  | otherwise
+  = case matchN in_scope tpl_vars tpl_args args of
+        Nothing                        -> Nothing
+        Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $
+                                               rule_fn `mkApps` tpl_vals)
+  where
+    rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
+        -- We could do this when putting things into the rulebase, I guess
+
+---------------------------------------
+matchN  :: InScopeEnv
+        -> [Var]                -- ^ Match template type variables
+        -> [CoreExpr]           -- ^ Match template
+        -> [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
+-- 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
+
+matchN (in_scope, id_unf) tmpl_vars tmpl_es target_es
+  = do  { subst <- go init_menv emptyRuleSubst tmpl_es target_es
+        ; return (rs_binds subst,
+                  map (lookup_tmpl subst) tmpl_vars') }
+  where
+    (init_rn_env, tmpl_vars') = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars
+        -- See Note [Template binders]
+
+    init_menv = RV { rv_tmpls = mkVarSet tmpl_vars', rv_lcl = init_rn_env
+                   , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env)
+                   , rv_unf = id_unf }
+
+    go _    subst []     _      = Just subst
+    go _    _     _      []     = Nothing       -- Fail if too few actual args
+    go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
+                                     ; go menv subst1 ts es }
+
+    lookup_tmpl :: RuleSubst -> Var -> CoreExpr
+    lookup_tmpl (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 -> e
+                             _      -> unbound tmpl_var'
+        | otherwise      = case lookupVarEnv tv_subst tmpl_var' of
+                             Just ty -> Type ty
+                             Nothing -> unbound tmpl_var'
+
+    unbound var = pprPanic "Template variable unbound in rewrite rule"
+                        (ppr var $$ ppr tmpl_vars $$ ppr tmpl_vars' $$ ppr tmpl_es $$ ppr target_es)
+
+{-
+Note [Template binders]
+~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following match:
+        Template:  forall x.  f x
+        Target:     f (x+1)
+This should succeed, because the template variable 'x' has
+nothing to do with the 'x' in the target.
+
+On reflection, this case probably does just work, but this might not
+        Template:  forall x. f (\x.x)
+        Target:    f (\y.y)
+Here we want to clone when we find the \x, but to know that x must be in scope
+
+To achive this, we use rnBndrL to rename the template variables if
+necessary; the renamed ones are the tmpl_vars'
+
+
+************************************************************************
+*                                                                      *
+                   The main matcher
+*                                                                      *
+************************************************************************
+
+        ---------------------------------------------
+                The inner workings of matching
+        ---------------------------------------------
+-}
+
+-- * The domain of the TvSubstEnv and IdSubstEnv are the template
+--   variables passed into the match.
+--
+-- * The BindWrapper in a RuleSubst are the bindings floated out
+--   from nested matches; see the Let case of match, below
+--
+data RuleMatchEnv
+  = 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
+       }
+
+rvInScopeEnv :: RuleMatchEnv -> InScopeEnv
+rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv)
+
+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
+                    }
+
+type BindWrapper = CoreExpr -> CoreExpr
+  -- See Notes [Matching lets] and [Matching cases]
+  -- we represent the floated bindings as a core-to-core function
+
+emptyRuleSubst :: RuleSubst
+emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv
+                    , rs_binds = \e -> e, rs_bndrs = emptyVarSet }
+
+--      At one stage I tried to match even if there are more
+--      template args than real args.
+
+--      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
+
+
+match :: RuleMatchEnv
+      -> RuleSubst
+      -> CoreExpr               -- Template
+      -> CoreExpr               -- Target
+      -> Maybe RuleSubst
+
+-- See the notes with Unify.match, which matches types
+-- Everything is very similar for terms
+
+-- Interesting examples:
+-- Consider matching
+--      \x->f      against    \f->f
+-- When we meet the lambdas we must remember to rename f to f' in the
+-- second expresion.  The RnEnv2 does that.
+--
+-- 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
+-- succeed in matching what looks like the template variable 'a' against 3.
+
+-- The Var case follows closely what happens in Unify.match
+match renv subst (Var v1)    e2 = match_var renv subst v1 e2
+
+match renv subst e1 (Var v2)      -- Note [Expanding variables]
+  | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables]
+  , Just e2' <- expandUnfolding_maybe (rv_unf renv v2')
+  = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2'
+  where
+    v2'    = lookupRnInScope rn_env v2
+    rn_env = rv_lcl renv
+        -- 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
+
+match renv subst e1 (Let bind e2)
+  | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $
+    okToFloat (rv_lcl renv) (bindFreeVars bind)        -- See Note [Matching lets]
+  = match (renv { rv_fltR = flt_subst' })
+          (subst { rs_binds = rs_binds subst . Let bind'
+                 , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs })
+          e1 e2
+  where
+    flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst)
+    (flt_subst', bind') = substBind flt_subst bind
+    new_bndrs = bindersOf bind'
+
+{- Disabled: see Note [Matching cases] below
+match renv (tv_subst, id_subst, binds) e1
+      (Case scrut case_bndr ty [(con, alt_bndrs, rhs)])
+  | exprOkForSpeculation scrut  -- See Note [Matching cases]
+  , okToFloat rn_env bndrs (exprFreeVars scrut)
+  = match (renv { me_env = rn_env' })
+          (tv_subst, id_subst, binds . case_wrap)
+          e1 rhs
+  where
+    rn_env   = me_env renv
+    rn_env'  = extendRnInScopeList rn_env bndrs
+    bndrs    = case_bndr : alt_bndrs
+    case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')]
+-}
+
+match _ subst (Lit lit1) (Lit lit2)
+  | lit1 == lit2
+  = Just subst
+
+match renv subst (App f1 a1) (App f2 a2)
+  = do  { subst' <- match renv subst f1 f2
+        ; match renv subst' a1 a2 }
+
+match renv subst (Lam x1 e1) e2
+  | Just (x2, e2) <- exprIsLambda_maybe (rvInScopeEnv renv) e2
+  = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2
+                     , rv_fltR = delBndr (rv_fltR renv) x2 }
+    in  match renv' subst e1 e2
+
+match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
+  = do  { subst1 <- match_ty renv subst ty1 ty2
+        ; subst2 <- match renv subst1 e1 e2
+        ; let renv' = rnMatchBndr2 renv subst x1 x2
+        ; match_alts renv' subst2 alts1 alts2   -- Alts are both sorted
+        }
+
+match renv subst (Type ty1) (Type ty2)
+  = match_ty renv subst ty1 ty2
+match renv subst (Coercion co1) (Coercion co2)
+  = match_co renv subst co1 co2
+
+match renv subst (Cast e1 co1) (Cast e2 co2)
+  = do  { subst1 <- match_co renv subst co1 co2
+        ; match renv subst1 e1 e2 }
+
+-- Everything else fails
+match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
+                    Nothing
+
+-------------
+match_co :: RuleMatchEnv
+         -> RuleSubst
+         -> Coercion
+         -> Coercion
+         -> Maybe RuleSubst
+match_co renv subst (CoVarCo cv) co
+  = match_var renv subst cv (Coercion co)
+match_co renv subst (Refl r1 ty1) co
+  = case co of
+       Refl r2 ty2
+         | r1 == r2 -> match_ty renv subst ty1 ty2
+       _            -> Nothing
+match_co renv subst (TyConAppCo r1 tc1 cos1) co2
+  = case co2 of
+       TyConAppCo r2 tc2 cos2
+         | r1 == r2 && tc1 == tc2
+         -> match_cos renv subst cos1 cos2
+       _ -> Nothing
+match_co _ _ co1 co2
+  = pprTrace "match_co: needs more cases" (ppr co1 $$ ppr co2) Nothing
+    -- Currently just deals with CoVarCo, TyConAppCo and Refl
+
+match_cos :: RuleMatchEnv
+         -> RuleSubst
+         -> [Coercion]
+         -> [Coercion]
+         -> Maybe RuleSubst
+match_cos renv subst (co1:cos1) (co2:cos2) =
+    case match_co renv subst co1 co2 of
+       Just subst' -> match_cos renv subst' cos1 cos2
+       Nothing -> Nothing
+match_cos _ subst [] [] = Just subst
+match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing
+
+
+-------------
+rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv
+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
+
+------------------------------------------
+match_alts :: RuleMatchEnv
+           -> RuleSubst
+           -> [CoreAlt]         -- Template
+           -> [CoreAlt]         -- Target
+           -> Maybe RuleSubst
+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
+
+------------------------------------------
+okToFloat :: RnEnv2 -> VarSet -> Bool
+okToFloat rn_env bind_fvs
+  = foldVarSet ((&&) . not_captured) True bind_fvs
+  where
+    not_captured fv = not (inRnEnvR rn_env fv)
+
+------------------------------------------
+match_var :: RuleMatchEnv
+          -> RuleSubst
+          -> Var                -- Template
+          -> CoreExpr        -- Target
+          -> Maybe RuleSubst
+match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env })
+          subst v1 e2
+  | v1' `elemVarSet` tmpls
+  = match_tmpl_var renv subst v1' e2
+
+  | otherwise   -- v1' is not a template variable; check for an exact match with e2
+  = case e2 of  -- Remember, envR of rn_env is disjoint from rv_fltR
+       Var v2 | v1' == rnOccR rn_env v2
+              -> Just subst
+
+              | Var v2' <- lookupIdSubst (text "match_var") flt_env v2
+              , v1' == v2'
+              -> Just subst
+
+       _ -> Nothing
+
+  where
+    v1' = rnOccL rn_env v1
+        -- If the template is
+        --      forall x. f x (\x -> x) = ...
+        -- Then the x inside the lambda isn't the
+        -- template x, so we must rename first!
+
+------------------------------------------
+match_tmpl_var :: RuleMatchEnv
+               -> RuleSubst
+               -> Var                -- Template
+               -> CoreExpr              -- Target
+               -> Maybe RuleSubst
+
+match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env })
+               subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs })
+               v1' e2
+  | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
+  = Nothing     -- Occurs check failure
+                -- e.g. match forall a. (\x-> a x) against (\y. y y)
+
+  | Just e1' <- lookupVarEnv id_subst v1'
+  = if eqExpr (rnInScopeSet rn_env) e1' e2'
+    then Just subst
+    else Nothing
+
+  | otherwise
+  =             -- Note [Matching variable types]
+                -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+                -- However, we must match the *types*; e.g.
+                --   forall (c::Char->Int) (x::Char).
+                --      f (c x) = "RULE FIRED"
+                -- We must only match on args that have the right type
+                -- It's actually quite difficult to come up with an example that shows
+                -- you need type matching, esp since matching is left-to-right, so type
+                -- args get matched first.  But it's possible (e.g. simplrun008) and
+                -- this is the Right Thing to do
+    do { subst' <- match_ty renv subst (idType v1') (exprType e2)
+       ; return (subst' { rs_id_subst = id_subst' }) }
+  where
+    -- e2' is the result of applying flt_env to e2
+    e2' | isEmptyVarSet let_bndrs = e2
+        | otherwise = substExpr (text "match_tmpl_var") flt_env e2
+
+    id_subst' = extendVarEnv (rs_id_subst subst) v1' e2'
+         -- No further renaming to do on e2',
+         -- because no free var of e2' is in the rnEnvR of the envt
+
+------------------------------------------
+match_ty :: RuleMatchEnv
+         -> RuleSubst
+         -> Type                -- Template
+         -> Type                -- Target
+         -> Maybe RuleSubst
+-- Matching Core types: use the matcher in TcType.
+-- Notice that we treat newtypes as opaque.  For example, suppose
+-- we have a specialised version of a function at a newtype, say
+--      newtype T = MkT Int
+-- We only want to replace (f T) with f', not (f Int).
+
+match_ty renv subst ty1 ty2
+  = do  { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
+        ; return (subst { rs_tv_subst = tv_subst' }) }
+  where
+    tv_subst = rs_tv_subst subst
+    menv = ME { me_tmpls = rv_tmpls renv, me_env = rv_lcl renv }
+
+{-
+Note [Expanding variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is another Very Important rule: if the term being matched is a
+variable, we expand it so long as its unfolding is "expandable". (Its
+occurrence information is not necessarily up to date, so we don't use
+it.)  By "expandable" we mean a WHNF or a "constructor-like" application.
+This is the key reason for "constructor-like" Ids.  If we have
+     {-# NOINLINE [1] CONLIKE g #-}
+     {-# RULE f (g x) = h x #-}
+then in the term
+   let v = g 3 in ....(f v)....
+we want to make the rule fire, to replace (f v) with (h 3).
+
+Note [Do not expand locally-bound variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do *not* expand locally-bound variables, else there's a worry that the
+unfolding might mention variables that are themselves renamed.
+Example
+          case x of y { (p,q) -> ...y... }
+Don't expand 'y' to (p,q) because p,q might themselves have been
+renamed.  Essentially we only expand unfoldings that are "outside"
+the entire match.
+
+Hence, (a) the guard (not (isLocallyBoundR v2))
+       (b) when we expand we nuke the renaming envt (nukeRnEnvR).
+
+Note [Tick annotations in RULE matching]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to look through Notes in both template and expression being
+matched.  This would be incorrect for ticks, which we cannot discard,
+so we do not look through Ticks at all.  cf Note [Notes in call
+patterns] in SpecConstr
+
+Note [Matching lets]
+~~~~~~~~~~~~~~~~~~~~
+Matching a let-expression.  Consider
+        RULE forall x.  f (g x) = <rhs>
+and target expression
+        f (let { w=R } in g E))
+Then we'd like the rule to match, to generate
+        let { w=R } in (\x. <rhs>) E
+In effect, we want to float the let-binding outward, to enable
+the match to happen.  This is the WHOLE REASON for accumulating
+bindings in the RuleSubst
+
+We can only do this if the free variables of R are not bound by the
+part of the target expression outside the let binding; e.g.
+        f (\v. let w = v+1 in g E)
+Here we obviously cannot float the let-binding for w.  Hence the
+use of okToFloat.
+
+There are a couple of tricky points.
+  (a) What if floating the binding captures a variable?
+        f (let v = x+1 in v) v
+      --> NOT!
+        let v = x+1 in f (x+1) v
+
+  (b) What if two non-nested let bindings bind the same variable?
+        f (let v = e1 in b1) (let v = e2 in b2)
+      --> NOT!
+        let v = e1 in let v = e2 in (f b2 b2)
+      See testsuite test "RuleFloatLet".
+
+Our cunning plan is this:
+  * Along with the growing substitution for template variables
+    we maintain a growing set of floated let-bindings (rs_binds)
+    plus the set of variables thus bound.
+
+  * The RnEnv2 in the MatchEnv binds only the local binders
+    in the term (lambdas, case)
+
+  * When we encounter a let in the term to be matched, we
+    check that does not mention any locally bound (lambda, case)
+    variables.  If so we fail
+
+  * We use CoreSubst.substBind to freshen the binding, using an
+    in-scope set that is the original in-scope variables plus the
+    rs_bndrs (currently floated let-bindings).  So in (a) above
+    we'll freshen the 'v' binding; in (b) above we'll freshen
+    the *second* 'v' binding.
+
+  * We apply that freshening substitution, in a lexically-scoped
+    way to the term, although lazily; this is the rv_fltR field.
+
+
+Note [Matching cases]
+~~~~~~~~~~~~~~~~~~~~~
+{- NOTE: This idea is currently disabled.  It really only works if
+         the primops involved are OkForSpeculation, and, since
+         they have side effects readIntOfAddr and touch are not.
+         Maybe we'll get back to this later .  -}
+
+Consider
+   f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->
+      case touch# fp s# of { _ ->
+      I# n# } } )
+This happened in a tight loop generated by stream fusion that
+Roman encountered.  We'd like to treat this just like the let
+case, because the primops concerned are ok-for-speculation.
+That is, we'd like to behave as if it had been
+   case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->
+   case touch# fp s# of { _ ->
+   f (I# n# } } )
+
+Note [Lookup in-scope]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider this example
+        foo :: Int -> Maybe Int -> Int
+        foo 0 (Just n) = n
+        foo m (Just n) = foo (m-n) (Just n)
+
+SpecConstr sees this fragment:
+
+        case w_smT of wild_Xf [Just A] {
+          Data.Maybe.Nothing -> lvl_smf;
+          Data.Maybe.Just n_acT [Just S(L)] ->
+            case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->
+            \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
+            }};
+
+and correctly generates the rule
+
+        RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#
+                                          sc_snn :: GHC.Prim.Int#}
+          \$wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))
+          = \$s\$wfoo_sno y_amr sc_snn ;]
+
+BUT we must ensure that this rule matches in the original function!
+Note that the call to \$wfoo is
+            \$wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf
+
+During matching we expand wild_Xf to (Just n_acT).  But then we must also
+expand n_acT to (I# y_amr).  And we can only do that if we look up n_acT
+in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding
+at all.
+
+That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'
+is so important.
+
+
+************************************************************************
+*                                                                      *
+                   Rule-check the program
+*                                                                      *
+************************************************************************
+
+   We want to know what sites have rules that could have fired but didn't.
+   This pass runs over the tree (without changing it) and reports such.
+-}
+
+-- | Report partial matches for rules beginning with the specified
+-- string for the purposes of error reporting
+ruleCheckProgram :: CompilerPhase               -- ^ Rule activation test
+                 -> String                      -- ^ Rule pattern
+                 -> RuleBase                    -- ^ Database of rules
+                 -> CoreProgram                 -- ^ Bindings to check in
+                 -> SDoc                        -- ^ Resulting check message
+ruleCheckProgram phase rule_pat rule_base binds
+  | isEmptyBag results
+  = text "Rule check results: no rule application sites"
+  | otherwise
+  = vcat [text "Rule check results:",
+          line,
+          vcat [ p $$ line | p <- bagToList results ]
+         ]
+  where
+    env = RuleCheckEnv { rc_is_active = isActive phase
+                       , rc_id_unf    = idUnfolding     -- Not quite right
+                                                        -- Should use activeUnfolding
+                       , rc_pattern   = rule_pat
+                       , rc_rule_base = rule_base }
+    results = unionManyBags (map (ruleCheckBind env) binds)
+    line = text (replicate 20 '-')
+
+data RuleCheckEnv = RuleCheckEnv {
+    rc_is_active :: Activation -> Bool,
+    rc_id_unf  :: IdUnfoldingFun,
+    rc_pattern :: String,
+    rc_rule_base :: RuleBase
+}
+
+ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
+   -- The Bag returned has one SDoc for each call site found
+ruleCheckBind env (NonRec _ r) = ruleCheck env r
+ruleCheckBind env (Rec prs)    = unionManyBags [ruleCheck env r | (_,r) <- prs]
+
+ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
+ruleCheck _   (Var _)       = emptyBag
+ruleCheck _   (Lit _)       = emptyBag
+ruleCheck _   (Type _)      = emptyBag
+ruleCheck _   (Coercion _)  = emptyBag
+ruleCheck env (App f a)     = ruleCheckApp env (App f a) []
+ruleCheck env (Tick _ e)  = ruleCheck env e
+ruleCheck env (Cast e _)    = ruleCheck env e
+ruleCheck env (Let bd e)    = ruleCheckBind env bd `unionBags` ruleCheck env e
+ruleCheck env (Lam _ e)     = ruleCheck env e
+ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
+                                unionManyBags [ruleCheck env r | (_,_,r) <- as]
+
+ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc
+ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
+ruleCheckApp env (Var f) as   = ruleCheckFun env f as
+ruleCheckApp env other _      = ruleCheck env other
+
+ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc
+-- Produce a report for all rules matching the predicate
+-- saying why it doesn't match the specified application
+
+ruleCheckFun env fn args
+  | null name_match_rules = emptyBag
+  | otherwise             = unitBag (ruleAppCheck_help env fn args name_match_rules)
+  where
+    name_match_rules = filter match (getRules (rc_rule_base env) fn)
+    match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
+
+ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
+ruleAppCheck_help env fn args rules
+  =     -- The rules match the pattern, so we want to print something
+    vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
+          vcat (map check_rule rules)]
+  where
+    n_args = length args
+    i_args = args `zip` [1::Int ..]
+    rough_args = map roughTopName args
+
+    check_rule rule = sdocWithDynFlags $ \dflags ->
+                      rule_herald rule <> colon <+> rule_info dflags rule
+
+    rule_herald (BuiltinRule { ru_name = name })
+        = ptext (sLit "Builtin rule") <+> doubleQuotes (ftext name)
+    rule_herald (Rule { ru_name = name })
+        = ptext (sLit "Rule") <+> doubleQuotes (ftext name)
+
+    rule_info dflags rule
+        | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env)
+                              noBlackList fn args rough_args rule
+        = text "matches (which is very peculiar!)"
+
+    rule_info _ (BuiltinRule {}) = text "does not match"
+
+    rule_info _ (Rule { ru_act = act,
+                        ru_bndrs = rule_bndrs, ru_args = rule_args})
+        | not (rc_is_active env act)  = text "active only in later phase"
+        | n_args < n_rule_args        = text "too few arguments"
+        | n_mismatches == n_rule_args = text "no arguments match"
+        | n_mismatches == 0           = text "all arguments match (considered individually), but rule as a whole does not"
+        | otherwise                   = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"
+        where
+          n_rule_args  = length rule_args
+          n_mismatches = length mismatches
+          mismatches   = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
+                              not (isJust (match_fn rule_arg arg))]
+
+          lhs_fvs = exprsFreeVars rule_args     -- Includes template tyvars
+          match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg
+                where
+                  in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg)
+                  renv = RV { rv_lcl   = mkRnEnv2 in_scope
+                            , rv_tmpls = mkVarSet rule_bndrs
+                            , rv_fltR  = mkEmptySubst in_scope
+                            , rv_unf   = rc_id_unf env }