    -----------------------------------------------------------------------------
    --
    -- Code generator utilities; mostly monadic
    --
    -- (c) The University of Glasgow 2004-2006
    --
    -----------------------------------------------------------------------------
    {-# LANGUAGE RecordWildCards #-}
    {-# LANGUAGE TupleSections #-}

    module GHC.StgToCmm.Utils (
            emitDataLits, emitRODataLits,
            emitDataCon,
            emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
            emitBarf,
            assignTemp, newTemp,

            newUnboxedTupleRegs,

            emitMultiAssign, emitCmmLitSwitch, emitSwitch,

            tagToClosure, mkTaggedObjectLoad,

            callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
            callerSaveGlobalReg, callerRestoreGlobalReg,

            cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
            cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
            cmmOffsetExprW, cmmOffsetExprB,
            cmmRegOffW, cmmRegOffB,
            cmmLabelOffW, cmmLabelOffB,
            cmmOffsetW, cmmOffsetB,
            cmmOffsetLitW, cmmOffsetLitB,
            cmmLoadIndexW,
            cmmConstrTag1,

            cmmUntag, cmmIsTagged,

            addToMem, addToMemE, addToMemLblE, addToMemLbl,
            emitAtomicRead, emitAtomicWrite,

            -- * Update remembered set operations
            whenUpdRemSetEnabled,
            emitUpdRemSetPush,
            emitUpdRemSetPushThunk,

            convertInfoProvMap, cmmInfoTableToInfoProvEnt, IPEStats(..),
            closureIpeStats, fallbackIpeStats, skippedIpeStats,
      ) where

    import GHC.Prelude hiding ( head, init, last, tail )

    import GHC.Platform
    import GHC.StgToCmm.Monad
    import GHC.StgToCmm.Closure
    import GHC.StgToCmm.Lit (mkSimpleLit, newStringCLit)
    import GHC.Cmm
    import GHC.Cmm.BlockId
    import GHC.Cmm.Graph as CmmGraph
    import GHC.Platform.Regs
    import GHC.Cmm.CLabel
    import GHC.Cmm.Utils
    import GHC.Cmm.Switch
    import {-# SOURCE #-} GHC.StgToCmm.Foreign (emitPrimCall)
    import GHC.StgToCmm.CgUtils

    import GHC.Types.ForeignCall
    import GHC.Types.Id.Info
    import GHC.Core.Type
    import GHC.Core.TyCon
    import GHC.Runtime.Heap.Layout
    import GHC.Unit
    import GHC.Types.Literal
    import GHC.Data.Graph.Directed
    import GHC.Utils.Misc
    import GHC.Types.Unique
    import GHC.Data.FastString
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Types.RepType
    import GHC.Types.CostCentre
    import GHC.Types.IPE

    import qualified Data.Map as M
    import Data.List (sortBy)
    import Data.Ord
    import GHC.Types.Unique.Map
    import Data.Maybe
    import qualified Data.List.NonEmpty as NE
    import GHC.Core.DataCon
    import GHC.Types.Unique.FM
    import GHC.Data.Maybe
    import Control.Monad
    import qualified Data.Map.Strict as Map
    import qualified Data.IntMap.Strict as I
    import qualified Data.Semigroup (Semigroup(..))

    --------------------------------------------------------------------------
    --
    -- Incrementing a memory location
    --
    --------------------------------------------------------------------------

    addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
    addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
    addToMemLbl CmmType
    rep CLabel
    lbl = CmmType -> CmmExpr -> Int -> CmmAGraph
    addToMem CmmType
    rep (CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel CLabel
    lbl))

    addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
    addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
    addToMemLblE CmmType
    rep CLabel
    lbl = CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
    addToMemE CmmType
    rep (CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel CLabel
    lbl))

    -- | @addToMem rep ptr n@ adds @n@ to the integer pointed-to by @ptr@.
    addToMem :: CmmType     -- rep of the counter
             -> CmmExpr     -- Naturally-aligned address
             -> Int         -- What to add (a word)
             -> CmmAGraph
    addToMem :: CmmType -> CmmExpr -> Int -> CmmAGraph
    addToMem CmmType
    rep CmmExpr
    ptr Int
    n = CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
    addToMemE CmmType
    rep CmmExpr
    ptr (CmmLit -> CmmExpr
    CmmLit (Integer -> Width -> CmmLit
    CmmInt (Int -> Integer
    forall a. Integral a => a -> Integer
    toInteger Int
    n) (CmmType -> Width
    typeWidth CmmType
    rep)))

    -- | @addToMemE rep ptr n@ adds @n@ to the integer pointed-to by @ptr@.
    addToMemE :: CmmType    -- rep of the counter
              -> CmmExpr    -- Naturally-aligned address
              -> CmmExpr    -- What to add (a word-typed expression)
              -> CmmAGraph
    addToMemE :: CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
    addToMemE CmmType
    rep CmmExpr
    ptr CmmExpr
    n
      = CmmExpr -> CmmExpr -> CmmAGraph
    mkStore CmmExpr
    ptr (MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Width -> MachOp
    MO_Add (CmmType -> Width
    typeWidth CmmType
    rep)) [CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
    CmmLoad CmmExpr
    ptr CmmType
    rep AlignmentSpec
    NaturallyAligned, CmmExpr
    n])

    -------------------------------------------------------------------------
    --      Atomic loads and stores
    -------------------------------------------------------------------------

    emitAtomicRead
      :: MemoryOrdering
      -> LocalReg -- ^ result register
      -> CmmExpr  -- ^ address
      -> FCode ()
    emitAtomicRead :: MemoryOrdering -> LocalReg -> CmmExpr -> FCode ()
    emitAtomicRead MemoryOrdering
    mord LocalReg
    res CmmExpr
    addr
      = FCode () -> FCode ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (FCode () -> FCode ()) -> FCode () -> FCode ()
    forall a b. (a -> b) -> a -> b
    $ [LocalReg] -> CallishMachOp -> [CmmExpr] -> FCode ()
    emitPrimCall [LocalReg
    res] (Width -> MemoryOrdering -> CallishMachOp
    MO_AtomicRead Width
    w MemoryOrdering
    mord) [CmmExpr
    addr]
      where
        w :: Width
    w = CmmType -> Width
    typeWidth (CmmType -> Width) -> CmmType -> Width
    forall a b. (a -> b) -> a -> b
    $ LocalReg -> CmmType
    localRegType LocalReg
    res

    emitAtomicWrite
      :: MemoryOrdering
      -> CmmExpr  -- ^ address
      -> CmmExpr  -- ^ value
      -> FCode ()
    emitAtomicWrite :: MemoryOrdering -> CmmExpr -> CmmExpr -> FCode ()
    emitAtomicWrite MemoryOrdering
    mord CmmExpr
    addr CmmExpr
    val
      = do platform <- FCode Platform
    getPlatform
           let w = CmmType -> Width
    typeWidth (CmmType -> Width) -> CmmType -> Width
    forall a b. (a -> b) -> a -> b
    $ Platform -> CmmExpr -> CmmType
    cmmExprType Platform
    platform CmmExpr
    val
           void $ emitPrimCall [] (MO_AtomicWrite w mord) [addr, val]

    -------------------------------------------------------------------------
    --
    --      Loading a field from an object,
    --      where the object pointer is itself tagged
    --
    -------------------------------------------------------------------------

    mkTaggedObjectLoad
      :: Platform -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
    -- (loadTaggedObjectField reg base off tag) generates assignment
    --      reg = bitsK[ base + off - tag ]
    -- where K is fixed by 'reg'
    mkTaggedObjectLoad :: Platform -> LocalReg -> LocalReg -> Int -> Int -> CmmAGraph
    mkTaggedObjectLoad Platform
    platform LocalReg
    reg LocalReg
    base Int
    offset Int
    tag
      = CmmReg -> CmmExpr -> CmmAGraph
    mkAssign (LocalReg -> CmmReg
    CmmLocal LocalReg
    reg)
                 (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
    CmmLoad (Platform -> CmmExpr -> Int -> CmmExpr
    cmmOffsetB Platform
    platform
                                      (CmmReg -> CmmExpr
    CmmReg (LocalReg -> CmmReg
    CmmLocal LocalReg
    base))
                                      (Int
    offset Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    tag))
                          (LocalReg -> CmmType
    localRegType LocalReg
    reg)
                          AlignmentSpec
    NaturallyAligned)

    -------------------------------------------------------------------------
    --
    --      Converting a closure tag to a closure for enumeration types
    --      (this is the implementation of tagToEnum#).
    --
    -------------------------------------------------------------------------

    tagToClosure :: Platform -> TyCon -> CmmExpr -> CmmExpr
    tagToClosure :: Platform -> TyCon -> CmmExpr -> CmmExpr
    tagToClosure Platform
    platform TyCon
    tycon CmmExpr
    tag
      = Platform -> CmmExpr -> CmmExpr
    cmmLoadBWord Platform
    platform (Platform -> CmmExpr -> CmmExpr -> CmmExpr
    cmmOffsetExprW Platform
    platform CmmExpr
    closure_tbl CmmExpr
    tag)
      where closure_tbl :: CmmExpr
    closure_tbl = CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel CLabel
    lbl)
            lbl :: CLabel
    lbl = Name -> CafInfo -> CLabel
    mkClosureTableLabel (TyCon -> Name
    tyConName TyCon
    tycon) CafInfo
    NoCafRefs

    -------------------------------------------------------------------------
    --
    --      Conditionals and rts calls
    --
    -------------------------------------------------------------------------

    emitBarf :: String -> FCode ()
    emitBarf :: String -> FCode ()
    emitBarf String
    msg = do
      strLbl <- String -> FCode CmmLit
    newStringCLit String
    msg
      emitRtsCall rtsUnitId (fsLit "barf") [(CmmLit strLbl,AddrHint)] False

    emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
    emitRtsCall :: UnitId
    -> FastString -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
    emitRtsCall UnitId
    pkg FastString
    fun = [(LocalReg, ForeignHint)]
    -> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
    emitRtsCallGen [] (UnitId -> FastString -> CLabel
    mkCmmCodeLabel UnitId
    pkg FastString
    fun)

    emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
            -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
    emitRtsCallWithResult :: LocalReg
    -> ForeignHint
    -> UnitId
    -> FastString
    -> [(CmmExpr, ForeignHint)]
    -> Bool
    -> FCode ()
    emitRtsCallWithResult LocalReg
    res ForeignHint
    hint UnitId
    pkg = [(LocalReg, ForeignHint)]
    -> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
    emitRtsCallGen [(LocalReg
    res,ForeignHint
    hint)] (CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ())
    -> (FastString -> CLabel)
    -> FastString
    -> [(CmmExpr, ForeignHint)]
    -> Bool
    -> FCode ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . UnitId -> FastString -> CLabel
    mkCmmCodeLabel UnitId
    pkg

    -- Make a call to an RTS C procedure
    emitRtsCallGen
       :: [(LocalReg,ForeignHint)]
       -> CLabel
       -> [(CmmExpr,ForeignHint)]
       -> Bool -- True <=> CmmSafe call
       -> FCode ()
    emitRtsCallGen :: [(LocalReg, ForeignHint)]
    -> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
    emitRtsCallGen [(LocalReg, ForeignHint)]
    res CLabel
    lbl [(CmmExpr, ForeignHint)]
    args Bool
    safe
      = do { platform <- FCode Platform
    getPlatform
           ; updfr_off <- getUpdFrameOff
           ; let (caller_save, caller_load) = callerSaveVolatileRegs platform
           ; emit caller_save
           ; call updfr_off
           ; emit caller_load }
      where
        call :: Int -> FCode ()
    call Int
    updfr_off =
          if Bool
    safe then
            CmmAGraph -> FCode ()
    emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< CmmExpr -> [LocalReg] -> [CmmExpr] -> Int -> FCode CmmAGraph
    mkCmmCall CmmExpr
    fun_expr [LocalReg]
    res' [CmmExpr]
    args' Int
    updfr_off
          else do
            let conv :: ForeignConvention
    conv = CCallConv
    -> [ForeignHint]
    -> [ForeignHint]
    -> CmmReturnInfo
    -> ForeignConvention
    ForeignConvention CCallConv
    CCallConv [ForeignHint]
    arg_hints [ForeignHint]
    res_hints CmmReturnInfo
    CmmMayReturn
            CmmAGraph -> FCode ()
    emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
    forall a b. (a -> b) -> a -> b
    $ ForeignTarget -> [LocalReg] -> [CmmExpr] -> CmmAGraph
    mkUnsafeCall (CmmExpr -> ForeignConvention -> ForeignTarget
    ForeignTarget CmmExpr
    fun_expr ForeignConvention
    conv) [LocalReg]
    res' [CmmExpr]
    args'
        ([CmmExpr]
    args', [ForeignHint]
    arg_hints) = [(CmmExpr, ForeignHint)] -> ([CmmExpr], [ForeignHint])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(CmmExpr, ForeignHint)]
    args
        ([LocalReg]
    res',  [ForeignHint]
    res_hints) = [(LocalReg, ForeignHint)] -> ([LocalReg], [ForeignHint])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(LocalReg, ForeignHint)]
    res
        fun_expr :: CmmExpr
    fun_expr = CLabel -> CmmExpr
    mkLblExpr CLabel
    lbl

    -----------------------------------------------------------------------------
    --
    --      Caller-Save Registers
    --
    -----------------------------------------------------------------------------

    -- Here we generate the sequence of saves/restores required around a
    -- foreign call instruction.

    -- TODO: reconcile with rts/include/Regs.h
    --  * Regs.h claims that BaseReg should be saved last and loaded first
    --    * This might not have been tickled before since BaseReg is callee save
    --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
    --
    -- This code isn't actually used right now, because callerSaves
    -- only ever returns true in the current universe for registers NOT in
    -- system_regs (just do a grep for CALLER_SAVES in
    -- rts/include/stg/MachRegs.h).  It's all one giant no-op, and for
    -- good reason: having to save system registers on every foreign call
    -- would be very expensive, so we avoid assigning them to those
    -- registers when we add support for an architecture.
    --
    -- Note that the old code generator actually does more work here: it
    -- also saves other global registers.  We can't (nor want) to do that
    -- here, as we don't have liveness information.  And really, we
    -- shouldn't be doing the workaround at this point in the pipeline, see
    -- Note [Register parameter passing] and the ToDo on CmmCall in
    -- "GHC.Cmm.Node".  Right now the workaround is to avoid inlining across
    -- unsafe foreign calls in GHC.Cmm.Sink, but this is strictly
    -- temporary.
    callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph)
    callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph)
    callerSaveVolatileRegs Platform
    platform = (CmmAGraph
    caller_save, CmmAGraph
    caller_load)
      where
        caller_save :: CmmAGraph
    caller_save = [CmmAGraph] -> CmmAGraph
    catAGraphs ((GlobalReg -> CmmAGraph) -> [GlobalReg] -> [CmmAGraph]
    forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> GlobalReg -> CmmAGraph
    callerSaveGlobalReg    Platform
    platform) [GlobalReg]
    regs_to_save)
        caller_load :: CmmAGraph
    caller_load = [CmmAGraph] -> CmmAGraph
    catAGraphs ((GlobalReg -> CmmAGraph) -> [GlobalReg] -> [CmmAGraph]
    forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> GlobalReg -> CmmAGraph
    callerRestoreGlobalReg Platform
    platform) [GlobalReg]
    regs_to_save)

        system_regs :: [GlobalReg]
    system_regs = [ GlobalReg
    Sp,GlobalReg
    SpLim,GlobalReg
    Hp,GlobalReg
    HpLim,GlobalReg
    CCCS,GlobalReg
    CurrentTSO,GlobalReg
    CurrentNursery
                        {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
                      , GlobalReg
    BaseReg ]

        regs_to_save :: [GlobalReg]
    regs_to_save = (GlobalReg -> Bool) -> [GlobalReg] -> [GlobalReg]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Platform -> GlobalReg -> Bool
    callerSaves Platform
    platform) [GlobalReg]
    system_regs

    callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph
    callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph
    callerSaveGlobalReg Platform
    platform GlobalReg
    reg
        = CmmExpr -> CmmExpr -> CmmAGraph
    mkStore (Platform -> GlobalReg -> CmmExpr
    get_GlobalReg_addr Platform
    platform GlobalReg
    reg) (CmmReg -> CmmExpr
    CmmReg (GlobalRegUse -> CmmReg
    CmmGlobal (GlobalReg -> CmmType -> GlobalRegUse
    GlobalRegUse GlobalReg
    reg CmmType
    spill_ty)))
        where
          spill_ty :: CmmType
    spill_ty = Platform -> GlobalReg -> CmmType
    globalRegSpillType Platform
    platform GlobalReg
    reg

    callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph
    callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph
    callerRestoreGlobalReg Platform
    platform GlobalReg
    reg
        = CmmReg -> CmmExpr -> CmmAGraph
    mkAssign (GlobalRegUse -> CmmReg
    CmmGlobal (GlobalReg -> CmmType -> GlobalRegUse
    GlobalRegUse GlobalReg
    reg CmmType
    spill_ty))
                   (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
    CmmLoad (Platform -> GlobalReg -> CmmExpr
    get_GlobalReg_addr Platform
    platform GlobalReg
    reg)
                            CmmType
    spill_ty AlignmentSpec
    NaturallyAligned)
        where
          spill_ty :: CmmType
    spill_ty = Platform -> GlobalReg -> CmmType
    globalRegSpillType Platform
    platform GlobalReg
    reg

    -------------------------------------------------------------------------
    --
    --      Strings generate a top-level data block
    --
    -------------------------------------------------------------------------

    -- | Emit a data-segment data block
    emitDataLits :: CLabel -> [CmmLit] -> FCode ()
    emitDataLits :: CLabel -> [CmmLit] -> FCode ()
    emitDataLits CLabel
    lbl [CmmLit]
    lits = CmmDecl -> FCode ()
    emitDecl (Section -> CLabel -> [CmmLit] -> CmmDecl
    forall (raw :: Bool) info stmt.
    Section
    -> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
    mkDataLits (SectionType -> CLabel -> Section
    Section SectionType
    Data CLabel
    lbl) CLabel
    lbl [CmmLit]
    lits)

    -- | Emit a read-only data block
    emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
    emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
    emitRODataLits CLabel
    lbl [CmmLit]
    lits = CmmDecl -> FCode ()
    emitDecl (CLabel -> [CmmLit] -> CmmDecl
    forall (raw :: Bool) info stmt.
    CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
    mkRODataLits CLabel
    lbl [CmmLit]
    lits)

    emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
    emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
    emitDataCon CLabel
    lbl CmmInfoTable
    itbl CostCentreStack
    ccs [CmmLit]
    payload =
      CmmDecl -> FCode ()
    emitDecl (Section -> CmmStatics -> CmmDecl
    forall d h g. Section -> d -> GenCmmDecl d h g
    CmmData (SectionType -> CLabel -> Section
    Section SectionType
    Data CLabel
    lbl) (CLabel
    -> CmmInfoTable
    -> CostCentreStack
    -> [CmmLit]
    -> [CmmLit]
    -> CmmStatics
    CmmStatics CLabel
    lbl CmmInfoTable
    itbl CostCentreStack
    ccs [CmmLit]
    payload []))

    -------------------------------------------------------------------------
    --
    --      Assigning expressions to temporaries
    --
    -------------------------------------------------------------------------

    assignTemp :: CmmExpr -> FCode LocalReg
    -- Make sure the argument is in a local register.
    -- We don't bother being particularly aggressive with avoiding
    -- unnecessary local registers, since we can rely on a later
    -- optimization pass to inline as necessary (and skipping out
    -- on things like global registers can be a little dangerous
    -- due to them being trashed on foreign calls--though it means
    -- the optimization pass doesn't have to do as much work)
    assignTemp :: CmmExpr -> FCode LocalReg
    assignTemp (CmmReg (CmmLocal LocalReg
    reg)) = LocalReg -> FCode LocalReg
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return LocalReg
    reg
    assignTemp CmmExpr
    e = do { platform <- FCode Platform
    getPlatform
                      ; reg <- newTemp (cmmExprType platform e)
                      ; emitAssign (CmmLocal reg) e
                      ; return reg }

    newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
    -- Choose suitable local regs to use for the components
    -- of an unboxed tuple that we are about to return to
    -- the Sequel.  If the Sequel is a join point, using the
    -- regs it wants will save later assignments.
    newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
    newUnboxedTupleRegs Type
    res_ty
      = Bool
    -> FCode ([LocalReg], [ForeignHint])
    -> FCode ([LocalReg], [ForeignHint])
    forall a. HasCallStack => Bool -> a -> a
    assert (Type -> Bool
    isUnboxedTupleType Type
    res_ty) (FCode ([LocalReg], [ForeignHint])
     -> FCode ([LocalReg], [ForeignHint]))
    -> FCode ([LocalReg], [ForeignHint])
    -> FCode ([LocalReg], [ForeignHint])
    forall a b. (a -> b) -> a -> b
    $
        do  { platform <- FCode Platform
    getPlatform
            ; sequel <- getSequel
            ; regs <- choose_regs platform sequel
            ; massert (regs `equalLength` reps)
            ; return (regs, map primRepForeignHint reps) }
      where
        reps :: [PrimRep]
    reps = HasDebugCallStack => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRep Type
    res_ty
        choose_regs :: Platform -> Sequel -> FCode [LocalReg]
    choose_regs Platform
    _ (AssignTo [LocalReg]
    regs Bool
    _) = [LocalReg] -> FCode [LocalReg]
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [LocalReg]
    regs
        choose_regs Platform
    platform Sequel
    _          = (PrimRep -> FCode LocalReg) -> [PrimRep] -> FCode [LocalReg]
    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 (CmmType -> FCode LocalReg
    forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (CmmType -> FCode LocalReg)
    -> (PrimRep -> CmmType) -> PrimRep -> FCode LocalReg
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> PrimRep -> CmmType
    primRepCmmType Platform
    platform) [PrimRep]
    reps

    -------------------------------------------------------------------------
    --      emitMultiAssign
    -------------------------------------------------------------------------

    emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
    -- Emit code to perform the assignments in the
    -- input simultaneously, using temporary variables when necessary.

    type Key  = Int
    type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
                            -- for fast comparison
    type Stmt = (LocalReg, CmmExpr) -- r := e

    -- We use the strongly-connected component algorithm, in which
    --      * the vertices are the statements
    --      * an edge goes from s1 to s2 iff
    --              s1 assigns to something s2 uses
    --        that is, if s1 should *follow* s2 in the final order

    emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
    emitMultiAssign []    []    = () -> FCode ()
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    emitMultiAssign [LocalReg
    reg] [CmmExpr
    rhs] = CmmReg -> CmmExpr -> FCode ()
    emitAssign (LocalReg -> CmmReg
    CmmLocal LocalReg
    reg) CmmExpr
    rhs
    emitMultiAssign [LocalReg]
    regs [CmmExpr]
    rhss   = do
      platform <- FCode Platform
    getPlatform
      assertPpr (equalLength regs rhss) (ppr regs $$ pdoc platform rhss) $
        unscramble platform ([1..] `zip` (regs `zip` rhss))

    unscramble :: Platform -> [Vrtx] -> FCode ()
    unscramble :: Platform -> [Vrtx] -> FCode ()
    unscramble Platform
    platform [Vrtx]
    vertices = (SCC Vrtx -> FCode ()) -> [SCC Vrtx] -> FCode ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ SCC Vrtx -> FCode ()
    do_component [SCC Vrtx]
    components
      where
            edges :: [ Node Key Vrtx ]
            edges :: [Node Int Vrtx]
    edges = [ Vrtx -> Int -> [Int] -> Node Int Vrtx
    forall key payload. payload -> key -> [key] -> Node key payload
    DigraphNode Vrtx
    vertex Int
    key1 (Stmt -> [Int]
    edges_from Stmt
    stmt1)
                    | vertex :: Vrtx
    vertex@(Int
    key1, Stmt
    stmt1) <- [Vrtx]
    vertices ]

            edges_from :: Stmt -> [Key]
            edges_from :: Stmt -> [Int]
    edges_from Stmt
    stmt1 = [ Int
    key2 | (Int
    key2, Stmt
    stmt2) <- [Vrtx]
    vertices,
                                        Stmt
    stmt1 Stmt -> Stmt -> Bool
    `mustFollow` Stmt
    stmt2 ]

            components :: [SCC Vrtx]
            components :: [SCC Vrtx]
    components = [Node Int Vrtx] -> [SCC Vrtx]
    forall key payload.
    Uniquable key =>
    [Node key payload] -> [SCC payload]
    stronglyConnCompFromEdgedVerticesUniq [Node Int Vrtx]
    edges

            -- do_components deal with one strongly-connected component
            -- Not cyclic, or singleton?  Just do it
            do_component :: SCC Vrtx -> FCode ()
            do_component :: SCC Vrtx -> FCode ()
    do_component (AcyclicSCC (Int
    _,Stmt
    stmt))  = Stmt -> FCode ()
    mk_graph Stmt
    stmt
            do_component (CyclicSCC [])         = String -> FCode ()
    forall a. HasCallStack => String -> a
    panic String
    "do_component"
            do_component (CyclicSCC [(Int
    _,Stmt
    stmt)]) = Stmt -> FCode ()
    mk_graph Stmt
    stmt

                    -- Cyclic?  Then go via temporaries.  Pick one to
                    -- break the loop and try again with the rest.
            do_component (CyclicSCC ((Int
    _,Stmt
    first_stmt) : [Vrtx]
    rest)) = do
                u <- FCode Unique
    newUnique
                let (to_tmp, from_tmp) = split u first_stmt
                mk_graph to_tmp
                unscramble platform rest
                mk_graph from_tmp

            split :: Unique -> Stmt -> (Stmt, Stmt)
            split :: Unique -> Stmt -> (Stmt, Stmt)
    split Unique
    uniq (LocalReg
    reg, CmmExpr
    rhs)
              = ((LocalReg
    tmp, CmmExpr
    rhs), (LocalReg
    reg, CmmReg -> CmmExpr
    CmmReg (LocalReg -> CmmReg
    CmmLocal LocalReg
    tmp)))
              where
                rep :: CmmType
    rep = Platform -> CmmExpr -> CmmType
    cmmExprType Platform
    platform CmmExpr
    rhs
                tmp :: LocalReg
    tmp = Unique -> CmmType -> LocalReg
    LocalReg Unique
    uniq CmmType
    rep

            mk_graph :: Stmt -> FCode ()
            mk_graph :: Stmt -> FCode ()
    mk_graph (LocalReg
    reg, CmmExpr
    rhs) = CmmReg -> CmmExpr -> FCode ()
    emitAssign (LocalReg -> CmmReg
    CmmLocal LocalReg
    reg) CmmExpr
    rhs

            mustFollow :: Stmt -> Stmt -> Bool
            (LocalReg
    reg, CmmExpr
    _) mustFollow :: Stmt -> Stmt -> Bool
    `mustFollow` (LocalReg
    _, CmmExpr
    rhs) = Platform -> CmmReg -> CmmExpr -> Bool
    regUsedIn Platform
    platform (LocalReg -> CmmReg
    CmmLocal LocalReg
    reg) CmmExpr
    rhs

    -------------------------------------------------------------------------
    --      mkSwitch
    -------------------------------------------------------------------------

    emitSwitch :: CmmExpr                      -- Tag to switch on
               -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
               -> Maybe CmmAGraphScoped        -- Default branch (if any)
               -> ConTagZ -> ConTagZ           -- Min and Max possible values;
                                               -- behaviour outside this range is
                                               -- undefined
               -> FCode ()

    -- First, two rather common cases in which there is no work to do
    emitSwitch :: CmmExpr
    -> [(Int, CmmAGraphScoped)]
    -> Maybe CmmAGraphScoped
    -> Int
    -> Int
    -> FCode ()
    emitSwitch CmmExpr
    _ []         (Just CmmAGraphScoped
    code) Int
    _ Int
    _ = CmmAGraph -> FCode ()
    emit (CmmAGraphScoped -> CmmAGraph
    forall a b. (a, b) -> a
    fst CmmAGraphScoped
    code)
    emitSwitch CmmExpr
    _ [(Int
    _,CmmAGraphScoped
    code)] Maybe CmmAGraphScoped
    Nothing     Int
    _ Int
    _ = CmmAGraph -> FCode ()
    emit (CmmAGraphScoped -> CmmAGraph
    forall a b. (a, b) -> a
    fst CmmAGraphScoped
    code)

    -- Right, off we go
    emitSwitch CmmExpr
    tag_expr [(Int, CmmAGraphScoped)]
    branches Maybe CmmAGraphScoped
    mb_deflt Int
    lo_tag Int
    hi_tag = do
        join_lbl      <- FCode BlockId
    forall (m :: * -> *). MonadUnique m => m BlockId
    newBlockId
        mb_deflt_lbl  <- label_default join_lbl mb_deflt
        branches_lbls <- label_branches join_lbl branches
        tag_expr'     <- assignTemp' tag_expr

        -- Sort the branches before calling mk_discrete_switch
        let branches_lbls' = [ (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    i, BlockId
    l) | (Int
    i,BlockId
    l) <- ((Int, BlockId) -> (Int, BlockId) -> Ordering)
    -> [(Int, BlockId)] -> [(Int, BlockId)]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (((Int, BlockId) -> Int)
    -> (Int, BlockId) -> (Int, BlockId) -> Ordering
    forall a b. Ord a => (b -> a) -> b -> b -> Ordering
    comparing (Int, BlockId) -> Int
    forall a b. (a, b) -> a
    fst) [(Int, BlockId)]
    branches_lbls ]
        let range = (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    lo_tag, Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    hi_tag)

        emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range

        emitLabel join_lbl

    mk_discrete_switch :: Bool -- ^ Use signed comparisons
              -> CmmExpr
              -> [(Integer, BlockId)]
              -> Maybe BlockId
              -> (Integer, Integer)
              -> CmmAGraph

    -- SINGLETON TAG RANGE: no case analysis to do
    mk_discrete_switch :: Bool
    -> CmmExpr
    -> [(Integer, BlockId)]
    -> Maybe BlockId
    -> (Integer, Integer)
    -> CmmAGraph
    mk_discrete_switch Bool
    _ CmmExpr
    _tag_expr [(Integer
    tag, BlockId
    lbl)] Maybe BlockId
    _ (Integer
    lo_tag, Integer
    hi_tag)
      | Integer
    lo_tag Integer -> Integer -> Bool
    forall a. Eq a => a -> a -> Bool
    == Integer
    hi_tag
      = Bool -> CmmAGraph -> CmmAGraph
    forall a. HasCallStack => Bool -> a -> a
    assert (Integer
    tag Integer -> Integer -> Bool
    forall a. Eq a => a -> a -> Bool
    == Integer
    lo_tag) (CmmAGraph -> CmmAGraph) -> CmmAGraph -> CmmAGraph
    forall a b. (a -> b) -> a -> b
    $
        BlockId -> CmmAGraph
    mkBranch BlockId
    lbl

    -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
    mk_discrete_switch Bool
    _ CmmExpr
    _tag_expr [(Integer
    _tag,BlockId
    lbl)] Maybe BlockId
    Nothing (Integer, Integer)
    _
      = BlockId -> CmmAGraph
    mkBranch BlockId
    lbl
            -- The simplifier might have eliminated a case
            --       so we may have e.g. case xs of
            --                               [] -> e
            -- In that situation we can be sure the (:) case
            -- can't happen, so no need to test

    -- SOMETHING MORE COMPLICATED: defer to GHC.Cmm.Switch.Implement
    -- See Note [Cmm Switches, the general plan] in GHC.Cmm.Switch
    mk_discrete_switch Bool
    signed CmmExpr
    tag_expr [(Integer, BlockId)]
    branches Maybe BlockId
    mb_deflt (Integer, Integer)
    range
      = CmmExpr -> SwitchTargets -> CmmAGraph
    mkSwitch CmmExpr
    tag_expr (SwitchTargets -> CmmAGraph) -> SwitchTargets -> CmmAGraph
    forall a b. (a -> b) -> a -> b
    $ Bool
    -> (Integer, Integer)
    -> Maybe BlockId
    -> Map Integer BlockId
    -> SwitchTargets
    mkSwitchTargets Bool
    signed (Integer, Integer)
    range Maybe BlockId
    mb_deflt ([(Integer, BlockId)] -> Map Integer BlockId
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList [(Integer, BlockId)]
    branches)

    divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])
    divideBranches :: forall a b. Ord a => [(a, b)] -> ([(a, b)], a, [(a, b)])
    divideBranches [(a, b)]
    branches = ([(a, b)]
    lo_branches, a
    mid, [(a, b)]
    hi_branches)
      where
        -- 2 branches => n_branches `div` 2 = 1
        --            => branches !! 1 give the *second* tag
        -- There are always at least 2 branches here
        (a
    mid,b
    _) = [(a, b)]
    branches [(a, b)] -> Int -> (a, b)
    forall a. HasCallStack => [a] -> Int -> a
    !! ([(a, b)] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(a, b)]
    branches Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    2)
        ([(a, b)]
    lo_branches, [(a, b)]
    hi_branches) = ((a, b) -> Bool) -> [(a, b)] -> ([(a, b)], [(a, b)])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    span (a, b) -> Bool
    is_lo [(a, b)]
    branches
        is_lo :: (a, b) -> Bool
    is_lo (a
    t,b
    _) = a
    t a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    < a
    mid

    --------------
    emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on
                   -> [(Literal, CmmAGraphScoped)] -- Tagged branches
                   -> CmmAGraphScoped              -- Default branch (always)
                   -> FCode ()                     -- Emit the code
    emitCmmLitSwitch :: CmmExpr
    -> [(Literal, CmmAGraphScoped)] -> CmmAGraphScoped -> FCode ()
    emitCmmLitSwitch CmmExpr
    _scrut [] CmmAGraphScoped
    deflt = CmmAGraph -> FCode ()
    emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
    forall a b. (a -> b) -> a -> b
    $ CmmAGraphScoped -> CmmAGraph
    forall a b. (a, b) -> a
    fst CmmAGraphScoped
    deflt
    emitCmmLitSwitch CmmExpr
    scrut branches :: [(Literal, CmmAGraphScoped)]
    branches@((Literal, CmmAGraphScoped)
    branch:[(Literal, CmmAGraphScoped)]
    _) CmmAGraphScoped
    deflt = do
        scrut' <- CmmExpr -> FCode CmmExpr
    assignTemp' CmmExpr
    scrut
        join_lbl <- newBlockId
        deflt_lbl <- label_code join_lbl deflt
        branches_lbls <- label_branches join_lbl branches

        platform <- getPlatform
        let cmm_ty = Platform -> CmmExpr -> CmmType
    cmmExprType Platform
    platform CmmExpr
    scrut
            rep = CmmType -> Width
    typeWidth CmmType
    cmm_ty

        -- We find the necessary type information in the literals in the branches
        let (signed,range) = case branch of
              (LitNumber LitNumType
    nt Integer
    _, CmmAGraphScoped
    _) -> (Bool
    signed,(Integer, Integer)
    range)
                where
                  signed :: Bool
    signed = LitNumType -> Bool
    litNumIsSigned LitNumType
    nt
                  range :: (Integer, Integer)
    range  = case Platform -> LitNumType -> (Maybe Integer, Maybe Integer)
    litNumRange Platform
    platform LitNumType
    nt of
                            (Just Integer
    mi, Just Integer
    ma) -> (Integer
    mi,Integer
    ma)
                                                  -- unbounded literals (Natural and
                                                  -- Integer) must have been
                                                  -- lowered at this point
                            (Maybe Integer, Maybe Integer)
    partial_bounds     -> String -> SDoc -> (Integer, Integer)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "Unexpected unbounded literal range"
                                                           ((Maybe Integer, Maybe Integer) -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Maybe Integer, Maybe Integer)
    partial_bounds)
                   -- assuming native word range
              (Literal, CmmAGraphScoped)
    _ -> (Bool
    False, (Integer
    0, Platform -> Integer
    platformMaxWord Platform
    platform))

        if isFloatType cmm_ty
        then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
        else emit $ mk_discrete_switch
            signed
            scrut'
            [(litValue lit,l) | (lit,l) <- branches_lbls]
            (Just deflt_lbl)
            range
        emitLabel join_lbl

    -- | lower bound (inclusive), upper bound (exclusive)
    type LitBound = (Maybe Literal, Maybe Literal)

    noBound :: LitBound
    noBound :: LitBound
    noBound = (Maybe Literal
    forall a. Maybe a
    Nothing, Maybe Literal
    forall a. Maybe a
    Nothing)

    mk_float_switch :: Width -> CmmExpr -> BlockId
                  -> LitBound
                  -> [(Literal,BlockId)]
                  -> FCode CmmAGraph
    mk_float_switch :: Width
    -> CmmExpr
    -> BlockId
    -> LitBound
    -> [(Literal, BlockId)]
    -> FCode CmmAGraph
    mk_float_switch Width
    rep CmmExpr
    scrut BlockId
    deflt LitBound
    _bounds [(Literal
    lit,BlockId
    blk)]
      = do platform <- FCode Platform
    getPlatform
           return $ mkCbranch (cond platform) deflt blk Nothing
      where
        cond :: Platform -> CmmExpr
    cond Platform
    platform = MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp MachOp
    ne [CmmExpr
    scrut, CmmLit -> CmmExpr
    CmmLit CmmLit
    cmm_lit]
          where
            cmm_lit :: CmmLit
    cmm_lit = Platform -> Literal -> CmmLit
    mkSimpleLit Platform
    platform Literal
    lit
            ne :: MachOp
    ne      = Width -> MachOp
    MO_F_Ne Width
    rep

    mk_float_switch Width
    rep CmmExpr
    scrut BlockId
    deflt_blk_id (Maybe Literal
    lo_bound, Maybe Literal
    hi_bound) [(Literal, BlockId)]
    branches
      = do platform <- FCode Platform
    getPlatform
           lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches
           hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches
           mkCmmIfThenElse (cond platform) lo_blk hi_blk
      where
        ([(Literal, BlockId)]
    lo_branches, Literal
    mid_lit, [(Literal, BlockId)]
    hi_branches) = [(Literal, BlockId)]
    -> ([(Literal, BlockId)], Literal, [(Literal, BlockId)])
    forall a b. Ord a => [(a, b)] -> ([(a, b)], a, [(a, b)])
    divideBranches [(Literal, BlockId)]
    branches

        bounds_lo :: LitBound
    bounds_lo = (Maybe Literal
    lo_bound, Literal -> Maybe Literal
    forall a. a -> Maybe a
    Just Literal
    mid_lit)
        bounds_hi :: LitBound
    bounds_hi = (Literal -> Maybe Literal
    forall a. a -> Maybe a
    Just Literal
    mid_lit, Maybe Literal
    hi_bound)

        cond :: Platform -> CmmExpr
    cond Platform
    platform = MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp MachOp
    lt [CmmExpr
    scrut, CmmLit -> CmmExpr
    CmmLit CmmLit
    cmm_lit]
          where
            cmm_lit :: CmmLit
    cmm_lit = Platform -> Literal -> CmmLit
    mkSimpleLit Platform
    platform Literal
    mid_lit
            lt :: MachOp
    lt      = Width -> MachOp
    MO_F_Lt Width
    rep

    --------------
    label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
    label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
    label_default BlockId
    _ Maybe CmmAGraphScoped
    Nothing
      = Maybe BlockId -> FCode (Maybe BlockId)
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe BlockId
    forall a. Maybe a
    Nothing
    label_default BlockId
    join_lbl (Just CmmAGraphScoped
    code)
      = do lbl <- BlockId -> CmmAGraphScoped -> FCode BlockId
    label_code BlockId
    join_lbl CmmAGraphScoped
    code
           return (Just lbl)

    --------------
    label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
    label_branches :: forall a. BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
    label_branches BlockId
    _join_lbl []
      = [(a, BlockId)] -> FCode [(a, BlockId)]
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
    label_branches BlockId
    join_lbl ((a
    tag,CmmAGraphScoped
    code):[(a, CmmAGraphScoped)]
    branches)
      = do lbl <- BlockId -> CmmAGraphScoped -> FCode BlockId
    label_code BlockId
    join_lbl CmmAGraphScoped
    code
           branches' <- label_branches join_lbl branches
           return ((tag,lbl):branches')

    --------------
    label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
    --  label_code J code
    --      generates
    --  [L: code; goto J]
    -- and returns L
    label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
    label_code BlockId
    join_lbl (CmmAGraph
    code,CmmTickScope
    tsc) = do
        lbl <- FCode BlockId
    forall (m :: * -> *). MonadUnique m => m BlockId
    newBlockId
        emitOutOfLine lbl (code CmmGraph.<*> mkBranch join_lbl, tsc)
        return lbl

    --------------
    assignTemp' :: CmmExpr -> FCode CmmExpr
    assignTemp' :: CmmExpr -> FCode CmmExpr
    assignTemp' CmmExpr
    e
      | CmmExpr -> Bool
    isTrivialCmmExpr CmmExpr
    e = CmmExpr -> FCode CmmExpr
    forall a. a -> FCode a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CmmExpr
    e
      | Bool
    otherwise = do
           platform <- FCode Platform
    getPlatform
           lreg <- newTemp (cmmExprType platform e)
           let reg = LocalReg -> CmmReg
    CmmLocal LocalReg
    lreg
           emitAssign reg e
           return (CmmReg reg)

    ---------------------------------------------------------------------------
    -- Pushing to the update remembered set
    ---------------------------------------------------------------------------

    whenUpdRemSetEnabled :: FCode a -> FCode ()
    whenUpdRemSetEnabled :: forall a. FCode a -> FCode ()
    whenUpdRemSetEnabled FCode a
    code = do
        platform <- FCode Platform
    getPlatform
        do_it <- getCode code
        let
          enabled = Platform -> CmmExpr -> CmmExpr
    cmmLoadBWord Platform
    platform (CmmLit -> CmmExpr
    CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
    forall a b. (a -> b) -> a -> b
    $ CLabel -> CmmLit
    CmmLabel CLabel
    mkNonmovingWriteBarrierEnabledLabel)
          zero = Platform -> CmmExpr
    zeroExpr Platform
    platform
          is_enabled = Platform -> CmmExpr -> CmmExpr -> CmmExpr
    cmmNeWord Platform
    platform CmmExpr
    enabled CmmExpr
    zero
        the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False)
        emit the_if

    -- | Emit code to add an entry to a now-overwritten pointer to the update
    -- remembered set.
    emitUpdRemSetPush :: CmmExpr   -- ^ value of pointer which was overwritten
                      -> FCode ()
    emitUpdRemSetPush :: CmmExpr -> FCode ()
    emitUpdRemSetPush CmmExpr
    ptr = do
        platform <- FCode Platform
    getPlatform
        emitRtsCall
          rtsUnitId
          (fsLit "updateRemembSetPushClosure_")
          [(CmmReg $ baseReg platform, AddrHint),
           (ptr, AddrHint)]
          False

    emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk
                           -> FCode ()
    emitUpdRemSetPushThunk :: CmmExpr -> FCode ()
    emitUpdRemSetPushThunk CmmExpr
    ptr = do
        platform <- FCode Platform
    getPlatform
        emitRtsCall
          rtsUnitId
          (fsLit "updateRemembSetPushThunk_")
          [(CmmReg $ baseReg platform, AddrHint),
           (ptr, AddrHint)]
          False

    -- | A bare bones InfoProvEnt for things which don't have a good source location
    cmmInfoTableToInfoProvEnt :: Module -> CmmInfoTable -> InfoProvEnt
    cmmInfoTableToInfoProvEnt :: Module -> CmmInfoTable -> InfoProvEnt
    cmmInfoTableToInfoProvEnt Module
    this_mod CmmInfoTable
    cmit =
        let cl :: CLabel
    cl = CmmInfoTable -> CLabel
    cit_lbl CmmInfoTable
    cmit
            cn :: Int
    cn  = SMRep -> Int
    rtsClosureType (CmmInfoTable -> SMRep
    cit_rep CmmInfoTable
    cmit)
        in CLabel
    -> Int
    -> String
    -> Module
    -> Maybe (RealSrcSpan, LexicalFastString)
    -> InfoProvEnt
    InfoProvEnt CLabel
    cl Int
    cn String
    "" Module
    this_mod Maybe (RealSrcSpan, LexicalFastString)
    forall a. Maybe a
    Nothing

    data IPEStats = IPEStats { IPEStats -> Int
    ipe_total :: !Int
                             , IPEStats -> IntMap Int
    ipe_closure_types :: !(I.IntMap Int)
                             , IPEStats -> Int
    ipe_fallback :: !Int
                             , IPEStats -> Int
    ipe_skipped :: !Int }

    instance Semigroup IPEStats where
      (IPEStats Int
    a1 IntMap Int
    a2 Int
    a3 Int
    a4) <> :: IPEStats -> IPEStats -> IPEStats
    <> (IPEStats Int
    b1 IntMap Int
    b2 Int
    b3 Int
    b4) = Int -> IntMap Int -> Int -> Int -> IPEStats
    IPEStats (Int
    a1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    b1) ((Int -> Int -> Int) -> IntMap Int -> IntMap Int -> IntMap Int
    forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
    I.unionWith Int -> Int -> Int
    forall a. Num a => a -> a -> a
    (+) IntMap Int
    a2 IntMap Int
    b2) (Int
    a3 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    b3) (Int
    a4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    b4)

    instance Monoid IPEStats where
      mempty :: IPEStats
    mempty = Int -> IntMap Int -> Int -> Int -> IPEStats
    IPEStats Int
    0 IntMap Int
    forall a. IntMap a
    I.empty Int
    0 Int
    0

    fallbackIpeStats :: IPEStats
    fallbackIpeStats :: IPEStats
    fallbackIpeStats = IPEStats
    forall a. Monoid a => a
    mempty { ipe_total = 1, ipe_fallback = 1 }

    closureIpeStats :: Int -> IPEStats
    closureIpeStats :: Int -> IPEStats
    closureIpeStats Int
    t = IPEStats
    forall a. Monoid a => a
    mempty { ipe_total = 1, ipe_closure_types = I.singleton t 1 }

    skippedIpeStats :: IPEStats
    skippedIpeStats :: IPEStats
    skippedIpeStats = IPEStats
    forall a. Monoid a => a
    mempty { ipe_skipped = 1 }

    instance Outputable IPEStats where
      ppr :: IPEStats -> SDoc
    ppr = IPEStats -> SDoc
    pprIPEStats

    pprIPEStats :: IPEStats -> SDoc
    pprIPEStats :: IPEStats -> SDoc
    pprIPEStats (IPEStats{Int
    IntMap Int
    ipe_total :: IPEStats -> Int
    ipe_closure_types :: IPEStats -> IntMap Int
    ipe_fallback :: IPEStats -> Int
    ipe_skipped :: IPEStats -> Int
    ipe_total :: Int
    ipe_closure_types :: IntMap Int
    ipe_fallback :: Int
    ipe_skipped :: Int
    ..}) =
      [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Tables with info:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Int
    ipe_total
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Tables with fallback:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Int
    ipe_fallback
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Tables skipped:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Int
    ipe_skipped
             ] [SDoc] -> [SDoc] -> [SDoc]
    forall a. [a] -> [a] -> [a]
    ++ [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Info(" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Int
    k SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "):" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Int
    n | (Int
    k, Int
    n) <- IntMap Int -> [(Int, Int)]
    forall a. IntMap a -> [(Int, a)]
    I.assocs IntMap Int
    ipe_closure_types ]

    -- | Convert source information collected about identifiers in 'GHC.STG.Debug'
    -- to entries suitable for placing into the info table provenance table.
    --
    -- The initial stats given to this function will (or should) only contain stats
    -- for stack info tables skipped during 'generateCgIPEStub'. As the fold
    -- progresses, counts of tables per closure type will be accumulated.
    convertInfoProvMap :: StgToCmmConfig -> Module -> InfoTableProvMap -> IPEStats -> [CmmInfoTable] -> (IPEStats, [InfoProvEnt])
    convertInfoProvMap :: StgToCmmConfig
    -> Module
    -> InfoTableProvMap
    -> IPEStats
    -> [CmmInfoTable]
    -> (IPEStats, [InfoProvEnt])
    convertInfoProvMap StgToCmmConfig
    cfg Module
    this_mod (InfoTableProvMap (UniqMap UniqFM
      DataCon
      (DataCon, NonEmpty (Int, Maybe (RealSrcSpan, LexicalFastString)))
    dcenv) ClosureMap
    denv InfoTableToSourceLocationMap
    infoTableToSourceLocationMap) IPEStats
    initStats [CmmInfoTable]
    cmits =
        ((IPEStats, [InfoProvEnt])
     -> CmmInfoTable -> (IPEStats, [InfoProvEnt]))
    -> (IPEStats, [InfoProvEnt])
    -> [CmmInfoTable]
    -> (IPEStats, [InfoProvEnt])
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (IPEStats, [InfoProvEnt])
    -> CmmInfoTable -> (IPEStats, [InfoProvEnt])
    convertInfoProvMap' (IPEStats
    initStats, []) [CmmInfoTable]
    cmits
      where
        convertInfoProvMap' :: (IPEStats, [InfoProvEnt]) -> CmmInfoTable -> (IPEStats, [InfoProvEnt])
        convertInfoProvMap' :: (IPEStats, [InfoProvEnt])
    -> CmmInfoTable -> (IPEStats, [InfoProvEnt])
    convertInfoProvMap' (!IPEStats
    stats, [InfoProvEnt]
    acc) CmmInfoTable
    cmit = do
          let
            cl :: CLabel
    cl = CmmInfoTable -> CLabel
    cit_lbl CmmInfoTable
    cmit
            cn :: Int
    cn  = SMRep -> Int
    rtsClosureType (CmmInfoTable -> SMRep
    cit_rep CmmInfoTable
    cmit)

            tyString :: Outputable a => a -> String
            tyString :: forall a. Outputable a => a -> String
    tyString = SDocContext -> SDoc -> String
    renderWithContext SDocContext
    defaultSDocContext (SDoc -> String) -> (a -> SDoc) -> a -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr

            lookupClosureMap :: Maybe (IPEStats, InfoProvEnt)
            lookupClosureMap :: Maybe (IPEStats, InfoProvEnt)
    lookupClosureMap = case CLabel -> Maybe Name
    hasHaskellName CLabel
    cl Maybe Name
    -> (Name -> Maybe (Type, Maybe (RealSrcSpan, LexicalFastString)))
    -> Maybe (Type, Maybe (RealSrcSpan, LexicalFastString))
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= ClosureMap
    -> Name -> Maybe (Type, Maybe (RealSrcSpan, LexicalFastString))
    forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
    lookupUniqMap ClosureMap
    denv of
                                    Just (Type
    ty, Maybe (RealSrcSpan, LexicalFastString)
    mbspan) -> (IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt)
    forall a. a -> Maybe a
    Just (Int -> IPEStats
    closureIpeStats Int
    cn, (CLabel
    -> Int
    -> String
    -> Module
    -> Maybe (RealSrcSpan, LexicalFastString)
    -> InfoProvEnt
    InfoProvEnt CLabel
    cl Int
    cn (Type -> String
    forall a. Outputable a => a -> String
    tyString Type
    ty) Module
    this_mod Maybe (RealSrcSpan, LexicalFastString)
    mbspan))
                                    Maybe (Type, Maybe (RealSrcSpan, LexicalFastString))
    Nothing -> Maybe (IPEStats, InfoProvEnt)
    forall a. Maybe a
    Nothing

            lookupDataConMap :: Maybe (IPEStats, InfoProvEnt)
            lookupDataConMap :: Maybe (IPEStats, InfoProvEnt)
    lookupDataConMap = (Int -> IPEStats
    closureIpeStats Int
    cn,) (InfoProvEnt -> (IPEStats, InfoProvEnt))
    -> Maybe InfoProvEnt -> Maybe (IPEStats, InfoProvEnt)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> do
                UsageSite _ n <- CLabel -> Maybe IdLabelInfo
    hasIdLabelInfo CLabel
    cl Maybe IdLabelInfo
    -> (IdLabelInfo -> Maybe ConInfoTableLocation)
    -> Maybe ConInfoTableLocation
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= IdLabelInfo -> Maybe ConInfoTableLocation
    getConInfoTableLocation
                -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do
                (dc, ns) <- hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique
                -- Lookup is linear but lists will be small (< 100)
                return $ (InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns)))

            lookupInfoTableToSourceLocation :: Maybe (IPEStats, InfoProvEnt)
            lookupInfoTableToSourceLocation :: Maybe (IPEStats, InfoProvEnt)
    lookupInfoTableToSourceLocation = do
                sourceNote <- CLabel
    -> InfoTableToSourceLocationMap
    -> Maybe (Maybe (RealSrcSpan, LexicalFastString))
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup (CmmInfoTable -> CLabel
    cit_lbl CmmInfoTable
    cmit) InfoTableToSourceLocationMap
    infoTableToSourceLocationMap
                return $ (closureIpeStats cn, (InfoProvEnt cl cn "" this_mod sourceNote))

            -- This catches things like prim closure types and anything else which doesn't have a
            -- source location
            simpleFallback :: Maybe (IPEStats, InfoProvEnt)
    simpleFallback =
              if StgToCmmConfig -> Bool
    stgToCmmInfoTableMapWithFallback StgToCmmConfig
    cfg then
                -- Create a default entry with fallback IPE data
                (IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt)
    forall a. a -> Maybe a
    Just (IPEStats
    fallbackIpeStats, Module -> CmmInfoTable -> InfoProvEnt
    cmmInfoTableToInfoProvEnt Module
    this_mod CmmInfoTable
    cmit)
              else
                -- If we are omitting tables with fallback info
                -- (-fno-info-table-map-with-fallback was given), do not create an
                -- entry
                Maybe (IPEStats, InfoProvEnt)
    forall a. Maybe a
    Nothing

            trackSkipped :: Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt])
            trackSkipped :: Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt])
    trackSkipped Maybe (IPEStats, InfoProvEnt)
    Nothing =
              (IPEStats
    stats IPEStats -> IPEStats -> IPEStats
    forall a. Semigroup a => a -> a -> a
    Data.Semigroup.<> IPEStats
    skippedIpeStats, [InfoProvEnt]
    acc)
            trackSkipped (Just (IPEStats
    s, !InfoProvEnt
    c)) =
              (IPEStats
    stats IPEStats -> IPEStats -> IPEStats
    forall a. Semigroup a => a -> a -> a
    Data.Semigroup.<> IPEStats
    s, InfoProvEnt
    cInfoProvEnt -> [InfoProvEnt] -> [InfoProvEnt]
    forall a. a -> [a] -> [a]
    :[InfoProvEnt]
    acc)

          Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt])
    trackSkipped (Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt]))
    -> Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt])
    forall a b. (a -> b) -> a -> b
    $
            if (SMRep -> Bool
    isStackRep (SMRep -> Bool) -> (CmmInfoTable -> SMRep) -> CmmInfoTable -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CmmInfoTable -> SMRep
    cit_rep) CmmInfoTable
    cmit then
              -- Note that we should have already skipped STACK info tables if
              -- necessary in 'generateCgIPEStub', so we should not need to worry
              -- about doing that here.
              Maybe (IPEStats, InfoProvEnt)
    -> Maybe (Maybe (IPEStats, InfoProvEnt))
    -> Maybe (IPEStats, InfoProvEnt)
    forall a. a -> Maybe a -> a
    fromMaybe Maybe (IPEStats, InfoProvEnt)
    simpleFallback ((IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt)
    forall a. a -> Maybe a
    Just ((IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt))
    -> Maybe (IPEStats, InfoProvEnt)
    -> Maybe (Maybe (IPEStats, InfoProvEnt))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Maybe (IPEStats, InfoProvEnt)
    lookupInfoTableToSourceLocation)
            else
              Maybe (IPEStats, InfoProvEnt)
    -> Maybe (Maybe (IPEStats, InfoProvEnt))
    -> Maybe (IPEStats, InfoProvEnt)
    forall a. a -> Maybe a -> a
    fromMaybe Maybe (IPEStats, InfoProvEnt)
    simpleFallback ((IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt)
    forall a. a -> Maybe a
    Just ((IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt))
    -> Maybe (IPEStats, InfoProvEnt)
    -> Maybe (Maybe (IPEStats, InfoProvEnt))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Maybe (IPEStats, InfoProvEnt)
    -> Maybe (IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt)
    forall a. Maybe a -> Maybe a -> Maybe a
    firstJust Maybe (IPEStats, InfoProvEnt)
    lookupDataConMap Maybe (IPEStats, InfoProvEnt)
    lookupClosureMap)