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

    {-# OPTIONS_GHC -fprof-auto-top #-}

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

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

    import GHC.Prelude

    import GHC.Driver.DynFlags
    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
    import GHC.Types.ForeignCall
    import GHC.Core
    import GHC.Types.Literal
    import GHC.Builtin.PrimOps
    import GHC.Builtin.PrimOps.Ids (primOpId)
    import GHC.Core.Type
    import GHC.Core.TyCo.Compare (eqType)
    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.Prim
    import GHC.Core.TyCo.Ppr ( pprType )
    import GHC.Utils.Error
    import GHC.Builtin.Uniques
    import GHC.Data.FastString
    import GHC.Utils.Panic
    import GHC.Utils.Exception (evaluate)
    import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,
                                  addIdReps, addArgReps,
                                  nonVoidIds, nonVoidStgArgs )
    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.Name.Env (mkNameEnv)
    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.Unit.Module
    import GHC.Unit.Home.ModInfo (lookupHpt)

    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 Data.Either ( partitionEithers )

    import GHC.Stg.Syntax
    import qualified Data.IntSet as IntSet
    import GHC.CoreToIface

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

    byteCodeGen :: HscEnv
                -> Module
                -> [CgStgTopBinding]
                -> [TyCon]
                -> Maybe ModBreaks
                -> IO CompiledByteCode
    byteCodeGen :: HscEnv
    -> Module
    -> [CgStgTopBinding]
    -> [TyCon]
    -> Maybe ModBreaks
    -> IO CompiledByteCode
    byteCodeGen HscEnv
    hsc_env Module
    this_mod [CgStgTopBinding]
    binds [TyCon]
    tycs Maybe ModBreaks
    mb_modBreaks
       = Logger
    -> SDoc
    -> (CompiledByteCode -> ())
    -> IO CompiledByteCode
    -> IO CompiledByteCode
    forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> SDoc -> (a -> ()) -> m a -> m a
    withTiming Logger
    logger
                    (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "GHC.StgToByteCode"SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    brackets (Module -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Module
    this_mod))
                    (() -> CompiledByteCode -> ()
    forall a b. a -> b -> a
    const ()) (IO CompiledByteCode -> IO CompiledByteCode)
    -> IO CompiledByteCode -> IO CompiledByteCode
    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 'CodeGen]
    lifted_binds) = [Either (Id, ByteString) (GenStgBinding 'CodeGen)]
    -> ([(Id, ByteString)], [GenStgBinding 'CodeGen])
    forall a b. [Either a b] -> ([a], [b])
    partitionEithers ([Either (Id, ByteString) (GenStgBinding 'CodeGen)]
     -> ([(Id, ByteString)], [GenStgBinding 'CodeGen]))
    -> [Either (Id, ByteString) (GenStgBinding 'CodeGen)]
    -> ([(Id, ByteString)], [GenStgBinding 'CodeGen])
    forall a b. (a -> b) -> a -> b
    $ do  -- list monad
                    bnd <- [CgStgTopBinding]
    binds
                    case bnd of
                      StgTopLifted GenStgBinding 'CodeGen
    bnd      -> [GenStgBinding 'CodeGen
    -> Either (Id, ByteString) (GenStgBinding 'CodeGen)
    forall a b. b -> Either a b
    Right GenStgBinding 'CodeGen
    bnd]
                      StgTopStringLit Id
    b ByteString
    str -> [(Id, ByteString)
    -> Either (Id, ByteString) (GenStgBinding 'CodeGen)
    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
            stringPtrs <- Interp -> [(Id, ByteString)] -> IO AddrEnv
    allocateTopStrings Interp
    interp [(Id, ByteString)]
    strings

            (BcM_State{..}, proto_bcos) <-
               runBc hsc_env this_mod mb_modBreaks $ do
                 let flattened_binds = (GenStgBinding 'CodeGen -> [(Id, CgStgRhs)])
    -> [GenStgBinding 'CodeGen] -> [(Id, CgStgRhs)]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap GenStgBinding 'CodeGen -> [(Id, CgStgRhs)]
    GenStgBinding 'CodeGen -> [(BinderP 'CodeGen, CgStgRhs)]
    forall {pass :: StgPass}.
    GenStgBinding pass -> [(BinderP pass, GenStgRhs pass)]
    flattenBind ([GenStgBinding 'CodeGen] -> [GenStgBinding 'CodeGen]
    forall a. [a] -> [a]
    reverse [GenStgBinding 'CodeGen]
    lifted_binds)
                 mapM schemeTopBind flattened_binds

            when (notNull ffis)
                 (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?")

            putDumpFileMaybe logger Opt_D_dump_BCOs
               "Proto-BCOs" FormatByteCode
               (vcat (intersperse (char ' ') (map ppr proto_bcos)))

            cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs
              (case modBreaks of
                 Maybe ModBreaks
    Nothing -> Maybe ModBreaks
    forall a. Maybe a
    Nothing
                 Just ModBreaks
    mb -> ModBreaks -> Maybe ModBreaks
    forall a. a -> Maybe a
    Just ModBreaks
    mb{ modBreaks_breakInfo = 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.
            evaluate (seqCompiledByteCode cbc)

            return 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

    -- | see Note [Generating code for top-level string literal bindings]
    allocateTopStrings
      :: Interp
      -> [(Id, ByteString)]
      -> IO AddrEnv
    allocateTopStrings :: Interp -> [(Id, ByteString)] -> IO AddrEnv
    allocateTopStrings Interp
    interp [(Id, ByteString)]
    topStrings = do
      let !([Id]
    bndrs, [ByteString]
    strings) = [(Id, ByteString)] -> ([Id], [ByteString])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(Id, ByteString)]
    topStrings
      ptrs <- Interp -> Message [RemotePtr ()] -> IO [RemotePtr ()]
    forall a. Binary a => Interp -> Message a -> IO a
    interpCmd Interp
    interp (Message [RemotePtr ()] -> IO [RemotePtr ()])
    -> Message [RemotePtr ()] -> IO [RemotePtr ()]
    forall a b. (a -> b) -> a -> b
    $ [ByteString] -> Message [RemotePtr ()]
    MallocStrings [ByteString]
    strings
      return $ mkNameEnv (zipWith mk_entry bndrs ptrs)
      where
        mk_entry :: a -> RemotePtr () -> (Name, (Name, AddrPtr))
    mk_entry a
    bndr RemotePtr ()
    ptr = let nm :: Name
    nm = a -> Name
    forall a. NamedThing a => a -> Name
    getName a
    bndr
                            in (Name
    nm, (Name
    nm, RemotePtr () -> AddrPtr
    AddrPtr RemotePtr ()
    ptr))

    {- Note [Generating code for top-level string literal bindings]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    As described in Note [Compilation plan for top-level string literals]
    in GHC.Core, the core-to-core optimizer can introduce top-level Addr#
    bindings to represent string literals. The creates two challenges for
    the bytecode compiler: (1) compiling the bindings themselves, and
    (2) compiling references to such bindings. Here is a summary on how
    we deal with them:

      1. Top-level string literal bindings are separated from the rest of
         the module. Memory for them is allocated immediately, via
         interpCmd, in allocateTopStrings, and the resulting AddrEnv is
         recorded in the bc_strs field of the CompiledByteCode result.

      2. When we encounter a reference to a top-level string literal, we
         generate a PUSH_ADDR pseudo-instruction, which is assembled to
         a PUSH_UBX instruction with a BCONPtrAddr argument.

      3. The loader accumulates string literal bindings from loaded
         bytecode in the addr_env field of the LinkerEnv.

      4. The BCO linker resolves BCONPtrAddr references by searching both
         the addr_env (to find literals defined in bytecode) and the native
         symbol table (to find literals defined in native code).

    This strategy works alright, but it does have one significant problem:
    we never free the memory that we allocate for the top-level strings.
    In theory, we could explicitly free it when BCOs are unloaded, but
    this comes with its own complications; see #22400 for why. For now,
    we just accept the leak, but it would nice to find something better. -}

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

    type BCInstrList = OrdList BCInstr

    wordsToBytes :: Platform -> WordOff -> ByteOff
    wordsToBytes :: Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform = Int -> ByteOff
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int -> ByteOff) -> (WordOff -> Int) -> WordOff -> ByteOff
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Platform -> Int
    platformWordSizeInBytes Platform
    platform) (Int -> Int) -> (WordOff -> Int) -> WordOff -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . WordOff -> Int
    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 Int -> Int -> (Int, Int)
    forall a. Integral a => a -> a -> (a, a)
    `quotRem` (Platform -> Int
    platformWordSizeInBytes Platform
    platform)
        in if Int
    r Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0
               then Int -> WordOff
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    q
               else String -> SDoc -> WordOff
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "GHC.StgToByteCode.bytesToWords"
                             (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "bytes=" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Int -> 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       -- ^ arity
       -> WordOff   -- ^ bitmap size
       -> [StgWord] -- ^ bitmap
       -> Bool      -- ^ True <=> is a return point, rather than a function
       -> [FFIInfo]
       -> ProtoBCO name
    mkProtoBCO :: forall name.
    Platform
    -> name
    -> OrdList BCInstr
    -> Either [CgStgAlt] CgStgRhs
    -> Int
    -> WordOff
    -> [StgWord]
    -> Bool
    -> [FFIInfo]
    -> ProtoBCO name
    mkProtoBCO Platform
    platform name
    nm OrdList BCInstr
    instrs_ordlist Either [CgStgAlt] CgStgRhs
    origin Int
    arity WordOff
    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 :: Word
    protoBCOBitmapSize = WordOff -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral WordOff
    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 Word -> Word -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int -> Word
    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 Word -> Word -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    iNTERP_STACK_CHECK_THRESH
               = Word -> BCInstr
    STKCHECK Word
    stack_usage BCInstr -> [BCInstr] -> [BCInstr]
    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 = [Word] -> Word
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum ((BCInstr -> Word) -> [BCInstr] -> [Word]
    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 (OrdList BCInstr -> [BCInstr]
    forall a. OrdList a -> [a]
    fromOL OrdList BCInstr
    instrs_ordlist)

            peep :: [BCInstr] -> [BCInstr]
    peep (PUSH_L WordOff
    off1 : PUSH_L WordOff
    off2 : PUSH_L WordOff
    off3 : [BCInstr]
    rest)
               = WordOff -> WordOff -> WordOff -> BCInstr
    PUSH_LLL WordOff
    off1 (WordOff
    off2WordOff -> WordOff -> WordOff
    forall a. Num a => a -> a -> a
    -WordOff
    1) (WordOff
    off3WordOff -> WordOff -> WordOff
    forall a. Num a => a -> a -> a
    -WordOff
    2) BCInstr -> [BCInstr] -> [BCInstr]
    forall a. a -> [a] -> [a]
    : [BCInstr] -> [BCInstr]
    peep [BCInstr]
    rest
            peep (PUSH_L WordOff
    off1 : PUSH_L WordOff
    off2 : [BCInstr]
    rest)
               = WordOff -> WordOff -> BCInstr
    PUSH_LL WordOff
    off1 (WordOff
    off2WordOff -> WordOff -> WordOff
    forall a. Num a => a -> a -> a
    -WordOff
    1) BCInstr -> [BCInstr] -> [BCInstr]
    forall a. a -> [a] -> [a]
    : [BCInstr] -> [BCInstr]
    peep [BCInstr]
    rest
            peep (BCInstr
    i:[BCInstr]
    rest)
               = BCInstr
    i BCInstr -> [BCInstr] -> [BCInstr]
    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 Bool -> [Bool] -> [Bool]
    forall a. a -> [a] -> [a]
    : Platform -> [ArgRep] -> [Bool]
    argBits Platform
    platform [ArgRep]
    args
      | Bool
    otherwise = Int -> Bool -> [Bool]
    forall a. Int -> a -> [a]
    replicate (Platform -> ArgRep -> Int
    argRepSizeW Platform
    platform ArgRep
    rep) Bool
    True [Bool] -> [Bool] -> [Bool]
    forall a. [a] -> [a] -> [a]
    ++ Platform -> [ArgRep] -> [Bool]
    argBits Platform
    platform [ArgRep]
    args

    -- -----------------------------------------------------------------------------
    -- 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 <- Profile -> Platform
    profilePlatform (Profile -> Platform) -> BcM Profile -> BcM Platform
    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")
        emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P])
                           (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})

      | Bool
    otherwise
      = [Id] -> (Name, CgStgRhs) -> BcM (ProtoBCO Name)
    schemeR [{- No free variables -}] (Id -> Name
    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 Type
    _) = ([Id]
    [BinderP 'CodeGen]
    args, CgStgExpr
    body)
    collect (StgRhsCon CostCentreStack
    _cc DataCon
    dc ConstructorNumber
    cnum [StgTickish]
    _ticks [StgArg]
    args Type
    _typ) = ([], DataCon
    -> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> CgStgExpr
    forall (pass :: StgPass).
    DataCon
    -> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> 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 <- BcM Profile
    getProfile
         let
             platform  = Profile -> Platform
    profilePlatform Profile
    profile
             all_args  = [Id] -> [Id]
    forall a. [a] -> [a]
    reverse [Id]
    args [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++ [Id]
    fvs
             arity     = [Id] -> Int
    forall a. [a] -> Int
    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 = (Id -> ByteOff) -> [Id] -> [ByteOff]
    forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform (WordOff -> ByteOff) -> (Id -> WordOff) -> Id -> ByteOff
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> Id -> WordOff
    idSizeW Platform
    platform) [Id]
    all_args
             sum_szsb_args  = [ByteOff] -> ByteOff
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum [ByteOff]
    szsb_args
             p_init    = [(Id, ByteOff)] -> Map Id ByteOff
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([Id] -> [ByteOff] -> [(Id, ByteOff)]
    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 = Platform -> [ArgRep] -> [Bool]
    argBits Platform
    platform ([ArgRep] -> [ArgRep]
    forall a. [a] -> [a]
    reverse ((Id -> ArgRep) -> [Id] -> [ArgRep]
    forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> Id -> ArgRep
    idArgRep Platform
    platform) [Id]
    all_args))
             bitmap_size = [Bool] -> WordOff
    forall i a. Num i => [a] -> i
    genericLength [Bool]
    bits
             bitmap = Platform -> [Bool] -> [StgWord]
    mkBitmap Platform
    platform [Bool]
    bits
         body_code <- schemeER_wrk sum_szsb_args p_init body

         emitBc (mkProtoBCO platform nm body_code (Right original_body)
                     arity bitmap_size bitmap False{-not alts-})

    -- | Introduce break instructions for ticked expressions.
    -- If no breakpoint information is available, the instruction is omitted.
    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 Module
    mod) CgStgExpr
    rhs) = do
      code <- ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d ByteOff
    0 Map Id ByteOff
    p CgStgExpr
    rhs
      hsc_env <- getHscEnv
      current_mod <- getCurrentModule
      current_mod_breaks <- getCurrentModBreaks
      case break_info hsc_env mod current_mod current_mod_breaks of
        Maybe ModBreaks
    Nothing -> OrdList BCInstr -> BcM (OrdList BCInstr)
    forall a. a -> BcM a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure OrdList BCInstr
    code
        Just ModBreaks {modBreaks_flags :: ModBreaks -> ForeignRef BreakArray
    modBreaks_flags = ForeignRef BreakArray
    breaks, modBreaks_module :: ModBreaks -> RemotePtr ModuleName
    modBreaks_module = RemotePtr ModuleName
    mod_ptr, modBreaks_ccs :: ModBreaks -> Array Int (RemotePtr CostCentre)
    modBreaks_ccs = Array Int (RemotePtr CostCentre)
    cc_arr} -> do
          platform <- Profile -> Platform
    profilePlatform (Profile -> Platform) -> BcM Profile -> BcM Platform
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM Profile
    getProfile
          let idOffSets = Platform
    -> ByteOff -> Map Id ByteOff -> [Id] -> [Maybe (Id, WordOff)]
    getVarOffSets Platform
    platform ByteOff
    d Map Id ByteOff
    p [Id]
    [XTickishId 'TickishPassStg]
    fvs
              ty_vars   = [Type] -> [Id]
    tyCoVarsOfTypesWellScoped (Type
    XBreakpoint 'TickishPassStg
    tick_tyType -> [Type] -> [Type]
    forall a. a -> [a] -> [a]
    :(Id -> Type) -> [Id] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> Type
    idType [Id]
    [XTickishId 'TickishPassStg]
    fvs)
              toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)
              toWord = ((Id, WordOff) -> (Id, Word))
    -> Maybe (Id, WordOff) -> Maybe (Id, Word)
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\(Id
    i, WordOff
    wo) -> (Id
    i, WordOff -> Word
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral WordOff
    wo))
              breakInfo  = [Id] -> [Maybe (Id, Word)] -> Type -> CgBreakInfo
    dehydrateCgBreakInfo [Id]
    ty_vars ((Maybe (Id, WordOff) -> Maybe (Id, Word))
    -> [Maybe (Id, WordOff)] -> [Maybe (Id, Word)]
    forall a b. (a -> b) -> [a] -> [b]
    map Maybe (Id, WordOff) -> Maybe (Id, Word)
    toWord [Maybe (Id, WordOff)]
    idOffSets) Type
    XBreakpoint 'TickishPassStg
    tick_ty
          newBreakInfo tick_no breakInfo
          let cc | Just Interp
    interp <- HscEnv -> Maybe Interp
    hsc_interp HscEnv
    hsc_env
                , Interp -> Bool
    interpreterProfiled Interp
    interp
                = Array Int (RemotePtr CostCentre)
    cc_arr Array Int (RemotePtr CostCentre) -> Int -> RemotePtr CostCentre
    forall i e. Ix i => Array i e -> i -> e
    ! Int
    tick_no
                | Bool
    otherwise = Ptr CostCentre -> RemotePtr CostCentre
    forall a. Ptr a -> RemotePtr a
    toRemotePtr Ptr CostCentre
    forall a. Ptr a
    nullPtr
              breakInstr = ForeignRef BreakArray
    -> Word16
    -> RemotePtr ModuleName
    -> RemotePtr CostCentre
    -> BCInstr
    BRK_FUN ForeignRef BreakArray
    breaks (Int -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    tick_no) RemotePtr ModuleName
    mod_ptr RemotePtr CostCentre
    cc
          return $ breakInstr `consOL` 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

    -- | Determine the GHCi-allocated 'BreakArray' and module pointer for the module
    -- from which the breakpoint originates.
    -- These are stored in 'ModBreaks' as remote pointers in order to allow the BCOs
    -- to refer to pointers in GHCi's address space.
    -- They are initialized in 'GHC.HsToCore.Breakpoints.mkModBreaks', called by
    -- 'GHC.HsToCore.deSugar'.
    --
    -- Breakpoints might be disabled because we're in TH, because
    -- @-fno-break-points@ was specified, or because a module was reloaded without
    -- reinitializing 'ModBreaks'.
    --
    -- If the module stored in the breakpoint is the currently processed module, use
    -- the 'ModBreaks' from the state.
    -- If that is 'Nothing', consider breakpoints to be disabled and skip the
    -- instruction.
    --
    -- If the breakpoint is inlined from another module, look it up in the home
    -- package table.
    -- If the module doesn't exist there, or its module pointer is null (which means
    -- that the 'ModBreaks' value is uninitialized), skip the instruction.
    break_info ::
      HscEnv ->
      Module ->
      Module ->
      Maybe ModBreaks ->
      Maybe ModBreaks
    break_info :: HscEnv -> Module -> Module -> Maybe ModBreaks -> Maybe ModBreaks
    break_info HscEnv
    hsc_env Module
    mod Module
    current_mod Maybe ModBreaks
    current_mod_breaks
      | Module
    mod Module -> Module -> Bool
    forall a. Eq a => a -> a -> Bool
    == Module
    current_mod
      = ModBreaks -> Maybe ModBreaks
    check_mod_ptr (ModBreaks -> Maybe ModBreaks)
    -> Maybe ModBreaks -> Maybe ModBreaks
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< Maybe ModBreaks
    current_mod_breaks
      | Just HomeModInfo
    hp <- HomePackageTable -> ModuleName -> Maybe HomeModInfo
    lookupHpt (HscEnv -> HomePackageTable
    hsc_HPT HscEnv
    hsc_env) (Module -> ModuleName
    forall unit. GenModule unit -> ModuleName
    moduleName Module
    mod)
      = ModBreaks -> Maybe ModBreaks
    check_mod_ptr (HomeModInfo -> ModBreaks
    getModBreaks HomeModInfo
    hp)
      | Bool
    otherwise
      = Maybe ModBreaks
    forall a. Maybe a
    Nothing
      where
        check_mod_ptr :: ModBreaks -> Maybe ModBreaks
    check_mod_ptr ModBreaks
    mb
          | RemotePtr ModuleName
    mod_ptr <- ModBreaks -> RemotePtr ModuleName
    modBreaks_module ModBreaks
    mb
          , RemotePtr ModuleName -> Ptr ModuleName
    forall a. RemotePtr a -> Ptr a
    fromRemotePtr RemotePtr ModuleName
    mod_ptr Ptr ModuleName -> Ptr ModuleName -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Ptr ModuleName
    forall a. Ptr a
    nullPtr
          = ModBreaks -> Maybe ModBreaks
    forall a. a -> Maybe a
    Just ModBreaks
    mb
          | Bool
    otherwise
          = Maybe ModBreaks
    forall a. Maybe a
    Nothing

    getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)]
    getVarOffSets :: Platform
    -> ByteOff -> Map Id ByteOff -> [Id] -> [Maybe (Id, WordOff)]
    getVarOffSets Platform
    platform ByteOff
    depth Map Id ByteOff
    env = (Id -> Maybe (Id, WordOff)) -> [Id] -> [Maybe (Id, WordOff)]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> Maybe (Id, WordOff)
    getOffSet
      where
        getOffSet :: Id -> Maybe (Id, WordOff)
    getOffSet Id
    id = case Id -> Map Id ByteOff -> Maybe ByteOff
    lookupBCEnv_maybe Id
    id Map Id ByteOff
    env of
            Maybe ByteOff
    Nothing     -> Maybe (Id, WordOff)
    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 :: WordOff
    var_depth_ws = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    depth ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    - ByteOff
    offset) WordOff -> WordOff -> WordOff
    forall a. Num a => a -> a -> a
    + WordOff
    2
                in (Id, WordOff) -> Maybe (Id, WordOff)
    forall a. a -> Maybe a
    Just (Id
    id, WordOff
    var_depth_ws)

    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 (DIdSet -> [Id]) -> DIdSet -> [Id]
    forall a b. (a -> b) -> a -> b
    $ CgStgRhs -> DIdSet
    forall (pass :: StgPass).
    (XRhsClosure pass ~ DIdSet) =>
    GenStgRhs pass -> DIdSet
    freeVarsOfRhs CgStgRhs
    rhs,
                           Id
    v Id -> Map Id ByteOff -> Bool
    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 = StgArg -> [PrimRep]
    stgArgRep StgArg
    e
        (push, szb) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p StgArg
    e
        ret <- returnUnliftedReps d s szb reps
        return (push `appOL` 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 <- BcM Profile
    getProfile
        let platform = Profile -> Platform
    profilePlatform Profile
    profile
        ret <- case reps of
                 -- use RETURN for nullary/unary representations
                 []    -> OrdList BCInstr -> BcM (OrdList BCInstr)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL (BCInstr -> OrdList BCInstr) -> BCInstr -> OrdList BCInstr
    forall a b. (a -> b) -> a -> b
    $ ArgRep -> BCInstr
    RETURN ArgRep
    V)
                 [PrimRep
    rep] -> OrdList BCInstr -> BcM (OrdList BCInstr)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL (BCInstr -> OrdList BCInstr) -> BCInstr -> OrdList BCInstr
    forall a b. (a -> b) -> a -> b
    $ ArgRep -> BCInstr
    RETURN (Platform -> PrimRep -> ArgRep
    toArgRep Platform
    platform PrimRep
    rep))
                 -- otherwise use RETURN_TUPLE with a tuple descriptor
                 [PrimRep]
    nv_reps -> do
                   let (NativeCallInfo
    call_info, [(PrimRep, ByteOff)]
    args_offsets) = Profile
    -> NativeCallType
    -> ByteOff
    -> (PrimRep -> CmmType)
    -> [PrimRep]
    -> (NativeCallInfo, [(PrimRep, ByteOff)])
    forall a.
    Profile
    -> NativeCallType
    -> ByteOff
    -> (a -> CmmType)
    -> [a]
    -> (NativeCallInfo, [(a, ByteOff)])
    layoutNativeCall Profile
    profile NativeCallType
    NativeTupleReturn ByteOff
    0 (Platform -> PrimRep -> CmmType
    primRepCmmType Platform
    platform) [PrimRep]
    nv_reps
                   tuple_bco <- ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
    emitBc (Platform
    -> NativeCallInfo
    -> [(PrimRep, ByteOff)]
    -> [FFIInfo]
    -> ProtoBCO Name
    tupleBCO Platform
    platform NativeCallInfo
    call_info [(PrimRep, ByteOff)]
    args_offsets)
                   return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL`
                            PUSH_BCO tuple_bco `consOL`
                            unitOL RETURN_TUPLE
        return ( mkSlideB platform szb (d - s) -- clear to sequel
                 `consOL` 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 <- BcM Profile
    getProfile
        let platform = Profile -> Platform
    profilePlatform Profile
    profile
            arg_ty StgArg
    e = Platform -> PrimRep -> CmmType
    primRepCmmType Platform
    platform (StgArg -> PrimRep
    stgArgRepU StgArg
    e)
            (call_info, tuple_components) = layoutNativeCall profile
                                                             NativeTupleReturn
                                                             d
                                                             arg_ty
                                                             es
            go ByteOff
    _   [OrdList BCInstr]
    pushes [] = [OrdList BCInstr] -> BcM [OrdList BCInstr]
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([OrdList BCInstr] -> [OrdList BCInstr]
    forall a. [a] -> [a]
    reverse [OrdList BCInstr]
    pushes)
            go !ByteOff
    dd [OrdList BCInstr]
    pushes ((StgArg
    a, ByteOff
    off):[(StgArg, ByteOff)]
    cs) = do (push, szb) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    dd Map Id ByteOff
    p StgArg
    a
                                             massert (off == dd + szb)
                                             go (dd + szb) (push:pushes) cs
        pushes <- go d [] tuple_components
        let rep_to_maybe :: PrimOrVoidRep -> Maybe PrimRep
            rep_to_maybe PrimOrVoidRep
    VoidRep = Maybe PrimRep
    forall a. Maybe a
    Nothing
            rep_to_maybe (NVRep PrimRep
    rep) = PrimRep -> Maybe PrimRep
    forall a. a -> Maybe a
    Just PrimRep
    rep

        ret <- returnUnliftedReps d
                                  s
                                  (wordsToBytes platform $ nativeCallSize call_info)
                                  (mapMaybe (rep_to_maybe . stgArgRep1) es)
        return (mconcat pushes `appOL` 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 => Type -> Bool
    Type -> Bool
    isUnliftedType (Id -> Type
    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 GenStgBinding 'CodeGen
    bnd CgStgExpr
    body)
       = ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d ByteOff
    s Map Id ByteOff
    p (XLet 'CodeGen -> GenStgBinding 'CodeGen -> CgStgExpr -> CgStgExpr
    forall (pass :: StgPass).
    XLet pass
    -> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
    StgLet XLetNoEscape 'CodeGen
    XLet 'CodeGen
    xlet GenStgBinding 'CodeGen
    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 Type
    _typ))
                          CgStgExpr
    body)
       = do -- Special case for a non-recursive let whose RHS is a
            -- saturated constructor application.
            -- Just allocate the constructor and carry on
            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 <- targetPlatform <$> getDynFlags
            let !d2 = ByteOff
    d ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    + Platform -> ByteOff
    wordSize Platform
    platform
            body_code <- schemeE d2 s (Map.insert x d2 p) body
            return (alloc_code `appOL` 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 GenStgBinding 'CodeGen
    binds CgStgExpr
    body) = do
         platform <- DynFlags -> Platform
    targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
         let (xs,rhss) = case binds of StgNonRec BinderP 'CodeGen
    x CgStgRhs
    rhs  -> ([Id
    BinderP 'CodeGen
    x],[CgStgRhs
    rhs])
                                       StgRec [(BinderP 'CodeGen, CgStgRhs)]
    xs_n_rhss -> [(Id, CgStgRhs)] -> ([Id], [CgStgRhs])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(Id, CgStgRhs)]
    [(BinderP 'CodeGen, CgStgRhs)]
    xs_n_rhss
             n_binds = [Id] -> WordOff
    forall i a. Num i => [a] -> i
    genericLength [Id]
    xs

             fvss  = (CgStgRhs -> [Id]) -> [CgStgRhs] -> [[Id]]
    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 = Platform -> Id -> WordOff
    idSizeW Platform
    platform
             sizes = ([Id] -> WordOff) -> [[Id]] -> [WordOff]
    forall a b. (a -> b) -> [a] -> [b]
    map (\[Id]
    rhs_fvs -> [WordOff] -> WordOff
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum ((Id -> WordOff) -> [Id] -> [WordOff]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> WordOff
    size_w [Id]
    rhs_fvs)) [[Id]]
    fvss

             -- the arity of each rhs
             arities = (CgStgRhs -> HalfWord) -> [CgStgRhs] -> [HalfWord]
    forall a b. (a -> b) -> [a] -> [b]
    map ([Id] -> HalfWord
    forall i a. Num i => [a] -> i
    genericLength ([Id] -> HalfWord) -> (CgStgRhs -> [Id]) -> CgStgRhs -> HalfWord
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ([Id], CgStgExpr) -> [Id]
    forall a b. (a, b) -> a
    fst (([Id], CgStgExpr) -> [Id])
    -> (CgStgRhs -> ([Id], CgStgExpr)) -> CgStgRhs -> [Id]
    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 -> [ByteOff] -> [ByteOff]
    mkStackOffsets ByteOff
    d (WordOff -> ByteOff -> [ByteOff]
    forall i a. Integral i => i -> a -> [a]
    genericReplicate WordOff
    n_binds (Platform -> ByteOff
    wordSize Platform
    platform))
             p' = [(Id, ByteOff)] -> Map Id ByteOff -> Map Id ByteOff
    forall key elt.
    Ord key =>
    [(key, elt)] -> Map key elt -> Map key elt
    Map.insertList ([Id] -> [ByteOff] -> [(Id, ByteOff)]
    forall a b. [a] -> [b] -> [(a, b)]
    zipE [Id]
    xs [ByteOff]
    offsets) Map Id ByteOff
    p
             d' = ByteOff
    d ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    + Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform WordOff
    n_binds
             zipE = String -> [a] -> [b] -> [(a, b)]
    forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
    zipEqual String
    "schemeE"

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

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

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

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

             compile_binds =
                [ ByteOff
    -> [Id]
    -> Id
    -> CgStgRhs
    -> WordOff
    -> HalfWord
    -> WordOff
    -> BcM (OrdList BCInstr)
    forall {a}.
    NamedThing a =>
    ByteOff
    -> [Id]
    -> a
    -> CgStgRhs
    -> WordOff
    -> HalfWord
    -> WordOff
    -> BcM (OrdList BCInstr)
    compile_bind ByteOff
    d' [Id]
    fvs Id
    x CgStgRhs
    rhs WordOff
    size HalfWord
    arity WordOff
    n
                | ([Id]
    fvs, Id
    x, CgStgRhs
    rhs, WordOff
    size, HalfWord
    arity, WordOff
    n) <-
                    [[Id]]
    -> [Id]
    -> [CgStgRhs]
    -> [WordOff]
    -> [HalfWord]
    -> [WordOff]
    -> [([Id], Id, CgStgRhs, WordOff, HalfWord, WordOff)]
    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 [WordOff]
    sizes [HalfWord]
    arities [WordOff
    n_binds, WordOff
    n_bindsWordOff -> WordOff -> WordOff
    forall a. Num a => a -> a -> a
    -WordOff
    1 .. WordOff
    1]
                ]
         body_code <- schemeE d' s p' body
         thunk_codes <- sequence compile_binds
         return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)

    schemeE ByteOff
    _d ByteOff
    _s Map Id ByteOff
    _p (StgTick (Breakpoint XBreakpoint 'TickishPassStg
    _ Int
    bp_id [XTickishId 'TickishPassStg]
    _ Module
    _) CgStgExpr
    _rhs)
       = String -> BcM (OrdList BCInstr)
    forall a. HasCallStack => String -> a
    panic (String
    "schemeE: Breakpoint without let binding: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                Int -> String
    forall a. Show a => a -> String
    show Int
    bp_id String -> String -> String
    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 Id
    BinderP 'CodeGen
    bndr [CgStgAlt]
    alts

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

    -- 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) Type
    _ty) [StgArg]
    args Type
    result_ty)
       = if CCallSpec -> Bool
    isSupportedCConv CCallSpec
    ccall_spec
          then ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> CCallSpec
    -> Type
    -> [StgArg]
    -> BcM (OrdList BCInstr)
    generateCCall ByteOff
    d ByteOff
    s Map Id ByteOff
    p CCallSpec
    ccall_spec Type
    result_ty [StgArg]
    args
          else BcM (OrdList BCInstr)
    forall a. a
    unsupportedCConvException

    schemeT ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgOpApp (StgPrimOp PrimOp
    op) [StgArg]
    args Type
    _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) ([StgArg] -> [StgArg]
    forall a. [a] -> [a]
    reverse [StgArg]
    args)

    schemeT ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgOpApp (StgPrimCallOp (PrimCall FastString
    label GenUnit UnitId
    unit)) [StgArg]
    args Type
    result_ty)
       = ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> FastString
    -> Maybe (GenUnit UnitId)
    -> Type
    -> [StgArg]
    -> BcM (OrdList BCInstr)
    generatePrimCall ByteOff
    d ByteOff
    s Map Id ByteOff
    p FastString
    label (GenUnit UnitId -> Maybe (GenUnit UnitId)
    forall a. a -> Maybe a
    Just GenUnit UnitId
    unit) Type
    result_ty [StgArg]
    args

    schemeT ByteOff
    d ByteOff
    s Map Id ByteOff
    p (StgConApp DataCon
    con ConstructorNumber
    _cn [StgArg]
    args [[PrimRep]]
    _tys)
       -- Case 2: Unboxed tuple
       | 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 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 <- profilePlatform <$> getProfile
            return (alloc_con         `appOL`
                    mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN P)

       -- 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 ([StgArg] -> [StgArg]
    forall a. [a] -> [a]
    reverse [StgArg]
    args)

    schemeT ByteOff
    _ ByteOff
    _ Map Id ByteOff
    _ CgStgExpr
    e = String -> SDoc -> BcM (OrdList BCInstr)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "GHC.StgToByteCode.schemeT"
                               (StgPprOpts -> CgStgExpr -> SDoc
    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 <- BcM Profile
    getProfile
            let platform = Profile -> Platform
    profilePlatform Profile
    profile

                non_voids =
                    [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
    addArgReps ([StgArg] -> [NonVoid StgArg]
    nonVoidStgArgs [StgArg]
    args)
                (_, _, args_offsets) =
                    mkVirtHeapOffsetsWithPadding profile StdHeader non_voids

                do_pushery !ByteOff
    d (FieldOffOrPadding StgArg
    arg : [FieldOffOrPadding StgArg]
    args) = do
                    (push, arg_bytes) <- case FieldOffOrPadding StgArg
    arg of
                        (Padding Int
    l Int
    _) -> (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff))
    -> (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
    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 (NonVoid StgArg -> StgArg
    forall a. NonVoid a -> a
    fromNonVoid NonVoid StgArg
    a)
                    more_push_code <- do_pushery (d + arg_bytes) args
                    return (push `appOL` more_push_code)
                do_pushery !ByteOff
    d [] = do
                    let !n_arg_words :: WordOff
    n_arg_words = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    d ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    - ByteOff
    orig_d)
                    OrdList BCInstr -> BcM (OrdList BCInstr)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL (DataCon -> WordOff -> BCInstr
    PACK DataCon
    con WordOff
    n_arg_words))

            -- Push on the stack in the reverse order.
            do_pushery orig_d (reverse 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 <- Profile -> Platform
    profilePlatform (Profile -> Platform) -> BcM Profile -> BcM Platform
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM Profile
    getProfile
       do_pushes init_d args (map (atomRep platform) args)
      where
      do_pushes :: ByteOff -> [StgArg] -> [ArgRep] -> BcM (OrdList BCInstr)
    do_pushes !ByteOff
    d [] [ArgRep]
    reps = do
            Bool -> (() -> BcM ()) -> () -> BcM ()
    forall a. HasCallStack => Bool -> a -> a
    assert ([ArgRep] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [ArgRep]
    reps) () -> BcM ()
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            (push_fn, sz) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p (Id -> StgArg
    StgVarArg Id
    fn)
            platform <- profilePlatform <$> getProfile
            assert (sz == wordSize platform) return ()
            let slide = Platform -> ByteOff -> ByteOff -> BCInstr
    mkSlideB Platform
    platform (ByteOff
    d ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    - ByteOff
    init_d ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    + Platform -> ByteOff
    wordSize Platform
    platform) (ByteOff
    init_d ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    - ByteOff
    s)
            return (push_fn `appOL` (slide `consOL` unitOL 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) = Int -> [StgArg] -> ([StgArg], [StgArg])
    forall a. Int -> [a] -> ([a], [a])
    splitAt Int
    n [StgArg]
    args
          (next_d, push_code) <- ByteOff -> [StgArg] -> BcM (ByteOff, OrdList BCInstr)
    push_seq ByteOff
    d [StgArg]
    these_args
          platform <- profilePlatform <$> getProfile
          instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps
          --                          ^^^ for the PUSH_APPLY_ instruction
          return (push_code `appOL` (push_apply `consOL` instrs))

      push_seq :: ByteOff -> [StgArg] -> BcM (ByteOff, OrdList BCInstr)
    push_seq ByteOff
    d [] = (ByteOff, OrdList BCInstr) -> BcM (ByteOff, OrdList BCInstr)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteOff
    d, OrdList BCInstr
    forall a. OrdList a
    nilOL)
      push_seq ByteOff
    d (StgArg
    arg:[StgArg]
    args) = do
        (push_code, sz) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p StgArg
    arg
        (final_d, more_push_code) <- push_seq (d + sz) args
        return (final_d, push_code `appOL` 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]
    argReps
      | (ArgRep -> Bool) -> [ArgRep] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (ArgRep -> [ArgRep] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [ArgRep
    V16, ArgRep
    V32, ArgRep
    V64]) [ArgRep]
    argReps
      = String -> (BCInstr, Int, [ArgRep])
    forall a. HasCallStack => String -> a
    sorry String
    "SIMD vector operations are not available in GHCi"
    findPushSeq [ArgRep]
    _
      = String -> (BCInstr, Int, [ArgRep])
    forall a. HasCallStack => 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 <- BcM Profile
    getProfile
         hsc_env <- getHscEnv
         let
            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.

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

            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; see Note [Return convention for non-tuple values]
            -- for details.
            ret_frame_size_b :: StackDepth
            ret_frame_size_b | Bool
    ubx_tuple_frame =
                                 (if Bool
    profiling then ByteOff
    5 else ByteOff
    4) ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    * Platform -> ByteOff
    wordSize Platform
    platform
                             | Bool
    otherwise = ByteOff
    2 ByteOff -> ByteOff -> ByteOff
    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 | Bool
    profiling Bool -> Bool -> Bool
    &&
                              Bool -> Bool
    not Bool
    ubx_tuple_frame = ByteOff
    2 ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    * Platform -> ByteOff
    wordSize Platform
    platform
                            | Bool
    otherwise = ByteOff
    0

            -- The size of the return frame info table pointer if one exists
            unlifted_itbl_size_b :: StackDepth
            unlifted_itbl_size_b | Bool
    ubx_tuple_frame = Platform -> ByteOff
    wordSize Platform
    platform
                                 | Bool
    otherwise       = ByteOff
    0

            (bndr_size, call_info, args_offsets)
               | ubx_tuple_frame =
                   let bndr_ty = Platform -> PrimRep -> CmmType
    primRepCmmType Platform
    platform
                       bndr_reps = HasDebugCallStack => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRep (Id -> Type
    idType Id
    bndr)
                       (call_info, args_offsets) =
                           layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps
                   in ( wordsToBytes platform (nativeCallSize call_info)
                      , call_info
                      , args_offsets
                      )
               | otherwise = ( wordsToBytes platform (idSizeW platform bndr)
                             , voidTupleReturnInfo
                             , []
                             )

            -- depth of stack after the return value has been pushed
            d_bndr =
                ByteOff
    d ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    + ByteOff
    ret_frame_size_b ByteOff -> ByteOff -> ByteOff
    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 ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    + ByteOff
    ret_frame_size_b ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    + ByteOff
    bndr_size ByteOff -> ByteOff -> ByteOff
    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 = Id -> ByteOff -> Map Id ByteOff -> Map Id ByteOff
    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 = Id -> Type
    idType Id
    bndr
            isAlgCase = Type -> Bool
    isAlgType Type
    bndr_ty

            -- given an alt, return a discr and code for it.
            codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList)
            codeAlt GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
    alt_con=AltCon
    DEFAULT,alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
    alt_bndrs=[BinderP 'CodeGen]
    _,alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
    alt_rhs=CgStgExpr
    rhs}
               = do rhs_code <- ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d_alts ByteOff
    s Map Id ByteOff
    p_alts CgStgExpr
    rhs
                    return (NoDiscr, rhs_code)

            codeAlt alt :: CgStgAlt
    alt@GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
    alt_con=AltCon
    _, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
    alt_bndrs=[BinderP 'CodeGen]
    bndrs, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
    alt_rhs=CgStgExpr
    rhs}
               -- primitive or nullary constructor alt: no need to UNPACK
               | [Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Id]
    real_bndrs = do
                    rhs_code <- ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    d_alts ByteOff
    s Map Id ByteOff
    p_alts CgStgExpr
    rhs
                    return (my_discr alt, rhs_code)
               | Type -> Bool
    isUnboxedTupleType Type
    bndr_ty Bool -> Bool -> Bool
    || Type -> Bool
    isUnboxedSumType Type
    bndr_ty =
                 let bndr_ty :: Id -> CmmType
    bndr_ty = Platform -> PrimRep -> CmmType
    primRepCmmType Platform
    platform (PrimRep -> CmmType) -> (Id -> PrimRep) -> Id -> CmmType
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> PrimRep
    idPrimRepU
                     tuple_start :: ByteOff
    tuple_start = ByteOff
    d_bndr
                     (NativeCallInfo
    call_info, [(Id, ByteOff)]
    args_offsets) =
                       Profile
    -> NativeCallType
    -> ByteOff
    -> (Id -> CmmType)
    -> [Id]
    -> (NativeCallInfo, [(Id, ByteOff)])
    forall a.
    Profile
    -> NativeCallType
    -> ByteOff
    -> (a -> CmmType)
    -> [a]
    -> (NativeCallInfo, [(a, ByteOff)])
    layoutNativeCall Profile
    profile
                                        NativeCallType
    NativeTupleReturn
                                        ByteOff
    0
                                        Id -> CmmType
    bndr_ty
                                        [Id]
    [BinderP 'CodeGen]
    bndrs

                     stack_bot :: ByteOff
    stack_bot = ByteOff
    d_alts

                     p' :: Map Id ByteOff
    p' = [(Id, ByteOff)] -> Map Id ByteOff -> Map Id ByteOff
    forall key elt.
    Ord key =>
    [(key, elt)] -> Map key elt -> Map key elt
    Map.insertList
                            [ (Id
    arg, ByteOff
    tuple_start ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    -
                                    Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform (NativeCallInfo -> WordOff
    nativeCallSize NativeCallInfo
    call_info) ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    +
                                    ByteOff
    offset)
                            | (Id
    arg, ByteOff
    offset) <- [(Id, ByteOff)]
    args_offsets
                            , Bool -> Bool
    not (HasDebugCallStack => Type -> Bool
    Type -> Bool
    isZeroBitTy (Type -> Bool) -> Type -> Bool
    forall a b. (a -> b) -> a -> b
    $ Id -> Type
    idType Id
    arg)]
                            Map Id ByteOff
    p_alts
                 in do
                   rhs_code <- ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    stack_bot ByteOff
    s Map Id ByteOff
    p' CgStgExpr
    rhs
                   return (NoDiscr, rhs_code)
               -- algebraic alt with some binders
               | Bool
    otherwise =
                 let (Int
    tot_wds, Int
    _ptrs_wds, [(NonVoid Id, Int)]
    args_offsets) =
                         Profile
    -> ClosureHeader
    -> [NonVoid (PrimRep, Id)]
    -> (Int, Int, [(NonVoid Id, Int)])
    forall a.
    Profile
    -> ClosureHeader
    -> [NonVoid (PrimRep, a)]
    -> (Int, Int, [(NonVoid a, Int)])
    mkVirtHeapOffsets Profile
    profile ClosureHeader
    NoHeader
                             ([NonVoid Id] -> [NonVoid (PrimRep, Id)]
    addIdReps ([Id] -> [NonVoid Id]
    nonVoidIds [Id]
    real_bndrs))
                     size :: WordOff
    size = Int -> WordOff
    WordOff Int
    tot_wds

                     stack_bot :: ByteOff
    stack_bot = ByteOff
    d_alts ByteOff -> ByteOff -> ByteOff
    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' = [(Id, ByteOff)] -> Map Id ByteOff -> Map Id ByteOff
    forall key elt.
    Ord key =>
    [(key, elt)] -> Map key elt -> Map key elt
    Map.insertList
                            [ (Id
    arg, ByteOff
    stack_bot ByteOff -> ByteOff -> ByteOff
    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

                 in do
                 Bool -> BcM ()
    forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
    massert Bool
    isAlgCase
                 rhs_code <- ByteOff
    -> ByteOff -> Map Id ByteOff -> CgStgExpr -> BcM (OrdList BCInstr)
    schemeE ByteOff
    stack_bot ByteOff
    s Map Id ByteOff
    p' CgStgExpr
    rhs
                 return (my_discr alt,
                         unitOL (UNPACK size) `appOL` rhs_code)
               where
                 real_bndrs :: [Id]
    real_bndrs = (Id -> Bool) -> [Id] -> [Id]
    forall a. (a -> Bool) -> [a] -> [a]
    filterOut Id -> Bool
    isTyVar [Id]
    [BinderP 'CodeGen]
    bndrs

            my_discr GenStgAlt pass
    alt = case GenStgAlt pass -> AltCon
    forall (pass :: StgPass). GenStgAlt pass -> AltCon
    alt_con GenStgAlt pass
    alt of
                AltCon
    DEFAULT    -> Discr
    NoDiscr {-shouldn't really happen-}
                DataAlt DataCon
    dc
                  | DataCon -> Bool
    isUnboxedTupleDataCon DataCon
    dc Bool -> Bool -> Bool
    || DataCon -> Bool
    isUnboxedSumDataCon DataCon
    dc
                  -> Discr
    NoDiscr
                  | Bool
    otherwise
                  -> Word16 -> Discr
    DiscrP (Int -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (DataCon -> Int
    dataConTag DataCon
    dc Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    fIRST_TAG))
                LitAlt Literal
    l -> case Literal
    l of
                  LitNumber LitNumType
    LitNumInt Integer
    i    -> Int -> Discr
    DiscrI (Integer -> Int
    forall a. Num a => Integer -> a
    fromInteger Integer
    i)
                  LitNumber LitNumType
    LitNumInt8 Integer
    i   -> Int8 -> Discr
    DiscrI8 (Integer -> Int8
    forall a. Num a => Integer -> a
    fromInteger Integer
    i)
                  LitNumber LitNumType
    LitNumInt16 Integer
    i  -> Int16 -> Discr
    DiscrI16 (Integer -> Int16
    forall a. Num a => Integer -> a
    fromInteger Integer
    i)
                  LitNumber LitNumType
    LitNumInt32 Integer
    i  -> Int32 -> Discr
    DiscrI32 (Integer -> Int32
    forall a. Num a => Integer -> a
    fromInteger Integer
    i)
                  LitNumber LitNumType
    LitNumInt64 Integer
    i  -> Int64 -> Discr
    DiscrI64 (Integer -> Int64
    forall a. Num a => Integer -> a
    fromInteger Integer
    i)
                  LitNumber LitNumType
    LitNumWord Integer
    w   -> Word -> Discr
    DiscrW (Integer -> Word
    forall a. Num a => Integer -> a
    fromInteger Integer
    w)
                  LitNumber LitNumType
    LitNumWord8 Integer
    w  -> Word8 -> Discr
    DiscrW8 (Integer -> Word8
    forall a. Num a => Integer -> a
    fromInteger Integer
    w)
                  LitNumber LitNumType
    LitNumWord16 Integer
    w -> Word16 -> Discr
    DiscrW16 (Integer -> Word16
    forall a. Num a => Integer -> a
    fromInteger Integer
    w)
                  LitNumber LitNumType
    LitNumWord32 Integer
    w -> Word32 -> Discr
    DiscrW32 (Integer -> Word32
    forall a. Num a => Integer -> a
    fromInteger Integer
    w)
                  LitNumber LitNumType
    LitNumWord64 Integer
    w -> Word64 -> Discr
    DiscrW64 (Integer -> Word64
    forall a. Num a => Integer -> a
    fromInteger Integer
    w)
                  LitNumber LitNumType
    LitNumBigNat Integer
    _ -> Discr
    unsupported
                  LitFloat Rational
    r               -> Float -> Discr
    DiscrF (Rational -> Float
    forall a. Fractional a => Rational -> a
    fromRational Rational
    r)
                  LitDouble Rational
    r              -> Double -> Discr
    DiscrD (Rational -> Double
    forall a. Fractional a => Rational -> a
    fromRational Rational
    r)
                  LitChar Char
    i                -> Int -> Discr
    DiscrI (Char -> Int
    ord Char
    i)
                  LitString {}             -> Discr
    unsupported
                  LitRubbish {}            -> Discr
    unsupported
                  LitNullAddr {}           -> Discr
    unsupported
                  LitLabel {}              -> Discr
    unsupported
                  where
                      unsupported :: Discr
    unsupported = String -> SDoc -> Discr
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "schemeE(StgCase).my_discr:" (Literal -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Literal
    l)

            maybe_ncons
               | Bool -> Bool
    not Bool
    isAlgCase = Maybe Int
    forall a. Maybe a
    Nothing
               | Bool
    otherwise
               = case [DataCon
    dc | DataAlt DataCon
    dc <- CgStgAlt -> AltCon
    forall (pass :: StgPass). GenStgAlt pass -> AltCon
    alt_con (CgStgAlt -> AltCon) -> [CgStgAlt] -> [AltCon]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [CgStgAlt]
    alts] of
                    []     -> Maybe Int
    forall a. Maybe a
    Nothing
                    (DataCon
    dc:[DataCon]
    _) -> Int -> Maybe Int
    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)
            (extra_pointers, extra_slots)
               | ubx_tuple_frame && profiling = ([1], 3) -- call_info, tuple_BCO, CCCS
               | ubx_tuple_frame              = ([1], 2) -- call_info, tuple_BCO
               | otherwise                    = ([], 0)

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

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

            pointers =
              [Int]
    extra_pointers [Int] -> [Int] -> [Int]
    forall a. [a] -> [a] -> [a]
    ++
              (Int -> Bool) -> [Int] -> [Int]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    bitmap_size') ((Int -> Int) -> [Int] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> Int -> Int
    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 (IntSet -> [Int]) -> IntSet -> [Int]
    forall a b. (a -> b) -> a -> b
    $ [Int] -> IntSet
    IntSet.fromList ([Int] -> IntSet) -> [Int] -> IntSet
    forall a b. (a -> b) -> a -> b
    $ Map Id Int -> [Int]
    forall k a. Map k a -> [a]
    Map.elems (Map Id Int -> [Int]) -> Map Id Int -> [Int]
    forall a b. (a -> b) -> a -> b
    $ (Id -> ByteOff -> Maybe Int) -> Map Id ByteOff -> Map Id Int
    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 | Type -> Bool
    isUnboxedTupleType (Id -> Type
    idType Id
    id) Bool -> Bool -> Bool
    ||
                                 Type -> Bool
    isUnboxedSumType (Id -> Type
    idType Id
    id) = Maybe Int
    forall a. Maybe a
    Nothing
                               | ArgRep -> Bool
    isFollowableArg (Platform -> Id -> ArgRep
    idArgRep Platform
    platform Id
    id) = Int -> Maybe Int
    forall a. a -> Maybe a
    Just (WordOff -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral WordOff
    rel_offset)
                               | Bool
    otherwise                      = Maybe Int
    forall a. Maybe a
    Nothing
                    where rel_offset :: WordOff
    rel_offset = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    d ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    - ByteOff
    offset)

            bitmap = Platform -> Int -> [Int] -> [StgWord]
    intsToReverseBitmap Platform
    platform Int
    bitmap_size' [Int]
    pointers

         alt_stuff <- mapM codeAlt alts
         alt_final0 <- mkMultiBranch maybe_ncons alt_stuff

         let alt_final
               | Bool
    ubx_tuple_frame    = WordOff -> WordOff -> BCInstr
    SLIDE WordOff
    0 WordOff
    2 BCInstr -> OrdList BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a -> OrdList a
    `consOL` OrdList BCInstr
    alt_final0
               | Bool
    otherwise          = OrdList BCInstr
    alt_final0

         let
             alt_bco_name = Id -> Name
    forall a. NamedThing a => a -> Name
    getName Id
    bndr
             alt_bco = Platform
    -> Name
    -> OrdList BCInstr
    -> Either [CgStgAlt] CgStgRhs
    -> Int
    -> WordOff
    -> [StgWord]
    -> Bool
    -> [FFIInfo]
    -> ProtoBCO Name
    forall name.
    Platform
    -> name
    -> OrdList BCInstr
    -> Either [CgStgAlt] CgStgRhs
    -> Int
    -> WordOff
    -> [StgWord]
    -> Bool
    -> [FFIInfo]
    -> ProtoBCO name
    mkProtoBCO Platform
    platform Name
    alt_bco_name OrdList BCInstr
    alt_final ([CgStgAlt] -> Either [CgStgAlt] CgStgRhs
    forall a b. a -> Either a b
    Left [CgStgAlt]
    alts)
                           Int
    0{-no arity-} WordOff
    bitmap_size [StgWord]
    bitmap Bool
    True{-is alts-}
         scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
                               (d + ret_frame_size_b + save_ccs_size_b)
                               p scrut
         alt_bco' <- emitBc alt_bco
         if ubx_tuple_frame
           then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)
                   return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco
                           `consOL` scrut_code)
           else let scrut_rep = case [ArgRep]
    non_void_arg_reps of
                      []    -> ArgRep
    V
                      [ArgRep
    rep] -> ArgRep
    rep
                      [ArgRep]
    _     -> String -> ArgRep
    forall a. HasCallStack => String -> a
    panic String
    "schemeE(StgCase).push_alts"
                in return (PUSH_ALTS alt_bco' scrut_rep `consOL` scrut_code)

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

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

    layoutNativeCall :: Profile
                     -> NativeCallType
                     -> ByteOff
                     -> (a -> CmmType)
                     -> [a]
                     -> ( NativeCallInfo      -- See Note [GHCi TupleInfo]
                        , [(a, ByteOff)] -- argument, offset on stack
                        )
    layoutNativeCall :: forall a.
    Profile
    -> NativeCallType
    -> ByteOff
    -> (a -> CmmType)
    -> [a]
    -> (NativeCallInfo, [(a, ByteOff)])
    layoutNativeCall Profile
    profile NativeCallType
    call_type 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) = Profile
    -> Int
    -> Convention
    -> (a -> CmmType)
    -> [a]
    -> (Int, [(a, ParamLocation)])
    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, Int -> ByteOff
    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 = [(GlobalReg, Int)] -> Map GlobalReg Int
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([(GlobalReg, Int)] -> Map GlobalReg Int)
    -> [(GlobalReg, Int)] -> Map GlobalReg Int
    forall a b. (a -> b) -> a -> b
    $ [GlobalReg] -> [Int] -> [(GlobalReg, Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip (Platform -> [GlobalReg]
    allArgRegsCover Platform
    platform) [Int
    0..]

          reg_order :: GlobalReg -> (Int, GlobalReg)
          reg_order :: GlobalReg -> (Int, GlobalReg)
    reg_order GlobalReg
    reg | Just Int
    n <- GlobalReg -> Map GlobalReg Int -> Maybe Int
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup GlobalReg
    reg Map GlobalReg Int
    regs_order = (Int
    n, GlobalReg
    reg)
          -- 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)
              = [((Int, GlobalReg), a)] -> ([(Int, GlobalReg)], [a])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([((Int, GlobalReg), a)] -> ([(Int, GlobalReg)], [a]))
    -> [((Int, GlobalReg), a)] -> ([(Int, GlobalReg)], [a])
    forall a b. (a -> b) -> a -> b
    $ (((Int, GlobalReg), a) -> ((Int, GlobalReg), a) -> Ordering)
    -> [((Int, GlobalReg), a)] -> [((Int, GlobalReg), a)]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy ((((Int, GlobalReg), a) -> (Int, GlobalReg))
    -> ((Int, GlobalReg), a) -> ((Int, GlobalReg), a) -> Ordering
    forall a b. Ord a => (b -> a) -> b -> b -> Ordering
    comparing ((Int, GlobalReg), a) -> (Int, GlobalReg)
    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) = Platform
    -> Int -> (a -> CmmType) -> [a] -> (Int, [(a, ParamLocation)])
    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 = [GlobalReg] -> RegSet GlobalReg
    forall r. Ord r => [r] -> RegSet r
    mkRegSet (((Int, GlobalReg) -> GlobalReg)
    -> [(Int, GlobalReg)] -> [GlobalReg]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, GlobalReg) -> GlobalReg
    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, Int -> b
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    y)
          get_byte_off (a, ParamLocation)
    _                 =
              String -> (a, b)
    forall a. HasCallStack => String -> a
    panic String
    "GHC.StgToByteCode.layoutTuple get_byte_off"

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

    {- Note [Return convention for non-tuple values]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The RETURN and ENTER instructions are used to return values. RETURN directly
    returns the value at the top of the stack while ENTER evaluates it first (so
    RETURN is only used when the result is already known to be evaluated), but the
    end result is the same: control returns to the enclosing stack frame with the
    result at the top of the stack.

    The PUSH_ALTS instruction pushes a two-word stack frame that receives a single
    lifted value. Its payload is a BCO that is executed when control returns, with
    the stack set up as if a RETURN instruction had just been executed: the returned
    value is at the top of the stack, and beneath it is the two-word frame being
    returned to. It is the continuation BCO’s job to pop its own frame off the
    stack, so the simplest possible continuation consists of two instructions:

        SLIDE 1 2   -- pop the return frame off the stack, keeping the returned value
        RETURN P    -- return the returned value to our caller

    RETURN and PUSH_ALTS are not really instructions but are in fact representation-
    polymorphic *families* of instructions indexed by ArgRep. ENTER, however, is a
    single real instruction, since it is only used to return lifted values, which
    are always pointers.

    The RETURN, ENTER, and PUSH_ALTS instructions are only used when the returned
    value has nullary or unary representation. Returning/receiving an unboxed
    tuple (or, indirectly, an unboxed sum, since unboxed sums have been desugared to
    unboxed tuples by Unarise) containing two or more results uses the special
    RETURN_TUPLE/PUSH_ALTS_TUPLE instructions, which use a different return
    convention. See Note [unboxed tuple bytecodes and tuple_BCO] for details.

    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 call_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 call_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
          call_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 call_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
         * call_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 call_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
          call_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 call_info word
      ===================

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

      See Note [GHCi and native call registers] for more details of how the
      data is packed in a single word.

     -}

    tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
    tupleBCO :: Platform
    -> NativeCallInfo
    -> [(PrimRep, ByteOff)]
    -> [FFIInfo]
    -> ProtoBCO Name
    tupleBCO Platform
    platform NativeCallInfo
    args_info [(PrimRep, ByteOff)]
    args =
      Platform
    -> Name
    -> OrdList BCInstr
    -> Either [CgStgAlt] CgStgRhs
    -> Int
    -> WordOff
    -> [StgWord]
    -> Bool
    -> [FFIInfo]
    -> ProtoBCO Name
    forall name.
    Platform
    -> name
    -> OrdList BCInstr
    -> Either [CgStgAlt] CgStgRhs
    -> Int
    -> WordOff
    -> [StgWord]
    -> Bool
    -> [FFIInfo]
    -> ProtoBCO name
    mkProtoBCO Platform
    platform Name
    invented_name OrdList BCInstr
    body_code ([CgStgAlt] -> Either [CgStgAlt] CgStgRhs
    forall a b. a -> Either a b
    Left [])
                 Int
    0{-no arity-} WordOff
    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 call_info word,
        -- which is not a pointer
        nptrs_prefix :: WordOff
    nptrs_prefix = WordOff
    1
        (WordOff
    bitmap_size, [StgWord]
    bitmap) = Platform
    -> WordOff
    -> NativeCallInfo
    -> [(PrimRep, ByteOff)]
    -> (WordOff, [StgWord])
    mkStackBitmap Platform
    platform WordOff
    nptrs_prefix NativeCallInfo
    args_info [(PrimRep, ByteOff)]
    args

        body_code :: OrdList BCInstr
    body_code = WordOff -> WordOff -> OrdList BCInstr
    mkSlideW WordOff
    0 WordOff
    1          -- pop frame header
                    OrdList BCInstr -> BCInstr -> OrdList BCInstr
    forall a. OrdList a -> a -> OrdList a
    `snocOL` BCInstr
    RETURN_TUPLE -- and add it again

    primCallBCO ::  Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
    primCallBCO :: Platform
    -> NativeCallInfo
    -> [(PrimRep, ByteOff)]
    -> [FFIInfo]
    -> ProtoBCO Name
    primCallBCO Platform
    platform NativeCallInfo
    args_info [(PrimRep, ByteOff)]
    args =
      Platform
    -> Name
    -> OrdList BCInstr
    -> Either [CgStgAlt] CgStgRhs
    -> Int
    -> WordOff
    -> [StgWord]
    -> Bool
    -> [FFIInfo]
    -> ProtoBCO Name
    forall name.
    Platform
    -> name
    -> OrdList BCInstr
    -> Either [CgStgAlt] CgStgRhs
    -> Int
    -> WordOff
    -> [StgWord]
    -> Bool
    -> [FFIInfo]
    -> ProtoBCO name
    mkProtoBCO Platform
    platform Name
    invented_name OrdList BCInstr
    body_code ([CgStgAlt] -> Either [CgStgAlt] CgStgRhs
    forall a b. a -> Either a b
    Left [])
                 Int
    0{-no arity-} WordOff
    bitmap_size [StgWord]
    bitmap Bool
    False{-is alts-}
      where
        {-
          The primcall 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
    "primcall")

        -- The first two words in the frame (after the BCO) are the call_info word
        -- and the pointer to the Cmm function being called. Neither of these is a
        -- pointer that should be followed by the garbage collector.
        nptrs_prefix :: WordOff
    nptrs_prefix = WordOff
    2
        (WordOff
    bitmap_size, [StgWord]
    bitmap) = Platform
    -> WordOff
    -> NativeCallInfo
    -> [(PrimRep, ByteOff)]
    -> (WordOff, [StgWord])
    mkStackBitmap Platform
    platform WordOff
    nptrs_prefix NativeCallInfo
    args_info [(PrimRep, ByteOff)]
    args

        -- if the primcall BCO is ever run it's a bug, since the BCO should only
        -- be pushed immediately before running the PRIMCALL bytecode instruction,
        -- which immediately leaves the interpreter to jump to the stg_primcall_info
        -- Cmm function
        body_code :: OrdList BCInstr
    body_code =  BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL BCInstr
    CASEFAIL

    -- | Builds a bitmap for a stack layout with a nonpointer prefix followed by
    -- some number of arguments.
    mkStackBitmap
      :: Platform
      -> WordOff
      -- ^ The number of nonpointer words that prefix the arguments.
      -> NativeCallInfo
      -> [(PrimRep, ByteOff)]
      -- ^ The stack layout of the arguments, where each offset is relative to the
      -- /bottom/ of the stack space they occupy. Their offsets must be word-aligned,
      -- and the list must be sorted in order of ascending offset (i.e. bottom to top).
      -> (WordOff, [StgWord])
    mkStackBitmap :: Platform
    -> WordOff
    -> NativeCallInfo
    -> [(PrimRep, ByteOff)]
    -> (WordOff, [StgWord])
    mkStackBitmap Platform
    platform WordOff
    nptrs_prefix NativeCallInfo
    args_info [(PrimRep, ByteOff)]
    args
      = (WordOff
    bitmap_size, [StgWord]
    bitmap)
      where
        bitmap_size :: WordOff
    bitmap_size = WordOff
    nptrs_prefix WordOff -> WordOff -> WordOff
    forall a. Num a => a -> a -> a
    + WordOff
    arg_bottom
        bitmap :: [StgWord]
    bitmap = Platform -> Int -> [Int] -> [StgWord]
    intsToReverseBitmap Platform
    platform (WordOff -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral WordOff
    bitmap_size) [Int]
    ptr_offsets

        arg_bottom :: WordOff
    arg_bottom = NativeCallInfo -> WordOff
    nativeCallSize NativeCallInfo
    args_info
        ptr_offsets :: [Int]
    ptr_offsets = [Int] -> [Int]
    forall a. [a] -> [a]
    reverse ([Int] -> [Int]) -> [Int] -> [Int]
    forall a b. (a -> b) -> a -> b
    $ (ByteOff -> Int) -> [ByteOff] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map (WordOff -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (WordOff -> Int) -> (ByteOff -> WordOff) -> ByteOff -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteOff -> WordOff
    convert_arg_offset)
                    ([ByteOff] -> [Int]) -> [ByteOff] -> [Int]
    forall a b. (a -> b) -> a -> b
    $ ((PrimRep, ByteOff) -> Maybe ByteOff)
    -> [(PrimRep, ByteOff)] -> [ByteOff]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (PrimRep, ByteOff) -> Maybe ByteOff
    get_ptr_offset [(PrimRep, ByteOff)]
    args

        get_ptr_offset :: (PrimRep, ByteOff) -> Maybe ByteOff
        get_ptr_offset :: (PrimRep, ByteOff) -> Maybe ByteOff
    get_ptr_offset (PrimRep
    rep, ByteOff
    byte_offset)
          | ArgRep -> Bool
    isFollowableArg (Platform -> PrimRep -> ArgRep
    toArgRep Platform
    platform PrimRep
    rep) = ByteOff -> Maybe ByteOff
    forall a. a -> Maybe a
    Just ByteOff
    byte_offset
          | Bool
    otherwise                               = Maybe ByteOff
    forall a. Maybe a
    Nothing

        convert_arg_offset :: ByteOff -> WordOff
        convert_arg_offset :: ByteOff -> WordOff
    convert_arg_offset ByteOff
    arg_offset =
          -- The argument offsets are relative to `arg_bottom`, but
          -- `intsToReverseBitmap` expects offsets from the top, so we need to flip
          -- them around.
          WordOff
    nptrs_prefix WordOff -> WordOff -> WordOff
    forall a. Num a => a -> a -> a
    + (WordOff
    arg_bottom WordOff -> WordOff -> WordOff
    forall a. Num a => a -> a -> a
    - Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform ByteOff
    arg_offset)

    -- -----------------------------------------------------------------------------
    -- Deal with a primitive call to native code.

    generatePrimCall
        :: StackDepth
        -> Sequel
        -> BCEnv
        -> CLabelString          -- where to call
        -> Maybe Unit
        -> Type
        -> [StgArg]              -- args (atoms)
        -> BcM BCInstrList
    generatePrimCall :: ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> FastString
    -> Maybe (GenUnit UnitId)
    -> Type
    -> [StgArg]
    -> BcM (OrdList BCInstr)
    generatePrimCall ByteOff
    d ByteOff
    s Map Id ByteOff
    p FastString
    target Maybe (GenUnit UnitId)
    _mb_unit Type
    _result_ty [StgArg]
    args
     = do
         profile <- BcM Profile
    getProfile
         let
             platform = Profile -> Platform
    profilePlatform Profile
    profile

             non_void PrimOrVoidRep
    VoidRep = Bool
    False
             non_void PrimOrVoidRep
    _       = Bool
    True

             nv_args :: [StgArg]
             nv_args = (StgArg -> Bool) -> [StgArg] -> [StgArg]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (PrimOrVoidRep -> Bool
    non_void (PrimOrVoidRep -> Bool)
    -> (StgArg -> PrimOrVoidRep) -> StgArg -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . StgArg -> PrimOrVoidRep
    stgArgRep1) [StgArg]
    args

             (args_info, args_offsets) =
                  layoutNativeCall profile
                                   NativePrimCall
                                   0
                                   (primRepCmmType platform . stgArgRepU)
                                   nv_args

             prim_args_offsets = (StgArg -> PrimRep) -> [(StgArg, ByteOff)] -> [(PrimRep, ByteOff)]
    forall (f :: * -> *) a c b.
    Functor f =>
    (a -> c) -> f (a, b) -> f (c, b)
    mapFst StgArg -> PrimRep
    stgArgRepU [(StgArg, ByteOff)]
    args_offsets
             shifted_args_offsets = (ByteOff -> ByteOff) -> [(StgArg, ByteOff)] -> [(StgArg, ByteOff)]
    forall (f :: * -> *) b c a.
    Functor f =>
    (b -> c) -> f (a, b) -> f (a, c)
    mapSnd (ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    + ByteOff
    d) [(StgArg, ByteOff)]
    args_offsets

             push_target = Literal -> WordOff -> BCInstr
    PUSH_UBX (FastString -> Maybe Int -> FunctionOrData -> Literal
    LitLabel FastString
    target Maybe Int
    forall a. Maybe a
    Nothing FunctionOrData
    IsFunction) WordOff
    1
             push_info = Literal -> WordOff -> BCInstr
    PUSH_UBX (Platform -> NativeCallInfo -> Literal
    mkNativeCallInfoLit Platform
    platform NativeCallInfo
    args_info) WordOff
    1
             {-
                compute size to move payload (without stg_primcall_info header)

                size of arguments plus three words for:
                    - function pointer to the target
                    - call_info word
                    - BCO to describe the stack frame
              -}
             szb = Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform (NativeCallInfo -> WordOff
    nativeCallSize NativeCallInfo
    args_info WordOff -> WordOff -> WordOff
    forall a. Num a => a -> a -> a
    + WordOff
    3)
             go ByteOff
    _   [OrdList BCInstr]
    pushes [] = [OrdList BCInstr] -> BcM [OrdList BCInstr]
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([OrdList BCInstr] -> [OrdList BCInstr]
    forall a. [a] -> [a]
    reverse [OrdList BCInstr]
    pushes)
             go !ByteOff
    dd [OrdList BCInstr]
    pushes ((StgArg
    a, ByteOff
    off):[(StgArg, ByteOff)]
    cs) = do (push, szb) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    dd Map Id ByteOff
    p StgArg
    a
                                              massert (off == dd + szb)
                                              go (dd + szb) (push:pushes) cs
         push_args <- go d [] shifted_args_offsets
         args_bco <- emitBc (primCallBCO platform args_info prim_args_offsets)
         return $ mconcat push_args `appOL`
                  (push_target `consOL`
                   push_info `consOL`
                   PUSH_BCO args_bco `consOL`
                   (mkSlideB platform szb (d - s) `consOL` unitOL PRIMCALL))

    -- -----------------------------------------------------------------------------
    -- 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
    -> Type
    -> [StgArg]
    -> BcM (OrdList BCInstr)
    generateCCall ByteOff
    d0 ByteOff
    s Map Id ByteOff
    p (CCallSpec CCallTarget
    target CCallConv
    PrimCallConv Safety
    _) Type
    result_ty [StgArg]
    args
     | (StaticTarget SourceText
    _ FastString
    label Maybe (GenUnit UnitId)
    mb_unit Bool
    _) <- CCallTarget
    target
     = ByteOff
    -> ByteOff
    -> Map Id ByteOff
    -> FastString
    -> Maybe (GenUnit UnitId)
    -> Type
    -> [StgArg]
    -> BcM (OrdList BCInstr)
    generatePrimCall ByteOff
    d0 ByteOff
    s Map Id ByteOff
    p FastString
    label Maybe (GenUnit UnitId)
    mb_unit Type
    result_ty [StgArg]
    args
     | Bool
    otherwise
     = String -> BcM (OrdList BCInstr)
    forall a. HasCallStack => String -> a
    panic String
    "GHC.StgToByteCode.generateCCall: primcall convention only supports static targets"
    generateCCall ByteOff
    d0 ByteOff
    s Map Id ByteOff
    p (CCallSpec CCallTarget
    target CCallConv
    cconv Safety
    safety) Type
    result_ty [StgArg]
    args
     = do
         profile <- BcM Profile
    getProfile

         let
             args_r_to_l = [StgArg] -> [StgArg]
    forall a. [a] -> [a]
    reverse [StgArg]
    args
             platform = Profile -> Platform
    profilePlatform Profile
    profile
             -- useful constants
             addr_size_b :: ByteOff
             addr_size_b = Platform -> ByteOff
    wordSize Platform
    platform

             arrayish_rep_hdr_size :: TyCon -> Maybe Int
             arrayish_rep_hdr_size TyCon
    t
               | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    arrayPrimTyCon Bool -> Bool -> Bool
    || TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    mutableArrayPrimTyCon
                  = Int -> Maybe Int
    forall a. a -> Maybe a
    Just (Profile -> Int
    arrPtrsHdrSize Profile
    profile)
               | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    smallArrayPrimTyCon Bool -> Bool -> Bool
    || TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    smallMutableArrayPrimTyCon
                  = Int -> Maybe Int
    forall a. a -> Maybe a
    Just (Profile -> Int
    smallArrPtrsHdrSize Profile
    profile)
               | TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    byteArrayPrimTyCon Bool -> Bool -> Bool
    || TyCon
    t TyCon -> TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == TyCon
    mutableByteArrayPrimTyCon
                  = Int -> Maybe Int
    forall a. a -> Maybe a
    Just (Profile -> Int
    arrWordsHdrSize Profile
    profile)
               | Bool
    otherwise
                  = Maybe Int
    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, PrimOrVoidRep)]
             pargs ByteOff
    _ [] = [(OrdList BCInstr, PrimOrVoidRep)]
    -> BcM [(OrdList BCInstr, PrimOrVoidRep)]
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
             pargs ByteOff
    d (aa :: StgArg
    aa@(StgVarArg Id
    a):[StgArg]
    az)
                | Just TyCon
    t      <- Type -> Maybe TyCon
    tyConAppTyCon_maybe (Id -> Type
    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 rest <- ByteOff -> [StgArg] -> BcM [(OrdList BCInstr, PrimOrVoidRep)]
    pargs (ByteOff
    d ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    + ByteOff
    addr_size_b) [StgArg]
    az
                     (push_fo, _) <- pushAtom d p aa
                     -- The ptr points at the header.  Advance it over the
                     -- header and then pretend this is an Addr#.
                     let code = OrdList BCInstr
    push_fo OrdList BCInstr -> BCInstr -> OrdList BCInstr
    forall a. OrdList a -> a -> OrdList a
    `snocOL` WordOff -> Int -> BCInstr
    SWIZZLE WordOff
    0 (Int -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    hdr_sz)
                     return ((code, NVRep AddrRep) : rest)
             pargs ByteOff
    d (StgArg
    aa:[StgArg]
    az) =  do (code_a, sz_a) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p StgArg
    aa
                                   rest <- pargs (d + sz_a) az
                                   return ((code_a, stgArgRep1 aa) : rest)

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

             push_args    = [OrdList BCInstr] -> OrdList BCInstr
    forall a. [OrdList a] -> OrdList a
    concatOL [OrdList BCInstr]
    pushs_arg
             !d_after_args = ByteOff
    d0 ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    + Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform WordOff
    a_reps_sizeW
             a_reps_pushed_RAW
                | PrimOrVoidRep
    VoidRep:[PrimOrVoidRep]
    xs <- [PrimOrVoidRep]
    a_reps_pushed_r_to_l
                = [PrimOrVoidRep] -> [PrimOrVoidRep]
    forall a. [a] -> [a]
    reverse [PrimOrVoidRep]
    xs
                | Bool
    otherwise
                = String -> [PrimOrVoidRep]
    forall a. HasCallStack => String -> a
    panic String
    "GHC.StgToByteCode.generateCCall: missing or invalid World token?"

             -- 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.
             r_rep = Type -> PrimOrVoidRep
    maybe_getCCallReturnRep Type
    result_ty
             {-
             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 marshal 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 marshal_code ( StgWord* ptr_to_top_of_stack )
             -}
             -- resolve static address
             maybe_static_target :: Maybe Literal
             maybe_static_target =
                 case CCallTarget
    target of
                     CCallTarget
    DynamicTarget -> Maybe Literal
    forall a. Maybe a
    Nothing
                     StaticTarget SourceText
    _ FastString
    _ Maybe (GenUnit UnitId)
    _ Bool
    False ->
                       String -> Maybe Literal
    forall a. HasCallStack => String -> a
    panic String
    "generateCCall: unexpected FFI value import"
                     StaticTarget SourceText
    _ FastString
    target Maybe (GenUnit UnitId)
    _ Bool
    True ->
                       Literal -> Maybe Literal
    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
                              = Int -> Maybe Int
    forall a. a -> Maybe a
    Just (WordOff -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral WordOff
    a_reps_sizeW Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Platform -> Int
    platformWordSizeInBytes Platform
    platform)
                              | Bool
    otherwise
                              = Maybe Int
    forall a. Maybe a
    Nothing

         let
             is_static = Maybe Literal -> Bool
    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 --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
                    | Bool
    is_static = [PrimOrVoidRep]
    a_reps_pushed_RAW
                    | PrimOrVoidRep
    _:[PrimOrVoidRep]
    xs <- [PrimOrVoidRep]
    a_reps_pushed_RAW = [PrimOrVoidRep]
    xs
                    | Bool
    otherwise = String -> [PrimOrVoidRep]
    forall a. HasCallStack => String -> a
    panic String
    "GHC.StgToByteCode.generateCCall: dyn with no args"

             -- push the Addr#
             (push_Addr, d_after_Addr)
                | Just machlabel <- maybe_static_target
                = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b)
                | otherwise -- is already on the stack
                = (nilOL, d_after_args)

             -- Push the return placeholder.  For a call returning nothing,
             -- this is a V (tag).
             r_sizeW   = Platform -> PrimOrVoidRep -> WordOff
    repSizeWords Platform
    platform PrimOrVoidRep
    r_rep
             d_after_r = ByteOff
    d_after_Addr ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    + Platform -> WordOff -> ByteOff
    wordsToBytes Platform
    platform WordOff
    r_sizeW
             push_r = case PrimOrVoidRep
    r_rep of
                        PrimOrVoidRep
    VoidRep -> OrdList BCInstr
    forall a. OrdList a
    nilOL
                        NVRep PrimRep
    r -> BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL (Literal -> WordOff -> BCInstr
    PUSH_UBX (Platform -> PrimRep -> Literal
    mkDummyLiteral Platform
    platform PrimRep
    r) 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   = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    d_after_r ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    - ByteOff
    s)

             conv = case CCallConv
    cconv of
               CCallConv
    CCallConv -> FFIConv
    FFICCall
               CCallConv
    CApiConv  -> FFIConv
    FFICCall
               CCallConv
    StdCallConv -> FFIConv
    FFIStdCall
               CCallConv
    _ -> String -> FFIConv
    forall a. HasCallStack => 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 = Platform -> PrimOrVoidRep -> FFIType
    primRepToFFIType Platform
    platform PrimOrVoidRep
    r_rep
             ffiargs = (PrimOrVoidRep -> FFIType) -> [PrimOrVoidRep] -> [FFIType]
    forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> PrimOrVoidRep -> FFIType
    primRepToFFIType Platform
    platform) [PrimOrVoidRep]
    a_reps
         interp <- hscInterp <$> getHscEnv
         token <- ioToBc $ interpCmd interp (PrepFFI conv ffiargs ffires)
         recordFFIBc token

         let
             -- do the call
             do_call      = BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL (WordOff -> RemotePtr C_ffi_cif -> Word16 -> BCInstr
    CCALL WordOff
    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 = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    d_after_r ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    - ByteOff
    s)
             wrapup       = WordOff -> WordOff -> OrdList BCInstr
    mkSlideW WordOff
    r_sizeW (WordOff
    d_after_r_min_s WordOff -> WordOff -> WordOff
    forall a. Num a => a -> a -> a
    - WordOff
    r_sizeW)
                            OrdList BCInstr -> BCInstr -> OrdList BCInstr
    forall a. OrdList a -> a -> OrdList a
    `snocOL` ArgRep -> BCInstr
    RETURN (Platform -> PrimOrVoidRep -> ArgRep
    toArgRepOrV Platform
    platform PrimOrVoidRep
    r_rep)
             --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $
         return (
             push_args `appOL`
             push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
             )

    primRepToFFIType :: Platform -> PrimOrVoidRep -> FFIType
    primRepToFFIType :: Platform -> PrimOrVoidRep -> FFIType
    primRepToFFIType Platform
    _ PrimOrVoidRep
    VoidRep = FFIType
    FFIVoid
    primRepToFFIType Platform
    platform (NVRep PrimRep
    r)
      = case PrimRep
    r of
         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
         BoxedRep Maybe Levity
    _  -> FFIType
    FFIPointer
         PrimRep
    _           -> String -> SDoc -> FFIType
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "primRepToFFIType" (PrimRep -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr PrimRep
    r)
      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
            BoxedRep Maybe Levity
    _  -> Literal
    LitNullAddr
            PrimRep
    _           -> String -> SDoc -> Literal
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "mkDummyLiteral" (PrimRep -> SDoc
    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  NVRep 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  VoidRep

    maybe_getCCallReturnRep :: Type -> PrimOrVoidRep
    maybe_getCCallReturnRep :: Type -> PrimOrVoidRep
    maybe_getCCallReturnRep Type
    fn_ty
       = let
           ([Scaled Type]
    _a_tys, Type
    r_ty) = Type -> ([Scaled Type], Type)
    splitFunTys (Type -> Type
    dropForAlls Type
    fn_ty)
         in
           case HasDebugCallStack => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRep Type
    r_ty of
             [] -> PrimOrVoidRep
    VoidRep
             [PrimRep
    rep] -> PrimRep -> PrimOrVoidRep
    NVRep PrimRep
    rep

                     -- if it was, it would be impossible to create a
                     -- valid return value placeholder on the stack
             [PrimRep]
    _ -> String -> SDoc -> PrimOrVoidRep
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "maybe_getCCallReturn: can't handle:"
                             (Type -> SDoc
    pprType Type
    fn_ty)

    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] Type
    t)
      = (Id, [Name]) -> Maybe (Id, [Name])
    forall a. a -> Maybe a
    Just (Id
    v, Type -> [Name]
    extract_constr_Names Type
    t)
      where
        extract_constr_Names :: Type -> [Name]
    extract_constr_Names Type
    ty
               | Type
    rep_ty <- Type -> Type
    unwrapType Type
    ty
               , Just TyCon
    tyc <- Type -> Maybe TyCon
    tyConAppTyCon_maybe Type
    rep_ty
               , TyCon -> Bool
    isDataTyCon TyCon
    tyc
               = (DataCon -> Name) -> [DataCon] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map (Id -> Name
    forall a. NamedThing a => a -> Name
    getName (Id -> Name) -> (DataCon -> Id) -> DataCon -> Name
    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
               = String -> SDoc -> [Name]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "maybe_is_tagToEnum_call.extract_constr_Ids" (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty)
    maybe_is_tagToEnum_call CgStgExpr
    _ = Maybe (Id, [Name])
    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

                    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
    -}

    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
      = Bool -> BcM (OrdList BCInstr) -> BcM (OrdList BCInstr)
    forall a. HasCallStack => Bool -> a -> a
    assert ([Name] -> Bool
    forall (f :: * -> *) a. Foldable f => f a -> Bool
    notNull [Name]
    names) (BcM (OrdList BCInstr) -> BcM (OrdList BCInstr))
    -> BcM (OrdList BCInstr) -> BcM (OrdList BCInstr)
    forall a b. (a -> b) -> a -> b
    $
        do (push_arg, arg_bytes) <- ByteOff
    -> Map Id ByteOff -> StgArg -> BcM (OrdList BCInstr, ByteOff)
    pushAtom ByteOff
    d Map Id ByteOff
    p (Id -> StgArg
    StgVarArg Id
    arg)
           labels <- getLabelsBc (genericLength names)
           label_fail <- getLabelBc
           label_exit <- getLabelBc
           dflags <- getDynFlags
           let infos = [LocalLabel]
    -> [LocalLabel]
    -> [Int]
    -> [Name]
    -> [(LocalLabel, LocalLabel, Int, Name)]
    forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
    zip4 [LocalLabel]
    labels ([LocalLabel] -> [LocalLabel]
    forall a. HasCallStack => [a] -> [a]
    tail [LocalLabel]
    labels [LocalLabel] -> [LocalLabel] -> [LocalLabel]
    forall a. [a] -> [a] -> [a]
    ++ [LocalLabel
    label_fail])
                                   [Int
    0 ..] [Name]
    names
               platform = DynFlags -> Platform
    targetPlatform DynFlags
    dflags
               steps = ((LocalLabel, LocalLabel, Int, Name) -> OrdList BCInstr)
    -> [(LocalLabel, LocalLabel, Int, Name)] -> [OrdList BCInstr]
    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 = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    d ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    - ByteOff
    s ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    + ByteOff
    arg_bytes)

           return (push_arg
                   `appOL` concatOL steps
                   `appOL` toOL [ LABEL label_fail, CASEFAIL,
                                  LABEL label_exit ]
                   `appOL` mkSlideW 1 slide_ws
                   `appOL` unitOL 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)
               = [BCInstr] -> OrdList BCInstr
    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 => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRep (Id -> Type
    idType Id
    var)
       = (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList BCInstr
    forall a. OrdList a
    nilOL, ByteOff
    0)

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

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

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

            case szb of
                ByteOff
    1 -> (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    with_instr ByteOff -> BCInstr
    PUSH8_W
                ByteOff
    2 -> (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    with_instr ByteOff -> BCInstr
    PUSH16_W
                ByteOff
    4 -> (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    with_instr ByteOff -> BCInstr
    PUSH32_W
                ByteOff
    _ -> do
                    let !szw :: WordOff
    szw = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform ByteOff
    szb
                        !off_w :: WordOff
    off_w = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform (ByteOff
    d ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    - ByteOff
    d_v) WordOff -> WordOff -> WordOff
    forall a. Num a => a -> a -> a
    + WordOff
    szw WordOff -> WordOff -> WordOff
    forall a. Num a => a -> a -> a
    - WordOff
    1
                    (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([BCInstr] -> OrdList BCInstr
    forall a. [a] -> OrdList a
    toOL (WordOff -> BCInstr -> [BCInstr]
    forall i a. Integral i => i -> a -> [a]
    genericReplicate WordOff
    szw (WordOff -> BCInstr
    PUSH_L WordOff
    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 platform <- DynFlags -> Platform
    targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
            let !szb = Platform -> Id -> ByteOff
    idSizeCon Platform
    platform Id
    var
            massert (szb == wordSize platform)

            -- PUSH_G doesn't tag constructors. So we use PACK here
            -- if we are dealing with nullary constructor.
            case isDataConWorkId_maybe var of
              Just DataCon
    con -> do
                Bool -> BcM ()
    forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
    massert (DataCon -> Bool
    isNullaryRepDataCon DataCon
    con)
                (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL (DataCon -> WordOff -> BCInstr
    PACK DataCon
    con WordOff
    0), ByteOff
    szb)

              Maybe DataCon
    Nothing
                -- see Note [Generating code for top-level string literal bindings]
                | HasDebugCallStack => Type -> Bool
    Type -> Bool
    isUnliftedType (Id -> Type
    idType Id
    var) -> do
                  Bool -> BcM ()
    forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
    massert (Id -> Type
    idType Id
    var Type -> Type -> Bool
    `eqType` Type
    addrPrimTy)
                  (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL (Name -> BCInstr
    PUSH_ADDR (Id -> Name
    forall a. NamedThing a => a -> Name
    getName Id
    var)), ByteOff
    szb)

                | Bool
    otherwise -> do
                  (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL (Name -> BCInstr
    PUSH_G (Id -> Name
    forall a. NamedThing a => a -> Name
    getName Id
    var)), ByteOff
    szb)

    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 <- DynFlags -> Platform
    targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
         let code :: PrimRep -> BcM (BCInstrList, ByteOff)
             code PrimRep
    rep =
                (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (OrdList BCInstr
    padding_instr OrdList BCInstr -> BCInstr -> OrdList BCInstr
    forall a. OrdList a -> a -> OrdList a
    `snocOL` BCInstr
    instr, ByteOff
    size_bytes ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    + ByteOff
    padding_bytes)
              where
                size_bytes :: ByteOff
    size_bytes = Int -> ByteOff
    ByteOff (Int -> ByteOff) -> Int -> 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 ByteOff -> ByteOff -> ByteOff
    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 -> WordOff -> BCInstr
    PUSH_UBX Literal
    lit (Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform ByteOff
    size_bytes)

         case 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 TypeOrConstraint
    _ Type
    rep-> case HasDebugCallStack => SDoc -> Type -> [PrimRep]
    SDoc -> Type -> [PrimRep]
    runtimeRepPrimRep (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "pushLiteral") Type
    rep of
                                 [PrimRep
    pr] -> PrimRep -> BcM (OrdList BCInstr, ByteOff)
    code PrimRep
    pr
                                 [PrimRep]
    _    -> String -> SDoc -> BcM (OrdList BCInstr, ByteOff)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "pushLiteral" (Literal -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Literal
    lit)
            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 LitNumBigNat should be left by the time this is called. CorePrep
              -- should have converted them all to a real core representation.
              LitNumType
    LitNumBigNat  -> String -> BcM (OrdList BCInstr, ByteOff)
    forall a. HasCallStack => String -> a
    panic String
    "pushAtom: LitNumBigNat"

    -- | 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 <- DynFlags -> Platform
    targetPlatform (DynFlags -> Platform) -> BcM DynFlags -> BcM Platform
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
            let !szb = Platform -> Id -> ByteOff
    idSizeCon Platform
    platform Id
    v
                done ByteOff -> BCInstr
    instr = do
                    let !off :: ByteOff
    off = ByteOff
    d ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    - ByteOff
    d_v
                    (OrdList BCInstr, ByteOff) -> BcM (OrdList BCInstr, ByteOff)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL (ByteOff -> BCInstr
    instr ByteOff
    off), ByteOff
    szb)
            case szb of
                ByteOff
    1 -> (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    done ByteOff -> BCInstr
    PUSH8
                ByteOff
    2 -> (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    done ByteOff -> BCInstr
    PUSH16
                ByteOff
    4 -> (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff)
    done ByteOff -> 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) = Int -> (OrdList BCInstr, ByteOff) -> (OrdList BCInstr, ByteOff)
    forall {t} {b}.
    (Eq t, Num t, Num b) =>
    t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
    go Int
    n (OrdList BCInstr
    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 OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
    forall a. Monoid a => a -> a -> a
    `mappend` BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL BCInstr
    PUSH_PAD8, b
    off b -> b -> b
    forall a. Num a => a -> a -> a
    + b
    1)
            t
    2 -> (OrdList BCInstr
    instrs OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
    forall a. Monoid a => a -> a -> a
    `mappend` BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL BCInstr
    PUSH_PAD16, b
    off b -> b -> b
    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 OrdList BCInstr -> OrdList BCInstr -> OrdList BCInstr
    forall a. Monoid a => a -> a -> a
    `mappend` BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL BCInstr
    PUSH_PAD32, b
    off b -> b -> b
    forall a. Num a => a -> a -> a
    + b
    4)
            t
    _ -> t -> (OrdList BCInstr, b) -> (OrdList BCInstr, b)
    go (t
    n t -> t -> t
    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
         lbl_default <- BcM LocalLabel
    getLabelBc

         let
             mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
             mkTree [] Discr
    _range_lo Discr
    _range_hi = OrdList BCInstr -> BcM (OrdList BCInstr)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BCInstr -> OrdList BCInstr
    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 Discr -> Discr -> Bool
    forall a. Eq a => a -> a -> Bool
    == Discr
    range_hi
                = OrdList BCInstr -> BcM (OrdList BCInstr)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((Discr, OrdList BCInstr) -> OrdList BCInstr
    forall a b. (a, b) -> b
    snd (Discr, OrdList BCInstr)
    val)
                | [(Discr, OrdList BCInstr)] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [(Discr, OrdList BCInstr)]
    defaults -- Note [CASEFAIL]
                = do lbl <- BcM LocalLabel
    getLabelBc
                     return (testEQ (fst val) lbl
                                `consOL` (snd val
                                `appOL`  (LABEL lbl `consOL` unitOL CASEFAIL)))
                | Bool
    otherwise
                = OrdList BCInstr -> BcM (OrdList BCInstr)
    forall a. a -> BcM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Discr -> LocalLabel -> BCInstr
    testEQ ((Discr, OrdList BCInstr) -> Discr
    forall a b. (a, b) -> a
    fst (Discr, OrdList BCInstr)
    val) LocalLabel
    lbl_default BCInstr -> OrdList BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a -> OrdList a
    `consOL` (Discr, OrdList BCInstr) -> OrdList BCInstr
    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 = [(Discr, OrdList BCInstr)] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Discr, OrdList BCInstr)]
    vals Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    2
                      ([(Discr, OrdList BCInstr)]
    vals_lo, [(Discr, OrdList BCInstr)]
    vals_hi) = Int
    -> [(Discr, OrdList BCInstr)]
    -> ([(Discr, OrdList BCInstr)], [(Discr, OrdList BCInstr)])
    forall a. Int -> [a] -> ([a], [a])
    splitAt Int
    n [(Discr, OrdList BCInstr)]
    vals
                      v_mid :: Discr
    v_mid = (Discr, OrdList BCInstr) -> Discr
    forall a b. (a, b) -> a
    fst ([(Discr, OrdList BCInstr)] -> (Discr, OrdList BCInstr)
    forall a. HasCallStack => [a] -> a
    head [(Discr, OrdList BCInstr)]
    vals_hi)
                  in do
                  label_geq <- BcM LocalLabel
    getLabelBc
                  code_lo <- mkTree vals_lo range_lo (dec v_mid)
                  code_hi <- mkTree vals_hi v_mid range_hi
                  return (testLT v_mid label_geq
                          `consOL` (code_lo
                          `appOL`   unitOL (LABEL label_geq)
                          `appOL`   code_hi))

             the_default
                = case [(Discr, OrdList BCInstr)]
    defaults of
                    []         -> OrdList BCInstr
    forall a. OrdList a
    nilOL
                    [(Discr
    _, OrdList BCInstr
    def)] -> LocalLabel -> BCInstr
    LABEL LocalLabel
    lbl_default BCInstr -> OrdList BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a -> OrdList a
    `consOL` OrdList BCInstr
    def
                    [(Discr, OrdList BCInstr)]
    _          -> String -> OrdList BCInstr
    forall a. HasCallStack => String -> a
    panic String
    "mkMultiBranch/the_default"
         instrs <- mkTree notd_ways init_lo init_hi
         return (instrs `appOL` the_default)
      where
             ([(Discr, OrdList BCInstr)]
    defaults, [(Discr, OrdList BCInstr)]
    not_defaults) = ((Discr, OrdList BCInstr) -> Bool)
    -> [(Discr, OrdList BCInstr)]
    -> ([(Discr, OrdList BCInstr)], [(Discr, OrdList BCInstr)])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    partition (Discr -> Bool
    isNoDiscr(Discr -> Bool)
    -> ((Discr, OrdList BCInstr) -> Discr)
    -> (Discr, OrdList BCInstr)
    -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .(Discr, OrdList BCInstr) -> Discr
    forall a b. (a, b) -> a
    fst) [(Discr, OrdList BCInstr)]
    raw_ways
             notd_ways :: [(Discr, OrdList BCInstr)]
    notd_ways = ((Discr, OrdList BCInstr) -> (Discr, OrdList BCInstr) -> Ordering)
    -> [(Discr, OrdList BCInstr)] -> [(Discr, OrdList BCInstr)]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (((Discr, OrdList BCInstr) -> Discr)
    -> (Discr, OrdList BCInstr) -> (Discr, OrdList BCInstr) -> Ordering
    forall a b. Ord a => (b -> a) -> b -> b -> Ordering
    comparing (Discr, OrdList BCInstr) -> Discr
    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 (DiscrI8 Int8
    i) LocalLabel
    fail_label = Int8 -> LocalLabel -> BCInstr
    TESTLT_I8 (Int8 -> Int8
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int8
    i) LocalLabel
    fail_label
             testLT (DiscrI16 Int16
    i) LocalLabel
    fail_label = Int16 -> LocalLabel -> BCInstr
    TESTLT_I16 (Int16 -> Int16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int16
    i) LocalLabel
    fail_label
             testLT (DiscrI32 Int32
    i) LocalLabel
    fail_label = Int32 -> LocalLabel -> BCInstr
    TESTLT_I32 (Int32 -> Int32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int32
    i) LocalLabel
    fail_label
             testLT (DiscrI64 Int64
    i) LocalLabel
    fail_label = Int64 -> LocalLabel -> BCInstr
    TESTLT_I64 (Int64 -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int64
    i) LocalLabel
    fail_label
             testLT (DiscrW Word
    i) LocalLabel
    fail_label = Word -> LocalLabel -> BCInstr
    TESTLT_W Word
    i LocalLabel
    fail_label
             testLT (DiscrW8 Word8
    i) LocalLabel
    fail_label = Word8 -> LocalLabel -> BCInstr
    TESTLT_W8 (Word8 -> Word8
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word8
    i) LocalLabel
    fail_label
             testLT (DiscrW16 Word16
    i) LocalLabel
    fail_label = Word16 -> LocalLabel -> BCInstr
    TESTLT_W16 (Word16 -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    i) LocalLabel
    fail_label
             testLT (DiscrW32 Word32
    i) LocalLabel
    fail_label = Word32 -> LocalLabel -> BCInstr
    TESTLT_W32 (Word32 -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word32
    i) LocalLabel
    fail_label
             testLT (DiscrW64 Word64
    i) LocalLabel
    fail_label = Word64 -> LocalLabel -> BCInstr
    TESTLT_W64 (Word64 -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word64
    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
    _          = String -> BCInstr
    forall a. HasCallStack => 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 (DiscrI8 Int8
    i) LocalLabel
    fail_label = Int16 -> LocalLabel -> BCInstr
    TESTEQ_I8 (Int8 -> Int16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int8
    i) LocalLabel
    fail_label
             testEQ (DiscrI16 Int16
    i) LocalLabel
    fail_label = Int16 -> LocalLabel -> BCInstr
    TESTEQ_I16 (Int16 -> Int16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int16
    i) LocalLabel
    fail_label
             testEQ (DiscrI32 Int32
    i) LocalLabel
    fail_label = Int32 -> LocalLabel -> BCInstr
    TESTEQ_I32 (Int32 -> Int32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int32
    i) LocalLabel
    fail_label
             testEQ (DiscrI64 Int64
    i) LocalLabel
    fail_label = Int64 -> LocalLabel -> BCInstr
    TESTEQ_I64 (Int64 -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int64
    i) LocalLabel
    fail_label
             testEQ (DiscrW Word
    i) LocalLabel
    fail_label = Word -> LocalLabel -> BCInstr
    TESTEQ_W Word
    i LocalLabel
    fail_label
             testEQ (DiscrW8 Word8
    i) LocalLabel
    fail_label = Word8 -> LocalLabel -> BCInstr
    TESTEQ_W8 (Word8 -> Word8
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word8
    i) LocalLabel
    fail_label
             testEQ (DiscrW16 Word16
    i) LocalLabel
    fail_label = Word16 -> LocalLabel -> BCInstr
    TESTEQ_W16 (Word16 -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word16
    i) LocalLabel
    fail_label
             testEQ (DiscrW32 Word32
    i) LocalLabel
    fail_label = Word32 -> LocalLabel -> BCInstr
    TESTEQ_W32 (Word32 -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word32
    i) LocalLabel
    fail_label
             testEQ (DiscrW64 Word64
    i) LocalLabel
    fail_label = Word64 -> LocalLabel -> BCInstr
    TESTEQ_W64 (Word64 -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word64
    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
    _          = String -> BCInstr
    forall a. HasCallStack => 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) = case [(Discr, OrdList BCInstr)]
    notd_ways of
                [] -> String -> (Discr, Discr)
    forall a. HasCallStack => String -> a
    panic String
    "mkMultiBranch: awesome foursome"
                (Discr
    discr, OrdList BCInstr
    _):[(Discr, OrdList BCInstr)]
    _ -> case Discr
    discr of
                    DiscrI Int
    _ -> ( Int -> Discr
    DiscrI Int
    forall a. Bounded a => a
    minBound,  Int -> Discr
    DiscrI Int
    forall a. Bounded a => a
    maxBound )
                    DiscrI8 Int8
    _ -> ( Int8 -> Discr
    DiscrI8 Int8
    forall a. Bounded a => a
    minBound, Int8 -> Discr
    DiscrI8 Int8
    forall a. Bounded a => a
    maxBound )
                    DiscrI16 Int16
    _ -> ( Int16 -> Discr
    DiscrI16 Int16
    forall a. Bounded a => a
    minBound, Int16 -> Discr
    DiscrI16 Int16
    forall a. Bounded a => a
    maxBound )
                    DiscrI32 Int32
    _ -> ( Int32 -> Discr
    DiscrI32 Int32
    forall a. Bounded a => a
    minBound, Int32 -> Discr
    DiscrI32 Int32
    forall a. Bounded a => a
    maxBound )
                    DiscrI64 Int64
    _ -> ( Int64 -> Discr
    DiscrI64 Int64
    forall a. Bounded a => a
    minBound, Int64 -> Discr
    DiscrI64 Int64
    forall a. Bounded a => a
    maxBound )
                    DiscrW Word
    _ -> ( Word -> Discr
    DiscrW Word
    forall a. Bounded a => a
    minBound,  Word -> Discr
    DiscrW Word
    forall a. Bounded a => a
    maxBound )
                    DiscrW8 Word8
    _ -> ( Word8 -> Discr
    DiscrW8 Word8
    forall a. Bounded a => a
    minBound, Word8 -> Discr
    DiscrW8 Word8
    forall a. Bounded a => a
    maxBound )
                    DiscrW16 Word16
    _ -> ( Word16 -> Discr
    DiscrW16 Word16
    forall a. Bounded a => a
    minBound, Word16 -> Discr
    DiscrW16 Word16
    forall a. Bounded a => a
    maxBound )
                    DiscrW32 Word32
    _ -> ( Word32 -> Discr
    DiscrW32 Word32
    forall a. Bounded a => a
    minBound, Word32 -> Discr
    DiscrW32 Word32
    forall a. Bounded a => a
    maxBound )
                    DiscrW64 Word64
    _ -> ( Word64 -> Discr
    DiscrW64 Word64
    forall a. Bounded a => a
    minBound, Word64 -> Discr
    DiscrW64 Word64
    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 -> String -> (Discr, Discr)
    forall a. HasCallStack => 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, Int -> Word16
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    n Word16 -> Word16 -> Word16
    forall a. Num a => a -> a -> a
    - Word16
    1)
                     Maybe Int
    Nothing -> (Word16
    forall a. Bounded a => a
    minBound, Word16
    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
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1)
             dec (DiscrW Word
    w) = Word -> Discr
    DiscrW (Word
    wWord -> Word -> Word
    forall a. Num a => a -> a -> a
    -Word
    1)
             dec (DiscrP Word16
    i) = Word16 -> Discr
    DiscrP (Word16
    iWord16 -> Word16 -> Word16
    forall 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
       | DiscrI8 Int8
       | DiscrI16 Int16
       | DiscrI32 Int32
       | DiscrI64 Int64
       | DiscrW Word
       | DiscrW8 Word8
       | DiscrW16 Word16
       | DiscrW32 Word32
       | DiscrW64 Word64
       | DiscrF Float
       | DiscrD Double
       | DiscrP Word16
       | NoDiscr
        deriving (Discr -> Discr -> Bool
    (Discr -> Discr -> Bool) -> (Discr -> Discr -> Bool) -> Eq Discr
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Discr -> Discr -> Bool
    == :: Discr -> Discr -> Bool
    $c/= :: Discr -> Discr -> Bool
    /= :: Discr -> Discr -> Bool
    Eq, Eq Discr
    Eq Discr =>
    (Discr -> Discr -> Ordering)
    -> (Discr -> Discr -> Bool)
    -> (Discr -> Discr -> Bool)
    -> (Discr -> Discr -> Bool)
    -> (Discr -> Discr -> Bool)
    -> (Discr -> Discr -> Discr)
    -> (Discr -> Discr -> Discr)
    -> Ord 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
    $ccompare :: Discr -> Discr -> Ordering
    compare :: Discr -> Discr -> Ordering
    $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
    >= :: Discr -> Discr -> Bool
    $cmax :: Discr -> Discr -> Discr
    max :: Discr -> Discr -> Discr
    $cmin :: Discr -> Discr -> Discr
    min :: Discr -> Discr -> Discr
    Ord)

    instance Outputable Discr where
       ppr :: Discr -> SDoc
    ppr (DiscrI Int
    i) = Int -> SDoc
    forall doc. IsLine doc => Int -> doc
    int Int
    i
       ppr (DiscrI8 Int8
    i) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (Int8 -> String
    forall a. Show a => a -> String
    show Int8
    i)
       ppr (DiscrI16 Int16
    i) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (Int16 -> String
    forall a. Show a => a -> String
    show Int16
    i)
       ppr (DiscrI32 Int32
    i) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (Int32 -> String
    forall a. Show a => a -> String
    show Int32
    i)
       ppr (DiscrI64 Int64
    i) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (Int64 -> String
    forall a. Show a => a -> String
    show Int64
    i)
       ppr (DiscrW Word
    w) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (Word -> String
    forall a. Show a => a -> String
    show Word
    w)
       ppr (DiscrW8 Word8
    w) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (Word8 -> String
    forall a. Show a => a -> String
    show Word8
    w)
       ppr (DiscrW16 Word16
    w) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (Word16 -> String
    forall a. Show a => a -> String
    show Word16
    w)
       ppr (DiscrW32 Word32
    w) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (Word32 -> String
    forall a. Show a => a -> String
    show Word32
    w)
       ppr (DiscrW64 Word64
    w) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (Word64 -> String
    forall a. Show a => a -> String
    show Word64
    w)
       ppr (DiscrF Float
    f) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (Float -> String
    forall a. Show a => a -> String
    show Float
    f)
       ppr (DiscrD Double
    d) = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text (Double -> String
    forall a. Show a => a -> String
    show Double
    d)
       ppr (DiscrP Word16
    i) = Word16 -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Word16
    i
       ppr Discr
    NoDiscr    = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "DEF"

    lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
    lookupBCEnv_maybe :: Id -> Map Id ByteOff -> Maybe ByteOff
    lookupBCEnv_maybe = Id -> Map Id ByteOff -> Maybe ByteOff
    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 (Int -> WordOff) -> (Id -> Int) -> Id -> WordOff
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> ArgRep -> Int
    argRepSizeW Platform
    platform (ArgRep -> Int) -> (Id -> ArgRep) -> Id -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> Id -> ArgRep
    idArgRep Platform
    platform

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

    repSizeWords :: Platform -> PrimOrVoidRep -> WordOff
    repSizeWords :: Platform -> PrimOrVoidRep -> WordOff
    repSizeWords Platform
    platform PrimOrVoidRep
    rep = Int -> WordOff
    WordOff (Int -> WordOff) -> Int -> WordOff
    forall a b. (a -> b) -> a -> b
    $ Platform -> ArgRep -> Int
    argRepSizeW Platform
    platform (Platform -> PrimOrVoidRep -> ArgRep
    toArgRepOrV Platform
    platform PrimOrVoidRep
    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
    True     -- 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 = GhcException -> a
    forall a. GhcException -> a
    throwGhcException (String -> GhcException
    ProgramError
      (String
    "Error: bytecode compiler can't handle some foreign calling conventions\n"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
       String
    "  Workaround: use -fobject-code, or compile this module to .o separately."))

    mkSlideB :: Platform -> ByteOff -> ByteOff -> BCInstr
    mkSlideB :: Platform -> ByteOff -> ByteOff -> BCInstr
    mkSlideB Platform
    platform ByteOff
    nb ByteOff
    db = WordOff -> WordOff -> BCInstr
    SLIDE WordOff
    n WordOff
    d
      where
        !n :: WordOff
    n = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform ByteOff
    nb
        !d :: WordOff
    d = Platform -> ByteOff -> WordOff
    bytesToWords Platform
    platform ByteOff
    db

    mkSlideW :: WordOff -> WordOff -> OrdList BCInstr
    mkSlideW :: WordOff -> WordOff -> OrdList BCInstr
    mkSlideW !WordOff
    n !WordOff
    ws
        | WordOff
    ws WordOff -> WordOff -> Bool
    forall a. Eq a => a -> a -> Bool
    == WordOff
    0
        = OrdList BCInstr
    forall a. OrdList a
    nilOL
        | Bool
    otherwise
        = BCInstr -> OrdList BCInstr
    forall a. a -> OrdList a
    unitOL (WordOff -> WordOff -> BCInstr
    SLIDE WordOff
    n (WordOff -> BCInstr) -> WordOff -> BCInstr
    forall a b. (a -> b) -> a -> b
    $ WordOff -> WordOff
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral WordOff
    ws)

    atomRep :: Platform -> StgArg -> ArgRep
    atomRep :: Platform -> StgArg -> ArgRep
    atomRep Platform
    platform StgArg
    e = Platform -> PrimOrVoidRep -> ArgRep
    toArgRepOrV Platform
    platform (StgArg -> PrimOrVoidRep
    stgArgRep1 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 = [ByteOff] -> [ByteOff]
    forall a. HasCallStack => [a] -> [a]
    tail ((ByteOff -> ByteOff -> ByteOff)
    -> ByteOff -> [ByteOff] -> [ByteOff]
    forall b a. (b -> a -> b) -> b -> [a] -> [b]
    scanl' ByteOff -> ByteOff -> ByteOff
    forall a. Num a => a -> a -> a
    (+) ByteOff
    original_depth [ByteOff]
    szsb)

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

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

    data BcM_State
       = BcM_State
            { BcM_State -> HscEnv
    bcm_hsc_env :: HscEnv
            , 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
            }

    newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving ((forall a b. (a -> b) -> BcM a -> BcM b)
    -> (forall a b. a -> BcM b -> BcM a) -> Functor BcM
    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
    $cfmap :: forall a b. (a -> b) -> BcM a -> BcM b
    fmap :: forall a b. (a -> b) -> BcM a -> BcM b
    $c<$ :: forall a b. a -> BcM b -> BcM a
    <$ :: forall a b. a -> BcM b -> BcM a
    Functor)

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

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

    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 = (BcM_State -> IO (BcM_State, b)) -> BcM b
    forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM ((BcM_State -> IO (BcM_State, b)) -> BcM b)
    -> (BcM_State -> IO (BcM_State, b)) -> BcM b
    forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st0 -> do
      (st1, q) <- BcM_State -> IO (BcM_State, a)
    expr BcM_State
    st0
      let BcM k = cont q
      (st2, r) <- k st1
      return (st2, 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) = (BcM_State -> IO (BcM_State, b)) -> BcM b
    forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM ((BcM_State -> IO (BcM_State, b)) -> BcM b)
    -> (BcM_State -> IO (BcM_State, b)) -> BcM b
    forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st0 -> do
      (st1, _) <- BcM_State -> IO (BcM_State, a)
    expr BcM_State
    st0
      (st2, r) <- cont st1
      return (st2, r)

    returnBc :: a -> BcM a
    returnBc :: forall a. a -> BcM a
    returnBc a
    result = (BcM_State -> IO (BcM_State, a)) -> BcM a
    forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM ((BcM_State -> IO (BcM_State, a)) -> BcM a)
    -> (BcM_State -> IO (BcM_State, a)) -> BcM a
    forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> ((BcM_State, a) -> IO (BcM_State, a)
    forall a. a -> IO a
    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 = a -> BcM a
    forall a. a -> BcM a
    returnBc
        <*> :: forall a b. BcM (a -> b) -> BcM a -> BcM 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
    (*>) = 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
    (>>=) = 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
    (>>)  = BcM a -> BcM b -> BcM b
    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 = (BcM_State -> IO (BcM_State, DynFlags)) -> BcM DynFlags
    forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM ((BcM_State -> IO (BcM_State, DynFlags)) -> BcM DynFlags)
    -> (BcM_State -> IO (BcM_State, DynFlags)) -> BcM DynFlags
    forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> (BcM_State, DynFlags) -> IO (BcM_State, DynFlags)
    forall a. a -> IO a
    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 = (BcM_State -> IO (BcM_State, HscEnv)) -> BcM HscEnv
    forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM ((BcM_State -> IO (BcM_State, HscEnv)) -> BcM HscEnv)
    -> (BcM_State -> IO (BcM_State, HscEnv)) -> BcM HscEnv
    forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> (BcM_State, HscEnv) -> IO (BcM_State, HscEnv)
    forall a. a -> IO a
    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 (DynFlags -> Profile) -> BcM DynFlags -> BcM Profile
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BcM DynFlags
    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
      = (BcM_State -> IO (BcM_State, ProtoBCO Name)) -> BcM (ProtoBCO Name)
    forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM ((BcM_State -> IO (BcM_State, ProtoBCO Name))
     -> BcM (ProtoBCO Name))
    -> (BcM_State -> IO (BcM_State, ProtoBCO Name))
    -> BcM (ProtoBCO Name)
    forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> (BcM_State, ProtoBCO Name) -> IO (BcM_State, ProtoBCO Name)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st{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
      = (BcM_State -> IO (BcM_State, ())) -> BcM ()
    forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM ((BcM_State -> IO (BcM_State, ())) -> BcM ())
    -> (BcM_State -> IO (BcM_State, ())) -> BcM ()
    forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> (BcM_State, ()) -> IO (BcM_State, ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st{ffis = FFIInfo a : ffis st}, ())

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

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

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

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

    getCurrentModBreaks :: BcM (Maybe ModBreaks)
    getCurrentModBreaks :: BcM (Maybe ModBreaks)
    getCurrentModBreaks = (BcM_State -> IO (BcM_State, Maybe ModBreaks))
    -> BcM (Maybe ModBreaks)
    forall r. (BcM_State -> IO (BcM_State, r)) -> BcM r
    BcM ((BcM_State -> IO (BcM_State, Maybe ModBreaks))
     -> BcM (Maybe ModBreaks))
    -> (BcM_State -> IO (BcM_State, Maybe ModBreaks))
    -> BcM (Maybe ModBreaks)
    forall a b. (a -> b) -> a -> b
    $ \BcM_State
    st -> (BcM_State, Maybe ModBreaks) -> IO (BcM_State, Maybe ModBreaks)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BcM_State
    st, BcM_State -> Maybe ModBreaks
    modBreaks BcM_State
    st)

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