    {-
    (c) The University of Glasgow 2006
    (c) The AQUA Project, Glasgow University, 1998

    This module contains definitions for the IdInfo for things that
    have a standard form, namely:

    - data constructors
    - record selectors
    - method and superclass selectors
    - primitive operations
    -}

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

    module GHC.Types.Id.Make (
            mkDictFunId, mkDictSelId, mkDictSelRhs,

            mkFCallId,

            unwrapNewTypeBody, wrapFamInstBody,
            DataConBoxer(..), vanillaDataConBoxer,
            mkDataConRep, mkDataConWorkId,
            DataConBangOpts (..), BangOpts (..),
            unboxedUnitExpr,

            -- And some particular Ids; see below for why they are wired in
            wiredInIds, ghcPrimIds,
            realWorldPrimId,
            voidPrimId, voidArgId,
            nullAddrId, seqId, lazyId, lazyIdKey,
            coercionTokenId, coerceId,
            proxyHashId,
            nospecId, nospecIdName,
            noinlineId, noinlineIdName,
            noinlineConstraintId, noinlineConstraintIdName,
            coerceName, leftSectionName, rightSectionName,
            pcRepPolyId,

            mkRepPolyIdConcreteTyVars,
        ) where

    import GHC.Prelude

    import GHC.Builtin.Types.Prim
    import GHC.Builtin.Types
    import GHC.Builtin.Names

    import GHC.Core
    import GHC.Core.Opt.Arity( typeOneShot )
    import GHC.Core.Type
    import GHC.Core.Multiplicity
    import GHC.Core.TyCo.Rep
    import GHC.Core.FamInstEnv
    import GHC.Core.Coercion
    import GHC.Core.Reduction
    import GHC.Core.Make
    import GHC.Core.FVs     ( mkRuleInfo )
    import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, coreAltsType )
    import GHC.Core.Unfold.Make
    import GHC.Core.SimpleOpt
    import GHC.Core.TyCon
    import GHC.Core.Class
    import GHC.Core.DataCon

    import GHC.Types.Literal
    import GHC.Types.SourceText
    import GHC.Types.RepType ( countFunRepArgs, typePrimRep )
    import GHC.Types.Name.Set
    import GHC.Types.Name
    import GHC.Types.Name.Env
    import GHC.Types.ForeignCall
    import GHC.Types.Id
    import GHC.Types.Id.Info
    import GHC.Types.Demand
    import GHC.Types.Cpr
    import GHC.Types.Unique.Supply
    import GHC.Types.Basic       hiding ( SuccessFlag(..) )
    import GHC.Types.Var (VarBndr(Bndr), visArgConstraintLike, tyVarName)

    import GHC.Tc.Types.Origin
    import GHC.Tc.Utils.TcType as TcType

    import GHC.Utils.Misc
    import GHC.Utils.Outputable
    import GHC.Utils.Panic

    import GHC.Data.FastString
    import GHC.Data.List.SetOps
    import Data.List        ( zipWith4 )

    -- A bit of a shame we must import these here
    import GHC.StgToCmm.Types (LambdaFormInfo(..))
    import GHC.Runtime.Heap.Layout (ArgDescr(ArgUnknown))

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Wired in Ids}
    *                                                                      *
    ************************************************************************

    Note [Wired-in Ids]
    ~~~~~~~~~~~~~~~~~~~
    A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId')
    rather than by looking it up its name in some environment or fetching
    it from an interface file.

    There are several reasons why an Id might appear in the wiredInIds:

    * ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)]

    * magicIds: see Note [magicIds]

    * errorIds, defined in GHC.Core.Make.
      These error functions (e.g. rUNTIME_ERROR_ID) are wired in
      because the desugarer generates code that mentions them directly

    In all cases except ghcPrimIds, there is a definition site in a
    library module, which may be called (e.g. in higher order situations);
    but the wired-in version means that the details are never read from
    that module's interface file; instead, the full definition is right
    here.

    Note [ghcPrimIds (aka pseudoops)]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The ghcPrimIds

      * Are exported from GHC.Prim (see ghcPrimExports, used in ghcPrimInterface)
        See Note [GHC.Prim] in primops.txt.pp for the remaining items in GHC.Prim.

      * Can't be defined in Haskell, and hence no Haskell binding site,
        but have perfectly reasonable unfoldings in Core

      * Either have a CompulsoryUnfolding (hence always inlined), or
            of an EvaldUnfolding and void representation (e.g. realWorldPrimId)

      * Are (or should be) defined in primops.txt.pp as 'pseudoop'
        Reason: that's how we generate documentation for them

    Note [magicIds]
    ~~~~~~~~~~~~~~~
    The magicIds

      * Are exported from GHC.Magic

      * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs).
        This definition at least generates Haddock documentation for them.

      * May or may not have a CompulsoryUnfolding.

      * But have some special behaviour that can't be done via an
        unfolding from an interface file.

      * May have IdInfo that differs from what would be imported from GHC.Magic.hi.
        For example, 'lazy' gets a lazy strictness signature, per Note [lazyId magic].

      The two remaining identifiers in GHC.Magic, runRW# and inline, are not
      listed in magicIds: they have special behavior but they can be known-key and
      not wired-in.
      Similarly for GHC.Internal.IO.seq# and GHC.Internal.Exts.considerAccessible.
      runRW#:             see Note [Simplification of runRW#] in Prep,
                          runRW# code in Simplifier, Note [Linting of runRW#].
      seq#:               see Note [seq# magic]
      inline:             see Note [inlineId magic]
      considerAccessible: see Note [considerAccessible]
    -}

    wiredInIds :: [Id]
    wiredInIds :: [Id]
    wiredInIds
      =  [Id]
    magicIds
      [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++ [Id]
    ghcPrimIds
      [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++ [Id]
    errorIds           -- Defined in GHC.Core.Make

    magicIds :: [Id]    -- See Note [magicIds]
    magicIds :: [Id]
    magicIds = [Id
    lazyId, Id
    oneShotId, Id
    noinlineId, Id
    noinlineConstraintId, Id
    nospecId]

    ghcPrimIds :: [Id]  -- See Note [ghcPrimIds (aka pseudoops)]
    ghcPrimIds :: [Id]
    ghcPrimIds
      = [ Id
    realWorldPrimId
        , Id
    voidPrimId
        , Id
    nullAddrId
        , Id
    seqId
        , Id
    coerceId
        , Id
    proxyHashId
        , Id
    leftSectionId
        , Id
    rightSectionId
        ]

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Data constructors}
    *                                                                      *
    ************************************************************************

    The wrapper for a constructor is an ordinary top-level binding that evaluates
    any strict args, unboxes any args that are going to be flattened, and calls
    the worker.

    We're going to build a constructor that looks like:

            data (Data a, C b) =>  T a b = T1 !a !Int b

            T1 = /\ a b ->
                 \d1::Data a, d2::C b ->
                 \p q r -> case p of { p ->
                           case q of { q ->
                           Con T1 [a,b] [p,q,r]}}

    Notice that

    * d2 is thrown away --- a context in a data decl is used to make sure
      one *could* construct dictionaries at the site the constructor
      is used, but the dictionary isn't actually used.

    * We have to check that we can construct Data dictionaries for
      the types a and Int.  Once we've done that we can throw d1 away too.

    * We use (case p of q -> ...) to evaluate p, rather than "seq" because
      all that matters is that the arguments are evaluated.  "seq" is
      very careful to preserve evaluation order, which we don't need
      to be here.

      You might think that we could simply give constructors some strictness
      info, like PrimOps, and let CoreToStg do the let-to-case transformation.
      But we don't do that because in the case of primops and functions strictness
      is a *property* not a *requirement*.  In the case of constructors we need to
      do something active to evaluate the argument.

      Making an explicit case expression allows the simplifier to eliminate
      it in the (common) case where the constructor arg is already evaluated.

    Note [Wrappers for data instance tycons]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    In the case of data instances, the wrapper also applies the coercion turning
    the representation type into the family instance type to cast the result of
    the wrapper.  For example, consider the declarations

      data family Map k :: * -> *
      data instance Map (a, b) v = MapPair (Map a (Pair b v))

    The tycon to which the datacon MapPair belongs gets a unique internal
    name of the form :R123Map, and we call it the representation tycon.
    In contrast, Map is the family tycon (accessible via
    tyConFamInst_maybe). A coercion allows you to move between
    representation and family type.  It is accessible from :R123Map via
    tyConFamilyCoercion_maybe and has kind

      Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}

    The wrapper and worker of MapPair get the types

            -- Wrapper
      $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
      $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v)

            -- Worker
      MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v

    This coercion is conditionally applied by wrapFamInstBody.

    It's a bit more complicated if the data instance is a GADT as well!

       data instance T [a] where
            T1 :: forall b. b -> T [Maybe b]

    Hence we translate to

            -- Wrapper
      $WT1 :: forall b. b -> T [Maybe b]
      $WT1 b v = T1 (Maybe b) b (Maybe b) v
                            `cast` sym (Co7T (Maybe b))

            -- Worker
      T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c

            -- Coercion from family type to representation type
      Co7T a :: T [a] ~ :R7T a

    Newtype instances through an additional wrinkle into the mix. Consider the
    following example (adapted from #15318, comment:2):

      data family T a
      newtype instance T [a] = MkT [a]

    Within the newtype instance, there are three distinct types at play:

    1. The newtype's underlying type, [a].
    2. The instance's representation type, TList a (where TList is the
       representation tycon).
    3. The family type, T [a].

    We need two coercions in order to cast from (1) to (3):

    (a) A newtype coercion axiom:

          axiom coTList a :: TList a ~ [a]

        (Where TList is the representation tycon of the newtype instance.)

    (b) A data family instance coercion axiom:

          axiom coT a :: T [a] ~ TList a

    When we translate the newtype instance to Core, we obtain:

        -- Wrapper
      $WMkT :: forall a. [a] -> T [a]
      $WMkT a x = MkT a x |> Sym (coT a)

        -- Worker
      MkT :: forall a. [a] -> TList [a]
      MkT a x = x |> Sym (coTList a)

    Unlike for data instances, the worker for a newtype instance is actually an
    executable function which expands to a cast, but otherwise, the general
    strategy is essentially the same as for data instances. Also note that we have
    a wrapper, which is unusual for a newtype, but we make GHC produce one anyway
    for symmetry with the way data instances are handled.

    Note [Newtype datacons]
    ~~~~~~~~~~~~~~~~~~~~~~~
    The "data constructor" for a newtype should have no existentials. It's
    not quite a "vanilla" data constructor, because the newtype arising from
         class C a => D a
    looks like
           newtype T:D a = C:D (C a)
    so the data constructor for T:C has a single argument, namely the
    predicate (C a).  That ends up in the dcOtherTheta for the data con,
    which makes it not vanilla.  So the assert just tests for existentials.
    The rest is checked by having a singleton arg_tys.

    Note [Newtype workers]
    ~~~~~~~~~~~~~~~~~~~~~~
    A newtype does not really have a worker. Instead, newtype constructors
    just unfold into a cast. But we need *something* for, say, MkAge to refer
    to. So, we do this:

    * The Id used as the newtype worker will have a compulsory unfolding to
      a cast. See Note [Compulsory newtype unfolding]

    * This Id is labeled as a DataConWrapId. We don't want to use a DataConWorkId,
      as those have special treatment in the back end.

    * There is no top-level binding, because the compulsory unfolding
      means that it will be inlined (to a cast) at every call site.

    We probably should have a NewtypeWorkId, but these Ids disappear as soon as
    we desugar anyway, so it seems a step too far.

    Note [Compulsory newtype unfolding]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Newtype wrappers, just like workers, have compulsory unfoldings.
    This is needed so that two optimizations involving newtypes have the same
    effect whether a wrapper is present or not:

    (1) Case-of-known constructor.
        See Note [beta-reduction in exprIsConApp_maybe].

    (2) Matching against the map/coerce RULE. Suppose we have the RULE

        {-# RULE "map/coerce" map coerce = ... #-}

        As described in Note [Getting the map/coerce RULE to work],
        the occurrence of 'coerce' is transformed into:

        {-# RULE "map/coerce" forall (c :: T1 ~R# T2).
                              map ((\v -> v) `cast` c) = ... #-}

        We'd like 'map Age' to match the LHS. For this to happen, Age
        must be unfolded, otherwise we'll be stuck. This is tested in T16208.

    It also allows for the possibility of representation-polymorphic newtypes
    with wrappers (with -XUnliftedNewtypes):

      newtype N (a :: TYPE r) = MkN a

    With -XUnliftedNewtypes, this is allowed -- even though MkN is representation-
    polymorphic. It's OK because MkN evaporates in the compiled code, becoming
    just a cast. That is, it has a compulsory unfolding. As long as its
    argument is not representation-polymorphic (which it can't be, according to
    Note [Representation polymorphism invariants] in GHC.Core), and it's saturated,
    no representation-polymorphic code ends up in the code generator.
    The saturation condition is effectively checked in
    GHC.Tc.Gen.Head.rejectRepPolyNewtypes.

    However, if we make a *wrapper* for a newtype, we get into trouble.
    In that case, we generate a forbidden representation-polymorphic
    binding, and we must then ensure that it is always instantiated
    at a representation-monomorphic type.

    The solution is simple, though: just make the newtype wrappers
    as ephemeral as the newtype workers. In other words, give the wrappers
    compulsory unfoldings and no bindings. The compulsory unfolding is given
    in wrap_unf in mkDataConRep, and the lack of a binding happens in
    GHC.Iface.Tidy.getTyConImplicitBinds, where we say that a newtype has no
    implicit bindings.

    Note [Records and linear types]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    All the fields, in a record constructor, are linear, because there is no syntax
    to specify the type of record field. There will be (see the proposal
    https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst#records-and-projections
    ), but it isn't implemented yet.

    Projections of records can't be linear:

      data Foo = MkFoo { a :: A, b :: B }

    If we had

      a :: Foo %1 -> A

    We could write

      bad :: A %1 -> B %1 -> A
      bad x y = a (MkFoo { a=x, b=y })

    There is an exception: if `b` (more generally all the fields besides `a`) is
    unrestricted, then is perfectly possible to have a linear projection. Such a
    linear projection has as simple definition.

      data Bar = MkBar { c :: C, d % Many :: D }

      c :: Bar %1 -> C
      c MkBar{ c=x, d=_} = x

    The `% Many` syntax, for records, does not exist yet. But there is one important
    special case which already happens: when there is a single field (usually a
    newtype).

      newtype Baz = MkBaz { unbaz :: E }

    unbaz could be linear. And, in fact, it is linear in the proposal design.

    However, this hasn't been implemented yet.

    ************************************************************************
    *                                                                      *
    \subsection{Dictionary selectors}
    *                                                                      *
    ************************************************************************

    Selecting a field for a dictionary.  If there is just one field, then
    there's nothing to do.

    Dictionary selectors may get nested forall-types.  Thus:

            class Foo a where
              op :: forall b. Ord b => a -> b -> b

    Then the top-level type for op is

            op :: forall a. Foo a =>
                  forall b. Ord b =>
                  a -> b -> b

    Note [Type classes and linear types]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Constraints, in particular type classes, don't have attached linearity
    information. Implicitly, they are all unrestricted. See the linear types proposal,
    https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst .

    When translating to core `C => ...` is always translated to an unrestricted
    arrow `C % Many -> ...`.

    Therefore there is no loss of generality if we make all selectors unrestricted.

    -}

    mkDictSelId :: Name          -- Name of one of the *value* selectors
                                 -- (dictionary superclass or method)
                -> Class -> Id
    mkDictSelId :: Name -> Class -> Id
    mkDictSelId Name
    name Class
    clas
      = IdDetails -> Name -> Type -> IdInfo -> Id
    mkGlobalId (Class -> Bool -> IdDetails
    ClassOpId Class
    clas Bool
    terminating) Name
    name Type
    sel_ty IdInfo
    info
      where
        tycon :: TyCon
    tycon          = Class -> TyCon
    classTyCon Class
    clas
        sel_names :: [Name]
    sel_names      = (Id -> Name) -> [Id] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> Name
    idName (Class -> [Id]
    classAllSelIds Class
    clas)
        new_tycon :: Bool
    new_tycon      = TyCon -> Bool
    isNewTyCon TyCon
    tycon
        [DataCon
    data_con]     = TyCon -> [DataCon]
    tyConDataCons TyCon
    tycon
        tyvars :: [InvisTVBinder]
    tyvars         = DataCon -> [InvisTVBinder]
    dataConUserTyVarBinders DataCon
    data_con
        n_ty_args :: Int
    n_ty_args      = [InvisTVBinder] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [InvisTVBinder]
    tyvars
        arg_tys :: [Scaled Type]
    arg_tys        = DataCon -> [Scaled Type]
    dataConRepArgTys DataCon
    data_con  -- Includes the dictionary superclasses
        val_index :: Int
    val_index      = String -> Assoc Name Int -> Name -> Int
    forall a b. Eq a => String -> Assoc a b -> a -> b
    assoc String
    "MkId.mkDictSelId" ([Name]
    sel_names [Name] -> [Int] -> Assoc Name Int
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` [Int
    0..]) Name
    name

        pred_ty :: Type
    pred_ty = Class -> [Type] -> Type
    mkClassPred Class
    clas ([Id] -> [Type]
    mkTyVarTys ([InvisTVBinder] -> [Id]
    forall tv argf. [VarBndr tv argf] -> [tv]
    binderVars [InvisTVBinder]
    tyvars))
        res_ty :: Type
    res_ty  = Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing ([Scaled Type] -> Int -> Scaled Type
    forall a. Outputable a => [a] -> Int -> a
    getNth [Scaled Type]
    arg_tys Int
    val_index)
        sel_ty :: Type
    sel_ty  = [InvisTVBinder] -> Type -> Type
    mkInvisForAllTys [InvisTVBinder]
    tyvars (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
                  HasDebugCallStack => Type -> Type -> Type -> Type
    Type -> Type -> Type -> Type
    mkFunctionType Type
    ManyTy Type
    pred_ty Type
    res_ty
                 -- See Note [Type classes and linear types]

        terminating :: Bool
    terminating = HasDebugCallStack => Type -> Bool
    Type -> Bool
    isTerminatingType Type
    res_ty Bool -> Bool -> Bool
    || Type -> Bool
    definitelyUnliftedType Type
    res_ty
                      -- If the field is unlifted, it can't be bottom
                      -- Ditto if it's a terminating type

        base_info :: IdInfo
    base_info = IdInfo
    noCafIdInfo
                    IdInfo -> Int -> IdInfo
    `setArityInfo`  Int
    1
                    IdInfo -> DmdSig -> IdInfo
    `setDmdSigInfo` DmdSig
    strict_sig
                    IdInfo -> CprSig -> IdInfo
    `setCprSigInfo` CprSig
    topCprSig

        info :: IdInfo
    info | Bool
    new_tycon
             = IdInfo
    base_info IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo` InlinePragma
    alwaysInlinePragma
                         IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`  SimpleOpts -> UnfoldingSource -> Int -> CoreExpr -> Unfolding
    mkInlineUnfoldingWithArity SimpleOpts
    defaultSimpleOpts
                                               UnfoldingSource
    StableSystemSrc Int
    1
                                               (Class -> Int -> CoreExpr
    mkDictSelRhs Class
    clas Int
    val_index)
                       -- See Note [Single-method classes] in GHC.Tc.TyCl.Instance
                       -- for why alwaysInlinePragma

             | Bool
    otherwise
             = IdInfo
    base_info IdInfo -> RuleInfo -> IdInfo
    `setRuleInfo` [CoreRule] -> RuleInfo
    mkRuleInfo [CoreRule
    rule]
                         IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo` InlinePragma
    neverInlinePragma
                         IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`  SimpleOpts -> UnfoldingSource -> Int -> CoreExpr -> Unfolding
    mkInlineUnfoldingWithArity SimpleOpts
    defaultSimpleOpts
                                               UnfoldingSource
    StableSystemSrc Int
    1
                                               (Class -> Int -> CoreExpr
    mkDictSelRhs Class
    clas Int
    val_index)
                       -- Add a magic BuiltinRule, but no unfolding
                       -- so that the rule is always available to fire.
                       -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance

        -- This is the built-in rule that goes
        --      op (dfT d1 d2) --->  opT d1 d2
        rule :: CoreRule
    rule = BuiltinRule { ru_name :: RuleName
    ru_name = String -> RuleName
    fsLit String
    "Class op " RuleName -> RuleName -> RuleName
    `appendFS`
                                         OccName -> RuleName
    occNameFS (Name -> OccName
    forall a. NamedThing a => a -> OccName
    getOccName Name
    name)
                           , ru_fn :: Name
    ru_fn    = Name
    name
                           , ru_nargs :: Int
    ru_nargs = Int
    n_ty_args Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
                           , ru_try :: RuleFun
    ru_try   = Int -> Int -> RuleFun
    dictSelRule Int
    val_index Int
    n_ty_args }

            -- The strictness signature is of the form U(AAAVAAAA) -> T
            -- where the V depends on which item we are selecting
            -- It's worth giving one, so that absence info etc is generated
            -- even if the selector isn't inlined

        strict_sig :: DmdSig
    strict_sig = [Demand] -> Divergence -> DmdSig
    mkClosedDmdSig [Demand
    arg_dmd] Divergence
    topDiv
        arg_dmd :: Demand
    arg_dmd | Bool
    new_tycon = Demand
    evalDmd
                | Bool
    otherwise = Card
    C_1N HasDebugCallStack => Card -> SubDemand -> Demand
    Card -> SubDemand -> Demand
    :* Boxity -> [Demand] -> SubDemand
    mkProd Boxity
    Unboxed [Demand]
    dict_field_dmds
                where
                  -- The evalDmd below is just a placeholder and will be replaced in
                  -- GHC.Types.Demand.dmdTransformDictSel
                  dict_field_dmds :: [Demand]
    dict_field_dmds = [ if Name
    name Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    sel_name then Demand
    evalDmd else Demand
    absDmd
                                    | Name
    sel_name <- [Name]
    sel_names ]

    mkDictSelRhs :: Class
                 -> Int         -- 0-indexed selector among (superclasses ++ methods)
                 -> CoreExpr
    mkDictSelRhs :: Class -> Int -> CoreExpr
    mkDictSelRhs Class
    clas Int
    val_index
      = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    tyvars (Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    dict_id CoreExpr
    rhs_body)
      where
        tycon :: TyCon
    tycon          = Class -> TyCon
    classTyCon Class
    clas
        new_tycon :: Bool
    new_tycon      = TyCon -> Bool
    isNewTyCon TyCon
    tycon
        [DataCon
    data_con]     = TyCon -> [DataCon]
    tyConDataCons TyCon
    tycon
        tyvars :: [Id]
    tyvars         = DataCon -> [Id]
    dataConUnivTyVars DataCon
    data_con
        arg_tys :: [Scaled Type]
    arg_tys        = DataCon -> [Scaled Type]
    dataConRepArgTys DataCon
    data_con  -- Includes the dictionary superclasses

        the_arg_id :: Id
    the_arg_id     = [Id] -> Int -> Id
    forall a. Outputable a => [a] -> Int -> a
    getNth [Id]
    arg_ids Int
    val_index
        pred :: Type
    pred           = Class -> [Type] -> Type
    mkClassPred Class
    clas ([Id] -> [Type]
    mkTyVarTys [Id]
    tyvars)
        dict_id :: Id
    dict_id        = Int -> Type -> Id
    mkTemplateLocal Int
    1 Type
    pred
        arg_ids :: [Id]
    arg_ids        = Int -> [Type] -> [Id]
    mkTemplateLocalsNum Int
    2 ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing [Scaled Type]
    arg_tys)

        rhs_body :: CoreExpr
    rhs_body | Bool
    new_tycon = TyCon -> [Type] -> CoreExpr -> CoreExpr
    unwrapNewTypeBody TyCon
    tycon ([Id] -> [Type]
    mkTyVarTys [Id]
    tyvars)
                                                       (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    dict_id)
                 | Bool
    otherwise = CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
    mkSingleAltCase (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    dict_id) Id
    dict_id (DataCon -> AltCon
    DataAlt DataCon
    data_con)
                                               [Id]
    arg_ids (Id -> CoreExpr
    forall b. Id -> Expr b
    varToCoreExpr Id
    the_arg_id)
                                    -- varToCoreExpr needed for equality superclass selectors
                                    --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }

    dictSelRule :: Int -> Arity -> RuleFun
    -- Tries to persuade the argument to look like a constructor
    -- application, using exprIsConApp_maybe, and then selects
    -- from it
    --       sel_i t1..tk (D t1..tk op1 ... opm) = opi
    --
    dictSelRule :: Int -> Int -> RuleFun
    dictSelRule Int
    val_index Int
    n_ty_args RuleOpts
    _ InScopeEnv
    id_unf Id
    _ [CoreExpr]
    args
      | (CoreExpr
    dict_arg : [CoreExpr]
    _) <- Int -> [CoreExpr] -> [CoreExpr]
    forall a. Int -> [a] -> [a]
    drop Int
    n_ty_args [CoreExpr]
    args
      , Just (InScopeSet
    _, [FloatBind]
    floats, DataCon
    _, [Type]
    _, [CoreExpr]
    con_args) <- HasDebugCallStack =>
    InScopeEnv
    -> CoreExpr
    -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
    InScopeEnv
    -> CoreExpr
    -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
    exprIsConApp_maybe InScopeEnv
    id_unf CoreExpr
    dict_arg
      = CoreExpr -> Maybe CoreExpr
    forall a. a -> Maybe a
    Just ([FloatBind] -> CoreExpr -> CoreExpr
    wrapFloats [FloatBind]
    floats (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $ [CoreExpr] -> Int -> CoreExpr
    forall a. Outputable a => [a] -> Int -> a
    getNth [CoreExpr]
    con_args Int
    val_index)
      | Bool
    otherwise
      = Maybe CoreExpr
    forall a. Maybe a
    Nothing

    {-
    ************************************************************************
    *                                                                      *
            Data constructors
    *                                                                      *
    ************************************************************************
    -}

    mkDataConWorkId :: Name -> DataCon -> Id
    mkDataConWorkId :: Name -> DataCon -> Id
    mkDataConWorkId Name
    wkr_name DataCon
    data_con
      | TyCon -> Bool
    isNewTyCon TyCon
    tycon
      = IdDetails -> Name -> Type -> IdInfo -> Id
    mkGlobalId (DataCon -> IdDetails
    DataConWrapId DataCon
    data_con) Name
    wkr_name Type
    wkr_ty IdInfo
    nt_work_info
          -- See Note [Newtype workers]

      | Bool
    otherwise
      = IdDetails -> Name -> Type -> IdInfo -> Id
    mkGlobalId (DataCon -> IdDetails
    DataConWorkId DataCon
    data_con) Name
    wkr_name Type
    wkr_ty IdInfo
    alg_wkr_info

      where
        tycon :: TyCon
    tycon  = DataCon -> TyCon
    dataConTyCon DataCon
    data_con  -- The representation TyCon
        wkr_ty :: Type
    wkr_ty = DataCon -> Type
    dataConRepType DataCon
    data_con

        ----------- Workers for data types --------------
        alg_wkr_info :: IdInfo
    alg_wkr_info = IdInfo
    noCafIdInfo
                       IdInfo -> Int -> IdInfo
    `setArityInfo`          Int
    wkr_arity
                       IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo`     InlinePragma
    wkr_inline_prag
                       IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`      Unfolding
    evaldUnfolding  -- Record that it's evaluated,
                                                               -- even if arity = 0
                       IdInfo -> LambdaFormInfo -> IdInfo
    `setLFInfo`             LambdaFormInfo
    wkr_lf_info
              -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon

        wkr_inline_prag :: InlinePragma
    wkr_inline_prag = InlinePragma
    defaultInlinePragma { inl_rule = ConLike }
        wkr_arity :: Int
    wkr_arity = DataCon -> Int
    dataConRepArity DataCon
    data_con

        -- See Note [LFInfo of DataCon workers and wrappers]
        wkr_lf_info :: LambdaFormInfo
    wkr_lf_info
          | Int
    wkr_arity Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 = DataCon -> LambdaFormInfo
    LFCon DataCon
    data_con
          | Bool
    otherwise      = TopLevelFlag -> Int -> Bool -> ArgDescr -> LambdaFormInfo
    LFReEntrant TopLevelFlag
    TopLevel (Int -> Type -> Int
    countFunRepArgs Int
    wkr_arity Type
    wkr_ty) Bool
    True ArgDescr
    ArgUnknown
                                                -- LFInfo stores post-unarisation arity

        ----------- Workers for newtypes --------------
        univ_tvs :: [Id]
    univ_tvs = DataCon -> [Id]
    dataConUnivTyVars DataCon
    data_con
        ex_tcvs :: [Id]
    ex_tcvs  = DataCon -> [Id]
    dataConExTyCoVars DataCon
    data_con
        arg_tys :: [Scaled Type]
    arg_tys  = DataCon -> [Scaled Type]
    dataConRepArgTys  DataCon
    data_con  -- Should be same as dataConOrigArgTys
        nt_work_info :: IdInfo
    nt_work_info = IdInfo
    noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
                      IdInfo -> Int -> IdInfo
    `setArityInfo` Int
    1      -- Arity 1
                      IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo`     InlinePragma
    dataConWrapperInlinePragma
                      IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`      Unfolding
    newtype_unf
                                   -- See W1 in Note [LFInfo of DataCon workers and wrappers]
                      IdInfo -> LambdaFormInfo -> IdInfo
    `setLFInfo` (String -> LambdaFormInfo
    forall a. HasCallStack => String -> a
    panic String
    "mkDataConWorkId: we shouldn't look at LFInfo for newtype worker ids")
        id_arg1 :: Id
    id_arg1      = Int -> Scaled Type -> Id
    mkScaledTemplateLocal Int
    1 ([Scaled Type] -> Scaled Type
    forall a. HasCallStack => [a] -> a
    head [Scaled Type]
    arg_tys)
        res_ty_args :: [Type]
    res_ty_args  = [Id] -> [Type]
    mkTyCoVarTys [Id]
    univ_tvs
        newtype_unf :: Unfolding
    newtype_unf  = Bool -> SDoc -> (CoreExpr -> Unfolding) -> CoreExpr -> Unfolding
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr ([Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Id]
    ex_tcvs Bool -> Bool -> Bool
    && [Scaled Type] -> Bool
    forall a. [a] -> Bool
    isSingleton [Scaled Type]
    arg_tys)
                                 (DataCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DataCon
    data_con)
                                  -- Note [Newtype datacons]
                       CoreExpr -> Unfolding
    mkCompulsoryUnfolding (CoreExpr -> Unfolding) -> CoreExpr -> Unfolding
    forall a b. (a -> b) -> a -> b
    $
                       [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    univ_tvs (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $ Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    id_arg1 (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                       TyCon -> [Type] -> CoreExpr -> CoreExpr
    wrapNewTypeBody TyCon
    tycon [Type]
    res_ty_args (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    id_arg1)

    {-
    Note [LFInfo of DataCon workers and wrappers]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    As noted in Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure, it's
    crucial that saturated data con applications are given an LFInfo of `LFCon`.

    Since for data constructors we never serialise the worker and the wrapper (only
    the data type declaration), we never serialise their lambda form info either.

    Therefore, when making data constructors workers and wrappers, we construct a
    correct `LFInfo` for them right away, and put it it in the `lfInfo` field of the
    worker/wrapper Id, ensuring that:

      The `lfInfo` field of a DataCon worker or wrapper is always populated with the correct LFInfo.

    How do we construct a /correct/ LFInfo for workers and wrappers?
    (Remember: `LFCon` means "a saturated constructor application")

    (1) Data constructor workers and wrappers with arity > 0 are unambiguously
    functions and should be given `LFReEntrant`, regardless of the runtime
    relevance of the arguments.
      - For example, `Just :: a -> Maybe a` is given `LFReEntrant`,
                 and `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too.

    (2) A datacon /worker/ with zero arity is trivially fully saturated -- it takes
    no arguments whatsoever (not even zero-width args), so it is given `LFCon`.

    (3) Perhaps surprisingly, a datacon /wrapper/ can be an `LFCon`. See Wrinkle (W1) below.
    A datacon /wrapper/ with zero arity must be a fully saturated application of
    the worker to zero-width arguments only (which are dropped after unarisation),
    and therefore is also given `LFCon`.

    For example, consider the following data constructors:

      data T1 a where
        TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a

      data T2 a where
        TCon2 :: {-# UNPACK #-} !() -> T2 a

      data T3 a where
        TCon3 :: T3 '[]

    `TCon1`'s wrapper has a lifted argument, which is non-zero-width, while the
    worker has an unlifted equality argument, which is zero-width.

    `TCon2`'s wrapper has a lifted argument, which is non-zero-width, while the
    worker has no arguments.

    Wrinkle (W1). Perhaps surprisingly, it is possible for the /wrapper/ to be an
    `LFCon` even though the /worker/ is not. Consider `T3` above. Here is the
    Core representation of the worker and wrapper:

      $WTCon3 :: T3 '[]             -- Wrapper
      $WTCon3 = TCon3 @[] <Refl>    -- A saturated constructor application: LFCon

      TCon3 :: forall (a :: * -> *). (a ~# []) => T a   -- Worker
      TCon3 = /\a. \(co :: a~#[]). TCon3 co             -- A function: LFReEntrant

    For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they
    both have arity == 1.

    For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1
    while the worker is `LFCon` since its arity == 0

    For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the
    worker `LFReEntrant` since its arity == 1

    One might think we could give *workers* with only zero-width-args the `LFCon`
    LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`.
    However, these workers are unambiguously functions
    -- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct.
    See also the discussion in #23158.

    Wrinkles:

    (W1) Why do we panic when generating `LFInfo` for newtype workers and wrappers?

      We don't generate code for newtype workers/wrappers, so we should never have to
      look at their LFInfo (and in general we can't; they may be representation-polymorphic).

    See also the Note [Imported unlifted nullary datacon wrappers must have correct LFInfo]
    in GHC.StgToCmm.Types.

    -------------------------------------------------
    --         Data constructor representation
    --
    -- This is where we decide how to wrap/unwrap the
    -- constructor fields
    --
    --------------------------------------------------
    -}

    type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)
      -- Unbox: bind rep vars by decomposing src var

    data Boxer = UnitBox | Boxer (Subst -> UniqSM ([Var], CoreExpr))
      -- Box:   build src arg using these rep vars

    -- | Data Constructor Boxer
    newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
                           -- Bind these src-level vars, returning the
                           -- rep-level vars to bind in the pattern

    vanillaDataConBoxer :: DataConBoxer
    -- No transformation on arguments needed
    vanillaDataConBoxer :: DataConBoxer
    vanillaDataConBoxer = ([Type] -> [Id] -> UniqSM ([Id], [CoreBind])) -> DataConBoxer
    DCB (\[Type]
    _tys [Id]
    args -> ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Id]
    args, []))

    {-
    Note [Inline partially-applied constructor wrappers]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    We allow the wrapper to inline when partially applied to avoid
    boxing values unnecessarily. For example, consider

       data Foo a = Foo !Int a

       instance Traversable Foo where
         traverse f (Foo i a) = Foo i <$> f a

    This desugars to

       traverse f foo = case foo of
            Foo i# a -> let i = I# i#
                        in map ($WFoo i) (f a)

    If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`.
    But if we inline the wrapper, we get

       map (\a. case i of I# i# a -> Foo i# a) (f a)

    and now case-of-known-constructor eliminates the redundant allocation.

    -}

    data DataConBangOpts
      = FixedBangOpts [HsImplBang]
        -- ^ Used for imported data constructors
        -- See Note [Bangs on imported data constructors]
      | SrcBangOpts !BangOpts

    data BangOpts = BangOpts
      { BangOpts -> Bool
    bang_opt_strict_data   :: !Bool -- ^ Strict fields by default
      , BangOpts -> Bool
    bang_opt_unbox_disable :: !Bool -- ^ Disable automatic field unboxing (e.g. if we aren't optimising)
      , BangOpts -> Bool
    bang_opt_unbox_strict  :: !Bool -- ^ Unbox strict fields
      , BangOpts -> Bool
    bang_opt_unbox_small   :: !Bool -- ^ Unbox small strict fields
      }

    mkDataConRep :: DataConBangOpts
                 -> FamInstEnvs
                 -> Name
                 -> DataCon
                 -> UniqSM DataConRep
    mkDataConRep :: DataConBangOpts
    -> FamInstEnvs -> Name -> DataCon -> UniqSM DataConRep
    mkDataConRep DataConBangOpts
    dc_bang_opts FamInstEnvs
    fam_envs Name
    wrap_name DataCon
    data_con
      | Bool -> Bool
    not Bool
    wrapper_reqd
      = DataConRep -> UniqSM DataConRep
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return DataConRep
    NoDataConRep

      | Bool
    otherwise
      = do { wrap_args <- (Scaled Type -> UniqSM Id) -> [Scaled Type] -> UniqSM [Id]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (RuleName -> Scaled Type -> UniqSM Id
    newLocal (String -> RuleName
    fsLit String
    "conrep")) [Scaled Type]
    wrap_arg_tys
           ; wrap_body <- mk_rep_app (dropList stupid_theta wrap_args `zip` dropList eq_spec unboxers)
                                     initial_wrap_app
                            -- Drop the stupid theta arguments, as per
                            -- Note [Instantiating stupid theta] in GHC.Core.DataCon.

           ; let wrap_id = IdDetails -> Name -> Type -> IdInfo -> Id
    mkGlobalId (DataCon -> IdDetails
    DataConWrapId DataCon
    data_con) Name
    wrap_name Type
    wrap_ty IdInfo
    wrap_info
                 wrap_info = IdInfo
    noCafIdInfo
                             IdInfo -> Int -> IdInfo
    `setArityInfo`         Int
    wrap_arity
                                 -- It's important to specify the arity, so that partial
                                 -- applications are treated as values
                             IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo`    InlinePragma
    wrap_prag
                             IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`     Unfolding
    wrap_unf
                             IdInfo -> DmdSig -> IdInfo
    `setDmdSigInfo`        DmdSig
    wrap_sig
                                 -- We need to get the CAF info right here because GHC.Iface.Tidy
                                 -- does not tidy the IdInfo of implicit bindings (like the wrapper)
                                 -- so it not make sure that the CAF info is sane
                             IdInfo -> LambdaFormInfo -> IdInfo
    `setLFInfo`            LambdaFormInfo
    wrap_lf_info

                 -- The signature is purely for passes like the Simplifier, not for
                 -- DmdAnal itself; see Note [DmdAnal for DataCon wrappers].
                 wrap_sig = [Demand] -> Divergence -> DmdSig
    mkClosedDmdSig [Demand]
    wrap_arg_dmds Divergence
    topDiv

                 -- See Note [LFInfo of DataCon workers and wrappers]
                 wrap_lf_info
                   | Int
    wrap_arity Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0  = DataCon -> LambdaFormInfo
    LFCon DataCon
    data_con
                   -- See W1 in Note [LFInfo of DataCon workers and wrappers]
                   | TyCon -> Bool
    isNewTyCon TyCon
    tycon = String -> LambdaFormInfo
    forall a. HasCallStack => String -> a
    panic String
    "mkDataConRep: we shouldn't look at LFInfo for newtype wrapper ids"
                   | Bool
    otherwise        = TopLevelFlag -> Int -> Bool -> ArgDescr -> LambdaFormInfo
    LFReEntrant TopLevelFlag
    TopLevel (Int -> Type -> Int
    countFunRepArgs Int
    wrap_arity Type
    wrap_ty) Bool
    True ArgDescr
    ArgUnknown
                                                          -- LFInfo stores post-unarisation arity

                 wrap_arg_dmds =
                   Int -> Demand -> [Demand]
    forall a. Int -> a -> [a]
    replicate ([Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    theta) Demand
    topDmd [Demand] -> [Demand] -> [Demand]
    forall a. [a] -> [a] -> [a]
    ++ (HsImplBang -> Demand) -> [HsImplBang] -> [Demand]
    forall a b. (a -> b) -> [a] -> [b]
    map HsImplBang -> Demand
    mk_dmd [HsImplBang]
    arg_ibangs
                   -- Don't forget the dictionary arguments when building
                   -- the strictness signature (#14290).

                 mk_dmd HsImplBang
    str | HsImplBang -> Bool
    isBanged HsImplBang
    str = Demand
    evalDmd
                            | Bool
    otherwise    = Demand
    topDmd

                 wrap_prag = InlinePragma
    dataConWrapperInlinePragma
                             InlinePragma -> Activation -> InlinePragma
    `setInlinePragmaActivation` Activation
    activateDuringFinal
                             -- See Note [Activation for data constructor wrappers]

                 -- The wrapper will usually be inlined (see wrap_unf), so its
                 -- strictness and CPR info is usually irrelevant. But this is
                 -- not always the case; GHC may choose not to inline it. In
                 -- particular, the wrapper constructor is not inlined inside
                 -- an INLINE rhs or when it is not applied to any arguments.
                 -- See Note [Inline partially-applied constructor wrappers]
                 -- Passing Nothing here allows the wrapper to inline when
                 -- unsaturated.
                 wrap_unf | TyCon -> Bool
    isNewTyCon TyCon
    tycon = CoreExpr -> Unfolding
    mkCompulsoryUnfolding CoreExpr
    wrap_rhs
                            -- See Note [Compulsory newtype unfolding]
                          | Bool
    otherwise        = CoreExpr -> Unfolding
    mkDataConUnfolding CoreExpr
    wrap_rhs
                 wrap_rhs = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    wrap_tvs (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                            [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    wrap_args (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                            TyCon -> [Type] -> CoreExpr -> CoreExpr
    wrapFamInstBody TyCon
    tycon [Type]
    res_ty_args (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                            CoreExpr
    wrap_body

           ; return (DCR { dcr_wrap_id = wrap_id
                         , dcr_boxer   = mk_boxer boxers
                         , dcr_arg_tys = rep_tys
                         , dcr_stricts = rep_strs
                           -- For newtypes, dcr_bangs is always [HsLazy].
                           -- See Note [HsImplBangs for newtypes].
                         , dcr_bangs   = arg_ibangs }) }

      where
        ([Id]
    univ_tvs, [Id]
    ex_tvs, [EqSpec]
    eq_spec, [Type]
    theta, [Scaled Type]
    orig_arg_tys, Type
    _orig_res_ty)
                     = DataCon -> ([Id], [Id], [EqSpec], [Type], [Scaled Type], Type)
    dataConFullSig DataCon
    data_con
        stupid_theta :: [Type]
    stupid_theta = DataCon -> [Type]
    dataConStupidTheta DataCon
    data_con
        wrap_tvs :: [Id]
    wrap_tvs     = DataCon -> [Id]
    dataConUserTyVars DataCon
    data_con
        res_ty_args :: [Type]
    res_ty_args  = DataCon -> [Type]
    dataConResRepTyArgs DataCon
    data_con

        tycon :: TyCon
    tycon        = DataCon -> TyCon
    dataConTyCon DataCon
    data_con       -- The representation TyCon (not family)
        wrap_ty :: Type
    wrap_ty      = DataCon -> Type
    dataConWrapperType DataCon
    data_con
        ev_tys :: [Type]
    ev_tys       = [EqSpec] -> [Type]
    eqSpecPreds [EqSpec]
    eq_spec [Type] -> [Type] -> [Type]
    forall a. [a] -> [a] -> [a]
    ++ [Type]
    theta
        all_arg_tys :: [Scaled Type]
    all_arg_tys  = (Type -> Scaled Type) -> [Type] -> [Scaled Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Scaled Type
    forall a. a -> Scaled a
    unrestricted [Type]
    ev_tys [Scaled Type] -> [Scaled Type] -> [Scaled Type]
    forall a. [a] -> [a] -> [a]
    ++ [Scaled Type]
    orig_arg_tys
        ev_ibangs :: [HsImplBang]
    ev_ibangs    = (Type -> HsImplBang) -> [Type] -> [HsImplBang]
    forall a b. (a -> b) -> [a] -> [b]
    map (HsImplBang -> Type -> HsImplBang
    forall a b. a -> b -> a
    const HsImplBang
    HsLazy) [Type]
    ev_tys
        orig_bangs :: [HsSrcBang]
    orig_bangs   = DataCon -> [HsSrcBang]
    dataConSrcBangs DataCon
    data_con

        wrap_arg_tys :: [Scaled Type]
    wrap_arg_tys = ((Type -> Scaled Type) -> [Type] -> [Scaled Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Scaled Type
    forall a. a -> Scaled a
    unrestricted ([Type] -> [Scaled Type]) -> [Type] -> [Scaled Type]
    forall a b. (a -> b) -> a -> b
    $ [Type]
    stupid_theta [Type] -> [Type] -> [Type]
    forall a. [a] -> [a] -> [a]
    ++ [Type]
    theta) [Scaled Type] -> [Scaled Type] -> [Scaled Type]
    forall a. [a] -> [a] -> [a]
    ++ [Scaled Type]
    orig_arg_tys
        wrap_arity :: Int
    wrap_arity   = (Id -> Bool) -> [Id] -> Int
    forall a. (a -> Bool) -> [a] -> Int
    count Id -> Bool
    isCoVar [Id]
    ex_tvs Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [Scaled Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Scaled Type]
    wrap_arg_tys
                 -- The wrap_args are the arguments *other than* the eq_spec
                 -- Because we are going to apply the eq_spec args manually in the
                 -- wrapper

        new_tycon :: Bool
    new_tycon = TyCon -> Bool
    isNewTyCon TyCon
    tycon
        arg_ibangs :: [HsImplBang]
    arg_ibangs
          | Bool
    new_tycon
          = (Scaled Type -> HsImplBang) -> [Scaled Type] -> [HsImplBang]
    forall a b. (a -> b) -> [a] -> [b]
    map (HsImplBang -> Scaled Type -> HsImplBang
    forall a b. a -> b -> a
    const HsImplBang
    HsLazy) [Scaled Type]
    orig_arg_tys -- See Note [HsImplBangs for newtypes]
                                            -- orig_arg_tys should be a singleton, but
                                            -- if a user declared a wrong newtype we
                                            -- detect this later (see test T2334A)
          | Bool
    otherwise
          = case DataConBangOpts
    dc_bang_opts of
              SrcBangOpts BangOpts
    bang_opts -> (Scaled Type -> HsSrcBang -> HsImplBang)
    -> [Scaled Type] -> [HsSrcBang] -> [HsImplBang]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (BangOpts -> FamInstEnvs -> Scaled Type -> HsSrcBang -> HsImplBang
    dataConSrcToImplBang BangOpts
    bang_opts FamInstEnvs
    fam_envs)
                                        [Scaled Type]
    orig_arg_tys [HsSrcBang]
    orig_bangs
              FixedBangOpts [HsImplBang]
    bangs   -> [HsImplBang]
    bangs

        ([[(Scaled Type, StrictnessMark)]]
    rep_tys_w_strs, [(Unboxer, Boxer)]
    wrappers)
          = [([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))]
    -> ([[(Scaled Type, StrictnessMark)]], [(Unboxer, Boxer)])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ((Scaled Type
     -> HsImplBang
     -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer)))
    -> [Scaled Type]
    -> [HsImplBang]
    -> [([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith Scaled Type
    -> HsImplBang
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    dataConArgRep [Scaled Type]
    all_arg_tys ([HsImplBang]
    ev_ibangs [HsImplBang] -> [HsImplBang] -> [HsImplBang]
    forall a. [a] -> [a] -> [a]
    ++ [HsImplBang]
    arg_ibangs))

        ([Unboxer]
    unboxers, [Boxer]
    boxers) = [(Unboxer, Boxer)] -> ([Unboxer], [Boxer])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(Unboxer, Boxer)]
    wrappers
        ([Scaled Type]
    rep_tys, [StrictnessMark]
    rep_strs) = [(Scaled Type, StrictnessMark)]
    -> ([Scaled Type], [StrictnessMark])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([[(Scaled Type, StrictnessMark)]]
    -> [(Scaled Type, StrictnessMark)]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[(Scaled Type, StrictnessMark)]]
    rep_tys_w_strs)

        -- This is True if the data constructor or class dictionary constructor
        -- needs a wrapper. This wrapper is injected into the program later in the
        -- CoreTidy pass. See Note [Injecting implicit bindings] in GHC.Iface.Tidy,
        -- along with the accompanying implementation in getTyConImplicitBinds.
        wrapper_reqd :: Bool
    wrapper_reqd
          | TyCon -> Bool
    isTypeDataTyCon TyCon
    tycon
            -- `type data` declarations never have data-constructor wrappers
            -- Their data constructors only live at the type level, in the
            -- form of PromotedDataCon, and therefore do not need wrappers.
            -- See wrinkle (W0) in Note [Type data declarations] in GHC.Rename.Module.
          = Bool
    False

          | Bool
    otherwise
          = (Bool -> Bool
    not Bool
    new_tycon
                         -- (Most) newtypes have only a worker, with the exception
                         -- of some newtypes written with GADT syntax.
                         -- See dataConUserTyVarsNeedWrapper below.
             Bool -> Bool -> Bool
    && ((HsImplBang -> Bool) -> [HsImplBang] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any HsImplBang -> Bool
    isBanged ([HsImplBang]
    ev_ibangs [HsImplBang] -> [HsImplBang] -> [HsImplBang]
    forall a. [a] -> [a] -> [a]
    ++ [HsImplBang]
    arg_ibangs)))
                         -- Some forcing/unboxing (includes eq_spec)

          Bool -> Bool -> Bool
    || TyCon -> Bool
    isFamInstTyCon TyCon
    tycon -- Cast result

          Bool -> Bool -> Bool
    || DataCon -> Bool
    dataConUserTyVarsNeedWrapper DataCon
    data_con
                         -- If the data type was written with GADT syntax and
                         -- orders the type variables differently from what the
                         -- worker expects, it needs a data con wrapper to reorder
                         -- the type variables.
                         -- See Note [Data con wrappers and GADT syntax].
                         --
                         -- NB: All GADTs return true from this function, but there
                         -- is one exception that we must check below.

          Bool -> Bool -> Bool
    || Bool -> Bool
    not ([Type] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Type]
    stupid_theta)
                         -- If the data constructor has a datatype context,
                         -- we need a wrapper in order to drop the stupid arguments.
                         -- See Note [Instantiating stupid theta] in GHC.Core.DataCon.

        initial_wrap_app :: CoreExpr
    initial_wrap_app = Id -> CoreExpr
    forall b. Id -> Expr b
    Var (DataCon -> Id
    dataConWorkId DataCon
    data_con)
                           CoreExpr -> [Type] -> CoreExpr
    forall b. Expr b -> [Type] -> Expr b
    `mkTyApps`  [Type]
    res_ty_args
                           CoreExpr -> [Id] -> CoreExpr
    forall b. Expr b -> [Id] -> Expr b
    `mkVarApps` [Id]
    ex_tvs
                           CoreExpr -> [Coercion] -> CoreExpr
    forall b. Expr b -> [Coercion] -> Expr b
    `mkCoApps`  (EqSpec -> Coercion) -> [EqSpec] -> [Coercion]
    forall a b. (a -> b) -> [a] -> [b]
    map (Role -> Type -> Coercion
    mkReflCo Role
    Nominal (Type -> Coercion) -> (EqSpec -> Type) -> EqSpec -> Coercion
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . EqSpec -> Type
    eqSpecType) [EqSpec]
    eq_spec

        mk_boxer :: [Boxer] -> DataConBoxer
        mk_boxer :: [Boxer] -> DataConBoxer
    mk_boxer [Boxer]
    boxers = ([Type] -> [Id] -> UniqSM ([Id], [CoreBind])) -> DataConBoxer
    DCB (\ [Type]
    ty_args [Id]
    src_vars ->
                          do { let ([Id]
    ex_vars, [Id]
    term_vars) = [Id] -> [Id] -> ([Id], [Id])
    forall b a. [b] -> [a] -> ([a], [a])
    splitAtList [Id]
    ex_tvs [Id]
    src_vars
                                   subst1 :: Subst
    subst1 = [Id] -> [Type] -> Subst
    HasDebugCallStack => [Id] -> [Type] -> Subst
    zipTvSubst [Id]
    univ_tvs [Type]
    ty_args
                                   subst2 :: Subst
    subst2 = (Subst -> Id -> Id -> Subst) -> Subst -> [Id] -> [Id] -> Subst
    forall acc a b. (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
    foldl2 Subst -> Id -> Id -> Subst
    extendTvSubstWithClone Subst
    subst1 [Id]
    ex_tvs [Id]
    ex_vars
                             ; (rep_ids, binds) <- Subst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
    go Subst
    subst2 [Boxer]
    boxers [Id]
    term_vars
                             ; return (ex_vars ++ rep_ids, binds) } )

        go :: Subst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
    go Subst
    _ [] [Id]
    src_vars = Bool
    -> SDoc -> UniqSM ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
    forall a. HasCallStack => Bool -> SDoc -> a -> a
    assertPpr ([Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Id]
    src_vars) (DataCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DataCon
    data_con) (UniqSM ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind]))
    -> UniqSM ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
    forall a b. (a -> b) -> a -> b
    $ ([Id], [CoreBind]) -> UniqSM ([Id], [CoreBind])
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], [])
        go Subst
    subst (Boxer
    UnitBox : [Boxer]
    boxers) (Id
    src_var : [Id]
    src_vars)
          = do { (rep_ids2, binds) <- Subst -> [Boxer] -> [Id] -> UniqSM ([Id], [CoreBind])
    go Subst
    subst [Boxer]
    boxers [Id]
    src_vars
               ; return (src_var : rep_ids2, binds) }
        go Subst
    subst (Boxer Subst -> UniqSM ([Id], CoreExpr)
    boxer : [Boxer]
    boxers) (Id
    src_var : [Id]
    src_vars)
          = do { (rep_ids1, arg)  <- Subst -> UniqSM ([Id], CoreExpr)
    boxer Subst
    subst
               ; (rep_ids2, binds) <- go subst boxers src_vars
               ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) }
        go Subst
    _ (Boxer
    _:[Boxer]
    _) [] = String -> SDoc -> UniqSM ([Id], [CoreBind])
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "mk_boxer" (DataCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr DataCon
    data_con)

        mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr
        mk_rep_app :: [(Id, Unboxer)] -> CoreExpr -> UniqSM CoreExpr
    mk_rep_app [] CoreExpr
    con_app
          = CoreExpr -> UniqSM CoreExpr
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CoreExpr
    con_app
        mk_rep_app ((Id
    wrap_arg, Unboxer
    unboxer) : [(Id, Unboxer)]
    prs) CoreExpr
    con_app
          = do { (rep_ids, unbox_fn) <- Unboxer
    unboxer Id
    wrap_arg
               ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
               ; return (unbox_fn expr) }

    dataConWrapperInlinePragma :: InlinePragma
    -- See Note [DataCon wrappers are conlike]
    dataConWrapperInlinePragma :: InlinePragma
    dataConWrapperInlinePragma =  InlinePragma
    alwaysInlineConLikePragma

    {- Note [Activation for data constructor wrappers]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The Activation on a data constructor wrapper allows it to inline only in FinalPhase.
    This way rules have a chance to fire if they mention a data constructor on
    the left
       RULE "foo"  f (K a b) = ...
    Since the LHS of rules are simplified with InitialPhase, we won't
    inline the wrapper on the LHS either.

    On the other hand, this means that exprIsConApp_maybe must be able to deal
    with wrappers so that case-of-constructor is not delayed; see
    Note [exprIsConApp_maybe on data constructors with wrappers] for details.

    It used to activate in phases 2 (afterInitial) and later, but it makes it
    awkward to write a RULE[1] with a constructor on the left: it would work if a
    constructor has no wrapper, but whether a constructor has a wrapper depends, for
    instance, on the order of type argument of that constructors. Therefore changing
    the order of type argument could make previously working RULEs fail.

    See also https://gitlab.haskell.org/ghc/ghc/issues/15840 .

    Note [DataCon wrappers are conlike]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    DataCon workers are clearly ConLike --- they are the “Con” in
    “ConLike”, after all --- but what about DataCon wrappers? Should they
    be marked ConLike, too?

    Yes, absolutely! As described in Note [CONLIKE pragma] in
    GHC.Types.Basic, isConLike influences GHC.Core.Utils.exprIsExpandable,
    which is used by both RULE matching and the case-of-known-constructor
    optimization. It’s crucial that both of those things can see
    applications of DataCon wrappers:

      * User-defined RULEs match on wrappers, not workers, so we might
        need to look through an unfolding built from a DataCon wrapper to
        determine if a RULE matches.

      * Likewise, if we have something like
            let x = $WC a b in ... case x of { C y z -> e } ...
        we still want to apply case-of-known-constructor.

    Therefore, it’s important that we consider DataCon wrappers conlike.
    This is especially true now that we don’t inline DataCon wrappers
    until the final simplifier phase; see Note [Activation for data
    constructor wrappers].

    For further reading, see:
      * Note [Conlike is interesting] in GHC.Core.Op.Simplify.Utils
      * Note [Lone variables] in GHC.Core.Unfold
      * Note [exprIsConApp_maybe on data constructors with wrappers]
        in GHC.Core.SimpleOpt
      * #18012

    Note [Bangs on imported data constructors]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs
    from imported modules.

    - Nothing <=> use HsSrcBangs
    - Just bangs <=> use HsImplBangs

    For imported types we can't work it all out from the HsSrcBangs,
    because we want to be very sure to follow what the original module
    (where the data type was declared) decided, and that depends on what
    flags were enabled when it was compiled. So we record the decisions in
    the interface file.

    The HsImplBangs passed are in 1-1 correspondence with the
    dataConOrigArgTys of the DataCon.

    Note [Data con wrappers and unlifted types]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider
       data T = MkT !Int#

    We certainly do not want to make a wrapper
       $WMkT x = case x of y { DEFAULT -> MkT y }

    For a start, it's still to generate a no-op.  But worse, since wrappers
    are currently injected at TidyCore, we don't even optimise it away!
    So the stupid case expression stays there.  This actually happened for
    the Integer data type (see #1600 comment:66)!

    Note [Data con wrappers and GADT syntax]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider these two very similar data types:

      data T1 a b = MkT1 b

      data T2 a b where
        MkT2 :: forall b a. b -> T2 a b

    Despite their similar appearance, T2 will have a data con wrapper but T1 will
    not. What sets them apart? The types of their constructors, which are:

      MkT1 :: forall a b. b -> T1 a b
      MkT2 :: forall b a. b -> T2 a b

    MkT2's use of GADT syntax allows it to permute the order in which `a` and `b`
    would normally appear. See Note [DataCon user type variable binders] in GHC.Core.DataCon
    for further discussion on this topic.

    The worker data cons for T1 and T2, however, both have types such that `a` is
    expected to come before `b` as arguments. Because MkT2 permutes this order, it
    needs a data con wrapper to swizzle around the type variables to be in the
    order the worker expects.

    A somewhat surprising consequence of this is that *newtypes* can have data con
    wrappers! After all, a newtype can also be written with GADT syntax:

      newtype T3 a b where
        MkT3 :: forall b a. b -> T3 a b

    Again, this needs a wrapper data con to reorder the type variables. It does
    mean that this newtype constructor requires another level of indirection when
    being called, but the inliner should make swift work of that.

    Note [HsImplBangs for newtypes]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Most of the time, we use the dataConSrctoImplBang function to decide what
    strictness/unpackedness to use for the fields of a data type constructor. But
    there is an exception to this rule: newtype constructors. You might not think
    that newtypes would pose a challenge, since newtypes are seemingly forbidden
    from having strictness annotations in the first place. But consider this
    (from #16141):

      {-# LANGUAGE StrictData #-}
      {-# OPTIONS_GHC -O #-}
      newtype T a b where
        MkT :: forall b a. Int -> T a b

    Because StrictData (plus optimization) is enabled, invoking
    dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#!
    This would be disastrous, since the wrapper for `MkT` uses a coercion involving
    Int, not Int#.

    Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the
    case of a newtype constructor, we simply hardcode its dcr_bangs field to
    [HsLazy].
    -}

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

    -- | Conjure a fresh local binder.
    newLocal :: FastString   -- ^ a string which will form part of the 'Var'\'s name
             -> Scaled Type  -- ^ the type of the 'Var'
             -> UniqSM Var
    newLocal :: RuleName -> Scaled Type -> UniqSM Id
    newLocal RuleName
    name_stem (Scaled Type
    w Type
    ty) =
        RuleName -> Type -> Type -> UniqSM Id
    forall (m :: * -> *).
    MonadUnique m =>
    RuleName -> Type -> Type -> m Id
    mkSysLocalOrCoVarM RuleName
    name_stem Type
    w Type
    ty
             -- We should not have "OrCoVar" here, this is a bug (#17545)

    -- | Unpack/Strictness decisions from source module.
    --
    -- This function should only ever be invoked for data constructor fields, and
    -- never on the field of a newtype constructor.
    -- See @Note [HsImplBangs for newtypes]@.
    dataConSrcToImplBang
       :: BangOpts
       -> FamInstEnvs
       -> Scaled Type
       -> HsSrcBang
       -> HsImplBang

    dataConSrcToImplBang :: BangOpts -> FamInstEnvs -> Scaled Type -> HsSrcBang -> HsImplBang
    dataConSrcToImplBang BangOpts
    bang_opts FamInstEnvs
    fam_envs Scaled Type
    arg_ty
                         (HsSrcBang SourceText
    ann (HsBang SrcUnpackedness
    unpk SrcStrictness
    NoSrcStrict))
      | BangOpts -> Bool
    bang_opt_strict_data BangOpts
    bang_opts -- StrictData => strict field
      = BangOpts -> FamInstEnvs -> Scaled Type -> HsSrcBang -> HsImplBang
    dataConSrcToImplBang BangOpts
    bang_opts FamInstEnvs
    fam_envs Scaled Type
    arg_ty
                      (SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
    mkHsSrcBang SourceText
    ann SrcUnpackedness
    unpk SrcStrictness
    SrcStrict)
      | Bool
    otherwise -- no StrictData => lazy field
      = HsImplBang
    HsLazy

    dataConSrcToImplBang BangOpts
    _ FamInstEnvs
    _ Scaled Type
    _ (HsSrcBang SourceText
    _ (HsBang SrcUnpackedness
    _ SrcStrictness
    SrcLazy))
      = HsImplBang
    HsLazy

    dataConSrcToImplBang BangOpts
    bang_opts FamInstEnvs
    fam_envs Scaled Type
    arg_ty
                         (HsSrcBang SourceText
    _ (HsBang SrcUnpackedness
    unpk_prag SrcStrictness
    SrcStrict))
      | HasDebugCallStack => Type -> Bool
    Type -> Bool
    isUnliftedType (Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing Scaled Type
    arg_ty)
        -- NB: non-newtype data constructors can't have representation-polymorphic fields
        -- so this is OK.
      = HsImplBang
    HsLazy  -- For !Int#, say, use HsLazy
                -- See Note [Data con wrappers and unlifted types]

      | let mb_co :: Maybe Reduction
    mb_co   = FamInstEnvs -> Type -> Maybe Reduction
    topNormaliseType_maybe FamInstEnvs
    fam_envs (Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing Scaled Type
    arg_ty)
                         -- Unwrap type families and newtypes
            arg_ty' :: Scaled Type
    arg_ty' = case Maybe Reduction
    mb_co of
                        { Just Reduction
    redn -> Scaled Type -> Type -> Scaled Type
    forall a b. Scaled a -> b -> Scaled b
    scaledSet Scaled Type
    arg_ty (Reduction -> Type
    reductionReducedType Reduction
    redn)
                        ; Maybe Reduction
    Nothing   -> Scaled Type
    arg_ty }
      , BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
    shouldUnpackArgTy BangOpts
    bang_opts SrcUnpackedness
    unpk_prag FamInstEnvs
    fam_envs Scaled Type
    arg_ty'
      = if BangOpts -> Bool
    bang_opt_unbox_disable BangOpts
    bang_opts
        then Bool -> HsImplBang
    HsStrict Bool
    True -- Not unpacking because of -O0
                           -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon
        else case Maybe Reduction
    mb_co of
               Maybe Reduction
    Nothing   -> Maybe Coercion -> HsImplBang
    HsUnpack Maybe Coercion
    forall a. Maybe a
    Nothing
               Just Reduction
    redn -> Maybe Coercion -> HsImplBang
    HsUnpack (Coercion -> Maybe Coercion
    forall a. a -> Maybe a
    Just (Coercion -> Maybe Coercion) -> Coercion -> Maybe Coercion
    forall a b. (a -> b) -> a -> b
    $ Reduction -> Coercion
    reductionCoercion Reduction
    redn)

      | Bool
    otherwise -- Record the strict-but-no-unpack decision
      = Bool -> HsImplBang
    HsStrict Bool
    False

    -- | Wrappers/Workers and representation following Unpack/Strictness
    -- decisions
    dataConArgRep
      :: Scaled Type
      -> HsImplBang
      -> ([(Scaled Type,StrictnessMark)] -- Rep types
         ,(Unboxer,Boxer))

    dataConArgRep :: Scaled Type
    -> HsImplBang
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    dataConArgRep Scaled Type
    arg_ty HsImplBang
    HsLazy
      = ([(Scaled Type
    arg_ty, StrictnessMark
    NotMarkedStrict)], (Unboxer
    unitUnboxer, Boxer
    unitBoxer))

    dataConArgRep Scaled Type
    arg_ty (HsStrict Bool
    _)
      = ([(Scaled Type
    arg_ty, StrictnessMark
    MarkedStrict)], (Unboxer
    seqUnboxer, Boxer
    unitBoxer))

    dataConArgRep Scaled Type
    arg_ty (HsUnpack Maybe Coercion
    Nothing)
      = Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    dataConArgUnpack Scaled Type
    arg_ty

    dataConArgRep (Scaled Type
    w Type
    _) (HsUnpack (Just Coercion
    co))
      | let co_rep_ty :: Type
    co_rep_ty = HasDebugCallStack => Coercion -> Type
    Coercion -> Type
    coercionRKind Coercion
    co
      , ([(Scaled Type, StrictnessMark)]
    rep_tys, (Unboxer, Boxer)
    wrappers) <- Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    dataConArgUnpack (Type -> Type -> Scaled Type
    forall a. Type -> a -> Scaled a
    Scaled Type
    w Type
    co_rep_ty)
      = ([(Scaled Type, StrictnessMark)]
    rep_tys, Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
    wrapCo Coercion
    co Type
    co_rep_ty (Unboxer, Boxer)
    wrappers)

    -------------------------
    wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
    wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
    wrapCo Coercion
    co Type
    rep_ty (Unboxer
    unbox_rep, Boxer
    box_rep)  -- co :: arg_ty ~ rep_ty
      = (Unboxer
    unboxer, Boxer
    boxer)
      where
        unboxer :: Unboxer
    unboxer Id
    arg_id = do { rep_id <- RuleName -> Scaled Type -> UniqSM Id
    newLocal (String -> RuleName
    fsLit String
    "cowrap_unbx") (Type -> Type -> Scaled Type
    forall a. Type -> a -> Scaled a
    Scaled (Id -> Type
    idMult Id
    arg_id) Type
    rep_ty)
                            ; (rep_ids, rep_fn) <- unbox_rep rep_id
                            ; let co_bind = Id -> CoreExpr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    rep_id (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    arg_id CoreExpr -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    `Cast` Coercion
    co)
                            ; return (rep_ids, Let co_bind . rep_fn) }
        boxer :: Boxer
    boxer = (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
    Boxer ((Subst -> UniqSM ([Id], CoreExpr)) -> Boxer)
    -> (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
    forall a b. (a -> b) -> a -> b
    $ \ Subst
    subst ->
                do { (rep_ids, rep_expr)
                        <- case Boxer
    box_rep of
                             Boxer
    UnitBox -> do { rep_id <- RuleName -> Scaled Type -> UniqSM Id
    newLocal (String -> RuleName
    fsLit String
    "cowrap_bx") (Type -> Scaled Type
    forall a. a -> Scaled a
    linear (Type -> Scaled Type) -> Type -> Scaled Type
    forall a b. (a -> b) -> a -> b
    $ HasDebugCallStack => Subst -> Type -> Type
    Subst -> Type -> Type
    TcType.substTy Subst
    subst Type
    rep_ty)
                                           ; return ([rep_id], Var rep_id) }
                             Boxer Subst -> UniqSM ([Id], CoreExpr)
    boxer -> Subst -> UniqSM ([Id], CoreExpr)
    boxer Subst
    subst
                   ; let sco = Subst -> Coercion -> Coercion
    substCoUnchecked Subst
    subst Coercion
    co
                   ; return (rep_ids, rep_expr `Cast` mkSymCo sco) }

    ------------------------
    seqUnboxer :: Unboxer
    seqUnboxer :: Unboxer
    seqUnboxer Id
    v = ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Id
    v], CoreExpr -> Id -> CoreExpr -> CoreExpr
    mkDefaultCase (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    v) Id
    v)

    unitUnboxer :: Unboxer
    unitUnboxer :: Unboxer
    unitUnboxer Id
    v = ([Id], CoreExpr -> CoreExpr) -> UniqSM ([Id], CoreExpr -> CoreExpr)
    forall a. a -> UniqSM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Id
    v], \CoreExpr
    e -> CoreExpr
    e)

    unitBoxer :: Boxer
    unitBoxer :: Boxer
    unitBoxer = Boxer
    UnitBox

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

    {- Note [UNPACK for sum types]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose we have a data type D, for example:
        data D = D1 [Int] [Bool]
               | D2

    and another data type which unpacks a field of type D:
        data U a = MkU {-# UNPACK #-} !D
                       {-# UNPACK #-} !(a,a)
                       {-# UNPACK #-} !D

    Then the wrapper and worker for MkU have these types

      -- Wrapper
      $WMkU :: D -> (a,a) -> D -> U a

      -- Worker
      MkU :: (# (# [Int],[Bool] #) | (# #) #)
          -> a
          -> a
          -> (# (# [Int],[Bool] #) | (# #) #)
          -> U a

    For each unpacked /sum/-type argument, the worker gets one argument.
    But for each unpacked /product/-type argument, the worker gets N
    arguments (here two).

    Why treat them differently?  See Note [Why sums and products are treated differently].

    The wrapper $WMkU looks like this:

      $WMkU :: D -> (a,a) -> D -> U a
      $WMkU x1 y x2
        = case (case x1 of {
                  D1 a b -> (# (# a,b #) | #)
                  D2     -> (# | (# #) #) }) of { x1_ubx ->
          case y of { (y1, y2) ->
          case (case x2 of {
                  D1 a b -> (# (# a,b #) | #)
                  D2     -> (# | (# #) #) }) of { x2_ubx ->
          MkU x1_ubx y1 y2 x2_ubx

    Notice the nested case needed for sums.

    This different treatment for sums and product is implemented in
    dataConArgUnpackSum and dataConArgUnpackProduct respectively.

    Note [Why sums and products are treated differently]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Can we handle sums like products, with each wrapper argument
    occupying multiple argument slots in the worker?  No: for a sum
    type the number of argument slots varies, and that's exactly what
    unboxed sums are designed for.

    Can we handle products like sums, with each wrapper argument occupying
    exactly one argument slot (and unboxed tuple) in the worker?  Yes,
    we could.  For example
       data P = MkP {-# UNPACK #-} !Q
       data Q = MkQ {-# NOUNPACK #-} !Int
                    {-# NOUNPACK #-} Int

    Currently could unpack P thus, taking two slots in the worker
       $WMkP :: Q -> P
       $WMkP x = case x of { MkQ a b -> MkP a b }
       MkP :: Int -> Int -> P  -- Worker

    We could instead do this (uniformly with sums)

       $WMkP1 :: Q -> P
       $WMkP1 x = case (case x of { MkQ a b -> (# a, b #) }) of ubx_x
                  MkP1 ubx_x
       MkP1 :: (# Int, Int #) -> P  -- Worker

    The representation of MkP and MkP1 would be identical (a constructor
    with two fields).

    BUT, with MkP (as with every data constructor) we record its argument
    strictness as a bit-vector, actually [StrictnessMark]
       MkP strictness:  SL
    This information is used in Core to record which fields are sure to
    be evaluated.  (Look for calls to dataConRepStrictness.)  E.g. in Core
        case v of MkP x y -> ....<here x is known to be evald>....

    Alas, with MkP1 this information is hidden by the unboxed pair,
    In Core there will be an auxiliary case expression to take apart the pair:
        case v of MkP1 xy -> case xy of (# x,y #) -> ...
    And now we have no easy way to know that x is evaluated in the "...".

    Fixing this might be possible, but it'd be tricky.  So we avoid the
    problem entirely by treating sums and products differently here.
    -}

    dataConArgUnpack
       :: Scaled Type
       ->  ( [(Scaled Type, StrictnessMark)]   -- Rep types
           , (Unboxer, Boxer) )
    dataConArgUnpack :: Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    dataConArgUnpack scaledTy :: Scaled Type
    scaledTy@(Scaled Type
    _ Type
    arg_ty)
      | Just (TyCon
    tc, [Type]
    tc_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    splitTyConApp_maybe Type
    arg_ty
      = Bool
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    forall a. HasCallStack => Bool -> a -> a
    assert (Bool -> Bool
    not (TyCon -> Bool
    isNewTyCon TyCon
    tc)) (([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
     -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer)))
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    forall a b. (a -> b) -> a -> b
    $
        case TyCon -> [DataCon]
    tyConDataCons TyCon
    tc of
          [DataCon
    con] -> Scaled Type
    -> [Type]
    -> DataCon
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    dataConArgUnpackProduct Scaled Type
    scaledTy [Type]
    tc_args DataCon
    con
          [DataCon]
    cons  -> Scaled Type
    -> [Type]
    -> [DataCon]
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    dataConArgUnpackSum Scaled Type
    scaledTy [Type]
    tc_args [DataCon]
    cons
      | Bool
    otherwise
      = String
    -> SDoc -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "dataConArgUnpack" (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    arg_ty)
        -- An interface file specified Unpacked, but we couldn't unpack it

    dataConArgUnpackProduct
      :: Scaled Type
      -> [Type]
      -> DataCon
      -> ( [(Scaled Type, StrictnessMark)]   -- Rep types
         , (Unboxer, Boxer) )
    dataConArgUnpackProduct :: Scaled Type
    -> [Type]
    -> DataCon
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    dataConArgUnpackProduct (Scaled Type
    arg_mult Type
    _) [Type]
    tc_args DataCon
    con =
      Bool
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    forall a. HasCallStack => Bool -> a -> a
    assert ([Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (DataCon -> [Id]
    dataConExTyCoVars DataCon
    con)) (([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
     -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer)))
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    forall a b. (a -> b) -> a -> b
    $
        -- Note [Unpacking GADTs and existentials]
      let rep_tys :: [Scaled Type]
    rep_tys = (Scaled Type -> Scaled Type) -> [Scaled Type] -> [Scaled Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (Type -> Scaled Type -> Scaled Type
    forall a. Type -> Scaled a -> Scaled a
    scaleScaled Type
    arg_mult) ([Scaled Type] -> [Scaled Type]) -> [Scaled Type] -> [Scaled Type]
    forall a b. (a -> b) -> a -> b
    $ DataCon -> [Type] -> [Scaled Type]
    dataConInstArgTys DataCon
    con [Type]
    tc_args
      in ( [Scaled Type]
    rep_tys [Scaled Type]
    -> [StrictnessMark] -> [(Scaled Type, StrictnessMark)]
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` DataCon -> [StrictnessMark]
    dataConRepStrictness DataCon
    con
         , ( \ Id
    arg_id ->
             do { rep_ids <- (Scaled Type -> UniqSM Id) -> [Scaled Type] -> UniqSM [Id]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (RuleName -> Scaled Type -> UniqSM Id
    newLocal (String -> RuleName
    fsLit String
    "unbx")) [Scaled Type]
    rep_tys
                ; let r_mult = Id -> Type
    idMult Id
    arg_id
                ; let rep_ids' = (Id -> Id) -> [Id] -> [Id]
    forall a b. (a -> b) -> [a] -> [b]
    map (Type -> Id -> Id
    scaleIdBy Type
    r_mult) [Id]
    rep_ids
                ; let unbox_fn CoreExpr
    body
                        = CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
    mkSingleAltCase (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    arg_id) Id
    arg_id
                                   (DataCon -> AltCon
    DataAlt DataCon
    con) [Id]
    rep_ids' CoreExpr
    body
                ; return (rep_ids, unbox_fn) }
           , (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
    Boxer ((Subst -> UniqSM ([Id], CoreExpr)) -> Boxer)
    -> (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
    forall a b. (a -> b) -> a -> b
    $ \ Subst
    subst ->
             do { rep_ids <- (Scaled Type -> UniqSM Id) -> [Scaled Type] -> UniqSM [Id]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (RuleName -> Scaled Type -> UniqSM Id
    newLocal (String -> RuleName
    fsLit String
    "bx") (Scaled Type -> UniqSM Id)
    -> (Scaled Type -> Scaled Type) -> Scaled Type -> UniqSM Id
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . HasDebugCallStack => Subst -> Scaled Type -> Scaled Type
    Subst -> Scaled Type -> Scaled Type
    TcType.substScaledTyUnchecked Subst
    subst) [Scaled Type]
    rep_tys
                ; return (rep_ids, Var (dataConWorkId con)
                                   `mkTyApps` (substTysUnchecked subst tc_args)
                                   `mkVarApps` rep_ids ) } ) )

    dataConArgUnpackSum
      :: Scaled Type
      -> [Type]
      -> [DataCon]
      -> ( [(Scaled Type, StrictnessMark)]   -- Rep types
         , (Unboxer, Boxer) )
    dataConArgUnpackSum :: Scaled Type
    -> [Type]
    -> [DataCon]
    -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    dataConArgUnpackSum (Scaled Type
    arg_mult Type
    arg_ty) [Type]
    tc_args [DataCon]
    cons =
      ( [ (Scaled Type
    sum_ty, StrictnessMark
    MarkedStrict) ] -- The idea: Unpacked variant will
                                   -- be one field only, and the type of the
                                   -- field will be an unboxed sum.
      , ( Unboxer
    unboxer, Boxer
    boxer ) )
      where
        !ubx_sum_arity :: Int
    ubx_sum_arity = [DataCon] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [DataCon]
    cons
        src_tys :: [[Type]]
    src_tys = (DataCon -> [Type]) -> [DataCon] -> [[Type]]
    forall a b. (a -> b) -> [a] -> [b]
    map (\DataCon
    con -> (Scaled Type -> Type) -> [Scaled Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type]
    forall a b. (a -> b) -> a -> b
    $ DataCon -> [Type] -> [Scaled Type]
    dataConInstArgTys DataCon
    con [Type]
    tc_args) [DataCon]
    cons
        sum_alt_tys :: [Type]
    sum_alt_tys = ([Type] -> Type) -> [[Type]] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map [Type] -> Type
    mkUbxSumAltTy [[Type]]
    src_tys
        sum_ty_unscaled :: Type
    sum_ty_unscaled = [Type] -> Type
    mkSumTy [Type]
    sum_alt_tys
        sum_ty :: Scaled Type
    sum_ty = Type -> Type -> Scaled Type
    forall a. Type -> a -> Scaled a
    Scaled Type
    arg_mult Type
    sum_ty_unscaled
        newLocal' :: RuleName -> Type -> UniqSM Id
    newLocal' RuleName
    fs = RuleName -> Scaled Type -> UniqSM Id
    newLocal RuleName
    fs (Scaled Type -> UniqSM Id)
    -> (Type -> Scaled Type) -> Type -> UniqSM Id
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> Type -> Scaled Type
    forall a. Type -> a -> Scaled a
    Scaled Type
    arg_mult

        -- See Note [UNPACK for sum types]
        unboxer :: Unboxer
        unboxer :: Unboxer
    unboxer Id
    arg_id = do
          con_arg_binders <- ([Type] -> UniqSM [Id]) -> [[Type]] -> UniqSM [[Id]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM ((Type -> UniqSM Id) -> [Type] -> UniqSM [Id]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (RuleName -> Type -> UniqSM Id
    newLocal' (String -> RuleName
    fsLit String
    "unbx"))) [[Type]]
    src_tys
          ubx_sum_bndr <- newLocal (fsLit "unbx") sum_ty

          let
            mk_ubx_sum_alt :: Int -> DataCon -> [Var] -> CoreAlt
            mk_ubx_sum_alt Int
    alt DataCon
    con [Id
    bndr] = AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (DataCon -> AltCon
    DataAlt DataCon
    con) [Id
    bndr]
                (Int -> Int -> [Type] -> CoreExpr -> CoreExpr
    mkCoreUnboxedSum Int
    ubx_sum_arity Int
    alt [Type]
    sum_alt_tys (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    bndr))

            mk_ubx_sum_alt Int
    alt DataCon
    con [Id]
    bndrs =
              let tuple :: CoreExpr
    tuple = [CoreExpr] -> CoreExpr
    mkCoreUnboxedTuple ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> CoreExpr
    forall b. Id -> Expr b
    Var [Id]
    bndrs)
               in AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (DataCon -> AltCon
    DataAlt DataCon
    con) [Id]
    bndrs (Int -> Int -> [Type] -> CoreExpr -> CoreExpr
    mkCoreUnboxedSum Int
    ubx_sum_arity Int
    alt [Type]
    sum_alt_tys CoreExpr
    tuple )

            ubx_sum :: CoreExpr
            ubx_sum =
              let alts :: [CoreAlt]
    alts = (Int -> DataCon -> [Id] -> CoreAlt)
    -> [Int] -> [DataCon] -> [[Id]] -> [CoreAlt]
    forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
    zipWith3 Int -> DataCon -> [Id] -> CoreAlt
    mk_ubx_sum_alt [ Int
    1 .. ] [DataCon]
    cons [[Id]]
    con_arg_binders
               in CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    arg_id) Id
    arg_id ([CoreAlt] -> Type
    coreAltsType [CoreAlt]
    alts) [CoreAlt]
    alts

            unbox_fn :: CoreExpr -> CoreExpr
            unbox_fn CoreExpr
    body =
              CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
    mkSingleAltCase CoreExpr
    ubx_sum Id
    ubx_sum_bndr AltCon
    DEFAULT [] CoreExpr
    body

          return ([ubx_sum_bndr], unbox_fn)

        boxer :: Boxer
        boxer :: Boxer
    boxer = (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
    Boxer ((Subst -> UniqSM ([Id], CoreExpr)) -> Boxer)
    -> (Subst -> UniqSM ([Id], CoreExpr)) -> Boxer
    forall a b. (a -> b) -> a -> b
    $ \ Subst
    subst -> do
                  unboxed_field_id <- RuleName -> Type -> UniqSM Id
    newLocal' (String -> RuleName
    fsLit String
    "bx") (HasDebugCallStack => Subst -> Type -> Type
    Subst -> Type -> Type
    TcType.substTy Subst
    subst Type
    sum_ty_unscaled)
                  tuple_bndrs <- mapM (newLocal' (fsLit "bx") . TcType.substTy subst) sum_alt_tys

                  let tc_args' = HasDebugCallStack => Subst -> [Type] -> [Type]
    Subst -> [Type] -> [Type]
    substTys Subst
    subst [Type]
    tc_args
                      arg_ty' = HasDebugCallStack => Subst -> Type -> Type
    Subst -> Type -> Type
    substTy Subst
    subst Type
    arg_ty

                  con_arg_binders <-
                    mapM (mapM (newLocal' (fsLit "bx")) . map (TcType.substTy subst)) src_tys

                  let mk_sum_alt :: Int -> DataCon -> Var -> [Var] -> CoreAlt
                      mk_sum_alt Int
    alt DataCon
    con Id
    _ [Id
    datacon_bndr] =
                        ( AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (DataCon -> AltCon
    DataAlt (Int -> Int -> DataCon
    sumDataCon Int
    alt Int
    ubx_sum_arity)) [Id
    datacon_bndr]
                          (Id -> CoreExpr
    forall b. Id -> Expr b
    Var (DataCon -> Id
    dataConWorkId DataCon
    con) CoreExpr -> [Type] -> CoreExpr
    forall b. Expr b -> [Type] -> Expr b
    `mkTyApps`  [Type]
    tc_args'
                                                  CoreExpr -> [Id] -> CoreExpr
    forall b. Expr b -> [Id] -> Expr b
    `mkVarApps` [Id
    datacon_bndr] ))

                      mk_sum_alt Int
    alt DataCon
    con Id
    tuple_bndr [Id]
    datacon_bndrs =
                        ( AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (DataCon -> AltCon
    DataAlt (Int -> Int -> DataCon
    sumDataCon Int
    alt Int
    ubx_sum_arity)) [Id
    tuple_bndr] (
                          CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    tuple_bndr) Id
    tuple_bndr Type
    arg_ty'
                            [ AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (DataCon -> AltCon
    DataAlt (Boxity -> Int -> DataCon
    tupleDataCon Boxity
    Unboxed ([Id] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Id]
    datacon_bndrs))) [Id]
    datacon_bndrs
                                (Id -> CoreExpr
    forall b. Id -> Expr b
    Var (DataCon -> Id
    dataConWorkId DataCon
    con) CoreExpr -> [Type] -> CoreExpr
    forall b. Expr b -> [Type] -> Expr b
    `mkTyApps`  [Type]
    tc_args'
                                                        CoreExpr -> [Id] -> CoreExpr
    forall b. Expr b -> [Id] -> Expr b
    `mkVarApps` [Id]
    datacon_bndrs ) ] ))

                  return ( [unboxed_field_id],
                           Case (Var unboxed_field_id) unboxed_field_id arg_ty'
                                (zipWith4 mk_sum_alt [ 1 .. ] cons tuple_bndrs con_arg_binders) )

    -- | Every alternative of an unboxed sum has exactly one field, and we use
    -- unboxed tuples when we need more than one field. This generates an unboxed
    -- tuple when necessary, to be used in unboxed sum alts.
    mkUbxSumAltTy :: [Type] -> Type
    mkUbxSumAltTy :: [Type] -> Type
    mkUbxSumAltTy [Type
    ty] = Type
    ty
    mkUbxSumAltTy [Type]
    tys  = Boxity -> [Type] -> Type
    mkTupleTy Boxity
    Unboxed [Type]
    tys

    shouldUnpackArgTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
    -- True if we ought to unpack the UNPACK the argument type
    -- See Note [Recursive unboxing]
    -- We look "deeply" inside rather than relying on the DataCons
    -- we encounter on the way, because otherwise we might well
    -- end up relying on ourselves!
    shouldUnpackArgTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
    shouldUnpackArgTy BangOpts
    bang_opts SrcUnpackedness
    prag FamInstEnvs
    fam_envs Scaled Type
    arg_ty
      | Just [DataCon]
    data_cons <- Type -> Maybe [DataCon]
    unpackable_type_datacons (Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing Scaled Type
    arg_ty)
      , (DataCon -> Bool) -> [DataCon] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all DataCon -> Bool
    ok_con [DataCon]
    data_cons                -- Returns True only if we can't get a
                                            -- loop involving these data cons
      , SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool
    should_unpack SrcUnpackedness
    prag Scaled Type
    arg_ty [DataCon]
    data_cons -- ...hence the call to dataConArgUnpack in
                                            --    should_unpack won't loop
           -- See Wrinkle (W1b) of Note [Recursive unboxing] for this loopy stuff
      = Bool
    True

      | Bool
    otherwise
      = Bool
    False
      where
        ok_con :: DataCon -> Bool      -- True <=> OK to unpack
        ok_con :: DataCon -> Bool
    ok_con DataCon
    top_con                 -- False <=> not safe
          = NameSet -> DataCon -> Bool
    ok_args NameSet
    emptyNameSet DataCon
    top_con
           where
             top_con_name :: Name
    top_con_name = DataCon -> Name
    forall a. NamedThing a => a -> Name
    getName DataCon
    top_con

             ok_args :: NameSet -> DataCon -> Bool
    ok_args NameSet
    dcs DataCon
    con
               = ((Scaled Type, HsSrcBang) -> Bool)
    -> [(Scaled Type, HsSrcBang)] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (NameSet -> (Scaled Type, HsSrcBang) -> Bool
    ok_arg NameSet
    dcs) ([(Scaled Type, HsSrcBang)] -> Bool)
    -> [(Scaled Type, HsSrcBang)] -> Bool
    forall a b. (a -> b) -> a -> b
    $
                 (DataCon -> [Scaled Type]
    dataConOrigArgTys DataCon
    con [Scaled Type] -> [HsSrcBang] -> [(Scaled Type, HsSrcBang)]
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` DataCon -> [HsSrcBang]
    dataConSrcBangs DataCon
    con)
                 -- NB: dataConSrcBangs gives the *user* request;
                 -- We'd get a black hole if we used dataConImplBangs

             ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool
             ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool
    ok_arg NameSet
    dcs (Scaled Type
    _ Type
    ty, HsSrcBang SourceText
    _ (HsBang SrcUnpackedness
    unpack_prag SrcStrictness
    str_prag))
               | SrcStrictness -> Bool
    strict_field SrcStrictness
    str_prag
               , Just [DataCon]
    data_cons <- Type -> Maybe [DataCon]
    unpackable_type_datacons (FamInstEnvs -> Type -> Type
    topNormaliseType FamInstEnvs
    fam_envs Type
    ty)
               , SrcUnpackedness -> [DataCon] -> Bool
    should_unpack_conservative SrcUnpackedness
    unpack_prag [DataCon]
    data_cons  -- Wrinkle (W3)
               = (DataCon -> Bool) -> [DataCon] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (NameSet -> DataCon -> Bool
    ok_rec_con NameSet
    dcs) [DataCon]
    data_cons                    --  of Note [Recursive unboxing]
               | Bool
    otherwise
               = Bool
    True        -- NB True here, in contrast to False at top level

             -- See Note [Recursive unboxing]
             --   * Do not look at the HsImplBangs to `con`; see Wrinkle (W1a)
             --   * For the "at the root" comments see Wrinkle (W2)
             ok_rec_con :: NameSet -> DataCon -> Bool
    ok_rec_con NameSet
    dcs DataCon
    con
               | Name
    dc_name Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    top_con_name   = Bool
    False  -- Recursion at the root
               | Name
    dc_name Name -> NameSet -> Bool
    `elemNameSet` NameSet
    dcs = Bool
    True   -- Not at the root
               | Bool
    otherwise                 = NameSet -> DataCon -> Bool
    ok_args (NameSet
    dcs NameSet -> Name -> NameSet
    `extendNameSet` Name
    dc_name) DataCon
    con
               where
                 dc_name :: Name
    dc_name = DataCon -> Name
    forall a. NamedThing a => a -> Name
    getName DataCon
    con

        strict_field :: SrcStrictness -> Bool
        -- True <=> strict field
        strict_field :: SrcStrictness -> Bool
    strict_field SrcStrictness
    NoSrcStrict = BangOpts -> Bool
    bang_opt_strict_data BangOpts
    bang_opts
        strict_field SrcStrictness
    SrcStrict   = Bool
    True
        strict_field SrcStrictness
    SrcLazy     = Bool
    False

        -- Determine whether we ought to unpack a field,
        -- based on user annotations if present.
        -- A conservative version of should_unpack that doesn't look at how
        -- many fields the field would unpack to... because that leads to a loop.
        -- "Conservative" = err on the side of saying "yes".
        should_unpack_conservative :: SrcUnpackedness -> [DataCon] -> Bool
        should_unpack_conservative :: SrcUnpackedness -> [DataCon] -> Bool
    should_unpack_conservative SrcUnpackedness
    SrcNoUnpack [DataCon]
    _   = Bool
    False  -- {-# NOUNPACK #-}
        should_unpack_conservative SrcUnpackedness
    SrcUnpack   [DataCon]
    _   = Bool
    True   -- {-# NOUNPACK #-}
        should_unpack_conservative SrcUnpackedness
    NoSrcUnpack [DataCon]
    dcs = Bool -> Bool
    not ([DataCon] -> Bool
    is_sum [DataCon]
    dcs)
            -- is_sum: we never unpack sums without a pragma; otherwise be conservative

        -- Determine whether we ought to unpack a field,
        -- based on user annotations if present, and heuristics if not.
        should_unpack :: SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool
        should_unpack :: SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool
    should_unpack SrcUnpackedness
    prag Scaled Type
    arg_ty [DataCon]
    data_cons =
          case SrcUnpackedness
    prag of
            SrcUnpackedness
    SrcNoUnpack -> Bool
    False -- {-# NOUNPACK #-}
            SrcUnpackedness
    SrcUnpack   -> Bool
    True  -- {-# UNPACK #-}
            SrcUnpackedness
    NoSrcUnpack -- No explicit unpack pragma, so use heuristics
              | [DataCon] -> Bool
    is_sum [DataCon]
    data_cons
              -> Bool
    False -- Don't unpack sum types automatically, but they can
                       -- be unpacked with an explicit source UNPACK.
              | Bool
    otherwise   -- Wrinkle (W4) of Note [Recursive unboxing]
              -> BangOpts -> Bool
    bang_opt_unbox_strict BangOpts
    bang_opts
                 Bool -> Bool -> Bool
    || (BangOpts -> Bool
    bang_opt_unbox_small BangOpts
    bang_opts
                     Bool -> Bool -> Bool
    && Bool
    is_small_rep)  -- See Note [Unpack one-wide fields]
          where
            ([(Scaled Type, StrictnessMark)]
    rep_tys, (Unboxer, Boxer)
    _) = Scaled Type -> ([(Scaled Type, StrictnessMark)], (Unboxer, Boxer))
    dataConArgUnpack Scaled Type
    arg_ty

            -- Takes in the list of reps used to represent the dataCon after it's unpacked
            -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields]
            is_small_rep :: Bool
    is_small_rep =
              let -- Neccesary to look through unboxed tuples.
                  prim_reps :: [PrimRep]
    prim_reps = ((Scaled Type, StrictnessMark) -> [PrimRep])
    -> [(Scaled Type, StrictnessMark)] -> [PrimRep]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (HasDebugCallStack => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRep (Type -> [PrimRep])
    -> ((Scaled Type, StrictnessMark) -> Type)
    -> (Scaled Type, StrictnessMark)
    -> [PrimRep]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing (Scaled Type -> Type)
    -> ((Scaled Type, StrictnessMark) -> Scaled Type)
    -> (Scaled Type, StrictnessMark)
    -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Scaled Type, StrictnessMark) -> Scaled Type
    forall a b. (a, b) -> a
    fst) ([(Scaled Type, StrictnessMark)] -> [PrimRep])
    -> [(Scaled Type, StrictnessMark)] -> [PrimRep]
    forall a b. (a -> b) -> a -> b
    $ [(Scaled Type, StrictnessMark)]
    rep_tys
                  -- And then get the actual size of the unpacked constructor.
                  rep_size :: Int
    rep_size = [Int] -> Int
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum ([Int] -> Int) -> [Int] -> Int
    forall a b. (a -> b) -> a -> b
    $ (PrimRep -> Int) -> [PrimRep] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map PrimRep -> Int
    primRepSizeW64_B [PrimRep]
    prim_reps
              in Int
    rep_size Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    8

        is_sum :: [DataCon] -> Bool
        -- We never unpack sum types automatically
        -- (Product types, we do. Empty types are weeded out by unpackable_type_datacons.)
        is_sum :: [DataCon] -> Bool
    is_sum (DataCon
    _:DataCon
    _:[DataCon]
    _) = Bool
    True
        is_sum [DataCon]
    _       = Bool
    False

    -- Given a type already assumed to have been normalized by topNormaliseType,
    -- unpackable_type_datacons ty = Just datacons
    -- iff ty is of the form
    --     T ty1 .. tyn
    -- and T is an algebraic data type (not newtype), in which no data
    -- constructors have existentials, and datacons is the list of data
    -- constructors of T.
    unpackable_type_datacons :: Type -> Maybe [DataCon]
    unpackable_type_datacons :: Type -> Maybe [DataCon]
    unpackable_type_datacons Type
    ty
      | Just (TyCon
    tc, [Type]
    _) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    splitTyConApp_maybe Type
    ty
      , Bool -> Bool
    not (TyCon -> Bool
    isNewTyCon TyCon
    tc)  -- Even though `ty` has been normalised, it could still
                             -- be a /recursive/ newtype, so we must check for that
      , Just [DataCon]
    cons <- TyCon -> Maybe [DataCon]
    tyConDataCons_maybe TyCon
    tc
      , Bool -> Bool
    not ([DataCon] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [DataCon]
    cons)      -- Don't upack nullary sums; no need.
                             -- They already take zero bits
      , (DataCon -> Bool) -> [DataCon] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all ([Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null ([Id] -> Bool) -> (DataCon -> [Id]) -> DataCon -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DataCon -> [Id]
    dataConExTyCoVars) [DataCon]
    cons
      = [DataCon] -> Maybe [DataCon]
    forall a. a -> Maybe a
    Just [DataCon]
    cons -- See Note [Unpacking GADTs and existentials]
      | Bool
    otherwise
      = Maybe [DataCon]
    forall a. Maybe a
    Nothing

    {-
    Note [Unpacking GADTs and existentials]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    There is nothing stopping us unpacking a data type with equality
    components, like
      data Equal a b where
        Equal :: Equal a a

    And it'd be fine to unpack a product type with existential components
    too, but that would require a bit more plumbing, so currently we don't.

    So for now we require: null (dataConExTyCoVars data_con)
    See #14978

    Note [Unpack one-wide fields]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The flag UnboxSmallStrictFields ensures that any field that can
    (safely) be unboxed to a word-sized unboxed field, should be so unboxed.
    For example:

        data A = A Int#
        newtype B = B A
        data C = C !B
        data D = D !C
        data E = E !()
        data F = F !D
        data G = G !F !F

    All of these should have an Int# as their representation, except
    G which should have two Int#s.

    However

        data T = T !(S Int)
        data S = S !a

    Here we can represent T with an Int#.

    Special care has to be taken to make sure we don't mistake fields with unboxed
    tuple/sum rep or very large reps. See #22309

    For consistency we unpack anything that fits into 8 bytes on a 64-bit platform,
    even when compiling for 32bit platforms. This way unpacking decisions will be the
    same for 32bit and 64bit systems. To do so we use primRepSizeW64_B instead of
    primRepSizeB. See also the tests in test case T22309.

    Note [Recursive unboxing]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider
      data R = MkR {-# UNPACK #-} !S Int
      data S = MkS {-# UNPACK #-} !Int
    The representation arguments of MkR are the *representation* arguments
    of S (plus Int); the rep args of MkS are Int#.  This is all fine.

    But be careful not to try to unbox this!
            data T = MkT {-# UNPACK #-} !T Int
    Because then we'd get an infinite number of arguments.

    Note that it's the *argument* type that matters. This is fine:
            data S = MkS S !Int
    because Int is non-recursive.

    Wrinkles:

    (W1a) We have to be careful that the compiler doesn't go into a loop!
          First, we must not look at the HsImplBang decisions of data constructors
          in the same mutually recursive group.  E.g.
             data S = MkS {-# UNPACK #-} !T Int
             data T = MkT {-# UNPACK #-} !S Int
          Each of S and T must decide /independently/ whether to unpack
          and they had better not both say yes. So they must both say no.
          (We could detect when we leave the group, and /then/ we can rely on
          HsImplBangs; but that requires more plumbing.)

    (W1b) Here is another way the compiler might go into a loop (test T23307b):
             data data T = MkT !S Int
             data S = MkS !T
         Suppose we call `shouldUnpackArgTy` on the !S arg of `T`.  In `should_unpack`
         we ask if the number of fields that `MkS` unpacks to is small enough
         (via rep_tys `lengthAtMost` 1).  But how many field /does/ `MkS` unpack
         to?  Well it depends on the unpacking decision we make for `MkS`, which
         in turn depends on `MkT`, which we are busy deciding. Black holes beckon.

         So we /first/ call `ok_con` on `MkS` (and `ok_con` is conservative;
         see `should_unpack_conservative`), and only /then/ call `should_unpack`.
         Tricky!

    (W2) As #23307 shows,  we /do/ want to unpack the second arg of the Yes
         data constructor in this example, despite the recursion in List:
           data Stream a   = Cons a !(Stream a)
           data Unconsed a = Unconsed a !(Stream a)
           data MUnconsed a = No | Yes {-# UNPACK #-} !(Unconsed a)
         When looking at
           {-# UNPACK #-} (Unconsed a)
         we can take Unconsed apart, but then get into a loop with Stream.
         That's fine: we can still take Unconsed apart.  It's only if we
         have a loop /at the root/ that we must not unpack.

    (W3) Moreover (W2) can apply even if there is a recursive loop:
           data List a = Nil | Cons {-# UNPACK #-} !(Unconsed a)
           data Unconsed a = Unconsed a !(List a)
         Here there is mutual recursion between `Unconsed` and `List`; and yet
         we can unpack the field of `Cons` because we will not unpack the second
         field of `Unconsed`: we never unpack a sum type without an explicit
         pragma (see should_unpack).

    (W4) Consider
            data T = MkT !Wombat
            data Wombat = MkW {-# UNPACK #-} !S Int
            data S = MkS {-# NOUNPACK #-} !Wombat Int
         Suppose we are deciding whether to unpack the first field of MkT, by
         calling (shouldUnpackArgTy Wombat).  Then we'll try to unpack the !S field
         of MkW, and be stopped by the {-# NOUNPACK #-}, and all is fine; we can
         unpack MkT.

         If that NOUNPACK had been a UNPACK, though, we'd get a loop, and would
         decide not to unpack the Wombat field of MkT.

         But what if there was no pragma in `data S`?  Then we /still/ decide not
         to unpack the Wombat field of MkT (at least when auto-unpacking is on),
         because we don't know for sure which decision will be taken for the
         Wombat field of MkS.

         TL;DR when there is no pragma, behave as if there was a UNPACK, at least
         when auto-unpacking is on.  See `should_unpack` in `shouldUnpackArgTy`.

    ************************************************************************
    *                                                                      *
            Wrapping and unwrapping newtypes and type families
    *                                                                      *
    ************************************************************************
    -}

    wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
    -- The wrapper for the data constructor for a newtype looks like this:
    --      newtype T a = MkT (a,Int)
    --      MkT :: forall a. (a,Int) -> T a
    --      MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)
    -- where CoT is the coercion TyCon associated with the newtype
    --
    -- The call (wrapNewTypeBody T [a] e) returns the
    -- body of the wrapper, namely
    --      e `cast` (CoT [a])
    --
    -- If a coercion constructor is provided in the newtype, then we use
    -- it, otherwise the wrap/unwrap are both no-ops

    wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
    wrapNewTypeBody TyCon
    tycon [Type]
    args CoreExpr
    result_expr
      = Bool -> CoreExpr -> CoreExpr
    forall a. HasCallStack => Bool -> a -> a
    assert (TyCon -> Bool
    isNewTyCon TyCon
    tycon) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
        HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
    CoreExpr -> Coercion -> CoreExpr
    mkCast CoreExpr
    result_expr (Coercion -> Coercion
    mkSymCo Coercion
    co)
      where
        co :: Coercion
    co = Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
    mkUnbranchedAxInstCo Role
    Representational (TyCon -> CoAxiom Unbranched
    newTyConCo TyCon
    tycon) [Type]
    args []

    -- When unwrapping, we do *not* apply any family coercion, because this will
    -- be done via a CoPat by the type checker.  We have to do it this way as
    -- computing the right type arguments for the coercion requires more than just
    -- a splitting operation (cf, GHC.Tc.Gen.Pat.tcConPat).

    unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
    unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
    unwrapNewTypeBody TyCon
    tycon [Type]
    args CoreExpr
    result_expr
      = Bool -> CoreExpr -> CoreExpr
    forall a. HasCallStack => Bool -> a -> a
    assert (TyCon -> Bool
    isNewTyCon TyCon
    tycon) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
        HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
    CoreExpr -> Coercion -> CoreExpr
    mkCast CoreExpr
    result_expr (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
    mkUnbranchedAxInstCo Role
    Representational (TyCon -> CoAxiom Unbranched
    newTyConCo TyCon
    tycon) [Type]
    args [])

    -- If the type constructor is a representation type of a data instance, wrap
    -- the expression into a cast adjusting the expression type, which is an
    -- instance of the representation type, to the corresponding instance of the
    -- family instance type.
    -- See Note [Wrappers for data instance tycons]
    wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
    wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
    wrapFamInstBody TyCon
    tycon [Type]
    args CoreExpr
    body
      | Just CoAxiom Unbranched
    co_con <- TyCon -> Maybe (CoAxiom Unbranched)
    tyConFamilyCoercion_maybe TyCon
    tycon
      = HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
    CoreExpr -> Coercion -> CoreExpr
    mkCast CoreExpr
    body (Coercion -> Coercion
    mkSymCo (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
    mkUnbranchedAxInstCo Role
    Representational CoAxiom Unbranched
    co_con [Type]
    args []))
      | Bool
    otherwise
      = CoreExpr
    body

    {-
    ************************************************************************
    *                                                                      *
    * Foreign calls
    *                                                                      *
    ************************************************************************
    -}

    -- For each ccall we manufacture a separate CCallOpId, giving it
    -- a fresh unique, a type that is correct for this particular ccall,
    -- and a CCall structure that gives the correct details about calling
    -- convention etc.
    --
    -- The *name* of this Id is a local name whose OccName gives the full
    -- details of the ccall, type and all.  This means that the interface
    -- file reader can reconstruct a suitable Id

    mkFCallId :: Unique -> ForeignCall -> Type -> Id
    mkFCallId :: Unique -> ForeignCall -> Type -> Id
    mkFCallId Unique
    uniq ForeignCall
    fcall Type
    ty
      = Bool -> Id -> Id
    forall a. HasCallStack => Bool -> a -> a
    assert (Type -> Bool
    noFreeVarsOfType Type
    ty) (Id -> Id) -> Id -> Id
    forall a b. (a -> b) -> a -> b
    $
        -- A CCallOpId should have no free type variables;
        -- when doing substitutions won't substitute over it
        IdDetails -> Name -> Type -> IdInfo -> Id
    mkGlobalId (ForeignCall -> IdDetails
    FCallId ForeignCall
    fcall) Name
    name Type
    ty IdInfo
    info
      where
        occ_str :: String
    occ_str = SDocContext -> SDoc -> String
    renderWithContext SDocContext
    defaultSDocContext (SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    braces (ForeignCall -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ForeignCall
    fcall SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty))
        -- The "occurrence name" of a ccall is the full info about the
        -- ccall; it is encoded, but may have embedded spaces etc!

        name :: Name
    name = Unique -> RuleName -> Name
    mkFCallName Unique
    uniq (String -> RuleName
    mkFastString String
    occ_str)

        info :: IdInfo
    info = IdInfo
    noCafIdInfo
               IdInfo -> Int -> IdInfo
    `setArityInfo`  Int
    arity
               IdInfo -> DmdSig -> IdInfo
    `setDmdSigInfo` DmdSig
    strict_sig
               IdInfo -> CprSig -> IdInfo
    `setCprSigInfo` CprSig
    topCprSig

        ([PiTyVarBinder]
    bndrs, Type
    _) = Type -> ([PiTyVarBinder], Type)
    tcSplitPiTys Type
    ty
        arity :: Int
    arity      = (PiTyVarBinder -> Bool) -> [PiTyVarBinder] -> Int
    forall a. (a -> Bool) -> [a] -> Int
    count PiTyVarBinder -> Bool
    isAnonPiTyBinder [PiTyVarBinder]
    bndrs
        strict_sig :: DmdSig
    strict_sig = Int -> Divergence -> DmdSig
    mkVanillaDmdSig Int
    arity Divergence
    topDiv
        -- the call does not claim to be strict in its arguments, since they
        -- may be lifted (foreign import prim) and the called code doesn't
        -- necessarily force them. See #11076.
    {-
    ************************************************************************
    *                                                                      *
    \subsection{DictFuns and default methods}
    *                                                                      *
    ************************************************************************

    Note [Dict funs and default methods]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Dict funs and default methods are *not* ImplicitIds.  Their definition
    involves user-written code, so we can't figure out their strictness etc
    based on fixed info, as we can for constructors and record selectors (say).

    NB: See also Note [Exported LocalIds] in GHC.Types.Id
    -}

    mkDictFunId :: Name      -- Name to use for the dict fun;
                -> [TyVar]
                -> ThetaType
                -> Class
                -> [Type]
                -> Id
    -- Implements the DFun Superclass Invariant (see GHC.Tc.TyCl.Instance)
    -- See Note [Dict funs and default methods]

    mkDictFunId :: Name -> [Id] -> [Type] -> Class -> [Type] -> Id
    mkDictFunId Name
    dfun_name [Id]
    tvs [Type]
    theta Class
    clas [Type]
    tys
      = IdDetails -> Name -> Type -> Id
    mkExportedLocalId (Bool -> IdDetails
    DFunId Bool
    is_nt)
                          Name
    dfun_name
                          Type
    dfun_ty
      where
        is_nt :: Bool
    is_nt = TyCon -> Bool
    isNewTyCon (Class -> TyCon
    classTyCon Class
    clas)
        dfun_ty :: Type
    dfun_ty = [Id] -> [Type] -> Type -> Type
    TcType.tcMkDFunSigmaTy [Id]
    tvs [Type]
    theta (Class -> [Type] -> Type
    mkClassPred Class
    clas [Type]
    tys)

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Un-definable}
    *                                                                      *
    ************************************************************************

    These Ids can't be defined in Haskell.  They could be defined in
    unfoldings in the wired-in GHC.Prim interface file, but we'd have to
    ensure that they were definitely, definitely inlined, because there is
    no curried identifier for them.  That's what mkCompulsoryUnfolding
    does. Alternatively, we could add the definitions to mi_decls of ghcPrimIface
    but it's not clear if this would be simpler.

    coercionToken# is not listed in ghcPrimIds, since its type uses (~#)
    which is not supposed to be used in expressions (GHC throws an assertion
    failure when trying.)
    -}

    nullAddrName, seqName,
       realWorldName, voidPrimIdName, coercionTokenName,
       coerceName, proxyName,
       leftSectionName, rightSectionName :: Name
    nullAddrName :: Name
    nullAddrName      = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_PRIM  (String -> RuleName
    fsLit String
    "nullAddr#")      Unique
    nullAddrIdKey      Id
    nullAddrId
    seqName :: Name
    seqName           = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_PRIM  (String -> RuleName
    fsLit String
    "seq")            Unique
    seqIdKey           Id
    seqId
    realWorldName :: Name
    realWorldName     = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_PRIM  (String -> RuleName
    fsLit String
    "realWorld#")     Unique
    realWorldPrimIdKey Id
    realWorldPrimId
    voidPrimIdName :: Name
    voidPrimIdName    = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_PRIM  (String -> RuleName
    fsLit String
    "void#")          Unique
    voidPrimIdKey      Id
    voidPrimId
    coercionTokenName :: Name
    coercionTokenName = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_PRIM  (String -> RuleName
    fsLit String
    "coercionToken#") Unique
    coercionTokenIdKey Id
    coercionTokenId
    coerceName :: Name
    coerceName        = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_PRIM  (String -> RuleName
    fsLit String
    "coerce")         Unique
    coerceKey          Id
    coerceId
    proxyName :: Name
    proxyName         = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_PRIM  (String -> RuleName
    fsLit String
    "proxy#")         Unique
    proxyHashKey       Id
    proxyHashId
    leftSectionName :: Name
    leftSectionName   = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_PRIM  (String -> RuleName
    fsLit String
    "leftSection")    Unique
    leftSectionKey     Id
    leftSectionId
    rightSectionName :: Name
    rightSectionName  = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_PRIM  (String -> RuleName
    fsLit String
    "rightSection")   Unique
    rightSectionKey    Id
    rightSectionId

    -- Names listed in magicIds; see Note [magicIds]
    lazyIdName, oneShotName, nospecIdName :: Name
    lazyIdName :: Name
    lazyIdName        = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_MAGIC (String -> RuleName
    fsLit String
    "lazy")           Unique
    lazyIdKey          Id
    lazyId
    oneShotName :: Name
    oneShotName       = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_MAGIC (String -> RuleName
    fsLit String
    "oneShot")        Unique
    oneShotKey         Id
    oneShotId
    nospecIdName :: Name
    nospecIdName      = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_MAGIC (String -> RuleName
    fsLit String
    "nospec")         Unique
    nospecIdKey        Id
    nospecId

    ------------------------------------------------
    proxyHashId :: Id
    proxyHashId :: Id
    proxyHashId
      = Name -> Type -> IdInfo -> Id
    pcMiscPrelId Name
    proxyName Type
    ty
           (IdInfo
    noCafIdInfo IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo` Unfolding
    evaldUnfolding) -- Note [evaldUnfoldings]
      where
        -- proxy# :: forall {k} (a:k). Proxy# k a
        --
        -- The visibility of the `k` binder is Inferred to match the type of the
        -- Proxy data constructor (#16293).
        [Id
    kv,Id
    tv] = Type -> (Type -> [Type]) -> [Id]
    mkTemplateKiTyVar Type
    liftedTypeKind (\Type
    x -> [Type
    x])
        kv_ty :: Type
    kv_ty   = Id -> Type
    mkTyVarTy Id
    kv
        tv_ty :: Type
    tv_ty   = Id -> Type
    mkTyVarTy Id
    tv
        ty :: Type
    ty      = Id -> Type -> Type
    mkInfForAllTy Id
    kv (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $ Id -> Type -> Type
    mkSpecForAllTy Id
    tv (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $ Type -> Type -> Type
    mkProxyPrimTy Type
    kv_ty Type
    tv_ty

    ------------------------------------------------
    nullAddrId :: Id
    -- nullAddr# :: Addr#
    -- The reason it is here is because we don't provide
    -- a way to write this literal in Haskell.
    nullAddrId :: Id
    nullAddrId = Name -> Type -> IdInfo -> Id
    pcMiscPrelId Name
    nullAddrName Type
    addrPrimTy IdInfo
    info
      where
        info :: IdInfo
    info = IdInfo
    noCafIdInfo IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo` InlinePragma
    alwaysInlinePragma
                           IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`  CoreExpr -> Unfolding
    mkCompulsoryUnfolding (Literal -> CoreExpr
    forall b. Literal -> Expr b
    Lit Literal
    nullAddrLit)

    ------------------------------------------------
    seqId :: Id     -- See Note [seqId magic]
    seqId :: Id
    seqId = Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
    pcRepPolyId Name
    seqName Type
    ty Name -> ConcreteTyVars
    concs IdInfo
    info
      where
        info :: IdInfo
    info = IdInfo
    noCafIdInfo IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo` InlinePragma
    inline_prag
                           IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`  CoreExpr -> Unfolding
    mkCompulsoryUnfolding CoreExpr
    rhs
                           IdInfo -> Int -> IdInfo
    `setArityInfo`      Int
    arity

        inline_prag :: InlinePragma
    inline_prag
             = InlinePragma
    alwaysInlinePragma InlinePragma -> Activation -> InlinePragma
    `setInlinePragmaActivation` SourceText -> Int -> Activation
    ActiveAfter
                     SourceText
    NoSourceText Int
    0
                      -- Make 'seq' not inline-always, so that simpleOptExpr
                      -- (see GHC.Core.Subst.simple_app) won't inline 'seq' on the
                      -- LHS of rules.  That way we can have rules for 'seq';
                      -- see Note [seqId magic]

        -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b
        ty :: Type
    ty  =
          Id -> Type -> Type
    mkInfForAllTy Id
    runtimeRep2TyVar
          (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $ [Id] -> Type -> Type
    mkSpecForAllTys [Id
    alphaTyVar, Id
    openBetaTyVar]
          (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $ HasDebugCallStack => Type -> Type -> Type
    Type -> Type -> Type
    mkVisFunTyMany Type
    alphaTy (HasDebugCallStack => Type -> Type -> Type
    Type -> Type -> Type
    mkVisFunTyMany Type
    openBetaTy Type
    openBetaTy)

        [Id
    x,Id
    y] = [Type] -> [Id]
    mkTemplateLocals [Type
    alphaTy, Type
    openBetaTy]
        rhs :: CoreExpr
    rhs = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams ([Id
    runtimeRep2TyVar, Id
    alphaTyVar, Id
    openBetaTyVar, Id
    x, Id
    y]) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
              CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    x) Id
    x Type
    openBetaTy [AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    DEFAULT [] (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    y)]

        concs :: Name -> ConcreteTyVars
    concs = [((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
    mkRepPolyIdConcreteTyVars
            [ ((Type
    openBetaTy, Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
    forall (p :: Polarity).
    Int -> Position (FlipPolarity p) -> Position p
    Argument Int
    2 Position (FlipPolarity 'Neg)
    Position 'Pos
    Top), Id
    runtimeRep2TyVar)]

        arity :: Int
    arity = Int
    2

    ------------------------------------------------
    lazyId :: Id    -- See Note [lazyId magic]
    lazyId :: Id
    lazyId = Name -> Type -> IdInfo -> Id
    pcMiscPrelId Name
    lazyIdName Type
    ty IdInfo
    info
      where
        info :: IdInfo
    info = IdInfo
    noCafIdInfo
        ty :: Type
    ty  = [Id] -> Type -> Type
    mkSpecForAllTys [Id
    alphaTyVar] (HasDebugCallStack => Type -> Type -> Type
    Type -> Type -> Type
    mkVisFunTyMany Type
    alphaTy Type
    alphaTy)

    ------------------------------------------------
    noinlineIdName, noinlineConstraintIdName :: Name
    noinlineIdName :: Name
    noinlineIdName           = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_MAGIC (String -> RuleName
    fsLit String
    "noinline")
                                               Unique
    noinlineIdKey Id
    noinlineId
    noinlineConstraintIdName :: Name
    noinlineConstraintIdName = Module -> RuleName -> Unique -> Id -> Name
    mkWiredInIdName Module
    gHC_MAGIC (String -> RuleName
    fsLit String
    "noinlineConstraint")
                                               Unique
    noinlineConstraintIdKey Id
    noinlineConstraintId

    noinlineId :: Id -- See Note [noinlineId magic]
    noinlineId :: Id
    noinlineId = Name -> Type -> IdInfo -> Id
    pcMiscPrelId Name
    noinlineIdName Type
    ty IdInfo
    info
      where
        info :: IdInfo
    info = IdInfo
    noCafIdInfo
        ty :: Type
    ty  = [Id] -> Type -> Type
    mkSpecForAllTys [Id
    alphaTyVar] (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
              HasDebugCallStack => Type -> Type -> Type
    Type -> Type -> Type
    mkVisFunTyMany Type
    alphaTy Type
    alphaTy

    noinlineConstraintId :: Id -- See Note [noinlineId magic]
    noinlineConstraintId :: Id
    noinlineConstraintId = Name -> Type -> IdInfo -> Id
    pcMiscPrelId Name
    noinlineConstraintIdName Type
    ty IdInfo
    info
      where
        info :: IdInfo
    info = IdInfo
    noCafIdInfo
        ty :: Type
    ty   = [Id] -> Type -> Type
    mkSpecForAllTys [Id
    alphaConstraintTyVar] (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
               HasDebugCallStack => FunTyFlag -> Type -> Type -> Type -> Type
    FunTyFlag -> Type -> Type -> Type -> Type
    mkFunTy FunTyFlag
    visArgConstraintLike Type
    ManyTy Type
    alphaTy Type
    alphaConstraintTy

    ------------------------------------------------
    nospecId :: Id -- See Note [nospecId magic]
    nospecId :: Id
    nospecId = Name -> Type -> IdInfo -> Id
    pcMiscPrelId Name
    nospecIdName Type
    ty IdInfo
    info
      where
        info :: IdInfo
    info = IdInfo
    noCafIdInfo
        ty :: Type
    ty  = [Id] -> Type -> Type
    mkSpecForAllTys [Id
    alphaTyVar] (HasDebugCallStack => Type -> Type -> Type
    Type -> Type -> Type
    mkVisFunTyMany Type
    alphaTy Type
    alphaTy)

    oneShotId :: Id -- See Note [oneShot magic]
    oneShotId :: Id
    oneShotId = Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
    pcRepPolyId Name
    oneShotName Type
    ty Name -> ConcreteTyVars
    concs IdInfo
    info
      where
        info :: IdInfo
    info = IdInfo
    noCafIdInfo IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo` InlinePragma
    alwaysInlinePragma
                           IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`  CoreExpr -> Unfolding
    mkCompulsoryUnfolding CoreExpr
    rhs
                           IdInfo -> Int -> IdInfo
    `setArityInfo`      Int
    arity
        -- oneShot :: forall {r1 r2} (a :: TYPE r1) (b :: TYPE r2). (a -> b) -> (a -> b)
        ty :: Type
    ty  = [Id] -> Type -> Type
    mkInfForAllTys  [ Id
    runtimeRep1TyVar, Id
    runtimeRep2TyVar ] (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
              [Id] -> Type -> Type
    mkSpecForAllTys [ Id
    openAlphaTyVar, Id
    openBetaTyVar ]      (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
              HasDebugCallStack => Type -> Type -> Type
    Type -> Type -> Type
    mkVisFunTyMany Type
    fun_ty Type
    fun_ty
        fun_ty :: Type
    fun_ty = HasDebugCallStack => Type -> Type -> Type
    Type -> Type -> Type
    mkVisFunTyMany Type
    openAlphaTy Type
    openBetaTy
        [Id
    body, Id
    x] = [Type] -> [Id]
    mkTemplateLocals [Type
    fun_ty, Type
    openAlphaTy]
        x' :: Id
    x' = Id -> Id
    setOneShotLambda Id
    x  -- Here is the magic bit!
        rhs :: CoreExpr
    rhs = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [ Id
    runtimeRep1TyVar, Id
    runtimeRep2TyVar
                     , Id
    openAlphaTyVar, Id
    openBetaTyVar
                     , Id
    body, Id
    x'] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
              Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    body CoreExpr -> CoreExpr -> CoreExpr
    forall b. Expr b -> Expr b -> Expr b
    `App` Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    x'
        arity :: Int
    arity = Int
    2

        concs :: Name -> ConcreteTyVars
    concs = [((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
    mkRepPolyIdConcreteTyVars
            [((Type
    openAlphaTy, Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
    forall (p :: Polarity).
    Int -> Position (FlipPolarity p) -> Position p
    Argument Int
    2 Position (FlipPolarity 'Neg)
    Position 'Pos
    Top), Id
    runtimeRep1TyVar)]

    ----------------------------------------------------------------------
    {- Note [Wired-in Ids for rebindable syntax]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The functions leftSectionId, rightSectionId are
    wired in here ONLY because they are used in a representation-polymorphic way
    by the rebindable syntax mechanism. See GHC.Rename.Expr
    Note [Handling overloaded and rebindable constructs].

    Alas, we can't currently give Haskell definitions for
    representation-polymorphic functions.

    They have Compulsory unfoldings, so that the representation polymorphism
    does not linger for long.
    -}

    -- See Note [Left and right sections] in GHC.Rename.Expr
    -- See Note [Wired-in Ids for rebindable syntax]
    --   leftSection :: forall r1 r2 n (a::TYPE r1) (b::TYPE r2).
    --                  (a %n-> b) -> a %n-> b
    --   leftSection f x = f x
    -- Important that it is eta-expanded, so that (leftSection undefined `seq` ())
    --   is () and not undefined
    -- Important that is is multiplicity-polymorphic (test linear/should_compile/OldList)
    leftSectionId :: Id
    leftSectionId :: Id
    leftSectionId = Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
    pcRepPolyId Name
    leftSectionName Type
    ty Name -> ConcreteTyVars
    concs IdInfo
    info
      where
        info :: IdInfo
    info = IdInfo
    noCafIdInfo IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo` InlinePragma
    alwaysInlinePragma
                           IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`  CoreExpr -> Unfolding
    mkCompulsoryUnfolding CoreExpr
    rhs
                           IdInfo -> Int -> IdInfo
    `setArityInfo`      Int
    arity
        ty :: Type
    ty  = [Id] -> Type -> Type
    mkInfForAllTys  [Id
    runtimeRep1TyVar,Id
    runtimeRep2TyVar, Id
    multiplicityTyVar1] (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
              [Id] -> Type -> Type
    mkSpecForAllTys [Id
    openAlphaTyVar,  Id
    openBetaTyVar]    (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
              HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType CoreExpr
    body
        [Id
    f,Id
    x] = [Type] -> [Id]
    mkTemplateLocals [HasDebugCallStack => Type -> Type -> Type -> Type
    Type -> Type -> Type -> Type
    mkVisFunTy Type
    mult Type
    openAlphaTy Type
    openBetaTy, Type
    openAlphaTy]

        mult :: Type
    mult = Id -> Type
    mkTyVarTy Id
    multiplicityTyVar1 :: Mult
        xmult :: Id
    xmult = Id -> Type -> Id
    setIdMult Id
    x Type
    mult

        rhs :: CoreExpr
    rhs  = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [ Id
    runtimeRep1TyVar, Id
    runtimeRep2TyVar, Id
    multiplicityTyVar1
                      , Id
    openAlphaTyVar,   Id
    openBetaTyVar   ] CoreExpr
    body
        body :: CoreExpr
    body = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id
    f,Id
    xmult] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $ CoreExpr -> CoreExpr -> CoreExpr
    forall b. Expr b -> Expr b -> Expr b
    App (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    f) (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    xmult)
        arity :: Int
    arity = Int
    2

        concs :: Name -> ConcreteTyVars
    concs = [((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
    mkRepPolyIdConcreteTyVars
                [((Type
    openAlphaTy, Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
    forall (p :: Polarity).
    Int -> Position (FlipPolarity p) -> Position p
    Argument Int
    2 Position (FlipPolarity 'Neg)
    Position 'Pos
    Top), Id
    runtimeRep1TyVar)]

    -- See Note [Left and right sections] in GHC.Rename.Expr
    -- See Note [Wired-in Ids for rebindable syntax]
    --   rightSection :: forall r1 r2 r3 n1 n2 (a::TYPE r1) (b::TYPE r2) (c::TYPE r3).
    --                   (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c
    --   rightSection f y x = f x y
    -- Again, multiplicity polymorphism is important
    rightSectionId :: Id
    rightSectionId :: Id
    rightSectionId = Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
    pcRepPolyId Name
    rightSectionName Type
    ty Name -> ConcreteTyVars
    concs IdInfo
    info
      where
        info :: IdInfo
    info = IdInfo
    noCafIdInfo IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo` InlinePragma
    alwaysInlinePragma
                           IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`  CoreExpr -> Unfolding
    mkCompulsoryUnfolding CoreExpr
    rhs
                           IdInfo -> Int -> IdInfo
    `setArityInfo`      Int
    arity
        ty :: Type
    ty  = [Id] -> Type -> Type
    mkInfForAllTys  [Id
    runtimeRep1TyVar,Id
    runtimeRep2TyVar,Id
    runtimeRep3TyVar
                              , Id
    multiplicityTyVar1, Id
    multiplicityTyVar2 ] (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
              [Id] -> Type -> Type
    mkSpecForAllTys [Id
    openAlphaTyVar,  Id
    openBetaTyVar,   Id
    openGammaTyVar ]  (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
              HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType CoreExpr
    body
        mult1 :: Type
    mult1 = Id -> Type
    mkTyVarTy Id
    multiplicityTyVar1
        mult2 :: Type
    mult2 = Id -> Type
    mkTyVarTy Id
    multiplicityTyVar2

        [Id
    f,Id
    x,Id
    y] = [Type] -> [Id]
    mkTemplateLocals [ [Scaled Type] -> Type -> Type
    HasDebugCallStack => [Scaled Type] -> Type -> Type
    mkScaledFunTys [ Type -> Type -> Scaled Type
    forall a. Type -> a -> Scaled a
    Scaled Type
    mult1 Type
    openAlphaTy
                                                    , Type -> Type -> Scaled Type
    forall a. Type -> a -> Scaled a
    Scaled Type
    mult2 Type
    openBetaTy ] Type
    openGammaTy
                                   , Type
    openAlphaTy, Type
    openBetaTy ]
        xmult :: Id
    xmult = Id -> Type -> Id
    setIdMult Id
    x Type
    mult1
        ymult :: Id
    ymult = Id -> Type -> Id
    setIdMult Id
    y Type
    mult2
        rhs :: CoreExpr
    rhs  = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [ Id
    runtimeRep1TyVar, Id
    runtimeRep2TyVar, Id
    runtimeRep3TyVar
                      , Id
    multiplicityTyVar1, Id
    multiplicityTyVar2
                      , Id
    openAlphaTyVar,   Id
    openBetaTyVar,    Id
    openGammaTyVar ] CoreExpr
    body
        body :: CoreExpr
    body = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id
    f,Id
    ymult,Id
    xmult] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $ CoreExpr -> [Id] -> CoreExpr
    forall b. Expr b -> [Id] -> Expr b
    mkVarApps (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    f) [Id
    xmult,Id
    ymult]
        arity :: Int
    arity = Int
    3

        concs :: Name -> ConcreteTyVars
    concs =
          [((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
    mkRepPolyIdConcreteTyVars
            [ ((Type
    openAlphaTy, Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
    forall (p :: Polarity).
    Int -> Position (FlipPolarity p) -> Position p
    Argument Int
    3 Position (FlipPolarity 'Neg)
    Position 'Pos
    Top), Id
    runtimeRep1TyVar)
            , ((Type
    openBetaTy , Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
    forall (p :: Polarity).
    Int -> Position (FlipPolarity p) -> Position p
    Argument Int
    2 Position (FlipPolarity 'Neg)
    Position 'Pos
    Top), Id
    runtimeRep2TyVar)]

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

    coerceId :: Id
    coerceId :: Id
    coerceId = Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
    pcRepPolyId Name
    coerceName Type
    ty Name -> ConcreteTyVars
    concs IdInfo
    info
      where
        info :: IdInfo
    info = IdInfo
    noCafIdInfo IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo` InlinePragma
    alwaysInlinePragma
                           IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`  CoreExpr -> Unfolding
    mkCompulsoryUnfolding CoreExpr
    rhs
                           IdInfo -> Int -> IdInfo
    `setArityInfo`      Int
    2
        eqRTy :: Type
    eqRTy     = TyCon -> [Type] -> Type
    mkTyConApp TyCon
    coercibleTyCon  [ Type
    tYPE_r,         Type
    a, Type
    b ]
        eqRPrimTy :: Type
    eqRPrimTy = TyCon -> [Type] -> Type
    mkTyConApp TyCon
    eqReprPrimTyCon [ Type
    tYPE_r, Type
    tYPE_r, Type
    a, Type
    b ]
        ty :: Type
    ty        = [InvisTVBinder] -> Type -> Type
    mkInvisForAllTys [ Id -> Specificity -> InvisTVBinder
    forall var argf. var -> argf -> VarBndr var argf
    Bndr Id
    rv Specificity
    InferredSpec
                                     , Id -> Specificity -> InvisTVBinder
    forall var argf. var -> argf -> VarBndr var argf
    Bndr Id
    av Specificity
    SpecifiedSpec
                                     , Id -> Specificity -> InvisTVBinder
    forall var argf. var -> argf -> VarBndr var argf
    Bndr Id
    bv Specificity
    SpecifiedSpec ] (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
                    HasDebugCallStack => Type -> Type -> Type
    Type -> Type -> Type
    mkInvisFunTy Type
    eqRTy (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $
                    HasDebugCallStack => Type -> Type -> Type
    Type -> Type -> Type
    mkVisFunTyMany Type
    a Type
    b

        bndrs :: [Id]
    bndrs@[Id
    rv,Id
    av,Id
    bv] = Type -> (Type -> [Type]) -> [Id]
    mkTemplateKiTyVar Type
    runtimeRepTy
                            (\Type
    r -> [Type -> Type
    mkTYPEapp Type
    r, Type -> Type
    mkTYPEapp Type
    r])

        [Type
    r, Type
    a, Type
    b] = [Id] -> [Type]
    mkTyVarTys [Id]
    bndrs
        tYPE_r :: Type
    tYPE_r    = Type -> Type
    mkTYPEapp Type
    r

        [Id
    eqR,Id
    x,Id
    eq] = [Type] -> [Id]
    mkTemplateLocals [Type
    eqRTy, Type
    a, Type
    eqRPrimTy]
        rhs :: CoreExpr
    rhs = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams ([Id]
    bndrs [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++ [Id
    eqR, Id
    x]) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
              CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
    mkWildCase (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    eqR) (Type -> Scaled Type
    forall a. a -> Scaled a
    unrestricted Type
    eqRTy) Type
    b ([CoreAlt] -> CoreExpr) -> [CoreAlt] -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
              [AltCon -> [Id] -> CoreExpr -> CoreAlt
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt (DataCon -> AltCon
    DataAlt DataCon
    coercibleDataCon) [Id
    eq] (CoreExpr -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    Cast (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    x) (Id -> Coercion
    mkCoVarCo Id
    eq))]

        concs :: Name -> ConcreteTyVars
    concs = [((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
    mkRepPolyIdConcreteTyVars
                [((Id -> Type
    mkTyVarTy Id
    av, Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
    forall (p :: Polarity).
    Int -> Position (FlipPolarity p) -> Position p
    Argument Int
    1 Position (FlipPolarity 'Neg)
    Position 'Pos
    Top), Id
    rv)]

    {-
    Note [seqId magic]
    ~~~~~~~~~~~~~~~~~~
    'GHC.Prim.seq' is special in several ways.

    a) Its fixity is set in GHC.Iface.Load.ghcPrimIface

    b) It has quite a bit of desugaring magic.
       See GHC.HsToCore.Utils Note [Desugaring seq] (1) and (2) and (3)

    c) There is some special rule handing: Note [User-defined RULES for seq]

    Historical note:
        In GHC.Tc.Gen.Expr we used to need a special typing rule for 'seq', to handle calls
        whose second argument had an unboxed type, e.g.  x `seq` 3#

        However, with representation polymorphism we can now give seq the type
        seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b
        which handles this case without special treatment in the typechecker.

    Note [User-defined RULES for seq]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Roman found situations where he had
          case (f n) of _ -> e
    where he knew that f (which was strict in n) would terminate if n did.
    Notice that the result of (f n) is discarded. So it makes sense to
    transform to
          case n of _ -> e

    Rather than attempt some general analysis to support this, I've added
    enough support that you can do this using a rewrite rule:

      RULE "f/seq" forall n.  seq (f n) = seq n

    You write that rule.  When GHC sees a case expression that discards
    its result, it mentally transforms it to a call to 'seq' and looks for
    a RULE.  (This is done in GHC.Core.Opt.Simplify.trySeqRules.)  As usual, the
    correctness of the rule is up to you.

    VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2.
    If we wrote
      RULE "f/seq" forall n e.  seq (f n) e = seq n e
    with rule arity 2, then two bad things would happen:

      - The magical desugaring done in Note [seqId magic] item (b)
        for saturated application of 'seq' would turn the LHS into
        a case expression!

      - The code in GHC.Core.Opt.Simplify.rebuildCase would need to actually supply
        the value argument, which turns out to be awkward.

    See also: Note [User-defined RULES for seq] in GHC.Core.Opt.Simplify.

    Note [lazyId magic]
    ~~~~~~~~~~~~~~~~~~~
    lazy :: forall a. a -> a

    'lazy' is used to make sure that a sub-expression, and its free variables,
    are truly used call-by-need, with no code motion.  Key examples:

    * pseq:    pseq a b = a `seq` lazy b
      We want to make sure that the free vars of 'b' are not evaluated
      before 'a', even though the expression is plainly strict in 'b'.

    * catch:   catch a b = catch# (lazy a) b
      Again, it's clear that 'a' will be evaluated strictly (and indeed
      applied to a state token) but we want to make sure that any exceptions
      arising from the evaluation of 'a' are caught by the catch (see
      #11555).

    Implementing 'lazy' is a bit tricky:

    * It must not have a strictness signature: by being a built-in Id,
      all the info about lazyId comes from here, not from GHC.Magic.hi.
      This is important, because the strictness analyser will spot it as
      strict!

    * It must not have an unfolding: it gets "inlined" by a HACK in
      CorePrep. It's very important to do this inlining *after* unfoldings
      are exposed in the interface file.  Otherwise, the unfolding for
      (say) pseq in the interface file will not mention 'lazy', so if we
      inline 'pseq' we'll totally miss the very thing that 'lazy' was
      there for in the first place. See #3259 for a real world
      example.

    * Suppose CorePrep sees (catch# (lazy e) b).  At all costs we must
      avoid using call by value here:
         case e of r -> catch# r b
      Avoiding that is the whole point of 'lazy'.  So in CorePrep (which
      generate the 'case' expression for a call-by-value call) we must
      spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let'
      instead.

    * lazyId is defined in GHC.Base, so we don't *have* to inline it.  If it
      appears un-applied, we'll end up just calling it.

    Note [noinlineId magic]
    ~~~~~~~~~~~~~~~~~~~~~~~
    'noinline' is used to make sure that a function f is never inlined,
    e.g., as in 'noinline f x'.  We won't inline f because we never inline
    lone variables (see Note [Lone variables] in GHC.Core.Unfold

    You might think that we could implement noinline like this:
       {-# NOINLINE #-}
       noinline :: forall a. a -> a
       noinline x = x

    But actually we give 'noinline' a wired-in name for three distinct reasons:

    1. We don't want to leave a (useless) call to noinline in the final program,
       to be executed at runtime. So we have a little bit of magic to
       optimize away 'noinline' after we are done running the simplifier.
       This is done in GHC.CoreToStg.Prep.cpeApp.

    2. 'noinline' sometimes gets inserted automatically when we serialize an
       expression to the interface format, in GHC.CoreToIface.toIfaceVar.
       See Note [Inlining and hs-boot files] in GHC.CoreToIface

    3. Given foo :: Eq a => [a] -> Bool, the expression
         noinline foo x xs
       where x::Int, will naturally desugar to
          noinline @Int (foo @Int dEqInt) x xs
       But now it's entirely possible that (foo @Int dEqInt) will inline foo,
       since 'foo' is no longer a lone variable -- see #18995

       Solution: in the desugarer, rewrite
          noinline (f x y)  ==>  noinline f x y
       This is done in GHC.HsToCore.Utils.mkCoreAppDs.
       This is only needed for noinlineId, not noInlineConstraintId (wrinkle
       (W1) below), because the latter never shows up in user code.

    Wrinkles

    (W1) Sometimes case (2) above needs to apply `noinline` to a type of kind
         Constraint; e.g.
                        noinline @(Eq Int) $dfEqInt
         We don't have type-or-kind polymorphism, so we simply have two `inline`
         Ids, namely `noinlineId` and `noinlineConstraintId`.

    (W2) Note that noinline as currently implemented can hide some simplifications
         since it hides strictness from the demand analyser. Specifically, the
         demand analyser will treat 'noinline f x' as lazy in 'x', even if the
         demand signature of 'f' specifies that it is strict in its argument. We
         considered fixing this this by adding a special case to the demand
         analyser to address #16588. However, the special case seemed like a large
         and expensive hammer to address a rare case and consequently we rather
         opted to use a more minimal solution.

    Note [nospecId magic]
    ~~~~~~~~~~~~~~~~~~~~~
    The 'nospec' magic Id is used to ensure to make a value opaque to the typeclass
    specialiser. In CorePrep, we inline 'nospec', turning (nospec e) into e.
    Note that this happens *after* unfoldings are exposed in the interface file.
    This is crucial: otherwise, we could import an unfolding in which
    'nospec' has been inlined (= erased), and we would lose the benefit.

    'nospec' is used:

    * In the implementation of 'withDict': we insert 'nospec' so that the
      typeclass specialiser doesn't assume any two evidence terms of the
      same type are equal. See Note [withDict] in GHC.Tc.Instance.Class,
      and see test case T21575b for an example.

    * To defeat the specialiser when we have incoherent instances.
      See Note [Coherence and specialisation: overview] in GHC.Core.InstEnv.

    Note [seq# magic]
    ~~~~~~~~~~~~~~~~~
    The purpose of the magic Id (See Note [magicIds])

      seq# :: forall a s . a -> State# s -> (# State# s, a #)

    is to elevate evaluation of its argument `a` into an observable side effect.
    This implies that GHC's optimisations must preserve the evaluation "exactly
    here", in the state thread.

    The main use of seq# is to implement `evaluate`

       evaluate :: a -> IO a
       evaluate a = IO $ \s -> seq# a s

    Its (NOINLINE) definition in GHC.Magic is simply

       seq# a s = let !a' = lazy a in (# s, a' #)

    Things to note

    (SEQ1)
      It must be NOINLINE, because otherwise the eval !a' would be decoupled from
      the state token s, and GHC's optimisations, in particular strictness analysis,
      would happily move the eval around.

      However, we *do* inline saturated applications of seq# in CorePrep, where
      evaluation order is fixed; see the implementation notes below.
      This is one reason why we need seq# to be known-key.

    (SEQ2)
      The use of `lazy` ensures that strictness analysis does not see the eval
      that takes place, so the final demand signature is <L><L>, not <1L><L>.
      This is important for a definition like

        foo x y = evaluate y >> evaluate x

      Although both y and x are ultimately evaluated, the user made it clear
      they want to evaluate y *before* x.
      But if strictness analysis sees the evals, it infers foo as strict in
      both parameters. This strictness would be exploited in the backend by
      picking a call-by-value calling convention for foo, one that would evaluate
      x *before* y. Nononono!

      Because the definition of seq# uses `lazy`, it must live in a different module
      (GHC.Internal.IO); otherwise strictness analysis uses its own strictness
      signature for the definition of `lazy` instead of the one we wire in.

    (SEQ3)
      Why does seq# return the value? Consider
         let x = e in
         case seq# x s of (# _, x' #) -> ... x' ... case x' of __DEFAULT -> ...
      Here, we could simply use x instead of x', but doing so would
      introduce an unnecessary indirection and tag check at runtime;
      also we can attach an evaldUnfolding to x' to discard any
      subsequent evals such as the `case x' of __DEFAULT`.

    (SEQ4)
      T15226 demonstrates that we want to discard ok-for-discard seq#s. That is,
      simplify `case seq# <ok-to-discard> s of (# s', _ #) -> rhs[s']` to `rhs[s]`.
      You might wonder whether the Simplifier could do this. But see the excellent
      example in #24334 (immortalised as test T24334) for why it should be done in
      CorePrep.

    Implementing seq#.  The compiler has magic for `seq#` in

    - GHC.CoreToStg.Prep.cpeRhsE: Implement (SEQ4).

    - Simplify.addEvals records evaluated-ness for the result (cf. (SEQ3)); see
      Note [Adding evaluatedness info to pattern-bound variables]
      in GHC.Core.Opt.Simplify.Iteration

    - GHC.Core.Opt.DmdAnal.exprMayThrowPreciseException:
      Historically, seq# used to be a primop, and the majority of primops
      should return False in exprMayThrowPreciseException, so we do the same
      for seq# for back compat.

    - GHC.CoreToStg.Prep: Inline saturated applications to a Case, e.g.,

        seq# (f 13) s
        ==>
        case f 13 of sat of __DEFAULT -> (# s, sat #)

      This is implemented in `cpeApp`, not unlike Note [runRW magic].
      We are only inlining seq#, leaving opportunities for case-of-known-con
      behind that are easily picked up by Unarise:

        case seq# f 13 s of (# s', r #) -> rhs
        ==> {Prep}
        case f 13 of sat of __DEFAULT -> case (# s, sat #) of (# s', r #) -> rhs
        ==> {Unarise}
        case f 13 of sat of __DEFAULT -> rhs[s/s',sat/r]

      Note that CorePrep really allocates a CaseBound FloatingBind for `f 13`.
      That's OK, because the telescope of Floats always stays in the same order
      and won't be floated out of binders, so all guarantees of evaluation order
      provided by seq# are upheld.

    Note [oneShot magic]
    ~~~~~~~~~~~~~~~~~~~~
    In the context of making left-folds fuse somewhat okish (see ticket #7994
    and Note [Left folds via right fold]) it was determined that it would be useful
    if library authors could explicitly tell the compiler that a certain lambda is
    called at most once. The oneShot function allows that.

    'oneShot' is representation-polymorphic, i.e. the type variables can refer
    to unlifted types as well (#10744); e.g.
       oneShot (\x:Int# -> x +# 1#)

    Like most magic functions it has a compulsory unfolding, so there is no need
    for a real definition somewhere. We have one in GHC.Magic for the convenience
    of putting the documentation there.

    It uses `setOneShotLambda` on the lambda's binder. That is the whole magic:

    A typical call looks like
         oneShot (\y. e)
    after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get
         (\f \x[oneshot]. f x) (\y. e)
     --> \x[oneshot]. ((\y.e) x)
     --> \x[oneshot] e[x/y]
    which is what we want.

    Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot.

    Wrinkles:
    (OS1)  It is only effective if the one-shot info survives as long as possible; in
           particular it must make it into the interface in unfoldings. See Note [Preserve
           OneShotInfo] in GHC.Core.Tidy.

    (OS2) (oneShot (error "urk")) rewrites to
               \x[oneshot]. error "urk" x
          thereby hiding the `error` under a lambda, which might be surprising,
          particularly if you have `-fpedantic-bottoms` on.  See #24296.

    -------------------------------------------------------------
    @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
    nasty as-is, change it back to a literal (@Literal@).

    voidArgId is a Local Id used simply as an argument in functions
    where we just want an arg to avoid having a thunk of unlifted type.
    E.g.
            x = \ void :: Void# -> (# p, q #)

    This comes up in strictness analysis

    Note [evaldUnfoldings]
    ~~~~~~~~~~~~~~~~~~~~~~
    The evaldUnfolding makes it look that some primitive value is
    evaluated, which in turn makes Simplify.interestingArg return True,
    which in turn makes INLINE things applied to said value likely to be
    inlined.
    -}

    realWorldPrimId :: Id   -- :: State# RealWorld
    realWorldPrimId :: Id
    realWorldPrimId = Name -> Type -> IdInfo -> Id
    pcMiscPrelId Name
    realWorldName Type
    id_ty
                         (IdInfo
    noCafIdInfo IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo` Unfolding
    evaldUnfolding    -- Note [evaldUnfoldings]
                                      IdInfo -> OneShotInfo -> IdInfo
    `setOneShotInfo`   Type -> OneShotInfo
    typeOneShot Type
    id_ty)
       where
         id_ty :: Type
    id_ty = Type
    realWorldStatePrimTy

    voidPrimId :: Id     -- Global constant :: Void#
                         -- The type Void# is now the same as (# #) (ticket #18441),
                         -- this identifier just signifies the (# #) datacon
                         -- and is kept for backwards compatibility.
                         -- We cannot define it in normal Haskell, since it's
                         -- a top-level unlifted value.
    voidPrimId :: Id
    voidPrimId  = Name -> Type -> IdInfo -> Id
    pcMiscPrelId Name
    voidPrimIdName Type
    unboxedUnitTy
                    (IdInfo
    noCafIdInfo IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo` CoreExpr -> Unfolding
    mkCompulsoryUnfolding CoreExpr
    unboxedUnitExpr)

    unboxedUnitExpr :: CoreExpr
    unboxedUnitExpr :: CoreExpr
    unboxedUnitExpr = Id -> CoreExpr
    forall b. Id -> Expr b
    Var (DataCon -> Id
    dataConWorkId DataCon
    unboxedUnitDataCon)

    voidArgId :: Id       -- Local lambda-bound :: Void#
    voidArgId :: Id
    voidArgId = RuleName -> Unique -> Type -> Type -> Id
    mkSysLocal (String -> RuleName
    fsLit String
    "void") Unique
    voidArgIdKey Type
    ManyTy Type
    unboxedUnitTy

    coercionTokenId :: Id         -- :: () ~# ()
    coercionTokenId :: Id
    coercionTokenId -- See Note [Coercion tokens] in "GHC.CoreToStg"
      = Name -> Type -> IdInfo -> Id
    pcMiscPrelId Name
    coercionTokenName
                     (TyCon -> [Type] -> Type
    mkTyConApp TyCon
    eqPrimTyCon [Type
    liftedTypeKind, Type
    liftedTypeKind, Type
    unitTy, Type
    unitTy])
                     IdInfo
    noCafIdInfo

    pcMiscPrelId :: Name -> Type -> IdInfo -> Id
    pcMiscPrelId :: Name -> Type -> IdInfo -> Id
    pcMiscPrelId Name
    name Type
    ty IdInfo
    info
      = HasDebugCallStack => Name -> Type -> IdInfo -> Id
    Name -> Type -> IdInfo -> Id
    mkVanillaGlobalWithInfo Name
    name Type
    ty IdInfo
    info

    pcRepPolyId :: Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
    pcRepPolyId :: Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
    pcRepPolyId Name
    name Type
    ty Name -> ConcreteTyVars
    conc_tvs IdInfo
    info =
      IdDetails -> Name -> Type -> IdInfo -> Id
    mkGlobalId (ConcreteTyVars -> IdDetails
    RepPolyId (ConcreteTyVars -> IdDetails) -> ConcreteTyVars -> IdDetails
    forall a b. (a -> b) -> a -> b
    $ Name -> ConcreteTyVars
    conc_tvs Name
    name) Name
    name Type
    ty IdInfo
    info

    -- | Directly specify which outer forall'd type variables of a
    -- representation-polymorphic 'Id' such become concrete metavariables when
    -- instantiated.
    mkRepPolyIdConcreteTyVars :: [((Type, Position Neg), TyVar)]
                                   -- ^ ((ty, pos), tv)
                                   -- 'ty' is the type on which the representation-polymorphism
                                   -- check is done
                                   -- 'tv' is the type variable we are checking for concreteness
                                   -- (usually the kind of 'ty')
                                   -- 'pos' is the position of 'ty' in the
                                   -- type of the 'Id'
                              -> Name -- ^ 'Name' of the rep-poly 'Id'
                              -> ConcreteTyVars
    mkRepPolyIdConcreteTyVars :: [((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
    mkRepPolyIdConcreteTyVars [((Type, Position 'Neg), Id)]
    vars Name
    nm =
      [(Name, ConcreteTvOrigin)] -> ConcreteTyVars
    forall a. [(Name, a)] -> NameEnv a
    mkNameEnv [ (Id -> Name
    tyVarName Id
    tv, Type -> Position 'Neg -> ConcreteTvOrigin
    mk_conc_frr Type
    ty Position 'Neg
    pos)
                | ((Type
    ty,Position 'Neg
    pos), Id
    tv) <- [((Type, Position 'Neg), Id)]
    vars ]
      where
        mk_conc_frr :: Type -> Position 'Neg -> ConcreteTvOrigin
    mk_conc_frr Type
    ty Position 'Neg
    pos =
          FixedRuntimeRepOrigin -> ConcreteTvOrigin
    ConcreteFRR (FixedRuntimeRepOrigin -> ConcreteTvOrigin)
    -> FixedRuntimeRepOrigin -> ConcreteTvOrigin
    forall a b. (a -> b) -> a -> b
    $ Type -> FixedRuntimeRepContext -> FixedRuntimeRepOrigin
    FixedRuntimeRepOrigin Type
    ty
                      (FixedRuntimeRepContext -> FixedRuntimeRepOrigin)
    -> FixedRuntimeRepContext -> FixedRuntimeRepOrigin
    forall a b. (a -> b) -> a -> b
    $ Name -> RepPolyId -> Position 'Neg -> FixedRuntimeRepContext
    FRRRepPolyId Name
    nm RepPolyId
    RepPolyFunction Position 'Neg
    pos