    -----------------------------------------------------------------------------
    --
    -- Stg to C--: heap management functions
    --
    -- (c) The University of Glasgow 2004-2006
    --
    -----------------------------------------------------------------------------

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

    module GHC.StgToCmm.Heap (
            getVirtHp, setVirtHp, setRealHp,
            getHpRelOffset,

            entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,
            heapStackCheckGen,
            entryHeapCheck',

            mkStaticClosureFields, mkStaticClosure,

            allocDynClosure, allocDynClosureCmm, allocHeapClosure,
            emitSetDynHdr
        ) where

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

    import GHC.Stg.Syntax
    import GHC.Cmm.CLabel
    import GHC.StgToCmm.Layout
    import GHC.StgToCmm.Utils
    import GHC.StgToCmm.Monad
    import GHC.StgToCmm.Prof (profDynAlloc, dynProfHdr, staticProfHdr)
    import GHC.StgToCmm.Ticky
    import GHC.StgToCmm.Closure

    import GHC.Cmm.Graph

    import GHC.Cmm.Dataflow.Label
    import GHC.Runtime.Heap.Layout
    import GHC.Cmm.BlockId
    import GHC.Cmm
    import GHC.Cmm.Utils
    import GHC.Types.CostCentre
    import GHC.Types.Id.Info( CafInfo(..), mayHaveCafRefs )
    import GHC.Types.Id ( Id )
    import GHC.Unit
    import GHC.Platform
    import GHC.Platform.Profile
    import GHC.Data.FastString( mkFastString, fsLit )
    import GHC.Utils.Panic( sorry )

    import Control.Monad (when)
    import Data.Maybe (isJust)

    -----------------------------------------------------------
    --              Initialise dynamic heap objects
    -----------------------------------------------------------

    allocDynClosure
            :: Maybe Id
            -> CmmInfoTable
            -> LambdaFormInfo
            -> CmmExpr              -- Cost Centre to stick in the object
            -> CmmExpr              -- Cost Centre to blame for this alloc
                                    -- (usually the same; sometimes "OVERHEAD")

            -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object
                                                    -- ie Info ptr has offset zero.
                                                    -- No void args in here
            -> FCode CmmExpr -- returns Hp+n

    allocDynClosureCmm
            :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
            -> [(CmmExpr, ByteOff)]
            -> FCode CmmExpr -- returns Hp+n

    -- allocDynClosure allocates the thing in the heap,
    -- and modifies the virtual Hp to account for this.
    -- The second return value is the graph that sets the value of the
    -- returned LocalReg, which should point to the closure after executing
    -- the graph.

    -- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is
    -- only valid until Hp is changed.  The caller should assign the
    -- result to a LocalReg if it is required to remain live.
    --
    -- The reason we don't assign it to a LocalReg here is that the caller
    -- is often about to call regIdInfo, which immediately assigns the
    -- result of allocDynClosure to a new temp in order to add the tag.
    -- So by not generating a LocalReg here we avoid a common source of
    -- new temporaries and save some compile time.  This can be quite
    -- significant - see test T4801.

    allocDynClosure :: Maybe Id
    -> CmmInfoTable
    -> LambdaFormInfo
    -> CmmExpr
    -> CmmExpr
    -> [(NonVoid StgArg, Int)]
    -> FCode CmmExpr
    allocDynClosure Maybe Id
    mb_id CmmInfoTable
    info_tbl LambdaFormInfo
    lf_info CmmExpr
    use_cc CmmExpr
    _blame_cc [(NonVoid StgArg, Int)]
    args_w_offsets = do
      let ([NonVoid StgArg]
    args, [Int]
    offsets) = [(NonVoid StgArg, Int)] -> ([NonVoid StgArg], [Int])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(NonVoid StgArg, Int)]
    args_w_offsets
      [CmmExpr]
    cmm_args <- (NonVoid StgArg -> FCode CmmExpr)
    -> [NonVoid StgArg] -> FCode [CmmExpr]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM NonVoid StgArg -> FCode CmmExpr
    getArgAmode [NonVoid StgArg]
    args     -- No void args
      Maybe Id
    -> CmmInfoTable
    -> LambdaFormInfo
    -> CmmExpr
    -> CmmExpr
    -> [(CmmExpr, Int)]
    -> FCode CmmExpr
    allocDynClosureCmm Maybe Id
    mb_id CmmInfoTable
    info_tbl LambdaFormInfo
    lf_info
                         CmmExpr
    use_cc CmmExpr
    _blame_cc ([CmmExpr] -> [Int] -> [(CmmExpr, Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [CmmExpr]
    cmm_args [Int]
    offsets)

    allocDynClosureCmm :: Maybe Id
    -> CmmInfoTable
    -> LambdaFormInfo
    -> CmmExpr
    -> CmmExpr
    -> [(CmmExpr, Int)]
    -> FCode CmmExpr
    allocDynClosureCmm Maybe Id
    mb_id CmmInfoTable
    info_tbl LambdaFormInfo
    lf_info CmmExpr
    use_cc CmmExpr
    _blame_cc [(CmmExpr, Int)]
    amodes_w_offsets = do
      -- SAY WHAT WE ARE ABOUT TO DO
      let rep :: SMRep
    rep = CmmInfoTable -> SMRep
    cit_rep CmmInfoTable
    info_tbl
      Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
    tickyDynAlloc Maybe Id
    mb_id SMRep
    rep LambdaFormInfo
    lf_info
      let info_ptr :: CmmExpr
    info_ptr = CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel (CmmInfoTable -> CLabel
    cit_lbl CmmInfoTable
    info_tbl))
      SMRep -> CmmExpr -> CmmExpr -> [(CmmExpr, Int)] -> FCode CmmExpr
    allocHeapClosure SMRep
    rep CmmExpr
    info_ptr CmmExpr
    use_cc [(CmmExpr, Int)]
    amodes_w_offsets

    -- | Low-level heap object allocation.
    allocHeapClosure
      :: SMRep                            -- ^ representation of the object
      -> CmmExpr                          -- ^ info pointer
      -> CmmExpr                          -- ^ cost centre
      -> [(CmmExpr,ByteOff)]              -- ^ payload
      -> FCode CmmExpr                    -- ^ returns the address of the object
    allocHeapClosure :: SMRep -> CmmExpr -> CmmExpr -> [(CmmExpr, Int)] -> FCode CmmExpr
    allocHeapClosure SMRep
    rep CmmExpr
    info_ptr CmmExpr
    use_cc [(CmmExpr, Int)]
    payload = do
      SMRep -> CmmExpr -> FCode ()
    profDynAlloc SMRep
    rep CmmExpr
    use_cc

      Int
    virt_hp <- FCode Int
    getVirtHp

      -- Find the offset of the info-ptr word
      let info_offset :: Int
    info_offset = Int
    virt_hp Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
                -- info_offset is the VirtualHpOffset of the first
                -- word of the new object
                -- Remember, virtHp points to last allocated word,
                -- ie 1 *before* the info-ptr word of new object.

      CmmExpr
    base <- Int -> FCode CmmExpr
    getHpRelOffset Int
    info_offset
      FastString -> FCode ()
    emitComment (FastString -> FCode ()) -> FastString -> FCode ()
    forall a b. (a -> b) -> a -> b
    $ String -> FastString
    mkFastString String
    "allocHeapClosure"
      CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
    emitSetDynHdr CmmExpr
    base CmmExpr
    info_ptr CmmExpr
    use_cc

      -- Fill in the fields
      CmmExpr -> [(CmmExpr, Int)] -> FCode ()
    hpStore CmmExpr
    base [(CmmExpr, Int)]
    payload

      -- Bump the virtual heap pointer
      Profile
    profile <- FCode Profile
    getProfile
      Int -> FCode ()
    setVirtHp (Int
    virt_hp Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Profile -> SMRep -> Int
    heapClosureSizeW Profile
    profile SMRep
    rep)

      CmmExpr -> FCode CmmExpr
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CmmExpr
    base

    emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
    emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
    emitSetDynHdr CmmExpr
    base CmmExpr
    info_ptr CmmExpr
    ccs
      = do Profile
    profile <- FCode Profile
    getProfile
           CmmExpr -> [(CmmExpr, Int)] -> FCode ()
    hpStore CmmExpr
    base ([CmmExpr] -> [Int] -> [(CmmExpr, Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip (Profile -> [CmmExpr]
    header Profile
    profile) [Int
    0, Profile -> Int
    profileWordSizeInBytes Profile
    profile ..])
      where
        header :: Profile -> [CmmExpr]
        header :: Profile -> [CmmExpr]
    header Profile
    profile = [CmmExpr
    info_ptr] [CmmExpr] -> [CmmExpr] -> [CmmExpr]
    forall a. [a] -> [a] -> [a]
    ++ Profile -> CmmExpr -> [CmmExpr]
    dynProfHdr Profile
    profile CmmExpr
    ccs
            -- ToDo: Parallel stuff
            -- No ticky header

    -- Store the item (expr,off) in base[off]
    hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()
    hpStore :: CmmExpr -> [(CmmExpr, Int)] -> FCode ()
    hpStore CmmExpr
    base [(CmmExpr, Int)]
    vals = do
      Platform
    platform <- FCode Platform
    getPlatform
      [FCode ()] -> FCode ()
    forall (t :: * -> *) (m :: * -> *) a.
    (Foldable t, Monad m) =>
    t (m a) -> m ()
    sequence_ ([FCode ()] -> FCode ()) -> [FCode ()] -> FCode ()
    forall a b. (a -> b) -> a -> b
    $
        [ CmmExpr -> CmmExpr -> FCode ()
    emitStore (Platform -> CmmExpr -> Int -> CmmExpr
    cmmOffsetB Platform
    platform CmmExpr
    base Int
    off) CmmExpr
    val | (CmmExpr
    val,Int
    off) <- [(CmmExpr, Int)]
    vals ]

    -----------------------------------------------------------
    --              Layout of static closures
    -----------------------------------------------------------

    -- Make a static closure, adding on any extra padding needed for CAFs,
    -- and adding a static link field if necessary.

    mkStaticClosureFields
            :: Profile
            -> CmmInfoTable
            -> CostCentreStack
            -> CafInfo
            -> [CmmLit]             -- Payload
            -> [CmmLit]             -- The full closure
    mkStaticClosureFields :: Profile
    -> CmmInfoTable
    -> CostCentreStack
    -> CafInfo
    -> [CmmLit]
    -> [CmmLit]
    mkStaticClosureFields Profile
    profile CmmInfoTable
    info_tbl CostCentreStack
    ccs CafInfo
    caf_refs [CmmLit]
    payload
      = Profile
    -> CLabel
    -> CostCentreStack
    -> [CmmLit]
    -> [CmmLit]
    -> [CmmLit]
    -> [CmmLit]
    -> [CmmLit]
    mkStaticClosure Profile
    profile CLabel
    info_lbl CostCentreStack
    ccs [CmmLit]
    payload [CmmLit]
    padding
            [CmmLit]
    static_link_field [CmmLit]
    saved_info_field
      where
        platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
        info_lbl :: CLabel
    info_lbl = CmmInfoTable -> CLabel
    cit_lbl CmmInfoTable
    info_tbl

        -- CAFs must have consistent layout, regardless of whether they
        -- are actually updatable or not.  The layout of a CAF is:
        --
        --        3 saved_info
        --        2 static_link
        --        1 indirectee
        --        0 info ptr
        --
        -- the static_link and saved_info fields must always be in the
        -- same place.  So we use isThunkRep rather than closureUpdReqd
        -- here:

        is_caf :: Bool
    is_caf = SMRep -> Bool
    isThunkRep (CmmInfoTable -> SMRep
    cit_rep CmmInfoTable
    info_tbl)

        padding :: [CmmLit]
    padding
            | Bool
    is_caf Bool -> Bool -> Bool
    && [CmmLit] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [CmmLit]
    payload = [Platform -> Int -> CmmLit
    mkIntCLit Platform
    platform Int
    0]
            | Bool
    otherwise = []

        static_link_field :: [CmmLit]
    static_link_field
            | Bool
    is_caf
            = [Platform -> Int -> CmmLit
    mkIntCLit Platform
    platform Int
    0]
            | Bool -> CmmInfoTable -> Bool
    staticClosureNeedsLink (CafInfo -> Bool
    mayHaveCafRefs CafInfo
    caf_refs) CmmInfoTable
    info_tbl
            = [CmmLit
    static_link_value]
            | Bool
    otherwise
            = []

        saved_info_field :: [CmmLit]
    saved_info_field
            | Bool
    is_caf     = [Platform -> Int -> CmmLit
    mkIntCLit Platform
    platform Int
    0]
            | Bool
    otherwise  = []

            -- For a static constructor which has NoCafRefs, we set the
            -- static link field to a non-zero value so the garbage
            -- collector will ignore it.
        static_link_value :: CmmLit
    static_link_value
            | CafInfo -> Bool
    mayHaveCafRefs CafInfo
    caf_refs  = Platform -> Int -> CmmLit
    mkIntCLit Platform
    platform Int
    0
            | Bool
    otherwise                = Platform -> Int -> CmmLit
    mkIntCLit Platform
    platform Int
    3  -- No CAF refs
                                          -- See Note [STATIC_LINK fields]
                                          -- in rts/sm/Storage.h

    mkStaticClosure :: Profile -> CLabel -> CostCentreStack -> [CmmLit]
      -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
    mkStaticClosure :: Profile
    -> CLabel
    -> CostCentreStack
    -> [CmmLit]
    -> [CmmLit]
    -> [CmmLit]
    -> [CmmLit]
    -> [CmmLit]
    mkStaticClosure Profile
    profile CLabel
    info_lbl CostCentreStack
    ccs [CmmLit]
    payload [CmmLit]
    padding [CmmLit]
    static_link_field [CmmLit]
    saved_info_field
      =  [CLabel -> CmmLit
    CmmLabel CLabel
    info_lbl]
      [CmmLit] -> [CmmLit] -> [CmmLit]
    forall a. [a] -> [a] -> [a]
    ++ Profile -> CostCentreStack -> [CmmLit]
    staticProfHdr Profile
    profile CostCentreStack
    ccs
      [CmmLit] -> [CmmLit] -> [CmmLit]
    forall a. [a] -> [a] -> [a]
    ++ [CmmLit]
    payload
      [CmmLit] -> [CmmLit] -> [CmmLit]
    forall a. [a] -> [a] -> [a]
    ++ [CmmLit]
    padding
      [CmmLit] -> [CmmLit] -> [CmmLit]
    forall a. [a] -> [a] -> [a]
    ++ [CmmLit]
    static_link_field
      [CmmLit] -> [CmmLit] -> [CmmLit]
    forall a. [a] -> [a] -> [a]
    ++ [CmmLit]
    saved_info_field

    -----------------------------------------------------------
    --              Heap overflow checking
    -----------------------------------------------------------

    {- Note [Heap checks]
       ~~~~~~~~~~~~~~~~~~
    Heap checks come in various forms.  We provide the following entry
    points to the runtime system, all of which use the native C-- entry
    convention.

      * gc() performs garbage collection and returns
        nothing to its caller

      * A series of canned entry points like
            r = gc_1p( r )
        where r is a pointer.  This performs gc, and
        then returns its argument r to its caller.

      * A series of canned entry points like
            gcfun_2p( f, x, y )
        where f is a function closure of arity 2
        This performs garbage collection, keeping alive the
        three argument ptrs, and then tail-calls f(x,y)

    These are used in the following circumstances

    * entryHeapCheck: Function entry
        (a) With a canned GC entry sequence
            f( f_clo, x:ptr, y:ptr ) {
                 Hp = Hp+8
                 if Hp > HpLim goto L
                 ...
              L: HpAlloc = 8
                 jump gcfun_2p( f_clo, x, y ) }
         Note the tail call to the garbage collector;
         it should do no register shuffling

        (b) No canned sequence
            f( f_clo, x:ptr, y:ptr, ...etc... ) {
              T: Hp = Hp+8
                 if Hp > HpLim goto L
                 ...
              L: HpAlloc = 8
                 call gc()  -- Needs an info table
                 goto T }

    * altHeapCheck: Immediately following an eval
      Started as
            case f x y of r { (p,q) -> rhs }
      (a) With a canned sequence for the results of f
           (which is the very common case since
           all boxed cases return just one pointer
               ...
               r = f( x, y )
            K:      -- K needs an info table
               Hp = Hp+8
               if Hp > HpLim goto L
               ...code for rhs...

            L: r = gc_1p( r )
               goto K }

            Here, the info table needed by the call
            to gc_1p should be the *same* as the
            one for the call to f; the C-- optimiser
            spots this sharing opportunity)

       (b) No canned sequence for results of f
           Note second info table
               ...
               (r1,r2,r3) = call f( x, y )
            K:
               Hp = Hp+8
               if Hp > HpLim goto L
               ...code for rhs...

            L: call gc()    -- Extra info table here
               goto K

    * generalHeapCheck: Anywhere else
      e.g. entry to thunk
           case branch *not* following eval,
           or let-no-escape
      Exactly the same as the previous case:

            K:      -- K needs an info table
               Hp = Hp+8
               if Hp > HpLim goto L
               ...

            L: call gc()
               goto K
    -}

    --------------------------------------------------------------
    -- A heap/stack check at a function or thunk entry point.

    entryHeapCheck :: ClosureInfo
                   -> Maybe LocalReg -- Function (closure environment)
                   -> Int            -- Arity -- not same as len args b/c of voids
                   -> [LocalReg]     -- Non-void args (empty for thunk)
                   -> FCode ()
                   -> FCode ()

    entryHeapCheck :: ClosureInfo
    -> Maybe LocalReg -> Int -> [LocalReg] -> FCode () -> FCode ()
    entryHeapCheck ClosureInfo
    cl_info Maybe LocalReg
    nodeSet Int
    arity [LocalReg]
    args FCode ()
    code = do
      Platform
    platform <- FCode Platform
    getPlatform
      let
        node :: CmmExpr
    node = case Maybe LocalReg
    nodeSet of
                  Just LocalReg
    r  -> CmmReg -> CmmExpr
    CmmReg (LocalReg -> CmmReg
    CmmLocal LocalReg
    r)
                  Maybe LocalReg
    Nothing -> CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel (CLabel -> CmmLit) -> CLabel -> CmmLit
    forall a b. (a -> b) -> a -> b
    $ Platform -> ClosureInfo -> CLabel
    staticClosureLabel Platform
    platform ClosureInfo
    cl_info)

        is_fastf :: Bool
    is_fastf = case ClosureInfo -> Maybe (Int, ArgDescr)
    closureFunInfo ClosureInfo
    cl_info of
                     Just (Int
    _, ArgGen Liveness
    _) -> Bool
    False
                     Maybe (Int, ArgDescr)
    _otherwise         -> Bool
    True

      Bool -> CmmExpr -> Int -> [LocalReg] -> FCode () -> FCode ()
    entryHeapCheck' Bool
    is_fastf CmmExpr
    node Int
    arity [LocalReg]
    args FCode ()
    code

    -- | lower-level version for "GHC.Cmm.Parser"
    entryHeapCheck' :: Bool           -- is a known function pattern
                    -> CmmExpr        -- expression for the closure pointer
                    -> Int            -- Arity -- not same as len args b/c of voids
                    -> [LocalReg]     -- Non-void args (empty for thunk)
                    -> FCode ()
                    -> FCode ()
    entryHeapCheck' :: Bool -> CmmExpr -> Int -> [LocalReg] -> FCode () -> FCode ()
    entryHeapCheck' Bool
    is_fastf CmmExpr
    node Int
    arity [LocalReg]
    args FCode ()
    code
      = do Profile
    profile <- FCode Profile
    getProfile
           let is_thunk :: Bool
    is_thunk = Int
    arity Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0

               args' :: [CmmExpr]
    args' = (LocalReg -> CmmExpr) -> [LocalReg] -> [CmmExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map (CmmReg -> CmmExpr
    CmmReg (CmmReg -> CmmExpr) -> (LocalReg -> CmmReg) -> LocalReg -> CmmExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LocalReg -> CmmReg
    CmmLocal) [LocalReg]
    args
               stg_gc_fun :: CmmExpr
    stg_gc_fun    = CmmReg -> CmmExpr
    CmmReg (GlobalReg -> CmmReg
    CmmGlobal GlobalReg
    GCFun)
               stg_gc_enter1 :: CmmExpr
    stg_gc_enter1 = CmmReg -> CmmExpr
    CmmReg (GlobalReg -> CmmReg
    CmmGlobal GlobalReg
    GCEnter1)

               {- Thunks:          jump stg_gc_enter_1

                  Function (fast): call (NativeNode) stg_gc_fun(fun, args)

                  Function (slow): call (slow) stg_gc_fun(fun, args)
               -}
               gc_call :: Int -> CmmAGraph
    gc_call Int
    upd
                   | Bool
    is_thunk
                     = Profile -> Convention -> CmmExpr -> [CmmExpr] -> Int -> CmmAGraph
    mkJump Profile
    profile Convention
    NativeNodeCall CmmExpr
    stg_gc_enter1 [CmmExpr
    node] Int
    upd

                   | Bool
    is_fastf
                     = Profile -> Convention -> CmmExpr -> [CmmExpr] -> Int -> CmmAGraph
    mkJump Profile
    profile Convention
    NativeNodeCall CmmExpr
    stg_gc_fun (CmmExpr
    node CmmExpr -> [CmmExpr] -> [CmmExpr]
    forall a. a -> [a] -> [a]
    : [CmmExpr]
    args') Int
    upd

                   | Bool
    otherwise
                     = Profile -> Convention -> CmmExpr -> [CmmExpr] -> Int -> CmmAGraph
    mkJump Profile
    profile Convention
    Slow CmmExpr
    stg_gc_fun (CmmExpr
    node CmmExpr -> [CmmExpr] -> [CmmExpr]
    forall a. a -> [a] -> [a]
    : [CmmExpr]
    args') Int
    upd

           Int
    updfr_sz <- FCode Int
    getUpdFrameOff

           BlockId
    loop_id <- FCode BlockId
    forall (m :: * -> *). MonadUnique m => m BlockId
    newBlockId
           BlockId -> FCode ()
    emitLabel BlockId
    loop_id
           Bool -> Bool -> CmmAGraph -> FCode () -> FCode ()
    forall a. Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
    heapCheck Bool
    True Bool
    True (Int -> CmmAGraph
    gc_call Int
    updfr_sz CmmAGraph -> CmmAGraph -> CmmAGraph
    <*> BlockId -> CmmAGraph
    mkBranch BlockId
    loop_id) FCode ()
    code

    -- ------------------------------------------------------------
    -- A heap/stack check in a case alternative

    -- If there are multiple alts and we need to GC, but don't have a
    -- continuation already (the scrut was simple), then we should
    -- pre-generate the continuation.  (if there are multiple alts it is
    -- always a canned GC point).

    -- altHeapCheck:
    -- If we have a return continuation,
    --   then if it is a canned GC pattern,
    --           then we do mkJumpReturnsTo
    --           else we do a normal call to stg_gc_noregs
    --   else if it is a canned GC pattern,
    --           then generate the continuation and do mkCallReturnsTo
    --           else we do a normal call to stg_gc_noregs

    altHeapCheck :: [LocalReg] -> FCode a -> FCode a
    altHeapCheck :: forall a. [LocalReg] -> FCode a -> FCode a
    altHeapCheck [LocalReg]
    regs FCode a
    code = Bool -> [LocalReg] -> FCode a -> FCode a
    forall a. Bool -> [LocalReg] -> FCode a -> FCode a
    altOrNoEscapeHeapCheck Bool
    False [LocalReg]
    regs FCode a
    code

    altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a
    altOrNoEscapeHeapCheck :: forall a. Bool -> [LocalReg] -> FCode a -> FCode a
    altOrNoEscapeHeapCheck Bool
    checkYield [LocalReg]
    regs FCode a
    code = do
        Profile
    profile <- FCode Profile
    getProfile
        Platform
    platform <- FCode Platform
    getPlatform
        case Platform -> [LocalReg] -> Maybe CmmExpr
    cannedGCEntryPoint Platform
    platform [LocalReg]
    regs of
          Maybe CmmExpr
    Nothing -> Bool -> FCode a -> FCode a
    forall a. Bool -> FCode a -> FCode a
    genericGC Bool
    checkYield FCode a
    code
          Just CmmExpr
    gc -> do
            BlockId
    lret <- FCode BlockId
    forall (m :: * -> *). MonadUnique m => m BlockId
    newBlockId
            let (Int
    off, [GlobalReg]
    _, CmmAGraph
    copyin) = Profile
    -> Convention
    -> Area
    -> [LocalReg]
    -> [LocalReg]
    -> (Int, [GlobalReg], CmmAGraph)
    copyInOflow Profile
    profile Convention
    NativeReturn (BlockId -> Area
    Young BlockId
    lret) [LocalReg]
    regs []
            BlockId
    lcont <- FCode BlockId
    forall (m :: * -> *). MonadUnique m => m BlockId
    newBlockId
            CmmTickScope
    tscope <- FCode CmmTickScope
    getTickScope
            BlockId -> CmmAGraphScoped -> FCode ()
    emitOutOfLine BlockId
    lret (CmmAGraph
    copyin CmmAGraph -> CmmAGraph -> CmmAGraph
    <*> BlockId -> CmmAGraph
    mkBranch BlockId
    lcont, CmmTickScope
    tscope)
            BlockId -> FCode ()
    emitLabel BlockId
    lcont
            Bool
    -> Bool
    -> CmmExpr
    -> [LocalReg]
    -> BlockId
    -> Int
    -> FCode a
    -> FCode a
    forall a.
    Bool
    -> Bool
    -> CmmExpr
    -> [LocalReg]
    -> BlockId
    -> Int
    -> FCode a
    -> FCode a
    cannedGCReturnsTo Bool
    checkYield Bool
    False CmmExpr
    gc [LocalReg]
    regs BlockId
    lret Int
    off FCode a
    code

    altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a
    altHeapCheckReturnsTo :: forall a. [LocalReg] -> BlockId -> Int -> FCode a -> FCode a
    altHeapCheckReturnsTo [LocalReg]
    regs BlockId
    lret Int
    off FCode a
    code
      = do Platform
    platform <- FCode Platform
    getPlatform
           case Platform -> [LocalReg] -> Maybe CmmExpr
    cannedGCEntryPoint Platform
    platform [LocalReg]
    regs of
               Maybe CmmExpr
    Nothing -> Bool -> FCode a -> FCode a
    forall a. Bool -> FCode a -> FCode a
    genericGC Bool
    False FCode a
    code
               Just CmmExpr
    gc -> Bool
    -> Bool
    -> CmmExpr
    -> [LocalReg]
    -> BlockId
    -> Int
    -> FCode a
    -> FCode a
    forall a.
    Bool
    -> Bool
    -> CmmExpr
    -> [LocalReg]
    -> BlockId
    -> Int
    -> FCode a
    -> FCode a
    cannedGCReturnsTo Bool
    False Bool
    True CmmExpr
    gc [LocalReg]
    regs BlockId
    lret Int
    off FCode a
    code

    -- noEscapeHeapCheck is implemented identically to altHeapCheck (which
    -- is more efficient), but cannot be optimized away in the non-allocating
    -- case because it may occur in a loop
    noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a
    noEscapeHeapCheck :: forall a. [LocalReg] -> FCode a -> FCode a
    noEscapeHeapCheck = Bool -> [LocalReg] -> FCode a -> FCode a
    forall a. Bool -> [LocalReg] -> FCode a -> FCode a
    altOrNoEscapeHeapCheck Bool
    True

    cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff
                      -> FCode a
                      -> FCode a
    cannedGCReturnsTo :: forall a.
    Bool
    -> Bool
    -> CmmExpr
    -> [LocalReg]
    -> BlockId
    -> Int
    -> FCode a
    -> FCode a
    cannedGCReturnsTo Bool
    checkYield Bool
    cont_on_stack CmmExpr
    gc [LocalReg]
    regs BlockId
    lret Int
    off FCode a
    code
      = do Profile
    profile <- FCode Profile
    getProfile
           Int
    updfr_sz <- FCode Int
    getUpdFrameOff
           Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
    forall a. Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
    heapCheck Bool
    False Bool
    checkYield (Profile -> CmmExpr -> Int -> CmmAGraph
    gc_call Profile
    profile CmmExpr
    gc Int
    updfr_sz) FCode a
    code
      where
        reg_exprs :: [CmmExpr]
    reg_exprs = (LocalReg -> CmmExpr) -> [LocalReg] -> [CmmExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map (CmmReg -> CmmExpr
    CmmReg (CmmReg -> CmmExpr) -> (LocalReg -> CmmReg) -> LocalReg -> CmmExpr
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LocalReg -> CmmReg
    CmmLocal) [LocalReg]
    regs
          -- Note [stg_gc arguments]

          -- NB. we use the NativeReturn convention for passing arguments
          -- to the canned heap-check routines, because we are in a case
          -- alternative and hence the [LocalReg] was passed to us in the
          -- NativeReturn convention.
        gc_call :: Profile -> CmmExpr -> Int -> CmmAGraph
    gc_call Profile
    profile CmmExpr
    label Int
    sp
          | Bool
    cont_on_stack
          = Profile
    -> CmmExpr
    -> Convention
    -> [CmmExpr]
    -> BlockId
    -> Int
    -> Int
    -> CmmAGraph
    mkJumpReturnsTo Profile
    profile CmmExpr
    label Convention
    NativeReturn [CmmExpr]
    reg_exprs BlockId
    lret Int
    off Int
    sp
          | Bool
    otherwise
          = Profile
    -> CmmExpr
    -> Convention
    -> [CmmExpr]
    -> BlockId
    -> Int
    -> Int
    -> [CmmExpr]
    -> CmmAGraph
    mkCallReturnsTo Profile
    profile CmmExpr
    label Convention
    NativeReturn [CmmExpr]
    reg_exprs BlockId
    lret Int
    off Int
    sp []

    genericGC :: Bool -> FCode a -> FCode a
    genericGC :: forall a. Bool -> FCode a -> FCode a
    genericGC Bool
    checkYield FCode a
    code
      = do Int
    updfr_sz <- FCode Int
    getUpdFrameOff
           BlockId
    lretry <- FCode BlockId
    forall (m :: * -> *). MonadUnique m => m BlockId
    newBlockId
           BlockId -> FCode ()
    emitLabel BlockId
    lretry
           CmmAGraph
    call <- CmmExpr
    -> (Convention, Convention)
    -> [LocalReg]
    -> [CmmExpr]
    -> Int
    -> [CmmExpr]
    -> FCode CmmAGraph
    mkCall CmmExpr
    generic_gc (Convention
    GC, Convention
    GC) [] [] Int
    updfr_sz []
           Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
    forall a. Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
    heapCheck Bool
    False Bool
    checkYield (CmmAGraph
    call CmmAGraph -> CmmAGraph -> CmmAGraph
    <*> BlockId -> CmmAGraph
    mkBranch BlockId
    lretry) FCode a
    code

    cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr
    cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr
    cannedGCEntryPoint Platform
    platform [LocalReg]
    regs
      = case (LocalReg -> CmmType) -> [LocalReg] -> [CmmType]
    forall a b. (a -> b) -> [a] -> [b]
    map LocalReg -> CmmType
    localRegType [LocalReg]
    regs of
          []  -> CmmExpr -> Maybe CmmExpr
    forall a. a -> Maybe a
    Just (String -> CmmExpr
    mkGcLabel String
    "stg_gc_noregs")
          [CmmType
    ty]
              | CmmType -> Bool
    isGcPtrType CmmType
    ty -> CmmExpr -> Maybe CmmExpr
    forall a. a -> Maybe a
    Just (String -> CmmExpr
    mkGcLabel String
    "stg_gc_unpt_r1")
              | CmmType -> Bool
    isFloatType CmmType
    ty -> case Width
    width of
                                      Width
    W32       -> CmmExpr -> Maybe CmmExpr
    forall a. a -> Maybe a
    Just (String -> CmmExpr
    mkGcLabel String
    "stg_gc_f1")
                                      Width
    W64       -> CmmExpr -> Maybe CmmExpr
    forall a. a -> Maybe a
    Just (String -> CmmExpr
    mkGcLabel String
    "stg_gc_d1")
                                      Width
    _         -> Maybe CmmExpr
    forall a. Maybe a
    Nothing

              | Width
    width Width -> Width -> Bool
    forall a. Eq a => a -> a -> Bool
    == Platform -> Width
    wordWidth Platform
    platform -> CmmExpr -> Maybe CmmExpr
    forall a. a -> Maybe a
    Just (String -> CmmExpr
    mkGcLabel String
    "stg_gc_unbx_r1")
              | Width
    width Width -> Width -> Bool
    forall a. Eq a => a -> a -> Bool
    == Width
    W64                -> CmmExpr -> Maybe CmmExpr
    forall a. a -> Maybe a
    Just (String -> CmmExpr
    mkGcLabel String
    "stg_gc_l1")
              | Bool
    otherwise                   -> Maybe CmmExpr
    forall a. Maybe a
    Nothing
              where
                  width :: Width
    width = CmmType -> Width
    typeWidth CmmType
    ty
          [CmmType
    ty1,CmmType
    ty2]
              |  CmmType -> Bool
    isGcPtrType CmmType
    ty1
              Bool -> Bool -> Bool
    && CmmType -> Bool
    isGcPtrType CmmType
    ty2 -> CmmExpr -> Maybe CmmExpr
    forall a. a -> Maybe a
    Just (String -> CmmExpr
    mkGcLabel String
    "stg_gc_pp")
          [CmmType
    ty1,CmmType
    ty2,CmmType
    ty3]
              |  CmmType -> Bool
    isGcPtrType CmmType
    ty1
              Bool -> Bool -> Bool
    && CmmType -> Bool
    isGcPtrType CmmType
    ty2
              Bool -> Bool -> Bool
    && CmmType -> Bool
    isGcPtrType CmmType
    ty3 -> CmmExpr -> Maybe CmmExpr
    forall a. a -> Maybe a
    Just (String -> CmmExpr
    mkGcLabel String
    "stg_gc_ppp")
          [CmmType
    ty1,CmmType
    ty2,CmmType
    ty3,CmmType
    ty4]
              |  CmmType -> Bool
    isGcPtrType CmmType
    ty1
              Bool -> Bool -> Bool
    && CmmType -> Bool
    isGcPtrType CmmType
    ty2
              Bool -> Bool -> Bool
    && CmmType -> Bool
    isGcPtrType CmmType
    ty3
              Bool -> Bool -> Bool
    && CmmType -> Bool
    isGcPtrType CmmType
    ty4 -> CmmExpr -> Maybe CmmExpr
    forall a. a -> Maybe a
    Just (String -> CmmExpr
    mkGcLabel String
    "stg_gc_pppp")
          [CmmType]
    _otherwise -> Maybe CmmExpr
    forall a. Maybe a
    Nothing

    -- Note [stg_gc arguments]
    -- ~~~~~~~~~~~~~~~~~~~~~~~
    -- It might seem that we could avoid passing the arguments to the
    -- stg_gc function, because they are already in the right registers.
    -- While this is usually the case, it isn't always.  Sometimes the
    -- code generator has cleverly avoided the eval in a case, e.g. in
    -- ffi/should_run/4221.hs we found
    --
    --   case a_r1mb of z
    --     FunPtr x y -> ...
    --
    -- where a_r1mb is bound a top-level constructor, and is known to be
    -- evaluated.  The codegen just assigns x, y and z, and continues;
    -- R1 is never assigned.
    --
    -- So we'll have to rely on optimisations to eliminatethese
    -- assignments where possible.

    -- | The generic GC procedure; no params, no results
    generic_gc :: CmmExpr
    generic_gc :: CmmExpr
    generic_gc = String -> CmmExpr
    mkGcLabel String
    "stg_gc_noregs"

    -- | Create a CLabel for calling a garbage collector entry point
    mkGcLabel :: String -> CmmExpr
    mkGcLabel :: String -> CmmExpr
    mkGcLabel String
    s = CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel (UnitId -> FastString -> CLabel
    mkCmmCodeLabel UnitId
    rtsUnitId (String -> FastString
    fsLit String
    s)))

    -------------------------------
    heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
    heapCheck :: forall a. Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
    heapCheck Bool
    checkStack Bool
    checkYield CmmAGraph
    do_gc FCode a
    code
      = (Int -> FCode a) -> FCode a
    forall a. (Int -> FCode a) -> FCode a
    getHeapUsage ((Int -> FCode a) -> FCode a) -> (Int -> FCode a) -> FCode a
    forall a b. (a -> b) -> a -> b
    $ \ Int
    hpHw ->
        -- Emit heap checks, but be sure to do it lazily so
        -- that the conditionals on hpHw don't cause a black hole
        do  { Platform
    platform <- FCode Platform
    getPlatform
            ; let mb_alloc_bytes :: Maybe CmmExpr
    mb_alloc_bytes
                     | Int
    hpHw Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    mBLOCK_SIZE = String -> Maybe CmmExpr
    forall a. String -> a
    sorry (String -> Maybe CmmExpr) -> String -> Maybe CmmExpr
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines
                        [String
    " Trying to allocate more than "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++Int -> String
    forall a. Show a => a -> String
    show Int
    mBLOCK_SIZEString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    " bytes.",
                         String
    "",
                         String
    "This is currently not possible due to a limitation of GHC's code generator.",
                         String
    "See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.",
                         String
    "Suggestion: read data from a file instead of having large static data",
                         String
    "structures in code."]
                     | Int
    hpHw Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0  = CmmExpr -> Maybe CmmExpr
    forall a. a -> Maybe a
    Just (Platform -> Int -> CmmExpr
    mkIntExpr Platform
    platform (Int
    hpHw Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * (Platform -> Int
    platformWordSizeInBytes Platform
    platform)))
                     | Bool
    otherwise = Maybe CmmExpr
    forall a. Maybe a
    Nothing
                     where
                      constants :: PlatformConstants
    constants = Platform -> PlatformConstants
    platformConstants Platform
    platform
                      bLOCK_SIZE_W :: Int
    bLOCK_SIZE_W = PlatformConstants -> Int
    pc_BLOCK_SIZE (Platform -> PlatformConstants
    platformConstants Platform
    platform) Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `quot` Platform -> Int
    platformWordSizeInBytes Platform
    platform
                      mBLOCK_SIZE :: Int
    mBLOCK_SIZE = PlatformConstants -> Int
    pc_BLOCKS_PER_MBLOCK PlatformConstants
    constants Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    bLOCK_SIZE_W
                  stk_hwm :: Maybe CmmExpr
    stk_hwm | Bool
    checkStack = CmmExpr -> Maybe CmmExpr
    forall a. a -> Maybe a
    Just (CmmLit -> CmmExpr
    CmmLit CmmLit
    CmmHighStackMark)
                          | Bool
    otherwise  = Maybe CmmExpr
    forall a. Maybe a
    Nothing
            ; FCode () -> FCode ()
    codeOnly (FCode () -> FCode ()) -> FCode () -> FCode ()
    forall a b. (a -> b) -> a -> b
    $ Maybe CmmExpr -> Bool -> Maybe CmmExpr -> CmmAGraph -> FCode ()
    do_checks Maybe CmmExpr
    stk_hwm Bool
    checkYield Maybe CmmExpr
    mb_alloc_bytes CmmAGraph
    do_gc
            ; Bool -> Int -> FCode ()
    tickyAllocHeap Bool
    True Int
    hpHw
            ; Int -> FCode ()
    setRealHp Int
    hpHw
            ; FCode a
    code }

    heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
    heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
    heapStackCheckGen Maybe CmmExpr
    stk_hwm Maybe CmmExpr
    mb_bytes
      = do Int
    updfr_sz <- FCode Int
    getUpdFrameOff
           BlockId
    lretry <- FCode BlockId
    forall (m :: * -> *). MonadUnique m => m BlockId
    newBlockId
           BlockId -> FCode ()
    emitLabel BlockId
    lretry
           CmmAGraph
    call <- CmmExpr
    -> (Convention, Convention)
    -> [LocalReg]
    -> [CmmExpr]
    -> Int
    -> [CmmExpr]
    -> FCode CmmAGraph
    mkCall CmmExpr
    generic_gc (Convention
    GC, Convention
    GC) [] [] Int
    updfr_sz []
           Maybe CmmExpr -> Bool -> Maybe CmmExpr -> CmmAGraph -> FCode ()
    do_checks Maybe CmmExpr
    stk_hwm Bool
    False Maybe CmmExpr
    mb_bytes (CmmAGraph
    call CmmAGraph -> CmmAGraph -> CmmAGraph
    <*> BlockId -> CmmAGraph
    mkBranch BlockId
    lretry)

    -- Note [Single stack check]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~
    -- When compiling a function we can determine how much stack space it
    -- will use. We therefore need to perform only a single stack check at
    -- the beginning of a function to see if we have enough stack space.
    --
    -- The check boils down to comparing Sp-N with SpLim, where N is the
    -- amount of stack space needed (see Note [Stack usage] below).  *BUT*
    -- at this stage of the pipeline we are not supposed to refer to Sp
    -- itself, because the stack is not yet manifest, so we don't quite
    -- know where Sp pointing.

    -- So instead of referring directly to Sp - as we used to do in the
    -- past - the code generator uses (old + 0) in the stack check. That
    -- is the address of the first word of the old area, so if we add N
    -- we'll get the address of highest used word.
    --
    -- This makes the check robust.  For example, while we need to perform
    -- only one stack check for each function, we could in theory place
    -- more stack checks later in the function. They would be redundant,
    -- but not incorrect (in a sense that they should not change program
    -- behaviour). We need to make sure however that a stack check
    -- inserted after incrementing the stack pointer checks for a
    -- respectively smaller stack space. This would not be the case if the
    -- code generator produced direct references to Sp. By referencing
    -- (old + 0) we make sure that we always check for a correct amount of
    -- stack: when converting (old + 0) to Sp the stack layout phase takes
    -- into account changes already made to stack pointer. The idea for
    -- this change came from observations made while debugging #8275.

    -- Note [Stack usage]
    -- ~~~~~~~~~~~~~~~~~~
    -- At the moment we convert from STG to Cmm we don't know N, the
    -- number of bytes of stack that the function will use, so we use a
    -- special late-bound CmmLit, namely
    --       CmmHighStackMark
    -- to stand for the number of bytes needed. When the stack is made
    -- manifest, the number of bytes needed is calculated, and used to
    -- replace occurrences of CmmHighStackMark
    --
    -- The (Maybe CmmExpr) passed to do_checks is usually
    --     Just (CmmLit CmmHighStackMark)
    -- but can also (in certain hand-written RTS functions)
    --     Just (CmmLit 8)  or some other fixed valuet
    -- If it is Nothing, we don't generate a stack check at all.

    do_checks :: Maybe CmmExpr    -- Should we check the stack?
                                  -- See Note [Stack usage]
              -> Bool             -- Should we check for preemption?
              -> Maybe CmmExpr    -- Heap headroom (bytes)
              -> CmmAGraph        -- What to do on failure
              -> FCode ()
    do_checks :: Maybe CmmExpr -> Bool -> Maybe CmmExpr -> CmmAGraph -> FCode ()
    do_checks Maybe CmmExpr
    mb_stk_hwm Bool
    checkYield Maybe CmmExpr
    mb_alloc_lit CmmAGraph
    do_gc = do
      Bool
    omit_yields <- StgToCmmConfig -> Bool
    stgToCmmOmitYields (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> FCode StgToCmmConfig
    getStgToCmmConfig
      Platform
    platform    <- FCode Platform
    getPlatform
      BlockId
    gc_id       <- FCode BlockId
    forall (m :: * -> *). MonadUnique m => m BlockId
    newBlockId

      let
        Just CmmExpr
    alloc_lit = Maybe CmmExpr
    mb_alloc_lit

        bump_hp :: CmmExpr
    bump_hp   = Platform -> CmmExpr -> CmmExpr -> CmmExpr
    cmmOffsetExprB Platform
    platform CmmExpr
    hpExpr CmmExpr
    alloc_lit

        -- Sp overflow if ((old + 0) - CmmHighStack < SpLim)
        -- At the beginning of a function old + 0 = Sp
        -- See Note [Single stack check]
        sp_oflo :: CmmExpr -> CmmExpr
    sp_oflo CmmExpr
    sp_hwm =
             MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Platform -> MachOp
    mo_wordULt Platform
    platform)
                      [MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Width -> MachOp
    MO_Sub (CmmType -> Width
    typeWidth (Platform -> CmmReg -> CmmType
    cmmRegType Platform
    platform CmmReg
    spReg)))
                                 [Area -> Int -> CmmExpr
    CmmStackSlot Area
    Old Int
    0, CmmExpr
    sp_hwm],
                       CmmReg -> CmmExpr
    CmmReg CmmReg
    spLimReg]

        -- Hp overflow if (Hp > HpLim)
        -- (Hp has been incremented by now)
        -- HpLim points to the LAST WORD of valid allocation space.
        hp_oflo :: CmmExpr
    hp_oflo = MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Platform -> MachOp
    mo_wordUGt Platform
    platform) [CmmExpr
    hpExpr, CmmExpr
    hpLimExpr]

        alloc_n :: CmmAGraph
    alloc_n = CmmReg -> CmmExpr -> CmmAGraph
    mkAssign CmmReg
    hpAllocReg CmmExpr
    alloc_lit

      case Maybe CmmExpr
    mb_stk_hwm of
        Maybe CmmExpr
    Nothing -> () -> FCode ()
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        Just CmmExpr
    stk_hwm -> FCode ()
    tickyStackCheck
          FCode () -> FCode () -> FCode ()
    forall a b. FCode a -> FCode b -> FCode b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> (CmmAGraph -> FCode ()
    emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph
    mkCmmIfGoto' (CmmExpr -> CmmExpr
    sp_oflo CmmExpr
    stk_hwm) BlockId
    gc_id (Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just Bool
    False) )

      -- Emit new label that might potentially be a header
      -- of a self-recursive tail call.
      -- See Note [Self-recursive loop header].
      Maybe SelfLoopInfo
    self_loop_info <- FCode (Maybe SelfLoopInfo)
    getSelfLoop
      case Maybe SelfLoopInfo
    self_loop_info of
        Just (Id
    _, BlockId
    loop_header_id, [LocalReg]
    _)
            | Bool
    checkYield Bool -> Bool -> Bool
    && Maybe CmmExpr -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe CmmExpr
    mb_stk_hwm -> BlockId -> FCode ()
    emitLabel BlockId
    loop_header_id
        Maybe SelfLoopInfo
    _otherwise -> () -> FCode ()
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

      if Maybe CmmExpr -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe CmmExpr
    mb_alloc_lit
        then do
         FCode ()
    tickyHeapCheck
         CmmReg -> CmmExpr -> FCode ()
    emitAssign CmmReg
    hpReg CmmExpr
    bump_hp
         CmmAGraph -> FCode ()
    emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
    mkCmmIfThen' CmmExpr
    hp_oflo (CmmAGraph
    alloc_n CmmAGraph -> CmmAGraph -> CmmAGraph
    <*> BlockId -> CmmAGraph
    mkBranch BlockId
    gc_id) (Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just Bool
    False)
        else
          Bool -> FCode () -> FCode ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Bool
    checkYield Bool -> Bool -> Bool
    && Bool -> Bool
    not Bool
    omit_yields) (FCode () -> FCode ()) -> FCode () -> FCode ()
    forall a b. (a -> b) -> a -> b
    $ do
             -- Yielding if HpLim == 0
             let yielding :: CmmExpr
    yielding = MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Platform -> MachOp
    mo_wordEq Platform
    platform)
                                      [CmmReg -> CmmExpr
    CmmReg CmmReg
    hpLimReg,
                                       CmmLit -> CmmExpr
    CmmLit (Platform -> CmmLit
    zeroCLit Platform
    platform)]
             CmmAGraph -> FCode ()
    emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph
    mkCmmIfGoto' CmmExpr
    yielding BlockId
    gc_id (Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just Bool
    False)

      CmmTickScope
    tscope <- FCode CmmTickScope
    getTickScope
      BlockId -> CmmAGraphScoped -> FCode ()
    emitOutOfLine BlockId
    gc_id
       (CmmAGraph
    do_gc, CmmTickScope
    tscope) -- this is expected to jump back somewhere

                    -- Test for stack pointer exhaustion, then
                    -- bump heap pointer, and test for heap exhaustion
                    -- Note that we don't move the heap pointer unless the
                    -- stack check succeeds.  Otherwise we might end up
                    -- with slop at the end of the current block, which can
                    -- confuse the LDV profiler.

    -- Note [Self-recursive loop header]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- Self-recursive loop header is required by loopification optimization (See
    -- Note [Self-recursive tail calls] in GHC.StgToCmm.Expr). We emit it if:
    --
    --  1. There is information about self-loop in the FCode environment. We don't
    --     check the binder (first component of the self_loop_info) because we are
    --     certain that if the self-loop info is present then we are compiling the
    --     binder body. Reason: the only possible way to get here with the
    --     self_loop_info present is from closureCodeBody.
    --
    --  2. checkYield && isJust mb_stk_hwm. checkYield tells us that it is possible
    --     to preempt the heap check (see #367 for motivation behind this check). It
    --     is True for heap checks placed at the entry to a function and
    --     let-no-escape heap checks but false for other heap checks (eg. in case
    --     alternatives or created from hand-written high-level Cmm). The second
    --     check (isJust mb_stk_hwm) is true for heap checks at the entry to a
    --     function and some heap checks created in hand-written Cmm. Otherwise it
    --     is Nothing. In other words the only situation when both conditions are
    --     true is when compiling stack and heap checks at the entry to a
    --     function. This is the only situation when we want to emit a self-loop
    --     label.