    {-
    (c) The GRASP/AQUA Project, Glasgow University, 1993-1998

    A library for the ``worker\/wrapper'' back-end to the strictness analyser
    -}

    {-# LANGUAGE CPP #-}

    module GHC.Core.Opt.WorkWrap.Utils
       ( mkWwBodies, mkWWstr, mkWorkerArgs
       , DataConPatContext(..), UnboxingDecision(..), splitArgType_maybe, wantToUnbox
       , findTypeShape
       , isWorkerSmallEnough
       )
    where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Core
    import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase
                            , dataConRepFSInstPat )
    import GHC.Types.Id
    import GHC.Types.Id.Info ( JoinArity )
    import GHC.Core.DataCon
    import GHC.Types.Demand
    import GHC.Types.Cpr
    import GHC.Core.Make    ( mkAbsentErrorApp, mkCoreUbxTup
                            , mkCoreApp, mkCoreLet )
    import GHC.Types.Id.Make ( voidArgId, voidPrimId )
    import GHC.Builtin.Types      ( tupleDataCon, unboxedUnitTy )
    import GHC.Types.Literal ( absentLiteralOf, rubbishLit )
    import GHC.Types.Var.Env ( mkInScopeSet )
    import GHC.Types.Var.Set ( VarSet )
    import GHC.Core.Type
    import GHC.Core.Multiplicity
    import GHC.Core.Predicate ( isClassPred )
    import GHC.Types.RepType  ( isVoidTy, typePrimRep )
    import GHC.Core.Coercion
    import GHC.Core.FamInstEnv
    import GHC.Types.Basic       ( Boxity(..) )
    import GHC.Core.TyCon
    import GHC.Core.TyCon.RecWalk
    import GHC.Types.Unique.Supply
    import GHC.Types.Unique
    import GHC.Types.Name ( getOccFS )
    import GHC.Data.Maybe
    import GHC.Utils.Misc
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Driver.Session
    import GHC.Driver.Ppr
    import GHC.Data.FastString
    import GHC.Data.List.SetOps

    {-
    ************************************************************************
    *                                                                      *
    \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
    *                                                                      *
    ************************************************************************

    Here's an example.  The original function is:

    \begin{verbatim}
    g :: forall a . Int -> [a] -> a

    g = \/\ a -> \ x ys ->
            case x of
              0 -> head ys
              _ -> head (tail ys)
    \end{verbatim}

    From this, we want to produce:
    \begin{verbatim}
    -- wrapper (an unfolding)
    g :: forall a . Int -> [a] -> a

    g = \/\ a -> \ x ys ->
            case x of
              I# x# -> $wg a x# ys
                -- call the worker; don't forget the type args!

    -- worker
    $wg :: forall a . Int# -> [a] -> a

    $wg = \/\ a -> \ x# ys ->
            let
                x = I# x#
            in
                case x of               -- note: body of g moved intact
                  0 -> head ys
                  _ -> head (tail ys)
    \end{verbatim}

    Something we have to be careful about:  Here's an example:

    \begin{verbatim}
    -- "f" strictness: U(P)U(P)
    f (I# a) (I# b) = a +# b

    g = f   -- "g" strictness same as "f"
    \end{verbatim}

    \tr{f} will get a worker all nice and friendly-like; that's good.
    {\em But we don't want a worker for \tr{g}}, even though it has the
    same strictness as \tr{f}.  Doing so could break laziness, at best.

    Consequently, we insist that the number of strictness-info items is
    exactly the same as the number of lambda-bound arguments.  (This is
    probably slightly paranoid, but OK in practice.)  If it isn't the
    same, we ``revise'' the strictness info, so that we won't propagate
    the unusable strictness-info into the interfaces.

    ************************************************************************
    *                                                                      *
    \subsection{The worker wrapper core}
    *                                                                      *
    ************************************************************************

    @mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
    -}

    type WwResult
      = ([Demand],              -- Demands for worker (value) args
         JoinArity,             -- Number of worker (type OR value) args
         Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id
         CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs

    mkWwBodies :: DynFlags
               -> FamInstEnvs
               -> VarSet         -- Free vars of RHS
                                 -- See Note [Freshen WW arguments]
               -> Id             -- The original function
               -> [Demand]       -- Strictness of original function
               -> Cpr            -- Info about function result
               -> UniqSM (Maybe WwResult)

    -- wrap_fn_args E       = \x y -> E
    -- work_fn_args E       = E x y

    -- wrap_fn_str E        = case x of { (a,b) ->
    --                        case a of { (a1,a2) ->
    --                        E a1 a2 b y }}
    -- work_fn_str E        = \a1 a2 b y ->
    --                        let a = (a1,a2) in
    --                        let x = (a,b) in
    --                        E

    mkWwBodies :: DynFlags
    -> FamInstEnvs
    -> VarSet
    -> Id
    -> [Demand]
    -> Cpr
    -> UniqSM (Maybe WwResult)
    mkWwBodies DynFlags
    dflags FamInstEnvs
    fam_envs VarSet
    rhs_fvs Id
    fun_id [Demand]
    demands Cpr
    cpr_info
      = do  { let empty_subst :: TCvSubst
    empty_subst = InScopeSet -> TCvSubst
    mkEmptyTCvSubst (VarSet -> InScopeSet
    mkInScopeSet VarSet
    rhs_fvs)
                    -- See Note [Freshen WW arguments]

            ; ([Id]
    wrap_args, CoreExpr -> CoreExpr
    wrap_fn_args, CoreExpr -> CoreExpr
    work_fn_args, Kind
    res_ty)
                 <- TCvSubst
    -> Kind
    -> [Demand]
    -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    mkWWargs TCvSubst
    empty_subst Kind
    fun_ty [Demand]
    demands
            ; (Bool
    useful1, [Id]
    work_args, CoreExpr -> CoreExpr
    wrap_fn_str, CoreExpr -> CoreExpr
    work_fn_str)
                 <- DynFlags
    -> FamInstEnvs
    -> Bool
    -> [Id]
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    mkWWstr DynFlags
    dflags FamInstEnvs
    fam_envs Bool
    has_inlineable_prag [Id]
    wrap_args

            -- Do CPR w/w.  See Note [Always do CPR w/w]
            ; (Bool
    useful2, CoreExpr -> CoreExpr
    wrap_fn_cpr, CoreExpr -> CoreExpr
    work_fn_cpr, Kind
    cpr_res_ty)
                  <- Bool
    -> FamInstEnvs
    -> Kind
    -> Cpr
    -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    mkWWcpr (GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_CprAnal DynFlags
    dflags) FamInstEnvs
    fam_envs Kind
    res_ty Cpr
    cpr_info

            ; let ([Id]
    work_lam_args, [Id]
    work_call_args) = DynFlags -> [Id] -> Kind -> ([Id], [Id])
    mkWorkerArgs DynFlags
    dflags [Id]
    work_args Kind
    cpr_res_ty
                  worker_args_dmds :: [Demand]
    worker_args_dmds = [Id -> Demand
    idDemandInfo Id
    v | Id
    v <- [Id]
    work_call_args, Id -> Bool
    isId Id
    v]
                  wrapper_body :: Id -> CoreExpr
    wrapper_body = CoreExpr -> CoreExpr
    wrap_fn_args (CoreExpr -> CoreExpr) -> (Id -> CoreExpr) -> Id -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreExpr -> CoreExpr
    wrap_fn_cpr (CoreExpr -> CoreExpr) -> (Id -> CoreExpr) -> Id -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreExpr -> CoreExpr
    wrap_fn_str (CoreExpr -> CoreExpr) -> (Id -> CoreExpr) -> Id -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Id] -> CoreExpr -> CoreExpr
    applyToVars [Id]
    work_call_args (CoreExpr -> CoreExpr) -> (Id -> CoreExpr) -> Id -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> CoreExpr
    forall b. Id -> Expr b
    Var
                  worker_body :: CoreExpr -> CoreExpr
    worker_body = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    work_lam_args(CoreExpr -> CoreExpr)
    -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreExpr -> CoreExpr
    work_fn_str (CoreExpr -> CoreExpr)
    -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreExpr -> CoreExpr
    work_fn_cpr (CoreExpr -> CoreExpr)
    -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreExpr -> CoreExpr
    work_fn_args

            ; if DynFlags -> Int -> [Id] -> Bool
    isWorkerSmallEnough DynFlags
    dflags ([Demand] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Demand]
    demands) [Id]
    work_args
                 Bool -> Bool -> Bool
    && Bool -> Bool
    not ([Id] -> Bool
    too_many_args_for_join_point [Id]
    wrap_args)
                 Bool -> Bool -> Bool
    && ((Bool
    useful1 Bool -> Bool -> Bool
    && Bool -> Bool
    not Bool
    only_one_void_argument) Bool -> Bool -> Bool
    || Bool
    useful2)
              then Maybe WwResult -> UniqSM (Maybe WwResult)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (WwResult -> Maybe WwResult
    forall a. a -> Maybe a
    Just ([Demand]
    worker_args_dmds, [Id] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Id]
    work_call_args,
                           Id -> CoreExpr
    wrapper_body, CoreExpr -> CoreExpr
    worker_body))
              else Maybe WwResult -> UniqSM (Maybe WwResult)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe WwResult
    forall a. Maybe a
    Nothing
            }
            -- We use an INLINE unconditionally, even if the wrapper turns out to be
            -- something trivial like
            --      fw = ...
            --      f = __inline__ (coerce T fw)
            -- The point is to propagate the coerce to f's call sites, so even though
            -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
            -- fw from being inlined into f's RHS
      where
        fun_ty :: Kind
    fun_ty        = Id -> Kind
    idType Id
    fun_id
        mb_join_arity :: Maybe Int
    mb_join_arity = Id -> Maybe Int
    isJoinId_maybe Id
    fun_id
        has_inlineable_prag :: Bool
    has_inlineable_prag = Unfolding -> Bool
    isStableUnfolding (Id -> Unfolding
    realIdUnfolding Id
    fun_id)
                              -- See Note [Do not unpack class dictionaries]

        -- Note [Do not split void functions]
        only_one_void_argument :: Bool
    only_one_void_argument
          | [Demand
    d] <- [Demand]
    demands
          , Just (Kind
    _, Kind
    arg_ty1, Kind
    _) <- Kind -> Maybe (Kind, Kind, Kind)
    splitFunTy_maybe Kind
    fun_ty
          , Demand -> Bool
    isAbsDmd Demand
    d Bool -> Bool -> Bool
    && Kind -> Bool
    isVoidTy Kind
    arg_ty1
          = Bool
    True
          | Bool
    otherwise
          = Bool
    False

        -- Note [Join points returning functions]
        too_many_args_for_join_point :: [Id] -> Bool
    too_many_args_for_join_point [Id]
    wrap_args
          | Just Int
    join_arity <- Maybe Int
    mb_join_arity
          , [Id]
    wrap_args [Id] -> Int -> Bool
    forall a. [a] -> Int -> Bool
    `lengthExceeds` Int
    join_arity
          = WARN(True, text "Unable to worker/wrapper join point with arity " <+>
                         int join_arity <+> text "but" <+>
                         int (length wrap_args) <+> text "args")
            Bool
    True
          | Bool
    otherwise
          = Bool
    False

    -- See Note [Limit w/w arity]
    isWorkerSmallEnough :: DynFlags -> Int -> [Var] -> Bool
    isWorkerSmallEnough :: DynFlags -> Int -> [Id] -> Bool
    isWorkerSmallEnough DynFlags
    dflags Int
    old_n_args [Id]
    vars
      = (Id -> Bool) -> [Id] -> Int
    forall a. (a -> Bool) -> [a] -> Int
    count Id -> Bool
    isId [Id]
    vars Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    max Int
    old_n_args (DynFlags -> Int
    maxWorkerArgs DynFlags
    dflags)
        -- We count only Free variables (isId) to skip Type, Kind
        -- variables which have no runtime representation.
        -- Also if the function took 82 arguments before (old_n_args), it's fine if
        -- it takes <= 82 arguments afterwards.

    {-
    Note [Always do CPR w/w]
    ~~~~~~~~~~~~~~~~~~~~~~~~
    At one time we refrained from doing CPR w/w for thunks, on the grounds that
    we might duplicate work.  But that is already handled by the demand analyser,
    which doesn't give the CPR property if w/w might waste work: see
    Note [CPR for thunks] in GHC.Core.Opt.DmdAnal.

    And if something *has* been given the CPR property and we don't w/w, it's
    a disaster, because then the enclosing function might say it has the CPR
    property, but now doesn't and there a cascade of disaster.  A good example
    is #5920.

    Note [Limit w/w arity]
    ~~~~~~~~~~~~~~~~~~~~~~~~
    Guard against high worker arity as it generates a lot of stack traffic.
    A simplified example is #11565#comment:6

    Current strategy is very simple: don't perform w/w transformation at all
    if the result produces a wrapper with arity higher than -fmax-worker-args
    and the number arguments before w/w (see #18122).

    It is a bit all or nothing, consider

            f (x,y) (a,b,c,d,e ... , z) = rhs

    Currently we will remove all w/w ness entirely. But actually we could
    w/w on the (x,y) pair... it's the huge product that is the problem.

    Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd
    solve f. But we can get a lot of args from deeply-nested products:

            g (a, (b, (c, (d, ...)))) = rhs

    This is harder to spot on an arg-by-arg basis. Previously mkWwStr was
    given some "fuel" saying how many arguments it could add; when we ran
    out of fuel it would stop w/wing.

    Still not very clever because it had a left-right bias.

    ************************************************************************
    *                                                                      *
    \subsection{Making wrapper args}
    *                                                                      *
    ************************************************************************

    During worker-wrapper stuff we may end up with an unlifted thing
    which we want to let-bind without losing laziness.  So we
    add a void argument.  E.g.

            f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z
    ==>
            fw = /\ a -> \void -> E
            f  = /\ a -> \x y z -> fw realworld

    We use the state-token type which generates no code.
    -}

    mkWorkerArgs :: DynFlags -> [Var]
                 -> Type    -- Type of body
                 -> ([Var], -- Lambda bound args
                     [Var]) -- Args at call site
    mkWorkerArgs :: DynFlags -> [Id] -> Kind -> ([Id], [Id])
    mkWorkerArgs DynFlags
    dflags [Id]
    args Kind
    res_ty
        | (Id -> Bool) -> [Id] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any Id -> Bool
    isId [Id]
    args Bool -> Bool -> Bool
    || Bool -> Bool
    not Bool
    needsAValueLambda
        = ([Id]
    args, [Id]
    args)
        | Bool
    otherwise
        = ([Id]
    args [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++ [Id
    voidArgId], [Id]
    args [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++ [Id
    voidPrimId])
        where
          -- See "Making wrapper args" section above
          needsAValueLambda :: Bool
    needsAValueLambda =
            Bool
    lifted
            -- We may encounter a levity-polymorphic result, in which case we
            -- conservatively assume that we have laziness that needs preservation.
            -- See #15186.
            Bool -> Bool -> Bool
    || Bool -> Bool
    not (GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_FunToThunk DynFlags
    dflags)
               -- see Note [Protecting the last value argument]

          -- Might the result be lifted?
          lifted :: Bool
    lifted =
            case HasDebugCallStack => Kind -> Maybe Bool
    Kind -> Maybe Bool
    isLiftedType_maybe Kind
    res_ty of
              Just Bool
    lifted -> Bool
    lifted
              Maybe Bool
    Nothing     -> Bool
    True

    {-
    Note [Protecting the last value argument]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    If the user writes (\_ -> E), they might be intentionally disallowing
    the sharing of E. Since absence analysis and worker-wrapper are keen
    to remove such unused arguments, we add in a void argument to prevent
    the function from becoming a thunk.

    The user can avoid adding the void argument with the -ffun-to-thunk
    flag. However, this can create sharing, which may be bad in two ways. 1) It can
    create a space leak. 2) It can prevent inlining *under a lambda*. If w/w
    removes the last argument from a function f, then f now looks like a thunk, and
    so f can't be inlined *under a lambda*.

    Note [Join points and beta-redexes]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Originally, the worker would invoke the original function by calling it with
    arguments, thus producing a beta-redex for the simplifier to munch away:

      \x y z -> e => (\x y z -> e) wx wy wz

    Now that we have special rules about join points, however, this is Not Good if
    the original function is itself a join point, as then it may contain invocations
    of other join points:

      join j1 x = ...
      join j2 y = if y == 0 then 0 else j1 y

      =>

      join j1 x = ...
      join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy
      join j2 y = case y of I# y# -> jump $wj2 y#

    There can't be an intervening lambda between a join point's declaration and its
    occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:

      ...
      let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y
      ...

    Hence we simply do the beta-reduction here. (This would be harder if we had to
    worry about hygiene, but luckily wy is freshly generated.)

    Note [Join points returning functions]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    It is crucial that the arity of a join point depends on its *callers,* not its
    own syntax. What this means is that a join point can have "extra lambdas":

    f :: Int -> Int -> (Int, Int) -> Int
    f x y = join j (z, w) = \(u, v) -> ...
            in jump j (x, y)

    Typically this happens with functions that are seen as computing functions,
    rather than being curried. (The real-life example was GHC.Data.Graph.Ops.addConflicts.)

    When we create the wrapper, it *must* be in "eta-contracted" form so that the
    jump has the right number of arguments:

    f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...
                 j (z, w)  = jump $wj z w

    (See Note [Join points and beta-redexes] for where the lets come from.) If j
    were a function, we would instead say

    f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...
                j (z, w) (u, v) = $wj z w u v

    Notice that the worker ends up with the same lambdas; it's only the wrapper we
    have to be concerned about.

    FIXME Currently the functionality to produce "eta-contracted" wrappers is
    unimplemented; we simply give up.

    ************************************************************************
    *                                                                      *
    \subsection{Coercion stuff}
    *                                                                      *
    ************************************************************************

    We really want to "look through" coerces.
    Reason: I've seen this situation:

            let f = coerce T (\s -> E)
            in \x -> case x of
                        p -> coerce T' f
                        q -> \s -> E2
                        r -> coerce T' f

    If only we w/w'd f, we'd get
            let f = coerce T (\s -> fw s)
                fw = \s -> E
            in ...

    Now we'll inline f to get

            let fw = \s -> E
            in \x -> case x of
                        p -> fw
                        q -> \s -> E2
                        r -> fw

    Now we'll see that fw has arity 1, and will arity expand
    the \x to get what we want.
    -}

    -- mkWWargs just does eta expansion
    -- is driven off the function type and arity.
    -- It chomps bites off foralls, arrows, newtypes
    -- and keeps repeating that until it's satisfied the supplied arity

    mkWWargs :: TCvSubst            -- Freshening substitution to apply to the type
                                    --   See Note [Freshen WW arguments]
             -> Type                -- The type of the function
             -> [Demand]     -- Demands and one-shot info for value arguments
             -> UniqSM  ([Var],            -- Wrapper args
                         CoreExpr -> CoreExpr,      -- Wrapper fn
                         CoreExpr -> CoreExpr,      -- Worker fn
                         Type)                      -- Type of wrapper body

    mkWWargs :: TCvSubst
    -> Kind
    -> [Demand]
    -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    mkWWargs TCvSubst
    subst Kind
    fun_ty [Demand]
    demands
      | [Demand] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Demand]
    demands
      = ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], CoreExpr -> CoreExpr
    forall a. a -> a
    id, CoreExpr -> CoreExpr
    forall a. a -> a
    id, HasCallStack => TCvSubst -> Kind -> Kind
    TCvSubst -> Kind -> Kind
    substTy TCvSubst
    subst Kind
    fun_ty)

      | (Demand
    dmd:[Demand]
    demands') <- [Demand]
    demands
      , Just (Kind
    mult, Kind
    arg_ty, Kind
    fun_ty') <- Kind -> Maybe (Kind, Kind, Kind)
    splitFunTy_maybe Kind
    fun_ty
      = do  { Unique
    uniq <- UniqSM Unique
    forall (m :: * -> *). MonadUnique m => m Unique
    getUniqueM
            ; let arg_ty' :: Scaled Kind
    arg_ty' = HasCallStack => TCvSubst -> Scaled Kind -> Scaled Kind
    TCvSubst -> Scaled Kind -> Scaled Kind
    substScaledTy TCvSubst
    subst (Kind -> Kind -> Scaled Kind
    forall a. Kind -> a -> Scaled a
    Scaled Kind
    mult Kind
    arg_ty)
                  id :: Id
    id = Unique -> Scaled Kind -> Demand -> Id
    mk_wrap_arg Unique
    uniq Scaled Kind
    arg_ty' Demand
    dmd
            ; ([Id]
    wrap_args, CoreExpr -> CoreExpr
    wrap_fn_args, CoreExpr -> CoreExpr
    work_fn_args, Kind
    res_ty)
                  <- TCvSubst
    -> Kind
    -> [Demand]
    -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    mkWWargs TCvSubst
    subst Kind
    fun_ty' [Demand]
    demands'
            ; ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id
    id Id -> [Id] -> [Id]
    forall a. a -> [a] -> [a]
    : [Id]
    wrap_args,
                      Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    id (CoreExpr -> CoreExpr)
    -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreExpr -> CoreExpr
    wrap_fn_args,
                      (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr
    apply_or_bind_then CoreExpr -> CoreExpr
    work_fn_args (Id -> CoreExpr
    forall b. Id -> Expr b
    varToCoreExpr Id
    id),
                      Kind
    res_ty) }

      | Just (Id
    tv, Kind
    fun_ty') <- Kind -> Maybe (Id, Kind)
    splitForAllTyCoVar_maybe Kind
    fun_ty
      = do  { Unique
    uniq <- UniqSM Unique
    forall (m :: * -> *). MonadUnique m => m Unique
    getUniqueM
            ; let (TCvSubst
    subst', Id
    tv') = TCvSubst -> Id -> Unique -> (TCvSubst, Id)
    cloneTyVarBndr TCvSubst
    subst Id
    tv Unique
    uniq
                    -- See Note [Freshen WW arguments]
            ; ([Id]
    wrap_args, CoreExpr -> CoreExpr
    wrap_fn_args, CoreExpr -> CoreExpr
    work_fn_args, Kind
    res_ty)
                 <- TCvSubst
    -> Kind
    -> [Demand]
    -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    mkWWargs TCvSubst
    subst' Kind
    fun_ty' [Demand]
    demands
            ; ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id
    tv' Id -> [Id] -> [Id]
    forall a. a -> [a] -> [a]
    : [Id]
    wrap_args,
                      Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    tv' (CoreExpr -> CoreExpr)
    -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreExpr -> CoreExpr
    wrap_fn_args,
                      (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr
    apply_or_bind_then CoreExpr -> CoreExpr
    work_fn_args (Kind -> CoreExpr
    forall b. Kind -> Expr b
    mkTyArg (Id -> Kind
    mkTyVarTy Id
    tv')),
                      Kind
    res_ty) }

      | Just (Coercion
    co, Kind
    rep_ty) <- Kind -> Maybe (Coercion, Kind)
    topNormaliseNewType_maybe Kind
    fun_ty
            -- The newtype case is for when the function has
            -- a newtype after the arrow (rare)
            --
            -- It's also important when we have a function returning (say) a pair
            -- wrapped in a  newtype, at least if CPR analysis can look
            -- through such newtypes, which it probably can since they are
            -- simply coerces.

      = do { ([Id]
    wrap_args, CoreExpr -> CoreExpr
    wrap_fn_args, CoreExpr -> CoreExpr
    work_fn_args, Kind
    res_ty)
                <-  TCvSubst
    -> Kind
    -> [Demand]
    -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    mkWWargs TCvSubst
    subst Kind
    rep_ty [Demand]
    demands
           ; let co' :: Coercion
    co' = HasCallStack => TCvSubst -> Coercion -> Coercion
    TCvSubst -> Coercion -> Coercion
    substCo TCvSubst
    subst Coercion
    co
           ; ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Id]
    wrap_args,
                      \CoreExpr
    e -> CoreExpr -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    Cast (CoreExpr -> CoreExpr
    wrap_fn_args CoreExpr
    e) (Coercion -> Coercion
    mkSymCo Coercion
    co'),
                      \CoreExpr
    e -> CoreExpr -> CoreExpr
    work_fn_args (CoreExpr -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    Cast CoreExpr
    e Coercion
    co'),
                      Kind
    res_ty) }

      | Bool
    otherwise
      = WARN( True, ppr fun_ty )                    -- Should not happen: if there is a demand
        ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], CoreExpr -> CoreExpr
    forall a. a -> a
    id, CoreExpr -> CoreExpr
    forall a. a -> a
    id, HasCallStack => TCvSubst -> Kind -> Kind
    TCvSubst -> Kind -> Kind
    substTy TCvSubst
    subst Kind
    fun_ty)   -- then there should be a function arrow
      where
        -- See Note [Join points and beta-redexes]
        apply_or_bind_then :: (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr
    apply_or_bind_then CoreExpr -> CoreExpr
    k CoreExpr
    arg (Lam Id
    bndr CoreExpr
    body)
          = CoreBind -> CoreExpr -> CoreExpr
    mkCoreLet (Id -> CoreExpr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    bndr CoreExpr
    arg) (CoreExpr -> CoreExpr
    k CoreExpr
    body)    -- Important that arg is fresh!
        apply_or_bind_then CoreExpr -> CoreExpr
    k CoreExpr
    arg CoreExpr
    fun
          = CoreExpr -> CoreExpr
    k (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $ SDoc -> CoreExpr -> CoreExpr -> CoreExpr
    mkCoreApp (String -> SDoc
    text String
    "mkWWargs") CoreExpr
    fun CoreExpr
    arg
    applyToVars :: [Var] -> CoreExpr -> CoreExpr
    applyToVars :: [Id] -> CoreExpr -> CoreExpr
    applyToVars [Id]
    vars CoreExpr
    fn = CoreExpr -> [Id] -> CoreExpr
    forall b. Expr b -> [Id] -> Expr b
    mkVarApps CoreExpr
    fn [Id]
    vars

    mk_wrap_arg :: Unique -> Scaled Type -> Demand -> Id
    mk_wrap_arg :: Unique -> Scaled Kind -> Demand -> Id
    mk_wrap_arg Unique
    uniq (Scaled Kind
    w Kind
    ty) Demand
    dmd
      = FastString -> Unique -> Kind -> Kind -> Id
    mkSysLocalOrCoVar (String -> FastString
    fsLit String
    "w") Unique
    uniq Kind
    w Kind
    ty
           Id -> Demand -> Id
    `setIdDemandInfo` Demand
    dmd

    {- Note [Freshen WW arguments]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Wen we do a worker/wrapper split, we must not in-scope names as the arguments
    of the worker, else we'll get name capture.  E.g.

       -- y1 is in scope from further out
       f x = ..y1..

    If we accidentally choose y1 as a worker argument disaster results:

       fww y1 y2 = let x = (y1,y2) in ...y1...

    To avoid this:

      * We use a fresh unique for both type-variable and term-variable binders
        Originally we lacked this freshness for type variables, and that led
        to the very obscure #12562.  (A type variable in the worker shadowed
        an outer term-variable binding.)

      * Because of this cloning we have to substitute in the type/kind of the
        new binders.  That's why we carry the TCvSubst through mkWWargs.

        So we need a decent in-scope set, just in case that type/kind
        itself has foralls.  We get this from the free vars of the RHS of the
        function since those are the only variables that might be captured.
        It's a lazy thunk, which will only be poked if the type/kind has a forall.

        Another tricky case was when f :: forall a. a -> forall a. a->a
        (i.e. with shadowing), and then the worker used the same 'a' twice.
    -}

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Unboxing Decision for Strictness and CPR}
    *                                                                      *
    ************************************************************************
    -}

    -- | The information needed to build a pattern for a DataCon to be unboxed.
    -- The pattern can be generated from 'dcpc_dc' and 'dcpc_tc_args' via
    -- 'GHC.Core.Utils.dataConRepInstPat'. The coercion 'dcpc_co' is for newtype
    -- wrappers.
    --
    -- If we get @DataConPatContext dc tys co@ for some type @ty@
    -- and @dataConRepInstPat ... dc tys = (exs, flds)@, then
    --
    --   * @dc @exs flds :: T tys@
    --   * @co :: T tys ~ ty@
    data DataConPatContext
      = DataConPatContext
      { DataConPatContext -> DataCon
    dcpc_dc      :: !DataCon
      , DataConPatContext -> [Kind]
    dcpc_tc_args :: ![Type]
      , DataConPatContext -> Coercion
    dcpc_co      :: !Coercion
      }

    -- | If @splitArgType_maybe ty = Just (dc, tys, co)@
    -- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@
    -- and  @co :: ty ~ tc tys@
    -- where underscore prefixes are holes, e.g. yet unspecified.
    --
    -- See Note [Which types are unboxed?].
    splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext
    splitArgType_maybe :: FamInstEnvs -> Kind -> Maybe DataConPatContext
    splitArgType_maybe FamInstEnvs
    fam_envs Kind
    ty
      | let (Coercion
    co, Kind
    ty1) = FamInstEnvs -> Kind -> Maybe (Coercion, Kind)
    topNormaliseType_maybe FamInstEnvs
    fam_envs Kind
    ty
                        Maybe (Coercion, Kind) -> (Coercion, Kind) -> (Coercion, Kind)
    forall a. Maybe a -> a -> a
    `orElse` (Kind -> Coercion
    mkRepReflCo Kind
    ty, Kind
    ty)
      , Just (TyCon
    tc, [Kind]
    tc_args) <- HasDebugCallStack => Kind -> Maybe (TyCon, [Kind])
    Kind -> Maybe (TyCon, [Kind])
    splitTyConApp_maybe Kind
    ty1
      , Just DataCon
    con <- TyCon -> Maybe DataCon
    tyConSingleAlgDataCon_maybe TyCon
    tc
      = DataConPatContext -> Maybe DataConPatContext
    forall a. a -> Maybe a
    Just DataConPatContext { dcpc_dc :: DataCon
    dcpc_dc      = DataCon
    con
                               , dcpc_tc_args :: [Kind]
    dcpc_tc_args = [Kind]
    tc_args
                               , dcpc_co :: Coercion
    dcpc_co      = Coercion
    co }
    splitArgType_maybe FamInstEnvs
    _ Kind
    _ = Maybe DataConPatContext
    forall a. Maybe a
    Nothing

    -- | If @splitResultType_maybe n ty = Just (dc, tys, co)@
    -- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@
    -- and  @co :: ty ~ tc tys@
    -- where underscore prefixes are holes, e.g. yet unspecified.
    -- @dc@ is the @n@th data constructor of @tc@.
    --
    -- See Note [Which types are unboxed?].
    splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext
    splitResultType_maybe :: FamInstEnvs -> Int -> Kind -> Maybe DataConPatContext
    splitResultType_maybe FamInstEnvs
    fam_envs Int
    con_tag Kind
    ty
      | let (Coercion
    co, Kind
    ty1) = FamInstEnvs -> Kind -> Maybe (Coercion, Kind)
    topNormaliseType_maybe FamInstEnvs
    fam_envs Kind
    ty
                        Maybe (Coercion, Kind) -> (Coercion, Kind) -> (Coercion, Kind)
    forall a. Maybe a -> a -> a
    `orElse` (Kind -> Coercion
    mkRepReflCo Kind
    ty, Kind
    ty)
      , Just (TyCon
    tc, [Kind]
    tc_args) <- HasDebugCallStack => Kind -> Maybe (TyCon, [Kind])
    Kind -> Maybe (TyCon, [Kind])
    splitTyConApp_maybe Kind
    ty1
      , TyCon -> Bool
    isDataTyCon TyCon
    tc -- NB: rules out unboxed sums and pairs!
      , let cons :: [DataCon]
    cons = TyCon -> [DataCon]
    tyConDataCons TyCon
    tc
      , [DataCon]
    cons [DataCon] -> Int -> Bool
    forall a. [a] -> Int -> Bool
    `lengthAtLeast` Int
    con_tag -- This might not be true if we import the
                                     -- type constructor via a .hs-boot file (#8743)
      , let con :: DataCon
    con = [DataCon]
    cons [DataCon] -> Int -> DataCon
    forall a. Outputable a => [a] -> Int -> a
    `getNth` (Int
    con_tag Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    fIRST_TAG)
      , [Id] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (DataCon -> [Id]
    dataConExTyCoVars DataCon
    con) -- no existentials;
                                     -- See Note [Which types are unboxed?]
                                     -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt
                                     -- where we also check this.
      , (Scaled Kind -> Bool) -> [Scaled Kind] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Scaled Kind -> Bool
    forall a. Scaled a -> Bool
    isLinear (DataCon -> [Kind] -> [Scaled Kind]
    dataConInstArgTys DataCon
    con [Kind]
    tc_args)
      -- Deactivates CPR worker/wrapper splits on constructors with non-linear
      -- arguments, for the moment, because they require unboxed tuple with variable
      -- multiplicity fields.
      = DataConPatContext -> Maybe DataConPatContext
    forall a. a -> Maybe a
    Just DataConPatContext { dcpc_dc :: DataCon
    dcpc_dc = DataCon
    con
                               , dcpc_tc_args :: [Kind]
    dcpc_tc_args = [Kind]
    tc_args
                               , dcpc_co :: Coercion
    dcpc_co = Coercion
    co }
    splitResultType_maybe FamInstEnvs
    _ Int
    _ Kind
    _ = Maybe DataConPatContext
    forall a. Maybe a
    Nothing

    isLinear :: Scaled a -> Bool
    isLinear :: forall a. Scaled a -> Bool
    isLinear (Scaled Kind
    w a
    _ ) =
      case Kind
    w of
        Kind
    One -> Bool
    True
        Kind
    _ -> Bool
    False

    -- | Describes the outer shape of an argument to be unboxed or left as-is
    -- Depending on how @s@ is instantiated (e.g., 'Demand').
    data UnboxingDecision s
      = StopUnboxing
      -- ^ We ran out of strictness info. Leave untouched.
      | Unbox !DataConPatContext [s]
      -- ^ The argument is used strictly or the returned product was constructed, so
      -- unbox it.
      -- The 'DataConPatContext' carries the bits necessary for
      -- instantiation with 'dataConRepInstPat'.
      -- The @[s]@ carries the bits of information with which we can continue
      -- unboxing, e.g. @s@ will be 'Demand'.

    wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand
    -- See Note [Which types are unboxed?]
    wantToUnbox :: FamInstEnvs -> Bool -> Kind -> Demand -> UnboxingDecision Demand
    wantToUnbox FamInstEnvs
    fam_envs Bool
    has_inlineable_prag Kind
    ty Demand
    dmd =
      case FamInstEnvs -> Kind -> Maybe DataConPatContext
    splitArgType_maybe FamInstEnvs
    fam_envs Kind
    ty of
        Just dcpc :: DataConPatContext
    dcpc@DataConPatContext{ dcpc_dc :: DataConPatContext -> DataCon
    dcpc_dc = DataCon
    dc }
          | Demand -> Bool
    isStrUsedDmd Demand
    dmd
          , let arity :: Int
    arity = DataCon -> Int
    dataConRepArity DataCon
    dc
          -- See Note [Unpacking arguments with product and polymorphic demands]
          , Just [Demand]
    cs <- Demand -> Int -> Maybe [Demand]
    split_prod_dmd_arity Demand
    dmd Int
    arity
          -- See Note [Do not unpack class dictionaries]
          , Bool -> Bool
    not (Bool
    has_inlineable_prag Bool -> Bool -> Bool
    && Kind -> Bool
    isClassPred Kind
    ty)
          -- See Note [mkWWstr and unsafeCoerce]
          , [Demand]
    cs [Demand] -> Int -> Bool
    forall a. [a] -> Int -> Bool
    `lengthIs` Int
    arity
          -- See Note [Add demands for strict constructors]
          , let cs' :: [Demand]
    cs' = DataCon -> [Demand] -> [Demand]
    addDataConStrictness DataCon
    dc [Demand]
    cs
          -> DataConPatContext -> [Demand] -> UnboxingDecision Demand
    forall s. DataConPatContext -> [s] -> UnboxingDecision s
    Unbox DataConPatContext
    dcpc [Demand]
    cs'
        Maybe DataConPatContext
    _ -> UnboxingDecision Demand
    forall s. UnboxingDecision s
    StopUnboxing
      where
        split_prod_dmd_arity :: Demand -> Int -> Maybe [Demand]
    split_prod_dmd_arity Demand
    dmd Int
    arity
          -- For seqDmd, it should behave like <S(AAAA)>, for some
          -- suitable arity
          | Demand -> Bool
    isSeqDmd Demand
    dmd        = [Demand] -> Maybe [Demand]
    forall a. a -> Maybe a
    Just (Int -> Demand -> [Demand]
    forall a. Int -> a -> [a]
    replicate Int
    arity Demand
    absDmd)
          | Card
    _ :* Prod [Demand]
    ds <- Demand
    dmd = [Demand] -> Maybe [Demand]
    forall a. a -> Maybe a
    Just [Demand]
    ds
          | Bool
    otherwise           = Maybe [Demand]
    forall a. Maybe a
    Nothing

    {- Note [Which types are unboxed?]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Worker/wrapper will unbox

      1. A strict data type argument, that
           * is an algebraic data type (not a newtype)
           * has a single constructor (thus is a "product")
           * that may bind existentials
         We can transform
         > f (D @ex a b) = e
         to
         > $wf @ex a b = e
         via 'mkWWstr'.

      2. The constructed result of a function, if
           * its type is an algebraic data type (not a newtype)
           * (might have multiple constructors, in contrast to (1))
           * the applied data constructor *does not* bind existentials
         We can transform
         > f x y = let ... in D a b
         to
         > $wf x y = let ... in (# a, b #)
         via 'mkWWcpr'.

         NB: We don't allow existentials for CPR W/W, because we don't have unboxed
         dependent tuples (yet?). Otherwise, we could transform
         > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)
         to
         > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)

    The respective tests are in 'splitArgType_maybe' and
    'splitResultType_maybe', respectively.

    Note that the data constructor /can/ have evidence arguments: equality
    constraints, type classes etc.  So it can be GADT.  These evidence
    arguments are simply value arguments, and should not get in the way.

    Note [Unpacking arguments with product and polymorphic demands]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The argument is unpacked in a case if it has a product type and has a
    strict *and* used demand put on it. I.e., arguments, with demands such
    as the following ones:

       <S,U(U, L)>
       <S(L,S),U>

    will be unpacked, but

       <S,U> or <B,U>

    will not, because the pieces aren't used. This is quite important otherwise
    we end up unpacking massive tuples passed to the bottoming function. Example:

            f :: ((Int,Int) -> String) -> (Int,Int) -> a
            f g pr = error (g pr)

            main = print (f fst (1, error "no"))

    Does 'main' print "error 1" or "error no"?  We don't really want 'f'
    to unbox its second argument.  This actually happened in GHC's onwn
    source code, in Packages.applyPackageFlag, which ended up un-boxing
    the enormous DynFlags tuple, and being strict in the
    as-yet-un-filled-in unitState files.

    Note [Do not unpack class dictionaries]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    If we have
       f :: Ord a => [a] -> Int -> a
       {-# INLINABLE f #-}
    and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
    (see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),
    which can still be specialised by the type-class specialiser, something like
       fw :: Ord a => [a] -> Int# -> a

    BUT if f is strict in the Ord dictionary, we might unpack it, to get
       fw :: (a->a->Bool) -> [a] -> Int# -> a
    and the type-class specialiser can't specialise that. An example is #6056.

    But in any other situation a dictionary is just an ordinary value,
    and can be unpacked.  So we track the INLINABLE pragma, and switch
    off the unpacking in mkWWstr_one (see the isClassPred test).

    Historical note: #14955 describes how I got this fix wrong the first time.

    Note [mkWWstr and unsafeCoerce]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    By using unsafeCoerce, it is possible to make the number of demands fail to
    match the number of constructor arguments; this happened in #8037.
    If so, the worker/wrapper split doesn't work right and we get a Core Lint
    bug.  The fix here is simply to decline to do w/w if that happens.

    Note [Add demands for strict constructors]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider this program (due to Roman):

        data X a = X !a

        foo :: X Int -> Int -> Int
        foo (X a) n = go 0
         where
           go i | i < n     = a + go (i+1)
                | otherwise = 0

    We want the worker for 'foo' too look like this:

        $wfoo :: Int# -> Int# -> Int#

    with the first argument unboxed, so that it is not eval'd each time
    around the 'go' loop (which would otherwise happen, since 'foo' is not
    strict in 'a').  It is sound for the wrapper to pass an unboxed arg
    because X is strict, so its argument must be evaluated.  And if we
    *don't* pass an unboxed argument, we can't even repair it by adding a
    `seq` thus:

        foo (X a) n = a `seq` go 0

    because the seq is discarded (very early) since X is strict!

    So here's what we do

    * We leave the demand-analysis alone.  The demand on 'a' in the
      definition of 'foo' is <L, U(U)>; the strictness info is Lazy
      because foo's body may or may not evaluate 'a'; but the usage info
      says that 'a' is unpacked and its content is used.

    * During worker/wrapper, if we unpack a strict constructor (as we do
      for 'foo'), we use 'addDataConStrictness' to bump up the strictness on
      the strict arguments of the data constructor.

    * That in turn means that, if the usage info supports doing so
      (i.e. splitProdDmd_maybe returns Just), we will unpack that argument
      -- even though the original demand (e.g. on 'a') was lazy.

    * What does "bump up the strictness" mean?  Just add a head-strict
      demand to the strictness!  Even for a demand like <L,A> we can
      safely turn it into <S,A>; remember case (1) of
      Note [How to do the worker/wrapper split].

    The net effect is that the w/w transformation is more aggressive about
    unpacking the strict arguments of a data constructor, when that
    eagerness is supported by the usage info.

    There is the usual danger of reboxing, which as usual we ignore. But
    if X is monomorphic, and has an UNPACK pragma, then this optimisation
    is even more important.  We don't want the wrapper to rebox an unboxed
    argument, and pass an Int to $wfoo!

    This works in nested situations like

        data family Bar a
        data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
        newtype instance Bar Int = Bar Int

        foo :: Bar ((Int, Int), Int) -> Int -> Int
        foo f k = case f of BarPair x y ->
                  case burble of
                     True -> case x of
                               BarPair p q -> ...
                     False -> ...

    The extra eagerness lets us produce a worker of type:
         $wfoo :: Int# -> Int# -> Int# -> Int -> Int
         $wfoo p# q# y# = ...

    even though the `case x` is only lazily evaluated.

    --------- Historical note ------------
    We used to add data-con strictness demands when demand analysing case
    expression. However, it was noticed in #15696 that this misses some cases. For
    instance, consider the program (from T10482)

        data family Bar a
        data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
        newtype instance Bar Int = Bar Int

        foo :: Bar ((Int, Int), Int) -> Int -> Int
        foo f k =
          case f of
            BarPair x y -> case burble of
                              True -> case x of
                                        BarPair p q -> ...
                              False -> ...

    We really should be able to assume that `p` is already evaluated since it came
    from a strict field of BarPair. This strictness would allow us to produce a
    worker of type:

        $wfoo :: Int# -> Int# -> Int# -> Int -> Int
        $wfoo p# q# y# = ...

    even though the `case x` is only lazily evaluated

    Indeed before we fixed #15696 this would happen since we would float the inner
    `case x` through the `case burble` to get:

        foo f k =
          case f of
            BarPair x y -> case x of
                              BarPair p q -> case burble of
                                              True -> ...
                                              False -> ...

    However, after fixing #15696 this could no longer happen (for the reasons
    discussed in ticket:15696#comment:76). This means that the demand placed on `f`
    would then be significantly weaker (since the False branch of the case on
    `burble` is not strict in `p` or `q`).

    Consequently, we now instead account for data-con strictness in mkWWstr_one,
    applying the strictness demands to the final result of DmdAnal. The result is
    that we get the strict demand signature we wanted even if we can't float
    the case on `x` up through the case on `burble`.
    -}

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Strictness stuff}
    *                                                                      *
    ************************************************************************
    -}

    mkWWstr :: DynFlags
            -> FamInstEnvs
            -> Bool    -- True <=> INLINEABLE pragma on this function defn
                       -- See Note [Do not unpack class dictionaries]
            -> [Var]                                -- Wrapper args; have their demand info on them
                                                    --  *Includes type variables*
            -> UniqSM (Bool,                        -- Is this useful
                       [Var],                       -- Worker args
                       CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call
                                                    -- and without its lambdas
                                                    -- This fn adds the unboxing

                       CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,
                                                    -- and lacking its lambdas.
                                                    -- This fn does the reboxing
    mkWWstr :: DynFlags
    -> FamInstEnvs
    -> Bool
    -> [Id]
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    mkWWstr DynFlags
    dflags FamInstEnvs
    fam_envs Bool
    has_inlineable_prag [Id]
    args
      = [Id]
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    go [Id]
    args
      where
        go_one :: Id
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    go_one Id
    arg = DynFlags
    -> FamInstEnvs
    -> Bool
    -> Id
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    mkWWstr_one DynFlags
    dflags FamInstEnvs
    fam_envs Bool
    has_inlineable_prag Id
    arg

        go :: [Id]
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    go []           = (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, [], CoreExpr -> CoreExpr
    nop_fn, CoreExpr -> CoreExpr
    nop_fn)
        go (Id
    arg : [Id]
    args) = do { (Bool
    useful1, [Id]
    args1, CoreExpr -> CoreExpr
    wrap_fn1, CoreExpr -> CoreExpr
    work_fn1) <- Id
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    go_one Id
    arg
                             ; (Bool
    useful2, [Id]
    args2, CoreExpr -> CoreExpr
    wrap_fn2, CoreExpr -> CoreExpr
    work_fn2) <- [Id]
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    go [Id]
    args
                             ; (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ( Bool
    useful1 Bool -> Bool -> Bool
    || Bool
    useful2
                                      , [Id]
    args1 [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++ [Id]
    args2
                                      , CoreExpr -> CoreExpr
    wrap_fn1 (CoreExpr -> CoreExpr)
    -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreExpr -> CoreExpr
    wrap_fn2
                                      , CoreExpr -> CoreExpr
    work_fn1 (CoreExpr -> CoreExpr)
    -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreExpr -> CoreExpr
    work_fn2) }

    ----------------------
    -- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
    --   *  wrap_fn assumes wrap_arg is in scope,
    --        brings into scope work_args (via cases)
    --   * work_fn assumes work_args are in scope, a
    --        brings into scope wrap_arg (via lets)
    -- See Note [How to do the worker/wrapper split]
    mkWWstr_one :: DynFlags -> FamInstEnvs
                -> Bool    -- True <=> INLINEABLE pragma on this function defn
                           -- See Note [Do not unpack class dictionaries]
                -> Var
                -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    mkWWstr_one :: DynFlags
    -> FamInstEnvs
    -> Bool
    -> Id
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    mkWWstr_one DynFlags
    dflags FamInstEnvs
    fam_envs Bool
    has_inlineable_prag Id
    arg
      | Id -> Bool
    isTyVar Id
    arg
      = (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, [Id
    arg],  CoreExpr -> CoreExpr
    nop_fn, CoreExpr -> CoreExpr
    nop_fn)

      | Demand -> Bool
    isAbsDmd Demand
    dmd
      , Just CoreExpr -> CoreExpr
    work_fn <- DynFlags
    -> FamInstEnvs -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)
    mk_absent_let DynFlags
    dflags FamInstEnvs
    fam_envs Id
    arg Demand
    dmd
         -- Absent case.  We can't always handle absence for arbitrary
         -- unlifted types, so we need to choose just the cases we can
         -- (that's what mk_absent_let does)
      = (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, [], CoreExpr -> CoreExpr
    nop_fn, CoreExpr -> CoreExpr
    work_fn)

      | Unbox DataConPatContext
    dcpc [Demand]
    cs <- FamInstEnvs -> Bool -> Kind -> Demand -> UnboxingDecision Demand
    wantToUnbox FamInstEnvs
    fam_envs Bool
    has_inlineable_prag Kind
    arg_ty Demand
    dmd
      = DynFlags
    -> FamInstEnvs
    -> Id
    -> [Demand]
    -> DataConPatContext
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    unbox_one DynFlags
    dflags FamInstEnvs
    fam_envs Id
    arg [Demand]
    cs DataConPatContext
    dcpc

      | Bool
    otherwise   -- Other cases
      = (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, [Id
    arg], CoreExpr -> CoreExpr
    nop_fn, CoreExpr -> CoreExpr
    nop_fn)

      where
        arg_ty :: Kind
    arg_ty = Id -> Kind
    idType Id
    arg
        dmd :: Demand
    dmd    = Id -> Demand
    idDemandInfo Id
    arg

    unbox_one :: DynFlags -> FamInstEnvs -> Var
              -> [Demand]
              -> DataConPatContext
              -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    unbox_one :: DynFlags
    -> FamInstEnvs
    -> Id
    -> [Demand]
    -> DataConPatContext
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    unbox_one DynFlags
    dflags FamInstEnvs
    fam_envs Id
    arg [Demand]
    cs
              DataConPatContext { dcpc_dc :: DataConPatContext -> DataCon
    dcpc_dc = DataCon
    dc, dcpc_tc_args :: DataConPatContext -> [Kind]
    dcpc_tc_args = [Kind]
    tc_args
                                , dcpc_co :: DataConPatContext -> Coercion
    dcpc_co = Coercion
    co }
      = do { (Unique
    case_bndr_uniq:[Unique]
    pat_bndrs_uniqs) <- UniqSM [Unique]
    forall (m :: * -> *). MonadUnique m => m [Unique]
    getUniquesM
           ; let ex_name_fss :: [FastString]
    ex_name_fss     = (Id -> FastString) -> [Id] -> [FastString]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> FastString
    forall a. NamedThing a => a -> FastString
    getOccFS ([Id] -> [FastString]) -> [Id] -> [FastString]
    forall a b. (a -> b) -> a -> b
    $ DataCon -> [Id]
    dataConExTyCoVars DataCon
    dc
                 ([Id]
    ex_tvs', [Id]
    arg_ids) =
                   [FastString]
    -> [Unique] -> Kind -> DataCon -> [Kind] -> ([Id], [Id])
    dataConRepFSInstPat ([FastString]
    ex_name_fss [FastString] -> [FastString] -> [FastString]
    forall a. [a] -> [a] -> [a]
    ++ FastString -> [FastString]
    forall a. a -> [a]
    repeat FastString
    ww_prefix) [Unique]
    pat_bndrs_uniqs (Id -> Kind
    idMult Id
    arg) DataCon
    dc [Kind]
    tc_args
                 arg_ids' :: [Id]
    arg_ids'  = String -> (Id -> Demand -> Id) -> [Id] -> [Demand] -> [Id]
    forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
    zipWithEqual String
    "unbox_one" Id -> Demand -> Id
    setIdDemandInfo [Id]
    arg_ids [Demand]
    cs
                 unbox_fn :: CoreExpr -> CoreExpr
    unbox_fn  = CoreExpr
    -> Coercion
    -> Kind
    -> Unique
    -> DataCon
    -> [Id]
    -> CoreExpr
    -> CoreExpr
    mkUnpackCase (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    arg) Coercion
    co (Id -> Kind
    idMult Id
    arg) Unique
    case_bndr_uniq
                                          DataCon
    dc ([Id]
    ex_tvs' [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++ [Id]
    arg_ids')
                 arg_no_unf :: Id
    arg_no_unf = Id -> Id
    zapStableUnfolding Id
    arg
                              -- See Note [Zap unfolding when beta-reducing]
                              -- in GHC.Core.Opt.Simplify; and see #13890
                 rebox_fn :: CoreExpr -> CoreExpr
    rebox_fn   = CoreBind -> CoreExpr -> CoreExpr
    forall b. Bind b -> Expr b -> Expr b
    Let (Id -> CoreExpr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    arg_no_unf CoreExpr
    con_app)
                 con_app :: CoreExpr
    con_app    = DataCon -> [Kind] -> [Id] -> CoreExpr
    forall b. DataCon -> [Kind] -> [Id] -> Expr b
    mkConApp2 DataCon
    dc [Kind]
    tc_args ([Id]
    ex_tvs' [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++ [Id]
    arg_ids') CoreExpr -> Coercion -> CoreExpr
    `mkCast` Coercion -> Coercion
    mkSymCo Coercion
    co
           ; (Bool
    _, [Id]
    worker_args, CoreExpr -> CoreExpr
    wrap_fn, CoreExpr -> CoreExpr
    work_fn) <- DynFlags
    -> FamInstEnvs
    -> Bool
    -> [Id]
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    mkWWstr DynFlags
    dflags FamInstEnvs
    fam_envs Bool
    False ([Id]
    ex_tvs' [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++ [Id]
    arg_ids')
           ; (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, [Id]
    worker_args, CoreExpr -> CoreExpr
    unbox_fn (CoreExpr -> CoreExpr)
    -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreExpr -> CoreExpr
    wrap_fn, CoreExpr -> CoreExpr
    work_fn (CoreExpr -> CoreExpr)
    -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreExpr -> CoreExpr
    rebox_fn) }
                              -- Don't pass the arg, rebox instead

    ----------------------
    nop_fn :: CoreExpr -> CoreExpr
    nop_fn :: CoreExpr -> CoreExpr
    nop_fn CoreExpr
    body = CoreExpr
    body

    addDataConStrictness :: DataCon -> [Demand] -> [Demand]
    -- See Note [Add demands for strict constructors]
    addDataConStrictness :: DataCon -> [Demand] -> [Demand]
    addDataConStrictness DataCon
    con [Demand]
    ds
      | Maybe Id
    Nothing <- DataCon -> Maybe Id
    dataConWrapId_maybe DataCon
    con
      -- DataCon worker=wrapper. Implies no strict fields, so nothing to do
      = [Demand]
    ds
    addDataConStrictness DataCon
    con [Demand]
    ds
      = String
    -> (Demand -> StrictnessMark -> Demand)
    -> [Demand]
    -> [StrictnessMark]
    -> [Demand]
    forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
    zipWithEqual String
    "addDataConStrictness" Demand -> StrictnessMark -> Demand
    add [Demand]
    ds [StrictnessMark]
    strs
      where
        strs :: [StrictnessMark]
    strs = DataCon -> [StrictnessMark]
    dataConRepStrictness DataCon
    con
        add :: Demand -> StrictnessMark -> Demand
    add Demand
    dmd StrictnessMark
    str | StrictnessMark -> Bool
    isMarkedStrict StrictnessMark
    str = Demand -> Demand
    strictifyDmd Demand
    dmd
                    | Bool
    otherwise          = Demand
    dmd

    {- Note [How to do the worker/wrapper split]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The worker-wrapper transformation, mkWWstr_one, takes into account
    several possibilities to decide if the function is worthy for
    splitting:

    1. If an argument is absent, it would be silly to pass it to
       the worker.  Hence the isAbsDmd case.  This case must come
       first because a demand like <S,A> or <B,A> is possible.
       E.g. <B,A> comes from a function like
           f x = error "urk"
       and <S,A> can come from Note [Add demands for strict constructors]

    2. If the argument is evaluated strictly, and we can split the
       product demand (splitProdDmd_maybe), then unbox it and w/w its
       pieces.  For example

        f :: (Int, Int) -> Int
        f p = (case p of (a,b) -> a) + 1
      is split to
        f :: (Int, Int) -> Int
        f p = case p of (a,b) -> $wf a

        $wf :: Int -> Int
        $wf a = a + 1

      and
        g :: Bool -> (Int, Int) -> Int
        g c p = case p of (a,b) ->
                   if c then a else b
      is split to
       g c p = case p of (a,b) -> $gw c a b
       $gw c a b = if c then a else b

    2a But do /not/ split if the components are not used; that is, the
       usage is just 'Used' rather than 'UProd'. In this case
       splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing
       a massive tuple which is barely used.  Example:

            f :: ((Int,Int) -> String) -> (Int,Int) -> a
            f g pr = error (g pr)

            main = print (f fst (1, error "no"))

       Here, f does not take 'pr' apart, and it's stupid to do so.
       Imagine that it had millions of fields. This actually happened
       in GHC itself where the tuple was DynFlags

    3. A plain 'seqDmd', which is head-strict with usage UHead, can't
       be split by splitProdDmd_maybe.  But we want it to behave just
       like U(AAAA) for suitable number of absent demands. So we have
       a special case for it, with arity coming from the data constructor.

    Note [Worker-wrapper for bottoming functions]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We used not to split if the result is bottom.
    [Justification:  there's no efficiency to be gained.]

    But it's sometimes bad not to make a wrapper.  Consider
            fw = \x# -> let x = I# x# in case e of
                                            p1 -> error_fn x
                                            p2 -> error_fn x
                                            p3 -> the real stuff
    The re-boxing code won't go away unless error_fn gets a wrapper too.
    [We don't do reboxing now, but in general it's better to pass an
    unboxed thing to f, and have it reboxed in the error cases....]

    Note [Record evaluated-ness in worker/wrapper]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose we have

       data T = MkT !Int Int

       f :: T -> T
       f x = e

    and f's is strict, and has the CPR property.  The we are going to generate
    this w/w split

       f x = case x of
               MkT x1 x2 -> case $wf x1 x2 of
                               (# r1, r2 #) -> MkT r1 r2

       $wfw x1 x2 = let x = MkT x1 x2 in
                    case e of
                      MkT r1 r2 -> (# r1, r2 #)

    Note that

    * In the worker $wf, inside 'e' we can be sure that x1 will be
      evaluated (it came from unpacking the argument MkT.  But that's no
      immediately apparent in $wf

    * In the wrapper 'f', which we'll inline at call sites, we can be sure
      that 'r1' has been evaluated (because it came from unpacking the result
      MkT.  But that is not immediately apparent from the wrapper code.

    Missing these facts isn't unsound, but it loses possible future
    opportunities for optimisation.

    Solution: use setCaseBndrEvald when creating
     (A) The arg binders x1,x2 in mkWstr_one
             See #13077, test T13077
     (B) The result binders r1,r2 in mkWWcpr_help
             See Trace #13077, test T13077a
             And #13027 comment:20, item (4)
    to record that the relevant binder is evaluated.

    ************************************************************************
    *                                                                      *
             Type scrutiny that is specific to demand analysis
    *                                                                      *
    ************************************************************************
    -}

    findTypeShape :: FamInstEnvs -> Type -> TypeShape
    -- Uncover the arrow and product shape of a type
    -- The data type TypeShape is defined in GHC.Types.Demand
    -- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal
    findTypeShape :: FamInstEnvs -> Kind -> TypeShape
    findTypeShape FamInstEnvs
    fam_envs Kind
    ty
      = RecTcChecker -> Kind -> TypeShape
    go (Int -> RecTcChecker -> RecTcChecker
    setRecTcMaxBound Int
    2 RecTcChecker
    initRecTc) Kind
    ty
           -- You might think this bound of 2 is low, but actually
           -- I think even 1 would be fine.  This only bites for recursive
           -- product types, which are rare, and we really don't want
           -- to look deep into such products -- see #18034
      where
        go :: RecTcChecker -> Kind -> TypeShape
    go RecTcChecker
    rec_tc Kind
    ty
           | Just (Kind
    _, Kind
    _, Kind
    res) <- Kind -> Maybe (Kind, Kind, Kind)
    splitFunTy_maybe Kind
    ty
           = TypeShape -> TypeShape
    TsFun (RecTcChecker -> Kind -> TypeShape
    go RecTcChecker
    rec_tc Kind
    res)

           | Just (TyCon
    tc, [Kind]
    tc_args)  <- HasDebugCallStack => Kind -> Maybe (TyCon, [Kind])
    Kind -> Maybe (TyCon, [Kind])
    splitTyConApp_maybe Kind
    ty
           = RecTcChecker -> TyCon -> [Kind] -> TypeShape
    go_tc RecTcChecker
    rec_tc TyCon
    tc [Kind]
    tc_args

           | Just (Id
    _, Kind
    ty') <- Kind -> Maybe (Id, Kind)
    splitForAllTyCoVar_maybe Kind
    ty
           = RecTcChecker -> Kind -> TypeShape
    go RecTcChecker
    rec_tc Kind
    ty'

           | Bool
    otherwise
           = TypeShape
    TsUnk

        go_tc :: RecTcChecker -> TyCon -> [Kind] -> TypeShape
    go_tc RecTcChecker
    rec_tc TyCon
    tc [Kind]
    tc_args
           | Just (Coercion
    _, Kind
    rhs, MCoercion
    _) <- FamInstEnvs -> TyCon -> [Kind] -> Maybe (Coercion, Kind, MCoercion)
    topReduceTyFamApp_maybe FamInstEnvs
    fam_envs TyCon
    tc [Kind]
    tc_args
           = RecTcChecker -> Kind -> TypeShape
    go RecTcChecker
    rec_tc Kind
    rhs

           | Just DataCon
    con <- TyCon -> Maybe DataCon
    tyConSingleAlgDataCon_maybe TyCon
    tc
           , Just RecTcChecker
    rec_tc <- if TyCon -> Bool
    isTupleTyCon TyCon
    tc
                            then RecTcChecker -> Maybe RecTcChecker
    forall a. a -> Maybe a
    Just RecTcChecker
    rec_tc
                            else RecTcChecker -> TyCon -> Maybe RecTcChecker
    checkRecTc RecTcChecker
    rec_tc TyCon
    tc
             -- We treat tuples specially because they can't cause loops.
             -- Maybe we should do so in checkRecTc.
             -- The use of 'dubiousDataConInstArgTys' is OK, since this
             -- function performs no substitution at all, hence the uniques
             -- don't matter.
           = [TypeShape] -> TypeShape
    TsProd ((Kind -> TypeShape) -> [Kind] -> [TypeShape]
    forall a b. (a -> b) -> [a] -> [b]
    map (RecTcChecker -> Kind -> TypeShape
    go RecTcChecker
    rec_tc) (DataCon -> [Kind] -> [Kind]
    dubiousDataConInstArgTys DataCon
    con [Kind]
    tc_args))

           | Just (Kind
    ty', Coercion
    _) <- TyCon -> [Kind] -> Maybe (Kind, Coercion)
    instNewTyCon_maybe TyCon
    tc [Kind]
    tc_args
           , Just RecTcChecker
    rec_tc <- RecTcChecker -> TyCon -> Maybe RecTcChecker
    checkRecTc RecTcChecker
    rec_tc TyCon
    tc
           = RecTcChecker -> Kind -> TypeShape
    go RecTcChecker
    rec_tc Kind
    ty'

           | Bool
    otherwise
           = TypeShape
    TsUnk

    -- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that
    -- the 'DataCon' may not have existentials. The lack of cloning the existentials
    -- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";
    -- only use it where type variables aren't substituted for!
    dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]
    dubiousDataConInstArgTys :: DataCon -> [Kind] -> [Kind]
    dubiousDataConInstArgTys DataCon
    dc [Kind]
    tc_args = [Kind]
    arg_tys
      where
        univ_tvs :: [Id]
    univ_tvs = DataCon -> [Id]
    dataConUnivTyVars DataCon
    dc
        ex_tvs :: [Id]
    ex_tvs   = DataCon -> [Id]
    dataConExTyCoVars DataCon
    dc
        subst :: TCvSubst
    subst    = TCvSubst -> [Id] -> TCvSubst
    extendTCvInScopeList ([Id] -> [Kind] -> TCvSubst
    HasDebugCallStack => [Id] -> [Kind] -> TCvSubst
    zipTvSubst [Id]
    univ_tvs [Kind]
    tc_args) [Id]
    ex_tvs
        arg_tys :: [Kind]
    arg_tys  = (Scaled Kind -> Kind) -> [Scaled Kind] -> [Kind]
    forall a b. (a -> b) -> [a] -> [b]
    map (HasCallStack => TCvSubst -> Kind -> Kind
    TCvSubst -> Kind -> Kind
    substTy TCvSubst
    subst (Kind -> Kind) -> (Scaled Kind -> Kind) -> Scaled Kind -> Kind
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Scaled Kind -> Kind
    forall a. Scaled a -> a
    scaledThing) (DataCon -> [Scaled Kind]
    dataConRepArgTys DataCon
    dc)

    {-
    ************************************************************************
    *                                                                      *
    \subsection{CPR stuff}
    *                                                                      *
    ************************************************************************

    @mkWWcpr@ takes the worker/wrapper pair produced from the strictness
    info and adds in the CPR transformation.  The worker returns an
    unboxed tuple containing non-CPR components.  The wrapper takes this
    tuple and re-produces the correct structured output.

    The non-CPR results appear ordered in the unboxed tuple as if by a
    left-to-right traversal of the result structure.
    -}

    mkWWcpr :: Bool
            -> FamInstEnvs
            -> Type                              -- function body type
            -> Cpr                               -- CPR analysis results
            -> UniqSM (Bool,                     -- Is w/w'ing useful?
                       CoreExpr -> CoreExpr,     -- New wrapper
                       CoreExpr -> CoreExpr,     -- New worker
                       Type)                     -- Type of worker's body

    mkWWcpr :: Bool
    -> FamInstEnvs
    -> Kind
    -> Cpr
    -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    mkWWcpr Bool
    opt_CprAnal FamInstEnvs
    fam_envs Kind
    body_ty Cpr
    cpr
        -- CPR explicitly turned off (or in -O0)
      | Bool -> Bool
    not Bool
    opt_CprAnal = (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, CoreExpr -> CoreExpr
    forall a. a -> a
    id, CoreExpr -> CoreExpr
    forall a. a -> a
    id, Kind
    body_ty)
        -- CPR is turned on by default for -O and O2
      | Bool
    otherwise
      = case Cpr -> Maybe (Int, [Cpr])
    asConCpr Cpr
    cpr of
           Maybe (Int, [Cpr])
    Nothing      -> (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, CoreExpr -> CoreExpr
    forall a. a -> a
    id, CoreExpr -> CoreExpr
    forall a. a -> a
    id, Kind
    body_ty)  -- No CPR info
           Just (Int
    con_tag, [Cpr]
    _cprs)
             | Just DataConPatContext
    dcpc <- FamInstEnvs -> Int -> Kind -> Maybe DataConPatContext
    splitResultType_maybe FamInstEnvs
    fam_envs Int
    con_tag Kind
    body_ty
             -> DataConPatContext
    -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    mkWWcpr_help DataConPatContext
    dcpc
             |  Bool
    otherwise
             -- See Note [non-algebraic or open body type warning]
             -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
                (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, CoreExpr -> CoreExpr
    forall a. a -> a
    id, CoreExpr -> CoreExpr
    forall a. a -> a
    id, Kind
    body_ty)

    mkWWcpr_help :: DataConPatContext
                 -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)

    mkWWcpr_help :: DataConPatContext
    -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    mkWWcpr_help (DataConPatContext { dcpc_dc :: DataConPatContext -> DataCon
    dcpc_dc = DataCon
    dc, dcpc_tc_args :: DataConPatContext -> [Kind]
    dcpc_tc_args = [Kind]
    tc_args
                                    , dcpc_co :: DataConPatContext -> Coercion
    dcpc_co = Coercion
    co })
      | [Scaled Kind
    arg_ty]   <- DataCon -> [Kind] -> [Scaled Kind]
    dataConInstArgTys DataCon
    dc [Kind]
    tc_args -- NB: No existentials!
      , [StrictnessMark
    str_mark] <- DataCon -> [StrictnessMark]
    dataConRepStrictness DataCon
    dc
      , HasDebugCallStack => Kind -> Bool
    Kind -> Bool
    isUnliftedType (Scaled Kind -> Kind
    forall a. Scaled a -> a
    scaledThing Scaled Kind
    arg_ty)
      , Scaled Kind -> Bool
    forall a. Scaled a -> Bool
    isLinear Scaled Kind
    arg_ty
            -- Special case when there is a single result of unlifted, linear, type
            --
            -- Wrapper:     case (..call worker..) of x -> C x
            -- Worker:      case (   ..body..    ) of C x -> x
      = do { (Unique
    work_uniq : Unique
    arg_uniq : [Unique]
    _) <- UniqSM [Unique]
    forall (m :: * -> *). MonadUnique m => m [Unique]
    getUniquesM
           ; let arg_id :: Id
    arg_id    = Unique -> StrictnessMark -> Scaled Kind -> Id
    mk_ww_local Unique
    arg_uniq StrictnessMark
    str_mark Scaled Kind
    arg_ty
                 con_app :: CoreExpr
    con_app   = DataCon -> [Kind] -> [Id] -> CoreExpr
    forall b. DataCon -> [Kind] -> [Id] -> Expr b
    mkConApp2 DataCon
    dc [Kind]
    tc_args [Id
    arg_id] CoreExpr -> Coercion -> CoreExpr
    `mkCast` Coercion -> Coercion
    mkSymCo Coercion
    co

           ; (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ( Bool
    True
                    , \ CoreExpr
    wkr_call -> CoreExpr -> Id -> CoreExpr -> CoreExpr
    mkDefaultCase CoreExpr
    wkr_call Id
    arg_id CoreExpr
    con_app
                    , \ CoreExpr
    body     -> CoreExpr
    -> Coercion
    -> Kind
    -> Unique
    -> DataCon
    -> [Id]
    -> CoreExpr
    -> CoreExpr
    mkUnpackCase CoreExpr
    body Coercion
    co Kind
    One Unique
    work_uniq DataCon
    dc [Id
    arg_id] (Id -> CoreExpr
    forall b. Id -> Expr b
    varToCoreExpr Id
    arg_id)
                                    -- varToCoreExpr important here: arg can be a coercion
                                    -- Lacking this caused #10658
                    , Scaled Kind -> Kind
    forall a. Scaled a -> a
    scaledThing Scaled Kind
    arg_ty ) }

      | Bool
    otherwise   -- The general case
            -- Wrapper: case (..call worker..) of (# a, b #) -> C a b
            -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)
            --
            -- Remark on linearity: in both the case of the wrapper and the worker,
            -- we build a linear case. All the multiplicity information is kept in
            -- the constructors (both C and (#, #)). In particular (#,#) is
            -- parametrised by the multiplicity of its fields. Specifically, in this
            -- instance, the multiplicity of the fields of (#,#) is chosen to be the
            -- same as those of C.
      = do { (Unique
    work_uniq : Unique
    wild_uniq : [Unique]
    pat_bndrs_uniqs) <- UniqSM [Unique]
    forall (m :: * -> *). MonadUnique m => m [Unique]
    getUniquesM
           ; let case_mult :: Kind
    case_mult       = Kind
    One -- see above
                 ([Id]
    _exs, [Id]
    arg_ids) =
                   [FastString]
    -> [Unique] -> Kind -> DataCon -> [Kind] -> ([Id], [Id])
    dataConRepFSInstPat (FastString -> [FastString]
    forall a. a -> [a]
    repeat FastString
    ww_prefix) [Unique]
    pat_bndrs_uniqs Kind
    case_mult DataCon
    dc [Kind]
    tc_args
                 wrap_wild :: Id
    wrap_wild       = Unique -> StrictnessMark -> Scaled Kind -> Id
    mk_ww_local Unique
    wild_uniq StrictnessMark
    MarkedStrict (Kind -> Kind -> Scaled Kind
    forall a. Kind -> a -> Scaled a
    Scaled Kind
    case_mult Kind
    ubx_tup_ty)
                 ubx_tup_ty :: Kind
    ubx_tup_ty      = CoreExpr -> Kind
    exprType CoreExpr
    ubx_tup_app
                 ubx_tup_app :: CoreExpr
    ubx_tup_app     = [Kind] -> [CoreExpr] -> CoreExpr
    mkCoreUbxTup ((Id -> Kind) -> [Id] -> [Kind]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> Kind
    idType [Id]
    arg_ids) ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> CoreExpr
    forall b. Id -> Expr b
    varToCoreExpr [Id]
    arg_ids)
                 con_app :: CoreExpr
    con_app         = DataCon -> [Kind] -> [Id] -> CoreExpr
    forall b. DataCon -> [Kind] -> [Id] -> Expr b
    mkConApp2 DataCon
    dc [Kind]
    tc_args [Id]
    arg_ids CoreExpr -> Coercion -> CoreExpr
    `mkCast` Coercion -> Coercion
    mkSymCo Coercion
    co
                 tup_con :: DataCon
    tup_con         = Boxity -> Int -> DataCon
    tupleDataCon Boxity
    Unboxed ([Id] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Id]
    arg_ids)

           ; MASSERT( null _exs ) -- Should have been caught by splitResultType_maybe

           ; (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True
                    , \ CoreExpr
    wkr_call -> CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
    mkSingleAltCase CoreExpr
    wkr_call Id
    wrap_wild
                                                    (DataCon -> AltCon
    DataAlt DataCon
    tup_con) [Id]
    arg_ids CoreExpr
    con_app
                    , \ CoreExpr
    body     -> CoreExpr
    -> Coercion
    -> Kind
    -> Unique
    -> DataCon
    -> [Id]
    -> CoreExpr
    -> CoreExpr
    mkUnpackCase CoreExpr
    body Coercion
    co Kind
    case_mult Unique
    work_uniq DataCon
    dc [Id]
    arg_ids CoreExpr
    ubx_tup_app
                    , Kind
    ubx_tup_ty ) }

    mkUnpackCase ::  CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
    -- (mkUnpackCase e co uniq Con args body)
    --      returns
    -- case e |> co of bndr { Con args -> body }

    mkUnpackCase :: CoreExpr
    -> Coercion
    -> Kind
    -> Unique
    -> DataCon
    -> [Id]
    -> CoreExpr
    -> CoreExpr
    mkUnpackCase (Tick CoreTickish
    tickish CoreExpr
    e) Coercion
    co Kind
    mult Unique
    uniq DataCon
    con [Id]
    args CoreExpr
    body   -- See Note [Profiling and unpacking]
      = CoreTickish -> CoreExpr -> CoreExpr
    forall b. CoreTickish -> Expr b -> Expr b
    Tick CoreTickish
    tickish (CoreExpr
    -> Coercion
    -> Kind
    -> Unique
    -> DataCon
    -> [Id]
    -> CoreExpr
    -> CoreExpr
    mkUnpackCase CoreExpr
    e Coercion
    co Kind
    mult Unique
    uniq DataCon
    con [Id]
    args CoreExpr
    body)
    mkUnpackCase CoreExpr
    scrut Coercion
    co Kind
    mult Unique
    uniq DataCon
    boxing_con [Id]
    unpk_args CoreExpr
    body
      = CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
    mkSingleAltCase CoreExpr
    casted_scrut Id
    bndr
                        (DataCon -> AltCon
    DataAlt DataCon
    boxing_con) [Id]
    unpk_args CoreExpr
    body
      where
        casted_scrut :: CoreExpr
    casted_scrut = CoreExpr
    scrut CoreExpr -> Coercion -> CoreExpr
    `mkCast` Coercion
    co
        bndr :: Id
    bndr = Unique -> StrictnessMark -> Scaled Kind -> Id
    mk_ww_local Unique
    uniq StrictnessMark
    MarkedStrict (Kind -> Kind -> Scaled Kind
    forall a. Kind -> a -> Scaled a
    Scaled Kind
    mult (CoreExpr -> Kind
    exprType CoreExpr
    casted_scrut))
          -- An unpacking case can always be chosen linear, because the variables
          -- are always passed to a constructor. This limits the
    {-
    Note [non-algebraic or open body type warning]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    There are a few cases where the W/W transformation is told that something
    returns a constructor, but the type at hand doesn't really match this. One
    real-world example involves unsafeCoerce:
      foo = IO a
      foo = unsafeCoerce c_exit
      foreign import ccall "c_exit" c_exit :: IO ()
    Here CPR will tell you that `foo` returns a () constructor for sure, but trying
    to create a worker/wrapper for type `a` obviously fails.
    (This was a real example until ee8e792  in libraries/base.)

    It does not seem feasible to avoid all such cases already in the analyser (and
    after all, the analysis is not really wrong), so we simply do nothing here in
    mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch
    other cases where something went avoidably wrong.

    This warning also triggers for the stream fusion library within `text`.
    We can'easily W/W constructed results like `Stream` because we have no simple
    way to express existential types in the worker's type signature.

    Note [Profiling and unpacking]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    If the original function looked like
            f = \ x -> {-# SCC "foo" #-} E

    then we want the CPR'd worker to look like
            \ x -> {-# SCC "foo" #-} (case E of I# x -> x)
    and definitely not
            \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)

    This transform doesn't move work or allocation
    from one cost centre to another.

    Later [SDM]: presumably this is because we want the simplifier to
    eliminate the case, and the scc would get in the way?  I'm ok with
    including the case itself in the cost centre, since it is morally
    part of the function (post transformation) anyway.

    ************************************************************************
    *                                                                      *
    \subsection{Utilities}
    *                                                                      *
    ************************************************************************

    Note [Absent errors]
    ~~~~~~~~~~~~~~~~~~~~
    Consider
      data T = MkT [Int] [Int] ![Int]
      f :: T -> Int# -> blah
      f ps w = case ps of MkT xs _ _ -> <body mentioning xs>
    Then f gets a strictness sig of <S(L,A,A)><A>. We make worker $wf thus:

    $wf :: [Int] -> blah
    $wf xs = case ps of MkT xs _ _ -> <body mentioning xs>
      where
        ys = absentError "ys :: [Int]"
        zs = LitRubbish True
        ps = MkT xs ys zs
        w  = 0#

    We make a let-binding for Absent arguments, such as ys and w, that are not even
    passed to the worker. They should, of course, never be used. We distinguish four
    cases:

    1. Ordinary boxed, lifted arguments, like 'ys' We make a new binding for Ids
       that are marked absent, thus
          let ys = absentError "ys :: [Int]"
       The idea is that this binding will never be used; but if it
       buggily is used we'll get a runtime error message.

    2. Boxed, lifted types, with a strict demand, like 'zs'.  You may ask: how the
       demand be both absent and strict?  That's exactly what happens for 'zs': it
       is not used, so its demand is Absent, but then during w/w, in
       addDataConStrictness, we strictify the demand.  So it gets cardinality C_10,
       the empty interval.

       We don't want to use an error-thunk for 'zs' because MkT's third argument has
       a bang, and hence should be always evaluated. This turned out to be
       important when fixing #16970, which establishes the invariant that strict
       constructor arguments are always evaluated. So we use LitRubbish instead
       of an error thunk -- see #19133.

       These first two cases are distinguished by isStrictDmd in lifted_rhs.

    3. Unboxed types, like 'w', with a type like Float#, Int#. Coping with absence
       for unboxed types is important; see, for example, #4306 and #15627.  We
       simply find a suitable literal, using Literal.absentLiteralOf.  We don't have
       literals for every primitive type, so the function is partial.

    4. Boxed, unlifted types, like (Array# t).  We can't use absentError because
       unlifted bindings ares strict.  So we use LitRubbish, which we need to apply
       to the required type.

    Case (2) and (4) crucially use LitRubbish as the placeholder: see Note [Rubbish
    literals] in GHC.Types.Literal.  We could do that in case (1) as well, but we
    get slightly better self-checking with an error thunk.

    Suppose we use LitRubbish and absence analysis is Wrong, so that the "absent"
    value is used after all.  Then in case (2) we could get a seg-fault, because we
    may have replaced, say, a [Either Int Bool] by (), and that will fail if we do
    case analysis on it.  Similarly with boxed unlifted types, case (4).

    In case (3), if absence analysis is wrong we could conceivably get an exception,
    from a divide-by-zero with the absent value.  But it's very unlikely.

    Only in case (1) can we guarantee a civilised runtime error.  Not much we can do
    about this; we really rely on absence analysis to be correct.

    Historical note: I did try the experiment of using an error thunk for unlifted
    things too, relying on the simplifier to drop it as dead code.  But this is
    fragile

     - It fails when profiling is on, which disables various optimisations

     - It fails when reboxing happens. E.g.
          data T = MkT Int Int#
          f p@(MkT a _) = ...g p....
       where g is /lazy/ in 'p', but only uses the first component.  Then
       'f' is /strict/ in 'p', and only uses the first component.  So we only
       pass that component to the worker for 'f', which reconstructs 'p' to
       pass it to 'g'.  Alas we can't say
           ...f (MkT a (absentError Int# "blah"))...
       because `MkT` is strict in its Int# argument, so we get an absentError
       exception when we shouldn't.  Very annoying!
    -}

    -- | Tries to find a suitable dummy RHS to bind the given absent identifier to.
    --
    -- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding
    -- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be
    -- found (currently only happens for bindings of 'VecRep' representation).
    mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)
    mk_absent_let :: DynFlags
    -> FamInstEnvs -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)
    mk_absent_let DynFlags
    dflags FamInstEnvs
    fam_envs Id
    arg Demand
    dmd

      -- The lifted case: Bind 'absentError'
      -- See Note [Absent errors]
      | Bool -> Bool
    not (HasDebugCallStack => Kind -> Bool
    Kind -> Bool
    isUnliftedType Kind
    arg_ty)
      = (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
    forall a. a -> Maybe a
    Just (CoreBind -> CoreExpr -> CoreExpr
    forall b. Bind b -> Expr b -> Expr b
    Let (Id -> CoreExpr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    lifted_arg CoreExpr
    lifted_rhs))
      -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@
      -- See Note [Absent errors]

      | [PrimRep
    UnliftedRep] <- HasDebugCallStack => Kind -> [PrimRep]
    Kind -> [PrimRep]
    typePrimRep Kind
    arg_ty
      = (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
    forall a. a -> Maybe a
    Just (CoreBind -> CoreExpr -> CoreExpr
    forall b. Bind b -> Expr b -> Expr b
    Let (Id -> CoreExpr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    arg CoreExpr
    unlifted_rhs))

      -- The monomorphic unlifted cases: Bind to some literal, if possible
      -- See Note [Absent errors]
      | Just TyCon
    tc <- Kind -> Maybe TyCon
    tyConAppTyCon_maybe Kind
    nty
      , Just Literal
    lit <- TyCon -> Maybe Literal
    absentLiteralOf TyCon
    tc
      = (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
    forall a. a -> Maybe a
    Just (CoreBind -> CoreExpr -> CoreExpr
    forall b. Bind b -> Expr b -> Expr b
    Let (Id -> CoreExpr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    arg (Literal -> CoreExpr
    forall b. Literal -> Expr b
    Lit Literal
    lit CoreExpr -> Coercion -> CoreExpr
    `mkCast` Coercion -> Coercion
    mkSymCo Coercion
    co)))

      | Kind
    nty Kind -> Kind -> Bool
    `eqType` Kind
    unboxedUnitTy
      = (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
    forall a. a -> Maybe a
    Just (CoreBind -> CoreExpr -> CoreExpr
    forall b. Bind b -> Expr b -> Expr b
    Let (Id -> CoreExpr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    arg (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    voidPrimId CoreExpr -> Coercion -> CoreExpr
    `mkCast` Coercion -> Coercion
    mkSymCo Coercion
    co)))

      | Bool
    otherwise
      = WARN( True, text "No absent value for" <+> ppr arg_ty )
        Maybe (CoreExpr -> CoreExpr)
    forall a. Maybe a
    Nothing -- Can happen for 'State#' and things of 'VecRep'
      where
        lifted_arg :: Id
    lifted_arg   = Id
    arg Id -> StrictSig -> Id
    `setIdStrictness` StrictSig
    botSig Id -> CprSig -> Id
    `setIdCprInfo` Int -> Cpr -> CprSig
    mkCprSig Int
    0 Cpr
    botCpr
                  -- Note in strictness signature that this is bottoming
                  -- (for the sake of the "empty case scrutinee not known to
                  -- diverge for sure lint" warning)

        lifted_rhs :: CoreExpr
    lifted_rhs | Demand -> Bool
    isStrictDmd Demand
    dmd = CoreExpr -> [Kind] -> CoreExpr
    forall b. Expr b -> [Kind] -> Expr b
    mkTyApps (Literal -> CoreExpr
    forall b. Literal -> Expr b
    Lit (Bool -> Literal
    rubbishLit Bool
    True))  [Kind
    arg_ty]
                   | Bool
    otherwise       = Kind -> String -> CoreExpr
    mkAbsentErrorApp Kind
    arg_ty String
    msg
        unlifted_rhs :: CoreExpr
    unlifted_rhs = CoreExpr -> [Kind] -> CoreExpr
    forall b. Expr b -> [Kind] -> Expr b
    mkTyApps (Literal -> CoreExpr
    forall b. Literal -> Expr b
    Lit (Bool -> Literal
    rubbishLit Bool
    False)) [Kind
    arg_ty]

        arg_ty :: Kind
    arg_ty       = Id -> Kind
    idType Id
    arg

        -- Normalise the type to have best chance of finding an absent literal
        -- e.g. (#17852)   data unlifted N = MkN Int#
        --                 f :: N -> a -> a
        --                 f _ x = x
        (Coercion
    co, Kind
    nty)    = FamInstEnvs -> Kind -> Maybe (Coercion, Kind)
    topNormaliseType_maybe FamInstEnvs
    fam_envs Kind
    arg_ty
                       Maybe (Coercion, Kind) -> (Coercion, Kind) -> (Coercion, Kind)
    forall a. Maybe a -> a -> a
    `orElse` (Kind -> Coercion
    mkRepReflCo Kind
    arg_ty, Kind
    arg_ty)

        msg :: String
    msg          = DynFlags -> SDoc -> String
    showSDoc (DynFlags -> GeneralFlag -> DynFlags
    gopt_set DynFlags
    dflags GeneralFlag
    Opt_SuppressUniques)
                                ([SDoc] -> SDoc
    vcat
                                  [ String -> SDoc
    text String
    "Arg:" SDoc -> SDoc -> SDoc
    <+> Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    arg
                                  , String -> SDoc
    text String
    "Type:" SDoc -> SDoc -> SDoc
    <+> Kind -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Kind
    arg_ty
                                  , SDoc
    file_msg
                                  ])
        file_msg :: SDoc
    file_msg     = case DynFlags -> Maybe String
    outputFile DynFlags
    dflags of
                         Maybe String
    Nothing -> SDoc
    empty
                         Just String
    f  -> String -> SDoc
    text String
    "In output file " SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (String -> SDoc
    text String
    f)
                  -- We need to suppress uniques here because otherwise they'd
                  -- end up in the generated code as strings. This is bad for
                  -- determinism, because with different uniques the strings
                  -- will have different lengths and hence different costs for
                  -- the inliner leading to different inlining.
                  -- See also Note [Unique Determinism] in GHC.Types.Unique

    ww_prefix :: FastString
    ww_prefix :: FastString
    ww_prefix = String -> FastString
    fsLit String
    "ww"

    mk_ww_local :: Unique -> StrictnessMark -> Scaled Type -> Id
    -- The StrictnessMark comes form the data constructor and says
    -- whether this field is strict
    -- See Note [Record evaluated-ness in worker/wrapper]
    mk_ww_local :: Unique -> StrictnessMark -> Scaled Kind -> Id
    mk_ww_local Unique
    uniq StrictnessMark
    str (Scaled Kind
    w Kind
    ty)
      = StrictnessMark -> Id -> Id
    setCaseBndrEvald StrictnessMark
    str (Id -> Id) -> Id -> Id
    forall a b. (a -> b) -> a -> b
    $
        FastString -> Unique -> Kind -> Kind -> Id
    mkSysLocalOrCoVar FastString
    ww_prefix Unique
    uniq Kind
    w Kind
    ty