    -----------------------------------------------------------------------------
    --
    -- Code generation for foreign calls.
    --
    -- (c) The University of Glasgow 2004-2006
    --
    -----------------------------------------------------------------------------

    module GHC.StgToCmm.Foreign (
      cgForeignCall,
      emitPrimCall, emitCCall,
      emitForeignCall,
      emitSaveThreadState,
      saveThreadState,
      emitLoadThreadState,
      emitSaveRegs,
      emitRestoreRegs,
      emitPushTupleRegs,
      emitPopTupleRegs,
      loadThreadState,
      emitOpenNursery,
      emitCloseNursery,
     ) where

    import GHC.Prelude hiding( succ, (<*>) )

    import GHC.Platform
    import GHC.Platform.Profile

    import GHC.Stg.Syntax
    import GHC.StgToCmm.Prof (storeCurCCS, ccsType)
    import GHC.StgToCmm.Monad
    import GHC.StgToCmm.Utils
    import GHC.StgToCmm.Closure
    import GHC.StgToCmm.Layout

    import GHC.Cmm.BlockId (newBlockId)
    import GHC.Cmm
    import GHC.Cmm.Utils
    import GHC.Cmm.Graph
    import GHC.Cmm.CallConv
    import GHC.Core.Type
    import GHC.Types.RepType
    import GHC.Cmm.CLabel
    import GHC.Runtime.Heap.Layout
    import GHC.Types.ForeignCall
    import GHC.Data.Maybe
    import GHC.Utils.Panic
    import GHC.Types.Unique.Supply
    import GHC.Types.Basic
    import GHC.Unit.Types

    import GHC.Core.TyCo.Rep
    import GHC.Builtin.Types.Prim
    import GHC.Utils.Misc (zipEqual)

    import Control.Monad

    -----------------------------------------------------------------------------
    -- Code generation for Foreign Calls
    -----------------------------------------------------------------------------

    -- | Emit code for a foreign call, and return the results to the sequel.
    -- Precondition: the length of the arguments list is the same as the
    -- arity of the foreign function.
    cgForeignCall :: ForeignCall            -- the op
                  -> Type                   -- type of foreign function
                  -> [StgArg]               -- x,y    arguments
                  -> Type                   -- result type
                  -> FCode ReturnKind

    cgForeignCall :: ForeignCall -> Type -> [StgArg] -> Type -> FCode ReturnKind
    cgForeignCall (CCall (CCallSpec CCallTarget
    target CCallConv
    cconv Safety
    safety)) Type
    typ [StgArg]
    stg_args Type
    res_ty
      = do  { Platform
    platform <- FCode Platform
    getPlatform
            ; let -- in the stdcall calling convention, the symbol needs @size appended
                  -- to it, where size is the total number of bytes of arguments.  We
                  -- attach this info to the CLabel here, and the CLabel pretty printer
                  -- will generate the suffix when the label is printed.
                call_size :: [(CmmExpr, ForeignHint)] -> Maybe ByteOff
    call_size [(CmmExpr, ForeignHint)]
    args
                  | CCallConv
    StdCallConv <- CCallConv
    cconv = forall a. a -> Maybe a
    Just (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum (forall a b. (a -> b) -> [a] -> [b]
    map (CmmExpr, ForeignHint) -> ByteOff
    arg_size [(CmmExpr, ForeignHint)]
    args))
                  | Bool
    otherwise            = forall a. Maybe a
    Nothing

                  -- ToDo: this might not be correct for 64-bit API
                  -- This is correct for the PowerPC ELF ABI version 1 and 2.
                arg_size :: (CmmExpr, ForeignHint) -> ByteOff
    arg_size (CmmExpr
    arg, ForeignHint
    _) = forall a. Ord a => a -> a -> a
    max (Width -> ByteOff
    widthInBytes forall a b. (a -> b) -> a -> b
    $ CmmType -> Width
    typeWidth forall a b. (a -> b) -> a -> b
    $ Platform -> CmmExpr -> CmmType
    cmmExprType Platform
    platform CmmExpr
    arg)
                                         (Platform -> ByteOff
    platformWordSizeInBytes Platform
    platform)
            ; [(CmmExpr, ForeignHint)]
    cmm_args <- [StgArg] -> Type -> FCode [(CmmExpr, ForeignHint)]
    getFCallArgs [StgArg]
    stg_args Type
    typ
            -- ; traceM $ show cmm_args
            ; ([LocalReg]
    res_regs, [ForeignHint]
    res_hints) <- Type -> FCode ([LocalReg], [ForeignHint])
    newUnboxedTupleRegs Type
    res_ty
            ; let (([CmmExpr]
    call_args, [ForeignHint]
    arg_hints), CmmExpr
    cmm_target)
                    = case CCallTarget
    target of
                       StaticTarget SourceText
    _ CLabelString
    _   Maybe Unit
    _      Bool
    False ->
                           forall a. String -> a
    panic String
    "cgForeignCall: unexpected FFI value import"
                       StaticTarget SourceText
    _ CLabelString
    lbl Maybe Unit
    mPkgId Bool
    True
                         -> let labelSource :: ForeignLabelSource
    labelSource
                                    = case Maybe Unit
    mPkgId of
                                            Maybe Unit
    Nothing         -> ForeignLabelSource
    ForeignLabelInThisPackage
                                            Just Unit
    pkgId      -> UnitId -> ForeignLabelSource
    ForeignLabelInPackage (Unit -> UnitId
    toUnitId Unit
    pkgId)
                                size :: Maybe ByteOff
    size = [(CmmExpr, ForeignHint)] -> Maybe ByteOff
    call_size [(CmmExpr, ForeignHint)]
    cmm_args
                            in  ( forall a b. [(a, b)] -> ([a], [b])
    unzip [(CmmExpr, ForeignHint)]
    cmm_args
                                , CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel
                                            (CLabelString
    -> Maybe ByteOff -> ForeignLabelSource -> FunctionOrData -> CLabel
    mkForeignLabel CLabelString
    lbl Maybe ByteOff
    size ForeignLabelSource
    labelSource FunctionOrData
    IsFunction)))

                       CCallTarget
    DynamicTarget    ->  case [(CmmExpr, ForeignHint)]
    cmm_args of
                                               (CmmExpr
    fn,ForeignHint
    _):[(CmmExpr, ForeignHint)]
    rest -> (forall a b. [(a, b)] -> ([a], [b])
    unzip [(CmmExpr, ForeignHint)]
    rest, CmmExpr
    fn)
                                               [] -> forall a. String -> a
    panic String
    "cgForeignCall []"
                  fc :: ForeignConvention
    fc = CCallConv
    -> [ForeignHint]
    -> [ForeignHint]
    -> CmmReturnInfo
    -> ForeignConvention
    ForeignConvention CCallConv
    cconv [ForeignHint]
    arg_hints [ForeignHint]
    res_hints CmmReturnInfo
    CmmMayReturn
                  call_target :: ForeignTarget
    call_target = CmmExpr -> ForeignConvention -> ForeignTarget
    ForeignTarget CmmExpr
    cmm_target ForeignConvention
    fc

            -- we want to emit code for the call, and then emitReturn.
            -- However, if the sequel is AssignTo, we shortcut a little
            -- and generate a foreign call that assigns the results
            -- directly.  Otherwise we end up generating a bunch of
            -- useless "r = r" assignments, which are not merely annoying:
            -- they prevent the common block elimination from working correctly
            -- in the case of a safe foreign call.
            -- See Note [safe foreign call convention]
            --
            ; Sequel
    sequel <- FCode Sequel
    getSequel
            ; case Sequel
    sequel of
                AssignTo [LocalReg]
    assign_to_these Bool
    _ ->
                    Safety
    -> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
    emitForeignCall Safety
    safety [LocalReg]
    assign_to_these ForeignTarget
    call_target [CmmExpr]
    call_args

                Sequel
    _something_else ->
                    do { ReturnKind
    _ <- Safety
    -> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
    emitForeignCall Safety
    safety [LocalReg]
    res_regs ForeignTarget
    call_target [CmmExpr]
    call_args
                       ; [CmmExpr] -> FCode ReturnKind
    emitReturn (forall a b. (a -> b) -> [a] -> [b]
    map (CmmReg -> CmmExpr
    CmmReg forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LocalReg -> CmmReg
    CmmLocal) [LocalReg]
    res_regs)
                       }
             }

    {- Note [safe foreign call convention]

    The simple thing to do for a safe foreign call would be the same as an
    unsafe one: just

        emitForeignCall ...
        emitReturn ...

    but consider what happens in this case

       case foo x y z of
         (# s, r #) -> ...

    The sequel is AssignTo [r].  The call to newUnboxedTupleRegs picks [r]
    as the result reg, and we generate

      r = foo(x,y,z) returns to L1  -- emitForeignCall
     L1:
      r = r  -- emitReturn
      goto L2
    L2:
      ...

    Now L1 is a proc point (by definition, it is the continuation of the
    safe foreign call).  If L2 does a heap check, then L2 will also be a
    proc point.

    Furthermore, the stack layout algorithm has to arrange to save r
    somewhere between the call and the jump to L1, which is annoying: we
    would have to treat r differently from the other live variables, which
    have to be saved *before* the call.

    So we adopt a special convention for safe foreign calls: the results
    are copied out according to the NativeReturn convention by the call,
    and the continuation of the call should copyIn the results.  (The
    copyOut code is actually inserted when the safe foreign call is
    lowered later).  The result regs attached to the safe foreign call are
    only used temporarily to hold the results before they are copied out.

    We will now generate this:

      r = foo(x,y,z) returns to L1
     L1:
      r = R1  -- copyIn, inserted by mkSafeCall
      goto L2
     L2:
      ... r ...

    And when the safe foreign call is lowered later (see Note [lower safe
    foreign calls]) we get this:

      suspendThread()
      r = foo(x,y,z)
      resumeThread()
      R1 = r  -- copyOut, inserted by lowerSafeForeignCall
      jump L1
     L1:
      r = R1  -- copyIn, inserted by mkSafeCall
      goto L2
     L2:
      ... r ...

    Now consider what happens if L2 does a heap check: the Adams
    optimisation kicks in and commons up L1 with the heap-check
    continuation, resulting in just one proc point instead of two. Yay!
    -}

    emitCCall :: [(CmmFormal,ForeignHint)]
              -> CmmExpr
              -> [(CmmActual,ForeignHint)]
              -> FCode ()
    emitCCall :: [(LocalReg, ForeignHint)]
    -> CmmExpr -> [(CmmExpr, ForeignHint)] -> FCode ()
    emitCCall [(LocalReg, ForeignHint)]
    hinted_results CmmExpr
    fn [(CmmExpr, ForeignHint)]
    hinted_args
      = forall (f :: * -> *) a. Functor f => f a -> f ()
    void forall a b. (a -> b) -> a -> b
    $ Safety
    -> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
    emitForeignCall Safety
    PlayRisky [LocalReg]
    results ForeignTarget
    target [CmmExpr]
    args
      where
        ([CmmExpr]
    args, [ForeignHint]
    arg_hints) = forall a b. [(a, b)] -> ([a], [b])
    unzip [(CmmExpr, ForeignHint)]
    hinted_args
        ([LocalReg]
    results, [ForeignHint]
    result_hints) = forall a b. [(a, b)] -> ([a], [b])
    unzip [(LocalReg, ForeignHint)]
    hinted_results
        target :: ForeignTarget
    target = CmmExpr -> ForeignConvention -> ForeignTarget
    ForeignTarget CmmExpr
    fn ForeignConvention
    fc
        fc :: ForeignConvention
    fc = CCallConv
    -> [ForeignHint]
    -> [ForeignHint]
    -> CmmReturnInfo
    -> ForeignConvention
    ForeignConvention CCallConv
    CCallConv [ForeignHint]
    arg_hints [ForeignHint]
    result_hints CmmReturnInfo
    CmmMayReturn

    emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
    emitPrimCall :: [LocalReg] -> CallishMachOp -> [CmmExpr] -> FCode ()
    emitPrimCall [LocalReg]
    res CallishMachOp
    op [CmmExpr]
    args
      = forall (f :: * -> *) a. Functor f => f a -> f ()
    void forall a b. (a -> b) -> a -> b
    $ Safety
    -> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
    emitForeignCall Safety
    PlayRisky [LocalReg]
    res (CallishMachOp -> ForeignTarget
    PrimTarget CallishMachOp
    op) [CmmExpr]
    args

    -- alternative entry point, used by GHC.Cmm.Parser
    emitForeignCall
            :: Safety
            -> [CmmFormal]          -- where to put the results
            -> ForeignTarget        -- the op
            -> [CmmActual]          -- arguments
            -> FCode ReturnKind
    emitForeignCall :: Safety
    -> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
    emitForeignCall Safety
    safety [LocalReg]
    results ForeignTarget
    target [CmmExpr]
    args
      | Bool -> Bool
    not (Safety -> Bool
    playSafe Safety
    safety) = do
        Platform
    platform <- FCode Platform
    getPlatform
        let (CmmAGraph
    caller_save, CmmAGraph
    caller_load) = Platform -> (CmmAGraph, CmmAGraph)
    callerSaveVolatileRegs Platform
    platform
        CmmAGraph -> FCode ()
    emit CmmAGraph
    caller_save
        ForeignTarget
    target' <- ForeignTarget -> FCode ForeignTarget
    load_target_into_temp ForeignTarget
    target
        [CmmExpr]
    args' <- forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM CmmExpr -> FCode CmmExpr
    maybe_assign_temp [CmmExpr]
    args
        CmmAGraph -> FCode ()
    emit forall a b. (a -> b) -> a -> b
    $ ForeignTarget -> [LocalReg] -> [CmmExpr] -> CmmAGraph
    mkUnsafeCall ForeignTarget
    target' [LocalReg]
    results [CmmExpr]
    args'
        CmmAGraph -> FCode ()
    emit CmmAGraph
    caller_load
        forall (m :: * -> *) a. Monad m => a -> m a
    return ReturnKind
    AssignedDirectly

      | Bool
    otherwise = do
        Profile
    profile <- FCode Profile
    getProfile
        Platform
    platform <- FCode Platform
    getPlatform
        ByteOff
    updfr_off <- FCode ByteOff
    getUpdFrameOff
        ForeignTarget
    target' <- ForeignTarget -> FCode ForeignTarget
    load_target_into_temp ForeignTarget
    target
        [CmmExpr]
    args' <- forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM CmmExpr -> FCode CmmExpr
    maybe_assign_temp [CmmExpr]
    args
        BlockId
    k <- forall (m :: * -> *). MonadUnique m => m BlockId
    newBlockId
        let (ByteOff
    off, [GlobalReg]
    _, CmmAGraph
    copyout) = Profile
    -> Convention
    -> Area
    -> [LocalReg]
    -> [LocalReg]
    -> (ByteOff, [GlobalReg], CmmAGraph)
    copyInOflow Profile
    profile Convention
    NativeReturn (BlockId -> Area
    Young BlockId
    k) [LocalReg]
    results []
           -- see Note [safe foreign call convention]
        CmmTickScope
    tscope <- FCode CmmTickScope
    getTickScope
        CmmAGraph -> FCode ()
    emit forall a b. (a -> b) -> a -> b
    $
               (    CmmExpr -> CmmExpr -> CmmAGraph
    mkStore (Area -> ByteOff -> CmmExpr
    CmmStackSlot (BlockId -> Area
    Young BlockId
    k) (Width -> ByteOff
    widthInBytes (Platform -> Width
    wordWidth Platform
    platform)))
                            (CmmLit -> CmmExpr
    CmmLit (BlockId -> CmmLit
    CmmBlock BlockId
    k))
                CmmAGraph -> CmmAGraph -> CmmAGraph
    <*> CmmNode O C -> CmmAGraph
    mkLast (CmmForeignCall { tgt :: ForeignTarget
    tgt  = ForeignTarget
    target'
                                           , res :: [LocalReg]
    res  = [LocalReg]
    results
                                           , args :: [CmmExpr]
    args = [CmmExpr]
    args'
                                           , succ :: BlockId
    succ = BlockId
    k
                                           , ret_args :: ByteOff
    ret_args = ByteOff
    off
                                           , ret_off :: ByteOff
    ret_off = ByteOff
    updfr_off
                                           , intrbl :: Bool
    intrbl = Safety -> Bool
    playInterruptible Safety
    safety })
                CmmAGraph -> CmmAGraph -> CmmAGraph
    <*> BlockId -> CmmTickScope -> CmmAGraph
    mkLabel BlockId
    k CmmTickScope
    tscope
                CmmAGraph -> CmmAGraph -> CmmAGraph
    <*> CmmAGraph
    copyout
               )
        forall (m :: * -> *) a. Monad m => a -> m a
    return (BlockId -> ByteOff -> ReturnKind
    ReturnedTo BlockId
    k ByteOff
    off)

    load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
    load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
    load_target_into_temp (ForeignTarget CmmExpr
    expr ForeignConvention
    conv) = do
      CmmExpr
    tmp <- CmmExpr -> FCode CmmExpr
    maybe_assign_temp CmmExpr
    expr
      forall (m :: * -> *) a. Monad m => a -> m a
    return (CmmExpr -> ForeignConvention -> ForeignTarget
    ForeignTarget CmmExpr
    tmp ForeignConvention
    conv)
    load_target_into_temp other_target :: ForeignTarget
    other_target@(PrimTarget CallishMachOp
    _) =
      forall (m :: * -> *) a. Monad m => a -> m a
    return ForeignTarget
    other_target

    -- What we want to do here is create a new temporary for the foreign
    -- call argument if it is not safe to use the expression directly,
    -- because the expression mentions caller-saves GlobalRegs (see
    -- Note [Register parameter passing]).
    --
    -- However, we can't pattern-match on the expression here, because
    -- this is used in a loop by GHC.Cmm.Parser, and testing the expression
    -- results in a black hole.  So we always create a temporary, and rely
    -- on GHC.Cmm.Sink to clean it up later.  (Yuck, ToDo).  The generated code
    -- ends up being the same, at least for the RTS .cmm code.
    --
    maybe_assign_temp :: CmmExpr -> FCode CmmExpr
    maybe_assign_temp :: CmmExpr -> FCode CmmExpr
    maybe_assign_temp CmmExpr
    e = do
      Platform
    platform <- FCode Platform
    getPlatform
      LocalReg
    reg <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmExpr -> CmmType
    cmmExprType Platform
    platform CmmExpr
    e)
      CmmReg -> CmmExpr -> FCode ()
    emitAssign (LocalReg -> CmmReg
    CmmLocal LocalReg
    reg) CmmExpr
    e
      forall (m :: * -> *) a. Monad m => a -> m a
    return (CmmReg -> CmmExpr
    CmmReg (LocalReg -> CmmReg
    CmmLocal LocalReg
    reg))

    -- -----------------------------------------------------------------------------
    -- Save/restore the thread state in the TSO

    -- This stuff can't be done in suspendThread/resumeThread, because it
    -- refers to global registers which aren't available in the C world.

    emitSaveThreadState :: FCode ()
    emitSaveThreadState :: FCode ()
    emitSaveThreadState = do
      Profile
    profile <- FCode Profile
    getProfile
      CmmAGraph
    code <- forall (m :: * -> *). MonadUnique m => Profile -> m CmmAGraph
    saveThreadState Profile
    profile
      CmmAGraph -> FCode ()
    emit CmmAGraph
    code

    -- | Produce code to save the current thread state to @CurrentTSO@
    saveThreadState :: MonadUnique m => Profile -> m CmmAGraph
    saveThreadState :: forall (m :: * -> *). MonadUnique m => Profile -> m CmmAGraph
    saveThreadState Profile
    profile = do
      let platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
      LocalReg
    tso <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmType
    gcWord Platform
    platform)
      CmmAGraph
    close_nursery <- forall (m :: * -> *).
    MonadUnique m =>
    Profile -> LocalReg -> m CmmAGraph
    closeNursery Profile
    profile LocalReg
    tso
      forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ [CmmAGraph] -> CmmAGraph
    catAGraphs
       [ -- tso = CurrentTSO;
         CmmReg -> CmmExpr -> CmmAGraph
    mkAssign (LocalReg -> CmmReg
    CmmLocal LocalReg
    tso) CmmExpr
    currentTSOExpr

       , -- tso->stackobj->sp = Sp;
         CmmExpr -> CmmExpr -> CmmAGraph
    mkStore (Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform
                            (Platform -> CmmExpr -> CmmExpr
    cmmLoadBWord Platform
    platform (Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform
                                                (CmmReg -> CmmExpr
    CmmReg (LocalReg -> CmmReg
    CmmLocal LocalReg
    tso))
                                                (Profile -> ByteOff
    tso_stackobj Profile
    profile)))
                            (Profile -> ByteOff
    stack_SP Profile
    profile))
                 CmmExpr
    spExpr

        , CmmAGraph
    close_nursery

        , -- and save the current cost centre stack in the TSO when profiling:
          if Profile -> Bool
    profileIsProfiling Profile
    profile
             then CmmExpr -> CmmExpr -> CmmAGraph
    mkStore (Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform (CmmReg -> CmmExpr
    CmmReg (LocalReg -> CmmReg
    CmmLocal LocalReg
    tso)) (Profile -> ByteOff
    tso_CCCS Profile
    profile)) CmmExpr
    cccsExpr
             else CmmAGraph
    mkNop
        ]

    -- | Save STG registers
    --
    -- STG registers must be saved around a C call, just in case the STG
    -- register is mapped to a caller-saves machine register.  Normally we
    -- don't need to worry about this the code generator has already
    -- loaded any live STG registers into variables for us, but in
    -- hand-written low-level Cmm code where we don't know which registers
    -- are live, we might have to save them all.
    emitSaveRegs :: FCode ()
    emitSaveRegs :: FCode ()
    emitSaveRegs = do
       Platform
    platform <- FCode Platform
    getPlatform
       let regs :: [GlobalReg]
    regs = Platform -> [GlobalReg]
    realArgRegsCover Platform
    platform
           save :: CmmAGraph
    save = [CmmAGraph] -> CmmAGraph
    catAGraphs (forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> GlobalReg -> CmmAGraph
    callerSaveGlobalReg Platform
    platform) [GlobalReg]
    regs)
       CmmAGraph -> FCode ()
    emit CmmAGraph
    save

    -- | Restore STG registers (see 'emitSaveRegs')
    emitRestoreRegs :: FCode ()
    emitRestoreRegs :: FCode ()
    emitRestoreRegs = do
       Platform
    platform <- FCode Platform
    getPlatform
       let regs :: [GlobalReg]
    regs    = Platform -> [GlobalReg]
    realArgRegsCover Platform
    platform
           restore :: CmmAGraph
    restore = [CmmAGraph] -> CmmAGraph
    catAGraphs (forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> GlobalReg -> CmmAGraph
    callerRestoreGlobalReg Platform
    platform) [GlobalReg]
    regs)
       CmmAGraph -> FCode ()
    emit CmmAGraph
    restore

    -- | Push a subset of STG registers onto the stack, specified by the bitmap
    --
    -- Sometimes, a "live" subset of the STG registers needs to be saved on the
    -- stack, for example when storing an unboxed tuple to be used in the GHCi
    -- bytecode interpreter.
    --
    -- The "live registers" bitmap corresponds to the list of registers given by
    -- 'tupleRegsCover', with the least significant bit indicating liveness of
    -- the first register in the list.
    --
    -- Each register is saved to a stack slot of one or more machine words, even
    -- if the register size itself is smaller.
    --
    -- The resulting Cmm code looks like this, with a line for each real or
    -- virtual register used for returning tuples:
    --
    --    ...
    --    if((mask & 2) != 0) { Sp_adj(-1); Sp(0) = R2; }
    --    if((mask & 1) != 0) { Sp_adj(-1); Sp(0) = R1; }
    --
    -- See Note [GHCi tuple layout]

    emitPushTupleRegs :: CmmExpr -> FCode ()
    emitPushTupleRegs :: CmmExpr -> FCode ()
    emitPushTupleRegs CmmExpr
    regs_live = do
      Platform
    platform <- FCode Platform
    getPlatform
      let regs :: [(GlobalReg, ByteOff)]
    regs = forall a b. [a] -> [b] -> [(a, b)]
    zip (Platform -> [GlobalReg]
    tupleRegsCover Platform
    platform) [ByteOff
    0..]
          save_arg :: (GlobalReg, ByteOff) -> FCode CmmAGraph
    save_arg (GlobalReg
    reg, ByteOff
    n) =
            let mask :: CmmExpr
    mask     = CmmLit -> CmmExpr
    CmmLit (Integer -> Width -> CmmLit
    CmmInt (Integer
    1 forall a. Bits a => a -> ByteOff -> a
    `shiftL` ByteOff
    n) (Platform -> Width
    wordWidth Platform
    platform))
                live :: CmmExpr
    live     = Platform -> CmmExpr -> CmmExpr -> CmmExpr
    cmmAndWord Platform
    platform CmmExpr
    regs_live CmmExpr
    mask
                cond :: CmmExpr
    cond     = Platform -> CmmExpr -> CmmExpr -> CmmExpr
    cmmNeWord Platform
    platform CmmExpr
    live (Platform -> CmmExpr
    zeroExpr Platform
    platform)
                reg_ty :: CmmType
    reg_ty   = Platform -> CmmReg -> CmmType
    cmmRegType Platform
    platform (GlobalReg -> CmmReg
    CmmGlobal GlobalReg
    reg)
                width :: ByteOff
    width    = Platform -> ByteOff -> ByteOff
    roundUpToWords Platform
    platform
                                          (Width -> ByteOff
    widthInBytes forall a b. (a -> b) -> a -> b
    $ CmmType -> Width
    typeWidth CmmType
    reg_ty)
                adj_sp :: CmmAGraph
    adj_sp   = CmmReg -> CmmExpr -> CmmAGraph
    mkAssign CmmReg
    spReg
                                    (Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform CmmExpr
    spExpr (forall a. Num a => a -> a
    negate ByteOff
    width))
                save_reg :: CmmAGraph
    save_reg = CmmExpr -> CmmExpr -> CmmAGraph
    mkStore CmmExpr
    spExpr (CmmReg -> CmmExpr
    CmmReg forall a b. (a -> b) -> a -> b
    $ GlobalReg -> CmmReg
    CmmGlobal GlobalReg
    reg)
            in CmmExpr -> CmmAGraph -> FCode CmmAGraph
    mkCmmIfThen CmmExpr
    cond forall a b. (a -> b) -> a -> b
    $ [CmmAGraph] -> CmmAGraph
    catAGraphs [CmmAGraph
    adj_sp, CmmAGraph
    save_reg]
      CmmAGraph -> FCode ()
    emit forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [CmmAGraph] -> CmmAGraph
    catAGraphs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (GlobalReg, ByteOff) -> FCode CmmAGraph
    save_arg (forall a. [a] -> [a]
    reverse [(GlobalReg, ByteOff)]
    regs)

    -- | Pop a subset of STG registers from the stack (see 'emitPushTupleRegs')
    emitPopTupleRegs :: CmmExpr -> FCode ()
    emitPopTupleRegs :: CmmExpr -> FCode ()
    emitPopTupleRegs CmmExpr
    regs_live = do
      Platform
    platform <- FCode Platform
    getPlatform
      let regs :: [(GlobalReg, ByteOff)]
    regs = forall a b. [a] -> [b] -> [(a, b)]
    zip (Platform -> [GlobalReg]
    tupleRegsCover Platform
    platform) [ByteOff
    0..]
          save_arg :: (GlobalReg, ByteOff) -> FCode CmmAGraph
    save_arg (GlobalReg
    reg, ByteOff
    n) =
            let mask :: CmmExpr
    mask     = CmmLit -> CmmExpr
    CmmLit (Integer -> Width -> CmmLit
    CmmInt (Integer
    1 forall a. Bits a => a -> ByteOff -> a
    `shiftL` ByteOff
    n) (Platform -> Width
    wordWidth Platform
    platform))
                live :: CmmExpr
    live     = Platform -> CmmExpr -> CmmExpr -> CmmExpr
    cmmAndWord Platform
    platform CmmExpr
    regs_live CmmExpr
    mask
                cond :: CmmExpr
    cond     = Platform -> CmmExpr -> CmmExpr -> CmmExpr
    cmmNeWord Platform
    platform CmmExpr
    live (Platform -> CmmExpr
    zeroExpr Platform
    platform)
                reg_ty :: CmmType
    reg_ty   = Platform -> CmmReg -> CmmType
    cmmRegType Platform
    platform (GlobalReg -> CmmReg
    CmmGlobal GlobalReg
    reg)
                width :: ByteOff
    width    = Platform -> ByteOff -> ByteOff
    roundUpToWords Platform
    platform
                                          (Width -> ByteOff
    widthInBytes forall a b. (a -> b) -> a -> b
    $ CmmType -> Width
    typeWidth CmmType
    reg_ty)
                adj_sp :: CmmAGraph
    adj_sp   = CmmReg -> CmmExpr -> CmmAGraph
    mkAssign CmmReg
    spReg
                                    (Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform CmmExpr
    spExpr ByteOff
    width)
                restore_reg :: CmmAGraph
    restore_reg = CmmReg -> CmmExpr -> CmmAGraph
    mkAssign (GlobalReg -> CmmReg
    CmmGlobal GlobalReg
    reg) (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
    CmmLoad CmmExpr
    spExpr CmmType
    reg_ty AlignmentSpec
    NaturallyAligned)
            in CmmExpr -> CmmAGraph -> FCode CmmAGraph
    mkCmmIfThen CmmExpr
    cond forall a b. (a -> b) -> a -> b
    $ [CmmAGraph] -> CmmAGraph
    catAGraphs [CmmAGraph
    restore_reg, CmmAGraph
    adj_sp]
      CmmAGraph -> FCode ()
    emit forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [CmmAGraph] -> CmmAGraph
    catAGraphs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (GlobalReg, ByteOff) -> FCode CmmAGraph
    save_arg [(GlobalReg, ByteOff)]
    regs

    emitCloseNursery :: FCode ()
    emitCloseNursery :: FCode ()
    emitCloseNursery = do
      Profile
    profile <- FCode Profile
    getProfile
      let platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
      LocalReg
    tso <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmType
    bWord Platform
    platform)
      CmmAGraph
    code <- forall (m :: * -> *).
    MonadUnique m =>
    Profile -> LocalReg -> m CmmAGraph
    closeNursery Profile
    profile LocalReg
    tso
      CmmAGraph -> FCode ()
    emit forall a b. (a -> b) -> a -> b
    $ CmmReg -> CmmExpr -> CmmAGraph
    mkAssign (LocalReg -> CmmReg
    CmmLocal LocalReg
    tso) CmmExpr
    currentTSOExpr CmmAGraph -> CmmAGraph -> CmmAGraph
    <*> CmmAGraph
    code

    {- |
    @closeNursery dflags tso@ produces code to close the nursery.
    A local register holding the value of @CurrentTSO@ is expected for
    efficiency.

    Closing the nursery corresponds to the following code:

    @
      tso = CurrentTSO;
      cn = CurrentNuresry;

      // Update the allocation limit for the current thread.  We don't
      // check to see whether it has overflowed at this point, that check is
      // made when we run out of space in the current heap block (stg_gc_noregs)
      // and in the scheduler when context switching (schedulePostRunThread).
      tso->alloc_limit -= Hp + WDS(1) - cn->start;

      // Set cn->free to the next unoccupied word in the block
      cn->free = Hp + WDS(1);
    @
    -}
    closeNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph
    closeNursery :: forall (m :: * -> *).
    MonadUnique m =>
    Profile -> LocalReg -> m CmmAGraph
    closeNursery Profile
    profile LocalReg
    tso = do
      let tsoreg :: CmmReg
    tsoreg   = LocalReg -> CmmReg
    CmmLocal LocalReg
    tso
          platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
      CmmReg
    cnreg      <- LocalReg -> CmmReg
    CmmLocal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmType
    bWord Platform
    platform)
      forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ [CmmAGraph] -> CmmAGraph
    catAGraphs [
        CmmReg -> CmmExpr -> CmmAGraph
    mkAssign CmmReg
    cnreg CmmExpr
    currentNurseryExpr,

        -- CurrentNursery->free = Hp+1;
        CmmExpr -> CmmExpr -> CmmAGraph
    mkStore (Platform -> CmmReg -> CmmExpr
    nursery_bdescr_free Platform
    platform CmmReg
    cnreg) (Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffsetW Platform
    platform CmmExpr
    hpExpr ByteOff
    1),

        let alloc :: CmmExpr
    alloc =
               MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Platform -> MachOp
    mo_wordSub Platform
    platform)
                  [ Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffsetW Platform
    platform CmmExpr
    hpExpr ByteOff
    1
                  , Platform -> CmmExpr -> CmmExpr
    cmmLoadBWord Platform
    platform (Platform -> CmmReg -> CmmExpr
    nursery_bdescr_start Platform
    platform CmmReg
    cnreg)
                  ]

            alloc_limit :: CmmExpr
    alloc_limit = Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform (CmmReg -> CmmExpr
    CmmReg CmmReg
    tsoreg) (Profile -> ByteOff
    tso_alloc_limit Profile
    profile)
        in

        -- tso->alloc_limit += alloc
        CmmExpr -> CmmExpr -> CmmAGraph
    mkStore CmmExpr
    alloc_limit (MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Width -> MachOp
    MO_Sub Width
    W64)
                                   [ CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
    CmmLoad CmmExpr
    alloc_limit CmmType
    b64 AlignmentSpec
    NaturallyAligned
                                   , MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Platform -> MachOp
    mo_WordTo64 Platform
    platform) [CmmExpr
    alloc] ])
       ]

    emitLoadThreadState :: FCode ()
    emitLoadThreadState :: FCode ()
    emitLoadThreadState = do
      Profile
    profile <- FCode Profile
    getProfile
      CmmAGraph
    code <- forall (m :: * -> *). MonadUnique m => Profile -> m CmmAGraph
    loadThreadState Profile
    profile
      CmmAGraph -> FCode ()
    emit CmmAGraph
    code

    -- | Produce code to load the current thread state from @CurrentTSO@
    loadThreadState :: MonadUnique m => Profile -> m CmmAGraph
    loadThreadState :: forall (m :: * -> *). MonadUnique m => Profile -> m CmmAGraph
    loadThreadState Profile
    profile = do
      let platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
      LocalReg
    tso <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmType
    gcWord Platform
    platform)
      LocalReg
    stack <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmType
    gcWord Platform
    platform)
      CmmAGraph
    open_nursery <- forall (m :: * -> *).
    MonadUnique m =>
    Profile -> LocalReg -> m CmmAGraph
    openNursery Profile
    profile LocalReg
    tso
      forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ [CmmAGraph] -> CmmAGraph
    catAGraphs [
        -- tso = CurrentTSO;
        CmmReg -> CmmExpr -> CmmAGraph
    mkAssign (LocalReg -> CmmReg
    CmmLocal LocalReg
    tso) CmmExpr
    currentTSOExpr,
        -- stack = tso->stackobj;
        CmmReg -> CmmExpr -> CmmAGraph
    mkAssign (LocalReg -> CmmReg
    CmmLocal LocalReg
    stack) (Platform -> CmmExpr -> CmmExpr
    cmmLoadBWord Platform
    platform (Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform (CmmReg -> CmmExpr
    CmmReg (LocalReg -> CmmReg
    CmmLocal LocalReg
    tso)) (Profile -> ByteOff
    tso_stackobj Profile
    profile))),
        -- Sp = stack->sp;
        CmmReg -> CmmExpr -> CmmAGraph
    mkAssign CmmReg
    spReg (Platform -> CmmExpr -> CmmExpr
    cmmLoadBWord Platform
    platform (Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform (CmmReg -> CmmExpr
    CmmReg (LocalReg -> CmmReg
    CmmLocal LocalReg
    stack)) (Profile -> ByteOff
    stack_SP Profile
    profile))),
        -- SpLim = stack->stack + RESERVED_STACK_WORDS;
        CmmReg -> CmmExpr -> CmmAGraph
    mkAssign CmmReg
    spLimReg (Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffsetW Platform
    platform (Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform (CmmReg -> CmmExpr
    CmmReg (LocalReg -> CmmReg
    CmmLocal LocalReg
    stack)) (Profile -> ByteOff
    stack_STACK Profile
    profile))
                                    (PlatformConstants -> ByteOff
    pc_RESERVED_STACK_WORDS (Platform -> PlatformConstants
    platformConstants Platform
    platform))),
        -- HpAlloc = 0;
        --   HpAlloc is assumed to be set to non-zero only by a failed
        --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
        CmmReg -> CmmExpr -> CmmAGraph
    mkAssign CmmReg
    hpAllocReg (Platform -> CmmExpr
    zeroExpr Platform
    platform),
        CmmAGraph
    open_nursery,
        -- and load the current cost centre stack from the TSO when profiling:
        if Profile -> Bool
    profileIsProfiling Profile
    profile
           then let ccs_ptr :: CmmExpr
    ccs_ptr = Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform (CmmReg -> CmmExpr
    CmmReg (LocalReg -> CmmReg
    CmmLocal LocalReg
    tso)) (Profile -> ByteOff
    tso_CCCS Profile
    profile)
                in CmmExpr -> CmmAGraph
    storeCurCCS (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
    CmmLoad CmmExpr
    ccs_ptr (Platform -> CmmType
    ccsType Platform
    platform) AlignmentSpec
    NaturallyAligned)
           else CmmAGraph
    mkNop
       ]

    emitOpenNursery :: FCode ()
    emitOpenNursery :: FCode ()
    emitOpenNursery = do
      Profile
    profile <- FCode Profile
    getProfile
      let platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
      LocalReg
    tso <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmType
    bWord Platform
    platform)
      CmmAGraph
    code <- forall (m :: * -> *).
    MonadUnique m =>
    Profile -> LocalReg -> m CmmAGraph
    openNursery Profile
    profile LocalReg
    tso
      CmmAGraph -> FCode ()
    emit forall a b. (a -> b) -> a -> b
    $ CmmReg -> CmmExpr -> CmmAGraph
    mkAssign (LocalReg -> CmmReg
    CmmLocal LocalReg
    tso) CmmExpr
    currentTSOExpr CmmAGraph -> CmmAGraph -> CmmAGraph
    <*> CmmAGraph
    code

    {- |
    @openNursery profile tso@ produces code to open the nursery. A local register
    holding the value of @CurrentTSO@ is expected for efficiency.

    Opening the nursery corresponds to the following code:

    @
       tso = CurrentTSO;
       cn = CurrentNursery;
       bdfree = CurrentNursery->free;
       bdstart = CurrentNursery->start;

       // We *add* the currently occupied portion of the nursery block to
       // the allocation limit, because we will subtract it again in
       // closeNursery.
       tso->alloc_limit += bdfree - bdstart;

       // Set Hp to the last occupied word of the heap block.  Why not the
       // next unoccupied word?  Doing it this way means that we get to use
       // an offset of zero more often, which might lead to slightly smaller
       // code on some architectures.
       Hp = bdfree - WDS(1);

       // Set HpLim to the end of the current nursery block (note that this block
       // might be a block group, consisting of several adjacent blocks.
       HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;
    @
    -}
    openNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph
    openNursery :: forall (m :: * -> *).
    MonadUnique m =>
    Profile -> LocalReg -> m CmmAGraph
    openNursery Profile
    profile LocalReg
    tso = do
      let tsoreg :: CmmReg
    tsoreg   = LocalReg -> CmmReg
    CmmLocal LocalReg
    tso
          platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
      CmmReg
    cnreg      <- LocalReg -> CmmReg
    CmmLocal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmType
    bWord Platform
    platform)
      CmmReg
    bdfreereg  <- LocalReg -> CmmReg
    CmmLocal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmType
    bWord Platform
    platform)
      CmmReg
    bdstartreg <- LocalReg -> CmmReg
    CmmLocal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmType
    bWord Platform
    platform)

      -- These assignments are carefully ordered to reduce register
      -- pressure and generate not completely awful code on x86.  To see
      -- what code we generate, look at the assembly for
      -- stg_returnToStackTop in rts/StgStartup.cmm.
      forall (f :: * -> *) a. Applicative f => a -> f a
    pure forall a b. (a -> b) -> a -> b
    $ [CmmAGraph] -> CmmAGraph
    catAGraphs [
         CmmReg -> CmmExpr -> CmmAGraph
    mkAssign CmmReg
    cnreg CmmExpr
    currentNurseryExpr,
         CmmReg -> CmmExpr -> CmmAGraph
    mkAssign CmmReg
    bdfreereg  (Platform -> CmmExpr -> CmmExpr
    cmmLoadBWord Platform
    platform (Platform -> CmmReg -> CmmExpr
    nursery_bdescr_free Platform
    platform CmmReg
    cnreg)),

         -- Hp = CurrentNursery->free - 1;
         CmmReg -> CmmExpr -> CmmAGraph
    mkAssign CmmReg
    hpReg (Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffsetW Platform
    platform (CmmReg -> CmmExpr
    CmmReg CmmReg
    bdfreereg) (-ByteOff
    1)),

         CmmReg -> CmmExpr -> CmmAGraph
    mkAssign CmmReg
    bdstartreg (Platform -> CmmExpr -> CmmExpr
    cmmLoadBWord Platform
    platform (Platform -> CmmReg -> CmmExpr
    nursery_bdescr_start Platform
    platform CmmReg
    cnreg)),

         -- HpLim = CurrentNursery->start +
         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
         CmmReg -> CmmExpr -> CmmAGraph
    mkAssign CmmReg
    hpLimReg
             (Platform -> CmmExpr -> CmmExpr -> CmmExpr
    cmmOffsetExpr Platform
    platform
                 (CmmReg -> CmmExpr
    CmmReg CmmReg
    bdstartreg)
                 (Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform
                   (MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Platform -> MachOp
    mo_wordMul Platform
    platform)
                     [ MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Width -> Width -> MachOp
    MO_SS_Conv Width
    W32 (Platform -> Width
    wordWidth Platform
    platform))
                         [CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
    CmmLoad (Platform -> CmmReg -> CmmExpr
    nursery_bdescr_blocks Platform
    platform CmmReg
    cnreg) CmmType
    b32 AlignmentSpec
    NaturallyAligned]
                     , Platform -> ByteOff -> CmmExpr
    mkIntExpr Platform
    platform (PlatformConstants -> ByteOff
    pc_BLOCK_SIZE (Platform -> PlatformConstants
    platformConstants Platform
    platform))
                     ])
                   (-ByteOff
    1)
                 )
             ),

         -- alloc = bd->free - bd->start
         let alloc :: CmmExpr
    alloc =
               MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Platform -> MachOp
    mo_wordSub Platform
    platform) [CmmReg -> CmmExpr
    CmmReg CmmReg
    bdfreereg, CmmReg -> CmmExpr
    CmmReg CmmReg
    bdstartreg]

             alloc_limit :: CmmExpr
    alloc_limit = Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform (CmmReg -> CmmExpr
    CmmReg CmmReg
    tsoreg) (Profile -> ByteOff
    tso_alloc_limit Profile
    profile)
         in

         -- tso->alloc_limit += alloc
         CmmExpr -> CmmExpr -> CmmAGraph
    mkStore CmmExpr
    alloc_limit (MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Width -> MachOp
    MO_Add Width
    W64)
                                   [ CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
    CmmLoad CmmExpr
    alloc_limit CmmType
    b64 AlignmentSpec
    NaturallyAligned
                                   , MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Platform -> MachOp
    mo_WordTo64 Platform
    platform) [CmmExpr
    alloc] ])

       ]

    nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks
      :: Platform -> CmmReg -> CmmExpr
    nursery_bdescr_free :: Platform -> CmmReg -> CmmExpr
    nursery_bdescr_free   Platform
    platform CmmReg
    cn =
      Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform (CmmReg -> CmmExpr
    CmmReg CmmReg
    cn) (PlatformConstants -> ByteOff
    pc_OFFSET_bdescr_free (Platform -> PlatformConstants
    platformConstants Platform
    platform))
    nursery_bdescr_start :: Platform -> CmmReg -> CmmExpr
    nursery_bdescr_start  Platform
    platform CmmReg
    cn =
      Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform (CmmReg -> CmmExpr
    CmmReg CmmReg
    cn) (PlatformConstants -> ByteOff
    pc_OFFSET_bdescr_start (Platform -> PlatformConstants
    platformConstants Platform
    platform))
    nursery_bdescr_blocks :: Platform -> CmmReg -> CmmExpr
    nursery_bdescr_blocks Platform
    platform CmmReg
    cn =
      Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffset Platform
    platform (CmmReg -> CmmExpr
    CmmReg CmmReg
    cn) (PlatformConstants -> ByteOff
    pc_OFFSET_bdescr_blocks (Platform -> PlatformConstants
    platformConstants Platform
    platform))

    tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: Profile -> ByteOff
    tso_stackobj :: Profile -> ByteOff
    tso_stackobj    Profile
    profile = Profile -> ByteOff -> ByteOff
    closureField Profile
    profile (PlatformConstants -> ByteOff
    pc_OFFSET_StgTSO_stackobj    (Profile -> PlatformConstants
    profileConstants Profile
    profile))
    tso_alloc_limit :: Profile -> ByteOff
    tso_alloc_limit Profile
    profile = Profile -> ByteOff -> ByteOff
    closureField Profile
    profile (PlatformConstants -> ByteOff
    pc_OFFSET_StgTSO_alloc_limit (Profile -> PlatformConstants
    profileConstants Profile
    profile))
    tso_CCCS :: Profile -> ByteOff
    tso_CCCS        Profile
    profile = Profile -> ByteOff -> ByteOff
    closureField Profile
    profile (PlatformConstants -> ByteOff
    pc_OFFSET_StgTSO_cccs        (Profile -> PlatformConstants
    profileConstants Profile
    profile))
    stack_STACK :: Profile -> ByteOff
    stack_STACK     Profile
    profile = Profile -> ByteOff -> ByteOff
    closureField Profile
    profile (PlatformConstants -> ByteOff
    pc_OFFSET_StgStack_stack     (Profile -> PlatformConstants
    profileConstants Profile
    profile))
    stack_SP :: Profile -> ByteOff
    stack_SP        Profile
    profile = Profile -> ByteOff -> ByteOff
    closureField Profile
    profile (PlatformConstants -> ByteOff
    pc_OFFSET_StgStack_sp        (Profile -> PlatformConstants
    profileConstants Profile
    profile))

    closureField :: Profile -> ByteOff -> ByteOff
    closureField :: Profile -> ByteOff -> ByteOff
    closureField Profile
    profile ByteOff
    off = ByteOff
    off forall a. Num a => a -> a -> a
    + Profile -> ByteOff
    fixedHdrSize Profile
    profile

    -- Note [Unlifted boxed arguments to foreign calls]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    --
    -- For certain types passed to foreign calls, we adjust the actual
    -- value passed to the call.  For ByteArray#, Array#, SmallArray#,
    -- and ArrayArray#, we pass the address of the array's payload, not
    -- the address of the heap object. For example, consider
    --   foreign import "c_foo" foo :: ByteArray# -> Int# -> IO ()
    -- At a Haskell call like `foo x y`, we'll generate a C call that
    -- is more like
    --   c_foo( x+8, y )
    -- where the "+8" takes the heap pointer (x :: ByteArray#) and moves
    -- it past the header words of the ByteArray object to point directly
    -- to the data inside the ByteArray#. (The exact offset depends
    -- on the target architecture and on profiling) By contrast, (y :: Int#)
    -- requires no such adjustment.
    --
    -- This adjustment is performed by 'add_shim'. The size of the
    -- adjustment depends on the type of heap object. But
    -- how can we determine that type? There are two available options.
    -- We could use the types of the actual values that the foreign call
    -- has been applied to, or we could use the types present in the
    -- foreign function's type. Prior to GHC 8.10, we used the former
    -- strategy since it's a little more simple. However, in issue #16650
    -- and more compellingly in the comments of
    -- https://gitlab.haskell.org/ghc/ghc/merge_requests/939, it was
    -- demonstrated that this leads to bad behavior in the presence
    -- of unsafeCoerce#. Returning to the above example, suppose the
    -- Haskell call looked like
    --   foo (unsafeCoerce# p)
    -- where the types of expressions comprising the arguments are
    --   p :: (Any :: TYPE 'UnliftedRep)
    --   i :: Int#
    -- so that the unsafe-coerce is between Any and ByteArray#.
    -- These two types have the same kind (they are both represented by
    -- a heap pointer) so no GC errors will occur if we do this unsafe coerce.
    -- By the time this gets to the code generator the cast has been
    -- discarded so we have
    --   foo p y
    -- But we *must* adjust the pointer to p by a ByteArray# shim,
    -- *not* by an Any shim (the Any shim involves no offset at all).
    --
    -- To avoid this bad behavior, we adopt the second strategy: use
    -- the types present in the foreign function's type.
    -- In collectStgFArgTypes, we convert the foreign function's
    -- type to a list of StgFArgType. Then, in add_shim, we interpret
    -- these as numeric offsets.

    getFCallArgs ::
         [StgArg]
      -> Type -- the type of the foreign function
      -> FCode [(CmmExpr, ForeignHint)]
    -- (a) Drop void args
    -- (b) Add foreign-call shim code
    -- It's (b) that makes this differ from getNonVoidArgAmodes
    -- Precondition: args and typs have the same length
    -- See Note [Unlifted boxed arguments to foreign calls]
    getFCallArgs :: [StgArg] -> Type -> FCode [(CmmExpr, ForeignHint)]
    getFCallArgs [StgArg]
    args Type
    typ
      = do  { [Maybe (CmmExpr, ForeignHint)]
    mb_cmms <- forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (StgArg, StgFArgType) -> FCode (Maybe (CmmExpr, ForeignHint))
    get (forall a b. String -> [a] -> [b] -> [(a, b)]
    zipEqual String
    "getFCallArgs" [StgArg]
    args (Type -> [StgFArgType]
    collectStgFArgTypes Type
    typ))
            ; forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. [Maybe a] -> [a]
    catMaybes [Maybe (CmmExpr, ForeignHint)]
    mb_cmms) }
      where
        get :: (StgArg, StgFArgType) -> FCode (Maybe (CmmExpr, ForeignHint))
    get (StgArg
    arg,StgFArgType
    typ)
          | forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [PrimRep]
    arg_reps
          = forall (m :: * -> *) a. Monad m => a -> m a
    return forall a. Maybe a
    Nothing
          | Bool
    otherwise
          = do { CmmExpr
    cmm <- NonVoid StgArg -> FCode CmmExpr
    getArgAmode (forall a. a -> NonVoid a
    NonVoid StgArg
    arg)
               ; Profile
    profile <- FCode Profile
    getProfile
               ; forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. a -> Maybe a
    Just (Profile -> StgFArgType -> CmmExpr -> CmmExpr
    add_shim Profile
    profile StgFArgType
    typ CmmExpr
    cmm, ForeignHint
    hint)) }
          where
            arg_ty :: Type
    arg_ty   = StgArg -> Type
    stgArgType StgArg
    arg
            arg_reps :: [PrimRep]
    arg_reps = HasDebugCallStack => Type -> [PrimRep]
    typePrimRep Type
    arg_ty
            hint :: ForeignHint
    hint     = Type -> ForeignHint
    typeForeignHint Type
    arg_ty

    -- The minimum amount of information needed to determine
    -- the offset to apply to an argument to a foreign call.
    -- See Note [Unlifted boxed arguments to foreign calls]
    data StgFArgType
      = StgPlainType
      | StgArrayType
      | StgSmallArrayType
      | StgByteArrayType

    -- See Note [Unlifted boxed arguments to foreign calls]
    add_shim :: Profile -> StgFArgType -> CmmExpr -> CmmExpr
    add_shim :: Profile -> StgFArgType -> CmmExpr -> CmmExpr
    add_shim Profile
    profile StgFArgType
    ty CmmExpr
    expr = case StgFArgType
    ty of
      StgFArgType
    StgPlainType      -> CmmExpr
    expr
      StgFArgType
    StgArrayType      -> Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffsetB Platform
    platform CmmExpr
    expr (Profile -> ByteOff
    arrPtrsHdrSize Profile
    profile)
      StgFArgType
    StgSmallArrayType -> Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffsetB Platform
    platform CmmExpr
    expr (Profile -> ByteOff
    smallArrPtrsHdrSize Profile
    profile)
      StgFArgType
    StgByteArrayType  -> Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffsetB Platform
    platform CmmExpr
    expr (Profile -> ByteOff
    arrWordsHdrSize Profile
    profile)
      where
        platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile

    -- From a function, extract information needed to determine
    -- the offset of each argument when used as a C FFI argument.
    -- See Note [Unlifted boxed arguments to foreign calls]
    collectStgFArgTypes :: Type -> [StgFArgType]
    collectStgFArgTypes :: Type -> [StgFArgType]
    collectStgFArgTypes = [StgFArgType] -> Type -> [StgFArgType]
    go []
      where
        -- Skip foralls
        go :: [StgFArgType] -> Type -> [StgFArgType]
    go [StgFArgType]
    bs (ForAllTy TyCoVarBinder
    _ Type
    res) = [StgFArgType] -> Type -> [StgFArgType]
    go [StgFArgType]
    bs Type
    res
        go [StgFArgType]
    bs (AppTy{}) = forall a. [a] -> [a]
    reverse [StgFArgType]
    bs
        go [StgFArgType]
    bs (TyConApp{}) = forall a. [a] -> [a]
    reverse [StgFArgType]
    bs
        go [StgFArgType]
    bs (LitTy{}) = forall a. [a] -> [a]
    reverse [StgFArgType]
    bs
        go [StgFArgType]
    bs (TyVarTy{}) = forall a. [a] -> [a]
    reverse [StgFArgType]
    bs
        go  [StgFArgType]
    _ (CastTy{}) = forall a. String -> a
    panic String
    "myCollectTypeArgs: CastTy"
        go  [StgFArgType]
    _ (CoercionTy{}) = forall a. String -> a
    panic String
    "myCollectTypeArgs: CoercionTy"
        go [StgFArgType]
    bs (FunTy {ft_arg :: Type -> Type
    ft_arg = Type
    arg, ft_res :: Type -> Type
    ft_res=Type
    res}) =
          [StgFArgType] -> Type -> [StgFArgType]
    go (Type -> StgFArgType
    typeToStgFArgType Type
    argforall a. a -> [a] -> [a]
    :[StgFArgType]
    bs) Type
    res

    -- Choose the offset based on the type. For anything other
    -- than an unlifted boxed type, there is no offset.
    -- See Note [Unlifted boxed arguments to foreign calls]
    typeToStgFArgType :: Type -> StgFArgType
    typeToStgFArgType :: Type -> StgFArgType
    typeToStgFArgType Type
    typ
      | TyCon
    tycon forall a. Eq a => a -> a -> Bool
    == TyCon
    arrayPrimTyCon = StgFArgType
    StgArrayType
      | TyCon
    tycon forall a. Eq a => a -> a -> Bool
    == TyCon
    mutableArrayPrimTyCon = StgFArgType
    StgArrayType
      | TyCon
    tycon forall a. Eq a => a -> a -> Bool
    == TyCon
    arrayArrayPrimTyCon = StgFArgType
    StgArrayType
      | TyCon
    tycon forall a. Eq a => a -> a -> Bool
    == TyCon
    mutableArrayArrayPrimTyCon = StgFArgType
    StgArrayType
      | TyCon
    tycon forall a. Eq a => a -> a -> Bool
    == TyCon
    smallArrayPrimTyCon = StgFArgType
    StgSmallArrayType
      | TyCon
    tycon forall a. Eq a => a -> a -> Bool
    == TyCon
    smallMutableArrayPrimTyCon = StgFArgType
    StgSmallArrayType
      | TyCon
    tycon forall a. Eq a => a -> a -> Bool
    == TyCon
    byteArrayPrimTyCon = StgFArgType
    StgByteArrayType
      | TyCon
    tycon forall a. Eq a => a -> a -> Bool
    == TyCon
    mutableByteArrayPrimTyCon = StgFArgType
    StgByteArrayType
      | Bool
    otherwise = StgFArgType
    StgPlainType
      where
      -- Should be a tycon app, since this is a foreign call. We look
      -- through newtypes so the offset does not change if a user replaces
      -- a type in a foreign function signature with a representationally
      -- equivalent newtype.
      tycon :: TyCon
    tycon = Type -> TyCon
    tyConAppTyCon (Type -> Type
    unwrapType Type
    typ)