    {-# LANGUAGE CPP                        #-}
    {-# LANGUAGE DeriveFunctor              #-}
    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE RecordWildCards            #-}

    {-# OPTIONS_GHC -fprof-auto-top #-}
    {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

    --
    --  (c) The University of Glasgow 2002-2006
    --

    -- | GHC.StgToByteCode: Generate bytecode from STG
    module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Driver.Session
    import GHC.Driver.Env

    import GHC.ByteCode.Instr
    import GHC.ByteCode.Asm
    import GHC.ByteCode.Types

    import GHC.Cmm.CallConv
    import GHC.Cmm.Expr
    import GHC.Cmm.Node
    import GHC.Cmm.Utils

    import GHC.Platform
    import GHC.Platform.Profile

    import GHC.Runtime.Interpreter
    import GHCi.FFI
    import GHCi.RemoteTypes
    import GHC.Types.Basic
    import GHC.Utils.Outputable
    import GHC.Types.Name
    import GHC.Types.Id.Make
    import GHC.Types.Id
    import GHC.Types.ForeignCall
    import GHC.Core
    import GHC.Types.Literal
    import GHC.Builtin.PrimOps
    import GHC.Core.Type
    import GHC.Types.RepType
    import GHC.Core.DataCon
    import GHC.Core.TyCon
    import GHC.Utils.Misc
    import GHC.Utils.Logger
    import GHC.Types.Var.Set
    import GHC.Builtin.Types ( unboxedUnitTy )
    import GHC.Builtin.Types.Prim
    import GHC.Core.TyCo.Ppr ( pprType )
    import GHC.Utils.Error
    import GHC.Types.Unique
    import GHC.Builtin.Uniques
    import GHC.Builtin.Utils ( primOpId )
    import GHC.Data.FastString
    import GHC.Utils.Panic
    import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )
    import GHC.StgToCmm.Layout
    import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
    import GHC.Data.Bitmap
    import GHC.Data.OrdList
    import GHC.Data.Maybe
    import GHC.Types.Var.Env
    import GHC.Types.Tickish

    import Data.List ( genericReplicate, genericLength, intersperse
                     , partition, scanl', sortBy, zip4, zip6 )
    import Foreign hiding (shiftL, shiftR)
    import Control.Monad
    import Data.Char

    import GHC.Types.Unique.Supply
    import GHC.Unit.Module

    import Control.Exception
    import Data.Array
    import Data.Coerce (coerce)
    import Data.ByteString (ByteString)
    import Data.Map (Map)
    import Data.IntMap (IntMap)
    import qualified Data.Map as Map
    import qualified Data.IntMap as IntMap
    import qualified GHC.Data.FiniteMap as Map
    import Data.Ord
    import GHC.Stack.CCS
    import Data.Either ( partitionEithers )

    import qualified GHC.Types.CostCentre as CC
    import GHC.Stg.Syntax
    import GHC.Stg.FVs
    import qualified Data.IntSet as IntSet

    -- -----------------------------------------------------------------------------
    -- Generating byte code for a complete module

    byteCodeGen :: HscEnv
                -> Module
                -> [StgTopBinding]
                -> [TyCon]
                -> Maybe ModBreaks
                -> IO CompiledByteCode
    byteCodeGen :: HscEnv
    -> Module
    -> [StgTopBinding]
    -> [TyCon]
    -> Maybe ModBreaks
    -> IO CompiledByteCode
    byteCodeGen HscEnv
    hsc_env Module
    this_mod [StgTopBinding]
    binds [TyCon]
    tycs Maybe ModBreaks
    mb_modBreaks
       = forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
    withTiming Logger
    logger DynFlags
    dflags
                    (String -> SDoc
    text String
    "GHC.StgToByteCode"SDoc -> SDoc -> SDoc
    <+>SDoc -> SDoc
    brackets (forall a. Outputable a => a -> SDoc
    ppr Module
    this_mod))
                    (forall a b. a -> b -> a
    const ()) forall a b. (a -> b) -> a -> b
    $ do
            -- Split top-level binds into strings and others.
            -- See Note [generating code for top-level string literal bindings].
            let ([(Id, ByteString)]
    strings, [GenStgBinding 'Vanilla]
    lifted_binds) = forall a b. [Either a b] -> ([a], [b])
    partitionEithers forall a b. (a -> b) -> a -> b
    $ do  -- list monad
                    StgTopBinding
    bnd <- [StgTopBinding]
    binds
                    case StgTopBinding
    bnd of
                      StgTopLifted GenStgBinding 'Vanilla
    bnd      -> [forall a b. b -> Either a b
    Right GenStgBinding 'Vanilla
    bnd]
                      StgTopStringLit Id
    b ByteString
    str -> [forall a b. a -> Either a b
    Left (Id
    b, ByteString
    str)]
                flattenBind :: GenStgBinding pass -> [(BinderP pass, GenStgRhs pass)]
    flattenBind (StgNonRec BinderP pass
    b GenStgRhs pass
    e) = [(BinderP pass
    b,GenStgRhs pass
    e)]
                flattenBind (StgRec [(BinderP pass, GenStgRhs pass)]
    bs)     = [(BinderP pass, GenStgRhs pass)]
    bs
            [(Id, RemotePtr ())]
    stringPtrs <- Interp -> [(Id, ByteString)] -> IO [(Id, RemotePtr ())]
    allocateTopStrings Interp
    interp [(Id, ByteString)]
    strings

            UniqSupply
    us <- Char -> IO UniqSupply
    mkSplitUniqSupply Char
    'y'
            (BcM_State{[FFIInfo]
    Maybe ModBreaks
    Word32
    IntMap CgBreakInfo
    Module
    UniqSupply
    IdEnv (RemotePtr ())
    HscEnv
    topStrings :: BcM_State -> IdEnv (RemotePtr ())
    breakInfo :: BcM_State -> IntMap CgBreakInfo
    modBreaks :: BcM_State -> Maybe ModBreaks
    ffis :: BcM_State -> [FFIInfo]
    nextlabel :: BcM_State -> Word32
    thisModule :: BcM_State -> Module
    uniqSupply :: BcM_State -> UniqSupply
    bcm_hsc_env :: BcM_State -> HscEnv
    topStrings :: IdEnv (RemotePtr ())
    breakInfo :: IntMap CgBreakInfo
    modBreaks :: Maybe ModBreaks
    ffis :: [FFIInfo]
    nextlabel :: Word32
    thisModule :: Module
    uniqSupply :: UniqSupply
    bcm_hsc_env :: HscEnv
    ..}, [ProtoBCO Name]
    proto_bcos) <-
               forall r.
    HscEnv
    -> UniqSupply
    -> Module
    -> Maybe ModBreaks
    -> IdEnv (RemotePtr ())
    -> BcM r
    -> IO (BcM_State, r)
    runBc HscEnv
    hsc_env UniqSupply
    us Module
    this_mod Maybe ModBreaks
    mb_modBreaks (forall a. [(Id, a)] -> VarEnv a
    mkVarEnv [(Id, RemotePtr ())]
    stringPtrs) forall a b. (a -> b) -> a -> b
    $ do
                 [GenStgBinding 'Vanilla]
    prepd_binds <- forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla)
    bcPrepBind [GenStgBinding 'Vanilla]
    lifted_binds
                 let flattened_binds :: [(Id, CgStgRhs)]
    flattened_binds =
                       forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (forall {pass :: StgPass}.
    GenStgBinding pass -> [(BinderP pass, GenStgRhs pass)]
    flattenBind forall b c a. (b -> c) -> (a -> b) -> a -> c
    . GenStgBinding 'Vanilla -> CgStgBinding
    annBindingFreeVars) (forall a. [a] -> [a]
    reverse [GenStgBinding 'Vanilla]
    prepd_binds)
                 forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (Id, CgStgRhs) -> BcM (ProtoBCO Name)
    schemeTopBind [(Id, CgStgRhs)]
    flattened_binds

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (forall (f :: * -> *) a. Foldable f => f a -> Bool
    notNull [FFIInfo]
    ffis)
                 (forall a. String -> a
    panic String
    "GHC.StgToByteCode.byteCodeGen: missing final emitBc?")

            Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger DynFlags
    dflags DumpFlag
    Opt_D_dump_BCOs
               String
    "Proto-BCOs" DumpFormat
    FormatByteCode
               ([SDoc] -> SDoc
    vcat (forall a. a -> [a] -> [a]
    intersperse (Char -> SDoc
    char Char
    ' ') (forall a b. (a -> b) -> [a] -> [b]
    map forall a. Outputable a => a -> SDoc
    ppr [ProtoBCO Name]
    proto_bcos)))

            CompiledByteCode
    cbc <- Interp
    -> Profile
    -> [ProtoBCO Name]
    -> [TyCon]
    -> [RemotePtr ()]
    -> Maybe ModBreaks
    -> IO CompiledByteCode
    assembleBCOs Interp
    interp Profile
    profile [ProtoBCO Name]
    proto_bcos [TyCon]
    tycs (forall a b. (a -> b) -> [a] -> [b]
    map forall a b. (a, b) -> b
    snd [(Id, RemotePtr ())]
    stringPtrs)
              (case Maybe ModBreaks
    modBreaks of
                 Maybe ModBreaks
    Nothing -> forall a. Maybe a
    Nothing
                 Just ModBreaks
    mb -> forall a. a -> Maybe a
    Just ModBreaks
    mb{ modBreaks_breakInfo :: IntMap CgBreakInfo
    modBreaks_breakInfo = IntMap CgBreakInfo
    breakInfo })

            -- Squash space leaks in the CompiledByteCode.  This is really
            -- important, because when loading a set of modules into GHCi
            -- we don't touch the CompiledByteCode until the end when we
            -- do linking.  Forcing out the thunks here reduces space
            -- usage by more than 50% when loading a large number of
            -- modules.
            forall a. a -> IO a
    evaluate (CompiledByteCode -> ()
    seqCompiledByteCode CompiledByteCode
    cbc)

            forall (m :: * -> *) a. Monad m => a -> m a
    return CompiledByteCode
    cbc

      where dflags :: DynFlags
    dflags = HscEnv -> DynFlags
    hsc_dflags HscEnv
    hsc_env
            logger :: Logger
    logger = HscEnv -> Logger
    hsc_logger HscEnv
    hsc_env
            interp :: Interp
    interp  = HscEnv -> Interp
    hscInterp HscEnv
    hsc_env
            profile :: Profile
    profile = DynFlags -> Profile
    targetProfile DynFlags
    dflags

    allocateTopStrings
      :: Interp
      -> [(Id, ByteString)]
      -> IO [(Var, RemotePtr ())]
    allocateTopStrings :: Interp -> [(Id, ByteString)] -> IO [(Id, RemotePtr ())]
    allocateTopStrings Interp
    interp [(Id, ByteString)]
    topStrings = do
      let !([Id]
    bndrs, [ByteString]
    strings) = forall a b. [(a, b)] -> ([a], [b])
    unzip [(Id, ByteString)]
    topStrings
      [RemotePtr ()]
    ptrs <- forall a. Binary a => Interp -> Message a -> IO a
    interpCmd Interp
    interp forall a b. (a -> b) -> a -> b
    $ [ByteString] -> Message [RemotePtr ()]
    MallocStrings [ByteString]
    strings
      forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ forall a b. [a] -> [b] -> [(a, b)]
    zip [Id]
    bndrs [RemotePtr ()]
    ptrs

    {-
    Note [generating code for top-level string literal bindings]

    Here is a summary on how the byte code generator deals with top-level string
    literals:

    1. Top-level string literal bindings are separated from the rest of the module.

    2. The strings are allocated via interpCmd, in allocateTopStrings

    3. The mapping from binders to allocated strings (topStrings) are maintained in
       BcM and used when generating code for variable references.
    -}

    {-
      Prepare the STG for bytecode generation:

       - Ensure that all breakpoints are directly under
            a let-binding, introducing a new binding for
            those that aren't already.

       - Protect Not-necessarily lifted join points, see
            Note [Not-necessarily-lifted join points]

     -}

    bcPrepRHS :: StgRhs -> BcM StgRhs
    -- explicitly match all constructors so we get a warning if we miss any
    bcPrepRHS :: StgRhs -> BcM StgRhs
    bcPrepRHS (StgRhsClosure XRhsClosure 'Vanilla
    fvs CostCentreStack
    cc UpdateFlag
    upd [BinderP 'Vanilla]
    args (StgTick bp :: StgTickish
    bp@Breakpoint{} GenStgExpr 'Vanilla
    expr)) = do
      {- If we have a breakpoint directly under an StgRhsClosure we don't
         need to introduce a new binding for it.
       -}
      GenStgExpr 'Vanilla
    expr' <- GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
    bcPrepExpr GenStgExpr 'Vanilla
    expr
      forall (f :: * -> *) a. Applicative f => a -> f a
    pure (forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure XRhsClosure 'Vanilla
    fvs CostCentreStack
    cc UpdateFlag
    upd [BinderP 'Vanilla]
    args (forall (pass :: StgPass).
    StgTickish -> GenStgExpr pass -> GenStgExpr pass
    StgTick StgTickish
    bp GenStgExpr 'Vanilla
    expr'))
    bcPrepRHS (StgRhsClosure XRhsClosure 'Vanilla
    fvs CostCentreStack
    cc UpdateFlag
    upd [BinderP 'Vanilla]
    args GenStgExpr 'Vanilla
    expr) =
      forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure XRhsClosure 'Vanilla
    fvs CostCentreStack
    cc UpdateFlag
    upd [BinderP 'Vanilla]
    args forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
    bcPrepExpr GenStgExpr 'Vanilla
    expr
    bcPrepRHS con :: StgRhs
    con@StgRhsCon{} = forall (f :: * -> *) a. Applicative f => a -> f a
    pure StgRhs
    con

    bcPrepExpr :: StgExpr -> BcM StgExpr
    -- explicitly match all constructors so we get a warning if we miss any
    bcPrepExpr :: GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
    bcPrepExpr (StgTick bp :: StgTickish
    bp@(Breakpoint XBreakpoint 'TickishPassStg
    tick_ty Int
    _ [XTickishId 'TickishPassStg]
    _) GenStgExpr 'Vanilla
    rhs)
      | Kind -> Bool
    isLiftedTypeKind (HasDebugCallStack => Kind -> Kind
    typeKind XBreakpoint 'TickishPassStg
    tick_ty) = do
          Id
    id <- Kind -> BcM Id
    newId XBreakpoint 'TickishPassStg
    tick_ty
          GenStgExpr 'Vanilla
    rhs' <- GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
    bcPrepExpr GenStgExpr 'Vanilla
    rhs
          let expr' :: GenStgExpr 'Vanilla
    expr' = forall (pass :: StgPass).
    StgTickish -> GenStgExpr pass -> GenStgExpr pass
    StgTick StgTickish
    bp GenStgExpr 'Vanilla
    rhs'
              bnd :: GenStgBinding 'Vanilla
    bnd = forall (pass :: StgPass).
    BinderP pass -> GenStgRhs pass -> GenStgBinding pass
    StgNonRec Id
    id (forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure NoExtFieldSilent
    noExtFieldSilent
                                                CostCentreStack
    CC.dontCareCCS
                                                UpdateFlag
    ReEntrant
                                                []
                                                GenStgExpr 'Vanilla
    expr'
                                 )
              letExp :: GenStgExpr 'Vanilla
    letExp = forall (pass :: StgPass).
    XLet pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLet NoExtFieldSilent
    noExtFieldSilent GenStgBinding 'Vanilla
    bnd (forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
    StgApp Id
    id [])
          forall (f :: * -> *) a. Applicative f => a -> f a
    pure GenStgExpr 'Vanilla
    letExp
      | Bool
    otherwise = do
          Id
    id <- Kind -> BcM Id
    newId (Kind -> Kind -> Kind
    mkVisFunTyMany Kind
    realWorldStatePrimTy XBreakpoint 'TickishPassStg
    tick_ty)
          Id
    st <- Kind -> BcM Id
    newId Kind
    realWorldStatePrimTy
          GenStgExpr 'Vanilla
    rhs' <- GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
    bcPrepExpr GenStgExpr 'Vanilla
    rhs
          let expr' :: GenStgExpr 'Vanilla
    expr' = forall (pass :: StgPass).
    StgTickish -> GenStgExpr pass -> GenStgExpr pass
    StgTick StgTickish
    bp GenStgExpr 'Vanilla
    rhs'
              bnd :: GenStgBinding 'Vanilla
    bnd = forall (pass :: StgPass).
    BinderP pass -> GenStgRhs pass -> GenStgBinding pass
    StgNonRec Id
    id (forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure NoExtFieldSilent
    noExtFieldSilent
                                                CostCentreStack
    CC.dontCareCCS
                                                UpdateFlag
    ReEntrant
                                                [Id
    voidArgId]
                                                GenStgExpr 'Vanilla
    expr'
                                 )
          forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ forall (pass :: StgPass).
    XLet pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLet NoExtFieldSilent
    noExtFieldSilent GenStgBinding 'Vanilla
    bnd (forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
    StgApp Id
    id [Id -> StgArg
    StgVarArg Id
    st])
    bcPrepExpr (StgTick StgTickish
    tick GenStgExpr 'Vanilla
    rhs) =
      forall (pass :: StgPass).
    StgTickish -> GenStgExpr pass -> GenStgExpr pass
    StgTick StgTickish
    tick forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
    bcPrepExpr GenStgExpr 'Vanilla
    rhs
    bcPrepExpr (StgLet XLet 'Vanilla
    xlet GenStgBinding 'Vanilla
    bnds GenStgExpr 'Vanilla
    expr) =
      forall (pass :: StgPass).
    XLet pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLet XLet 'Vanilla
    xlet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla)
    bcPrepBind GenStgBinding 'Vanilla
    bnds
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
    bcPrepExpr GenStgExpr 'Vanilla
    expr
    bcPrepExpr (StgLetNoEscape XLetNoEscape 'Vanilla
    xlne GenStgBinding 'Vanilla
    bnds GenStgExpr 'Vanilla
    expr) =
      forall (pass :: StgPass).
    XLet pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLet XLetNoEscape 'Vanilla
    xlne forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla)
    bcPrepBind GenStgBinding 'Vanilla
    bnds
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
    bcPrepExpr GenStgExpr 'Vanilla
    expr
    bcPrepExpr (StgCase GenStgExpr 'Vanilla
    expr BinderP 'Vanilla
    bndr AltType
    alt_type [GenStgAlt 'Vanilla]
    alts) =
      forall (pass :: StgPass).
    GenStgExpr pass
    -> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
    StgCase forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
    bcPrepExpr GenStgExpr 'Vanilla
    expr
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> forall (f :: * -> *) a. Applicative f => a -> f a
    pure BinderP 'Vanilla
    bndr
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> forall (f :: * -> *) a. Applicative f => a -> f a
    pure AltType
    alt_type
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM GenStgAlt 'Vanilla -> BcM (GenStgAlt 'Vanilla)
    bcPrepAlt [GenStgAlt 'Vanilla]
    alts
    bcPrepExpr lit :: GenStgExpr 'Vanilla
    lit@StgLit{} = forall (f :: * -> *) a. Applicative f => a -> f a
    pure GenStgExpr 'Vanilla
    lit
    -- See Note [Not-necessarily-lifted join points], step 3.
    bcPrepExpr (StgApp Id
    x [])
      | Id -> Bool
    isNNLJoinPoint Id
    x = forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $
          forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
    StgApp (Id -> Id
    protectNNLJoinPointId Id
    x) [Id -> StgArg
    StgVarArg Id
    voidPrimId]
    bcPrepExpr app :: GenStgExpr 'Vanilla
    app@StgApp{} = forall (f :: * -> *) a. Applicative f => a -> f a
    pure GenStgExpr 'Vanilla
    app
    bcPrepExpr app :: GenStgExpr 'Vanilla
    app@StgConApp{} = forall (f :: * -> *) a. Applicative f => a -> f a
    pure GenStgExpr 'Vanilla
    app
    bcPrepExpr app :: GenStgExpr 'Vanilla
    app@StgOpApp{} = forall (f :: * -> *) a. Applicative f => a -> f a
    pure GenStgExpr 'Vanilla
    app

    bcPrepAlt :: StgAlt -> BcM StgAlt
    bcPrepAlt :: GenStgAlt 'Vanilla -> BcM (GenStgAlt 'Vanilla)
    bcPrepAlt (AltCon
    ac, [BinderP 'Vanilla]
    bndrs, GenStgExpr 'Vanilla
    expr) = (,,) AltCon
    ac [BinderP 'Vanilla]
    bndrs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> GenStgExpr 'Vanilla -> BcM (GenStgExpr 'Vanilla)
    bcPrepExpr GenStgExpr 'Vanilla
    expr

    bcPrepBind :: StgBinding -> BcM StgBinding
    -- explicitly match all constructors so we get a warning if we miss any
    bcPrepBind :: GenStgBinding 'Vanilla -> BcM (GenStgBinding 'Vanilla)
    bcPrepBind (StgNonRec BinderP 'Vanilla
    bndr StgRhs
    rhs) =
      let (Id
    bndr', StgRhs
    rhs') = (Id, StgRhs) -> (Id, StgRhs)
    bcPrepSingleBind (BinderP 'Vanilla
    bndr, StgRhs
    rhs)
      in  forall (pass :: StgPass).
    BinderP pass -> GenStgRhs pass -> GenStgBinding pass
    StgNonRec Id
    bndr' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> StgRhs -> BcM StgRhs
    bcPrepRHS StgRhs
    rhs'
    bcPrepBind (StgRec [(BinderP 'Vanilla, StgRhs)]
    bnds) =
      forall (pass :: StgPass).
    [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
    StgRec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM ((\(Id
    b,StgRhs
    r) -> (,) Id
    b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> StgRhs -> BcM StgRhs
    bcPrepRHS StgRhs
    r) forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Id, StgRhs) -> (Id, StgRhs)
    bcPrepSingleBind)
                      [(BinderP 'Vanilla, StgRhs)]
    bnds

    bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
    -- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
    -- See Note [Not-necessarily-lifted join points], step 2.
    bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
    bcPrepSingleBind (Id
    x, StgRhsClosure XRhsClosure 'Vanilla
    ext CostCentreStack
    cc UpdateFlag
    upd_flag [BinderP 'Vanilla]
    args GenStgExpr 'Vanilla
    body)
      | Id -> Bool
    isNNLJoinPoint Id
    x
      = ( Id -> Id
    protectNNLJoinPointId Id
    x
        , forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> GenStgRhs pass
    StgRhsClosure XRhsClosure 'Vanilla
    ext CostCentreStack
    cc UpdateFlag
    upd_flag ([BinderP 'Vanilla]
    args forall a. [a] -> [a] -> [a]
    ++ [Id
    voidArgId]) GenStgExpr 'Vanilla
    body)
    bcPrepSingleBind (Id, StgRhs)
    bnd = (Id, StgRhs)
    bnd

    -- -----------------------------------------------------------------------------
    -- Compilation schema for the bytecode generator

    type BCInstrList = OrdList BCInstr

    wordsToBytes :: Platform -> WordOff -> ByteOff
    wordsToBytes :: Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform = forall a b. (Integral a, Num b) => a -> b
    fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (forall a. Num a => a -> a -> a
    * Platform -> Int
    platformWordSizeInBytes Platform
    platform) forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b. (Integral a, Num b) => a -> b
    fromIntegral

    -- Used when we know we have a whole number of words
    bytesToWords :: Platform -> ByteOff -> WordOff
    bytesToWords :: Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff Int
    bytes) =
        let (Int
    q, Int
    r) = Int
    bytes forall a. Integral a => a -> a -> (a, a)
    `quotRem` (Platform -> Int
    platformWordSizeInBytes Platform
    platform)
        in if Int
    r forall a. Eq a => a -> a -> Bool
    == Int
    0
               then forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    q
               else forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "GHC.StgToByteCode.bytesToWords"
                             (String -> SDoc
    text String
    "bytes=" SDoc -> SDoc -> SDoc
    <> forall a. Outputable a => a -> SDoc
    ppr Int
    bytes)

    wordSize :: Platform -> ByteOff
    wordSize :: Platform -> ByteOff
    wordSize Platform
    platform = Int -> ByteOff
    ByteOff (Platform -> Int
    platformWordSizeInBytes Platform
    platform)

    type Sequel = ByteOff -- back off to this depth before ENTER

    type StackDepth = ByteOff

    -- | Maps Ids to their stack depth. This allows us to avoid having to mess with
    -- it after each push/pop.
    type BCEnv = Map Id StackDepth -- To find vars on the stack

    {-
    ppBCEnv :: BCEnv -> SDoc
    ppBCEnv p
       = text "begin-env"
         $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
         $$ text "end-env"
         where
            pp_one (var, ByteOff offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgReps var)
            cmp_snd x y = compare (snd x) (snd y)
    -}

    -- Create a BCO and do a spot of peephole optimisation on the insns
    -- at the same time.
    mkProtoBCO
       :: Platform
       -> name
       -> BCInstrList
       -> Either  [CgStgAlt] (CgStgRhs)
            -- ^ original expression; for debugging only
       -> Int
       -> Word16
       -> [StgWord]
       -> Bool      -- True <=> is a return point, rather than a function
       -> [FFIInfo]
       -> ProtoBCO name
    mkProtoBCO :: forall name.
    Platform
    -> name
    -> OrdList BCInstr
    -> Either [CgStgAlt] CgStgRhs
    -> Int
    -> Word16
    -> [StgWord]
    -> Bool
    -> [FFIInfo]
    -> ProtoBCO name
    mkProtoBCO Platform
    platform name
    nm OrdList BCInstr
    instrs_ordlist Either [CgStgAlt] CgStgRhs
    origin Int
    arity Word16
    bitmap_size [StgWord]
    bitmap Bool
    is_ret [FFIInfo]
    ffis
       = ProtoBCO {
            protoBCOName :: name
    protoBCOName = name
    nm,
            protoBCOInstrs :: [BCInstr]
    protoBCOInstrs = [BCInstr]
    maybe_with_stack_check,
            protoBCOBitmap :: [StgWord]
    protoBCOBitmap = [StgWord]
    bitmap,
            protoBCOBitmapSize :: Word16
    protoBCOBitmapSize = Word16
    bitmap_size,
            protoBCOArity :: Int
    protoBCOArity = Int
    arity,
            protoBCOExpr :: Either [CgStgAlt] CgStgRhs
    protoBCOExpr = Either [CgStgAlt] CgStgRhs
    origin,
            protoBCOFFIs :: [FFIInfo]
    protoBCOFFIs = [FFIInfo]
    ffis
          }
         where
            -- Overestimate the stack usage (in words) of this BCO,
            -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
            -- stack check.  (The interpreter always does a stack check
            -- for iNTERP_STACK_CHECK_THRESH words at the start of each
            -- BCO anyway, so we only need to add an explicit one in the
            -- (hopefully rare) cases when the (overestimated) stack use
            -- exceeds iNTERP_STACK_CHECK_THRESH.
            maybe_with_stack_check :: [BCInstr]
    maybe_with_stack_check
               | Bool
    is_ret Bool -> Bool -> Bool
    && Word
    stack_usage forall a. Ord a => a -> a -> Bool
    < forall a b. (Integral a, Num b) => a -> b
    fromIntegral (PlatformConstants -> Int
    pc_AP_STACK_SPLIM (Platform -> PlatformConstants
    platformConstants Platform
    platform)) = [BCInstr]
    peep_d
                    -- don't do stack checks at return points,
                    -- everything is aggregated up to the top BCO
                    -- (which must be a function).
                    -- That is, unless the stack usage is >= AP_STACK_SPLIM,
                    -- see bug #1466.
               | Word
    stack_usage forall a. Ord a => a -> a -> Bool
    >= forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    iNTERP_STACK_CHECK_THRESH
               = Word -> BCInstr
    STKCHECK Word
    stack_usage forall a. a -> [a] -> [a]
    : [BCInstr]
    peep_d
               | Bool
    otherwise
               = [BCInstr]
    peep_d     -- the supposedly common case

            -- We assume that this sum doesn't wrap
            stack_usage :: Word
    stack_usage = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum (forall a b. (a -> b) -> [a] -> [b]
    map BCInstr -> Word
    bciStackUse [BCInstr]
    peep_d)

            -- Merge local pushes
            peep_d :: [BCInstr]
    peep_d = [BCInstr] -> [BCInstr]
    peep (forall a. OrdList a -> [a]
    fromOL OrdList BCInstr
    instrs_ordlist)

            peep :: [BCInstr] -> [BCInstr]
    peep (PUSH_L Word16
    off1 : PUSH_L Word16
    off2 : PUSH_L Word16
    off3 : [BCInstr]
    rest)
               = Word16 -> Word16 -> Word16 -> BCInstr
    PUSH_LLL Word16
    off1 (Word16
    off2forall a. Num a => a -> a -> a
    -Word16
    1) (Word16
    off3forall a. Num a => a -> a -> a
    -Word16
    2) forall a. a -> [a] -> [a]
    : [BCInstr] -> [BCInstr]
    peep [BCInstr]
    rest
            peep (PUSH_L Word16
    off1 : PUSH_L Word16
    off2 : [BCInstr]
    rest)
               = Word16 -> Word16 -> BCInstr
    PUSH_LL Word16
    off1 (Word16
    off2forall a. Num a => a -> a -> a
    -Word16
    1) forall a. a -> [a] -> [a]
    : [BCInstr] -> [BCInstr]
    peep [BCInstr]
    rest
            peep (BCInstr
    i:[BCInstr]
    rest)
               = BCInstr
    i forall a. a -> [a] -> [a]
    : [BCInstr] -> [BCInstr]
    peep [BCInstr]
    rest
            peep []
               = []

    argBits :: Platform -> [ArgRep] -> [Bool]
    argBits :: Platform -> [ArgRep] -> [Bool]
    argBits Platform
    _        [] = []
    argBits Platform
    platform (ArgRep
    rep : [ArgRep]
    args)
      | ArgRep -> Bool
    isFollowableArg ArgRep
    rep  = Bool
    False forall a. a -> [a] -> [a]
    : Platform -> [ArgRep] -> [Bool]
    argBits Platform
    platform [ArgRep]
    args
      | Bool
    otherwise = forall a. Int -> [a] -> [a]
    take (Platform -> ArgRep -> Int
    argRepSizeW Platform
    platform ArgRep
    rep) (forall a. a -> [a]
    repeat Bool
    True) forall a. [a] -> [a] -> [a]
    ++ Platform -> [ArgRep] -> [Bool]
    argBits Platform
    platform [ArgRep]
    args

    non_void :: [ArgRep] -> [ArgRep]
    non_void :: [ArgRep] -> [ArgRep]
    non_void = forall a. (a -> Bool) -> [a] -> [a]
    filter ArgRep -> Bool
    nv
      where nv :: ArgRep -> Bool
    nv ArgRep
    V = Bool
    False
            nv ArgRep
    _ = Bool
    True

    -- -----------------------------------------------------------------------------
    -- schemeTopBind

    -- Compile code for the right-hand side of a top-level binding

    schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)
    schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)
    schemeTopBind (Id
    id, CgStgRhs
    rhs)
      | Just DataCon
    data_con <- Id -> Maybe DataCon
    isDataConWorkId_maybe Id
    id,
        DataCon -> Bool
    isNullaryRepDataCon DataCon
    data_con = do
        Platform
    platform <- Profile -> Platform
    profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM Profile
    getProfile
            -- Special case for the worker of a nullary data con.
            -- It'll look like this:        Nil = /\a -> Nil a
            -- If we feed it into schemeR, we'll get
            --      Nil = Nil
            -- because mkConAppCode treats nullary constructor applications
            -- by just re-using the single top-level definition.  So
            -- for the worker itself, we must allocate it directly.
        -- ioToBc (putStrLn $ "top level BCO")
        let enter :: BCInstr
    enter = if Kind -> Bool
    isUnliftedTypeKind (TyCon -> Kind
    tyConResKind (DataCon -> TyCon
    dataConTyCon DataCon
    data_con))
                    then ArgRep -> BCInstr
    RETURN_UNLIFTED ArgRep
    P
                    else BCInstr
    ENTER
        ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
    emitBc (forall name.
    Platform
    -> name
    -> OrdList BCInstr
    -> Either [CgStgAlt] CgStgRhs
    -> Int
    -> Word16
    -> [StgWord]
    -> Bool
    -> [FFIInfo]
    -> ProtoBCO name
    mkProtoBCO Platform
    platform (forall a. NamedThing a => a -> Name
    getName Id
    id) (forall a. [a] -> OrdList a
    toOL [DataCon -> Word16 -> BCInstr
    PACK DataCon
    data_con Word16
    0, BCInstr
    enter])
                           (forall a b. b -> Either a b
    Right CgStgRhs
    rhs) Int
    0 Word16
    0 [{-no bitmap-}] Bool
    False{-not alts-})

      | Bool
    otherwise
      = [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
    schemeR [{- No free variables -}] (forall a. NamedThing a => a -> Name
    getName Id
    id, CgStgRhs
    rhs)

    -- -----------------------------------------------------------------------------
    -- schemeR

    -- Compile code for a right-hand side, to give a BCO that,
    -- when executed with the free variables and arguments on top of the stack,
    -- will return with a pointer to the result on top of the stack, after
    -- removing the free variables and arguments.
    --
    -- Park the resulting BCO in the monad.  Also requires the
    -- name of the variable to which this value was bound,
    -- so as to give the resulting BCO a name.
    schemeR :: [Id]                 -- Free vars of the RHS, ordered as they
                                    -- will appear in the thunk.  Empty for
                                    -- top-level things, which have no free vars.
            -> (Name, CgStgRhs)
            -> BcM (ProtoBCO Name)
    schemeR :: [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
    schemeR [Id]
    fvs (Name
    nm, CgStgRhs
    rhs)
       = [Id]
    -> Name -> CgStgRhs -> ([Id], CgStgExpr) -> BcM (ProtoBCO Name)
    schemeR_wrk [Id]
    fvs Name
    nm CgStgRhs
    rhs (CgStgRhs -> ([Id], CgStgExpr)
    collect CgStgRhs
    rhs)

    -- If an expression is a lambda, return the
    -- list of arguments to the lambda (in R-to-L order) and the
    -- underlying expression

    collect :: CgStgRhs -> ([Var], CgStgExpr)
    collect :: CgStgRhs -> ([Id], CgStgExpr)
    collect (StgRhsClosure XRhsClosure 'CodeGen
    _ CostCentreStack
    _ UpdateFlag
    _ [BinderP 'CodeGen]
    args CgStgExpr
    body) = ([BinderP 'CodeGen]
    args, CgStgExpr
    body)
    collect (StgRhsCon CostCentreStack
    _cc DataCon
    dc ConstructorNumber
    cnum [StgTickish]
    _ticks [StgArg]
    args) = ([], forall (pass :: StgPass).
    DataCon -> XConApp pass -> [StgArg] -> [Kind] -> GenStgExpr pass
    StgConApp DataCon
    dc ConstructorNumber
    cnum [StgArg]
    args [])

    schemeR_wrk
        :: [Id]
        -> Name
        -> CgStgRhs            -- expression e, for debugging only
        -> ([Var], CgStgExpr)  -- result of collect on e
        -> BcM (ProtoBCO Name)
    schemeR_wrk :: [Id]
    -> Name -> CgStgRhs -> ([Id], CgStgExpr) -> BcM (ProtoBCO Name)
    schemeR_wrk [Id]
    fvs Name
    nm CgStgRhs
    original_body ([Id]
    args, CgStgExpr
    body)
       = do
         Profile
    profile <- BcM Profile
    getProfile
         let
             platform :: Platform
    platform  = Profile -> Platform
    profilePlatform Profile
    profile
             all_args :: [Id]
    all_args  = forall a. [a] -> [a]
    reverse [Id]
    args forall a. [a] -> [a] -> [a]
    ++ [Id]
    fvs
             arity :: Int
    arity     = forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Id]
    all_args
             -- all_args are the args in reverse order.  We're compiling a function
             -- \fv1..fvn x1..xn -> e
             -- i.e. the fvs come first

             -- Stack arguments always take a whole number of words, we never pack
             -- them unlike constructor fields.
             szsb_args :: [ByteOff]
    szsb_args = forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> Id -> WordOff
    idSizeW Platform
    platform) [Id]
    all_args
             sum_szsb_args :: ByteOff
    sum_szsb_args  = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum [ByteOff]
    szsb_args
             p_init :: Map Id ByteOff
    p_init    = forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList (forall a b. [a] -> [b] -> [(a, b)]
    zip [Id]
    all_args (ByteOff -> [ByteOff] -> [ByteOff]
    mkStackOffsets ByteOff
    0 [ByteOff]
    szsb_args))

             -- make the arg bitmap
             bits :: [Bool]
    bits = Platform -> [ArgRep] -> [Bool]
    argBits Platform
    platform (forall a. [a] -> [a]
    reverse (forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> Id -> ArgRep
    bcIdArgRep Platform
    platform) [Id]
    all_args))
             bitmap_size :: Word16
    bitmap_size = forall i a. Num i => [a] -> i
    genericLength [Bool]
    bits
             bitmap :: [StgWord]
    bitmap = Platform -> [Bool] -> [StgWord]
    mkBitmap Platform
    platform [Bool]
    bits
         OrdList BCInstr
    body_code <- ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeER_wrk ByteOff
    sum_szsb_args Map Id ByteOff
    p_init CgStgExpr
    body

         ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
    emitBc (forall name.
    Platform
    -> name
    -> OrdList BCInstr
    -> Either [CgStgAlt] CgStgRhs
    -> Int
    -> Word16
    -> [StgWord]
    -> Bool
    -> [FFIInfo]
    -> ProtoBCO name
    mkProtoBCO Platform
    platform Name
    nm OrdList BCInstr
    body_code (forall a b. b -> Either a b
    Right CgStgRhs
    original_body)
                     Int
    arity Word16
    bitmap_size [StgWord]
    bitmap Bool
    False{-not alts-})

    -- introduce break instructions for ticked expressions
    schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
    schemeER_wrk :: ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeER_wrk ByteOff
    d Map Id ByteOff
    p (StgTick (Breakpoint XBreakpoint 'TickishPassStg
    tick_ty Int
    tick_no [XTickishId 'TickishPassStg]
    fvs) CgStgExpr
    rhs)
      = do  OrdList BCInstr
    code <- ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d ByteOff
    0 Map Id ByteOff
    p CgStgExpr
    rhs
            Array Int (RemotePtr CostCentre)
    cc_arr <- BcM (Array Int (RemotePtr CostCentre))
    getCCArray
            ModuleName
    this_mod <- forall unit. GenModule unit -> ModuleName
    moduleName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM Module
    getCurrentModule
            Platform
    platform <- Profile -> Platform
    profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM Profile
    getProfile
            let idOffSets :: [Maybe (Id, Word16)]
    idOffSets = Platform
    -> ByteOff -> Map Id ByteOff -> [Id] -> [Maybe (Id, Word16)]
    getVarOffSets Platform
    platform ByteOff
    d Map Id ByteOff
    p [XTickishId 'TickishPassStg]
    fvs
            let breakInfo :: CgBreakInfo
    breakInfo = CgBreakInfo
                            { cgb_vars :: [Maybe (Id, Word16)]
    cgb_vars = [Maybe (Id, Word16)]
    idOffSets
                            , cgb_resty :: Kind
    cgb_resty = XBreakpoint 'TickishPassStg
    tick_ty
                            }
            Int -> CgBreakInfo -> BcM ()
    newBreakInfo Int
    tick_no CgBreakInfo
    breakInfo
            HscEnv
    hsc_env <- BcM HscEnv
    getHscEnv
            let cc :: RemotePtr CostCentre
    cc | Just Interp
    interp <- HscEnv -> Maybe Interp
    hsc_interp HscEnv
    hsc_env
                   , Interp -> Bool
    interpreterProfiled Interp
    interp
                   = Array Int (RemotePtr CostCentre)
    cc_arr forall i e. Ix i => Array i e -> i -> e
    ! Int
    tick_no
                   | Bool
    otherwise = forall a. Ptr a -> RemotePtr a
    toRemotePtr forall a. Ptr a
    nullPtr
            let breakInstr :: BCInstr
    breakInstr = Word16 -> Unique -> RemotePtr CostCentre -> BCInstr
    BRK_FUN (forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    tick_no) (forall a. Uniquable a => a -> Unique
    getUnique ModuleName
    this_mod) RemotePtr CostCentre
    cc
            forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ BCInstr
    breakInstr forall a. a -> OrdList a -> OrdList a
    `consOL` OrdList BCInstr
    code
    schemeER_wrk ByteOff
    d Map Id ByteOff
    p CgStgExpr
    rhs = ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d ByteOff
    0 Map Id ByteOff
    p CgStgExpr
    rhs

    getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
    getVarOffSets :: Platform
    -> ByteOff -> Map Id ByteOff -> [Id] -> [Maybe (Id, Word16)]
    getVarOffSets Platform
    platform ByteOff
    depth Map Id ByteOff
    env = forall a b. (a -> b) -> [a] -> [b]
    map Id -> Maybe (Id, Word16)
    getOffSet
      where
        getOffSet :: Id -> Maybe (Id, Word16)
    getOffSet Id
    id = case Id -> Map Id ByteOff -> Maybe ByteOff
    lookupBCEnv_maybe Id
    id Map Id ByteOff
    env of
            Maybe ByteOff
    Nothing     -> forall a. Maybe a
    Nothing
            Just ByteOff
    offset ->
                -- michalt: I'm not entirely sure why we need the stack
                -- adjustment by 2 here. I initially thought that there's
                -- something off with getIdValFromApStack (the only user of this
                -- value), but it looks ok to me. My current hypothesis is that
                -- this "adjustment" is needed due to stack manipulation for
                -- BRK_FUN in Interpreter.c In any case, this is used only when
                -- we trigger a breakpoint.
                let !var_depth_ws :: Word16
    var_depth_ws =
                        WordOff -> Word16
    trunc16W forall a b. (a -> b) -> a -> b
    $ Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    depth forall a. Num a => a -> a -> a
    - ByteOff
    offset) forall a. Num a => a -> a -> a
    + WordOff
    2
                in forall a. a -> Maybe a
    Just (Id
    id, Word16
    var_depth_ws)

    truncIntegral16 :: Integral a => a -> Word16
    truncIntegral16 :: forall a. Integral a => a -> Word16
    truncIntegral16 a
    w
        | a
    w forall a. Ord a => a -> a -> Bool
    > forall a b. (Integral a, Num b) => a -> b
    fromIntegral (forall a. Bounded a => a
    maxBound :: Word16)
        = forall a. String -> a
    panic String
    "stack depth overflow"
        | Bool
    otherwise
        = forall a b. (Integral a, Num b) => a -> b
    fromIntegral a
    w

    trunc16B :: ByteOff -> Word16
    trunc16B :: ByteOff -> Word16
    trunc16B = forall a. Integral a => a -> Word16
    truncIntegral16

    trunc16W :: WordOff -> Word16
    trunc16W :: WordOff -> Word16
    trunc16W = forall a. Integral a => a -> Word16
    truncIntegral16

    fvsToEnv :: BCEnv -> CgStgRhs -> [Id]
    -- Takes the free variables of a right-hand side, and
    -- delivers an ordered list of the local variables that will
    -- be captured in the thunk for the RHS
    -- The BCEnv argument tells which variables are in the local
    -- environment: these are the ones that should be captured
    --
    -- The code that constructs the thunk, and the code that executes
    -- it, have to agree about this layout

    fvsToEnv :: Map Id ByteOff -> CgStgRhs -> [Id]
    fvsToEnv Map Id ByteOff
    p CgStgRhs
    rhs =  [Id
    v | Id
    v <- DIdSet -> [Id]
    dVarSetElems forall a b. (a -> b) -> a -> b
    $ forall (pass :: StgPass).
    (XRhsClosure pass ~ DIdSet) =>
    GenStgRhs pass -> DIdSet
    freeVarsOfRhs CgStgRhs
    rhs,
                           Id
    v forall k a. Ord k => k -> Map k a -> Bool
    `Map.member` Map Id ByteOff
    p]

    -- -----------------------------------------------------------------------------
    -- schemeE

    -- Returning an unlifted value.
    -- Heave it on the stack, SLIDE, and RETURN.
    returnUnliftedAtom
        :: StackDepth
        -> Sequel
        -> BCEnv
        -> StgArg
        -> BcM BCInstrList
    returnUnliftedAtom :: ByteOff
    -> ByteOff -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr)
    returnUnliftedAtom ByteOff
    d ByteOff
    s Map Id ByteOff
    p StgArg
    e = do
        let reps :: [PrimRep]
    reps = case StgArg
    e of
                     StgLitArg Literal
    lit -> HasDebugCallStack => Kind -> [PrimRep]
    typePrimRepArgs (Literal -> Kind
    literalType Literal
    lit)
                     StgVarArg Id
    i   -> Id -> [PrimRep]
    bcIdPrimReps Id
    i
        (OrdList BCInstr
    push, ByteOff
    szb) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p StgArg
    e
        OrdList BCInstr
    ret <- ByteOff -> ByteOff -> ByteOff -> [PrimRep] -> BcM (OrdList BCInstr)
    returnUnliftedReps ByteOff
    d ByteOff
    s ByteOff
    szb [PrimRep]
    reps
        forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList BCInstr
    push forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` OrdList BCInstr
    ret)

    -- return an unlifted value from the top of the stack
    returnUnliftedReps
        :: StackDepth
        -> Sequel
        -> ByteOff    -- size of the thing we're returning
        -> [PrimRep]  -- representations
        -> BcM BCInstrList
    returnUnliftedReps :: ByteOff -> ByteOff -> ByteOff -> [PrimRep] -> BcM (OrdList BCInstr)
    returnUnliftedReps ByteOff
    d ByteOff
    s ByteOff
    szb [PrimRep]
    reps = do
        Profile
    profile <- BcM Profile
    getProfile
        let platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
            non_void :: PrimRep -> Bool
    non_void PrimRep
    VoidRep = Bool
    False
            non_void PrimRep
    _ = Bool
    True
        OrdList BCInstr
    ret <- case forall a. (a -> Bool) -> [a] -> [a]
    filter PrimRep -> Bool
    non_void [PrimRep]
    reps of
                 -- use RETURN_UBX for unary representations
                 []    -> forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. a -> OrdList a
    unitOL forall a b. (a -> b) -> a -> b
    $ ArgRep -> BCInstr
    RETURN_UNLIFTED ArgRep
    V)
                 [PrimRep
    rep] -> forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. a -> OrdList a
    unitOL forall a b. (a -> b) -> a -> b
    $ ArgRep -> BCInstr
    RETURN_UNLIFTED (Platform -> PrimRep -> ArgRep
    toArgRep Platform
    platform PrimRep
    rep))
                 -- otherwise use RETURN_TUPLE with a tuple descriptor
                 [PrimRep]
    nv_reps -> do
                   let (TupleInfo
    tuple_info, [(PrimRep, ByteOff)]
    args_offsets) = forall a.
    Profile
    -> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
    layoutTuple Profile
    profile ByteOff
    0 (Platform -> PrimRep -> CmmType
    primRepCmmType Platform
    platform) [PrimRep]
    nv_reps
                       args_ptrs :: [(Bool, ByteOff)]
    args_ptrs = forall a b. (a -> b) -> [a] -> [b]
    map (\(PrimRep
    rep, ByteOff
    off) -> (ArgRep -> Bool
    isFollowableArg (Platform -> PrimRep -> ArgRep
    toArgRep Platform
    platform PrimRep
    rep), ByteOff
    off)) [(PrimRep, ByteOff)]
    args_offsets
                   ProtoBCO Name
    tuple_bco <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
    emitBc (Platform
    -> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
    tupleBCO Platform
    platform TupleInfo
    tuple_info [(Bool, ByteOff)]
    args_ptrs)
                   forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ Literal -> Word16 -> BCInstr
    PUSH_UBX (Platform -> TupleInfo -> Literal
    mkTupleInfoLit Platform
    platform TupleInfo
    tuple_info) Word16
    1 forall a. a -> OrdList a -> OrdList a
    `consOL`
                            ProtoBCO Name -> BCInstr
    PUSH_BCO ProtoBCO Name
    tuple_bco forall a. a -> OrdList a -> OrdList a
    `consOL`
                            forall a. a -> OrdList a
    unitOL BCInstr
    RETURN_TUPLE
        forall (m :: * -> *) a. Monad m => a -> m a
    return ( Platform -> ByteOff -> ByteOff -> OrdList BCInstr
    mkSlideB Platform
    platform ByteOff
    szb (ByteOff
    d forall a. Num a => a -> a -> a
    - ByteOff
    s) -- clear to sequel
                 forall a. OrdList a -> OrdList a -> OrdList a
    `appOL`  OrdList BCInstr
    ret)                 -- go

    -- construct and return an unboxed tuple
    returnUnboxedTuple
        :: StackDepth
        -> Sequel
        -> BCEnv
        -> [StgArg]
        -> BcM BCInstrList
    returnUnboxedTuple :: ByteOff
    -> ByteOff -> Map Id ByteOff -> [StgArg] -> BcM (OrdList BCInstr)
    returnUnboxedTuple ByteOff
    d ByteOff
    s Map Id ByteOff
    p [StgArg]
    es = do
        Profile
    profile <- BcM Profile
    getProfile
        let platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
            arg_ty :: StgArg -> CmmType
    arg_ty StgArg
    e = Platform -> PrimRep -> CmmType
    primRepCmmType Platform
    platform (StgArg -> PrimRep
    atomPrimRep StgArg
    e)
            (TupleInfo
    tuple_info, [(StgArg, ByteOff)]
    tuple_components) = forall a.
    Profile
    -> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
    layoutTuple Profile
    profile ByteOff
    d StgArg -> CmmType
    arg_ty [StgArg]
    es
            go :: ByteOff
    -> [OrdList BCInstr]
    -> [(StgArg, ByteOff)]
    -> BcM [OrdList BCInstr]
    go ByteOff
    _   [OrdList BCInstr]
    pushes [] = forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. [a] -> [a]
    reverse [OrdList BCInstr]
    pushes)
            go !ByteOff
    dd [OrdList BCInstr]
    pushes ((StgArg
    a, ByteOff
    off):[(StgArg, ByteOff)]
    cs) = do (OrdList BCInstr
    push, ByteOff
    szb) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    dd Map Id ByteOff
    p StgArg
    a
                                             MASSERT(off == dd + szb)
                                             ByteOff
    -> [OrdList BCInstr]
    -> [(StgArg, ByteOff)]
    -> BcM [OrdList BCInstr]
    go (ByteOff
    dd forall a. Num a => a -> a -> a
    + ByteOff
    szb) (OrdList BCInstr
    pushforall a. a -> [a] -> [a]
    :[OrdList BCInstr]
    pushes) [(StgArg, ByteOff)]
    cs
        [OrdList BCInstr]
    pushes <- ByteOff
    -> [OrdList BCInstr]
    -> [(StgArg, ByteOff)]
    -> BcM [OrdList BCInstr]
    go ByteOff
    d [] [(StgArg, ByteOff)]
    tuple_components
        OrdList BCInstr
    ret <- ByteOff -> ByteOff -> ByteOff -> [PrimRep] -> BcM (OrdList BCInstr)
    returnUnliftedReps ByteOff
    d
                                  ByteOff
    s
                                  (Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform forall a b. (a -> b) -> a -> b
    $ TupleInfo -> WordOff
    tupleSize TupleInfo
    tuple_info)
                                  (forall a b. (a -> b) -> [a] -> [b]
    map StgArg -> PrimRep
    atomPrimRep [StgArg]
    es)
        forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. Monoid a => [a] -> a
    mconcat [OrdList BCInstr]
    pushes forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` OrdList BCInstr
    ret)

    -- Compile code to apply the given expression to the remaining args
    -- on the stack, returning a HNF.
    schemeE
        :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList
    schemeE :: ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgLit Literal
    lit) = ByteOff
    -> ByteOff -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr)
    returnUnliftedAtom ByteOff
    d ByteOff
    s Map Id ByteOff
    p (Literal -> StgArg
    StgLitArg Literal
    lit)
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgApp Id
    x [])
       | HasDebugCallStack => Kind -> Bool
    isUnliftedType (Id -> Kind
    idType Id
    x) = ByteOff
    -> ByteOff -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr)
    returnUnliftedAtom ByteOff
    d ByteOff
    s Map Id ByteOff
    p (Id -> StgArg
    StgVarArg Id
    x)
    -- Delegate tail-calls to schemeT.
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p e :: CgStgExpr
    e@(StgApp {}) = ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeT ByteOff
    d ByteOff
    s Map Id ByteOff
    p CgStgExpr
    e
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p e :: CgStgExpr
    e@(StgConApp {}) = ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeT ByteOff
    d ByteOff
    s Map Id ByteOff
    p CgStgExpr
    e
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p e :: CgStgExpr
    e@(StgOpApp {}) = ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeT ByteOff
    d ByteOff
    s Map Id ByteOff
    p CgStgExpr
    e
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgLetNoEscape XLetNoEscape 'CodeGen
    xlet CgStgBinding
    bnd CgStgExpr
    body)
       = ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p (forall (pass :: StgPass).
    XLet pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLet XLetNoEscape 'CodeGen
    xlet CgStgBinding
    bnd CgStgExpr
    body)
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgLet XLet 'CodeGen
    _xlet
                          (StgNonRec BinderP 'CodeGen
    x (StgRhsCon CostCentreStack
    _cc DataCon
    data_con ConstructorNumber
    _cnum [StgTickish]
    _ticks [StgArg]
    args))
                          CgStgExpr
    body)
       = do -- Special case for a non-recursive let whose RHS is a
            -- saturated constructor application.
            -- Just allocate the constructor and carry on
            OrdList BCInstr
    alloc_code <- ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> DataCon
    -> [StgArg]
    -> BcM (OrdList BCInstr)
    mkConAppCode ByteOff
    d ByteOff
    s Map Id ByteOff
    p DataCon
    data_con [StgArg]
    args
            Platform
    platform <- DynFlags -> Platform
    targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
            let !d2 :: ByteOff
    d2 = ByteOff
    d forall a. Num a => a -> a -> a
    + Platform -> ByteOff
    wordSize Platform
    platform
            OrdList BCInstr
    body_code <- ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d2 ByteOff
    s (forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert BinderP 'CodeGen
    x ByteOff
    d2 Map Id ByteOff
    p) CgStgExpr
    body
            forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList BCInstr
    alloc_code forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` OrdList BCInstr
    body_code)
    -- General case for let.  Generates correct, if inefficient, code in
    -- all situations.
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgLet XLet 'CodeGen
    _ext CgStgBinding
    binds CgStgExpr
    body) = do
         Platform
    platform <- DynFlags -> Platform
    targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
         let ([Id]
    xs,[CgStgRhs]
    rhss) = case CgStgBinding
    binds of StgNonRec BinderP 'CodeGen
    x CgStgRhs
    rhs  -> ([BinderP 'CodeGen
    x],[CgStgRhs
    rhs])
                                       StgRec [(BinderP 'CodeGen, CgStgRhs)]
    xs_n_rhss -> forall a b. [(a, b)] -> ([a], [b])
    unzip [(BinderP 'CodeGen, CgStgRhs)]
    xs_n_rhss
             n_binds :: WordOff
    n_binds = forall i a. Num i => [a] -> i
    genericLength [Id]
    xs

             fvss :: [[Id]]
    fvss  = forall a b. (a -> b) -> [a] -> [b]
    map (Map Id ByteOff -> CgStgRhs -> [Id]
    fvsToEnv Map Id ByteOff
    p') [CgStgRhs]
    rhss

             -- Sizes of free vars
             size_w :: Id -> Word16
    size_w = WordOff -> Word16
    trunc16W forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> Id -> WordOff
    idSizeW Platform
    platform
             sizes :: [Word16]
    sizes = forall a b. (a -> b) -> [a] -> [b]
    map (\[Id]
    rhs_fvs -> forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum (forall a b. (a -> b) -> [a] -> [b]
    map Id -> Word16
    size_w [Id]
    rhs_fvs)) [[Id]]
    fvss

             -- the arity of each rhs
             arities :: [Word16]
    arities = forall a b. (a -> b) -> [a] -> [b]
    map (forall i a. Num i => [a] -> i
    genericLength forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b. (a, b) -> a
    fst forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CgStgRhs -> ([Id], CgStgExpr)
    collect) [CgStgRhs]
    rhss

             -- This p', d' defn is safe because all the items being pushed
             -- are ptrs, so all have size 1 word.  d' and p' reflect the stack
             -- after the closures have been allocated in the heap (but not
             -- filled in), and pointers to them parked on the stack.
             offsets :: [ByteOff]
    offsets = ByteOff -> [ByteOff] -> [ByteOff]
    mkStackOffsets ByteOff
    d (forall i a. Integral i => i -> a -> [a]
    genericReplicate WordOff
    n_binds (Platform -> ByteOff
    wordSize Platform
    platform))
             p' :: Map Id ByteOff
    p' = forall key elt.
    Ord key =>
    [(key, elt)] -> Map key elt -> Map key elt
    Map.insertList (forall a b. [a] -> [b] -> [(a, b)]
    zipE [Id]
    xs [ByteOff]
    offsets) Map Id ByteOff
    p
             d' :: ByteOff
    d' = ByteOff
    d forall a. Num a => a -> a -> a
    + Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform WordOff
    n_binds
             zipE :: [a] -> [b] -> [(a, b)]
    zipE = forall a b. String -> [a] -> [b] -> [(a, b)]
    zipEqual String
    "schemeE"

             -- ToDo: don't build thunks for things with no free variables
             build_thunk
                 :: StackDepth
                 -> [Id]
                 -> Word16
                 -> ProtoBCO Name
                 -> Word16
                 -> Word16
                 -> BcM BCInstrList
             build_thunk :: ByteOff
    -> [Id]
    -> Word16
    -> ProtoBCO Name
    -> Word16
    -> Word16
    -> BcM (OrdList BCInstr)
    build_thunk ByteOff
    _ [] Word16
    size ProtoBCO Name
    bco Word16
    off Word16
    arity
                = forall (m :: * -> *) a. Monad m => a -> m a
    return (ProtoBCO Name -> BCInstr
    PUSH_BCO ProtoBCO Name
    bco forall a. a -> OrdList a -> OrdList a
    `consOL` forall a. a -> OrdList a
    unitOL (Word16 -> Word16 -> BCInstr
    mkap (Word16
    offforall a. Num a => a -> a -> a
    +Word16
    size) Word16
    size))
               where
                    mkap :: Word16 -> Word16 -> BCInstr
    mkap | Word16
    arity forall a. Eq a => a -> a -> Bool
    == Word16
    0 = Word16 -> Word16 -> BCInstr
    MKAP
                         | Bool
    otherwise  = Word16 -> Word16 -> BCInstr
    MKPAP
             build_thunk ByteOff
    dd (Id
    fv:[Id]
    fvs) Word16
    size ProtoBCO Name
    bco Word16
    off Word16
    arity = do
                  (OrdList BCInstr
    push_code, ByteOff
    pushed_szb) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    dd Map Id ByteOff
    p' (Id -> StgArg
    StgVarArg Id
    fv)
                  OrdList BCInstr
    more_push_code <-
                      ByteOff
    -> [Id]
    -> Word16
    -> ProtoBCO Name
    -> Word16
    -> Word16
    -> BcM (OrdList BCInstr)
    build_thunk (ByteOff
    dd forall a. Num a => a -> a -> a
    + ByteOff
    pushed_szb) [Id]
    fvs Word16
    size ProtoBCO Name
    bco Word16
    off Word16
    arity
                  forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList BCInstr
    push_code forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` OrdList BCInstr
    more_push_code)

             alloc_code :: OrdList BCInstr
    alloc_code = forall a. [a] -> OrdList a
    toOL (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith Word16 -> Word16 -> BCInstr
    mkAlloc [Word16]
    sizes [Word16]
    arities)
               where mkAlloc :: Word16 -> Word16 -> BCInstr
    mkAlloc Word16
    sz Word16
    0
                        | Bool
    is_tick     = Word16 -> BCInstr
    ALLOC_AP_NOUPD Word16
    sz
                        | Bool
    otherwise   = Word16 -> BCInstr
    ALLOC_AP Word16
    sz
                     mkAlloc Word16
    sz Word16
    arity = Word16 -> Word16 -> BCInstr
    ALLOC_PAP Word16
    arity Word16
    sz

             is_tick :: Bool
    is_tick = case CgStgBinding
    binds of
                         StgNonRec BinderP 'CodeGen
    id CgStgRhs
    _ -> OccName -> FastString
    occNameFS (forall a. NamedThing a => a -> OccName
    getOccName BinderP 'CodeGen
    id) forall a. Eq a => a -> a -> Bool
    == FastString
    tickFS
                         CgStgBinding
    _other -> Bool
    False

             compile_bind :: ByteOff
    -> [Id]
    -> a
    -> CgStgRhs
    -> Word16
    -> Word16
    -> Word16
    -> BcM (OrdList BCInstr)
    compile_bind ByteOff
    d' [Id]
    fvs a
    x (CgStgRhs
    rhs::CgStgRhs) Word16
    size Word16
    arity Word16
    off = do
                    ProtoBCO Name
    bco <- [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
    schemeR [Id]
    fvs (forall a. NamedThing a => a -> Name
    getName a
    x,CgStgRhs
    rhs)
                    ByteOff
    -> [Id]
    -> Word16
    -> ProtoBCO Name
    -> Word16
    -> Word16
    -> BcM (OrdList BCInstr)
    build_thunk ByteOff
    d' [Id]
    fvs Word16
    size ProtoBCO Name
    bco Word16
    off Word16
    arity

             compile_binds :: [BcM (OrdList BCInstr)]
    compile_binds =
                [ forall {a}.
    NamedThing a =>
    ByteOff
    -> [Id]
    -> a
    -> CgStgRhs
    -> Word16
    -> Word16
    -> Word16
    -> BcM (OrdList BCInstr)
    compile_bind ByteOff
    d' [Id]
    fvs Id
    x CgStgRhs
    rhs Word16
    size Word16
    arity (WordOff -> Word16
    trunc16W WordOff
    n)
                | ([Id]
    fvs, Id
    x, CgStgRhs
    rhs, Word16
    size, Word16
    arity, WordOff
    n) <-
                    forall a b c d e f.
    [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)]
    zip6 [[Id]]
    fvss [Id]
    xs [CgStgRhs]
    rhss [Word16]
    sizes [Word16]
    arities [WordOff
    n_binds, WordOff
    n_bindsforall a. Num a => a -> a -> a
    -WordOff
    1 .. WordOff
    1]
                ]
         OrdList BCInstr
    body_code <- ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d' ByteOff
    s Map Id ByteOff
    p' CgStgExpr
    body
         [OrdList BCInstr]
    thunk_codes <- forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [BcM (OrdList BCInstr)]
    compile_binds
         forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList BCInstr
    alloc_code forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` forall a. [OrdList a] -> OrdList a
    concatOL [OrdList BCInstr]
    thunk_codes forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` OrdList BCInstr
    body_code)

    schemeE ByteOff
    _d ByteOff
    _s Map Id ByteOff
    _p (StgTick (Breakpoint XBreakpoint 'TickishPassStg
    _ Int
    bp_id [XTickishId 'TickishPassStg]
    _) CgStgExpr
    _rhs)
       = forall a. String -> a
    panic (String
    "schemeE: Breakpoint without let binding: " forall a. [a] -> [a] -> [a]
    ++
                forall a. Show a => a -> String
    show Int
    bp_id forall a. [a] -> [a] -> [a]
    ++
                String
    " forgot to run bcPrep?")

    -- ignore other kinds of tick
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgTick StgTickish
    _ CgStgExpr
    rhs) = ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p CgStgExpr
    rhs

    -- no alts: scrut is guaranteed to diverge
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgCase CgStgExpr
    scrut BinderP 'CodeGen
    _ AltType
    _ []) = ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p CgStgExpr
    scrut

    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgCase CgStgExpr
    scrut BinderP 'CodeGen
    bndr AltType
    _ [CgStgAlt]
    alts)
       = ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> CgStgExpr
    -> Id
    -> [CgStgAlt]
    -> BcM (OrdList BCInstr)
    doCase ByteOff
    d ByteOff
    s Map Id ByteOff
    p CgStgExpr
    scrut BinderP 'CodeGen
    bndr [CgStgAlt]
    alts

    -- Is this Id a not-necessarily-lifted join point?
    -- See Note [Not-necessarily-lifted join points], step 1
    isNNLJoinPoint :: Id -> Bool
    isNNLJoinPoint :: Id -> Bool
    isNNLJoinPoint Id
    x = Id -> Bool
    isJoinId Id
    x Bool -> Bool -> Bool
    &&
                       forall a. a -> Maybe a
    Just Bool
    True forall a. Eq a => a -> a -> Bool
    /= HasDebugCallStack => Kind -> Maybe Bool
    isLiftedType_maybe (Id -> Kind
    idType Id
    x)

    -- Update an Id's type to take a Void# argument.
    -- Precondition: the Id is a not-necessarily-lifted join point.
    -- See Note [Not-necessarily-lifted join points]
    protectNNLJoinPointId :: Id -> Id
    protectNNLJoinPointId :: Id -> Id
    protectNNLJoinPointId Id
    x
      = ASSERT( isNNLJoinPoint x )
        (Kind -> Kind) -> Id -> Id
    updateIdTypeButNotMult (Kind
    unboxedUnitTy Kind -> Kind -> Kind
    `mkVisFunTyMany`) Id
    x

    {-
       Ticked Expressions
       ------------------

      The idea is that the "breakpoint<n,fvs> E" is really just an annotation on
      the code. When we find such a thing, we pull out the useful information,
      and then compile the code as if it was just the expression E.

    Note [Not-necessarily-lifted join points]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    A join point variable is essentially a goto-label: it is, for example,
    never used as an argument to another function, and it is called only
    in tail position. See Note [Join points] and Note [Invariants on join points],
    both in GHC.Core. Because join points do not compile to true, red-blooded
    variables (with, e.g., registers allocated to them), they are allowed
    to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points]
    in GHC.Core.)

    However, in this byte-code generator, join points *are* treated just as
    ordinary variables. There is no check whether a binding is for a join point
    or not; they are all treated uniformly. (Perhaps there is a missed optimization
    opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)

    We thus must have *some* strategy for dealing with levity-polymorphic and
    unlifted join points. Levity-polymorphic variables are generally not allowed
    (though levity-polymorphic join points *are*; see Note [Invariants on join points]
    in GHC.Core, point 6), and we don't wish to evaluate unlifted join points eagerly.
    The questionable join points are *not-necessarily-lifted join points*
    (NNLJPs). (Not having such a strategy led to #16509, which panicked in the
    isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:

    1. Detect NNLJPs. This is done in isNNLJoinPoint.

    2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the
       type to tack on a `(# #) ->`.
       Note that functions are never levity-polymorphic, so this transformation
       changes an NNLJP to a non-levity-polymorphic join point. This is done
       in bcPrepSingleBind.

    3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),
       being careful to note the new type of the NNLJP. This is done in the AnnVar
       case of schemeE, with help from protectNNLJoinPointId.

    Here is an example. Suppose we have

      f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
          join j :: a
               j = error @r @a "bloop"
          in case x of
               A -> j
               B -> j
               C -> error @r @a "blurp"

    Our plan is to behave is if the code was

      f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
          let j :: (Void# -> a)
              j = \ _ -> error @r @a "bloop"
          in case x of
               A -> j void#
               B -> j void#
               C -> error @r @a "blurp"

    It's a bit hacky, but it works well in practice and is local. I suspect the
    Right Fix is to take advantage of join points as goto-labels.

    -}

    -- Compile code to do a tail call.  Specifically, push the fn,
    -- slide the on-stack app back down to the sequel depth,
    -- and enter.  Four cases:
    --
    -- 0.  (Nasty hack).
    --     An application "GHC.Prim.tagToEnum# <type> unboxed-int".
    --     The int will be on the stack.  Generate a code sequence
    --     to convert it to the relevant constructor, SLIDE and ENTER.
    --
    -- 1.  The fn denotes a ccall.  Defer to generateCCall.
    --
    -- 2.  An unboxed tuple: push the components on the top of
    --     the stack and return.
    --
    -- 3.  Application of a constructor, by defn saturated.
    --     Split the args into ptrs and non-ptrs, and push the nonptrs,
    --     then the ptrs, and then do PACK and RETURN.
    --
    -- 4.  Otherwise, it must be a function call.  Push the args
    --     right to left, SLIDE and ENTER.

    schemeT :: StackDepth   -- Stack depth
            -> Sequel       -- Sequel depth
            -> BCEnv        -- stack env
            -> CgStgExpr
            -> BcM BCInstrList

       -- Case 0
    schemeT :: ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeT ByteOff
    d ByteOff
    s Map Id ByteOff
    p CgStgExpr
    app
       | Just (Id
    arg, [Name]
    constr_names) <- CgStgExpr -> Maybe (Id, [Name])
    maybe_is_tagToEnum_call CgStgExpr
    app
       = ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> Id
    -> [Name]
    -> BcM (OrdList BCInstr)
    implement_tagToId ByteOff
    d ByteOff
    s Map Id ByteOff
    p Id
    arg [Name]
    constr_names

       -- Case 1
    schemeT ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgOpApp (StgFCallOp (CCall CCallSpec
    ccall_spec) Kind
    _ty) [StgArg]
    args Kind
    result_ty)
       = if CCallSpec -> Bool
    isSupportedCConv CCallSpec
    ccall_spec
          then ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> CCallSpec
    -> Kind
    -> [StgArg]
    -> BcM (OrdList BCInstr)
    generateCCall ByteOff
    d ByteOff
    s Map Id ByteOff
    p CCallSpec
    ccall_spec Kind
    result_ty (forall a. [a] -> [a]
    reverse [StgArg]
    args)
          else forall a. a
    unsupportedCConvException

    schemeT ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgOpApp (StgPrimOp PrimOp
    op) [StgArg]
    args Kind
    _ty)
       = ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> Id
    -> [StgArg]
    -> BcM (OrdList BCInstr)
    doTailCall ByteOff
    d ByteOff
    s Map Id ByteOff
    p (PrimOp -> Id
    primOpId PrimOp
    op) (forall a. [a] -> [a]
    reverse [StgArg]
    args)

    schemeT ByteOff
    _d ByteOff
    _s Map Id ByteOff
    _p (StgOpApp StgPrimCallOp{} [StgArg]
    _args Kind
    _ty)
       = forall a. a
    unsupportedCConvException

       -- Case 2: Unboxed tuple
    schemeT ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgConApp DataCon
    con XConApp 'CodeGen
    _ext [StgArg]
    args [Kind]
    _tys)
       | DataCon -> Bool
    isUnboxedTupleDataCon DataCon
    con Bool -> Bool -> Bool
    || DataCon -> Bool
    isUnboxedSumDataCon DataCon
    con
       = ByteOff
    -> ByteOff -> Map Id ByteOff -> [StgArg] -> BcM (OrdList BCInstr)
    returnUnboxedTuple ByteOff
    d ByteOff
    s Map Id ByteOff
    p [StgArg]
    args

       -- Case 3: Ordinary data constructor
       | Bool
    otherwise
       = do OrdList BCInstr
    alloc_con <- ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> DataCon
    -> [StgArg]
    -> BcM (OrdList BCInstr)
    mkConAppCode ByteOff
    d ByteOff
    s Map Id ByteOff
    p DataCon
    con [StgArg]
    args
            Platform
    platform <- Profile -> Platform
    profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM Profile
    getProfile
            forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList BCInstr
    alloc_con         forall a. OrdList a -> OrdList a -> OrdList a
    `appOL`
                    Word16 -> WordOff -> OrdList BCInstr
    mkSlideW Word16
    1 (Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform forall a b. (a -> b) -> a -> b
    $ ByteOff
    d forall a. Num a => a -> a -> a
    - ByteOff
    s) forall a. OrdList a -> a -> OrdList a
    `snocOL`
                    if Kind -> Bool
    isUnliftedTypeKind (TyCon -> Kind
    tyConResKind (DataCon -> TyCon
    dataConTyCon DataCon
    con))
                    then ArgRep -> BCInstr
    RETURN_UNLIFTED ArgRep
    P
                    else BCInstr
    ENTER)

       -- Case 4: Tail call of function
    schemeT ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgApp Id
    fn [StgArg]
    args)
       = ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> Id
    -> [StgArg]
    -> BcM (OrdList BCInstr)
    doTailCall ByteOff
    d ByteOff
    s Map Id ByteOff
    p Id
    fn (forall a. [a] -> [a]
    reverse [StgArg]
    args)

    schemeT ByteOff
    _ ByteOff
    _ Map Id ByteOff
    _ CgStgExpr
    e = forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "GHC.StgToByteCode.schemeT"
                               (forall (pass :: StgPass).
    OutputablePass pass =>
    StgPprOpts -> GenStgExpr pass -> SDoc
    pprStgExpr StgPprOpts
    shortStgPprOpts CgStgExpr
    e)

    -- -----------------------------------------------------------------------------
    -- Generate code to build a constructor application,
    -- leaving it on top of the stack

    mkConAppCode
        :: StackDepth
        -> Sequel
        -> BCEnv
        -> DataCon                  -- The data constructor
        -> [StgArg]                 -- Args, in *reverse* order
        -> BcM BCInstrList
    mkConAppCode :: ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> DataCon
    -> [StgArg]
    -> BcM (OrdList BCInstr)
    mkConAppCode ByteOff
    orig_d ByteOff
    _ Map Id ByteOff
    p DataCon
    con [StgArg]
    args = BcM (OrdList BCInstr)
    app_code
      where
        app_code :: BcM (OrdList BCInstr)
    app_code = do
            Profile
    profile <- BcM Profile
    getProfile
            let platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile

                non_voids :: [NonVoid (PrimRep, StgArg)]
    non_voids =
                    [ forall a. a -> NonVoid a
    NonVoid (PrimRep
    prim_rep, StgArg
    arg)
                    | StgArg
    arg <- [StgArg]
    args
                    , let prim_rep :: PrimRep
    prim_rep = StgArg -> PrimRep
    atomPrimRep StgArg
    arg
                    , Bool -> Bool
    not (PrimRep -> Bool
    isVoidRep PrimRep
    prim_rep)
                    ]
                (Int
    _, Int
    _, [FieldOffOrPadding StgArg]
    args_offsets) =
                    forall a.
    Profile
    -> ClosureHeader
    -> [NonVoid (PrimRep, a)]
    -> (Int, Int, [FieldOffOrPadding a])
    mkVirtHeapOffsetsWithPadding Profile
    profile ClosureHeader
    StdHeader [NonVoid (PrimRep, StgArg)]
    non_voids

                do_pushery :: ByteOff -> [FieldOffOrPadding StgArg] -> BcM (OrdList BCInstr)
    do_pushery !ByteOff
    d (FieldOffOrPadding StgArg
    arg : [FieldOffOrPadding StgArg]
    args) = do
                    (OrdList BCInstr
    push, ByteOff
    arg_bytes) <- case FieldOffOrPadding StgArg
    arg of
                        (Padding Int
    l Int
    _) -> forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $! ByteOff -> (OrdList BCInstr, ByteOff)
    pushPadding (Int -> ByteOff
    ByteOff Int
    l)
                        (FieldOff NonVoid StgArg
    a Int
    _) -> ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushConstrAtom ByteOff
    d Map Id ByteOff
    p (forall a. NonVoid a -> a
    fromNonVoid NonVoid StgArg
    a)
                    OrdList BCInstr
    more_push_code <- ByteOff -> [FieldOffOrPadding StgArg] -> BcM (OrdList BCInstr)
    do_pushery (ByteOff
    d forall a. Num a => a -> a -> a
    + ByteOff
    arg_bytes) [FieldOffOrPadding StgArg]
    args
                    forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList BCInstr
    push forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` OrdList BCInstr
    more_push_code)
                do_pushery !ByteOff
    d [] = do
                    let !n_arg_words :: Word16
    n_arg_words = WordOff -> Word16
    trunc16W forall a b. (a -> b) -> a -> b
    $ Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    d forall a. Num a => a -> a -> a
    - ByteOff
    orig_d)
                    forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. a -> OrdList a
    unitOL (DataCon -> Word16 -> BCInstr
    PACK DataCon
    con Word16
    n_arg_words))

            -- Push on the stack in the reverse order.
            ByteOff -> [FieldOffOrPadding StgArg] -> BcM (OrdList BCInstr)
    do_pushery ByteOff
    orig_d (forall a. [a] -> [a]
    reverse [FieldOffOrPadding StgArg]
    args_offsets)

    -- -----------------------------------------------------------------------------
    -- Generate code for a tail-call

    doTailCall
        :: StackDepth
        -> Sequel
        -> BCEnv
        -> Id
        -> [StgArg]
        -> BcM BCInstrList
    doTailCall :: ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> Id
    -> [StgArg]
    -> BcM (OrdList BCInstr)
    doTailCall ByteOff
    init_d ByteOff
    s Map Id ByteOff
    p Id
    fn [StgArg]
    args = do
       Platform
    platform <- Profile -> Platform
    profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM Profile
    getProfile
       ByteOff -> [StgArg] -> [ArgRep] -> BcM (OrdList BCInstr)
    do_pushes ByteOff
    init_d [StgArg]
    args (forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> StgArg -> ArgRep
    atomRep Platform
    platform) [StgArg]
    args)
      where
      do_pushes :: ByteOff -> [StgArg] -> [ArgRep] -> BcM (OrdList BCInstr)
    do_pushes !ByteOff
    d [] [ArgRep]
    reps = do
            ASSERT( null reps ) return ()
            (OrdList BCInstr
    push_fn, ByteOff
    sz) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p (Id -> StgArg
    StgVarArg Id
    fn)
            Platform
    platform <- Profile -> Platform
    profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM Profile
    getProfile
            ASSERT( sz == wordSize platform ) return ()
            let slide :: OrdList BCInstr
    slide = Platform -> ByteOff -> ByteOff -> OrdList BCInstr
    mkSlideB Platform
    platform (ByteOff
    d forall a. Num a => a -> a -> a
    - ByteOff
    init_d forall a. Num a => a -> a -> a
    + Platform -> ByteOff
    wordSize Platform
    platform) (ByteOff
    init_d forall a. Num a => a -> a -> a
    - ByteOff
    s)
                enter :: BCInstr
    enter = if HasDebugCallStack => Kind -> Bool
    isUnliftedType (Id -> Kind
    idType Id
    fn)
                        then ArgRep -> BCInstr
    RETURN_UNLIFTED ArgRep
    P
                        else BCInstr
    ENTER
            forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList BCInstr
    push_fn forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` (OrdList BCInstr
    slide forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` forall a. a -> OrdList a
    unitOL BCInstr
    enter))
      do_pushes !ByteOff
    d [StgArg]
    args [ArgRep]
    reps = do
          let (BCInstr
    push_apply, Int
    n, [ArgRep]
    rest_of_reps) = [ArgRep] -> (BCInstr, Int, [ArgRep])
    findPushSeq [ArgRep]
    reps
              ([StgArg]
    these_args, [StgArg]
    rest_of_args) = forall a. Int -> [a] -> ([a], [a])
    splitAt Int
    n [StgArg]
    args
          (ByteOff
    next_d, OrdList BCInstr
    push_code) <- ByteOff -> [StgArg] -> BcM (ByteOff, OrdList BCInstr)
    push_seq ByteOff
    d [StgArg]
    these_args
          Platform
    platform <- Profile -> Platform
    profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM Profile
    getProfile
          OrdList BCInstr
    instrs <- ByteOff -> [StgArg] -> [ArgRep] -> BcM (OrdList BCInstr)
    do_pushes (ByteOff
    next_d forall a. Num a => a -> a -> a
    + Platform -> ByteOff
    wordSize Platform
    platform) [StgArg]
    rest_of_args [ArgRep]
    rest_of_reps
          --                          ^^^ for the PUSH_APPLY_ instruction
          forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList BCInstr
    push_code forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` (BCInstr
    push_apply forall a. a -> OrdList a -> OrdList a
    `consOL` OrdList BCInstr
    instrs))

      push_seq :: ByteOff -> [StgArg] -> BcM (ByteOff, OrdList BCInstr)
    push_seq ByteOff
    d [] = forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteOff
    d, forall a. OrdList a
    nilOL)
      push_seq ByteOff
    d (StgArg
    arg:[StgArg]
    args) = do
        (OrdList BCInstr
    push_code, ByteOff
    sz) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p StgArg
    arg
        (ByteOff
    final_d, OrdList BCInstr
    more_push_code) <- ByteOff -> [StgArg] -> BcM (ByteOff, OrdList BCInstr)
    push_seq (ByteOff
    d forall a. Num a => a -> a -> a
    + ByteOff
    sz) [StgArg]
    args
        forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteOff
    final_d, OrdList BCInstr
    push_code forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` OrdList BCInstr
    more_push_code)

    -- v. similar to CgStackery.findMatch, ToDo: merge
    findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
    findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
    findPushSeq (ArgRep
    P: ArgRep
    P: ArgRep
    P: ArgRep
    P: ArgRep
    P: ArgRep
    P: [ArgRep]
    rest)
      = (BCInstr
    PUSH_APPLY_PPPPPP, Int
    6, [ArgRep]
    rest)
    findPushSeq (ArgRep
    P: ArgRep
    P: ArgRep
    P: ArgRep
    P: ArgRep
    P: [ArgRep]
    rest)
      = (BCInstr
    PUSH_APPLY_PPPPP, Int
    5, [ArgRep]
    rest)
    findPushSeq (ArgRep
    P: ArgRep
    P: ArgRep
    P: ArgRep
    P: [ArgRep]
    rest)
      = (BCInstr
    PUSH_APPLY_PPPP, Int
    4, [ArgRep]
    rest)
    findPushSeq (ArgRep
    P: ArgRep
    P: ArgRep
    P: [ArgRep]
    rest)
      = (BCInstr
    PUSH_APPLY_PPP, Int
    3, [ArgRep]
    rest)
    findPushSeq (ArgRep
    P: ArgRep
    P: [ArgRep]
    rest)
      = (BCInstr
    PUSH_APPLY_PP, Int
    2, [ArgRep]
    rest)
    findPushSeq (ArgRep
    P: [ArgRep]
    rest)
      = (BCInstr
    PUSH_APPLY_P, Int
    1, [ArgRep]
    rest)
    findPushSeq (ArgRep
    V: [ArgRep]
    rest)
      = (BCInstr
    PUSH_APPLY_V, Int
    1, [ArgRep]
    rest)
    findPushSeq (ArgRep
    N: [ArgRep]
    rest)
      = (BCInstr
    PUSH_APPLY_N, Int
    1, [ArgRep]
    rest)
    findPushSeq (ArgRep
    F: [ArgRep]
    rest)
      = (BCInstr
    PUSH_APPLY_F, Int
    1, [ArgRep]
    rest)
    findPushSeq (ArgRep
    D: [ArgRep]
    rest)
      = (BCInstr
    PUSH_APPLY_D, Int
    1, [ArgRep]
    rest)
    findPushSeq (ArgRep
    L: [ArgRep]
    rest)
      = (BCInstr
    PUSH_APPLY_L, Int
    1, [ArgRep]
    rest)
    findPushSeq [ArgRep]
    _
      = forall a. String -> a
    panic String
    "GHC.StgToByteCode.findPushSeq"

    -- -----------------------------------------------------------------------------
    -- Case expressions

    doCase
        :: StackDepth
        -> Sequel
        -> BCEnv
        -> CgStgExpr
        -> Id
        -> [CgStgAlt]
        -> BcM BCInstrList
    doCase :: ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> CgStgExpr
    -> Id
    -> [CgStgAlt]
    -> BcM (OrdList BCInstr)
    doCase ByteOff
    d ByteOff
    s Map Id ByteOff
    p CgStgExpr
    scrut Id
    bndr [CgStgAlt]
    alts
      = do
         Profile
    profile <- BcM Profile
    getProfile
         HscEnv
    hsc_env <- BcM HscEnv
    getHscEnv
         let
            platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile

            -- Are we dealing with an unboxed tuple with a tuple return frame?
            --
            -- 'Simple' tuples with at most one non-void component,
            -- like (# Word# #) or (# Int#, State# RealWorld# #) do not have a
            -- tuple return frame. This is because (# foo #) and (# foo, Void# #)
            -- have the same runtime rep. We have more efficient specialized
            -- return frames for the situations with one non-void element.

            ubx_tuple_frame :: Bool
    ubx_tuple_frame =
              (Kind -> Bool
    isUnboxedTupleType Kind
    bndr_ty Bool -> Bool -> Bool
    || Kind -> Bool
    isUnboxedSumType Kind
    bndr_ty) Bool -> Bool -> Bool
    &&
              forall (t :: * -> *) a. Foldable t => t a -> Int
    length [ArgRep]
    non_void_arg_reps forall a. Ord a => a -> a -> Bool
    > Int
    1

            non_void_arg_reps :: [ArgRep]
    non_void_arg_reps = [ArgRep] -> [ArgRep]
    non_void (Platform -> Kind -> [ArgRep]
    typeArgReps Platform
    platform Kind
    bndr_ty)

            profiling :: Bool
    profiling
              | Just Interp
    interp <- HscEnv -> Maybe Interp
    hsc_interp HscEnv
    hsc_env
              = Interp -> Bool
    interpreterProfiled Interp
    interp
              | Bool
    otherwise = Bool
    False

            -- Top of stack is the return itbl, as usual.
            -- underneath it is the pointer to the alt_code BCO.
            -- When an alt is entered, it assumes the returned value is
            -- on top of the itbl.
            ret_frame_size_b :: StackDepth
            ret_frame_size_b :: ByteOff
    ret_frame_size_b | Bool
    ubx_tuple_frame =
                                 (if Bool
    profiling then ByteOff
    5 else ByteOff
    4) forall a. Num a => a -> a -> a
    * Platform -> ByteOff
    wordSize Platform
    platform
                             | Bool
    otherwise = ByteOff
    2 forall a. Num a => a -> a -> a
    * Platform -> ByteOff
    wordSize Platform
    platform

            -- The stack space used to save/restore the CCCS when profiling
            save_ccs_size_b :: ByteOff
    save_ccs_size_b | Bool
    profiling Bool -> Bool -> Bool
    &&
                              Bool -> Bool
    not Bool
    ubx_tuple_frame = ByteOff
    2 forall a. Num a => a -> a -> a
    * Platform -> ByteOff
    wordSize Platform
    platform
                            | Bool
    otherwise = ByteOff
    0

            -- An unlifted value gets an extra info table pushed on top
            -- when it is returned.
            unlifted_itbl_size_b :: StackDepth
            unlifted_itbl_size_b :: ByteOff
    unlifted_itbl_size_b | Bool
    ubx_tuple_frame              = ByteOff
    3 forall a. Num a => a -> a -> a
    * Platform -> ByteOff
    wordSize Platform
    platform
                                 | Bool -> Bool
    not (HasDebugCallStack => Kind -> Bool
    isUnliftedType Kind
    bndr_ty) = ByteOff
    0
                                 | Bool
    otherwise                    = Platform -> ByteOff
    wordSize Platform
    platform

            (ByteOff
    bndr_size, TupleInfo
    tuple_info, [(PrimRep, ByteOff)]
    args_offsets)
               | Bool
    ubx_tuple_frame =
                   let bndr_ty :: PrimRep -> CmmType
    bndr_ty = Platform -> PrimRep -> CmmType
    primRepCmmType Platform
    platform
                       bndr_reps :: [PrimRep]
    bndr_reps = forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    notforall b c a. (b -> c) -> (a -> b) -> a -> c
    .PrimRep -> Bool
    isVoidRep) (Id -> [PrimRep]
    bcIdPrimReps Id
    bndr)
                       (TupleInfo
    tuple_info, [(PrimRep, ByteOff)]
    args_offsets) =
                           forall a.
    Profile
    -> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
    layoutTuple Profile
    profile ByteOff
    0 PrimRep -> CmmType
    bndr_ty [PrimRep]
    bndr_reps
                   in ( Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform (TupleInfo -> WordOff
    tupleSize TupleInfo
    tuple_info)
                      , TupleInfo
    tuple_info
                      , [(PrimRep, ByteOff)]
    args_offsets
                      )
               | Bool
    otherwise = ( Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform (Platform -> Id -> WordOff
    idSizeW Platform
    platform Id
    bndr)
                             , TupleInfo
    voidTupleInfo
                             , []
                             )

            -- depth of stack after the return value has been pushed
            d_bndr :: ByteOff
    d_bndr =
                ByteOff
    d forall a. Num a => a -> a -> a
    + ByteOff
    ret_frame_size_b forall a. Num a => a -> a -> a
    + ByteOff
    bndr_size

            -- depth of stack after the extra info table for an unlifted return
            -- has been pushed, if any.  This is the stack depth at the
            -- continuation.
            d_alts :: ByteOff
    d_alts = ByteOff
    d forall a. Num a => a -> a -> a
    + ByteOff
    ret_frame_size_b forall a. Num a => a -> a -> a
    + ByteOff
    bndr_size forall a. Num a => a -> a -> a
    + ByteOff
    unlifted_itbl_size_b

            -- Env in which to compile the alts, not including
            -- any vars bound by the alts themselves
            p_alts :: Map Id ByteOff
    p_alts = forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert Id
    bndr ByteOff
    d_bndr Map Id ByteOff
    p

            bndr_ty :: Kind
    bndr_ty = Id -> Kind
    idType Id
    bndr
            isAlgCase :: Bool
    isAlgCase = Kind -> Bool
    isAlgType Kind
    bndr_ty

            -- given an alt, return a discr and code for it.
            codeAlt :: (AltCon, [Id], CgStgExpr) -> BcM (Discr, OrdList BCInstr)
    codeAlt (AltCon
    DEFAULT, [Id]
    _, CgStgExpr
    rhs)
               = do OrdList BCInstr
    rhs_code <- ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d_alts ByteOff
    s Map Id ByteOff
    p_alts CgStgExpr
    rhs
                    forall (m :: * -> *) a. Monad m => a -> m a
    return (Discr
    NoDiscr, OrdList BCInstr
    rhs_code)

            codeAlt alt :: (AltCon, [Id], CgStgExpr)
    alt@(AltCon
    _, [Id]
    bndrs, CgStgExpr
    rhs)
               -- primitive or nullary constructor alt: no need to UNPACK
               | forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Id]
    real_bndrs = do
                    OrdList BCInstr
    rhs_code <- ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d_alts ByteOff
    s Map Id ByteOff
    p_alts CgStgExpr
    rhs
                    forall (m :: * -> *) a. Monad m => a -> m a
    return (forall {b} {c}. (AltCon, b, c) -> Discr
    my_discr (AltCon, [Id], CgStgExpr)
    alt, OrdList BCInstr
    rhs_code)
               | Kind -> Bool
    isUnboxedTupleType Kind
    bndr_ty Bool -> Bool -> Bool
    || Kind -> Bool
    isUnboxedSumType Kind
    bndr_ty =
                 let bndr_ty :: Id -> CmmType
    bndr_ty = Platform -> PrimRep -> CmmType
    primRepCmmType Platform
    platform forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> PrimRep
    bcIdPrimRep
                     tuple_start :: ByteOff
    tuple_start = ByteOff
    d_bndr
                     (TupleInfo
    tuple_info, [(Id, ByteOff)]
    args_offsets) =
                       forall a.
    Profile
    -> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
    layoutTuple Profile
    profile
                                   ByteOff
    0
                                   Id -> CmmType
    bndr_ty
                                   [Id]
    bndrs

                     stack_bot :: ByteOff
    stack_bot = ByteOff
    d_alts

                     p' :: Map Id ByteOff
    p' = forall key elt.
    Ord key =>
    [(key, elt)] -> Map key elt -> Map key elt
    Map.insertList
                            [ (Id
    arg, ByteOff
    tuple_start forall a. Num a => a -> a -> a
    -
                                    Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform (TupleInfo -> WordOff
    tupleSize TupleInfo
    tuple_info) forall a. Num a => a -> a -> a
    +
                                    ByteOff
    offset)
                            | (Id
    arg, ByteOff
    offset) <- [(Id, ByteOff)]
    args_offsets
                            , Bool -> Bool
    not (PrimRep -> Bool
    isVoidRep forall a b. (a -> b) -> a -> b
    $ Id -> PrimRep
    bcIdPrimRep Id
    arg)]
                            Map Id ByteOff
    p_alts
                 in do
                   OrdList BCInstr
    rhs_code <- ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    stack_bot ByteOff
    s Map Id ByteOff
    p' CgStgExpr
    rhs
                   forall (m :: * -> *) a. Monad m => a -> m a
    return (Discr
    NoDiscr, OrdList BCInstr
    rhs_code)
               -- algebraic alt with some binders
               | Bool
    otherwise =
                 let (Int
    tot_wds, Int
    _ptrs_wds, [(NonVoid Id, Int)]
    args_offsets) =
                         forall a.
    Profile
    -> ClosureHeader
    -> [NonVoid (PrimRep, a)]
    -> (Int, Int, [(NonVoid a, Int)])
    mkVirtHeapOffsets Profile
    profile ClosureHeader
    NoHeader
                             [ forall a. a -> NonVoid a
    NonVoid (Id -> PrimRep
    bcIdPrimRep Id
    id, Id
    id)
                             | NonVoid Id
    id <- [Id] -> [NonVoid Id]
    nonVoidIds [Id]
    real_bndrs
                             ]
                     size :: WordOff
    size = Int -> WordOff
    WordOff Int
    tot_wds

                     stack_bot :: ByteOff
    stack_bot = ByteOff
    d_alts forall a. Num a => a -> a -> a
    + Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform WordOff
    size

                     -- convert offsets from Sp into offsets into the virtual stack
                     p' :: Map Id ByteOff
    p' = forall key elt.
    Ord key =>
    [(key, elt)] -> Map key elt -> Map key elt
    Map.insertList
                            [ (Id
    arg, ByteOff
    stack_bot forall a. Num a => a -> a -> a
    - Int -> ByteOff
    ByteOff Int
    offset)
                            | (NonVoid Id
    arg, Int
    offset) <- [(NonVoid Id, Int)]
    args_offsets ]
                            Map Id ByteOff
    p_alts

                     -- unlifted datatypes have an infotable word on top
                     unpack :: OrdList BCInstr
    unpack = if HasDebugCallStack => Kind -> Bool
    isUnliftedType Kind
    bndr_ty
                              then Word16 -> BCInstr
    PUSH_L Word16
    1 forall a. a -> OrdList a -> OrdList a
    `consOL`
                                   Word16 -> BCInstr
    UNPACK (WordOff -> Word16
    trunc16W WordOff
    size) forall a. a -> OrdList a -> OrdList a
    `consOL`
                                   forall a. a -> OrdList a
    unitOL (Word16 -> Word16 -> BCInstr
    SLIDE (WordOff -> Word16
    trunc16W WordOff
    size) Word16
    1)
                              else forall a. a -> OrdList a
    unitOL (Word16 -> BCInstr
    UNPACK (WordOff -> Word16
    trunc16W WordOff
    size))
                 in do
                 MASSERT(isAlgCase)
                 OrdList BCInstr
    rhs_code <- ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    stack_bot ByteOff
    s Map Id ByteOff
    p' CgStgExpr
    rhs
                 forall (m :: * -> *) a. Monad m => a -> m a
    return (forall {b} {c}. (AltCon, b, c) -> Discr
    my_discr (AltCon, [Id], CgStgExpr)
    alt, OrdList BCInstr
    unpack forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` OrdList BCInstr
    rhs_code)
               where
                 real_bndrs :: [Id]
    real_bndrs = forall a. (a -> Bool) -> [a] -> [a]
    filterOut Id -> Bool
    isTyVar [Id]
    bndrs

            my_discr :: (AltCon, b, c) -> Discr
    my_discr (AltCon
    DEFAULT, b
    _, c
    _) = Discr
    NoDiscr {-shouldn't really happen-}
            my_discr (DataAlt DataCon
    dc, b
    _, c
    _)
               | DataCon -> Bool
    isUnboxedTupleDataCon DataCon
    dc Bool -> Bool -> Bool
    || DataCon -> Bool
    isUnboxedSumDataCon DataCon
    dc
               = Discr
    NoDiscr
               | Bool
    otherwise
               = Word16 -> Discr
    DiscrP (forall a b. (Integral a, Num b) => a -> b
    fromIntegral (DataCon -> Int
    dataConTag DataCon
    dc forall a. Num a => a -> a -> a
    - Int
    fIRST_TAG))
            my_discr (LitAlt Literal
    l, b
    _, c
    _)
               = case Literal
    l of LitNumber LitNumType
    LitNumInt Integer
    i  -> Int -> Discr
    DiscrI (forall a. Num a => Integer -> a
    fromInteger Integer
    i)
                           LitNumber LitNumType
    LitNumWord Integer
    w -> Word -> Discr
    DiscrW (forall a. Num a => Integer -> a
    fromInteger Integer
    w)
                           LitFloat Rational
    r   -> Float -> Discr
    DiscrF (forall a. Fractional a => Rational -> a
    fromRational Rational
    r)
                           LitDouble Rational
    r  -> Double -> Discr
    DiscrD (forall a. Fractional a => Rational -> a
    fromRational Rational
    r)
                           LitChar Char
    i    -> Int -> Discr
    DiscrI (Char -> Int
    ord Char
    i)
                           Literal
    _ -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "schemeE(StgCase).my_discr" (forall a. Outputable a => a -> SDoc
    ppr Literal
    l)

            maybe_ncons :: Maybe Int
    maybe_ncons
               | Bool -> Bool
    not Bool
    isAlgCase = forall a. Maybe a
    Nothing
               | Bool
    otherwise
               = case [DataCon
    dc | (DataAlt DataCon
    dc, [Id]
    _, CgStgExpr
    _) <- [CgStgAlt]
    alts] of
                    []     -> forall a. Maybe a
    Nothing
                    (DataCon
    dc:[DataCon]
    _) -> forall a. a -> Maybe a
    Just (TyCon -> Int
    tyConFamilySize (DataCon -> TyCon
    dataConTyCon DataCon
    dc))

            -- the bitmap is relative to stack depth d, i.e. before the
            -- BCO, info table and return value are pushed on.
            -- This bit of code is v. similar to buildLivenessMask in CgBindery,
            -- except that here we build the bitmap from the known bindings of
            -- things that are pointers, whereas in CgBindery the code builds the
            -- bitmap from the free slots and unboxed bindings.
            -- (ToDo: merge?)
            --
            -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
            -- The bitmap must cover the portion of the stack up to the sequel only.
            -- Previously we were building a bitmap for the whole depth (d), but we
            -- really want a bitmap up to depth (d-s).  This affects compilation of
            -- case-of-case expressions, which is the only time we can be compiling a
            -- case expression with s /= 0.

            -- unboxed tuples get two more words, the second is a pointer (tuple_bco)
            ([Int]
    extra_pointers, Int
    extra_slots)
               | Bool
    ubx_tuple_frame Bool -> Bool -> Bool
    && Bool
    profiling = ([Int
    1], Int
    3) -- tuple_info, tuple_BCO, CCCS
               | Bool
    ubx_tuple_frame              = ([Int
    1], Int
    2) -- tuple_info, tuple_BCO
               | Bool
    otherwise                    = ([], Int
    0)

            bitmap_size :: Word16
    bitmap_size = WordOff -> Word16
    trunc16W forall a b. (a -> b) -> a -> b
    $ forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    extra_slots forall a. Num a => a -> a -> a
    +
                                     Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    d forall a. Num a => a -> a -> a
    - ByteOff
    s)

            bitmap_size' :: Int
            bitmap_size' :: Int
    bitmap_size' = forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    bitmap_size

            pointers :: [Int]
    pointers =
              [Int]
    extra_pointers forall a. [a] -> [a] -> [a]
    ++
              forall a. (a -> Bool) -> [a] -> [a]
    filter (forall a. Ord a => a -> a -> Bool
    < Int
    bitmap_size') (forall a b. (a -> b) -> [a] -> [b]
    map (forall a. Num a => a -> a -> a
    +Int
    extra_slots) [Int]
    rel_slots)
              where
              -- NB: unboxed tuple cases bind the scrut binder to the same offset
              -- as one of the alt binders, so we have to remove any duplicates here:
              -- 'toAscList' takes care of sorting the result, which was previously done after the application of 'filter'.
              rel_slots :: [Int]
    rel_slots = IntSet -> [Int]
    IntSet.toAscList forall a b. (a -> b) -> a -> b
    $ [Int] -> IntSet
    IntSet.fromList forall a b. (a -> b) -> a -> b
    $ forall k a. Map k a -> [a]
    Map.elems forall a b. (a -> b) -> a -> b
    $ forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
    Map.mapMaybeWithKey Id -> ByteOff -> Maybe Int
    spread Map Id ByteOff
    p
              spread :: Id -> ByteOff -> Maybe Int
    spread Id
    id ByteOff
    offset | Kind -> Bool
    isUnboxedTupleType (Id -> Kind
    idType Id
    id) Bool -> Bool -> Bool
    ||
                                 Kind -> Bool
    isUnboxedSumType (Id -> Kind
    idType Id
    id) = forall a. Maybe a
    Nothing
                               | ArgRep -> Bool
    isFollowableArg (Platform -> Id -> ArgRep
    bcIdArgRep Platform
    platform Id
    id) = forall a. a -> Maybe a
    Just (forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    rel_offset)
                               | Bool
    otherwise                      = forall a. Maybe a
    Nothing
                    where rel_offset :: Word16
    rel_offset = WordOff -> Word16
    trunc16W forall a b. (a -> b) -> a -> b
    $ Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    d forall a. Num a => a -> a -> a
    - ByteOff
    offset)

            bitmap :: [StgWord]
    bitmap = Platform -> Int -> [Int] -> [StgWord]
    intsToReverseBitmap Platform
    platform Int
    bitmap_size'{-size-} [Int]
    pointers

         [(Discr, OrdList BCInstr)]
    alt_stuff <- forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (AltCon, [Id], CgStgExpr) -> BcM (Discr, OrdList BCInstr)
    codeAlt [CgStgAlt]
    alts
         OrdList BCInstr
    alt_final <- Maybe Int -> [(Discr, OrdList BCInstr)] -> BcM (OrdList BCInstr)
    mkMultiBranch Maybe Int
    maybe_ncons [(Discr, OrdList BCInstr)]
    alt_stuff

         let
             alt_bco_name :: Name
    alt_bco_name = forall a. NamedThing a => a -> Name
    getName Id
    bndr
             alt_bco :: [FFIInfo] -> ProtoBCO Name
    alt_bco = forall name.
    Platform
    -> name
    -> OrdList BCInstr
    -> Either [CgStgAlt] CgStgRhs
    -> Int
    -> Word16
    -> [StgWord]
    -> Bool
    -> [FFIInfo]
    -> ProtoBCO name
    mkProtoBCO Platform
    platform Name
    alt_bco_name OrdList BCInstr
    alt_final (forall a b. a -> Either a b
    Left [CgStgAlt]
    alts)
                           Int
    0{-no arity-} Word16
    bitmap_size [StgWord]
    bitmap Bool
    True{-is alts-}
         OrdList BCInstr
    scrut_code <- ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE (ByteOff
    d forall a. Num a => a -> a -> a
    + ByteOff
    ret_frame_size_b forall a. Num a => a -> a -> a
    + ByteOff
    save_ccs_size_b)
                               (ByteOff
    d forall a. Num a => a -> a -> a
    + ByteOff
    ret_frame_size_b forall a. Num a => a -> a -> a
    + ByteOff
    save_ccs_size_b)
                               Map Id ByteOff
    p CgStgExpr
    scrut
         ProtoBCO Name
    alt_bco' <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
    emitBc [FFIInfo] -> ProtoBCO Name
    alt_bco
         if Bool
    ubx_tuple_frame
           then do
                  let args_ptrs :: [(Bool, ByteOff)]
    args_ptrs =
                        forall a b. (a -> b) -> [a] -> [b]
    map (\(PrimRep
    rep, ByteOff
    off) -> (ArgRep -> Bool
    isFollowableArg (Platform -> PrimRep -> ArgRep
    toArgRep Platform
    platform PrimRep
    rep), ByteOff
    off))
                            [(PrimRep, ByteOff)]
    args_offsets
                  ProtoBCO Name
    tuple_bco <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
    emitBc (Platform
    -> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
    tupleBCO Platform
    platform TupleInfo
    tuple_info [(Bool, ByteOff)]
    args_ptrs)
                  forall (m :: * -> *) a. Monad m => a -> m a
    return (ProtoBCO Name -> TupleInfo -> ProtoBCO Name -> BCInstr
    PUSH_ALTS_TUPLE ProtoBCO Name
    alt_bco' TupleInfo
    tuple_info ProtoBCO Name
    tuple_bco
                          forall a. a -> OrdList a -> OrdList a
    `consOL` OrdList BCInstr
    scrut_code)
           else let push_alts :: BCInstr
    push_alts
                      | Bool -> Bool
    not (HasDebugCallStack => Kind -> Bool
    isUnliftedType Kind
    bndr_ty)
                      = ProtoBCO Name -> BCInstr
    PUSH_ALTS ProtoBCO Name
    alt_bco'
                      | Bool
    otherwise
                      = let unlifted_rep :: ArgRep
    unlifted_rep =
                              case [ArgRep]
    non_void_arg_reps of
                                []    -> ArgRep
    V
                                [ArgRep
    rep] -> ArgRep
    rep
                                [ArgRep]
    _     -> forall a. String -> a
    panic String
    "schemeE(StgCase).push_alts"
                        in ProtoBCO Name -> ArgRep -> BCInstr
    PUSH_ALTS_UNLIFTED ProtoBCO Name
    alt_bco' ArgRep
    unlifted_rep
                in forall (m :: * -> *) a. Monad m => a -> m a
    return (BCInstr
    push_alts forall a. a -> OrdList a -> OrdList a
    `consOL` OrdList BCInstr
    scrut_code)

    -- -----------------------------------------------------------------------------
    -- Deal with tuples

    -- The native calling convention uses registers for tuples, but in the
    -- bytecode interpreter, all values live on the stack.

    layoutTuple :: Profile
                -> ByteOff
                -> (a -> CmmType)
                -> [a]
                -> ( TupleInfo      -- See Note [GHCi TupleInfo]
                   , [(a, ByteOff)] -- argument, offset on stack
                   )
    layoutTuple :: forall a.
    Profile
    -> ByteOff -> (a -> CmmType) -> [a] -> (TupleInfo, [(a, ByteOff)])
    layoutTuple Profile
    profile ByteOff
    start_off a -> CmmType
    arg_ty [a]
    reps =
      let platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
          (Int
    orig_stk_bytes, [(a, ParamLocation)]
    pos) = forall a.
    Profile
    -> Int
    -> Convention
    -> (a -> CmmType)
    -> [a]
    -> (Int, [(a, ParamLocation)])
    assignArgumentsPos Profile
    profile
                                                     Int
    0
                                                     Convention
    NativeReturn
                                                     a -> CmmType
    arg_ty
                                                     [a]
    reps

          -- keep the stack parameters in the same place
          orig_stk_params :: [(a, ByteOff)]
    orig_stk_params = [(a
    x, forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    off) | (a
    x, StackParam Int
    off) <- [(a, ParamLocation)]
    pos]

          -- sort the register parameters by register and add them to the stack
          regs_order :: Map.Map GlobalReg Int
          regs_order :: Map GlobalReg Int
    regs_order = forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList forall a b. (a -> b) -> a -> b
    $ forall a b. [a] -> [b] -> [(a, b)]
    zip (Platform -> [GlobalReg]
    tupleRegsCover Platform
    platform) [Int
    0..]

          reg_order :: GlobalReg -> (Int, GlobalReg)
          reg_order :: GlobalReg -> (Int, GlobalReg)
    reg_order GlobalReg
    reg | Just Int
    n <- forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup GlobalReg
    reg Map GlobalReg Int
    regs_order = (Int
    n, GlobalReg
    reg)
          -- a VanillaReg goes to the same place regardless of whether it
          -- contains a pointer
          reg_order (VanillaReg Int
    n VGcPtr
    VNonGcPtr) = GlobalReg -> (Int, GlobalReg)
    reg_order (Int -> VGcPtr -> GlobalReg
    VanillaReg Int
    n VGcPtr
    VGcPtr)
          -- if we don't have a position for a FloatReg then they must be passed
          -- in the equivalent DoubleReg
          reg_order (FloatReg Int
    n) = GlobalReg -> (Int, GlobalReg)
    reg_order (Int -> GlobalReg
    DoubleReg Int
    n)
          -- one-tuples can be passed in other registers, but then we don't need
          -- to care about the order
          reg_order GlobalReg
    reg          = (Int
    0, GlobalReg
    reg)

          ([(Int, GlobalReg)]
    regs, [a]
    reg_params)
              = forall a b. [(a, b)] -> ([a], [b])
    unzip forall a b. (a -> b) -> a -> b
    $ forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
    comparing forall a b. (a, b) -> a
    fst)
                               [(GlobalReg -> (Int, GlobalReg)
    reg_order GlobalReg
    reg, a
    x) | (a
    x, RegisterParam GlobalReg
    reg) <- [(a, ParamLocation)]
    pos]

          (Int
    new_stk_bytes, [(a, ParamLocation)]
    new_stk_params) = forall a.
    Platform
    -> Int -> (a -> CmmType) -> [a] -> (Int, [(a, ParamLocation)])
    assignStack Platform
    platform
                                                        Int
    orig_stk_bytes
                                                        a -> CmmType
    arg_ty
                                                        [a]
    reg_params

          regs_set :: RegSet GlobalReg
    regs_set = forall r. Ord r => [r] -> RegSet r
    mkRegSet (forall a b. (a -> b) -> [a] -> [b]
    map forall a b. (a, b) -> b
    snd [(Int, GlobalReg)]
    regs)

          get_byte_off :: (a, ParamLocation) -> (a, b)
    get_byte_off (a
    x, StackParam Int
    y) = (a
    x, forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    y)
          get_byte_off (a, ParamLocation)
    _                 =
              forall a. String -> a
    panic String
    "GHC.StgToByteCode.layoutTuple get_byte_off"

      in ( TupleInfo
             { tupleSize :: WordOff
    tupleSize        = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (Int -> ByteOff
    ByteOff Int
    new_stk_bytes)
             , tupleRegs :: RegSet GlobalReg
    tupleRegs        = RegSet GlobalReg
    regs_set
             , tupleNativeStackSize :: WordOff
    tupleNativeStackSize = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform
                                                   (Int -> ByteOff
    ByteOff Int
    orig_stk_bytes)
             }
         , forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
    comparing forall a b. (a, b) -> b
    snd) forall a b. (a -> b) -> a -> b
    $
                  forall a b. (a -> b) -> [a] -> [b]
    map (\(a
    x, ByteOff
    o) -> (a
    x, ByteOff
    o forall a. Num a => a -> a -> a
    + ByteOff
    start_off))
                      ([(a, ByteOff)]
    orig_stk_params forall a. [a] -> [a] -> [a]
    ++ forall a b. (a -> b) -> [a] -> [b]
    map forall {b} {a}. Num b => (a, ParamLocation) -> (a, b)
    get_byte_off [(a, ParamLocation)]
    new_stk_params)
         )

    {- Note [unboxed tuple bytecodes and tuple_BCO]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to
      return and receive arbitrary unboxed tuples, respectively. These
      instructions use the helper data tuple_BCO and tuple_info.

      The helper data is used to convert tuples between GHCs native calling
      convention (object code), which uses stack and registers, and the bytecode
      calling convention, which only uses the stack. See Note [GHCi TupleInfo]
      for more details.

      Returning a tuple
      =================

      Bytecode that returns a tuple first pushes all the tuple fields followed
      by the appropriate tuple_info and tuple_BCO onto the stack. It then
      executes the RETURN_TUPLE instruction, which causes the interpreter
      to push stg_ret_t_info to the top of the stack. The stack (growing down)
      then looks as follows:

          ...
          next_frame
          tuple_field_1
          tuple_field_2
          ...
          tuple_field_n
          tuple_info
          tuple_BCO
          stg_ret_t_info <- Sp

      If next_frame is bytecode, the interpreter will start executing it. If
      it's object code, the interpreter jumps back to the scheduler, which in
      turn jumps to stg_ret_t. stg_ret_t converts the tuple to the native
      calling convention using the description in tuple_info, and then jumps
      to next_frame.

      Receiving a tuple
      =================

      Bytecode that receives a tuple uses the PUSH_ALTS_TUPLE instruction to
      push a continuation, followed by jumping to the code that produces the
      tuple. The PUSH_ALTS_TUPLE instuction contains three pieces of data:

         * cont_BCO: the continuation that receives the tuple
         * tuple_info: see below
         * tuple_BCO: see below

      The interpreter pushes these onto the stack when the PUSH_ALTS_TUPLE
      instruction is executed, followed by stg_ctoi_tN_info, with N depending
      on the number of stack words used by the tuple in the GHC native calling
      convention. N is derived from tuple_info.

      For example if we expect a tuple with three words on the stack, the stack
      looks as follows after PUSH_ALTS_TUPLE:

          ...
          next_frame
          cont_free_var_1
          cont_free_var_2
          ...
          cont_free_var_n
          tuple_info
          tuple_BCO
          cont_BCO
          stg_ctoi_t3_info <- Sp

      If the tuple is returned by object code, stg_ctoi_t3 will deal with
      adjusting the stack pointer and converting the tuple to the bytecode
      calling convention. See Note [GHCi unboxed tuples stack spills] for more
      details.

      The tuple_BCO
      =============

      The tuple_BCO is a helper bytecode object. Its main purpose is describing
      the contents of the stack frame containing the tuple for the storage
      manager. It contains only instructions to immediately return the tuple
      that is already on the stack.

      The tuple_info word
      ===================

      The tuple_info word describes the stack and STG register (e.g. R1..R6,
      D1..D6) usage for the tuple. tuple_info contains enough information to
      convert the tuple between the stack-only bytecode and stack+registers
      GHC native calling conventions.

      See Note [GHCi tuple layout] for more details of how the data is packed
      in a single word.

     -}

    tupleBCO :: Platform -> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
    tupleBCO :: Platform
    -> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
    tupleBCO Platform
    platform TupleInfo
    info [(Bool, ByteOff)]
    pointers =
      forall name.
    Platform
    -> name
    -> OrdList BCInstr
    -> Either [CgStgAlt] CgStgRhs
    -> Int
    -> Word16
    -> [StgWord]
    -> Bool
    -> [FFIInfo]
    -> ProtoBCO name
    mkProtoBCO Platform
    platform Name
    invented_name OrdList BCInstr
    body_code (forall a b. a -> Either a b
    Left [])
                 Int
    0{-no arity-} Word16
    bitmap_size [StgWord]
    bitmap Bool
    False{-is alts-}

      where
        {-
          The tuple BCO is never referred to by name, so we can get away
          with using a fake name here. We will need to change this if we want
          to save some memory by sharing the BCO between places that have
          the same tuple shape
        -}
        invented_name :: Name
    invented_name  = Unique -> FastString -> Name
    mkSystemVarName (Int -> Unique
    mkPseudoUniqueE Int
    0) (String -> FastString
    fsLit String
    "tuple")

        -- the first word in the frame is the tuple_info word,
        -- which is not a pointer
        bitmap_size :: Word16
    bitmap_size = WordOff -> Word16
    trunc16W forall a b. (a -> b) -> a -> b
    $ WordOff
    1 forall a. Num a => a -> a -> a
    + TupleInfo -> WordOff
    tupleSize TupleInfo
    info
        bitmap :: [StgWord]
    bitmap      = Platform -> Int -> [Int] -> [StgWord]
    intsToReverseBitmap Platform
    platform (forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    bitmap_size) forall a b. (a -> b) -> a -> b
    $
                      forall a b. (a -> b) -> [a] -> [b]
    map ((forall a. Num a => a -> a -> a
    +Int
    1) forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b. (Integral a, Num b) => a -> b
    fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b. (a, b) -> b
    snd)
                          (forall a. (a -> Bool) -> [a] -> [a]
    filter forall a b. (a, b) -> a
    fst [(Bool, ByteOff)]
    pointers)
        body_code :: OrdList BCInstr
    body_code = Word16 -> WordOff -> OrdList BCInstr
    mkSlideW Word16
    0 WordOff
    1          -- pop frame header
                    forall a. OrdList a -> a -> OrdList a
    `snocOL` BCInstr
    RETURN_TUPLE -- and add it again

    -- -----------------------------------------------------------------------------
    -- Deal with a CCall.

    -- Taggedly push the args onto the stack R->L,
    -- deferencing ForeignObj#s and adjusting addrs to point to
    -- payloads in Ptr/Byte arrays.  Then, generate the marshalling
    -- (machine) code for the ccall, and create bytecodes to call that and
    -- then return in the right way.

    generateCCall
        :: StackDepth
        -> Sequel
        -> BCEnv
        -> CCallSpec               -- where to call
        -> Type
        -> [StgArg]              -- args (atoms)
        -> BcM BCInstrList
    generateCCall :: ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> CCallSpec
    -> Kind
    -> [StgArg]
    -> BcM (OrdList BCInstr)
    generateCCall ByteOff
    d0 ByteOff
    s Map Id ByteOff
    p (CCallSpec CCallTarget
    target CCallConv
    cconv Safety
    safety) Kind
    result_ty [StgArg]
    args_r_to_l
     = do
         Profile
    profile <- BcM Profile
    getProfile

         let
             platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
             -- useful constants
             addr_size_b :: ByteOff
             addr_size_b :: ByteOff
    addr_size_b = Platform -> ByteOff
    wordSize Platform
    platform

             arrayish_rep_hdr_size :: TyCon -> Maybe Int
             arrayish_rep_hdr_size :: TyCon -> Maybe Int
    arrayish_rep_hdr_size TyCon
    t
               | TyCon
    t forall a. Eq a => a -> a -> Bool
    == TyCon
    arrayPrimTyCon Bool -> Bool -> Bool
    || TyCon
    t forall a. Eq a => a -> a -> Bool
    == TyCon
    mutableArrayPrimTyCon
                  = forall a. a -> Maybe a
    Just (Profile -> Int
    arrPtrsHdrSize Profile
    profile)
               | TyCon
    t forall a. Eq a => a -> a -> Bool
    == TyCon
    smallArrayPrimTyCon Bool -> Bool -> Bool
    || TyCon
    t forall a. Eq a => a -> a -> Bool
    == TyCon
    smallMutableArrayPrimTyCon
                  = forall a. a -> Maybe a
    Just (Profile -> Int
    smallArrPtrsHdrSize Profile
    profile)
               | TyCon
    t forall a. Eq a => a -> a -> Bool
    == TyCon
    byteArrayPrimTyCon Bool -> Bool -> Bool
    || TyCon
    t forall a. Eq a => a -> a -> Bool
    == TyCon
    mutableByteArrayPrimTyCon
                  = forall a. a -> Maybe a
    Just (Profile -> Int
    arrWordsHdrSize Profile
    profile)
               | Bool
    otherwise
                  = forall a. Maybe a
    Nothing

             -- Get the args on the stack, with tags and suitably
             -- dereferenced for the CCall.  For each arg, return the
             -- depth to the first word of the bits for that arg, and the
             -- ArgRep of what was actually pushed.

             pargs
                 :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)]
             pargs :: ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimRep)]
    pargs ByteOff
    _ [] = forall (m :: * -> *) a. Monad m => a -> m a
    return []
             pargs ByteOff
    d (aa :: StgArg
    aa@(StgVarArg Id
    a):[StgArg]
    az)
                | Just TyCon
    t      <- Kind -> Maybe TyCon
    tyConAppTyCon_maybe (Id -> Kind
    idType Id
    a)
                , Just Int
    hdr_sz <- TyCon -> Maybe Int
    arrayish_rep_hdr_size TyCon
    t
                -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
                -- the stack but then advance it over the headers, so as to
                -- point to the payload.
                = do [(OrdList BCInstr, PrimRep)]
    rest <- ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimRep)]
    pargs (ByteOff
    d forall a. Num a => a -> a -> a
    + ByteOff
    addr_size_b) [StgArg]
    az
                     (OrdList BCInstr
    push_fo, ByteOff
    _) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p StgArg
    aa
                     -- The ptr points at the header.  Advance it over the
                     -- header and then pretend this is an Addr#.
                     let code :: OrdList BCInstr
    code = OrdList BCInstr
    push_fo forall a. OrdList a -> a -> OrdList a
    `snocOL` Word16 -> Word16 -> BCInstr
    SWIZZLE Word16
    0 (forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    hdr_sz)
                     forall (m :: * -> *) a. Monad m => a -> m a
    return ((OrdList BCInstr
    code, PrimRep
    AddrRep) forall a. a -> [a] -> [a]
    : [(OrdList BCInstr, PrimRep)]
    rest)
             pargs ByteOff
    d (StgArg
    aa:[StgArg]
    az) =  do (OrdList BCInstr
    code_a, ByteOff
    sz_a) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p StgArg
    aa
                                   [(OrdList BCInstr, PrimRep)]
    rest <- ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimRep)]
    pargs (ByteOff
    d forall a. Num a => a -> a -> a
    + ByteOff
    sz_a) [StgArg]
    az
                                   forall (m :: * -> *) a. Monad m => a -> m a
    return ((OrdList BCInstr
    code_a, StgArg -> PrimRep
    atomPrimRep StgArg
    aa) forall a. a -> [a] -> [a]
    : [(OrdList BCInstr, PrimRep)]
    rest)

         [(OrdList BCInstr, PrimRep)]
    code_n_reps <- ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimRep)]
    pargs ByteOff
    d0 [StgArg]
    args_r_to_l
         let
             ([OrdList BCInstr]
    pushs_arg, [PrimRep]
    a_reps_pushed_r_to_l) = forall a b. [(a, b)] -> ([a], [b])
    unzip [(OrdList BCInstr, PrimRep)]
    code_n_reps
             a_reps_sizeW :: WordOff
    a_reps_sizeW = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum (forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> PrimRep -> WordOff
    repSizeWords Platform
    platform) [PrimRep]
    a_reps_pushed_r_to_l)

             push_args :: OrdList BCInstr
    push_args    = forall a. [OrdList a] -> OrdList a
    concatOL [OrdList BCInstr]
    pushs_arg
             !d_after_args :: ByteOff
    d_after_args = ByteOff
    d0 forall a. Num a => a -> a -> a
    + Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform WordOff
    a_reps_sizeW
             a_reps_pushed_RAW :: [PrimRep]
    a_reps_pushed_RAW
                | forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [PrimRep]
    a_reps_pushed_r_to_l Bool -> Bool -> Bool
    || Bool -> Bool
    not (PrimRep -> Bool
    isVoidRep (forall a. [a] -> a
    head [PrimRep]
    a_reps_pushed_r_to_l))
                = forall a. String -> a
    panic String
    "GHC.StgToByteCode.generateCCall: missing or invalid World token?"
                | Bool
    otherwise
                = forall a. [a] -> [a]
    reverse (forall a. [a] -> [a]
    tail [PrimRep]
    a_reps_pushed_r_to_l)

             -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
             -- push_args is the code to do that.
             -- d_after_args is the stack depth once the args are on.

             -- Get the result rep.
             (Bool
    returns_void, PrimRep
    r_rep)
                = case Kind -> Maybe PrimRep
    maybe_getCCallReturnRep Kind
    result_ty of
                     Maybe PrimRep
    Nothing -> (Bool
    True,  PrimRep
    VoidRep)
                     Just PrimRep
    rr -> (Bool
    False, PrimRep
    rr)
             {-
             Because the Haskell stack grows down, the a_reps refer to
             lowest to highest addresses in that order.  The args for the call
             are on the stack.  Now push an unboxed Addr# indicating
             the C function to call.  Then push a dummy placeholder for the
             result.  Finally, emit a CCALL insn with an offset pointing to the
             Addr# just pushed, and a literal field holding the mallocville
             address of the piece of marshalling code we generate.
             So, just prior to the CCALL insn, the stack looks like this
             (growing down, as usual):

                <arg_n>
                ...
                <arg_1>
                Addr# address_of_C_fn
                <placeholder-for-result#> (must be an unboxed type)

             The interpreter then calls the marshall code mentioned
             in the CCALL insn, passing it (& <placeholder-for-result#>),
             that is, the addr of the topmost word in the stack.
             When this returns, the placeholder will have been
             filled in.  The placeholder is slid down to the sequel
             depth, and we RETURN.

             This arrangement makes it simple to do f-i-dynamic since the Addr#
             value is the first arg anyway.

             The marshalling code is generated specifically for this
             call site, and so knows exactly the (Haskell) stack
             offsets of the args, fn address and placeholder.  It
             copies the args to the C stack, calls the stacked addr,
             and parks the result back in the placeholder.  The interpreter
             calls it as a normal C call, assuming it has a signature
                void marshall_code ( StgWord* ptr_to_top_of_stack )
             -}
             -- resolve static address
             maybe_static_target :: Maybe Literal
             maybe_static_target :: Maybe Literal
    maybe_static_target =
                 case CCallTarget
    target of
                     CCallTarget
    DynamicTarget -> forall a. Maybe a
    Nothing
                     StaticTarget SourceText
    _ FastString
    _ Maybe Unit
    _ Bool
    False ->
                       forall a. String -> a
    panic String
    "generateCCall: unexpected FFI value import"
                     StaticTarget SourceText
    _ FastString
    target Maybe Unit
    _ Bool
    True ->
                       forall a. a -> Maybe a
    Just (FastString -> Maybe Int -> FunctionOrData -> Literal
    LitLabel FastString
    target Maybe Int
    mb_size FunctionOrData
    IsFunction)
                       where
                          mb_size :: Maybe Int
    mb_size
                              | OS
    OSMinGW32 <- Platform -> OS
    platformOS Platform
    platform
                              , CCallConv
    StdCallConv <- CCallConv
    cconv
                              = forall a. a -> Maybe a
    Just (forall a b. (Integral a, Num b) => a -> b
    fromIntegral WordOff
    a_reps_sizeW forall a. Num a => a -> a -> a
    * Platform -> Int
    platformWordSizeInBytes Platform
    platform)
                              | Bool
    otherwise
                              = forall a. Maybe a
    Nothing

         let
             is_static :: Bool
    is_static = forall a. Maybe a -> Bool
    isJust Maybe Literal
    maybe_static_target

             -- Get the arg reps, zapping the leading Addr# in the dynamic case
             a_reps :: [PrimRep]
    a_reps --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
                    | Bool
    is_static = [PrimRep]
    a_reps_pushed_RAW
                    | Bool
    otherwise = if forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [PrimRep]
    a_reps_pushed_RAW
                                  then forall a. String -> a
    panic String
    "GHC.StgToByteCode.generateCCall: dyn with no args"
                                  else forall a. [a] -> [a]
    tail [PrimRep]
    a_reps_pushed_RAW

             -- push the Addr#
             (OrdList BCInstr
    push_Addr, ByteOff
    d_after_Addr)
                | Just Literal
    machlabel <- Maybe Literal
    maybe_static_target
                = (forall a. [a] -> OrdList a
    toOL [Literal -> Word16 -> BCInstr
    PUSH_UBX Literal
    machlabel Word16
    1], ByteOff
    d_after_args forall a. Num a => a -> a -> a
    + ByteOff
    addr_size_b)
                | Bool
    otherwise -- is already on the stack
                = (forall a. OrdList a
    nilOL, ByteOff
    d_after_args)

             -- Push the return placeholder.  For a call returning nothing,
             -- this is a V (tag).
             r_sizeW :: WordOff
    r_sizeW   = Platform -> PrimRep -> WordOff
    repSizeWords Platform
    platform PrimRep
    r_rep
             d_after_r :: ByteOff
    d_after_r = ByteOff
    d_after_Addr forall a. Num a => a -> a -> a
    + Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform WordOff
    r_sizeW
             push_r :: OrdList BCInstr
    push_r =
                 if Bool
    returns_void
                    then forall a. OrdList a
    nilOL
                    else forall a. a -> OrdList a
    unitOL (Literal -> Word16 -> BCInstr
    PUSH_UBX (Platform -> PrimRep -> Literal
    mkDummyLiteral Platform
    platform PrimRep
    r_rep) (WordOff -> Word16
    trunc16W WordOff
    r_sizeW))

             -- generate the marshalling code we're going to call

             -- Offset of the next stack frame down the stack.  The CCALL
             -- instruction needs to describe the chunk of stack containing
             -- the ccall args to the GC, so it needs to know how large it
             -- is.  See comment in Interpreter.c with the CCALL instruction.
             stk_offset :: Word16
    stk_offset   = WordOff -> Word16
    trunc16W forall a b. (a -> b) -> a -> b
    $ Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    d_after_r forall a. Num a => a -> a -> a
    - ByteOff
    s)

             conv :: FFIConv
    conv = case CCallConv
    cconv of
               CCallConv
    CCallConv -> FFIConv
    FFICCall
               CCallConv
    CApiConv  -> FFIConv
    FFICCall
               CCallConv
    StdCallConv -> FFIConv
    FFIStdCall
               CCallConv
    _ -> forall a. String -> a
    panic String
    "GHC.StgToByteCode: unexpected calling convention"

         -- the only difference in libffi mode is that we prepare a cif
         -- describing the call type by calling libffi, and we attach the
         -- address of this to the CCALL instruction.

         let ffires :: FFIType
    ffires = Platform -> PrimRep -> FFIType
    primRepToFFIType Platform
    platform PrimRep
    r_rep
             ffiargs :: [FFIType]
    ffiargs = forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> PrimRep -> FFIType
    primRepToFFIType Platform
    platform) [PrimRep]
    a_reps
         Interp
    interp <- HscEnv -> Interp
    hscInterp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM HscEnv
    getHscEnv
         RemotePtr C_ffi_cif
    token <- forall a. IO a -> BcM a
    ioToBc forall a b. (a -> b) -> a -> b
    $ forall a. Binary a => Interp -> Message a -> IO a
    interpCmd Interp
    interp (FFIConv -> [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif)
    PrepFFI FFIConv
    conv [FFIType]
    ffiargs FFIType
    ffires)
         RemotePtr C_ffi_cif -> BcM ()
    recordFFIBc RemotePtr C_ffi_cif
    token

         let
             -- do the call
             do_call :: OrdList BCInstr
    do_call      = forall a. a -> OrdList a
    unitOL (Word16 -> RemotePtr C_ffi_cif -> Word16 -> BCInstr
    CCALL Word16
    stk_offset RemotePtr C_ffi_cif
    token Word16
    flags)
               where flags :: Word16
    flags = case Safety
    safety of
                               Safety
    PlaySafe          -> Word16
    0x0
                               Safety
    PlayInterruptible -> Word16
    0x1
                               Safety
    PlayRisky         -> Word16
    0x2

             -- slide and return
             d_after_r_min_s :: WordOff
    d_after_r_min_s = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    d_after_r forall a. Num a => a -> a -> a
    - ByteOff
    s)
             wrapup :: OrdList BCInstr
    wrapup       = Word16 -> WordOff -> OrdList BCInstr
    mkSlideW (WordOff -> Word16
    trunc16W WordOff
    r_sizeW) (WordOff
    d_after_r_min_s forall a. Num a => a -> a -> a
    - WordOff
    r_sizeW)
                            forall a. OrdList a -> a -> OrdList a
    `snocOL` ArgRep -> BCInstr
    RETURN_UNLIFTED (Platform -> PrimRep -> ArgRep
    toArgRep Platform
    platform PrimRep
    r_rep)
             --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $
         forall (m :: * -> *) a. Monad m => a -> m a
    return (
             OrdList BCInstr
    push_args forall a. OrdList a -> OrdList a -> OrdList a
    `appOL`
             OrdList BCInstr
    push_Addr forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` OrdList BCInstr
    push_r forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` OrdList BCInstr
    do_call forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` OrdList BCInstr
    wrapup
             )

    primRepToFFIType :: Platform -> PrimRep -> FFIType
    primRepToFFIType :: Platform -> PrimRep -> FFIType
    primRepToFFIType Platform
    platform PrimRep
    r
      = case PrimRep
    r of
         PrimRep
    VoidRep     -> FFIType
    FFIVoid
         PrimRep
    IntRep      -> FFIType
    signed_word
         PrimRep
    WordRep     -> FFIType
    unsigned_word
         PrimRep
    Int8Rep     -> FFIType
    FFISInt8
         PrimRep
    Word8Rep    -> FFIType
    FFIUInt8
         PrimRep
    Int16Rep    -> FFIType
    FFISInt16
         PrimRep
    Word16Rep   -> FFIType
    FFIUInt16
         PrimRep
    Int32Rep    -> FFIType
    FFISInt32
         PrimRep
    Word32Rep   -> FFIType
    FFIUInt32
         PrimRep
    Int64Rep    -> FFIType
    FFISInt64
         PrimRep
    Word64Rep   -> FFIType
    FFIUInt64
         PrimRep
    AddrRep     -> FFIType
    FFIPointer
         PrimRep
    FloatRep    -> FFIType
    FFIFloat
         PrimRep
    DoubleRep   -> FFIType
    FFIDouble
         PrimRep
    _           -> forall a. String -> a
    panic String
    "primRepToFFIType"
      where
        (FFIType
    signed_word, FFIType
    unsigned_word) = case Platform -> PlatformWordSize
    platformWordSize Platform
    platform of
           PlatformWordSize
    PW4 -> (FFIType
    FFISInt32, FFIType
    FFIUInt32)
           PlatformWordSize
    PW8 -> (FFIType
    FFISInt64, FFIType
    FFIUInt64)

    -- Make a dummy literal, to be used as a placeholder for FFI return
    -- values on the stack.
    mkDummyLiteral :: Platform -> PrimRep -> Literal
    mkDummyLiteral :: Platform -> PrimRep -> Literal
    mkDummyLiteral Platform
    platform PrimRep
    pr
       = case PrimRep
    pr of
            PrimRep
    IntRep    -> Platform -> Integer -> Literal
    mkLitInt  Platform
    platform Integer
    0
            PrimRep
    WordRep   -> Platform -> Integer -> Literal
    mkLitWord Platform
    platform Integer
    0
            PrimRep
    Int8Rep   -> Integer -> Literal
    mkLitInt8 Integer
    0
            PrimRep
    Word8Rep  -> Integer -> Literal
    mkLitWord8 Integer
    0
            PrimRep
    Int16Rep  -> Integer -> Literal
    mkLitInt16 Integer
    0
            PrimRep
    Word16Rep -> Integer -> Literal
    mkLitWord16 Integer
    0
            PrimRep
    Int32Rep  -> Integer -> Literal
    mkLitInt32 Integer
    0
            PrimRep
    Word32Rep -> Integer -> Literal
    mkLitWord32 Integer
    0
            PrimRep
    Int64Rep  -> Integer -> Literal
    mkLitInt64 Integer
    0
            PrimRep
    Word64Rep -> Integer -> Literal
    mkLitWord64 Integer
    0
            PrimRep
    AddrRep   -> Literal
    LitNullAddr
            PrimRep
    DoubleRep -> Rational -> Literal
    LitDouble Rational
    0
            PrimRep
    FloatRep  -> Rational -> Literal
    LitFloat Rational
    0
            PrimRep
    _         -> forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "mkDummyLiteral" (forall a. Outputable a => a -> SDoc
    ppr PrimRep
    pr)

    -- Convert (eg)
    --     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
    --                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
    --
    -- to  Just IntRep
    -- and check that an unboxed pair is returned wherein the first arg is V'd.
    --
    -- Alternatively, for call-targets returning nothing, convert
    --
    --     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
    --                   -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
    --
    -- to  Nothing

    maybe_getCCallReturnRep :: Type -> Maybe PrimRep
    maybe_getCCallReturnRep :: Kind -> Maybe PrimRep
    maybe_getCCallReturnRep Kind
    fn_ty
       = let
           ([Scaled Kind]
    _a_tys, Kind
    r_ty) = Kind -> ([Scaled Kind], Kind)
    splitFunTys (Kind -> Kind
    dropForAlls Kind
    fn_ty)
           r_reps :: [PrimRep]
    r_reps = HasDebugCallStack => Kind -> [PrimRep]
    typePrimRepArgs Kind
    r_ty

           blargh :: a -- Used at more than one type
           blargh :: forall a. a
    blargh = forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "maybe_getCCallReturn: can't handle:"
                             (Kind -> SDoc
    pprType Kind
    fn_ty)
         in
           case [PrimRep]
    r_reps of
             []            -> forall a. String -> a
    panic String
    "empty typePrimRepArgs"
             [PrimRep
    VoidRep]     -> forall a. Maybe a
    Nothing
             [PrimRep
    rep]
               | PrimRep -> Bool
    isGcPtrRep PrimRep
    rep -> forall a. a
    blargh
               | Bool
    otherwise      -> forall a. a -> Maybe a
    Just PrimRep
    rep

                     -- if it was, it would be impossible to create a
                     -- valid return value placeholder on the stack
             [PrimRep]
    _             -> forall a. a
    blargh

    maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])
    -- Detect and extract relevant info for the tagToEnum kludge.
    maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])
    maybe_is_tagToEnum_call (StgOpApp (StgPrimOp PrimOp
    TagToEnumOp) [StgVarArg Id
    v] Kind
    t)
      = forall a. a -> Maybe a
    Just (Id
    v, Kind -> [Name]
    extract_constr_Names Kind
    t)
      where
        extract_constr_Names :: Kind -> [Name]
    extract_constr_Names Kind
    ty
               | Kind
    rep_ty <- Kind -> Kind
    unwrapType Kind
    ty
               , Just TyCon
    tyc <- Kind -> Maybe TyCon
    tyConAppTyCon_maybe Kind
    rep_ty
               , TyCon -> Bool
    isDataTyCon TyCon
    tyc
               = forall a b. (a -> b) -> [a] -> [b]
    map (forall a. NamedThing a => a -> Name
    getName forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DataCon -> Id
    dataConWorkId) (TyCon -> [DataCon]
    tyConDataCons TyCon
    tyc)
               -- NOTE: use the worker name, not the source name of
               -- the DataCon.  See "GHC.Core.DataCon" for details.
               | Bool
    otherwise
               = forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "maybe_is_tagToEnum_call.extract_constr_Ids" (forall a. Outputable a => a -> SDoc
    ppr Kind
    ty)
    maybe_is_tagToEnum_call CgStgExpr
    _ = forall a. Maybe a
    Nothing

    {- -----------------------------------------------------------------------------
    Note [Implementing tagToEnum#]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    (implement_tagToId arg names) compiles code which takes an argument
    'arg', (call it i), and enters the i'th closure in the supplied list
    as a consequence.  The [Name] is a list of the constructors of this
    (enumeration) type.

    The code we generate is this:
                    push arg
                    push bogus-word

                    TESTEQ_I 0 L1
                      PUSH_G <lbl for first data con>
                      JMP L_Exit

            L1:     TESTEQ_I 1 L2
                      PUSH_G <lbl for second data con>
                      JMP L_Exit
            ...etc...
            Ln:     TESTEQ_I n L_fail
                      PUSH_G <lbl for last data con>
                      JMP L_Exit

            L_fail: CASEFAIL

            L_exit: SLIDE 1 n
                    ENTER

    The 'bogus-word' push is because TESTEQ_I expects the top of the stack
    to have an info-table, and the next word to have the value to be
    tested.  This is very weird, but it's the way it is right now.  See
    Interpreter.c.  We don't actually need an info-table here; we just
    need to have the argument to be one-from-top on the stack, hence pushing
    a 1-word null. See #8383.
    -}

    implement_tagToId
        :: StackDepth
        -> Sequel
        -> BCEnv
        -> Id
        -> [Name]
        -> BcM BCInstrList
    -- See Note [Implementing tagToEnum#]
    implement_tagToId :: ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> Id
    -> [Name]
    -> BcM (OrdList BCInstr)
    implement_tagToId ByteOff
    d ByteOff
    s Map Id ByteOff
    p Id
    arg [Name]
    names
      = ASSERT( notNull names )
        do (OrdList BCInstr
    push_arg, ByteOff
    arg_bytes) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p (Id -> StgArg
    StgVarArg Id
    arg)
           [LocalLabel]
    labels <- Word32 -> BcM [LocalLabel]
    getLabelsBc (forall i a. Num i => [a] -> i
    genericLength [Name]
    names)
           LocalLabel
    label_fail <- BcM LocalLabel
    getLabelBc
           LocalLabel
    label_exit <- BcM LocalLabel
    getLabelBc
           DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
           let infos :: [(LocalLabel, LocalLabel, Int, Name)]
    infos = forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
    zip4 [LocalLabel]
    labels (forall a. [a] -> [a]
    tail [LocalLabel]
    labels forall a. [a] -> [a] -> [a]
    ++ [LocalLabel
    label_fail])
                                   [Int
    0 ..] [Name]
    names
               platform :: Platform
    platform = DynFlags -> Platform
    targetPlatform DynFlags
    dflags
               steps :: [OrdList BCInstr]
    steps = forall a b. (a -> b) -> [a] -> [b]
    map (LocalLabel
    -> (LocalLabel, LocalLabel, Int, Name) -> OrdList BCInstr
    mkStep LocalLabel
    label_exit) [(LocalLabel, LocalLabel, Int, Name)]
    infos
               slide_ws :: WordOff
    slide_ws = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    d forall a. Num a => a -> a -> a
    - ByteOff
    s forall a. Num a => a -> a -> a
    + ByteOff
    arg_bytes)

           forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList BCInstr
    push_arg
                   forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` forall a. a -> OrdList a
    unitOL (Literal -> Word16 -> BCInstr
    PUSH_UBX Literal
    LitNullAddr Word16
    1)
                       -- Push bogus word (see Note [Implementing tagToEnum#])
                   forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` forall a. [OrdList a] -> OrdList a
    concatOL [OrdList BCInstr]
    steps
                   forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` forall a. [a] -> OrdList a
    toOL [ LocalLabel -> BCInstr
    LABEL LocalLabel
    label_fail, BCInstr
    CASEFAIL,
                                  LocalLabel -> BCInstr
    LABEL LocalLabel
    label_exit ]
                   forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` Word16 -> WordOff -> OrdList BCInstr
    mkSlideW Word16
    1 (WordOff
    slide_ws forall a. Num a => a -> a -> a
    + WordOff
    1)
                       -- "+1" to account for bogus word
                       --      (see Note [Implementing tagToEnum#])
                   forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` forall a. a -> OrdList a
    unitOL BCInstr
    ENTER)
      where
            mkStep :: LocalLabel
    -> (LocalLabel, LocalLabel, Int, Name) -> OrdList BCInstr
    mkStep LocalLabel
    l_exit (LocalLabel
    my_label, LocalLabel
    next_label, Int
    n, Name
    name_for_n)
               = forall a. [a] -> OrdList a
    toOL [LocalLabel -> BCInstr
    LABEL LocalLabel
    my_label,
                       Int -> LocalLabel -> BCInstr
    TESTEQ_I Int
    n LocalLabel
    next_label,
                       Name -> BCInstr
    PUSH_G Name
    name_for_n,
                       LocalLabel -> BCInstr
    JMP LocalLabel
    l_exit]

    -- -----------------------------------------------------------------------------
    -- pushAtom

    -- Push an atom onto the stack, returning suitable code & number of
    -- stack words used.
    --
    -- The env p must map each variable to the highest- numbered stack
    -- slot for it.  For example, if the stack has depth 4 and we
    -- tagged-ly push (v :: Int#) on it, the value will be in stack[4],
    -- the tag in stack[5], the stack will have depth 6, and p must map v
    -- to 5 and not to 4.  Stack locations are numbered from zero, so a
    -- depth 6 stack has valid words 0 .. 5.

    pushAtom
        :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)

    -- See Note [Empty case alternatives] in GHC.Core
    -- and Note [Bottoming expressions] in GHC.Core.Utils:
    -- The scrutinee of an empty case evaluates to bottom
    pushAtom :: ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p (StgVarArg Id
    var)
       | [] <- HasDebugCallStack => Kind -> [PrimRep]
    typePrimRep (Id -> Kind
    idType Id
    var)
       = forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. OrdList a
    nilOL, ByteOff
    0)

       | Id -> Bool
    isFCallId Id
    var
       = forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "pushAtom: shouldn't get an FCallId here" (forall a. Outputable a => a -> SDoc
    ppr Id
    var)

       | Just PrimOp
    primop <- Id -> Maybe PrimOp
    isPrimOpId_maybe Id
    var
       = do
           Platform
    platform <- DynFlags -> Platform
    targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
           forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. a -> OrdList a
    unitOL (PrimOp -> BCInstr
    PUSH_PRIMOP PrimOp
    primop), Platform -> ByteOff
    wordSize Platform
    platform)

       | Just ByteOff
    d_v <- Id -> Map Id ByteOff -> Maybe ByteOff
    lookupBCEnv_maybe Id
    var Map Id ByteOff
    p  -- var is a local variable
       = do Platform
    platform <- DynFlags -> Platform
    targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags

            let !szb :: ByteOff
    szb = Platform -> Id -> ByteOff
    idSizeCon Platform
    platform Id
    var
                with_instr :: (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    with_instr Word16 -> BCInstr
    instr = do
                    let !off_b :: Word16
    off_b = ByteOff -> Word16
    trunc16B forall a b. (a -> b) -> a -> b
    $ ByteOff
    d forall a. Num a => a -> a -> a
    - ByteOff
    d_v
                    forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. a -> OrdList a
    unitOL (Word16 -> BCInstr
    instr Word16
    off_b), Platform -> ByteOff
    wordSize Platform
    platform)

            case ByteOff
    szb of
                ByteOff
    1 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    with_instr Word16 -> BCInstr
    PUSH8_W
                ByteOff
    2 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    with_instr Word16 -> BCInstr
    PUSH16_W
                ByteOff
    4 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    with_instr Word16 -> BCInstr
    PUSH32_W
                ByteOff
    _ -> do
                    let !szw :: WordOff
    szw = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform ByteOff
    szb
                        !off_w :: Word16
    off_w = WordOff -> Word16
    trunc16W forall a b. (a -> b) -> a -> b
    $ Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    d forall a. Num a => a -> a -> a
    - ByteOff
    d_v) forall a. Num a => a -> a -> a
    + WordOff
    szw forall a. Num a => a -> a -> a
    - WordOff
    1
                    forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. [a] -> OrdList a
    toOL (forall i a. Integral i => i -> a -> [a]
    genericReplicate WordOff
    szw (Word16 -> BCInstr
    PUSH_L Word16
    off_w)),
                                  Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform WordOff
    szw)
            -- d - d_v           offset from TOS to the first slot of the object
            --
            -- d - d_v + sz - 1  offset from the TOS of the last slot of the object
            --
            -- Having found the last slot, we proceed to copy the right number of
            -- slots on to the top of the stack.

       | Bool
    otherwise  -- var must be a global variable
       = do IdEnv (RemotePtr ())
    topStrings <- BcM (IdEnv (RemotePtr ()))
    getTopStrings
            Platform
    platform <- DynFlags -> Platform
    targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
            case forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv IdEnv (RemotePtr ())
    topStrings Id
    var of
                Just RemotePtr ()
    ptr -> ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p forall a b. (a -> b) -> a -> b
    $ Literal -> StgArg
    StgLitArg forall a b. (a -> b) -> a -> b
    $ Platform -> Integer -> Literal
    mkLitWord Platform
    platform forall a b. (a -> b) -> a -> b
    $
                  forall a b. (Integral a, Num b) => a -> b
    fromIntegral forall a b. (a -> b) -> a -> b
    $ forall a. Ptr a -> WordPtr
    ptrToWordPtr forall a b. (a -> b) -> a -> b
    $ forall a. RemotePtr a -> Ptr a
    fromRemotePtr RemotePtr ()
    ptr
                Maybe (RemotePtr ())
    Nothing -> do
                    let sz :: ByteOff
    sz = Platform -> Id -> ByteOff
    idSizeCon Platform
    platform Id
    var
                    MASSERT( sz == wordSize platform )
                    forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. a -> OrdList a
    unitOL (Name -> BCInstr
    PUSH_G (forall a. NamedThing a => a -> Name
    getName Id
    var)), ByteOff
    sz)

    pushAtom ByteOff
    _ Map Id ByteOff
    _ (StgLitArg Literal
    lit) = Bool -> Literal -> BcM (OrdList BCInstr, ByteOff)
    pushLiteral Bool
    True Literal
    lit

    pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff)
    pushLiteral :: Bool -> Literal -> BcM (OrdList BCInstr, ByteOff)
    pushLiteral Bool
    padded Literal
    lit =
      do
         Platform
    platform <- DynFlags -> Platform
    targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
         let code :: PrimRep -> BcM (BCInstrList, ByteOff)
             code :: PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    rep =
                forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList BCInstr
    padding_instr forall a. OrdList a -> a -> OrdList a
    `snocOL` BCInstr
    instr, ByteOff
    size_bytes forall a. Num a => a -> a -> a
    + ByteOff
    padding_bytes)
              where
                size_bytes :: ByteOff
    size_bytes = Int -> ByteOff
    ByteOff forall a b. (a -> b) -> a -> b
    $ Platform -> PrimRep -> Int
    primRepSizeB Platform
    platform PrimRep
    rep

                -- Here we handle the non-word-width cases specifically since we
                -- must emit different bytecode for them.

                round_to_words :: ByteOff -> ByteOff
    round_to_words (ByteOff Int
    bytes) =
                  Int -> ByteOff
    ByteOff (Platform -> Int -> Int
    roundUpToWords Platform
    platform Int
    bytes)

                padding_bytes :: ByteOff
    padding_bytes
                    | Bool
    padded    = ByteOff -> ByteOff
    round_to_words ByteOff
    size_bytes forall a. Num a => a -> a -> a
    - ByteOff
    size_bytes
                    | Bool
    otherwise = ByteOff
    0

                (OrdList BCInstr
    padding_instr, ByteOff
    _) = ByteOff -> (OrdList BCInstr, ByteOff)
    pushPadding ByteOff
    padding_bytes

                instr :: BCInstr
    instr =
                  case ByteOff
    size_bytes of
                    ByteOff
    1  -> Literal -> BCInstr
    PUSH_UBX8 Literal
    lit
                    ByteOff
    2  -> Literal -> BCInstr
    PUSH_UBX16 Literal
    lit
                    ByteOff
    4  -> Literal -> BCInstr
    PUSH_UBX32 Literal
    lit
                    ByteOff
    _  -> Literal -> Word16 -> BCInstr
    PUSH_UBX Literal
    lit (WordOff -> Word16
    trunc16W forall a b. (a -> b) -> a -> b
    $ Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform ByteOff
    size_bytes)

         case Literal
    lit of
            LitLabel {}     -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    AddrRep
            LitFloat {}     -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    FloatRep
            LitDouble {}    -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    DoubleRep
            LitChar {}      -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    WordRep
            Literal
    LitNullAddr     -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    AddrRep
            LitString {}    -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    AddrRep
            LitRubbish {}   -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    WordRep
            LitNumber LitNumType
    nt Integer
    _  -> case LitNumType
    nt of
              LitNumType
    LitNumInt     -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    IntRep
              LitNumType
    LitNumWord    -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    WordRep
              LitNumType
    LitNumInt8    -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    Int8Rep
              LitNumType
    LitNumWord8   -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    Word8Rep
              LitNumType
    LitNumInt16   -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    Int16Rep
              LitNumType
    LitNumWord16  -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    Word16Rep
              LitNumType
    LitNumInt32   -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    Int32Rep
              LitNumType
    LitNumWord32  -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    Word32Rep
              LitNumType
    LitNumInt64   -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    Int64Rep
              LitNumType
    LitNumWord64  -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    Word64Rep
              -- No LitInteger's or LitNatural's should be left by the time this is
              -- called. CorePrep should have converted them all to a real core
              -- representation.
              LitNumType
    LitNumInteger -> forall a. String -> a
    panic String
    "pushAtom: LitInteger"
              LitNumType
    LitNumNatural -> forall a. String -> a
    panic String
    "pushAtom: LitNatural"

    -- | Push an atom for constructor (i.e., PACK instruction) onto the stack.
    -- This is slightly different to @pushAtom@ due to the fact that we allow
    -- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.
    pushConstrAtom
        :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
    pushConstrAtom :: ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushConstrAtom ByteOff
    _ Map Id ByteOff
    _ (StgLitArg Literal
    lit) = Bool -> Literal -> BcM (OrdList BCInstr, ByteOff)
    pushLiteral Bool
    False Literal
    lit

    pushConstrAtom ByteOff
    d Map Id ByteOff
    p va :: StgArg
    va@(StgVarArg Id
    v)
        | Just ByteOff
    d_v <- Id -> Map Id ByteOff -> Maybe ByteOff
    lookupBCEnv_maybe Id
    v Map Id ByteOff
    p = do  -- v is a local variable
            Platform
    platform <- DynFlags -> Platform
    targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
            let !szb :: ByteOff
    szb = Platform -> Id -> ByteOff
    idSizeCon Platform
    platform Id
    v
                done :: (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    done Word16 -> BCInstr
    instr = do
                    let !off :: Word16
    off = ByteOff -> Word16
    trunc16B forall a b. (a -> b) -> a -> b
    $ ByteOff
    d forall a. Num a => a -> a -> a
    - ByteOff
    d_v
                    forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. a -> OrdList a
    unitOL (Word16 -> BCInstr
    instr Word16
    off), ByteOff
    szb)
            case ByteOff
    szb of
                ByteOff
    1 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    done Word16 -> BCInstr
    PUSH8
                ByteOff
    2 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    done Word16 -> BCInstr
    PUSH16
                ByteOff
    4 -> (Word16 -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    done Word16 -> BCInstr
    PUSH32
                ByteOff
    _ -> ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p StgArg
    va

    pushConstrAtom ByteOff
    d Map Id ByteOff
    p StgArg
    expr = ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p StgArg
    expr

    pushPadding :: ByteOff -> (BCInstrList, ByteOff)
    pushPadding :: ByteOff -> (OrdList BCInstr, ByteOff)
    pushPadding (ByteOff Int
    n) = forall {t} {b}.
    (Eq t, Num t, Num b) =>
    t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
    go Int
    n (forall a. OrdList a
    nilOL, ByteOff
    0)
      where
        go :: t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
    go t
    n acc :: (OrdList BCInstr, b)
    acc@(!OrdList BCInstr
    instrs, !b
    off) = case t
    n of
            t
    0 -> (OrdList BCInstr, b)
    acc
            t
    1 -> (OrdList BCInstr
    instrs forall a. Monoid a => a -> a -> a
    `mappend` forall a. a -> OrdList a
    unitOL BCInstr
    PUSH_PAD8, b
    off forall a. Num a => a -> a -> a
    + b
    1)
            t
    2 -> (OrdList BCInstr
    instrs forall a. Monoid a => a -> a -> a
    `mappend` forall a. a -> OrdList a
    unitOL BCInstr
    PUSH_PAD16, b
    off forall a. Num a => a -> a -> a
    + b
    2)
            t
    3 -> t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
    go t
    1 (t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
    go t
    2 (OrdList BCInstr, b)
    acc)
            t
    4 -> (OrdList BCInstr
    instrs forall a. Monoid a => a -> a -> a
    `mappend` forall a. a -> OrdList a
    unitOL BCInstr
    PUSH_PAD32, b
    off forall a. Num a => a -> a -> a
    + b
    4)
            t
    _ -> t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
    go (t
    n forall a. Num a => a -> a -> a
    - t
    4) (t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
    go t
    4 (OrdList BCInstr, b)
    acc)

    -- -----------------------------------------------------------------------------
    -- Given a bunch of alts code and their discrs, do the donkey work
    -- of making a multiway branch using a switch tree.
    -- What a load of hassle!

    mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt
                                    -- a hint; generates better code
                                    -- Nothing is always safe
                  -> [(Discr, BCInstrList)]
                  -> BcM BCInstrList
    mkMultiBranch :: Maybe Int -> [(Discr, OrdList BCInstr)] -> BcM (OrdList BCInstr)
    mkMultiBranch Maybe Int
    maybe_ncons [(Discr, OrdList BCInstr)]
    raw_ways = do
         LocalLabel
    lbl_default <- BcM LocalLabel
    getLabelBc

         let
             mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
             mkTree :: [(Discr, OrdList BCInstr)]
    -> Discr -> Discr -> BcM (OrdList BCInstr)
    mkTree [] Discr
    _range_lo Discr
    _range_hi = forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. a -> OrdList a
    unitOL (LocalLabel -> BCInstr
    JMP LocalLabel
    lbl_default))
                 -- shouldn't happen?

             mkTree [(Discr, OrdList BCInstr)
    val] Discr
    range_lo Discr
    range_hi
                | Discr
    range_lo forall a. Eq a => a -> a -> Bool
    == Discr
    range_hi
                = forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a b. (a, b) -> b
    snd (Discr, OrdList BCInstr)
    val)
                | forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [(Discr, OrdList BCInstr)]
    defaults -- Note [CASEFAIL]
                = do LocalLabel
    lbl <- BcM LocalLabel
    getLabelBc
                     forall (m :: * -> *) a. Monad m => a -> m a
    return (Discr -> LocalLabel -> BCInstr
    testEQ (forall a b. (a, b) -> a
    fst (Discr, OrdList BCInstr)
    val) LocalLabel
    lbl
                                forall a. a -> OrdList a -> OrdList a
    `consOL` (forall a b. (a, b) -> b
    snd (Discr, OrdList BCInstr)
    val
                                forall a. OrdList a -> OrdList a -> OrdList a
    `appOL`  (LocalLabel -> BCInstr
    LABEL LocalLabel
    lbl forall a. a -> OrdList a -> OrdList a
    `consOL` forall a. a -> OrdList a
    unitOL BCInstr
    CASEFAIL)))
                | Bool
    otherwise
                = forall (m :: * -> *) a. Monad m => a -> m a
    return (Discr -> LocalLabel -> BCInstr
    testEQ (forall a b. (a, b) -> a
    fst (Discr, OrdList BCInstr)
    val) LocalLabel
    lbl_default forall a. a -> OrdList a -> OrdList a
    `consOL` forall a b. (a, b) -> b
    snd (Discr, OrdList BCInstr)
    val)

                -- Note [CASEFAIL] It may be that this case has no default
                -- branch, but the alternatives are not exhaustive - this
                -- happens for GADT cases for example, where the types
                -- prove that certain branches are impossible.  We could
                -- just assume that the other cases won't occur, but if
                -- this assumption was wrong (because of a bug in GHC)
                -- then the result would be a segfault.  So instead we
                -- emit an explicit test and a CASEFAIL instruction that
                -- causes the interpreter to barf() if it is ever
                -- executed.

             mkTree [(Discr, OrdList BCInstr)]
    vals Discr
    range_lo Discr
    range_hi
                = let n :: Int
    n = forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Discr, OrdList BCInstr)]
    vals forall a. Integral a => a -> a -> a
    `div` Int
    2
                      vals_lo :: [(Discr, OrdList BCInstr)]
    vals_lo = forall a. Int -> [a] -> [a]
    take Int
    n [(Discr, OrdList BCInstr)]
    vals
                      vals_hi :: [(Discr, OrdList BCInstr)]
    vals_hi = forall a. Int -> [a] -> [a]
    drop Int
    n [(Discr, OrdList BCInstr)]
    vals
                      v_mid :: Discr
    v_mid = forall a b. (a, b) -> a
    fst (forall a. [a] -> a
    head [(Discr, OrdList BCInstr)]
    vals_hi)
                  in do
                  LocalLabel
    label_geq <- BcM LocalLabel
    getLabelBc
                  OrdList BCInstr
    code_lo <- [(Discr, OrdList BCInstr)]
    -> Discr -> Discr -> BcM (OrdList BCInstr)
    mkTree [(Discr, OrdList BCInstr)]
    vals_lo Discr
    range_lo (Discr -> Discr
    dec Discr
    v_mid)
                  OrdList BCInstr
    code_hi <- [(Discr, OrdList BCInstr)]
    -> Discr -> Discr -> BcM (OrdList BCInstr)
    mkTree [(Discr, OrdList BCInstr)]
    vals_hi Discr
    v_mid Discr
    range_hi
                  forall (m :: * -> *) a. Monad m => a -> m a
    return (Discr -> LocalLabel -> BCInstr
    testLT Discr
    v_mid LocalLabel
    label_geq
                          forall a. a -> OrdList a -> OrdList a
    `consOL` (OrdList BCInstr
    code_lo
                          forall a. OrdList a -> OrdList a -> OrdList a
    `appOL`   forall a. a -> OrdList a
    unitOL (LocalLabel -> BCInstr
    LABEL LocalLabel
    label_geq)
                          forall a. OrdList a -> OrdList a -> OrdList a
    `appOL`   OrdList BCInstr
    code_hi))

             the_default :: OrdList BCInstr
    the_default
                = case [(Discr, OrdList BCInstr)]
    defaults of
                    []         -> forall a. OrdList a
    nilOL
                    [(Discr
    _, OrdList BCInstr
    def)] -> LocalLabel -> BCInstr
    LABEL LocalLabel
    lbl_default forall a. a -> OrdList a -> OrdList a
    `consOL` OrdList BCInstr
    def
                    [(Discr, OrdList BCInstr)]
    _          -> forall a. String -> a
    panic String
    "mkMultiBranch/the_default"
         OrdList BCInstr
    instrs <- [(Discr, OrdList BCInstr)]
    -> Discr -> Discr -> BcM (OrdList BCInstr)
    mkTree [(Discr, OrdList BCInstr)]
    notd_ways Discr
    init_lo Discr
    init_hi
         forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList BCInstr
    instrs forall a. OrdList a -> OrdList a -> OrdList a
    `appOL` OrdList BCInstr
    the_default)
      where
             ([(Discr, OrdList BCInstr)]
    defaults, [(Discr, OrdList BCInstr)]
    not_defaults) = forall a. (a -> Bool) -> [a] -> ([a], [a])
    partition (Discr -> Bool
    isNoDiscrforall b c a. (b -> c) -> (a -> b) -> a -> c
    .forall a b. (a, b) -> a
    fst) [(Discr, OrdList BCInstr)]
    raw_ways
             notd_ways :: [(Discr, OrdList BCInstr)]
    notd_ways = forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
    comparing forall a b. (a, b) -> a
    fst) [(Discr, OrdList BCInstr)]
    not_defaults

             testLT :: Discr -> LocalLabel -> BCInstr
    testLT (DiscrI Int
    i) LocalLabel
    fail_label = Int -> LocalLabel -> BCInstr
    TESTLT_I Int
    i LocalLabel
    fail_label
             testLT (DiscrW Word
    i) LocalLabel
    fail_label = Word -> LocalLabel -> BCInstr
    TESTLT_W Word
    i LocalLabel
    fail_label
             testLT (DiscrF Float
    i) LocalLabel
    fail_label = Float -> LocalLabel -> BCInstr
    TESTLT_F Float
    i LocalLabel
    fail_label
             testLT (DiscrD Double
    i) LocalLabel
    fail_label = Double -> LocalLabel -> BCInstr
    TESTLT_D Double
    i LocalLabel
    fail_label
             testLT (DiscrP Word16
    i) LocalLabel
    fail_label = Word16 -> LocalLabel -> BCInstr
    TESTLT_P Word16
    i LocalLabel
    fail_label
             testLT Discr
    NoDiscr    LocalLabel
    _          = forall a. String -> a
    panic String
    "mkMultiBranch NoDiscr"

             testEQ :: Discr -> LocalLabel -> BCInstr
    testEQ (DiscrI Int
    i) LocalLabel
    fail_label = Int -> LocalLabel -> BCInstr
    TESTEQ_I Int
    i LocalLabel
    fail_label
             testEQ (DiscrW Word
    i) LocalLabel
    fail_label = Word -> LocalLabel -> BCInstr
    TESTEQ_W Word
    i LocalLabel
    fail_label
             testEQ (DiscrF Float
    i) LocalLabel
    fail_label = Float -> LocalLabel -> BCInstr
    TESTEQ_F Float
    i LocalLabel
    fail_label
             testEQ (DiscrD Double
    i) LocalLabel
    fail_label = Double -> LocalLabel -> BCInstr
    TESTEQ_D Double
    i LocalLabel
    fail_label
             testEQ (DiscrP Word16
    i) LocalLabel
    fail_label = Word16 -> LocalLabel -> BCInstr
    TESTEQ_P Word16
    i LocalLabel
    fail_label
             testEQ Discr
    NoDiscr    LocalLabel
    _          = forall a. String -> a
    panic String
    "mkMultiBranch NoDiscr"

             -- None of these will be needed if there are no non-default alts
             (Discr
    init_lo, Discr
    init_hi)
                | forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [(Discr, OrdList BCInstr)]
    notd_ways
                = forall a. String -> a
    panic String
    "mkMultiBranch: awesome foursome"
                | Bool
    otherwise
                = case forall a b. (a, b) -> a
    fst (forall a. [a] -> a
    head [(Discr, OrdList BCInstr)]
    notd_ways) of
                    DiscrI Int
    _ -> ( Int -> Discr
    DiscrI forall a. Bounded a => a
    minBound,  Int -> Discr
    DiscrI forall a. Bounded a => a
    maxBound )
                    DiscrW Word
    _ -> ( Word -> Discr
    DiscrW forall a. Bounded a => a
    minBound,  Word -> Discr
    DiscrW forall a. Bounded a => a
    maxBound )
                    DiscrF Float
    _ -> ( Float -> Discr
    DiscrF Float
    minF,      Float -> Discr
    DiscrF Float
    maxF )
                    DiscrD Double
    _ -> ( Double -> Discr
    DiscrD Double
    minD,      Double -> Discr
    DiscrD Double
    maxD )
                    DiscrP Word16
    _ -> ( Word16 -> Discr
    DiscrP Word16
    algMinBound, Word16 -> Discr
    DiscrP Word16
    algMaxBound )
                    Discr
    NoDiscr -> forall a. String -> a
    panic String
    "mkMultiBranch NoDiscr"

             (Word16
    algMinBound, Word16
    algMaxBound)
                = case Maybe Int
    maybe_ncons of
                     -- XXX What happens when n == 0?
                     Just Int
    n  -> (Word16
    0, forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    n forall a. Num a => a -> a -> a
    - Word16
    1)
                     Maybe Int
    Nothing -> (forall a. Bounded a => a
    minBound, forall a. Bounded a => a
    maxBound)

             isNoDiscr :: Discr -> Bool
    isNoDiscr Discr
    NoDiscr = Bool
    True
             isNoDiscr Discr
    _       = Bool
    False

             dec :: Discr -> Discr
    dec (DiscrI Int
    i) = Int -> Discr
    DiscrI (Int
    iforall a. Num a => a -> a -> a
    -Int
    1)
             dec (DiscrW Word
    w) = Word -> Discr
    DiscrW (Word
    wforall a. Num a => a -> a -> a
    -Word
    1)
             dec (DiscrP Word16
    i) = Word16 -> Discr
    DiscrP (Word16
    iforall a. Num a => a -> a -> a
    -Word16
    1)
             dec Discr
    other      = Discr
    other         -- not really right, but if you
                    -- do cases on floating values, you'll get what you deserve

             -- same snotty comment applies to the following
             minF, maxF :: Float
             minD, maxD :: Double
             minF :: Float
    minF = -Float
    1.0e37
             maxF :: Float
    maxF =  Float
    1.0e37
             minD :: Double
    minD = -Double
    1.0e308
             maxD :: Double
    maxD =  Double
    1.0e308

    -- -----------------------------------------------------------------------------
    -- Supporting junk for the compilation schemes

    -- Describes case alts
    data Discr
       = DiscrI Int
       | DiscrW Word
       | DiscrF Float
       | DiscrD Double
       | DiscrP Word16
       | NoDiscr
        deriving (Discr -> Discr -> Bool
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: Discr -> Discr -> Bool
    $c/= :: Discr -> Discr -> Bool
    == :: Discr -> Discr -> Bool
    $c== :: Discr -> Discr -> Bool
    Eq, Eq Discr
    Discr -> Discr -> Bool
    Discr -> Discr -> Ordering
    Discr -> Discr -> Discr
    forall a.
    Eq a
    -> (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    min :: Discr -> Discr -> Discr
    $cmin :: Discr -> Discr -> Discr
    max :: Discr -> Discr -> Discr
    $cmax :: Discr -> Discr -> Discr
    >= :: Discr -> Discr -> Bool
    $c>= :: Discr -> Discr -> Bool
    > :: Discr -> Discr -> Bool
    $c> :: Discr -> Discr -> Bool
    <= :: Discr -> Discr -> Bool
    $c<= :: Discr -> Discr -> Bool
    < :: Discr -> Discr -> Bool
    $c< :: Discr -> Discr -> Bool
    compare :: Discr -> Discr -> Ordering
    $ccompare :: Discr -> Discr -> Ordering
    Ord)

    instance Outputable Discr where
       ppr :: Discr -> SDoc
    ppr (DiscrI Int
    i) = Int -> SDoc
    int Int
    i
       ppr (DiscrW Word
    w) = String -> SDoc
    text (forall a. Show a => a -> String
    show Word
    w)
       ppr (DiscrF Float
    f) = String -> SDoc
    text (forall a. Show a => a -> String
    show Float
    f)
       ppr (DiscrD Double
    d) = String -> SDoc
    text (forall a. Show a => a -> String
    show Double
    d)
       ppr (DiscrP Word16
    i) = forall a. Outputable a => a -> SDoc
    ppr Word16
    i
       ppr Discr
    NoDiscr    = String -> SDoc
    text String
    "DEF"

    lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
    lookupBCEnv_maybe :: Id -> Map Id ByteOff -> Maybe ByteOff
    lookupBCEnv_maybe = forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup

    idSizeW :: Platform -> Id -> WordOff
    idSizeW :: Platform -> Id -> WordOff
    idSizeW Platform
    platform = Int -> WordOff
    WordOff forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> ArgRep -> Int
    argRepSizeW Platform
    platform forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> Id -> ArgRep
    bcIdArgRep Platform
    platform

    idSizeCon :: Platform -> Id -> ByteOff
    idSizeCon :: Platform -> Id -> ByteOff
    idSizeCon Platform
    platform Id
    var
      -- unboxed tuple components are padded to word size
      | Kind -> Bool
    isUnboxedTupleType (Id -> Kind
    idType Id
    var) Bool -> Bool -> Bool
    ||
        Kind -> Bool
    isUnboxedSumType (Id -> Kind
    idType Id
    var) =
        Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
        Int -> WordOff
    WordOff forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> ArgRep -> Int
    argRepSizeW Platform
    platform forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> PrimRep -> ArgRep
    toArgRep Platform
    platform) forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
        Id -> [PrimRep]
    bcIdPrimReps forall a b. (a -> b) -> a -> b
    $ Id
    var
      | Bool
    otherwise = Int -> ByteOff
    ByteOff (Platform -> PrimRep -> Int
    primRepSizeB Platform
    platform (Id -> PrimRep
    bcIdPrimRep Id
    var))

    bcIdArgRep :: Platform -> Id -> ArgRep
    bcIdArgRep :: Platform -> Id -> ArgRep
    bcIdArgRep Platform
    platform = Platform -> PrimRep -> ArgRep
    toArgRep Platform
    platform forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> PrimRep
    bcIdPrimRep

    bcIdPrimRep :: Id -> PrimRep
    bcIdPrimRep :: Id -> PrimRep
    bcIdPrimRep Id
    id
      | [PrimRep
    rep] <- HasDebugCallStack => Kind -> [PrimRep]
    typePrimRepArgs (Id -> Kind
    idType Id
    id)
      = PrimRep
    rep
      | Bool
    otherwise
      = forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "bcIdPrimRep" (forall a. Outputable a => a -> SDoc
    ppr Id
    id SDoc -> SDoc -> SDoc
    <+> SDoc
    dcolon SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr (Id -> Kind
    idType Id
    id))

    bcIdPrimReps :: Id -> [PrimRep]
    bcIdPrimReps :: Id -> [PrimRep]
    bcIdPrimReps Id
    id = HasDebugCallStack => Kind -> [PrimRep]
    typePrimRepArgs (Id -> Kind
    idType Id
    id)

    repSizeWords :: Platform -> PrimRep -> WordOff
    repSizeWords :: Platform -> PrimRep -> WordOff
    repSizeWords Platform
    platform PrimRep
    rep = Int -> WordOff
    WordOff forall a b. (a -> b) -> a -> b
    $ Platform -> ArgRep -> Int
    argRepSizeW Platform
    platform (Platform -> PrimRep -> ArgRep
    toArgRep Platform
    platform PrimRep
    rep)

    isFollowableArg :: ArgRep -> Bool
    isFollowableArg :: ArgRep -> Bool
    isFollowableArg ArgRep
    P = Bool
    True
    isFollowableArg ArgRep
    _ = Bool
    False

    -- | Indicate if the calling convention is supported
    isSupportedCConv :: CCallSpec -> Bool
    isSupportedCConv :: CCallSpec -> Bool
    isSupportedCConv (CCallSpec CCallTarget
    _ CCallConv
    cconv Safety
    _) = case CCallConv
    cconv of
       CCallConv
    CCallConv            -> Bool
    True     -- we explicitly pattern match on every
       CCallConv
    StdCallConv          -> Bool
    True     -- convention to ensure that a warning
       CCallConv
    PrimCallConv         -> Bool
    False    -- is triggered when a new one is added
       CCallConv
    JavaScriptCallConv   -> Bool
    False
       CCallConv
    CApiConv             -> Bool
    True

    -- See bug #10462
    unsupportedCConvException :: a
    unsupportedCConvException :: forall a. a
    unsupportedCConvException = forall a. GhcException -> a
    throwGhcException (String -> GhcException
    ProgramError
      (String
    "Error: bytecode compiler can't handle some foreign calling conventions\n"forall a. [a] -> [a] -> [a]
    ++
       String
    "  Workaround: use -fobject-code, or compile this module to .o separately."))

    mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr
    mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr
    mkSlideB Platform
    platform !ByteOff
    nb !ByteOff
    db = Word16 -> WordOff -> OrdList BCInstr
    mkSlideW Word16
    n WordOff
    d
      where
        !n :: Word16
    n = WordOff -> Word16
    trunc16W forall a b. (a -> b) -> a -> b
    $ Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform ByteOff
    nb
        !d :: WordOff
    d = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform ByteOff
    db

    mkSlideW :: Word16 -> WordOff -> OrdList BCInstr
    mkSlideW :: Word16 -> WordOff -> OrdList BCInstr
    mkSlideW !Word16
    n !WordOff
    ws
        | WordOff
    ws forall a. Ord a => a -> a -> Bool
    > forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    limit
        -- If the amount to slide doesn't fit in a Word16, generate multiple slide
        -- instructions
        = Word16 -> Word16 -> BCInstr
    SLIDE Word16
    n Word16
    limit forall a. a -> OrdList a -> OrdList a
    `consOL` Word16 -> WordOff -> OrdList BCInstr
    mkSlideW Word16
    n (WordOff
    ws forall a. Num a => a -> a -> a
    - forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    limit)
        | WordOff
    ws forall a. Eq a => a -> a -> Bool
    == WordOff
    0
        = forall a. OrdList a
    nilOL
        | Bool
    otherwise
        = forall a. a -> OrdList a
    unitOL (Word16 -> Word16 -> BCInstr
    SLIDE Word16
    n forall a b. (a -> b) -> a -> b
    $ forall a b. (Integral a, Num b) => a -> b
    fromIntegral WordOff
    ws)
      where
        limit :: Word16
        limit :: Word16
    limit = forall a. Bounded a => a
    maxBound

    atomPrimRep :: StgArg -> PrimRep
    atomPrimRep :: StgArg -> PrimRep
    atomPrimRep (StgVarArg Id
    v) = Id -> PrimRep
    bcIdPrimRep Id
    v
    atomPrimRep (StgLitArg Literal
    l) = HasDebugCallStack => Kind -> PrimRep
    typePrimRep1 (Literal -> Kind
    literalType Literal
    l)

    atomRep :: Platform -> StgArg -> ArgRep
    atomRep :: Platform -> StgArg -> ArgRep
    atomRep Platform
    platform StgArg
    e = Platform -> PrimRep -> ArgRep
    toArgRep Platform
    platform (StgArg -> PrimRep
    atomPrimRep StgArg
    e)

    -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
    -- has initial depth @original_depth@.  Return the values which the stack
    -- environment should map these items to.
    mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
    mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
    mkStackOffsets ByteOff
    original_depth [ByteOff]
    szsb = forall a. [a] -> [a]
    tail (forall b a. (b -> a -> b) -> b -> [a] -> [b]
    scanl' forall a. Num a => a -> a -> a
    (+) ByteOff
    original_depth [ByteOff]
    szsb)

    typeArgReps :: Platform -> Type -> [ArgRep]
    typeArgReps :: Platform -> Kind -> [ArgRep]
    typeArgReps Platform
    platform = forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> PrimRep -> ArgRep
    toArgRep Platform
    platform) forall b c a. (b -> c) -> (a -> b) -> a -> c
    . HasDebugCallStack => Kind -> [PrimRep]
    typePrimRepArgs

    -- -----------------------------------------------------------------------------
    -- The bytecode generator's monad

    data BcM_State
       = BcM_State
            { BcM_State -> HscEnv
    bcm_hsc_env :: HscEnv
            , BcM_State -> UniqSupply
    uniqSupply  :: UniqSupply      -- for generating fresh variable names
            , BcM_State -> Module
    thisModule  :: Module          -- current module (for breakpoints)
            , BcM_State -> Word32
    nextlabel   :: Word32          -- for generating local labels
            , BcM_State -> [FFIInfo]
    ffis        :: [FFIInfo]       -- ffi info blocks, to free later
                                             -- Should be free()d when it is GCd
            , BcM_State -> Maybe ModBreaks
    modBreaks   :: Maybe ModBreaks -- info about breakpoints
            , BcM_State -> IntMap CgBreakInfo
    breakInfo   :: IntMap CgBreakInfo
            , BcM_State -> IdEnv (RemotePtr ())
    topStrings  :: IdEnv (RemotePtr ()) -- top-level string literals
              -- See Note [generating code for top-level string literal bindings].
            }

    newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (forall a b. a -> BcM b -> BcM a
    forall a b. (a -> b) -> BcM a -> BcM b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    <$ :: forall a b. a -> BcM b -> BcM a
    $c<$ :: forall a b. a -> BcM b -> BcM a
    fmap :: forall a b. (a -> b) -> BcM a -> BcM b
    $cfmap :: forall a b. (a -> b) -> BcM a -> BcM b
    Functor)

    ioToBc :: IO a -> BcM a
    ioToBc :: forall a. IO a -> BcM a
    ioToBc IO a
    io = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> do
      a
    x <- IO a
    io
      forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st, a
    x)

    runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks
          -> IdEnv (RemotePtr ())
          -> BcM r
          -> IO (BcM_State, r)
    runBc :: forall r.
    HscEnv
    -> UniqSupply
    -> Module
    -> Maybe ModBreaks
    -> IdEnv (RemotePtr ())
    -> BcM r
    -> IO (BcM_State, r)
    runBc HscEnv
    hsc_env UniqSupply
    us Module
    this_mod Maybe ModBreaks
    modBreaks IdEnv (RemotePtr ())
    topStrings (BcM BcM_State -> IO (BcM_State, r)
    m)
       = BcM_State -> IO (BcM_State, r)
    m (HscEnv
    -> UniqSupply
    -> Module
    -> Word32
    -> [FFIInfo]
    -> Maybe ModBreaks
    -> IntMap CgBreakInfo
    -> IdEnv (RemotePtr ())
    -> BcM_State
    BcM_State HscEnv
    hsc_env UniqSupply
    us Module
    this_mod Word32
    0 [] Maybe ModBreaks
    modBreaks forall a. IntMap a
    IntMap.empty IdEnv (RemotePtr ())
    topStrings)

    thenBc :: BcM a -> (a -> BcM b) -> BcM b
    thenBc :: forall a b. BcM a -> (a -> BcM b) -> BcM b
    thenBc (BcM BcM_State -> IO (BcM_State, a)
    expr) a -> BcM b
    cont = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st0 -> do
      (BcM_State
    st1, a
    q) <- BcM_State -> IO (BcM_State, a)
    expr BcM_State
    st0
      let BcM BcM_State -> IO (BcM_State, b)
    k = a -> BcM b
    cont a
    q
      (BcM_State
    st2, b
    r) <- BcM_State -> IO (BcM_State, b)
    k BcM_State
    st1
      forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st2, b
    r)

    thenBc_ :: BcM a -> BcM b -> BcM b
    thenBc_ :: forall a b. BcM a -> BcM b -> BcM b
    thenBc_ (BcM BcM_State -> IO (BcM_State, a)
    expr) (BcM BcM_State -> IO (BcM_State, b)
    cont) = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st0 -> do
      (BcM_State
    st1, a
    _) <- BcM_State -> IO (BcM_State, a)
    expr BcM_State
    st0
      (BcM_State
    st2, b
    r) <- BcM_State -> IO (BcM_State, b)
    cont BcM_State
    st1
      forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st2, b
    r)

    returnBc :: a -> BcM a
    returnBc :: forall a. a -> BcM a
    returnBc a
    result = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> (forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st, a
    result))

    instance Applicative BcM where
        pure :: forall a. a -> BcM a
    pure = forall a. a -> BcM a
    returnBc
        <*> :: forall a b. BcM (a -> b) -> BcM a -> BcM b
    (<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap
        *> :: forall a b. BcM a -> BcM b -> BcM b
    (*>) = forall a b. BcM a -> BcM b -> BcM b
    thenBc_

    instance Monad BcM where
      >>= :: forall a b. BcM a -> (a -> BcM b) -> BcM b
    (>>=) = forall a b. BcM a -> (a -> BcM b) -> BcM b
    thenBc
      >> :: forall a b. BcM a -> BcM b -> BcM b
    (>>)  = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    (*>)

    instance HasDynFlags BcM where
        getDynFlags :: BcM DynFlags
    getDynFlags = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st, HscEnv -> DynFlags
    hsc_dflags (BcM_State -> HscEnv
    bcm_hsc_env BcM_State
    st))

    getHscEnv :: BcM HscEnv
    getHscEnv :: BcM HscEnv
    getHscEnv = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st, BcM_State -> HscEnv
    bcm_hsc_env BcM_State
    st)

    getProfile :: BcM Profile
    getProfile :: BcM Profile
    getProfile = DynFlags -> Profile
    targetProfile forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags

    emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
    emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
    emitBc [FFIInfo] -> ProtoBCO Name
    bco
      = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st{ffis :: [FFIInfo]
    ffis=[]}, [FFIInfo] -> ProtoBCO Name
    bco (BcM_State -> [FFIInfo]
    ffis BcM_State
    st))

    recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
    recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
    recordFFIBc RemotePtr C_ffi_cif
    a
      = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st{ffis :: [FFIInfo]
    ffis = RemotePtr C_ffi_cif -> FFIInfo
    FFIInfo RemotePtr C_ffi_cif
    a forall a. a -> [a] -> [a]
    : BcM_State -> [FFIInfo]
    ffis BcM_State
    st}, ())

    getLabelBc :: BcM LocalLabel
    getLabelBc :: BcM LocalLabel
    getLabelBc
      = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> do let nl :: Word32
    nl = BcM_State -> Word32
    nextlabel BcM_State
    st
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Word32
    nl forall a. Eq a => a -> a -> Bool
    == forall a. Bounded a => a
    maxBound) forall a b. (a -> b) -> a -> b
    $
                            forall a. String -> a
    panic String
    "getLabelBc: Ran out of labels"
                        forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st{nextlabel :: Word32
    nextlabel = Word32
    nl forall a. Num a => a -> a -> a
    + Word32
    1}, Word32 -> LocalLabel
    LocalLabel Word32
    nl)

    getLabelsBc :: Word32 -> BcM [LocalLabel]
    getLabelsBc :: Word32 -> BcM [LocalLabel]
    getLabelsBc Word32
    n
      = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> let ctr :: Word32
    ctr = BcM_State -> Word32
    nextlabel BcM_State
    st
                     in forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st{nextlabel :: Word32
    nextlabel = Word32
    ctrforall a. Num a => a -> a -> a
    +Word32
    n}, coerce :: forall a b. Coercible a b => a -> b
    coerce [Word32
    ctr .. Word32
    ctrforall a. Num a => a -> a -> a
    +Word32
    nforall a. Num a => a -> a -> a
    -Word32
    1])

    getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
    getCCArray :: BcM (Array Int (RemotePtr CostCentre))
    getCCArray = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st ->
      let breaks :: ModBreaks
    breaks = forall a. HasCallStack => String -> Maybe a -> a
    expectJust String
    "GHC.StgToByteCode.getCCArray" forall a b. (a -> b) -> a -> b
    $ BcM_State -> Maybe ModBreaks
    modBreaks BcM_State
    st in
      forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st, ModBreaks -> Array Int (RemotePtr CostCentre)
    modBreaks_ccs ModBreaks
    breaks)

    newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
    newBreakInfo :: Int -> CgBreakInfo -> BcM ()
    newBreakInfo Int
    ix CgBreakInfo
    info = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st ->
      forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st{breakInfo :: IntMap CgBreakInfo
    breakInfo = forall a. Int -> a -> IntMap a -> IntMap a
    IntMap.insert Int
    ix CgBreakInfo
    info (BcM_State -> IntMap CgBreakInfo
    breakInfo BcM_State
    st)}, ())

    newUnique :: BcM Unique
    newUnique :: BcM Unique
    newUnique = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $
       \BcM_State
    st -> case UniqSupply -> (Unique, UniqSupply)
    takeUniqFromSupply (BcM_State -> UniqSupply
    uniqSupply BcM_State
    st) of
                 (Unique
    uniq, UniqSupply
    us) -> let newState :: BcM_State
    newState = BcM_State
    st { uniqSupply :: UniqSupply
    uniqSupply = UniqSupply
    us }
                               in  forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    newState, Unique
    uniq)

    getCurrentModule :: BcM Module
    getCurrentModule :: BcM Module
    getCurrentModule = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st, BcM_State -> Module
    thisModule BcM_State
    st)

    getTopStrings :: BcM (IdEnv (RemotePtr ()))
    getTopStrings :: BcM (IdEnv (RemotePtr ()))
    getTopStrings = forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st, BcM_State -> IdEnv (RemotePtr ())
    topStrings BcM_State
    st)

    newId :: Type -> BcM Id
    newId :: Kind -> BcM Id
    newId Kind
    ty = do
        Unique
    uniq <- BcM Unique
    newUnique
        forall (m :: * -> *) a. Monad m => a -> m a
    return forall a b. (a -> b) -> a -> b
    $ FastString -> Unique -> Kind -> Kind -> Id
    mkSysLocal FastString
    tickFS Unique
    uniq Kind
    Many Kind
    ty

    tickFS :: FastString
    tickFS :: FastString
    tickFS = String -> FastString
    fsLit String
    "ticked"