coreSyn/CoreOpt.hs

    {-
    (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.
    -}