No join-point from an INLINE function with wrong arity
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 17 Mar 2017 16:25:41 +0000 (16:25 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 17 Mar 2017 16:31:13 +0000 (16:31 +0000)
The main payload of this patch is NOT to make a join-point
from a function with an INLINE pragma and the wrong arity;
see Note [Join points and INLINE pragmas] in CoreOpt.
This is what caused Trac #13413.

But we must do the exact same thing in simpleOptExpr,
which drove me to the following refactoring:

* Move simpleOptExpr and simpleOptPgm from CoreSubst to a new
  module CoreOpt along with a few others (exprIsConApp_maybe,
  pushCoArg, etc)

  This eliminates a module loop altogether (delete
  CoreArity.hs-boot), and stops CoreSubst getting too huge.

* Rename Simplify.matchOrConvertToJoinPoint
     to joinPointBinding_maybe
  Move it to the new CoreOpt
  Use it in simpleOptExpr as well as in Simplify

* Define CoreArity.joinRhsArity and use it

17 files changed:
compiler/coreSyn/CoreArity.hs
compiler/coreSyn/CoreArity.hs-boot [deleted file]
compiler/coreSyn/CoreOpt.hs [new file with mode: 0644]
compiler/coreSyn/CoreSubst.hs
compiler/coreSyn/CoreSyn.hs
compiler/coreSyn/CoreUnfold.hs
compiler/deSugar/Desugar.hs
compiler/deSugar/DsBinds.hs
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/main/GhcPlugins.hs
compiler/prelude/PrelRules.hs
compiler/simplCore/Simplify.hs
compiler/specialise/Rules.hs
compiler/specialise/Specialise.hs
testsuite/tests/simplCore/should_compile/T13413.hs [new file with mode: 0644]
testsuite/tests/simplCore/should_compile/all.T

index 49f58c6..88c3a7a 100644 (file)
 
 -- | Arity and eta expansion
 module CoreArity (
-        manifestArity, exprArity, typeArity, exprBotStrictness_maybe,
+        manifestArity, joinRhsArity, exprArity, typeArity,
         exprEtaExpandArity, findRhsArity, CheapFun, etaExpand,
-        etaExpandToJoinPoint, etaExpandToJoinPointRule
+        etaExpandToJoinPoint, etaExpandToJoinPointRule,
+        exprBotStrictness_maybe
     ) where
 
 #include "HsVersions.h"
@@ -77,6 +78,14 @@ manifestArity (Tick t e) | not (tickishIsCode t) =  manifestArity e
 manifestArity (Cast e _)                = manifestArity e
 manifestArity _                         = 0
 
+joinRhsArity :: CoreExpr -> JoinArity
+-- Join points are supposed to have manifestly-visible
+-- lambdas at the top: no ticks, no casts, nothing
+-- Moreover, type lambdas count in JoinArity
+joinRhsArity (Lam _ e) = 1 + joinRhsArity e
+joinRhsArity _         = 0
+
+
 ---------------
 exprArity :: CoreExpr -> Arity
 -- ^ An approximate, fast, version of 'exprEtaExpandArity'
diff --git a/compiler/coreSyn/CoreArity.hs-boot b/compiler/coreSyn/CoreArity.hs-boot
deleted file mode 100644 (file)
index 4c155da..0000000
+++ /dev/null
@@ -1,6 +0,0 @@
-module CoreArity where
-
-import BasicTypes
-import CoreSyn
-
-etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr)
diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
new file mode 100644 (file)
index 0000000..98a590b
--- /dev/null
@@ -0,0 +1,1176 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+
+{-# LANGUAGE CPP #-}
+module CoreOpt (
+        -- ** Simple expression optimiser
+        simpleOptPgm, simpleOptExpr, simpleOptExprWith,
+
+        -- ** Join points
+        joinPointBinding_maybe, joinPointBindings_maybe,
+
+        -- ** Predicates on expressions
+        exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,
+
+        -- ** Coercions and casts
+        pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo
+    ) where
+
+#include "HsVersions.h"
+
+import CoreArity( joinRhsArity, etaExpandToJoinPoint )
+
+import CoreSyn
+import CoreSubst
+import CoreUtils
+import CoreFVs
+import PprCore  ( pprCoreBindings, pprRules )
+import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
+import Literal  ( Literal(MachStr) )
+import Id
+import Var      ( varType )
+import VarSet
+import VarEnv
+import DataCon
+import OptCoercion ( optCoercion )
+import Type     hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
+                       , isInScope, substTyVarBndr, cloneTyVarBndr )
+import Coercion hiding ( substCo, substCoVarBndr )
+import TyCon        ( tyConArity )
+import TysWiredIn
+import PrelNames
+import BasicTypes
+import Module       ( Module )
+import ErrUtils
+import DynFlags
+import Outputable
+import Pair
+import Util
+import Maybes       ( orElse )
+import FastString
+import Data.List
+import qualified Data.ByteString as BS
+
+{-
+************************************************************************
+*                                                                      *
+        The Simple Optimiser
+*                                                                      *
+************************************************************************
+
+Note [The simple optimiser]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The simple optimiser is a lightweight, pure (non-monadic) function
+that rapidly does a lot of simple optimisations, including
+
+  - inlining things that occur just once,
+      or whose RHS turns out to be trivial
+  - beta reduction
+  - case of known constructor
+  - dead code elimination
+
+It does NOT do any call-site inlining; it only inlines a function if
+it can do so unconditionally, dropping the binding.  It thereby
+guarantees to leave no un-reduced beta-redexes.
+
+It is careful to follow the guidance of "Secrets of the GHC inliner",
+and in particular the pre-inline-unconditionally and
+post-inline-unconditionally story, to do effective beta reduction on
+functions called precisely once, without repeatedly optimising the same
+expression.  In fact, the simple optimiser is a good example of this
+little dance in action; the full Simplifier is a lot more complicated.
+
+-}
+
+simpleOptExpr :: CoreExpr -> CoreExpr
+-- See Note [The simple optimiser]
+-- Do simple optimisation on an expression
+-- The optimisation is very straightforward: just
+-- inline non-recursive bindings that are used only once,
+-- or where the RHS is trivial
+--
+-- We also inline bindings that bind a Eq# box: see
+-- See Note [Getting the map/coerce RULE to work].
+--
+-- Also we convert functions to join points where possible (as
+-- the occurrence analyser does most of the work anyway).
+--
+-- The result is NOT guaranteed occurrence-analysed, because
+-- in  (let x = y in ....) we substitute for x; so y's occ-info
+-- may change radically
+
+simpleOptExpr expr
+  = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
+    simpleOptExprWith init_subst expr
+  where
+    init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
+        -- It's potentially important to make a proper in-scope set
+        -- Consider  let x = ..y.. in \y. ...x...
+        -- Then we should remember to clone y before substituting
+        -- for x.  It's very unlikely to occur, because we probably
+        -- won't *be* substituting for x if it occurs inside a
+        -- lambda.
+        --
+        -- It's a bit painful to call exprFreeVars, because it makes
+        -- three passes instead of two (occ-anal, and go)
+
+simpleOptExprWith :: Subst -> InExpr -> OutExpr
+-- See Note [The simple optimiser]
+simpleOptExprWith subst expr
+  = simple_opt_expr init_env (occurAnalyseExpr expr)
+  where
+    init_env = SOE { soe_inl = emptyVarEnv, soe_subst = subst }
+
+----------------------
+simpleOptPgm :: DynFlags -> Module
+             -> CoreProgram -> [CoreRule] -> [CoreVect]
+             -> IO (CoreProgram, [CoreRule], [CoreVect])
+-- See Note [The simple optimiser]
+simpleOptPgm dflags this_mod binds rules vects
+  = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
+                       (pprCoreBindings occ_anald_binds $$ pprRules rules );
+
+       ; return (reverse binds', rules', vects') }
+  where
+    occ_anald_binds  = occurAnalysePgm this_mod (\_ -> False) {- No rules active -}
+                                       rules vects emptyVarSet binds
+
+    (final_env, binds') = foldl do_one (emptyEnv, []) occ_anald_binds
+    final_subst = soe_subst final_env
+
+    rules' = substRulesForImportedIds final_subst rules
+    vects' = substVects final_subst vects
+             -- We never unconditionally inline into rules,
+             -- hence pasing just a substitution
+
+    do_one (env, binds') bind
+      = case simple_opt_bind env bind of
+          (env', Nothing)    -> (env', binds')
+          (env', Just bind') -> (env', bind':binds')
+
+-- In these functions the substitution maps InVar -> OutExpr
+
+----------------------
+type SimpleClo = (SimpleOptEnv, InExpr)
+
+data SimpleOptEnv
+  = SOE { soe_inl   :: IdEnv SimpleClo
+             -- Deals with preInlineUnconditionally; things
+             -- that occur exactly once and are inlined
+             -- without having first been simplified
+
+        , soe_subst :: Subst
+             -- Deals with cloning; includes the InScopeSet
+        }
+
+instance Outputable SimpleOptEnv where
+  ppr (SOE { soe_inl = inl, soe_subst = subst })
+    = text "SOE {" <+> vcat [ text "soe_inl   =" <+> ppr inl
+                            , text "soe_subst =" <+> ppr subst ]
+                   <+> text "}"
+
+emptyEnv :: SimpleOptEnv
+emptyEnv = SOE { soe_inl = emptyVarEnv
+               , soe_subst = emptySubst }
+
+soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
+soeZapSubst (SOE { soe_subst = subst })
+  = SOE { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst }
+
+soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
+-- Take in-scope set from env1, and the rest from env2
+soeSetInScope (SOE { soe_subst = subst1 })
+              env2@(SOE { soe_subst = subst2 })
+  = env2 { soe_subst = setInScope subst2 (substInScope subst1) }
+
+---------------
+simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr
+simple_opt_clo env (e_env, e)
+  = simple_opt_expr (soeSetInScope env e_env) e
+
+simple_opt_expr :: SimpleOptEnv -> InExpr -> OutExpr
+simple_opt_expr env expr
+  = go expr
+  where
+    subst        = soe_subst env
+    in_scope     = substInScope subst
+    in_scope_env = (in_scope, simpleUnfoldingFun)
+
+    go (Var v)
+       | Just clo <- lookupVarEnv (soe_inl env) v
+       = simple_opt_clo env clo
+       | otherwise
+       = lookupIdSubst (text "simpleOptExpr") (soe_subst env) v
+
+    go (App e1 e2)      = simple_app env e1 [(env,e2)]
+    go (Type ty)        = Type     (substTy subst ty)
+    go (Coercion co)    = Coercion (optCoercion (getTCvSubst subst) co)
+    go (Lit lit)        = Lit lit
+    go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
+    go (Cast e co)      | isReflCo co' = go e
+                        | otherwise    = Cast (go e) co'
+                        where
+                          co' = optCoercion (getTCvSubst subst) co
+
+    go (Let bind body) = case simple_opt_bind env bind of
+                           (env', Nothing)   -> simple_opt_expr env' body
+                           (env', Just bind) -> Let bind (simple_opt_expr env' body)
+
+    go lam@(Lam {})     = go_lam env [] lam
+    go (Case e b ty as)
+       -- See Note [Getting the map/coerce RULE to work]
+      | isDeadBinder b
+      , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e'
+      , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as
+      = case altcon of
+          DEFAULT -> go rhs
+          _       -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs
+            where
+              (env', mb_prs) = mapAccumL simple_out_bind env $
+                               zipEqual "simpleOptExpr" bs es
+
+         -- Note [Getting the map/coerce RULE to work]
+      | isDeadBinder b
+      , [(DEFAULT, _, rhs)] <- as
+      , isCoercionType (varType b)
+      , (Var fun, _args) <- collectArgs e
+      , fun `hasKey` coercibleSCSelIdKey
+         -- without this last check, we get #11230
+      = go rhs
+
+      | otherwise
+      = Case e' b' (substTy subst ty)
+                   (map (go_alt env') as)
+      where
+        e' = go e
+        (env', b') = subst_opt_bndr env b
+
+    ----------------------
+    go_alt env (con, bndrs, rhs)
+      = (con, bndrs', simple_opt_expr env' rhs)
+      where
+        (env', bndrs') = subst_opt_bndrs env bndrs
+
+    ----------------------
+    -- go_lam tries eta reduction
+    go_lam env bs' (Lam b e)
+       = go_lam env' (b':bs') e
+       where
+         (env', b') = subst_opt_bndr env b
+    go_lam env bs' e
+       | Just etad_e <- tryEtaReduce bs e' = etad_e
+       | otherwise                         = mkLams bs e'
+       where
+         bs = reverse bs'
+         e' = simple_opt_expr env e
+
+----------------------
+-- simple_app collects arguments for beta reduction
+simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr
+
+simple_app env (Var v) as
+  | Just (env', e) <- lookupVarEnv (soe_inl env) v
+  = simple_app (soeSetInScope env env') e as
+
+  | let unf = idUnfolding v
+  , isCompulsoryUnfolding (idUnfolding v)
+  , isAlwaysActive (idInlineActivation v)
+    -- See Note [Unfold compulsory unfoldings in LHSs]
+  = simple_app (soeZapSubst env) (unfoldingTemplate unf) as
+
+  | otherwise
+  , let out_fn = lookupIdSubst (text "simple_app") (soe_subst env) v
+  = finish_app env out_fn as
+
+simple_app env (App e1 e2) as
+  = simple_app env e1 ((env, e2) : as)
+
+simple_app env (Lam b e) (a:as)
+  = wrapLet mb_pr (simple_app env' e as)
+  where
+     (env', mb_pr) = simple_bind_pair env b Nothing a
+
+simple_app env (Tick t e) as
+  -- Okay to do "(Tick t e) x ==> Tick t (e x)"?
+  | t `tickishScopesLike` SoftScope
+  = mkTick t $ simple_app env e as
+
+simple_app env e as
+  = finish_app env (simple_opt_expr env e) as
+
+finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
+finish_app _ fun []
+  = fun
+finish_app env fun (arg:args)
+  = finish_app env (App fun (simple_opt_clo env arg)) args
+
+----------------------
+simple_opt_bind :: SimpleOptEnv -> InBind
+                -> (SimpleOptEnv, Maybe OutBind)
+simple_opt_bind env (NonRec b r)
+  = (env', case mb_pr of
+            Nothing    -> Nothing
+            Just (b,r) -> Just (NonRec b r))
+  where
+    (b', r') = joinPointBinding_maybe b r `orElse` (b, r)
+    (env', mb_pr) = simple_bind_pair env b' Nothing (env,r')
+
+simple_opt_bind env (Rec prs)
+  = (env'', res_bind)
+  where
+    res_bind          = Just (Rec (reverse rev_prs'))
+    prs'              = joinPointBindings_maybe prs `orElse` prs
+    (env', bndrs')    = subst_opt_bndrs env (map fst prs')
+    (env'', rev_prs') = foldl do_pr (env', []) (prs' `zip` bndrs')
+    do_pr (env, prs) ((b,r), b')
+       = (env', case mb_pr of
+                  Just pr -> pr : prs
+                  Nothing -> prs)
+       where
+         (env', mb_pr) = simple_bind_pair env b (Just b') (env,r)
+
+----------------------
+simple_bind_pair :: SimpleOptEnv
+                 -> InVar -> Maybe OutVar
+                 -> SimpleClo
+                 -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
+    -- (simple_bind_pair subst in_var out_rhs)
+    --   either extends subst with (in_var -> out_rhs)
+    --   or     returns Nothing
+simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
+                 in_bndr mb_out_bndr clo@(rhs_env, in_rhs)
+  | Type ty <- in_rhs        -- let a::* = TYPE ty in <body>
+  , let out_ty = substTy (soe_subst rhs_env) ty
+  = ASSERT( isTyVar in_bndr )
+    (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
+
+  | Coercion co <- in_rhs
+  , let out_co = optCoercion (getTCvSubst (soe_subst rhs_env)) co
+  = ASSERT( isCoVar in_bndr )
+    (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
+
+  | pre_inline_unconditionally
+  = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing)
+
+  | otherwise
+  = simple_out_bind_pair env in_bndr mb_out_bndr
+                         (simple_opt_clo env clo)
+                         occ active stable_unf
+  where
+    stable_unf = isStableUnfolding (idUnfolding in_bndr)
+    active     = isAlwaysActive (idInlineActivation in_bndr)
+    occ        = idOccInfo in_bndr
+
+    pre_inline_unconditionally :: Bool
+    pre_inline_unconditionally
+       | isCoVar in_bndr          = False    -- See Note [Do not inline CoVars unconditionally]
+       | isExportedId in_bndr     = False    --     in SimplUtils
+       | stable_unf               = False
+       | not active               = False    -- Note [Inline prag in simplOpt]
+       | not (safe_to_inline occ) = False
+       | otherwise = True
+
+        -- Unconditionally safe to inline
+    safe_to_inline :: OccInfo -> Bool
+    safe_to_inline (IAmALoopBreaker {}) = False
+    safe_to_inline IAmDead              = True
+    safe_to_inline occ@(OneOcc {})      =  not (occ_in_lam occ)
+                                        && occ_one_br occ
+    safe_to_inline (ManyOccs {})        = False
+
+-------------------
+simple_out_bind :: SimpleOptEnv -> (InVar, OutExpr)
+                -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
+simple_out_bind env@(SOE { soe_subst = subst }) (in_bndr, out_rhs)
+  | Type out_ty <- out_rhs
+  = ASSERT( isTyVar in_bndr )
+    (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
+
+  | Coercion out_co <- out_rhs
+  = ASSERT( isCoVar in_bndr )
+    (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
+
+  | otherwise
+  = simple_out_bind_pair env in_bndr Nothing out_rhs
+                         (idOccInfo in_bndr) True False
+
+-------------------
+simple_out_bind_pair :: SimpleOptEnv
+                     -> InId -> Maybe OutId -> OutExpr
+                     -> OccInfo -> Bool -> Bool
+                     -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
+simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
+                     occ_info active stable_unf
+  | post_inline_unconditionally
+  = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs }
+    , Nothing)
+
+  | otherwise
+  = ( env', Just (out_bndr, out_rhs) )
+  where
+    (env', bndr1) = case mb_out_bndr of
+                      Just out_bndr -> (env, out_bndr)
+                      Nothing       -> subst_opt_bndr env in_bndr
+    out_bndr = add_info env' in_bndr bndr1
+
+    post_inline_unconditionally :: Bool
+    post_inline_unconditionally
+       | not active                  = False
+       | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline
+                                             -- because it might be referred to "earlier"
+       | stable_unf                  = False -- Note [Stable unfoldings and postInlineUnconditionally]
+       | isExportedId in_bndr        = False -- Note [Exported Ids and trivial RHSs]
+       | exprIsTrivial out_rhs       = True
+       | coercible_hack              = True
+       | otherwise                   = False
+
+    -- See Note [Getting the map/coerce RULE to work]
+    coercible_hack | (Var fun, args) <- collectArgs out_rhs
+                   , Just dc <- isDataConWorkId_maybe fun
+                   , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey
+                   = all exprIsTrivial args
+                   | otherwise
+                   = False
+
+{- Note [Exported Ids and trivial RHSs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We obviously do not want to unconditionally inline an Id that is exported.
+In SimplUtils, Note [Top level and postInlineUnconditionally], we
+explain why we don't inline /any/ top-level things unconditionally, even
+trivial ones.  But we do here!  Why?  In the simple optimiser
+
+  * We do no rule rewrites
+  * We do no call-site inlining
+
+Those differences obviate the reasons for not inlining a trivial rhs,
+and increase the benefit for doing so.  So we unconditionally inline trivial
+rhss here.
+-}
+
+----------------------
+subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar])
+subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs
+
+subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar)
+subst_opt_bndr env bndr
+  | isTyVar bndr  = (env { soe_subst = subst_tv }, tv')
+  | isCoVar bndr  = (env { soe_subst = subst_cv }, cv')
+  | otherwise     = subst_opt_id_bndr env bndr
+  where
+    subst           = soe_subst env
+    (subst_tv, tv') = substTyVarBndr subst bndr
+    (subst_cv, cv') = substCoVarBndr subst bndr
+
+subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId)
+-- Nuke all fragile IdInfo, unfolding, and RULES;
+--    it gets added back later by add_info
+-- Rather like SimplEnv.substIdBndr
+--
+-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr
+-- carefully does not do) because simplOptExpr invalidates it
+
+subst_opt_id_bndr (SOE { soe_subst = subst, soe_inl = inl }) old_id
+  = (SOE { soe_subst = new_subst, soe_inl = new_inl }, new_id)
+  where
+    Subst in_scope id_subst tv_subst cv_subst = subst
+
+    id1    = uniqAway in_scope old_id
+    id2    = setIdType id1 (substTy subst (idType old_id))
+    new_id = zapFragileIdInfo id2
+             -- Zaps rules, worker-info, unfolding, and fragile OccInfo
+             -- The unfolding and rules will get added back later, by add_info
+
+    new_in_scope = in_scope `extendInScopeSet` new_id
+
+    no_change = new_id == old_id
+
+        -- Extend the substitution if the unique has changed,
+        -- See the notes with substTyVarBndr for the delSubstEnv
+    new_id_subst
+      | no_change = delVarEnv id_subst old_id
+      | otherwise = extendVarEnv id_subst old_id (Var new_id)
+
+    new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst
+    new_inl   = delVarEnv inl old_id
+
+----------------------
+add_info :: SimpleOptEnv -> InVar -> OutVar -> OutVar
+add_info env old_bndr new_bndr
+ | isTyVar old_bndr = new_bndr
+ | otherwise        = maybeModifyIdInfo mb_new_info new_bndr
+ where
+   subst = soe_subst env
+   mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
+
+simpleUnfoldingFun :: IdUnfoldingFun
+simpleUnfoldingFun id
+  | isAlwaysActive (idInlineActivation id) = idUnfolding id
+  | otherwise                              = noUnfolding
+
+wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
+wrapLet Nothing      body = body
+wrapLet (Just (b,r)) body = Let (NonRec b r) body
+
+------------------
+substVects :: Subst -> [CoreVect] -> [CoreVect]
+substVects subst = map (substVect subst)
+
+------------------
+substVect :: Subst -> CoreVect -> CoreVect
+substVect subst  (Vect v rhs)        = Vect v (simpleOptExprWith subst rhs)
+substVect _subst vd@(NoVect _)       = vd
+substVect _subst vd@(VectType _ _ _) = vd
+substVect _subst vd@(VectClass _)    = vd
+substVect _subst vd@(VectInst _)     = vd
+
+{-
+Note [Inline prag in simplOpt]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If there's an INLINE/NOINLINE pragma that restricts the phase in
+which the binder can be inlined, we don't inline here; after all,
+we don't know what phase we're in.  Here's an example
+
+  foo :: Int -> Int -> Int
+  {-# INLINE foo #-}
+  foo m n = inner m
+     where
+       {-# INLINE [1] inner #-}
+       inner m = m+n
+
+  bar :: Int -> Int
+  bar n = foo n 1
+
+When inlining 'foo' in 'bar' we want the let-binding for 'inner'
+to remain visible until Phase 1
+
+Note [Unfold compulsory unfoldings in LHSs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the user writes `RULES map coerce = coerce` as a rule, the rule
+will only ever match if simpleOptExpr replaces coerce by its unfolding
+on the LHS, because that is the core that the rule matching engine
+will find. So do that for everything that has a compulsory
+unfolding. Also see Note [Desugaring coerce as cast] in Desugar.
+
+However, we don't want to inline 'seq', which happens to also have a
+compulsory unfolding, so we only do this unfolding only for things
+that are always-active.  See Note [User-defined RULES for seq] in MkId.
+
+Note [Getting the map/coerce RULE to work]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We wish to allow the "map/coerce" RULE to fire:
+
+  {-# RULES "map/coerce" map coerce = coerce #-}
+
+The naive core produced for this is
+
+  forall a b (dict :: Coercible * a b).
+    map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict'
+
+  where dict' :: Coercible [a] [b]
+        dict' = ...
+
+This matches literal uses of `map coerce` in code, but that's not what we
+want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int)
+too. Some of this is addressed by compulsorily unfolding coerce on the LHS,
+yielding
+
+  forall a b (dict :: Coercible * a b).
+    map @a @b (\(x :: a) -> case dict of
+      MkCoercible (co :: a ~R# b) -> x |> co) = ...
+
+Getting better. But this isn't exactly what gets produced. This is because
+Coercible essentially has ~R# as a superclass, and superclasses get eagerly
+extracted during solving. So we get this:
+
+  forall a b (dict :: Coercible * a b).
+    case Coercible_SCSel @* @a @b dict of
+      _ [Dead] -> map @a @b (\(x :: a) -> case dict of
+                               MkCoercible (co :: a ~R# b) -> x |> co) = ...
+
+Unfortunately, this still abstracts over a Coercible dictionary. We really
+want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce,
+which transforms the above to (see also Note [Desugaring coerce as cast] in
+Desugar)
+
+  forall a b (co :: a ~R# b).
+    let dict = MkCoercible @* @a @b co in
+    case Coercible_SCSel @* @a @b dict of
+      _ [Dead] -> map @a @b (\(x :: a) -> case dict of
+         MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ...
+
+Now, we need simpleOptExpr to fix this up. It does so by taking three
+separate actions:
+  1. Inline certain non-recursive bindings. The choice whether to inline
+     is made in simple_bind_pair. Note the rather specific check for
+     MkCoercible in there.
+
+  2. Stripping case expressions like the Coercible_SCSel one.
+     See the `Case` case of simple_opt_expr's `go` function.
+
+  3. Look for case expressions that unpack something that was
+     just packed and inline them. This is also done in simple_opt_expr's
+     `go` function.
+
+This is all a fair amount of special-purpose hackery, but it's for
+a good cause. And it won't hurt other RULES and such that it comes across.
+
+
+************************************************************************
+*                                                                      *
+                Join points
+*                                                                      *
+************************************************************************
+-}
+
+-- | Returns Just (bndr,rhs) if the binding is a join point:
+-- If it's a JoinId, just return it
+-- If it's not yet a JoinId but is always tail-called,
+--    make it into a JoinId and return it.
+-- In the latter case, eta-expand the RHS if necessary, to make the
+-- lambdas explicit, as is required for join points
+--
+-- Precondition: the InBndr has been occurrence-analysed,
+--               so its OccInfo is valid
+joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
+joinPointBinding_maybe bndr rhs
+  | not (isId bndr)
+  = Nothing
+
+  | isJoinId bndr
+  = Just (bndr, rhs)
+
+  | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)
+  , not (bad_unfolding join_arity (idUnfolding bndr))
+  , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
+  = Just (bndr `asJoinId` join_arity, mkLams bndrs body)
+
+  | otherwise
+  = Nothing
+
+  where
+    -- bad_unfolding returns True if we should /not/ convert a non-join-id
+    -- into a join-id, even though it is AlwaysTailCalled
+    -- See Note [Join points and INLINE pragmas]
+    bad_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })
+      = isStableSource src && join_arity > joinRhsArity rhs
+    bad_unfolding _ (DFunUnfolding {})
+      = True
+    bad_unfolding _ _
+      = False
+
+joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
+joinPointBindings_maybe bndrs
+  = mapM (uncurry joinPointBinding_maybe) bndrs
+
+
+{- Note [Join points and INLINE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f x = let g = \x. not  -- Arity 1
+             {-# INLINE g #-}
+         in case x of
+              A -> g True True
+              B -> g True False
+              C -> blah2
+
+Here 'g' is always tail-called applied to 2 args, but the stable
+unfolding captured by the INLINE pragma has arity 1.  If we try to
+convert g to be a join point, its unfolding will still have arity 1
+(since it is stable, and we don't meddle with stable unfoldings), and
+Lint will complain (see Note [Invariants on join points], (2a), in
+CoreSyn.  Trac #13413.
+
+Moreover, since g is going to be inlined anyway, there is no benefit
+from making it a join point.
+
+If it is recursive, and uselessly marked INLINE, this will stop us
+making it a join point, which is a annoying.  But occasionally
+(notably in class methods; see Note [Instances and loop breakers] in
+TcInstDcls) we mark recurive things as INLINE but the recursion
+unravels; so ignoring INLINE pragmas on recursive things isn't good
+either.
+
+
+************************************************************************
+*                                                                      *
+         exprIsConApp_maybe
+*                                                                      *
+************************************************************************
+
+Note [exprIsConApp_maybe]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+exprIsConApp_maybe is a very important function.  There are two principal
+uses:
+  * case e of { .... }
+  * cls_op e, where cls_op is a class operation
+
+In both cases you want to know if e is of form (C e1..en) where C is
+a data constructor.
+
+However e might not *look* as if
+
+
+Note [exprIsConApp_maybe on literal strings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See #9400 and #13317.
+
+Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core
+they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or
+unpackCStringUtf8# when the literal contains multi-byte UTF8 characters.
+
+For optimizations we want to be able to treat it as a list, so they can be
+decomposed when used in a case-statement. exprIsConApp_maybe detects those
+calls to unpackCString# and returns:
+
+Just (':', [Char], ['a', unpackCString# "bc"]).
+
+We need to be careful about UTF8 strings here. ""# contains a ByteString, so
+we must parse it back into a FastString to split off the first character.
+That way we can treat unpackCString# and unpackCStringUtf8# in the same way.
+
+We must also be caeful about
+   lvl = "foo"#
+   ...(unpackCString# lvl)...
+to ensure that we see through the let-binding for 'lvl'.  Hence the
+(exprIsLiteral_maybe .. arg) in the guard before the call to
+dealWithStringLiteral.
+
+Note [Push coercions in exprIsConApp_maybe]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In Trac #13025 I found a case where we had
+    op (df @t1 @t2)     -- op is a ClassOp
+where
+    df = (/\a b. K e1 e2) |> g
+
+To get this to come out we need to simplify on the fly
+   ((/\a b. K e1 e2) |> g) @t1 @t2
+
+Hence the use of pushCoArgs.
+-}
+
+data ConCont = CC [CoreExpr] Coercion
+                  -- Substitution already applied
+
+-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is
+-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
+-- where t1..tk are the *universally-qantified* type args of 'dc'
+exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
+exprIsConApp_maybe (in_scope, id_unf) expr
+  = go (Left in_scope) expr (CC [] (mkRepReflCo (exprType expr)))
+  where
+    go :: Either InScopeSet Subst
+             -- Left in-scope  means "empty substitution"
+             -- Right subst    means "apply this substitution to the CoreExpr"
+       -> CoreExpr -> ConCont
+       -> Maybe (DataCon, [Type], [CoreExpr])
+    go subst (Tick t expr) cont
+       | not (tickishIsCode t) = go subst expr cont
+    go subst (Cast expr co1) (CC args co2)
+       | Just (args', co1') <- pushCoArgs (subst_co subst co1) args
+            -- See Note [Push coercions in exprIsConApp_maybe]
+       = go subst expr (CC args' (co1' `mkTransCo` co2))
+    go subst (App fun arg) (CC args co)
+       = go subst fun (CC (subst_arg subst arg : args) co)
+    go subst (Lam var body) (CC (arg:args) co)
+       | exprIsTrivial arg          -- Don't duplicate stuff!
+       = go (extend subst var arg) body (CC args co)
+    go (Right sub) (Var v) cont
+       = go (Left (substInScope sub))
+            (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v)
+            cont
+
+    go (Left in_scope) (Var fun) cont@(CC args co)
+
+        | Just con <- isDataConWorkId_maybe fun
+        , count isValArg args == idArity fun
+        = pushCoDataCon con args co
+
+        -- Look through dictionary functions; see Note [Unfolding DFuns]
+        | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding
+        , bndrs `equalLength` args    -- See Note [DFun arity check]
+        , let subst = mkOpenSubst in_scope (bndrs `zip` args)
+        = pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co
+
+        -- Look through unfoldings, but only arity-zero one;
+        -- if arity > 0 we are effectively inlining a function call,
+        -- and that is the business of callSiteInline.
+        -- In practice, without this test, most of the "hits" were
+        -- CPR'd workers getting inlined back into their wrappers,
+        | idArity fun == 0
+        , Just rhs <- expandUnfolding_maybe unfolding
+        , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs)
+        = go (Left in_scope') rhs cont
+
+        -- See Note [exprIsConApp_maybe on literal strings]
+        | (fun `hasKey` unpackCStringIdKey) ||
+          (fun `hasKey` unpackCStringUtf8IdKey)
+        , [arg]              <- args
+        , Just (MachStr str) <- exprIsLiteral_maybe (in_scope, id_unf) arg
+        = dealWithStringLiteral fun str co
+        where
+          unfolding = id_unf fun
+
+    go _ _ _ = Nothing
+
+    ----------------------------
+    -- Operations on the (Either InScopeSet CoreSubst)
+    -- The Left case is wildly dominant
+    subst_co (Left {}) co = co
+    subst_co (Right s) co = CoreSubst.substCo s co
+
+    subst_arg (Left {}) e = e
+    subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e
+
+    extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)
+    extend (Right s)       v e = Right (extendSubst s v e)
+
+
+-- See Note [exprIsConApp_maybe on literal strings]
+dealWithStringLiteral :: Var -> BS.ByteString -> Coercion
+                      -> Maybe (DataCon, [Type], [CoreExpr])
+
+-- This is not possible with user-supplied empty literals, MkCore.mkStringExprFS
+-- turns those into [] automatically, but just in case something else in GHC
+-- generates a string literal directly.
+dealWithStringLiteral _   str co
+  | BS.null str
+  = pushCoDataCon nilDataCon [Type charTy] co
+
+dealWithStringLiteral fun str co
+  = let strFS = mkFastStringByteString str
+
+        char = mkConApp charDataCon [mkCharLit (headFS strFS)]
+        charTail = fastStringToByteString (tailFS strFS)
+
+        -- In singleton strings, just add [] instead of unpackCstring# ""#.
+        rest = if BS.null charTail
+                 then mkConApp nilDataCon [Type charTy]
+                 else App (Var fun)
+                          (Lit (MachStr charTail))
+
+    in pushCoDataCon consDataCon [Type charTy, char, rest] co
+
+{-
+Note [Unfolding DFuns]
+~~~~~~~~~~~~~~~~~~~~~~
+DFuns look like
+
+  df :: forall a b. (Eq a, Eq b) -> Eq (a,b)
+  df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b)
+                               ($c2 a b d_a d_b)
+
+So to split it up we just need to apply the ops $c1, $c2 etc
+to the very same args as the dfun.  It takes a little more work
+to compute the type arguments to the dictionary constructor.
+
+Note [DFun arity check]
+~~~~~~~~~~~~~~~~~~~~~~~
+Here we check that the total number of supplied arguments (inclding
+type args) matches what the dfun is expecting.  This may be *less*
+than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
+-}
+
+exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
+-- Same deal as exprIsConApp_maybe, but much simpler
+-- Nevertheless we do need to look through unfoldings for
+-- Integer and string literals, which are vigorously hoisted to top level
+-- and not subsequently inlined
+exprIsLiteral_maybe env@(_, id_unf) e
+  = case e of
+      Lit l     -> Just l
+      Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?
+      Var v     | Just rhs <- expandUnfolding_maybe (id_unf v)
+                -> exprIsLiteral_maybe env rhs
+      _         -> Nothing
+
+{-
+Note [exprIsLambda_maybe]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+exprIsLambda_maybe will, given an expression `e`, try to turn it into the form
+`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through
+casts (using the Push rule), and it unfolds function calls if the unfolding
+has a greater arity than arguments are present.
+
+Currently, it is used in Rules.match, and is required to make
+"map coerce = coerce" match.
+-}
+
+exprIsLambda_maybe :: InScopeEnv -> CoreExpr
+                      -> Maybe (Var, CoreExpr,[Tickish Id])
+    -- See Note [exprIsLambda_maybe]
+
+-- The simple case: It is a lambda already
+exprIsLambda_maybe _ (Lam x e)
+    = Just (x, e, [])
+
+-- Still straightforward: Ticks that we can float out of the way
+exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e)
+    | tickishFloatable t
+    , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e
+    = Just (x, e, t:ts)
+
+-- Also possible: A casted lambda. Push the coercion inside
+exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
+    | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e
+    -- Only do value lambdas.
+    -- this implies that x is not in scope in gamma (makes this code simpler)
+    , not (isTyVar x) && not (isCoVar x)
+    , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True
+    , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co
+    , let res = Just (x',e',ts)
+    = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])
+      res
+
+-- Another attempt: See if we find a partial unfolding
+exprIsLambda_maybe (in_scope_set, id_unf) e
+    | (Var f, as, ts) <- collectArgsTicks tickishFloatable e
+    , idArity f > count isValArg as
+    -- Make sure there is hope to get a lambda
+    , Just rhs <- expandUnfolding_maybe (id_unf f)
+    -- Optimize, for beta-reduction
+    , let e' =  simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as)
+    -- Recurse, because of possible casts
+    , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
+    , let res = Just (x', e'', ts++ts')
+    = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')])
+      res
+
+exprIsLambda_maybe _ _e
+    = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e])
+      Nothing
+
+
+{- *********************************************************************
+*                                                                      *
+              The "push rules"
+*                                                                      *
+************************************************************************
+
+Here we implement the "push rules" from FC papers:
+
+* The push-argument rules, where we can move a coercion past an argument.
+  We have
+      (fun |> co) arg
+  and we want to transform it to
+    (fun arg') |> co'
+  for some suitable co' and tranformed arg'.
+
+* The PushK rule for data constructors.  We have
+       (K e1 .. en) |> co
+  and we want to tranform to
+       (K e1' .. en')
+  by pushing the coercion into the oarguments
+-}
+
+pushCoArgs :: Coercion -> [CoreArg] -> Maybe ([CoreArg], Coercion)
+pushCoArgs co []         = return ([], co)
+pushCoArgs co (arg:args) = do { (arg',  co1) <- pushCoArg  co  arg
+                              ; (args', co2) <- pushCoArgs co1 args
+                              ; return (arg':args', co2) }
+
+pushCoArg :: Coercion -> CoreArg -> Maybe (CoreArg, Coercion)
+-- We have (fun |> co) arg, and we want to transform it to
+--         (fun arg) |> co
+-- This may fail, e.g. if (fun :: N) where N is a newtype
+-- C.f. simplCast in Simplify.hs
+-- 'co' is always Representational
+
+pushCoArg co (Type ty) = do { (ty', co') <- pushCoTyArg co ty
+                            ; return (Type ty', co') }
+pushCoArg co val_arg   = do { (arg_co, co') <- pushCoValArg co
+                            ; return (mkCast val_arg arg_co, co') }
+
+pushCoTyArg :: Coercion -> Type -> Maybe (Type, Coercion)
+-- We have (fun |> co) @ty
+-- Push the coercion through to return
+--         (fun @ty') |> co'
+-- 'co' is always Representational
+pushCoTyArg co ty
+  | tyL `eqType` tyR
+  = Just (ty, mkRepReflCo (piResultTy tyR ty))
+
+  | isForAllTy tyL
+  = ASSERT2( isForAllTy tyR, ppr co $$ ppr ty )
+    Just (ty `mkCastTy` mkSymCo co1, co2)
+
+  | otherwise
+  = Nothing
+  where
+    Pair tyL tyR = coercionKind co
+       -- co :: tyL ~ tyR
+       -- tyL = forall (a1 :: k1). ty1
+       -- tyR = forall (a2 :: k2). ty2
+
+    co1 = mkNthCo 0 co
+       -- co1 :: k1 ~ k2
+       -- Note that NthCo can extract an equality between the kinds
+       -- of the types related by a coercion between forall-types.
+       -- See the NthCo case in CoreLint.
+
+    co2 = mkInstCo co (mkCoherenceLeftCo (mkNomReflCo ty) co1)
+        -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ]
+        -- Arg of mkInstCo is always nominal, hence mkNomReflCo
+
+pushCoValArg :: Coercion -> Maybe (Coercion, Coercion)
+-- We have (fun |> co) arg
+-- Push the coercion through to return
+--         (fun (arg |> co_arg)) |> co_res
+-- 'co' is always Representational
+pushCoValArg co
+  | tyL `eqType` tyR
+  = Just (mkRepReflCo arg, mkRepReflCo res)
+
+  | isFunTy tyL
+  , (co1, co2) <- decomposeFunCo co
+              -- If   co  :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)
+              -- then co1 :: tyL1 ~ tyR1
+              --      co2 :: tyL2 ~ tyR2
+  = ASSERT2( isFunTy tyR, ppr co $$ ppr arg )
+    Just (mkSymCo co1, co2)
+
+  | otherwise
+  = Nothing
+  where
+    (arg, res)   = splitFunTy tyR
+    Pair tyL tyR = coercionKind co
+
+pushCoercionIntoLambda
+    :: InScopeSet -> Var -> CoreExpr -> Coercion -> Maybe (Var, CoreExpr)
+-- This implements the Push rule from the paper on coercions
+--    (\x. e) |> co
+-- ===>
+--    (\x'. e |> co')
+pushCoercionIntoLambda in_scope x e co
+    | ASSERT(not (isTyVar x) && not (isCoVar x)) True
+    , Pair s1s2 t1t2 <- coercionKind co
+    , Just (_s1,_s2) <- splitFunTy_maybe s1s2
+    , Just (t1,_t2) <- splitFunTy_maybe t1t2
+    = let (co1, co2) = decomposeFunCo co
+          -- Should we optimize the coercions here?
+          -- Otherwise they might not match too well
+          x' = x `setIdType` t1
+          in_scope' = in_scope `extendInScopeSet` x'
+          subst = extendIdSubst (mkEmptySubst in_scope')
+                                x
+                                (mkCast (Var x') co1)
+      in Just (x', substExpr (text "pushCoercionIntoLambda") subst e `mkCast` co2)
+    | otherwise
+    = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e))
+      Nothing
+
+pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion
+              -> Maybe (DataCon
+                       , [Type]      -- Universal type args
+                       , [CoreExpr]) -- All other args incl existentials
+-- Implement the KPush reduction rule as described in "Down with kinds"
+-- The transformation applies iff we have
+--      (C e1 ... en) `cast` co
+-- where co :: (T t1 .. tn) ~ to_ty
+-- The left-hand one must be a T, because exprIsConApp returned True
+-- but the right-hand one might not be.  (Though it usually will.)
+pushCoDataCon dc dc_args co
+  | isReflCo co || from_ty `eqType` to_ty  -- try cheap test first
+  , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args
+  = Just (dc, map exprToType univ_ty_args, rest_args)
+
+  | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty
+  , to_tc == dataConTyCon dc
+        -- These two tests can fail; we might see
+        --      (C x y) `cast` (g :: T a ~ S [a]),
+        -- where S is a type function.  In fact, exprIsConApp
+        -- will probably not be called in such circumstances,
+        -- but there't nothing wrong with it
+
+  = let
+        tc_arity       = tyConArity to_tc
+        dc_univ_tyvars = dataConUnivTyVars dc
+        dc_ex_tyvars   = dataConExTyVars dc
+        arg_tys        = dataConRepArgTys dc
+
+        non_univ_args  = dropList dc_univ_tyvars dc_args
+        (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args
+
+        -- Make the "Psi" from the paper
+        omegas = decomposeCo tc_arity co
+        (psi_subst, to_ex_arg_tys)
+          = liftCoSubstWithEx Representational
+                              dc_univ_tyvars
+                              omegas
+                              dc_ex_tyvars
+                              (map exprToType ex_args)
+
+          -- Cast the value arguments (which include dictionaries)
+        new_val_args = zipWith cast_arg arg_tys val_args
+        cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty)
+
+        to_ex_args = map Type to_ex_arg_tys
+
+        dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,
+                         ppr arg_tys, ppr dc_args,
+                         ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ]
+    in
+    ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc )
+    ASSERT2( equalLength val_args arg_tys, dump_doc )
+    Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)
+
+  | otherwise
+  = Nothing
+
+  where
+    Pair from_ty to_ty = coercionKind co
+
+collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)
+-- Collect lambda binders, pushing coercions inside if possible
+-- E.g.   (\x.e) |> g         g :: <Int> -> blah
+--        = (\x. e |> Nth 1 g)
+--
+-- That is,
+--
+-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g)
+collectBindersPushingCo e
+  = go [] e
+  where
+    -- Peel off lambdas until we hit a cast.
+    go :: [Var] -> CoreExpr -> ([Var], CoreExpr)
+    -- The accumulator is in reverse order
+    go bs (Lam b e)   = go (b:bs) e
+    go bs (Cast e co) = go_c bs e co
+    go bs e           = (reverse bs, e)
+
+    -- We are in a cast; peel off casts until we hit a lambda.
+    go_c :: [Var] -> CoreExpr -> Coercion -> ([Var], CoreExpr)
+    -- (go_c bs e c) is same as (go bs e (e |> c))
+    go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2)
+    go_c bs (Lam b e)    co  = go_lam bs b e co
+    go_c bs e            co  = (reverse bs, mkCast e co)
+
+    -- We are in a lambda under a cast; peel off lambdas and build a
+    -- new coercion for the body.
+    go_lam :: [Var] -> Var -> CoreExpr -> Coercion -> ([Var], CoreExpr)
+    -- (go_lam bs b e c) is same as (go_c bs (\b.e) c)
+    go_lam bs b e co
+      | isTyVar b
+      , let Pair tyL tyR = coercionKind co
+      , ASSERT( isForAllTy tyL )
+        isForAllTy tyR
+      , isReflCo (mkNthCo 0 co)  -- See Note [collectBindersPushingCo]
+      = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b)))
+
+      | isId b
+      , let Pair tyL tyR = coercionKind co
+      , ASSERT( isFunTy tyL) isFunTy tyR
+      , (co_arg, co_res) <- decomposeFunCo co
+      , isReflCo co_arg  -- See Note [collectBindersPushingCo]
+      = go_c (b:bs) e co_res
+
+      | otherwise = (reverse bs, mkCast (Lam b e) co)
+
+{- Note [collectBindersPushingCo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We just look for coercions of form
+   <type> -> blah
+(and similarly for foralls) to keep this function simple.  We could do
+more elaborate stuff, but it'd involve substitution etc.
+-}
index f2485f3..640c7f1 100644 (file)
@@ -17,40 +17,29 @@ module CoreSubst (
         substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
         substUnfolding, substUnfoldingSC,
         lookupIdSubst, lookupTCvSubst, substIdOcc,
-        substTickish, substDVarSet,
+        substTickish, substDVarSet, substIdInfo,
 
         -- ** Operations on substitutions
         emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,
         extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList,
         extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,
         addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds,
-        isInScope, setInScope,
+        isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst,
         delBndr, delBndrs,
 
         -- ** Substituting and cloning binders
-        substBndr, substBndrs, substRecBndrs,
+        substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr,
         cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
 
-        -- ** Simple expression optimiser
-        simpleOptPgm, simpleOptExpr, simpleOptExprWith,
-        exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,
-        pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo
     ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} CoreArity ( etaExpandToJoinPoint )
-                        -- Needed for simpleOptPgm to convert bindings to join
-                        -- points, but CoreArity uses substitutions throughout
 
 import CoreSyn
 import CoreFVs
 import CoreSeq
 import CoreUtils
-import Literal  ( Literal(MachStr) )
-import qualified Data.ByteString as BS
-import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
-
 import qualified Type
 import qualified Coercion
 
@@ -59,12 +48,7 @@ import Type     hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstLis
                        , isInScope, substTyVarBndr, cloneTyVarBndr )
 import Coercion hiding ( substCo, substCoVarBndr )
 
-import TyCon       ( tyConArity )
-import DataCon
 import PrelNames
-import OptCoercion ( optCoercion )
-import PprCore     ( pprCoreBindings, pprRules )
-import Module      ( Module )
 import VarSet
 import VarEnv
 import Id
@@ -73,18 +57,11 @@ import Var
 import IdInfo
 import UniqSupply
 import Maybes
-import ErrUtils
-import DynFlags
-import BasicTypes ( isAlwaysActive )
 import Util
-import Pair
 import Outputable
 import PprCore          ()              -- Instances
-import FastString
-
 import Data.List
 
-import TysWiredIn
 
 
 {-
@@ -724,18 +701,6 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
     (subst', bndrs') = substBndrs subst bndrs
 
 ------------------
-substVects :: Subst -> [CoreVect] -> [CoreVect]
-substVects subst = map (substVect subst)
-
-------------------
-substVect :: Subst -> CoreVect -> CoreVect
-substVect subst  (Vect v rhs)        = Vect v (simpleOptExprWith subst rhs)
-substVect _subst vd@(NoVect _)       = vd
-substVect _subst vd@(VectType _ _ _) = vd
-substVect _subst vd@(VectClass _)    = vd
-substVect _subst vd@(VectInst _)     = vd
-
-------------------
 substDVarSet :: Subst -> DVarSet -> DVarSet
 substDVarSet subst fvs
   = mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs
@@ -793,1048 +758,5 @@ analyser, so it's possible that the worker is not even in scope any more.
 
 In all all these cases we simply drop the special case, returning to
 InlVanilla.  The WARN is just so I can see if it happens a lot.
-
-
-************************************************************************
-*                                                                      *
-        The Simple Optimiser
-*                                                                      *
-************************************************************************
-
-Note [The simple optimiser]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The simple optimiser is a lightweight, pure (non-monadic) function
-that rapidly does a lot of simple optimisations, including
-
-  - inlining things that occur just once,
-      or whose RHS turns out to be trivial
-  - beta reduction
-  - case of known constructor
-  - dead code elimination
-
-It does NOT do any call-site inlining; it only inlines a function if
-it can do so unconditionally, dropping the binding.  It thereby
-guarantees to leave no un-reduced beta-redexes.
-
-It is careful to follow the guidance of "Secrets of the GHC inliner",
-and in particular the pre-inline-unconditionally and
-post-inline-unconditionally story, to do effective beta reduction on
-functions called precisely once, without repeatedly optimising the same
-expression.  In fact, the simple optimiser is a good example of this
-little dance in action; the full Simplifier is a lot more complicated.
-
--}
-
-simpleOptExpr :: CoreExpr -> CoreExpr
--- See Note [The simple optimiser]
--- Do simple optimisation on an expression
--- The optimisation is very straightforward: just
--- inline non-recursive bindings that are used only once,
--- or where the RHS is trivial
---
--- We also inline bindings that bind a Eq# box: see
--- See Note [Getting the map/coerce RULE to work].
---
--- Also we convert functions to join points where possible (as
--- the occurrence analyser does most of the work anyway).
---
--- The result is NOT guaranteed occurrence-analysed, because
--- in  (let x = y in ....) we substitute for x; so y's occ-info
--- may change radically
-
-simpleOptExpr expr
-  = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
-    simpleOptExprWith init_subst expr
-  where
-    init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
-        -- It's potentially important to make a proper in-scope set
-        -- Consider  let x = ..y.. in \y. ...x...
-        -- Then we should remember to clone y before substituting
-        -- for x.  It's very unlikely to occur, because we probably
-        -- won't *be* substituting for x if it occurs inside a
-        -- lambda.
-        --
-        -- It's a bit painful to call exprFreeVars, because it makes
-        -- three passes instead of two (occ-anal, and go)
-
-simpleOptExprWith :: Subst -> InExpr -> OutExpr
--- See Note [The simple optimiser]
-simpleOptExprWith subst expr
-  = simple_opt_expr init_env (occurAnalyseExpr expr)
-  where
-    init_env = SOE { soe_inl = emptyVarEnv, soe_subst = subst }
-
-----------------------
-simpleOptPgm :: DynFlags -> Module
-             -> CoreProgram -> [CoreRule] -> [CoreVect]
-             -> IO (CoreProgram, [CoreRule], [CoreVect])
--- See Note [The simple optimiser]
-simpleOptPgm dflags this_mod binds rules vects
-  = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
-                       (pprCoreBindings occ_anald_binds $$ pprRules rules );
-
-       ; return (reverse binds', rules', vects') }
-  where
-    occ_anald_binds  = occurAnalysePgm this_mod (\_ -> False) {- No rules active -}
-                                       rules vects emptyVarSet binds
-
-    (final_env, binds') = foldl do_one (emptyEnv, []) occ_anald_binds
-    final_subst = soe_subst final_env
-
-    rules' = substRulesForImportedIds final_subst rules
-    vects' = substVects final_subst vects
-             -- We never unconditionally inline into rules,
-             -- hence pasing just a substitution
-
-    do_one (env, binds') bind
-      = case simple_opt_bind env bind of
-          (env', Nothing)    -> (env', binds')
-          (env', Just bind') -> (env', bind':binds')
-
--- In these functions the substitution maps InVar -> OutExpr
-
-----------------------
-type SimpleClo = (SimpleOptEnv, InExpr)
-
-data SimpleOptEnv
-  = SOE { soe_inl   :: IdEnv SimpleClo
-             -- Deals with preInlineUnconditionally; things
-             -- that occur exactly once and are inlined
-             -- without having first been simplified
-
-        , soe_subst :: Subst
-             -- Deals with cloning; includes the InScopeSet
-        }
-
-instance Outputable SimpleOptEnv where
-  ppr (SOE { soe_inl = inl, soe_subst = subst })
-    = text "SOE {" <+> vcat [ text "soe_inl   =" <+> ppr inl
-                            , text "soe_subst =" <+> ppr subst ]
-                   <+> text "}"
-
-emptyEnv :: SimpleOptEnv
-emptyEnv = SOE { soe_inl = emptyVarEnv
-               , soe_subst = emptySubst }
-
-soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
-soeZapSubst (SOE { soe_subst = subst })
-  = SOE { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst }
-
-soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
--- Take in-scope set from env1, and the rest from env2
-soeSetInScope (SOE { soe_subst = subst1 })
-              env2@(SOE { soe_subst = subst2 })
-  = env2 { soe_subst = setInScope subst2 (substInScope subst1) }
-
----------------
-simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr
-simple_opt_clo env (e_env, e)
-  = simple_opt_expr (soeSetInScope env e_env) e
-
-simple_opt_expr :: SimpleOptEnv -> InExpr -> OutExpr
-simple_opt_expr env expr
-  = go expr
-  where
-    subst        = soe_subst env
-    in_scope     = substInScope subst
-    in_scope_env = (in_scope, simpleUnfoldingFun)
-
-    go (Var v)
-       | Just clo <- lookupVarEnv (soe_inl env) v
-       = simple_opt_clo env clo
-       | otherwise
-       = lookupIdSubst (text "simpleOptExpr") (soe_subst env) v
-
-    go (App e1 e2)      = simple_app env e1 [(env,e2)]
-    go (Type ty)        = Type     (substTy subst ty)
-    go (Coercion co)    = Coercion (optCoercion (getTCvSubst subst) co)
-    go (Lit lit)        = Lit lit
-    go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
-    go (Cast e co)      | isReflCo co' = go e
-                        | otherwise    = Cast (go e) co'
-                        where
-                          co' = optCoercion (getTCvSubst subst) co
-
-    go (Let bind body) = case simple_opt_bind env bind of
-                           (env', Nothing)   -> simple_opt_expr env' body
-                           (env', Just bind) -> Let bind (simple_opt_expr env' body)
-
-    go lam@(Lam {})     = go_lam env [] lam
-    go (Case e b ty as)
-       -- See Note [Getting the map/coerce RULE to work]
-      | isDeadBinder b
-      , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e'
-      , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as
-      = case altcon of
-          DEFAULT -> go rhs
-          _       -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs
-            where
-              (env', mb_prs) = mapAccumL simple_out_bind env $
-                               zipEqual "simpleOptExpr" bs es
-
-         -- Note [Getting the map/coerce RULE to work]
-      | isDeadBinder b
-      , [(DEFAULT, _, rhs)] <- as
-      , isCoercionType (varType b)
-      , (Var fun, _args) <- collectArgs e
-      , fun `hasKey` coercibleSCSelIdKey
-         -- without this last check, we get #11230
-      = go rhs
-
-      | otherwise
-      = Case e' b' (substTy subst ty)
-                   (map (go_alt env') as)
-      where
-        e' = go e
-        (env', b') = subst_opt_bndr env b
-
-    ----------------------
-    go_alt env (con, bndrs, rhs)
-      = (con, bndrs', simple_opt_expr env' rhs)
-      where
-        (env', bndrs') = subst_opt_bndrs env bndrs
-
-    ----------------------
-    -- go_lam tries eta reduction
-    go_lam env bs' (Lam b e)
-       = go_lam env' (b':bs') e
-       where
-         (env', b') = subst_opt_bndr env b
-    go_lam env bs' e
-       | Just etad_e <- tryEtaReduce bs e' = etad_e
-       | otherwise                         = mkLams bs e'
-       where
-         bs = reverse bs'
-         e' = simple_opt_expr env e
-
-----------------------
--- simple_app collects arguments for beta reduction
-simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr
-
-simple_app env (Var v) as
-  | Just (env', e) <- lookupVarEnv (soe_inl env) v
-  = simple_app (soeSetInScope env env') e as
-
-  | let unf = idUnfolding v
-  , isCompulsoryUnfolding (idUnfolding v)
-  , isAlwaysActive (idInlineActivation v)
-    -- See Note [Unfold compulsory unfoldings in LHSs]
-  = simple_app (soeZapSubst env) (unfoldingTemplate unf) as
-
-  | otherwise
-  , let out_fn = lookupIdSubst (text "simple_app") (soe_subst env) v
-  = finish_app env out_fn as
-
-simple_app env (App e1 e2) as
-  = simple_app env e1 ((env, e2) : as)
-
-simple_app env (Lam b e) (a:as)
-  = wrapLet mb_pr (simple_app env' e as)
-  where
-     (env', mb_pr) = simple_bind_pair env b Nothing a
-
-simple_app env (Tick t e) as
-  -- Okay to do "(Tick t e) x ==> Tick t (e x)"?
-  | t `tickishScopesLike` SoftScope
-  = mkTick t $ simple_app env e as
-
-simple_app env e as
-  = finish_app env (simple_opt_expr env e) as
-
-finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
-finish_app _ fun []
-  = fun
-finish_app env fun (arg:args)
-  = finish_app env (App fun (simple_opt_clo env arg)) args
-
-----------------------
-simple_opt_bind :: SimpleOptEnv -> InBind
-                -> (SimpleOptEnv, Maybe OutBind)
-simple_opt_bind env (NonRec b r)
-  = (env', case mb_pr of
-            Nothing    -> Nothing
-            Just (b,r) -> Just (NonRec b r))
-  where
-    (b', r') = convert_if_marked b r
-    (env', mb_pr) = simple_bind_pair env b' Nothing (env,r')
-
-simple_opt_bind env (Rec prs)
-  = (env'', res_bind)
-  where
-    res_bind          = Just (Rec (reverse rev_prs'))
-    prs'              = map (uncurry convert_if_marked) prs
-    (env', bndrs')    = subst_opt_bndrs env (map fst prs')
-    (env'', rev_prs') = foldl do_pr (env', []) (prs' `zip` bndrs')
-    do_pr (env, prs) ((b,r), b')
-       = (env', case mb_pr of
-                  Just pr -> pr : prs
-                  Nothing -> prs)
-       where
-         (env', mb_pr) = simple_bind_pair env b (Just b') (env,r)
-
-convert_if_marked :: InVar -> InExpr -> (InVar, InExpr)
-convert_if_marked bndr rhs
-  | isId bndr
-  , AlwaysTailCalled ar <- tailCallInfo (idOccInfo bndr)
-    -- Marked to become a join point
-  , (bndrs, body) <- etaExpandToJoinPoint ar rhs
-  = -- Tail call info now unnecessary
-    (zapIdTailCallInfo (bndr `asJoinId` ar), mkLams bndrs body)
-  | otherwise
-  = (bndr, rhs)
-
-----------------------
-simple_bind_pair :: SimpleOptEnv
-                 -> InVar -> Maybe OutVar
-                 -> SimpleClo
-                 -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
-    -- (simple_bind_pair subst in_var out_rhs)
-    --   either extends subst with (in_var -> out_rhs)
-    --   or     returns Nothing
-simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
-                 in_bndr mb_out_bndr clo@(rhs_env, in_rhs)
-  | Type ty <- in_rhs        -- let a::* = TYPE ty in <body>
-  , let out_ty = substTy (soe_subst rhs_env) ty
-  = ASSERT( isTyVar in_bndr )
-    (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
-
-  | Coercion co <- in_rhs
-  , let out_co = optCoercion (getTCvSubst (soe_subst rhs_env)) co
-  = ASSERT( isCoVar in_bndr )
-    (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
-
-  | pre_inline_unconditionally
-  = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing)
-
-  | otherwise
-  = simple_out_bind_pair env in_bndr mb_out_bndr
-                         (simple_opt_clo env clo)
-                         occ active stable_unf
-  where
-    stable_unf = isStableUnfolding (idUnfolding in_bndr)
-    active     = isAlwaysActive (idInlineActivation in_bndr)
-    occ        = idOccInfo in_bndr
-
-    pre_inline_unconditionally :: Bool
-    pre_inline_unconditionally
-       | isCoVar in_bndr          = False    -- See Note [Do not inline CoVars unconditionally]
-       | isExportedId in_bndr     = False    --     in SimplUtils
-       | stable_unf               = False
-       | not active               = False    -- Note [Inline prag in simplOpt]
-       | not (safe_to_inline occ) = False
-       | otherwise = True
-
-        -- Unconditionally safe to inline
-    safe_to_inline :: OccInfo -> Bool
-    safe_to_inline (IAmALoopBreaker {}) = False
-    safe_to_inline IAmDead              = True
-    safe_to_inline occ@(OneOcc {})      =  not (occ_in_lam occ)
-                                        && occ_one_br occ
-    safe_to_inline (ManyOccs {})        = False
-
--------------------
-simple_out_bind :: SimpleOptEnv -> (InVar, OutExpr)
-                -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
-simple_out_bind env@(SOE { soe_subst = subst }) (in_bndr, out_rhs)
-  | Type out_ty <- out_rhs
-  = ASSERT( isTyVar in_bndr )
-    (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
-
-  | Coercion out_co <- out_rhs
-  = ASSERT( isCoVar in_bndr )
-    (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
-
-  | otherwise
-  = simple_out_bind_pair env in_bndr Nothing out_rhs
-                         (idOccInfo in_bndr) True False
-
--------------------
-simple_out_bind_pair :: SimpleOptEnv
-                     -> InId -> Maybe OutId -> OutExpr
-                     -> OccInfo -> Bool -> Bool
-                     -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
-simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
-                     occ_info active stable_unf
-  | post_inline_unconditionally
-  = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs }
-    , Nothing)
-
-  | otherwise
-  = ( env', Just (out_bndr, out_rhs) )
-  where
-    (env', bndr1) = case mb_out_bndr of
-                      Just out_bndr -> (env, out_bndr)
-                      Nothing       -> subst_opt_bndr env in_bndr
-    out_bndr = add_info env' in_bndr bndr1
-
-    post_inline_unconditionally :: Bool
-    post_inline_unconditionally
-       | not active                  = False
-       | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline
-                                             -- because it might be referred to "earlier"
-       | stable_unf                  = False -- Note [Stable unfoldings and postInlineUnconditionally]
-       | isExportedId in_bndr        = False -- Note [Exported Ids and trivial RHSs]
-       | exprIsTrivial out_rhs       = True
-       | coercible_hack              = True
-       | otherwise                   = False
-
-    -- See Note [Getting the map/coerce RULE to work]
-    coercible_hack | (Var fun, args) <- collectArgs out_rhs
-                   , Just dc <- isDataConWorkId_maybe fun
-                   , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey
-                   = all exprIsTrivial args
-                   | otherwise
-                   = False
-
-{- Note [Exported Ids and trivial RHSs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We obviously do not want to unconditionally inline an Id that is exported.
-In SimplUtils, Note [Top level and postInlineUnconditionally], we
-explain why we don't inline /any/ top-level things unconditionally, even
-trivial ones.  But we do here!  Why?  In the simple optimiser
-
-  * We do no rule rewrites
-  * We do no call-site inlining
-
-Those differences obviate the reasons for not inlining a trivial rhs,
-and increase the benefit for doing so.  So we unconditionally inline trivial
-rhss here.
--}
-
-----------------------
-subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar])
-subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs
-
-subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar)
-subst_opt_bndr env bndr
-  | isTyVar bndr  = (env { soe_subst = subst_tv }, tv')
-  | isCoVar bndr  = (env { soe_subst = subst_cv }, cv')
-  | otherwise     = subst_opt_id_bndr env bndr
-  where
-    subst           = soe_subst env
-    (subst_tv, tv') = substTyVarBndr subst bndr
-    (subst_cv, cv') = substCoVarBndr subst bndr
-
-subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId)
--- Nuke all fragile IdInfo, unfolding, and RULES;
---    it gets added back later by add_info
--- Rather like SimplEnv.substIdBndr
---
--- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr
--- carefully does not do) because simplOptExpr invalidates it
-
-subst_opt_id_bndr (SOE { soe_subst = subst, soe_inl = inl }) old_id
-  = (SOE { soe_subst = new_subst, soe_inl = new_inl }, new_id)
-  where
-    Subst in_scope id_subst tv_subst cv_subst = subst
-
-    id1    = uniqAway in_scope old_id
-    id2    = setIdType id1 (substTy subst (idType old_id))
-    new_id = zapFragileIdInfo id2
-             -- Zaps rules, worker-info, unfolding, and fragile OccInfo
-             -- The unfolding and rules will get added back later, by add_info
-
-    new_in_scope = in_scope `extendInScopeSet` new_id
-
-    no_change = new_id == old_id
-
-        -- Extend the substitution if the unique has changed,
-        -- See the notes with substTyVarBndr for the delSubstEnv
-    new_id_subst
-      | no_change = delVarEnv id_subst old_id
-      | otherwise = extendVarEnv id_subst old_id (Var new_id)
-
-    new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst
-    new_inl   = delVarEnv inl old_id
-
-----------------------
-add_info :: SimpleOptEnv -> InVar -> OutVar -> OutVar
-add_info env old_bndr new_bndr
- | isTyVar old_bndr = new_bndr
- | otherwise        = maybeModifyIdInfo mb_new_info new_bndr
- where
-   subst = soe_subst env
-   mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
-
-simpleUnfoldingFun :: IdUnfoldingFun
-simpleUnfoldingFun id
-  | isAlwaysActive (idInlineActivation id) = idUnfolding id
-  | otherwise                              = noUnfolding
-
-wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
-wrapLet Nothing      body = body
-wrapLet (Just (b,r)) body = Let (NonRec b r) body
-
-{-
-Note [Inline prag in simplOpt]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If there's an INLINE/NOINLINE pragma that restricts the phase in
-which the binder can be inlined, we don't inline here; after all,
-we don't know what phase we're in.  Here's an example
-
-  foo :: Int -> Int -> Int
-  {-# INLINE foo #-}
-  foo m n = inner m
-     where
-       {-# INLINE [1] inner #-}
-       inner m = m+n
-
-  bar :: Int -> Int
-  bar n = foo n 1
-
-When inlining 'foo' in 'bar' we want the let-binding for 'inner'
-to remain visible until Phase 1
-
-Note [Unfold compulsory unfoldings in LHSs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When the user writes `RULES map coerce = coerce` as a rule, the rule
-will only ever match if simpleOptExpr replaces coerce by its unfolding
-on the LHS, because that is the core that the rule matching engine
-will find. So do that for everything that has a compulsory
-unfolding. Also see Note [Desugaring coerce as cast] in Desugar.
-
-However, we don't want to inline 'seq', which happens to also have a
-compulsory unfolding, so we only do this unfolding only for things
-that are always-active.  See Note [User-defined RULES for seq] in MkId.
-
-Note [Getting the map/coerce RULE to work]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We wish to allow the "map/coerce" RULE to fire:
-
-  {-# RULES "map/coerce" map coerce = coerce #-}
-
-The naive core produced for this is
-
-  forall a b (dict :: Coercible * a b).
-    map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict'
-
-  where dict' :: Coercible [a] [b]
-        dict' = ...
-
-This matches literal uses of `map coerce` in code, but that's not what we
-want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int)
-too. Some of this is addressed by compulsorily unfolding coerce on the LHS,
-yielding
-
-  forall a b (dict :: Coercible * a b).
-    map @a @b (\(x :: a) -> case dict of
-      MkCoercible (co :: a ~R# b) -> x |> co) = ...
-
-Getting better. But this isn't exactly what gets produced. This is because
-Coercible essentially has ~R# as a superclass, and superclasses get eagerly
-extracted during solving. So we get this:
-
-  forall a b (dict :: Coercible * a b).
-    case Coercible_SCSel @* @a @b dict of
-      _ [Dead] -> map @a @b (\(x :: a) -> case dict of
-                               MkCoercible (co :: a ~R# b) -> x |> co) = ...
-
-Unfortunately, this still abstracts over a Coercible dictionary. We really
-want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce,
-which transforms the above to (see also Note [Desugaring coerce as cast] in
-Desugar)
-
-  forall a b (co :: a ~R# b).
-    let dict = MkCoercible @* @a @b co in
-    case Coercible_SCSel @* @a @b dict of
-      _ [Dead] -> map @a @b (\(x :: a) -> case dict of
-         MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ...
-
-Now, we need simpleOptExpr to fix this up. It does so by taking three
-separate actions:
-  1. Inline certain non-recursive bindings. The choice whether to inline
-     is made in simple_bind_pair. Note the rather specific check for
-     MkCoercible in there.
-
-  2. Stripping case expressions like the Coercible_SCSel one.
-     See the `Case` case of simple_opt_expr's `go` function.
-
-  3. Look for case expressions that unpack something that was
-     just packed and inline them. This is also done in simple_opt_expr's
-     `go` function.
-
-This is all a fair amount of special-purpose hackery, but it's for
-a good cause. And it won't hurt other RULES and such that it comes across.
-
-
-************************************************************************
-*                                                                      *
-         exprIsConApp_maybe
-*                                                                      *
-************************************************************************
-
-Note [exprIsConApp_maybe]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-exprIsConApp_maybe is a very important function.  There are two principal
-uses:
-  * case e of { .... }
-  * cls_op e, where cls_op is a class operation
-
-In both cases you want to know if e is of form (C e1..en) where C is
-a data constructor.
-
-However e might not *look* as if
-
-
-Note [exprIsConApp_maybe on literal strings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #9400 and #13317.
-
-Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core
-they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or
-unpackCStringUtf8# when the literal contains multi-byte UTF8 characters.
-
-For optimizations we want to be able to treat it as a list, so they can be
-decomposed when used in a case-statement. exprIsConApp_maybe detects those
-calls to unpackCString# and returns:
-
-Just (':', [Char], ['a', unpackCString# "bc"]).
-
-We need to be careful about UTF8 strings here. ""# contains a ByteString, so
-we must parse it back into a FastString to split off the first character.
-That way we can treat unpackCString# and unpackCStringUtf8# in the same way.
-
-We must also be caeful about
-   lvl = "foo"#
-   ...(unpackCString# lvl)...
-to ensure that we see through the let-binding for 'lvl'.  Hence the
-(exprIsLiteral_maybe .. arg) in the guard before the call to
-dealWithStringLiteral.
-
-Note [Push coercions in exprIsConApp_maybe]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In Trac #13025 I found a case where we had
-    op (df @t1 @t2)     -- op is a ClassOp
-where
-    df = (/\a b. K e1 e2) |> g
-
-To get this to come out we need to simplify on the fly
-   ((/\a b. K e1 e2) |> g) @t1 @t2
-
-Hence the use of pushCoArgs.
 -}
 
-data ConCont = CC [CoreExpr] Coercion
-                  -- Substitution already applied
-
--- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is
--- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
--- where t1..tk are the *universally-qantified* type args of 'dc'
-exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
-exprIsConApp_maybe (in_scope, id_unf) expr
-  = go (Left in_scope) expr (CC [] (mkRepReflCo (exprType expr)))
-  where
-    go :: Either InScopeSet Subst
-             -- Left in-scope  means "empty substitution"
-             -- Right subst    means "apply this substitution to the CoreExpr"
-       -> CoreExpr -> ConCont
-       -> Maybe (DataCon, [Type], [CoreExpr])
-    go subst (Tick t expr) cont
-       | not (tickishIsCode t) = go subst expr cont
-    go subst (Cast expr co1) (CC args co2)
-       | Just (args', co1') <- pushCoArgs (subst_co subst co1) args
-            -- See Note [Push coercions in exprIsConApp_maybe]
-       = go subst expr (CC args' (co1' `mkTransCo` co2))
-    go subst (App fun arg) (CC args co)
-       = go subst fun (CC (subst_arg subst arg : args) co)
-    go subst (Lam var body) (CC (arg:args) co)
-       | exprIsTrivial arg          -- Don't duplicate stuff!
-       = go (extend subst var arg) body (CC args co)
-    go (Right sub) (Var v) cont
-       = go (Left (substInScope sub))
-            (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v)
-            cont
-
-    go (Left in_scope) (Var fun) cont@(CC args co)
-
-        | Just con <- isDataConWorkId_maybe fun
-        , count isValArg args == idArity fun
-        = pushCoDataCon con args co
-
-        -- Look through dictionary functions; see Note [Unfolding DFuns]
-        | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding
-        , bndrs `equalLength` args    -- See Note [DFun arity check]
-        , let subst = mkOpenSubst in_scope (bndrs `zip` args)
-        = pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co
-
-        -- Look through unfoldings, but only arity-zero one;
-        -- if arity > 0 we are effectively inlining a function call,
-        -- and that is the business of callSiteInline.
-        -- In practice, without this test, most of the "hits" were
-        -- CPR'd workers getting inlined back into their wrappers,
-        | idArity fun == 0
-        , Just rhs <- expandUnfolding_maybe unfolding
-        , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs)
-        = go (Left in_scope') rhs cont
-
-        -- See Note [exprIsConApp_maybe on literal strings]
-        | (fun `hasKey` unpackCStringIdKey) ||
-          (fun `hasKey` unpackCStringUtf8IdKey)
-        , [arg]              <- args
-        , Just (MachStr str) <- exprIsLiteral_maybe (in_scope, id_unf) arg
-        = dealWithStringLiteral fun str co
-        where
-          unfolding = id_unf fun
-
-    go _ _ _ = Nothing
-
-    ----------------------------
-    -- Operations on the (Either InScopeSet CoreSubst)
-    -- The Left case is wildly dominant
-    subst_co (Left {}) co = co
-    subst_co (Right s) co = CoreSubst.substCo s co
-
-    subst_arg (Left {}) e = e
-    subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e
-
-    extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)
-    extend (Right s)       v e = Right (extendSubst s v e)
-
-
--- See Note [exprIsConApp_maybe on literal strings]
-dealWithStringLiteral :: Var -> BS.ByteString -> Coercion
-                      -> Maybe (DataCon, [Type], [CoreExpr])
-
--- This is not possible with user-supplied empty literals, MkCore.mkStringExprFS
--- turns those into [] automatically, but just in case something else in GHC
--- generates a string literal directly.
-dealWithStringLiteral _   str co
-  | BS.null str
-  = pushCoDataCon nilDataCon [Type charTy] co
-
-dealWithStringLiteral fun str co
-  = let strFS = mkFastStringByteString str
-
-        char = mkConApp charDataCon [mkCharLit (headFS strFS)]
-        charTail = fastStringToByteString (tailFS strFS)
-
-        -- In singleton strings, just add [] instead of unpackCstring# ""#.
-        rest = if BS.null charTail
-                 then mkConApp nilDataCon [Type charTy]
-                 else App (Var fun)
-                          (Lit (MachStr charTail))
-
-    in pushCoDataCon consDataCon [Type charTy, char, rest] co
-
-{-
-Note [Unfolding DFuns]
-~~~~~~~~~~~~~~~~~~~~~~
-DFuns look like
-
-  df :: forall a b. (Eq a, Eq b) -> Eq (a,b)
-  df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b)
-                               ($c2 a b d_a d_b)
-
-So to split it up we just need to apply the ops $c1, $c2 etc
-to the very same args as the dfun.  It takes a little more work
-to compute the type arguments to the dictionary constructor.
-
-Note [DFun arity check]
-~~~~~~~~~~~~~~~~~~~~~~~
-Here we check that the total number of supplied arguments (inclding
-type args) matches what the dfun is expecting.  This may be *less*
-than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
--}
-
-exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
--- Same deal as exprIsConApp_maybe, but much simpler
--- Nevertheless we do need to look through unfoldings for
--- Integer and string literals, which are vigorously hoisted to top level
--- and not subsequently inlined
-exprIsLiteral_maybe env@(_, id_unf) e
-  = case e of
-      Lit l     -> Just l
-      Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?
-      Var v     | Just rhs <- expandUnfolding_maybe (id_unf v)
-                -> exprIsLiteral_maybe env rhs
-      _         -> Nothing
-
-{-
-Note [exprIsLambda_maybe]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-exprIsLambda_maybe will, given an expression `e`, try to turn it into the form
-`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through
-casts (using the Push rule), and it unfolds function calls if the unfolding
-has a greater arity than arguments are present.
-
-Currently, it is used in Rules.match, and is required to make
-"map coerce = coerce" match.
--}
-
-exprIsLambda_maybe :: InScopeEnv -> CoreExpr
-                      -> Maybe (Var, CoreExpr,[Tickish Id])
-    -- See Note [exprIsLambda_maybe]
-
--- The simple case: It is a lambda already
-exprIsLambda_maybe _ (Lam x e)
-    = Just (x, e, [])
-
--- Still straightforward: Ticks that we can float out of the way
-exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e)
-    | tickishFloatable t
-    , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e
-    = Just (x, e, t:ts)
-
--- Also possible: A casted lambda. Push the coercion inside
-exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
-    | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e
-    -- Only do value lambdas.
-    -- this implies that x is not in scope in gamma (makes this code simpler)
-    , not (isTyVar x) && not (isCoVar x)
-    , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True
-    , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co
-    , let res = Just (x',e',ts)
-    = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])
-      res
-
--- Another attempt: See if we find a partial unfolding
-exprIsLambda_maybe (in_scope_set, id_unf) e
-    | (Var f, as, ts) <- collectArgsTicks tickishFloatable e
-    , idArity f > count isValArg as
-    -- Make sure there is hope to get a lambda
-    , Just rhs <- expandUnfolding_maybe (id_unf f)
-    -- Optimize, for beta-reduction
-    , let e' =  simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as)
-    -- Recurse, because of possible casts
-    , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
-    , let res = Just (x', e'', ts++ts')
-    = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')])
-      res
-
-exprIsLambda_maybe _ _e
-    = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e])
-      Nothing
-
-
-{- *********************************************************************
-*                                                                      *
-              The "push rules"
-*                                                                      *
-************************************************************************
-
-Here we implement the "push rules" from FC papers:
-
-* The push-argument rules, where we can move a coercion past an argument.
-  We have
-      (fun |> co) arg
-  and we want to transform it to
-    (fun arg') |> co'
-  for some suitable co' and tranformed arg'.
-
-* The PushK rule for data constructors.  We have
-       (K e1 .. en) |> co
-  and we want to tranform to
-       (K e1' .. en')
-  by pushing the coercion into the oarguments
--}
-
-pushCoArgs :: Coercion -> [CoreArg] -> Maybe ([CoreArg], Coercion)
-pushCoArgs co []         = return ([], co)
-pushCoArgs co (arg:args) = do { (arg',  co1) <- pushCoArg  co  arg
-                              ; (args', co2) <- pushCoArgs co1 args
-                              ; return (arg':args', co2) }
-
-pushCoArg :: Coercion -> CoreArg -> Maybe (CoreArg, Coercion)
--- We have (fun |> co) arg, and we want to transform it to
---         (fun arg) |> co
--- This may fail, e.g. if (fun :: N) where N is a newtype
--- C.f. simplCast in Simplify.hs
--- 'co' is always Representational
-
-pushCoArg co (Type ty) = do { (ty', co') <- pushCoTyArg co ty
-                            ; return (Type ty', co') }
-pushCoArg co val_arg   = do { (arg_co, co') <- pushCoValArg co
-                            ; return (mkCast val_arg arg_co, co') }
-
-pushCoTyArg :: Coercion -> Type -> Maybe (Type, Coercion)
--- We have (fun |> co) @ty
--- Push the coercion through to return
---         (fun @ty') |> co'
--- 'co' is always Representational
-pushCoTyArg co ty
-  | tyL `eqType` tyR
-  = Just (ty, mkRepReflCo (piResultTy tyR ty))
-
-  | isForAllTy tyL
-  = ASSERT2( isForAllTy tyR, ppr co $$ ppr ty )
-    Just (ty `mkCastTy` mkSymCo co1, co2)
-
-  | otherwise
-  = Nothing
-  where
-    Pair tyL tyR = coercionKind co
-       -- co :: tyL ~ tyR
-       -- tyL = forall (a1 :: k1). ty1
-       -- tyR = forall (a2 :: k2). ty2
-
-    co1 = mkNthCo 0 co
-       -- co1 :: k1 ~ k2
-       -- Note that NthCo can extract an equality between the kinds
-       -- of the types related by a coercion between forall-types.
-       -- See the NthCo case in CoreLint.
-
-    co2 = mkInstCo co (mkCoherenceLeftCo (mkNomReflCo ty) co1)
-        -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ]
-        -- Arg of mkInstCo is always nominal, hence mkNomReflCo
-
-pushCoValArg :: Coercion -> Maybe (Coercion, Coercion)
--- We have (fun |> co) arg
--- Push the coercion through to return
---         (fun (arg |> co_arg)) |> co_res
--- 'co' is always Representational
-pushCoValArg co
-  | tyL `eqType` tyR
-  = Just (mkRepReflCo arg, mkRepReflCo res)
-
-  | isFunTy tyL
-  , (co1, co2) <- decomposeFunCo co
-              -- If   co  :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)
-              -- then co1 :: tyL1 ~ tyR1
-              --      co2 :: tyL2 ~ tyR2
-  = ASSERT2( isFunTy tyR, ppr co $$ ppr arg )
-    Just (mkSymCo co1, co2)
-
-  | otherwise
-  = Nothing
-  where
-    (arg, res)   = splitFunTy tyR
-    Pair tyL tyR = coercionKind co
-
-pushCoercionIntoLambda
-    :: InScopeSet -> Var -> CoreExpr -> Coercion -> Maybe (Var, CoreExpr)
--- This implements the Push rule from the paper on coercions
---    (\x. e) |> co
--- ===>
---    (\x'. e |> co')
-pushCoercionIntoLambda in_scope x e co
-    | ASSERT(not (isTyVar x) && not (isCoVar x)) True
-    , Pair s1s2 t1t2 <- coercionKind co
-    , Just (_s1,_s2) <- splitFunTy_maybe s1s2
-    , Just (t1,_t2) <- splitFunTy_maybe t1t2
-    = let (co1, co2) = decomposeFunCo co
-          -- Should we optimize the coercions here?
-          -- Otherwise they might not match too well
-          x' = x `setIdType` t1
-          in_scope' = in_scope `extendInScopeSet` x'
-          subst = extendIdSubst (mkEmptySubst in_scope')
-                                x
-                                (mkCast (Var x') co1)
-      in Just (x', subst_expr (text "pushCoercionIntoLambda") subst e `mkCast` co2)
-    | otherwise
-    = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e))
-      Nothing
-
-pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion
-              -> Maybe (DataCon
-                       , [Type]      -- Universal type args
-                       , [CoreExpr]) -- All other args incl existentials
--- Implement the KPush reduction rule as described in "Down with kinds"
--- The transformation applies iff we have
---      (C e1 ... en) `cast` co
--- where co :: (T t1 .. tn) ~ to_ty
--- The left-hand one must be a T, because exprIsConApp returned True
--- but the right-hand one might not be.  (Though it usually will.)
-pushCoDataCon dc dc_args co
-  | isReflCo co || from_ty `eqType` to_ty  -- try cheap test first
-  , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args
-  = Just (dc, map exprToType univ_ty_args, rest_args)
-
-  | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty
-  , to_tc == dataConTyCon dc
-        -- These two tests can fail; we might see
-        --      (C x y) `cast` (g :: T a ~ S [a]),
-        -- where S is a type function.  In fact, exprIsConApp
-        -- will probably not be called in such circumstances,
-        -- but there't nothing wrong with it
-
-  = let
-        tc_arity       = tyConArity to_tc
-        dc_univ_tyvars = dataConUnivTyVars dc
-        dc_ex_tyvars   = dataConExTyVars dc
-        arg_tys        = dataConRepArgTys dc
-
-        non_univ_args  = dropList dc_univ_tyvars dc_args
-        (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args
-
-        -- Make the "Psi" from the paper
-        omegas = decomposeCo tc_arity co
-        (psi_subst, to_ex_arg_tys)
-          = liftCoSubstWithEx Representational
-                              dc_univ_tyvars
-                              omegas
-                              dc_ex_tyvars
-                              (map exprToType ex_args)
-
-          -- Cast the value arguments (which include dictionaries)
-        new_val_args = zipWith cast_arg arg_tys val_args
-        cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty)
-
-        to_ex_args = map Type to_ex_arg_tys
-
-        dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,
-                         ppr arg_tys, ppr dc_args,
-                         ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ]
-    in
-    ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc )
-    ASSERT2( equalLength val_args arg_tys, dump_doc )
-    Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)
-
-  | otherwise
-  = Nothing
-
-  where
-    Pair from_ty to_ty = coercionKind co
-
-collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)
--- Collect lambda binders, pushing coercions inside if possible
--- E.g.   (\x.e) |> g         g :: <Int> -> blah
---        = (\x. e |> Nth 1 g)
---
--- That is,
---
--- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g)
-collectBindersPushingCo e
-  = go [] e
-  where
-    -- Peel off lambdas until we hit a cast.
-    go :: [Var] -> CoreExpr -> ([Var], CoreExpr)
-    -- The accumulator is in reverse order
-    go bs (Lam b e)   = go (b:bs) e
-    go bs (Cast e co) = go_c bs e co
-    go bs e           = (reverse bs, e)
-
-    -- We are in a cast; peel off casts until we hit a lambda.
-    go_c :: [Var] -> CoreExpr -> Coercion -> ([Var], CoreExpr)
-    -- (go_c bs e c) is same as (go bs e (e |> c))
-    go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2)
-    go_c bs (Lam b e)    co  = go_lam bs b e co
-    go_c bs e            co  = (reverse bs, mkCast e co)
-
-    -- We are in a lambda under a cast; peel off lambdas and build a
-    -- new coercion for the body.
-    go_lam :: [Var] -> Var -> CoreExpr -> Coercion -> ([Var], CoreExpr)
-    -- (go_lam bs b e c) is same as (go_c bs (\b.e) c)
-    go_lam bs b e co
-      | isTyVar b
-      , let Pair tyL tyR = coercionKind co
-      , ASSERT( isForAllTy tyL )
-        isForAllTy tyR
-      , isReflCo (mkNthCo 0 co)  -- See Note [collectBindersPushingCo]
-      = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b)))
-
-      | isId b
-      , let Pair tyL tyR = coercionKind co
-      , ASSERT( isFunTy tyL) isFunTy tyR
-      , (co_arg, co_res) <- decomposeFunCo co
-      , isReflCo co_arg  -- See Note [collectBindersPushingCo]
-      = go_c (b:bs) e co_res
-
-      | otherwise = (reverse bs, mkCast (Lam b e) co)
-
-{- Note [collectBindersPushingCo]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We just look for coercions of form
-   <type> -> blah
-(and similarly for foralls) to keep this function simple.  We could do
-more elaborate stuff, but it'd involve substitution etc.
--}
index ad504ac..6762ed6 100644 (file)
@@ -589,6 +589,11 @@ Join points must follow these invariants:
      "join arity" (to distinguish from regular arity, which only counts values).
 
   2. For join arity n, the right-hand side must begin with at least n lambdas.
+     No ticks, no casts, just lambdas!  C.f. CoreUtils.joinRhsArity.
+
+  2a. Moreover, this same constraint applies to any unfolding of the binder.
+     Reason: if we want to push a continuation into the RHS we must push it
+     into the unfolding as well.
 
   3. If the binding is recursive, then all other bindings in the recursive group
      must also be join points.
index 0e3efbf..e629467 100644 (file)
@@ -46,7 +46,7 @@ import DynFlags
 import CoreSyn
 import PprCore          ()      -- Instances
 import OccurAnal        ( occurAnalyseExpr )
-import CoreSubst hiding( substTy )
+import CoreOpt
 import CoreArity       ( manifestArity )
 import CoreUtils
 import Id
index 6c939d4..6ae7fb4 100644 (file)
@@ -29,8 +29,8 @@ import InstEnv
 import Class
 import Avail
 import CoreSyn
-import CoreFVs( exprsSomeFreeVarsList )
-import CoreSubst
+import CoreFVs     ( exprsSomeFreeVarsList )
+import CoreOpt     ( simpleOptPgm, simpleOptExpr )
 import PprCore
 import DsMonad
 import DsExpr
index e31f23f..1ff04b2 100644 (file)
@@ -28,7 +28,7 @@ import DsUtils
 import HsSyn            -- lots of things
 import CoreSyn          -- lots of things
 import Literal          ( Literal(MachStr) )
-import CoreSubst
+import CoreOpt          ( simpleOptExpr )
 import OccurAnal        ( occurAnalyseExpr )
 import MkCore
 import CoreUtils
index 33c218c..8c9bc3b 100644 (file)
@@ -277,6 +277,7 @@ Library
         CoreLint
         CorePrep
         CoreSubst
+        CoreOpt
         CoreSyn
         TrieMap
         CoreTidy
index 86091f5..3f6e77c 100644 (file)
@@ -452,6 +452,7 @@ compiler_stage2_dll0_MODULES = \
        CoreArity \
        CoreFVs \
        CoreSubst \
+       CoreOpt \
        CoreSyn \
        CoreTidy \
        CoreUnfold \
index 2af2da8..c064c0e 100644 (file)
@@ -41,7 +41,8 @@ import DataCon
 import CoreUtils
 import MkCore
 import CoreFVs
-import CoreSubst
+import CoreSubst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )
+       -- These names are also exported by Type
 
 -- Core "extras"
 import Rules
index 2b1bf76..5406b0d 100644 (file)
@@ -31,7 +31,7 @@ import CoreSyn
 import MkCore
 import Id
 import Literal
-import CoreSubst   ( exprIsLiteral_maybe )
+import CoreOpt     ( exprIsLiteral_maybe )
 import PrimOp      ( PrimOp(..), tagToEnumKey )
 import TysWiredIn
 import TysPrim
index b63e745..4b158b6 100644 (file)
@@ -35,7 +35,8 @@ import PprCore          ( pprCoreExpr )
 import CoreUnfold
 import CoreUtils
 import CoreArity
-import CoreSubst        ( pushCoTyArg, pushCoValArg )
+import CoreOpt          ( pushCoTyArg, pushCoValArg
+                        , joinPointBinding_maybe, joinPointBindings_maybe )
 --import PrimOp           ( tagToEnumKey ) -- temporalily commented out. See #8326
 import Rules            ( mkRuleInfo, lookupRule, getRules )
 --import TysPrim          ( intPrimTy ) -- temporalily commented out. See #8326
@@ -1462,7 +1463,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
            -> simplExprF (rhs_se `setFloats` env) rhs
                          (StrictBind bndr bndrs body env cont)
 
-           | Just (bndr', rhs') <- matchOrConvertToJoinPoint bndr rhs
+           | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs
            -> do { let cont_dup_res_ty = resultTypeOfDupableCont (getMode env)
                                            [bndr'] cont
                  ; (env1, bndr1) <- simplNonRecJoinBndr env
@@ -1498,7 +1499,7 @@ simplRecE :: SimplEnv
 -- simplRecE is used for
 --  * non-top-level recursive lets in expressions
 simplRecE env pairs body cont
-  | Just pairs' <- matchOrConvertToJoinPoints pairs
+  | Just pairs' <- joinPointBindings_maybe pairs
   = do  { let bndrs' = map fst pairs'
               cont_dup_res_ty = resultTypeOfDupableCont (getMode env)
                                                         bndrs' cont
@@ -1525,29 +1526,6 @@ simplRecE env pairs body cont
         ; env2 <- simplRecBind env1 NotTopLevel (Just cont) pairs
         ; simplExprF env2 body cont }
 
--- | Returns Just (bndr,rhs) if the binding is a join point:
--- If it's a JoinId, just return it
--- If it's not yet a JoinId but is always tail-called,
---    make it into a JoinId and return it.
-matchOrConvertToJoinPoint :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
-matchOrConvertToJoinPoint bndr rhs
-  | not (isId bndr)
-  = Nothing
-
-  | isJoinId bndr
-  = -- No point in keeping tailCallInfo around; very fragile
-    Just (bndr, rhs)
-
-  | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)
-  , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
-  = Just (bndr `asJoinId` join_arity, mkLams bndrs body)
-
-  | otherwise
-  = Nothing
-
-matchOrConvertToJoinPoints :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
-matchOrConvertToJoinPoints bndrs
-  = mapM (uncurry matchOrConvertToJoinPoint) bndrs
 
 {-
 ************************************************************************
index 47193c6..192b6bb 100644 (file)
@@ -31,6 +31,7 @@ module Rules (
 import CoreSyn          -- All of it
 import Module           ( Module, ModuleSet, elemModuleSet )
 import CoreSubst
+import CoreOpt          ( exprIsLambda_maybe )
 import CoreFVs          ( exprFreeVars, exprsFreeVars, bindFreeVars
                         , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )
 import CoreUtils        ( exprType, eqExpr, mkTick, mkTicks,
index bd1c7ae..0dd295d 100644 (file)
@@ -21,6 +21,7 @@ import VarSet
 import VarEnv
 import CoreSyn
 import Rules
+import CoreOpt          ( collectBindersPushingCo )
 import CoreUtils        ( exprIsTrivial, applyTypeToArgs, mkCast )
 import CoreFVs          ( exprFreeVars, exprsFreeVars, idFreeVars, exprsFreeIdsList )
 import CoreArity        ( etaExpandToJoinPointRule )
@@ -1194,7 +1195,7 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
         -- Figure out whether the function has an INLINE pragma
         -- See Note [Inline specialisations]
 
-    (rhs_bndrs, rhs_body)      = CoreSubst.collectBindersPushingCo rhs
+    (rhs_bndrs, rhs_body)      = collectBindersPushingCo rhs
                                  -- See Note [Account for casts in binding]
     (rhs_tyvars, rhs_bndrs1)   = span isTyVar rhs_bndrs
     (rhs_dict_ids, rhs_bndrs2) = splitAt n_dicts rhs_bndrs1
diff --git a/testsuite/tests/simplCore/should_compile/T13413.hs b/testsuite/tests/simplCore/should_compile/T13413.hs
new file mode 100644 (file)
index 0000000..63de8b3
--- /dev/null
@@ -0,0 +1,19 @@
+{-# LANGUAGE MagicHash #-}
+module T13413 where
+
+import GHC.Exts
+
+fillBlock2 :: (Int# -> Int# -> IO ())
+           -> Int# -> Int# -> IO ()
+
+fillBlock2 write x0 y0
+ = fillBlock y0 x0
+ where
+   {-# INLINE fillBlock #-}
+   fillBlock y ix
+         | 1# <- y >=# y0
+         = return ()
+         | otherwise
+         = do   write ix x0
+                fillBlock (y +# 1#) ix
+
index 5265569..98d7d79 100644 (file)
@@ -251,3 +251,4 @@ test('T13340', normal, run_command, ['$MAKE -s --no-print-directory T13340'])
 test('T13338', only_ways(['optasm']), compile, ['-dcore-lint'])
 test('T13367', normal, run_command, ['$MAKE -s --no-print-directory T13367'])
 test('T13417', normal, compile, ['-O'])
+test('T13413', normal, compile, [''])