    {-# LANGUAGE CPP              #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE TupleSections    #-}

    {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

    {-
    (c) The GRASP/AQUA Project, Glasgow University, 1992-2012

    Note [Unarisation]
    ~~~~~~~~~~~~~~~~~~
    The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum
    binders. So for example:

      f (x :: (# Int, Bool #)) = f x + f (# 1, True #)

      ==>

      f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True

    It is important that we do this at the STG level and NOT at the Core level
    because it would be very hard to make this pass Core-type-preserving. In this
    example the type of 'f' changes, for example.

    STG fed to the code generators *must* be unarised because the code generators do
    not support unboxed tuple and unboxed sum binders natively.

    In more detail: (see next note for unboxed sums)

    Suppose that a variable x : (# t1, t2 #).

      * At the binding site for x, make up fresh vars  x1:t1, x2:t2

      * Extend the UnariseEnv   x :-> MultiVal [x1,x2]

      * Replace the binding with a curried binding for x1,x2

           Lambda:   \x.e                ==>   \x1 x2. e
           Case alt: MkT a b x c d -> e  ==>   MkT a b x1 x2 c d -> e

      * Replace argument occurrences with a sequence of args via a lookup in
        UnariseEnv

           f a b x c d   ==>   f a b x1 x2 c d

      * Replace tail-call occurrences with an unboxed tuple via a lookup in
        UnariseEnv

           x  ==>  (# x1, x2 #)

        So, for example

           f x = x    ==>   f x1 x2 = (# x1, x2 #)

      * We /always/ eliminate a case expression when

           - It scrutinises an unboxed tuple or unboxed sum

           - The scrutinee is a variable (or when it is an explicit tuple, but the
             simplifier eliminates those)

        The case alternative (there can be only one) can be one of these two
        things:

          - An unboxed tuple pattern. e.g.

              case v of x { (# x1, x2, x3 #) -> ... }

            Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the
            environment with

              x :-> MultiVal [t1,t2,t3]
              x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3

          - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3

    By the end of this pass, we only have unboxed tuples in return positions.
    Unboxed sums are completely eliminated, see next note.

    Note [Translating unboxed sums to unboxed tuples]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Unarise also eliminates unboxed sum binders, and translates unboxed sums in
    return positions to unboxed tuples. We want to overlap fields of a sum when
    translating it to a tuple to have efficient memory layout. When translating a
    sum pattern to a tuple pattern, we need to translate it so that binders of sum
    alternatives will be mapped to right arguments after the term translation. So
    translation of sum DataCon applications to tuple DataCon applications and
    translation of sum patterns to tuple patterns need to be in sync.

    These translations work like this. Suppose we have

      (# x1 | | ... #) :: (# t1 | t2 | ... #)

    remember that t1, t2 ... can be sums and tuples too. So we first generate
    layouts of those. Then we "merge" layouts of each alternative, which gives us a
    sum layout with best overlapping possible.

    Layout of a flat type 'ty1' is just [ty1].
    Layout of a tuple is just concatenation of layouts of its fields.

    For layout of a sum type,

      - We first get layouts of all alternatives.
      - We sort these layouts based on their "slot types".
      - We merge all the alternatives.

    For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)

      - Layouts of alternatives: [ [Word, LiftedPtr], [Word, Word], [Word] ]
      - Sorted: [ [LiftedPtr, Word], [Word, Word], [Word] ]
      - Merge all alternatives together: [ LiftedPtr, Word, Word ]

    We add a slot for the tag to the first position. So our tuple type is

      (# Tag#, Any, Word#, Word# #)
      (we use Any for pointer slots)

    Now, any term of this sum type needs to generate a tuple of this type instead.
    The translation works by simply putting arguments to first slots that they fit
    in. Suppose we had

      (# (# 42#, 'c' #) | | #)

    42# fits in Word#, 'c' fits in Any, so we generate this application:

      (# 1#, 'c', 42#, rubbish #)

    Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#,
    3# fits in Word #, so we get:

      (# 2#, rubbish, 2#, 3# #).

    When merging slots, one might be tempted to collapse lifted and unlifted
    points. However, as seen in #19645, this is wrong. Imagine that you have
    the program:

        test :: (# Char | ByteArray# #) -> ByteArray#
        test (# | ba #) = ba
        test (# c | #) = ...

    If we were to collapse the sum argument to (# Tag#, Any #) we would end up treating
    the ByteArray# as a lifted object. This would cause the code generator to
    attempt to enter it upon returning, causing a runtime crash. For this reason we
    treat unlifted and lifted things as distinct slot types, despite both being GC
    pointers.

    Note [Types in StgConApp]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose we have this unboxed sum term:

      (# 123 | #)

    What will be the unboxed tuple representation? We can't tell without knowing the
    type of this term. For example, these are all valid tuples for this:

      (# 1#, 123 #)          -- when type is (# Int | String #)
      (# 1#, 123, rubbish #) -- when type is (# Int | Float# #)
      (# 1#, 123, rubbish, rubbish #)
                             -- when type is (# Int | (# Int, Int, Int #) #)

    So we pass type arguments of the DataCon's TyCon in StgConApp to decide what
    layout to use. Note that unlifted values can't be let-bound, so we don't need
    types in StgRhsCon.

    Note [UnariseEnv can map to literals]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    To avoid redundant case expressions when unarising unboxed sums, UnariseEnv
    needs to map variables to literals too. Suppose we have this Core:

      f (# x | #)

      ==> (CorePrep)

      case (# x | #) of y {
        _ -> f y
      }

      ==> (MultiVal)

      case (# 1#, x #) of [x1, x2] {
        _ -> f x1 x2
      }

    To eliminate this case expression we need to map x1 to 1# in UnariseEnv:

      x1 :-> UnaryVal 1#, x2 :-> UnaryVal x

    so that `f x1 x2` becomes `f 1# x`.

    Note [Unarisation and arity]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Because of unarisation, the arity that will be recorded in the generated info
    table for an Id may be larger than the idArity. Instead we record what we call
    the RepArity, which is the Arity taking into account any expanded arguments, and
    corresponds to the number of (possibly-void) *registers* arguments will arrive
    in.

    Note [Post-unarisation invariants]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    STG programs after unarisation have these invariants:

      * No unboxed sums at all.

      * No unboxed tuple binders. Tuples only appear in return position.

      * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.
        This means that it's safe to wrap `StgArg`s of DataCon applications with
        `GHC.StgToCmm.Env.NonVoid`, for example.

      * Alt binders (binders in patterns) are always non-void.

      * Binders always have zero (for void arguments) or one PrimRep.
    -}

    module GHC.Stg.Unarise (unarise) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Types.Basic
    import GHC.Core
    import GHC.Core.DataCon
    import GHC.Data.FastString (FastString, mkFastString)
    import GHC.Types.Id
    import GHC.Types.Literal
    import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID)
    import GHC.Types.Id.Make (voidPrimId, voidArgId)
    import GHC.Utils.Monad (mapAccumLM)
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Types.RepType
    import GHC.Stg.Syntax
    import GHC.Core.Type
    import GHC.Builtin.Types.Prim (intPrimTy)
    import GHC.Builtin.Types
    import GHC.Types.Unique.Supply
    import GHC.Utils.Misc
    import GHC.Types.Var.Env

    import Data.Bifunctor (second)
    import Data.Maybe (mapMaybe)
    import qualified Data.IntMap as IM

    --------------------------------------------------------------------------------

    -- | A mapping from binders to the Ids they were expanded/renamed to.
    --
    --   x :-> MultiVal [a,b,c] in rho
    --
    -- iff  x's typePrimRep is not a singleton, or equivalently
    --      x's type is an unboxed tuple, sum or void.
    --
    --    x :-> UnaryVal x'
    --
    -- iff x's RepType is UnaryRep or equivalently
    --     x's type is not unboxed tuple, sum or void.
    --
    -- So
    --     x :-> MultiVal [a] in rho
    -- means x is represented by singleton tuple.
    --
    --     x :-> MultiVal [] in rho
    -- means x is void.
    --
    -- INVARIANT: OutStgArgs in the range only have NvUnaryTypes
    --            (i.e. no unboxed tuples, sums or voids)
    --
    type UnariseEnv = VarEnv UnariseVal

    data UnariseVal
      = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).
      | UnaryVal OutStgArg   -- See NOTE [Renaming during unarisation].

    instance Outputable UnariseVal where
      ppr :: UnariseVal -> SDoc
    ppr (MultiVal [OutStgArg]
    args) = String -> SDoc
    text String
    "MultiVal" SDoc -> SDoc -> SDoc
    <+> [OutStgArg] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [OutStgArg]
    args
      ppr (UnaryVal OutStgArg
    arg)   = String -> SDoc
    text String
    "UnaryVal" SDoc -> SDoc -> SDoc
    <+> OutStgArg -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr OutStgArg
    arg

    -- | Extend the environment, checking the UnariseEnv invariant.
    extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    extendRho UnariseEnv
    rho Id
    x (MultiVal [OutStgArg]
    args)
      = ASSERT(all (isNvUnaryType . stgArgType) args)
        UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    forall a. VarEnv a -> Id -> a -> VarEnv a
    extendVarEnv UnariseEnv
    rho Id
    x ([OutStgArg] -> UnariseVal
    MultiVal [OutStgArg]
    args)
    extendRho UnariseEnv
    rho Id
    x (UnaryVal OutStgArg
    val)
      = ASSERT(isNvUnaryType (stgArgType val))
        UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    forall a. VarEnv a -> Id -> a -> VarEnv a
    extendVarEnv UnariseEnv
    rho Id
    x (OutStgArg -> UnariseVal
    UnaryVal OutStgArg
    val)

    --------------------------------------------------------------------------------

    unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
    unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
    unarise UniqSupply
    us [StgTopBinding]
    binds = UniqSupply -> UniqSM [StgTopBinding] -> [StgTopBinding]
    forall a. UniqSupply -> UniqSM a -> a
    initUs_ UniqSupply
    us ((StgTopBinding -> UniqSM StgTopBinding)
    -> [StgTopBinding] -> UniqSM [StgTopBinding]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
    unariseTopBinding UnariseEnv
    forall a. VarEnv a
    emptyVarEnv) [StgTopBinding]
    binds)

    unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
    unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
    unariseTopBinding UnariseEnv
    rho (StgTopLifted GenStgBinding 'Vanilla
    bind)
      = GenStgBinding 'Vanilla -> StgTopBinding
    forall (pass :: StgPass).
    GenStgBinding pass -> GenStgTopBinding pass
    StgTopLifted (GenStgBinding 'Vanilla -> StgTopBinding)
    -> UniqSM (GenStgBinding 'Vanilla) -> UniqSM StgTopBinding
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UnariseEnv
    -> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
    unariseBinding UnariseEnv
    rho GenStgBinding 'Vanilla
    bind
    unariseTopBinding UnariseEnv
    _ bind :: StgTopBinding
    bind@StgTopStringLit{} = StgTopBinding -> UniqSM StgTopBinding
    forall (m :: * -> *) a. Monad m => a -> m a
    return StgTopBinding
    bind

    unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
    unariseBinding :: UnariseEnv
    -> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
    unariseBinding UnariseEnv
    rho (StgNonRec BinderP 'Vanilla
    x GenStgRhs 'Vanilla
    rhs)
      = BinderP 'Vanilla -> GenStgRhs 'Vanilla -> GenStgBinding 'Vanilla
    forall (pass :: StgPass).
    BinderP pass -> GenStgRhs pass -> GenStgBinding pass
    StgNonRec BinderP 'Vanilla
    x (GenStgRhs 'Vanilla -> GenStgBinding 'Vanilla)
    -> UniqSM (GenStgRhs 'Vanilla) -> UniqSM (GenStgBinding 'Vanilla)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UnariseEnv -> GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
    unariseRhs UnariseEnv
    rho GenStgRhs 'Vanilla
    rhs
    unariseBinding UnariseEnv
    rho (StgRec [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
    xrhss)
      = [(Id, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla
    forall (pass :: StgPass).
    [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
    StgRec ([(Id, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla)
    -> UniqSM [(Id, GenStgRhs 'Vanilla)]
    -> UniqSM (GenStgBinding 'Vanilla)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ((Id, GenStgRhs 'Vanilla) -> UniqSM (Id, GenStgRhs 'Vanilla))
    -> [(Id, GenStgRhs 'Vanilla)] -> UniqSM [(Id, GenStgRhs 'Vanilla)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (\(Id
    x, GenStgRhs 'Vanilla
    rhs) -> (Id
    x,) (GenStgRhs 'Vanilla -> (Id, GenStgRhs 'Vanilla))
    -> UniqSM (GenStgRhs 'Vanilla) -> UniqSM (Id, GenStgRhs 'Vanilla)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UnariseEnv -> GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
    unariseRhs UnariseEnv
    rho GenStgRhs 'Vanilla
    rhs) [(Id, GenStgRhs 'Vanilla)]
    [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
    xrhss

    unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
    unariseRhs :: UnariseEnv -> GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
    unariseRhs UnariseEnv
    rho (StgRhsClosure XRhsClosure 'Vanilla
    ext CostCentreStack
    ccs UpdateFlag
    update_flag [BinderP 'Vanilla]
    args GenStgExpr 'Vanilla
    expr)
      = do (UnariseEnv
    rho', [Id]
    args1) <- UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
    unariseFunArgBinders UnariseEnv
    rho [Id]
    [BinderP 'Vanilla]
    args
           GenStgExpr 'Vanilla
    expr' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    unariseExpr UnariseEnv
    rho' GenStgExpr 'Vanilla
    expr
           GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (XRhsClosure 'Vanilla
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP 'Vanilla]
    -> GenStgExpr 'Vanilla
    -> GenStgRhs 'Vanilla
    forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure XRhsClosure 'Vanilla
    ext CostCentreStack
    ccs UpdateFlag
    update_flag [Id]
    [BinderP 'Vanilla]
    args1 GenStgExpr 'Vanilla
    expr')

    unariseRhs UnariseEnv
    rho (StgRhsCon CostCentreStack
    ccs DataCon
    con ConstructorNumber
    mu [StgTickish]
    ts [OutStgArg]
    args)
      = ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
        GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [OutStgArg]
    -> GenStgRhs 'Vanilla
    forall (pass :: StgPass).
    CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [OutStgArg]
    -> GenStgRhs pass
    StgRhsCon CostCentreStack
    ccs DataCon
    con ConstructorNumber
    mu [StgTickish]
    ts (UnariseEnv -> [OutStgArg] -> [OutStgArg]
    unariseConArgs UnariseEnv
    rho [OutStgArg]
    args))

    --------------------------------------------------------------------------------

    unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr

    unariseExpr :: UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    unariseExpr UnariseEnv
    rho e :: GenStgExpr 'Vanilla
    e@(StgApp Id
    f [])
      = case UnariseEnv -> Id -> Maybe UnariseVal
    forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv UnariseEnv
    rho Id
    f of
          Just (MultiVal [OutStgArg]
    args)  -- Including empty tuples
            -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([OutStgArg] -> GenStgExpr 'Vanilla
    mkTuple [OutStgArg]
    args)
          Just (UnaryVal (StgVarArg Id
    f'))
            -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id -> [OutStgArg] -> GenStgExpr 'Vanilla
    forall (pass :: StgPass). Id -> [OutStgArg] -> GenStgExpr pass
    StgApp Id
    f' [])
          Just (UnaryVal (StgLitArg Literal
    f'))
            -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Literal -> GenStgExpr 'Vanilla
    forall (pass :: StgPass). Literal -> GenStgExpr pass
    StgLit Literal
    f')
          Maybe UnariseVal
    Nothing
            -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return GenStgExpr 'Vanilla
    e

    unariseExpr UnariseEnv
    rho e :: GenStgExpr 'Vanilla
    e@(StgApp Id
    f [OutStgArg]
    args)
      = GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Id -> [OutStgArg] -> GenStgExpr 'Vanilla
    forall (pass :: StgPass). Id -> [OutStgArg] -> GenStgExpr pass
    StgApp Id
    f' (UnariseEnv -> [OutStgArg] -> [OutStgArg]
    unariseFunArgs UnariseEnv
    rho [OutStgArg]
    args))
      where
        f' :: Id
    f' = case UnariseEnv -> Id -> Maybe UnariseVal
    forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv UnariseEnv
    rho Id
    f of
               Just (UnaryVal (StgVarArg Id
    f')) -> Id
    f'
               Maybe UnariseVal
    Nothing -> Id
    f
               Maybe UnariseVal
    err -> String -> SDoc -> Id
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "unariseExpr - app2" (StgPprOpts -> GenStgExpr 'Vanilla -> SDoc
    forall (pass :: StgPass).
    OutputablePass pass =>
    StgPprOpts -> GenStgExpr pass -> SDoc
    pprStgExpr StgPprOpts
    panicStgPprOpts GenStgExpr 'Vanilla
    e SDoc -> SDoc -> SDoc
    $$ Maybe UnariseVal -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Maybe UnariseVal
    err)
                   -- Can't happen because 'args' is non-empty, and
                   -- a tuple or sum cannot be applied to anything

    unariseExpr UnariseEnv
    _ (StgLit Literal
    l)
      = GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Literal -> GenStgExpr 'Vanilla
    forall (pass :: StgPass). Literal -> GenStgExpr pass
    StgLit Literal
    l)

    unariseExpr UnariseEnv
    rho (StgConApp DataCon
    dc XConApp 'Vanilla
    n [OutStgArg]
    args [Type]
    ty_args)
      | Just [OutStgArg]
    args' <- UnariseEnv -> DataCon -> [OutStgArg] -> [Type] -> Maybe [OutStgArg]
    unariseMulti_maybe UnariseEnv
    rho DataCon
    dc [OutStgArg]
    args [Type]
    ty_args
      = GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([OutStgArg] -> GenStgExpr 'Vanilla
    mkTuple [OutStgArg]
    args')

      | Bool
    otherwise
      , let args' :: [OutStgArg]
    args' = UnariseEnv -> [OutStgArg] -> [OutStgArg]
    unariseConArgs UnariseEnv
    rho [OutStgArg]
    args
      = GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DataCon
    -> XConApp 'Vanilla -> [OutStgArg] -> [Type] -> GenStgExpr 'Vanilla
    forall (pass :: StgPass).
    DataCon -> XConApp pass -> [OutStgArg] -> [Type] -> GenStgExpr pass
    StgConApp DataCon
    dc XConApp 'Vanilla
    n [OutStgArg]
    args' ((OutStgArg -> Type) -> [OutStgArg] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map OutStgArg -> Type
    stgArgType [OutStgArg]
    args'))

    unariseExpr UnariseEnv
    rho (StgOpApp StgOp
    op [OutStgArg]
    args Type
    ty)
      = GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (StgOp -> [OutStgArg] -> Type -> GenStgExpr 'Vanilla
    forall (pass :: StgPass).
    StgOp -> [OutStgArg] -> Type -> GenStgExpr pass
    StgOpApp StgOp
    op (UnariseEnv -> [OutStgArg] -> [OutStgArg]
    unariseFunArgs UnariseEnv
    rho [OutStgArg]
    args) Type
    ty)

    unariseExpr UnariseEnv
    rho (StgCase GenStgExpr 'Vanilla
    scrut BinderP 'Vanilla
    bndr AltType
    alt_ty [GenStgAlt 'Vanilla]
    alts)
      -- tuple/sum binders in the scrutinee can always be eliminated
      | StgApp Id
    v [] <- GenStgExpr 'Vanilla
    scrut
      , Just (MultiVal [OutStgArg]
    xs) <- UnariseEnv -> Id -> Maybe UnariseVal
    forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv UnariseEnv
    rho Id
    v
      = UnariseEnv
    -> [OutStgArg]
    -> Id
    -> AltType
    -> [GenStgAlt 'Vanilla]
    -> UniqSM (GenStgExpr 'Vanilla)
    elimCase UnariseEnv
    rho [OutStgArg]
    xs Id
    BinderP 'Vanilla
    bndr AltType
    alt_ty [GenStgAlt 'Vanilla]
    alts

      -- Handle strict lets for tuples and sums:
      --   case (# a,b #) of r -> rhs
      -- and analogously for sums
      | StgConApp DataCon
    dc XConApp 'Vanilla
    _n [OutStgArg]
    args [Type]
    ty_args <- GenStgExpr 'Vanilla
    scrut
      , Just [OutStgArg]
    args' <- UnariseEnv -> DataCon -> [OutStgArg] -> [Type] -> Maybe [OutStgArg]
    unariseMulti_maybe UnariseEnv
    rho DataCon
    dc [OutStgArg]
    args [Type]
    ty_args
      = UnariseEnv
    -> [OutStgArg]
    -> Id
    -> AltType
    -> [GenStgAlt 'Vanilla]
    -> UniqSM (GenStgExpr 'Vanilla)
    elimCase UnariseEnv
    rho [OutStgArg]
    args' Id
    BinderP 'Vanilla
    bndr AltType
    alt_ty [GenStgAlt 'Vanilla]
    alts

      -- general case
      | Bool
    otherwise
      = do GenStgExpr 'Vanilla
    scrut' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    unariseExpr UnariseEnv
    rho GenStgExpr 'Vanilla
    scrut
           [(AltCon, [Id], GenStgExpr 'Vanilla)]
    alts'  <- UnariseEnv
    -> AltType
    -> Id
    -> [GenStgAlt 'Vanilla]
    -> UniqSM [GenStgAlt 'Vanilla]
    unariseAlts UnariseEnv
    rho AltType
    alt_ty Id
    BinderP 'Vanilla
    bndr [GenStgAlt 'Vanilla]
    alts
           GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (GenStgExpr 'Vanilla
    -> BinderP 'Vanilla
    -> AltType
    -> [GenStgAlt 'Vanilla]
    -> GenStgExpr 'Vanilla
    forall (pass :: StgPass).
    GenStgExpr pass
    -> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
    StgCase GenStgExpr 'Vanilla
    scrut' BinderP 'Vanilla
    bndr AltType
    alt_ty [(AltCon, [Id], GenStgExpr 'Vanilla)]
    [GenStgAlt 'Vanilla]
    alts')
                           -- bndr may have a unboxed sum/tuple type but it will be
                           -- dead after unarise (checked in GHC.Stg.Lint)

    unariseExpr UnariseEnv
    rho (StgLet XLet 'Vanilla
    ext GenStgBinding 'Vanilla
    bind GenStgExpr 'Vanilla
    e)
      = XLet 'Vanilla
    -> GenStgBinding 'Vanilla
    -> GenStgExpr 'Vanilla
    -> GenStgExpr 'Vanilla
    forall (pass :: StgPass).
    XLet pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLet XLet 'Vanilla
    ext (GenStgBinding 'Vanilla
     -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
    -> UniqSM (GenStgBinding 'Vanilla)
    -> UniqSM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UnariseEnv
    -> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
    unariseBinding UnariseEnv
    rho GenStgBinding 'Vanilla
    bind UniqSM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
    -> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgExpr 'Vanilla)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    unariseExpr UnariseEnv
    rho GenStgExpr 'Vanilla
    e

    unariseExpr UnariseEnv
    rho (StgLetNoEscape XLetNoEscape 'Vanilla
    ext GenStgBinding 'Vanilla
    bind GenStgExpr 'Vanilla
    e)
      = XLetNoEscape 'Vanilla
    -> GenStgBinding 'Vanilla
    -> GenStgExpr 'Vanilla
    -> GenStgExpr 'Vanilla
    forall (pass :: StgPass).
    XLetNoEscape pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLetNoEscape XLetNoEscape 'Vanilla
    ext (GenStgBinding 'Vanilla
     -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
    -> UniqSM (GenStgBinding 'Vanilla)
    -> UniqSM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UnariseEnv
    -> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
    unariseBinding UnariseEnv
    rho GenStgBinding 'Vanilla
    bind UniqSM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
    -> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgExpr 'Vanilla)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    unariseExpr UnariseEnv
    rho GenStgExpr 'Vanilla
    e

    unariseExpr UnariseEnv
    rho (StgTick StgTickish
    tick GenStgExpr 'Vanilla
    e)
      = StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
    forall (pass :: StgPass).
    StgTickish -> GenStgExpr pass -> GenStgExpr pass
    StgTick StgTickish
    tick (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
    -> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgExpr 'Vanilla)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    unariseExpr UnariseEnv
    rho GenStgExpr 'Vanilla
    e

    -- Doesn't return void args.
    unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]
    unariseMulti_maybe :: UnariseEnv -> DataCon -> [OutStgArg] -> [Type] -> Maybe [OutStgArg]
    unariseMulti_maybe UnariseEnv
    rho DataCon
    dc [OutStgArg]
    args [Type]
    ty_args
      | DataCon -> Bool
    isUnboxedTupleDataCon DataCon
    dc
      = [OutStgArg] -> Maybe [OutStgArg]
    forall a. a -> Maybe a
    Just (UnariseEnv -> [OutStgArg] -> [OutStgArg]
    unariseConArgs UnariseEnv
    rho [OutStgArg]
    args)

      | DataCon -> Bool
    isUnboxedSumDataCon DataCon
    dc
      , let args1 :: [OutStgArg]
    args1 = ASSERT(isSingleton args) (unariseConArgs rho args)
      = [OutStgArg] -> Maybe [OutStgArg]
    forall a. a -> Maybe a
    Just (DataCon -> [Type] -> [OutStgArg] -> [OutStgArg]
    mkUbxSum DataCon
    dc [Type]
    ty_args [OutStgArg]
    args1)

      | Bool
    otherwise
      = Maybe [OutStgArg]
    forall a. Maybe a
    Nothing

    --------------------------------------------------------------------------------

    elimCase :: UnariseEnv
             -> [OutStgArg] -- non-void args
             -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr

    elimCase :: UnariseEnv
    -> [OutStgArg]
    -> Id
    -> AltType
    -> [GenStgAlt 'Vanilla]
    -> UniqSM (GenStgExpr 'Vanilla)
    elimCase UnariseEnv
    rho [OutStgArg]
    args Id
    bndr (MultiValAlt Int
    _) [(AltCon
    _, [BinderP 'Vanilla]
    bndrs, GenStgExpr 'Vanilla
    rhs)]
      = do let rho1 :: UnariseEnv
    rho1 = UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    extendRho UnariseEnv
    rho Id
    bndr ([OutStgArg] -> UnariseVal
    MultiVal [OutStgArg]
    args)
               rho2 :: UnariseEnv
    rho2
                 | Id -> Bool
    isUnboxedTupleBndr Id
    bndr
                 = [Id] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
    mapTupleIdBinders [Id]
    [BinderP 'Vanilla]
    bndrs [OutStgArg]
    args UnariseEnv
    rho1
                 | Bool
    otherwise
                 = ASSERT(isUnboxedSumBndr bndr)
                   if [Id] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Id]
    [BinderP 'Vanilla]
    bndrs then UnariseEnv
    rho1
                                 else [Id] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
    mapSumIdBinders [Id]
    [BinderP 'Vanilla]
    bndrs [OutStgArg]
    args UnariseEnv
    rho1

           UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    unariseExpr UnariseEnv
    rho2 GenStgExpr 'Vanilla
    rhs

    elimCase UnariseEnv
    rho [OutStgArg]
    args Id
    bndr (MultiValAlt Int
    _) [GenStgAlt 'Vanilla]
    alts
      | Id -> Bool
    isUnboxedSumBndr Id
    bndr
      = do let (OutStgArg
    tag_arg : [OutStgArg]
    real_args) = [OutStgArg]
    args
           Id
    tag_bndr <- FastString -> Type -> UniqSM Id
    mkId (String -> FastString
    mkFastString String
    "tag") Type
    tagTy
              -- this won't be used but we need a binder anyway
           let rho1 :: UnariseEnv
    rho1 = UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    extendRho UnariseEnv
    rho Id
    bndr ([OutStgArg] -> UnariseVal
    MultiVal [OutStgArg]
    args)
               scrut' :: GenStgExpr 'Vanilla
    scrut' = case OutStgArg
    tag_arg of
                          StgVarArg Id
    v     -> Id -> [OutStgArg] -> GenStgExpr 'Vanilla
    forall (pass :: StgPass). Id -> [OutStgArg] -> GenStgExpr pass
    StgApp Id
    v []
                          StgLitArg Literal
    l     -> Literal -> GenStgExpr 'Vanilla
    forall (pass :: StgPass). Literal -> GenStgExpr pass
    StgLit Literal
    l

           [(AltCon, [Id], GenStgExpr 'Vanilla)]
    alts' <- UnariseEnv
    -> [OutStgArg]
    -> [GenStgAlt 'Vanilla]
    -> UniqSM [GenStgAlt 'Vanilla]
    unariseSumAlts UnariseEnv
    rho1 [OutStgArg]
    real_args [GenStgAlt 'Vanilla]
    alts
           GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (GenStgExpr 'Vanilla
    -> BinderP 'Vanilla
    -> AltType
    -> [GenStgAlt 'Vanilla]
    -> GenStgExpr 'Vanilla
    forall (pass :: StgPass).
    GenStgExpr pass
    -> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
    StgCase GenStgExpr 'Vanilla
    scrut' Id
    BinderP 'Vanilla
    tag_bndr AltType
    tagAltTy [(AltCon, [Id], GenStgExpr 'Vanilla)]
    [GenStgAlt 'Vanilla]
    alts')

    elimCase UnariseEnv
    _ [OutStgArg]
    args Id
    bndr AltType
    alt_ty [GenStgAlt 'Vanilla]
    alts
      = String -> SDoc -> UniqSM (GenStgExpr 'Vanilla)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "elimCase - unhandled case"
          ([OutStgArg] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [OutStgArg]
    args SDoc -> SDoc -> SDoc
    <+> Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    bndr SDoc -> SDoc -> SDoc
    <+> AltType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr AltType
    alt_ty SDoc -> SDoc -> SDoc
    $$ [(AltCon, [Id], GenStgExpr 'Vanilla)] -> SDoc
    forall a b (pass :: StgPass).
    (Outputable a, Outputable b, OutputablePass pass) =>
    [(a, b, GenStgExpr pass)] -> SDoc
    pprPanicAlts [(AltCon, [Id], GenStgExpr 'Vanilla)]
    [GenStgAlt 'Vanilla]
    alts)

    --------------------------------------------------------------------------------

    unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
    unariseAlts :: UnariseEnv
    -> AltType
    -> Id
    -> [GenStgAlt 'Vanilla]
    -> UniqSM [GenStgAlt 'Vanilla]
    unariseAlts UnariseEnv
    rho (MultiValAlt Int
    n) Id
    bndr [(AltCon
    DEFAULT, [], GenStgExpr 'Vanilla
    e)]
      | Id -> Bool
    isUnboxedTupleBndr Id
    bndr
      = do (UnariseEnv
    rho', [Id]
    ys) <- UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
    unariseConArgBinder UnariseEnv
    rho Id
    bndr
           GenStgExpr 'Vanilla
    e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    unariseExpr UnariseEnv
    rho' GenStgExpr 'Vanilla
    e
           [(AltCon, [Id], GenStgExpr 'Vanilla)]
    -> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [(DataCon -> AltCon
    DataAlt (Boxity -> Int -> DataCon
    tupleDataCon Boxity
    Unboxed Int
    n), [Id]
    ys, GenStgExpr 'Vanilla
    e')]

    unariseAlts UnariseEnv
    rho (MultiValAlt Int
    n) Id
    bndr [(DataAlt DataCon
    _, [BinderP 'Vanilla]
    ys, GenStgExpr 'Vanilla
    e)]
      | Id -> Bool
    isUnboxedTupleBndr Id
    bndr
      = do (UnariseEnv
    rho', [Id]
    ys1) <- UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
    unariseConArgBinders UnariseEnv
    rho [Id]
    [BinderP 'Vanilla]
    ys
           MASSERT(ys1 `lengthIs` n)
           let rho'' :: UnariseEnv
    rho'' = UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    extendRho UnariseEnv
    rho' Id
    bndr ([OutStgArg] -> UnariseVal
    MultiVal ((Id -> OutStgArg) -> [Id] -> [OutStgArg]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> OutStgArg
    StgVarArg [Id]
    ys1))
           GenStgExpr 'Vanilla
    e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    unariseExpr UnariseEnv
    rho'' GenStgExpr 'Vanilla
    e
           [(AltCon, [Id], GenStgExpr 'Vanilla)]
    -> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [(DataCon -> AltCon
    DataAlt (Boxity -> Int -> DataCon
    tupleDataCon Boxity
    Unboxed Int
    n), [Id]
    ys1, GenStgExpr 'Vanilla
    e')]

    unariseAlts UnariseEnv
    _ (MultiValAlt Int
    _) Id
    bndr [GenStgAlt 'Vanilla]
    alts
      | Id -> Bool
    isUnboxedTupleBndr Id
    bndr
      = String -> SDoc -> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "unariseExpr: strange multi val alts" ([(AltCon, [Id], GenStgExpr 'Vanilla)] -> SDoc
    forall a b (pass :: StgPass).
    (Outputable a, Outputable b, OutputablePass pass) =>
    [(a, b, GenStgExpr pass)] -> SDoc
    pprPanicAlts [(AltCon, [Id], GenStgExpr 'Vanilla)]
    [GenStgAlt 'Vanilla]
    alts)

    -- In this case we don't need to scrutinize the tag bit
    unariseAlts UnariseEnv
    rho (MultiValAlt Int
    _) Id
    bndr [(AltCon
    DEFAULT, [BinderP 'Vanilla]
    _, GenStgExpr 'Vanilla
    rhs)]
      | Id -> Bool
    isUnboxedSumBndr Id
    bndr
      = do (UnariseEnv
    rho_sum_bndrs, [Id]
    sum_bndrs) <- UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
    unariseConArgBinder UnariseEnv
    rho Id
    bndr
           GenStgExpr 'Vanilla
    rhs' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    unariseExpr UnariseEnv
    rho_sum_bndrs GenStgExpr 'Vanilla
    rhs
           [(AltCon, [Id], GenStgExpr 'Vanilla)]
    -> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [(DataCon -> AltCon
    DataAlt (Boxity -> Int -> DataCon
    tupleDataCon Boxity
    Unboxed ([Id] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Id]
    sum_bndrs)), [Id]
    sum_bndrs, GenStgExpr 'Vanilla
    rhs')]

    unariseAlts UnariseEnv
    rho (MultiValAlt Int
    _) Id
    bndr [GenStgAlt 'Vanilla]
    alts
      | Id -> Bool
    isUnboxedSumBndr Id
    bndr
      = do (UnariseEnv
    rho_sum_bndrs, scrt_bndrs :: [Id]
    scrt_bndrs@(Id
    tag_bndr : [Id]
    real_bndrs)) <- UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
    unariseConArgBinder UnariseEnv
    rho Id
    bndr
           [(AltCon, [Id], GenStgExpr 'Vanilla)]
    alts' <- UnariseEnv
    -> [OutStgArg]
    -> [GenStgAlt 'Vanilla]
    -> UniqSM [GenStgAlt 'Vanilla]
    unariseSumAlts UnariseEnv
    rho_sum_bndrs ((Id -> OutStgArg) -> [Id] -> [OutStgArg]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> OutStgArg
    StgVarArg [Id]
    real_bndrs) [GenStgAlt 'Vanilla]
    alts
           let inner_case :: GenStgExpr 'Vanilla
    inner_case = GenStgExpr 'Vanilla
    -> BinderP 'Vanilla
    -> AltType
    -> [GenStgAlt 'Vanilla]
    -> GenStgExpr 'Vanilla
    forall (pass :: StgPass).
    GenStgExpr pass
    -> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
    StgCase (Id -> [OutStgArg] -> GenStgExpr 'Vanilla
    forall (pass :: StgPass). Id -> [OutStgArg] -> GenStgExpr pass
    StgApp Id
    tag_bndr []) Id
    BinderP 'Vanilla
    tag_bndr AltType
    tagAltTy [(AltCon, [Id], GenStgExpr 'Vanilla)]
    [GenStgAlt 'Vanilla]
    alts'
           [(AltCon, [Id], GenStgExpr 'Vanilla)]
    -> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [ (DataCon -> AltCon
    DataAlt (Boxity -> Int -> DataCon
    tupleDataCon Boxity
    Unboxed ([Id] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Id]
    scrt_bndrs)),
                     [Id]
    scrt_bndrs,
                     GenStgExpr 'Vanilla
    inner_case) ]

    unariseAlts UnariseEnv
    rho AltType
    _ Id
    _ [GenStgAlt 'Vanilla]
    alts
      = ((AltCon, [Id], GenStgExpr 'Vanilla)
     -> UniqSM (AltCon, [Id], GenStgExpr 'Vanilla))
    -> [(AltCon, [Id], GenStgExpr 'Vanilla)]
    -> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (\(AltCon, [Id], GenStgExpr 'Vanilla)
    alt -> UnariseEnv -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
    unariseAlt UnariseEnv
    rho (AltCon, [Id], GenStgExpr 'Vanilla)
    GenStgAlt 'Vanilla
    alt) [(AltCon, [Id], GenStgExpr 'Vanilla)]
    [GenStgAlt 'Vanilla]
    alts

    unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
    unariseAlt :: UnariseEnv -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
    unariseAlt UnariseEnv
    rho (AltCon
    con, [BinderP 'Vanilla]
    xs, GenStgExpr 'Vanilla
    e)
      = do (UnariseEnv
    rho', [Id]
    xs') <- UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
    unariseConArgBinders UnariseEnv
    rho [Id]
    [BinderP 'Vanilla]
    xs
           (AltCon
    con, [Id]
    xs',) (GenStgExpr 'Vanilla -> (AltCon, [Id], GenStgExpr 'Vanilla))
    -> UniqSM (GenStgExpr 'Vanilla)
    -> UniqSM (AltCon, [Id], GenStgExpr 'Vanilla)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    unariseExpr UnariseEnv
    rho' GenStgExpr 'Vanilla
    e

    --------------------------------------------------------------------------------

    -- | Make alternatives that match on the tag of a sum
    -- (i.e. generate LitAlts for the tag)
    unariseSumAlts :: UnariseEnv
                   -> [StgArg] -- sum components _excluding_ the tag bit.
                   -> [StgAlt] -- original alternative with sum LHS
                   -> UniqSM [StgAlt]
    unariseSumAlts :: UnariseEnv
    -> [OutStgArg]
    -> [GenStgAlt 'Vanilla]
    -> UniqSM [GenStgAlt 'Vanilla]
    unariseSumAlts UnariseEnv
    env [OutStgArg]
    args [GenStgAlt 'Vanilla]
    alts
      = do [(AltCon, [Id], GenStgExpr 'Vanilla)]
    alts' <- ((AltCon, [Id], GenStgExpr 'Vanilla)
     -> UniqSM (AltCon, [Id], GenStgExpr 'Vanilla))
    -> [(AltCon, [Id], GenStgExpr 'Vanilla)]
    -> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (UnariseEnv
    -> [OutStgArg] -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
    unariseSumAlt UnariseEnv
    env [OutStgArg]
    args) [(AltCon, [Id], GenStgExpr 'Vanilla)]
    [GenStgAlt 'Vanilla]
    alts
           [(AltCon, [Id], GenStgExpr 'Vanilla)]
    -> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([GenStgAlt 'Vanilla] -> [GenStgAlt 'Vanilla]
    mkDefaultLitAlt [(AltCon, [Id], GenStgExpr 'Vanilla)]
    [GenStgAlt 'Vanilla]
    alts')

    unariseSumAlt :: UnariseEnv
                  -> [StgArg] -- sum components _excluding_ the tag bit.
                  -> StgAlt   -- original alternative with sum LHS
                  -> UniqSM StgAlt
    unariseSumAlt :: UnariseEnv
    -> [OutStgArg] -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
    unariseSumAlt UnariseEnv
    rho [OutStgArg]
    _ (AltCon
    DEFAULT, [BinderP 'Vanilla]
    _, GenStgExpr 'Vanilla
    e)
      = ( AltCon
    DEFAULT, [], ) (GenStgExpr 'Vanilla -> (AltCon, [Id], GenStgExpr 'Vanilla))
    -> UniqSM (GenStgExpr 'Vanilla)
    -> UniqSM (AltCon, [Id], GenStgExpr 'Vanilla)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    unariseExpr UnariseEnv
    rho GenStgExpr 'Vanilla
    e

    unariseSumAlt UnariseEnv
    rho [OutStgArg]
    args (DataAlt DataCon
    sumCon, [BinderP 'Vanilla]
    bs, GenStgExpr 'Vanilla
    e)
      = do let rho' :: UnariseEnv
    rho' = [Id] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
    mapSumIdBinders [Id]
    [BinderP 'Vanilla]
    bs [OutStgArg]
    args UnariseEnv
    rho
           GenStgExpr 'Vanilla
    e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
    unariseExpr UnariseEnv
    rho' GenStgExpr 'Vanilla
    e
           (AltCon, [Id], GenStgExpr 'Vanilla)
    -> UniqSM (AltCon, [Id], GenStgExpr 'Vanilla)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ( Literal -> AltCon
    LitAlt (LitNumType -> Integer -> Literal
    LitNumber LitNumType
    LitNumInt (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (DataCon -> Int
    dataConTag DataCon
    sumCon))), [], GenStgExpr 'Vanilla
    e' )

    unariseSumAlt UnariseEnv
    _ [OutStgArg]
    scrt GenStgAlt 'Vanilla
    alt
      = String -> SDoc -> UniqSM (AltCon, [Id], GenStgExpr 'Vanilla)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "unariseSumAlt" ([OutStgArg] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [OutStgArg]
    scrt SDoc -> SDoc -> SDoc
    $$ (AltCon, [Id], GenStgExpr 'Vanilla) -> SDoc
    forall a b (pass :: StgPass).
    (Outputable a, Outputable b, OutputablePass pass) =>
    (a, b, GenStgExpr pass) -> SDoc
    pprPanicAlt (AltCon, [Id], GenStgExpr 'Vanilla)
    GenStgAlt 'Vanilla
    alt)

    --------------------------------------------------------------------------------

    mapTupleIdBinders
      :: [InId]       -- Un-processed binders of a tuple alternative.
                      -- Can have void binders.
      -> [OutStgArg]  -- Arguments that form the tuple (after unarisation).
                      -- Can't have void args.
      -> UnariseEnv
      -> UnariseEnv
    mapTupleIdBinders :: [Id] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
    mapTupleIdBinders [Id]
    ids [OutStgArg]
    args0 UnariseEnv
    rho0
      = ASSERT(not (any (isVoidTy . stgArgType) args0))
        let
          ids_unarised :: [(Id, [PrimRep])]
          ids_unarised :: [(Id, [PrimRep])]
    ids_unarised = (Id -> (Id, [PrimRep])) -> [Id] -> [(Id, [PrimRep])]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Id
    id -> (Id
    id, HasDebugCallStack => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRep (Id -> Type
    idType Id
    id))) [Id]
    ids

          map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
          map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [OutStgArg] -> UnariseEnv
    map_ids UnariseEnv
    rho [] [OutStgArg]
    _  = UnariseEnv
    rho
          map_ids UnariseEnv
    rho ((Id
    x, [PrimRep]
    x_reps) : [(Id, [PrimRep])]
    xs) [OutStgArg]
    args =
            let
              x_arity :: Int
    x_arity = [PrimRep] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [PrimRep]
    x_reps
              ([OutStgArg]
    x_args, [OutStgArg]
    args') =
                ASSERT(args `lengthAtLeast` x_arity)
                Int -> [OutStgArg] -> ([OutStgArg], [OutStgArg])
    forall a. Int -> [a] -> ([a], [a])
    splitAt Int
    x_arity [OutStgArg]
    args

              rho' :: UnariseEnv
    rho'
                | Int
    x_arity Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    1
                = ASSERT(x_args `lengthIs` 1)
                  UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    extendRho UnariseEnv
    rho Id
    x (OutStgArg -> UnariseVal
    UnaryVal ([OutStgArg] -> OutStgArg
    forall a. [a] -> a
    head [OutStgArg]
    x_args))
                | Bool
    otherwise
                = UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    extendRho UnariseEnv
    rho Id
    x ([OutStgArg] -> UnariseVal
    MultiVal [OutStgArg]
    x_args)
            in
              UnariseEnv -> [(Id, [PrimRep])] -> [OutStgArg] -> UnariseEnv
    map_ids UnariseEnv
    rho' [(Id, [PrimRep])]
    xs [OutStgArg]
    args'
        in
          UnariseEnv -> [(Id, [PrimRep])] -> [OutStgArg] -> UnariseEnv
    map_ids UnariseEnv
    rho0 [(Id, [PrimRep])]
    ids_unarised [OutStgArg]
    args0

    mapSumIdBinders
      :: [InId]      -- Binder of a sum alternative (remember that sum patterns
                     -- only have one binder, so this list should be a singleton)
      -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).
                     -- Can't have void args.
      -> UnariseEnv
      -> UnariseEnv

    mapSumIdBinders :: [Id] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
    mapSumIdBinders [Id
    id] [OutStgArg]
    args UnariseEnv
    rho0
      = ASSERT(not (any (isVoidTy . stgArgType) args))
        let
          arg_slots :: [SlotTy]
    arg_slots = (PrimRep -> SlotTy) -> [PrimRep] -> [SlotTy]
    forall a b. (a -> b) -> [a] -> [b]
    map PrimRep -> SlotTy
    primRepSlot ([PrimRep] -> [SlotTy]) -> [PrimRep] -> [SlotTy]
    forall a b. (a -> b) -> a -> b
    $ (OutStgArg -> [PrimRep]) -> [OutStgArg] -> [PrimRep]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (HasDebugCallStack => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRep (Type -> [PrimRep])
    -> (OutStgArg -> Type) -> OutStgArg -> [PrimRep]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . OutStgArg -> Type
    stgArgType) [OutStgArg]
    args
          id_slots :: [SlotTy]
    id_slots  = (PrimRep -> SlotTy) -> [PrimRep] -> [SlotTy]
    forall a b. (a -> b) -> [a] -> [b]
    map PrimRep -> SlotTy
    primRepSlot ([PrimRep] -> [SlotTy]) -> [PrimRep] -> [SlotTy]
    forall a b. (a -> b) -> a -> b
    $ HasDebugCallStack => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRep (Id -> Type
    idType Id
    id)
          layout1 :: [Int]
    layout1   = [SlotTy] -> [SlotTy] -> [Int]
    layoutUbxSum [SlotTy]
    arg_slots [SlotTy]
    id_slots
        in
          if Id -> Bool
    isMultiValBndr Id
    id
            then UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    extendRho UnariseEnv
    rho0 Id
    id ([OutStgArg] -> UnariseVal
    MultiVal [ [OutStgArg]
    args [OutStgArg] -> Int -> OutStgArg
    forall a. [a] -> Int -> a
    !! Int
    i | Int
    i <- [Int]
    layout1 ])
            else ASSERT(layout1 `lengthIs` 1)
                 UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    extendRho UnariseEnv
    rho0 Id
    id (OutStgArg -> UnariseVal
    UnaryVal ([OutStgArg]
    args [OutStgArg] -> Int -> OutStgArg
    forall a. [a] -> Int -> a
    !! [Int] -> Int
    forall a. [a] -> a
    head [Int]
    layout1))

    mapSumIdBinders [Id]
    ids [OutStgArg]
    sum_args UnariseEnv
    _
      = String -> SDoc -> UnariseEnv
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "mapSumIdBinders" ([Id] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Id]
    ids SDoc -> SDoc -> SDoc
    $$ [OutStgArg] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [OutStgArg]
    sum_args)

    -- | Build a unboxed sum term from arguments of an alternative.
    --
    -- Example, for (# x | #) :: (# (# #) | Int #) we call
    --
    --   mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]
    --
    -- which returns
    --
    --   [ 1#, rubbish ]
    --
    mkUbxSum
      :: DataCon      -- Sum data con
      -> [Type]       -- Type arguments of the sum data con
      -> [OutStgArg]  -- Actual arguments of the alternative.
      -> [OutStgArg]  -- Final tuple arguments
    mkUbxSum :: DataCon -> [Type] -> [OutStgArg] -> [OutStgArg]
    mkUbxSum DataCon
    dc [Type]
    ty_args [OutStgArg]
    args0
      = let
          (SlotTy
    _ : [SlotTy]
    sum_slots) = [[PrimRep]] -> [SlotTy]
    ubxSumRepType ((Type -> [PrimRep]) -> [Type] -> [[PrimRep]]
    forall a b. (a -> b) -> [a] -> [b]
    map HasDebugCallStack => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRep [Type]
    ty_args)
            -- drop tag slot

          tag :: Int
    tag = DataCon -> Int
    dataConTag DataCon
    dc

          layout' :: [Int]
    layout'  = [SlotTy] -> [SlotTy] -> [Int]
    layoutUbxSum [SlotTy]
    sum_slots ((OutStgArg -> Maybe SlotTy) -> [OutStgArg] -> [SlotTy]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (Type -> Maybe SlotTy
    typeSlotTy (Type -> Maybe SlotTy)
    -> (OutStgArg -> Type) -> OutStgArg -> Maybe SlotTy
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . OutStgArg -> Type
    stgArgType) [OutStgArg]
    args0)
          tag_arg :: OutStgArg
    tag_arg  = Literal -> OutStgArg
    StgLitArg (LitNumType -> Integer -> Literal
    LitNumber LitNumType
    LitNumInt (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    tag))
          arg_idxs :: IntMap OutStgArg
    arg_idxs = [(Int, OutStgArg)] -> IntMap OutStgArg
    forall a. [(Int, a)] -> IntMap a
    IM.fromList (String -> [Int] -> [OutStgArg] -> [(Int, OutStgArg)]
    forall a b. String -> [a] -> [b] -> [(a, b)]
    zipEqual String
    "mkUbxSum" [Int]
    layout' [OutStgArg]
    args0)

          mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
          mkTupArgs :: Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
    mkTupArgs Int
    _ [] IntMap OutStgArg
    _
            = []
          mkTupArgs Int
    arg_idx (SlotTy
    slot : [SlotTy]
    slots_left) IntMap OutStgArg
    arg_map
            | Just OutStgArg
    stg_arg <- Int -> IntMap OutStgArg -> Maybe OutStgArg
    forall a. Int -> IntMap a -> Maybe a
    IM.lookup Int
    arg_idx IntMap OutStgArg
    arg_map
            = OutStgArg
    stg_arg OutStgArg -> [OutStgArg] -> [OutStgArg]
    forall a. a -> [a] -> [a]
    : Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
    mkTupArgs (Int
    arg_idx Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) [SlotTy]
    slots_left IntMap OutStgArg
    arg_map
            | Bool
    otherwise
            = SlotTy -> OutStgArg
    ubxSumRubbishArg SlotTy
    slot OutStgArg -> [OutStgArg] -> [OutStgArg]
    forall a. a -> [a] -> [a]
    : Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
    mkTupArgs (Int
    arg_idx Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) [SlotTy]
    slots_left IntMap OutStgArg
    arg_map
        in
          OutStgArg
    tag_arg OutStgArg -> [OutStgArg] -> [OutStgArg]
    forall a. a -> [a] -> [a]
    : Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
    mkTupArgs Int
    0 [SlotTy]
    sum_slots IntMap OutStgArg
    arg_idxs

    -- | Return a rubbish value for the given slot type.
    --
    -- We use the following rubbish values:
    --    * Literals: 0 or 0.0
    --    * Pointers: `ghc-prim:GHC.Prim.Panic.absentSumFieldError`
    --
    -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in "GHC.Core.Make"
    --
    ubxSumRubbishArg :: SlotTy -> StgArg
    ubxSumRubbishArg :: SlotTy -> OutStgArg
    ubxSumRubbishArg SlotTy
    PtrLiftedSlot    = Id -> OutStgArg
    StgVarArg Id
    aBSENT_SUM_FIELD_ERROR_ID
    ubxSumRubbishArg SlotTy
    PtrUnliftedSlot  = Id -> OutStgArg
    StgVarArg Id
    aBSENT_SUM_FIELD_ERROR_ID
    ubxSumRubbishArg SlotTy
    WordSlot   = Literal -> OutStgArg
    StgLitArg (LitNumType -> Integer -> Literal
    LitNumber LitNumType
    LitNumWord Integer
    0)
    ubxSumRubbishArg SlotTy
    Word64Slot = Literal -> OutStgArg
    StgLitArg (LitNumType -> Integer -> Literal
    LitNumber LitNumType
    LitNumWord64 Integer
    0)
    ubxSumRubbishArg SlotTy
    FloatSlot  = Literal -> OutStgArg
    StgLitArg (Rational -> Literal
    LitFloat Rational
    0)
    ubxSumRubbishArg SlotTy
    DoubleSlot = Literal -> OutStgArg
    StgLitArg (Rational -> Literal
    LitDouble Rational
    0)

    --------------------------------------------------------------------------------

    {-
    For arguments (StgArg) and binders (Id) we have two kind of unarisation:

      - When unarising function arg binders and arguments, we don't want to remove
        void binders and arguments. For example,

          f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...
          f x y z = <body>

        Here after unarise we should still get a function with arity 3. Similarly
        in the call site we shouldn't remove void arguments:

          f (# (# #), (# #) #) voidId rw

        When unarising <body>, we extend the environment with these binders:

          x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []

        Because their rep types are `MultiRep []` (aka. void). This means that when
        we see `x` in a function argument position, we actually replace it with a
        void argument. When we see it in a DataCon argument position, we just get
        rid of it, because DataCon applications in STG are always saturated.

      - When unarising case alternative binders we remove void binders, but we
        still update the environment the same way, because those binders may be
        used in the RHS. Example:

          case x of y {
            (# x1, x2, x3 #) -> <RHS>
          }

        We know that y can't be void, because we don't scrutinize voids, so x will
        be unarised to some number of arguments, and those arguments will have at
        least one non-void thing. So in the rho we will have something like:

          x :-> MultiVal [xu1, xu2]

        Now, after we eliminate void binders in the pattern, we get exactly the same
        number of binders, and extend rho again with these:

          x1 :-> UnaryVal xu1
          x2 :-> MultiVal [] -- x2 is void
          x3 :-> UnaryVal xu2

        Now when we see x2 in a function argument position or in return position, we
        generate void#. In constructor argument position, we just remove it.

    So in short, when we have a void id,

      - We keep it if it's a lambda argument binder or
                           in argument position of an application.

      - We remove it if it's a DataCon field binder or
                             in argument position of a DataCon application.
    -}

    unariseArgBinder
        :: Bool -- data con arg?
        -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
    unariseArgBinder :: Bool -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
    unariseArgBinder Bool
    is_con_arg UnariseEnv
    rho Id
    x =
      case HasDebugCallStack => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRep (Id -> Type
    idType Id
    x) of
        []
          | Bool
    is_con_arg
          -> (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    extendRho UnariseEnv
    rho Id
    x ([OutStgArg] -> UnariseVal
    MultiVal []), [])
          | Bool
    otherwise -- fun arg, do not remove void binders
          -> (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    extendRho UnariseEnv
    rho Id
    x ([OutStgArg] -> UnariseVal
    MultiVal []), [Id
    voidArgId])

        [PrimRep
    rep]
          -- Arg represented as single variable, but original type may still be an
          -- unboxed sum/tuple, e.g. (# Void# | Void# #).
          --
          -- While not unarising the binder in this case does not break any programs
          -- (because it unarises to a single variable), it triggers StgLint as we
          -- break the post-unarisation invariant that says unboxed tuple/sum
          -- binders should vanish. See Note [Post-unarisation invariants].
          | Type -> Bool
    isUnboxedSumType (Id -> Type
    idType Id
    x) Bool -> Bool -> Bool
    || Type -> Bool
    isUnboxedTupleType (Id -> Type
    idType Id
    x)
          -> do Id
    x' <- FastString -> Type -> UniqSM Id
    mkId (String -> FastString
    mkFastString String
    "us") (PrimRep -> Type
    primRepToType PrimRep
    rep)
                (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    extendRho UnariseEnv
    rho Id
    x ([OutStgArg] -> UnariseVal
    MultiVal [Id -> OutStgArg
    StgVarArg Id
    x']), [Id
    x'])
          | Bool
    otherwise
          -> (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (UnariseEnv
    rho, [Id
    x])

        [PrimRep]
    reps -> do
          [Id]
    xs <- FastString -> [Type] -> UniqSM [Id]
    mkIds (String -> FastString
    mkFastString String
    "us") ((PrimRep -> Type) -> [PrimRep] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map PrimRep -> Type
    primRepToType [PrimRep]
    reps)
          (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
    extendRho UnariseEnv
    rho Id
    x ([OutStgArg] -> UnariseVal
    MultiVal ((Id -> OutStgArg) -> [Id] -> [OutStgArg]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> OutStgArg
    StgVarArg [Id]
    xs)), [Id]
    xs)

    --------------------------------------------------------------------------------

    -- | MultiVal a function argument. Never returns an empty list.
    unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
    unariseFunArg :: UnariseEnv -> OutStgArg -> [OutStgArg]
    unariseFunArg UnariseEnv
    rho (StgVarArg Id
    x) =
      case UnariseEnv -> Id -> Maybe UnariseVal
    forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv UnariseEnv
    rho Id
    x of
        Just (MultiVal [])  -> [OutStgArg
    voidArg]   -- NB: do not remove void args
        Just (MultiVal [OutStgArg]
    as)  -> [OutStgArg]
    as
        Just (UnaryVal OutStgArg
    arg) -> [OutStgArg
    arg]
        Maybe UnariseVal
    Nothing             -> [Id -> OutStgArg
    StgVarArg Id
    x]
    unariseFunArg UnariseEnv
    _ OutStgArg
    arg = [OutStgArg
    arg]

    unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
    unariseFunArgs :: UnariseEnv -> [OutStgArg] -> [OutStgArg]
    unariseFunArgs = (OutStgArg -> [OutStgArg]) -> [OutStgArg] -> [OutStgArg]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap ((OutStgArg -> [OutStgArg]) -> [OutStgArg] -> [OutStgArg])
    -> (UnariseEnv -> OutStgArg -> [OutStgArg])
    -> UnariseEnv
    -> [OutStgArg]
    -> [OutStgArg]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . UnariseEnv -> OutStgArg -> [OutStgArg]
    unariseFunArg

    unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
    unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
    unariseFunArgBinders UnariseEnv
    rho [Id]
    xs = ([[Id]] -> [Id]) -> (UnariseEnv, [[Id]]) -> (UnariseEnv, [Id])
    forall (p :: * -> * -> *) b c a.
    Bifunctor p =>
    (b -> c) -> p a b -> p a c
    second [[Id]] -> [Id]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ((UnariseEnv, [[Id]]) -> (UnariseEnv, [Id]))
    -> UniqSM (UnariseEnv, [[Id]]) -> UniqSM (UnariseEnv, [Id])
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]))
    -> UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [[Id]])
    forall (m :: * -> *) acc x y.
    Monad m =>
    (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
    mapAccumLM UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
    unariseFunArgBinder UnariseEnv
    rho [Id]
    xs

    -- Result list of binders is never empty
    unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
    unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
    unariseFunArgBinder = Bool -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
    unariseArgBinder Bool
    False

    --------------------------------------------------------------------------------

    -- | MultiVal a DataCon argument. Returns an empty list when argument is void.
    unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]
    unariseConArg :: UnariseEnv -> OutStgArg -> [OutStgArg]
    unariseConArg UnariseEnv
    rho (StgVarArg Id
    x) =
      case UnariseEnv -> Id -> Maybe UnariseVal
    forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv UnariseEnv
    rho Id
    x of
        Just (UnaryVal OutStgArg
    arg) -> [OutStgArg
    arg]
        Just (MultiVal [OutStgArg]
    as) -> [OutStgArg]
    as      -- 'as' can be empty
        Maybe UnariseVal
    Nothing
          | Type -> Bool
    isVoidTy (Id -> Type
    idType Id
    x) -> [] -- e.g. C realWorld#
                                      -- Here realWorld# is not in the envt, but
                                      -- is a void, and so should be eliminated
          | Bool
    otherwise -> [Id -> OutStgArg
    StgVarArg Id
    x]
    unariseConArg UnariseEnv
    _ arg :: OutStgArg
    arg@(StgLitArg Literal
    lit) =
        ASSERT(not (isVoidTy (literalType lit)))  -- We have no void literals
        [OutStgArg
    arg]

    unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
    unariseConArgs :: UnariseEnv -> [OutStgArg] -> [OutStgArg]
    unariseConArgs = (OutStgArg -> [OutStgArg]) -> [OutStgArg] -> [OutStgArg]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap ((OutStgArg -> [OutStgArg]) -> [OutStgArg] -> [OutStgArg])
    -> (UnariseEnv -> OutStgArg -> [OutStgArg])
    -> UnariseEnv
    -> [OutStgArg]
    -> [OutStgArg]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . UnariseEnv -> OutStgArg -> [OutStgArg]
    unariseConArg

    unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
    unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
    unariseConArgBinders UnariseEnv
    rho [Id]
    xs = ([[Id]] -> [Id]) -> (UnariseEnv, [[Id]]) -> (UnariseEnv, [Id])
    forall (p :: * -> * -> *) b c a.
    Bifunctor p =>
    (b -> c) -> p a b -> p a c
    second [[Id]] -> [Id]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ((UnariseEnv, [[Id]]) -> (UnariseEnv, [Id]))
    -> UniqSM (UnariseEnv, [[Id]]) -> UniqSM (UnariseEnv, [Id])
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]))
    -> UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [[Id]])
    forall (m :: * -> *) acc x y.
    Monad m =>
    (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
    mapAccumLM UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
    unariseConArgBinder UnariseEnv
    rho [Id]
    xs

    -- Different from `unariseFunArgBinder`: result list of binders may be empty.
    -- See DataCon applications case in Note [Post-unarisation invariants].
    unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
    unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
    unariseConArgBinder = Bool -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
    unariseArgBinder Bool
    True

    --------------------------------------------------------------------------------

    mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
    mkIds :: FastString -> [Type] -> UniqSM [Id]
    mkIds FastString
    fs [Type]
    tys = (Type -> UniqSM Id) -> [Type] -> UniqSM [Id]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (FastString -> Type -> UniqSM Id
    mkId FastString
    fs) [Type]
    tys

    mkId :: FastString -> UnaryType -> UniqSM Id
    mkId :: FastString -> Type -> UniqSM Id
    mkId FastString
    s Type
    t = FastString -> Type -> Type -> UniqSM Id
    forall (m :: * -> *).
    MonadUnique m =>
    FastString -> Type -> Type -> m Id
    mkSysLocalM FastString
    s Type
    Many Type
    t

    isMultiValBndr :: Id -> Bool
    isMultiValBndr :: Id -> Bool
    isMultiValBndr Id
    id
      | [PrimRep
    _] <- HasDebugCallStack => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRep (Id -> Type
    idType Id
    id)
      = Bool
    False
      | Bool
    otherwise
      = Bool
    True

    isUnboxedSumBndr :: Id -> Bool
    isUnboxedSumBndr :: Id -> Bool
    isUnboxedSumBndr = Type -> Bool
    isUnboxedSumType (Type -> Bool) -> (Id -> Type) -> Id -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> Type
    idType

    isUnboxedTupleBndr :: Id -> Bool
    isUnboxedTupleBndr :: Id -> Bool
    isUnboxedTupleBndr = Type -> Bool
    isUnboxedTupleType (Type -> Bool) -> (Id -> Type) -> Id -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> Type
    idType

    mkTuple :: [StgArg] -> StgExpr
    mkTuple :: [OutStgArg] -> GenStgExpr 'Vanilla
    mkTuple [OutStgArg]
    args = DataCon
    -> XConApp 'Vanilla -> [OutStgArg] -> [Type] -> GenStgExpr 'Vanilla
    forall (pass :: StgPass).
    DataCon -> XConApp pass -> [OutStgArg] -> [Type] -> GenStgExpr pass
    StgConApp (Boxity -> Int -> DataCon
    tupleDataCon Boxity
    Unboxed ([OutStgArg] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [OutStgArg]
    args)) ConstructorNumber
    XConApp 'Vanilla
    NoNumber [OutStgArg]
    args ((OutStgArg -> Type) -> [OutStgArg] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map OutStgArg -> Type
    stgArgType [OutStgArg]
    args)

    tagAltTy :: AltType
    tagAltTy :: AltType
    tagAltTy = PrimRep -> AltType
    PrimAlt PrimRep
    IntRep

    tagTy :: Type
    tagTy :: Type
    tagTy = Type
    intPrimTy

    voidArg :: StgArg
    voidArg :: OutStgArg
    voidArg = Id -> OutStgArg
    StgVarArg Id
    voidPrimId

    mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
    -- We have an exhauseive list of literal alternatives
    --    1# -> e1
    --    2# -> e2
    -- Since they are exhaustive, we can replace one with DEFAULT, to avoid
    -- generating a final test. Remember, the DEFAULT comes first if it exists.
    mkDefaultLitAlt :: [GenStgAlt 'Vanilla] -> [GenStgAlt 'Vanilla]
    mkDefaultLitAlt [] = String -> SDoc -> [(AltCon, [Id], GenStgExpr 'Vanilla)]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "elimUbxSumExpr.mkDefaultAlt" (String -> SDoc
    text String
    "Empty alts")
    mkDefaultLitAlt alts :: [GenStgAlt 'Vanilla]
    alts@((AltCon
    DEFAULT, [BinderP 'Vanilla]
    _, GenStgExpr 'Vanilla
    _) : [GenStgAlt 'Vanilla]
    _) = [GenStgAlt 'Vanilla]
    alts
    mkDefaultLitAlt ((LitAlt{}, [], GenStgExpr 'Vanilla
    rhs) : [GenStgAlt 'Vanilla]
    alts) = (AltCon
    DEFAULT, [], GenStgExpr 'Vanilla
    rhs) (AltCon, [Id], GenStgExpr 'Vanilla)
    -> [(AltCon, [Id], GenStgExpr 'Vanilla)]
    -> [(AltCon, [Id], GenStgExpr 'Vanilla)]
    forall a. a -> [a] -> [a]
    : [(AltCon, [Id], GenStgExpr 'Vanilla)]
    [GenStgAlt 'Vanilla]
    alts
    mkDefaultLitAlt [GenStgAlt 'Vanilla]
    alts = String -> SDoc -> [(AltCon, [Id], GenStgExpr 'Vanilla)]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "mkDefaultLitAlt" (String -> SDoc
    text String
    "Not a lit alt:" SDoc -> SDoc -> SDoc
    <+> [(AltCon, [Id], GenStgExpr 'Vanilla)] -> SDoc
    forall a b (pass :: StgPass).
    (Outputable a, Outputable b, OutputablePass pass) =>
    [(a, b, GenStgExpr pass)] -> SDoc
    pprPanicAlts [(AltCon, [Id], GenStgExpr 'Vanilla)]
    [GenStgAlt 'Vanilla]
    alts)

    pprPanicAlts :: (Outputable a, Outputable b, OutputablePass pass) => [(a,b,GenStgExpr pass)] -> SDoc
    pprPanicAlts :: forall a b (pass :: StgPass).
    (Outputable a, Outputable b, OutputablePass pass) =>
    [(a, b, GenStgExpr pass)] -> SDoc
    pprPanicAlts [(a, b, GenStgExpr pass)]
    alts = [SDoc] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (((a, b, GenStgExpr pass) -> SDoc)
    -> [(a, b, GenStgExpr pass)] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map (a, b, GenStgExpr pass) -> SDoc
    forall a b (pass :: StgPass).
    (Outputable a, Outputable b, OutputablePass pass) =>
    (a, b, GenStgExpr pass) -> SDoc
    pprPanicAlt [(a, b, GenStgExpr pass)]
    alts)

    pprPanicAlt :: (Outputable a, Outputable b, OutputablePass pass) => (a,b,GenStgExpr pass) -> SDoc
    pprPanicAlt :: forall a b (pass :: StgPass).
    (Outputable a, Outputable b, OutputablePass pass) =>
    (a, b, GenStgExpr pass) -> SDoc
    pprPanicAlt (a
    c,b
    b,GenStgExpr pass
    e) = (a, b, SDoc) -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (a
    c,b
    b,StgPprOpts -> GenStgExpr pass -> SDoc
    forall (pass :: StgPass).
    OutputablePass pass =>
    StgPprOpts -> GenStgExpr pass -> SDoc
    pprStgExpr StgPprOpts
    panicStgPprOpts GenStgExpr pass
    e)