    {-# LANGUAGE CPP #-}
    {-# LANGUAGE LambdaCase #-}

    -----------------------------------------------------------------------------
    --
    -- Code generator utilities; mostly monadic
    --
    -- (c) The University of Glasgow 2004-2006
    --
    -----------------------------------------------------------------------------

    module GHC.StgToCmm.Utils (
            cgLit, mkSimpleLit,
            emitDataLits, emitRODataLits,
            emitDataCon,
            emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
            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,
            newStringCLit, newByteStringCLit,

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

            convertInfoProvMap, cmmInfoTableToInfoProvEnt
      ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Platform
    import GHC.StgToCmm.Monad
    import GHC.StgToCmm.Closure
    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 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.Types.Unique.Supply (MonadUnique(..))
    import GHC.Driver.Session
    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 Data.ByteString (ByteString)
    import qualified Data.ByteString.Char8 as BS8
    import qualified Data.Map as M
    import Data.Char
    import Data.List (sortBy)
    import Data.Ord
    import GHC.Types.Unique.Map
    import Data.Maybe
    import GHC.Driver.Ppr
    import qualified Data.List.NonEmpty as NE
    import GHC.Core.DataCon
    import GHC.Types.Unique.FM
    import GHC.Data.Maybe
    import Control.Monad

    -------------------------------------------------------------------------
    --
    --      Literals
    --
    -------------------------------------------------------------------------

    cgLit :: Literal -> FCode CmmLit
    cgLit :: Literal -> FCode CmmLit
    cgLit (LitString ByteString
    s) = ByteString -> FCode CmmLit
    newByteStringCLit ByteString
    s
     -- not unpackFS; we want the UTF-8 byte stream.
    cgLit Literal
    other_lit     = do Platform
    platform <- FCode Platform
    getPlatform
                             CmmLit -> FCode CmmLit
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Platform -> Literal -> CmmLit
    mkSimpleLit Platform
    platform Literal
    other_lit)

    mkSimpleLit :: Platform -> Literal -> CmmLit
    mkSimpleLit :: Platform -> Literal -> CmmLit
    mkSimpleLit Platform
    platform = \case
       (LitChar   Char
    c)                -> Integer -> Width -> CmmLit
    CmmInt (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Char -> Int
    ord Char
    c))
                                              (Platform -> Width
    wordWidth Platform
    platform)
       Literal
    LitNullAddr                  -> Platform -> CmmLit
    zeroCLit Platform
    platform
       (LitNumber LitNumType
    LitNumInt Integer
    i)      -> Integer -> Width -> CmmLit
    CmmInt Integer
    i (Platform -> Width
    wordWidth Platform
    platform)
       (LitNumber LitNumType
    LitNumInt8 Integer
    i)     -> Integer -> Width -> CmmLit
    CmmInt Integer
    i Width
    W8
       (LitNumber LitNumType
    LitNumInt16 Integer
    i)    -> Integer -> Width -> CmmLit
    CmmInt Integer
    i Width
    W16
       (LitNumber LitNumType
    LitNumInt32 Integer
    i)    -> Integer -> Width -> CmmLit
    CmmInt Integer
    i Width
    W32
       (LitNumber LitNumType
    LitNumInt64 Integer
    i)    -> Integer -> Width -> CmmLit
    CmmInt Integer
    i Width
    W64
       (LitNumber LitNumType
    LitNumWord Integer
    i)     -> Integer -> Width -> CmmLit
    CmmInt Integer
    i (Platform -> Width
    wordWidth Platform
    platform)
       (LitNumber LitNumType
    LitNumWord8 Integer
    i)    -> Integer -> Width -> CmmLit
    CmmInt Integer
    i Width
    W8
       (LitNumber LitNumType
    LitNumWord16 Integer
    i)   -> Integer -> Width -> CmmLit
    CmmInt Integer
    i Width
    W16
       (LitNumber LitNumType
    LitNumWord32 Integer
    i)   -> Integer -> Width -> CmmLit
    CmmInt Integer
    i Width
    W32
       (LitNumber LitNumType
    LitNumWord64 Integer
    i)   -> Integer -> Width -> CmmLit
    CmmInt Integer
    i Width
    W64
       (LitFloat Rational
    r)                 -> Rational -> Width -> CmmLit
    CmmFloat Rational
    r Width
    W32
       (LitDouble Rational
    r)                -> Rational -> Width -> CmmLit
    CmmFloat Rational
    r Width
    W64
       (LitLabel FastString
    fs Maybe Int
    ms FunctionOrData
    fod)
         -> let -- TODO: Literal labels might not actually be in the current package...
                labelSrc :: ForeignLabelSource
    labelSrc = ForeignLabelSource
    ForeignLabelInThisPackage
            in CLabel -> CmmLit
    CmmLabel (FastString
    -> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
    mkForeignLabel FastString
    fs Maybe Int
    ms ForeignLabelSource
    labelSrc FunctionOrData
    fod)
       -- NB: LitRubbish should have been lowered in "CoreToStg"
       Literal
    other -> String -> SDoc -> CmmLit
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "mkSimpleLit" (Literal -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Literal
    other)

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

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

    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])

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

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

    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 FastString
    fun [(CmmExpr, ForeignHint)]
    args Bool
    safe
       = [(LocalReg, ForeignHint)]
    -> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
    emitRtsCallGen [(LocalReg
    res,ForeignHint
    hint)] (UnitId -> FastString -> CLabel
    mkCmmCodeLabel UnitId
    pkg FastString
    fun) [(CmmExpr, ForeignHint)]
    args Bool
    safe

    -- 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
    platform <- DynFlags -> Platform
    targetPlatform (DynFlags -> Platform) -> FCode DynFlags -> FCode Platform
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> FCode DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
           ; Int
    updfr_off <- FCode Int
    getUpdFrameOff
           ; let (CmmAGraph
    caller_save, CmmAGraph
    caller_load) = Platform -> (CmmAGraph, CmmAGraph)
    callerSaveVolatileRegs Platform
    platform
           ; CmmAGraph -> FCode ()
    emit CmmAGraph
    caller_save
           ; Int -> FCode ()
    call Int
    updfr_off
           ; CmmAGraph -> FCode ()
    emit CmmAGraph
    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 includes/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
    -- includes/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 (GlobalReg -> CmmReg
    CmmGlobal GlobalReg
    reg))

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

    -------------------------------------------------------------------------
    --
    --      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] -> CmmStatics
    CmmStatics CLabel
    lbl CmmInfoTable
    itbl CostCentreStack
    ccs [CmmLit]
    payload))

    newStringCLit :: String -> FCode CmmLit
    -- Make a global definition for the string,
    -- and return its label
    newStringCLit :: String -> FCode CmmLit
    newStringCLit String
    str = ByteString -> FCode CmmLit
    newByteStringCLit (String -> ByteString
    BS8.pack String
    str)

    newByteStringCLit :: ByteString -> FCode CmmLit
    newByteStringCLit :: ByteString -> FCode CmmLit
    newByteStringCLit ByteString
    bytes
      = do  { Unique
    uniq <- FCode Unique
    newUnique
            ; let (CmmLit
    lit, CmmDecl
    decl) = CLabel -> ByteString -> (CmmLit, CmmDecl)
    forall (raw :: Bool) info stmt.
    CLabel
    -> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
    mkByteStringCLit (Unique -> CLabel
    mkStringLitLabel Unique
    uniq) ByteString
    bytes
            ; CmmDecl -> FCode ()
    emitDecl CmmDecl
    decl
            ; CmmLit -> FCode CmmLit
    forall (m :: * -> *) a. Monad m => a -> m a
    return CmmLit
    lit }

    -------------------------------------------------------------------------
    --
    --      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 (m :: * -> *) a. Monad m => a -> m a
    return LocalReg
    reg
    assignTemp CmmExpr
    e = do { Platform
    platform <- FCode Platform
    getPlatform
                      ; LocalReg
    reg <- CmmType -> FCode LocalReg
    forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmExpr -> CmmType
    cmmExprType Platform
    platform CmmExpr
    e)
                      ; CmmReg -> CmmExpr -> FCode ()
    emitAssign (LocalReg -> CmmReg
    CmmLocal LocalReg
    reg) CmmExpr
    e
                      ; LocalReg -> FCode LocalReg
    forall (m :: * -> *) a. Monad m => a -> m a
    return LocalReg
    reg }

    newTemp :: MonadUnique m => CmmType -> m LocalReg
    newTemp :: forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp CmmType
    rep = do { Unique
    uniq <- m Unique
    forall (m :: * -> *). MonadUnique m => m Unique
    getUniqueM
                     ; LocalReg -> m LocalReg
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Unique -> CmmType -> LocalReg
    LocalReg Unique
    uniq CmmType
    rep) }

    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
      = ASSERT( isUnboxedTupleType res_ty )
        do  { Platform
    platform <- FCode Platform
    getPlatform
            ; Sequel
    sequel <- FCode Sequel
    getSequel
            ; [LocalReg]
    regs <- Platform -> Sequel -> FCode [LocalReg]
    choose_regs Platform
    platform Sequel
    sequel
            ; ASSERT( regs `equalLength` reps )
              ([LocalReg], [ForeignHint]) -> FCode ([LocalReg], [ForeignHint])
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([LocalReg]
    regs, (PrimRep -> ForeignHint) -> [PrimRep] -> [ForeignHint]
    forall a b. (a -> b) -> [a] -> [b]
    map PrimRep -> ForeignHint
    primRepForeignHint [PrimRep]
    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 (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)
    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 (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
    platform <- FCode Platform
    getPlatform
      ASSERT2( equalLength regs rhss, ppr regs $$ pdoc platform rhss )
        Platform -> [Vrtx] -> FCode ()
    unscramble Platform
    platform ([Int
    1..] [Int] -> [Stmt] -> [Vrtx]
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` ([LocalReg]
    regs [LocalReg] -> [CmmExpr] -> [Stmt]
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` [CmmExpr]
    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. 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
                Unique
    u <- FCode Unique
    newUnique
                let (Stmt
    to_tmp, Stmt
    from_tmp) = Unique -> Stmt -> (Stmt, Stmt)
    split Unique
    u Stmt
    first_stmt
                Stmt -> FCode ()
    mk_graph Stmt
    to_tmp
                Platform -> [Vrtx] -> FCode ()
    unscramble Platform
    platform [Vrtx]
    rest
                Stmt -> FCode ()
    mk_graph Stmt
    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
        BlockId
    join_lbl      <- FCode BlockId
    forall (m :: * -> *). MonadUnique m => m BlockId
    newBlockId
        Maybe BlockId
    mb_deflt_lbl  <- BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
    label_default BlockId
    join_lbl Maybe CmmAGraphScoped
    mb_deflt
        [(Int, BlockId)]
    branches_lbls <- BlockId -> [(Int, CmmAGraphScoped)] -> FCode [(Int, BlockId)]
    forall a. BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
    label_branches BlockId
    join_lbl [(Int, CmmAGraphScoped)]
    branches
        CmmExpr
    tag_expr'     <- CmmExpr -> FCode CmmExpr
    assignTemp' CmmExpr
    tag_expr

        -- Sort the branches before calling mk_discrete_switch
        let branches_lbls' :: [(Integer, BlockId)]
    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 :: (Integer, Integer)
    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)

        CmmAGraph -> FCode ()
    emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
    forall a b. (a -> b) -> a -> b
    $ Bool
    -> CmmExpr
    -> [(Integer, BlockId)]
    -> Maybe BlockId
    -> (Integer, Integer)
    -> CmmAGraph
    mk_discrete_switch Bool
    False CmmExpr
    tag_expr' [(Integer, BlockId)]
    branches_lbls' Maybe BlockId
    mb_deflt_lbl (Integer, Integer)
    range

        BlockId -> FCode ()
    emitLabel BlockId
    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
      = ASSERT( tag == lo_tag )
        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. [a] -> Int -> a
    !! ([(a, b)] -> 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  [(Literal, CmmAGraphScoped)]
    branches CmmAGraphScoped
    deflt = do
        CmmExpr
    scrut' <- CmmExpr -> FCode CmmExpr
    assignTemp' CmmExpr
    scrut
        BlockId
    join_lbl <- FCode BlockId
    forall (m :: * -> *). MonadUnique m => m BlockId
    newBlockId
        BlockId
    deflt_lbl <- BlockId -> CmmAGraphScoped -> FCode BlockId
    label_code BlockId
    join_lbl CmmAGraphScoped
    deflt
        [(Literal, BlockId)]
    branches_lbls <- BlockId
    -> [(Literal, CmmAGraphScoped)] -> FCode [(Literal, BlockId)]
    forall a. BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
    label_branches BlockId
    join_lbl [(Literal, CmmAGraphScoped)]
    branches

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

        -- We find the necessary type information in the literals in the branches
        let signed :: Bool
    signed = case [(Literal, CmmAGraphScoped)] -> (Literal, CmmAGraphScoped)
    forall a. [a] -> a
    head [(Literal, CmmAGraphScoped)]
    branches of
                        (LitNumber LitNumType
    nt Integer
    _, CmmAGraphScoped
    _) -> LitNumType -> Bool
    litNumIsSigned LitNumType
    nt
                        (Literal, CmmAGraphScoped)
    _ -> Bool
    False

        let range :: (Integer, Integer)
    range | Bool
    signed    = (Platform -> Integer
    platformMinInt Platform
    platform, Platform -> Integer
    platformMaxInt Platform
    platform)
                  | Bool
    otherwise = (Integer
    0, Platform -> Integer
    platformMaxWord Platform
    platform)

        if CmmType -> Bool
    isFloatType CmmType
    cmm_ty
        then CmmAGraph -> FCode ()
    emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< Width
    -> CmmExpr
    -> BlockId
    -> LitBound
    -> [(Literal, BlockId)]
    -> FCode CmmAGraph
    mk_float_switch Width
    rep CmmExpr
    scrut' BlockId
    deflt_lbl LitBound
    noBound [(Literal, BlockId)]
    branches_lbls
        else CmmAGraph -> FCode ()
    emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
    forall a b. (a -> b) -> a -> b
    $ Bool
    -> CmmExpr
    -> [(Integer, BlockId)]
    -> Maybe BlockId
    -> (Integer, Integer)
    -> CmmAGraph
    mk_discrete_switch
            Bool
    signed
            CmmExpr
    scrut'
            [(Literal -> Integer
    litValue Literal
    lit,BlockId
    l) | (Literal
    lit,BlockId
    l) <- [(Literal, BlockId)]
    branches_lbls]
            (BlockId -> Maybe BlockId
    forall a. a -> Maybe a
    Just BlockId
    deflt_lbl)
            (Integer, Integer)
    range
        BlockId -> FCode ()
    emitLabel BlockId
    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
    platform <- FCode Platform
    getPlatform
           CmmAGraph -> FCode CmmAGraph
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CmmAGraph -> FCode CmmAGraph) -> CmmAGraph -> FCode CmmAGraph
    forall a b. (a -> b) -> a -> b
    $ CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
    mkCbranch (Platform -> CmmExpr
    cond Platform
    platform) BlockId
    deflt BlockId
    blk Maybe Bool
    forall a. Maybe a
    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
    platform <- FCode Platform
    getPlatform
           CmmAGraph
    lo_blk <- Width
    -> CmmExpr
    -> BlockId
    -> LitBound
    -> [(Literal, BlockId)]
    -> FCode CmmAGraph
    mk_float_switch Width
    rep CmmExpr
    scrut BlockId
    deflt_blk_id LitBound
    bounds_lo [(Literal, BlockId)]
    lo_branches
           CmmAGraph
    hi_blk <- Width
    -> CmmExpr
    -> BlockId
    -> LitBound
    -> [(Literal, BlockId)]
    -> FCode CmmAGraph
    mk_float_switch Width
    rep CmmExpr
    scrut BlockId
    deflt_blk_id LitBound
    bounds_hi [(Literal, BlockId)]
    hi_branches
           CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
    mkCmmIfThenElse (Platform -> CmmExpr
    cond Platform
    platform) CmmAGraph
    lo_blk CmmAGraph
    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 (m :: * -> *) a. Monad m => a -> m a
    return Maybe BlockId
    forall a. Maybe a
    Nothing
    label_default BlockId
    join_lbl (Just CmmAGraphScoped
    code)
      = do BlockId
    lbl <- BlockId -> CmmAGraphScoped -> FCode BlockId
    label_code BlockId
    join_lbl CmmAGraphScoped
    code
           Maybe BlockId -> FCode (Maybe BlockId)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BlockId -> Maybe BlockId
    forall a. a -> Maybe a
    Just BlockId
    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 (m :: * -> *) a. Monad m => a -> m a
    return []
    label_branches BlockId
    join_lbl ((a
    tag,CmmAGraphScoped
    code):[(a, CmmAGraphScoped)]
    branches)
      = do BlockId
    lbl <- BlockId -> CmmAGraphScoped -> FCode BlockId
    label_code BlockId
    join_lbl CmmAGraphScoped
    code
           [(a, BlockId)]
    branches' <- BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
    forall a. BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
    label_branches BlockId
    join_lbl [(a, CmmAGraphScoped)]
    branches
           [(a, BlockId)] -> FCode [(a, BlockId)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((a
    tag,BlockId
    lbl)(a, BlockId) -> [(a, BlockId)] -> [(a, BlockId)]
    forall a. a -> [a] -> [a]
    :[(a, BlockId)]
    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
        BlockId
    lbl <- FCode BlockId
    forall (m :: * -> *). MonadUnique m => m BlockId
    newBlockId
        BlockId -> CmmAGraphScoped -> FCode ()
    emitOutOfLine BlockId
    lbl (CmmAGraph
    code CmmAGraph -> CmmAGraph -> CmmAGraph
    CmmGraph.<*> BlockId -> CmmAGraph
    mkBranch BlockId
    join_lbl, CmmTickScope
    tsc)
        BlockId -> FCode BlockId
    forall (m :: * -> *) a. Monad m => a -> m a
    return BlockId
    lbl

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

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

    whenUpdRemSetEnabled :: FCode a -> FCode ()
    whenUpdRemSetEnabled :: forall a. FCode a -> FCode ()
    whenUpdRemSetEnabled FCode a
    code = do
        Platform
    platform <- FCode Platform
    getPlatform
        CmmAGraph
    do_it <- FCode a -> FCode CmmAGraph
    forall a. FCode a -> FCode CmmAGraph
    getCode FCode a
    code
        let
          enabled :: CmmExpr
    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 :: CmmExpr
    zero = Platform -> CmmExpr
    zeroExpr Platform
    platform
          is_enabled :: CmmExpr
    is_enabled = Platform -> CmmExpr -> CmmExpr -> CmmExpr
    cmmNeWord Platform
    platform CmmExpr
    enabled CmmExpr
    zero
        CmmAGraph
    the_if <- CmmExpr -> CmmAGraph -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
    mkCmmIfThenElse' CmmExpr
    is_enabled CmmAGraph
    do_it CmmAGraph
    mkNop (Bool -> Maybe Bool
    forall a. a -> Maybe a
    Just Bool
    False)
        CmmAGraph -> FCode ()
    emit CmmAGraph
    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 =
        UnitId
    -> FastString -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
    emitRtsCall
          UnitId
    rtsUnitId
          (String -> FastString
    fsLit String
    "updateRemembSetPushClosure_")
          [(CmmReg -> CmmExpr
    CmmReg (GlobalReg -> CmmReg
    CmmGlobal GlobalReg
    BaseReg), ForeignHint
    AddrHint),
           (CmmExpr
    ptr, ForeignHint
    AddrHint)]
          Bool
    False

    emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk
                           -> FCode ()
    emitUpdRemSetPushThunk :: CmmExpr -> FCode ()
    emitUpdRemSetPushThunk CmmExpr
    ptr =
        UnitId
    -> FastString -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
    emitRtsCall
          UnitId
    rtsUnitId
          (String -> FastString
    fsLit String
    "updateRemembSetPushThunk_")
          [(CmmReg -> CmmExpr
    CmmReg (GlobalReg -> CmmReg
    CmmGlobal GlobalReg
    BaseReg), ForeignHint
    AddrHint),
           (CmmExpr
    ptr, ForeignHint
    AddrHint)]
          Bool
    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, String)
    -> InfoProvEnt
    InfoProvEnt CLabel
    cl Int
    cn String
    "" Module
    this_mod Maybe (RealSrcSpan, String)
    forall a. Maybe a
    Nothing

    -- | Convert source information collected about identifiers in 'GHC.STG.Debug'
    -- to entries suitable for placing into the info table provenenance table.
    convertInfoProvMap :: DynFlags -> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]
    convertInfoProvMap :: DynFlags
    -> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]
    convertInfoProvMap DynFlags
    dflags [CmmInfoTable]
    defns Module
    this_mod (InfoTableProvMap (UniqMap UniqFM
      DataCon (DataCon, NonEmpty (Int, Maybe (RealSrcSpan, String)))
    dcenv) ClosureMap
    denv) =
      (CmmInfoTable -> InfoProvEnt) -> [CmmInfoTable] -> [InfoProvEnt]
    forall a b. (a -> b) -> [a] -> [b]
    map (\CmmInfoTable
    cmit ->
        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 a
    t = DynFlags -> a -> String
    forall a. Outputable a => DynFlags -> a -> String
    showPpr DynFlags
    dflags a
    t

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

            lookupDataConMap :: Maybe InfoProvEnt
    lookupDataConMap = do
                UsageSite Module
    _ Int
    n <- CLabel -> Maybe IdLabelInfo
    hasIdLabelInfo CLabel
    cl Maybe IdLabelInfo
    -> (IdLabelInfo -> Maybe ConInfoTableLocation)
    -> Maybe ConInfoTableLocation
    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
                (DataCon
    dc, NonEmpty (Int, Maybe (RealSrcSpan, String))
    ns) <- (CLabel -> Maybe Name
    hasHaskellName CLabel
    cl Maybe Name
    -> (Name
        -> Maybe (DataCon, NonEmpty (Int, Maybe (RealSrcSpan, String))))
    -> Maybe (DataCon, NonEmpty (Int, Maybe (RealSrcSpan, String)))
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= UniqFM
      DataCon (DataCon, NonEmpty (Int, Maybe (RealSrcSpan, String)))
    -> Unique
    -> Maybe (DataCon, NonEmpty (Int, Maybe (RealSrcSpan, String)))
    forall key elt. UniqFM key elt -> Unique -> Maybe elt
    lookupUFM_Directly UniqFM
      DataCon (DataCon, NonEmpty (Int, Maybe (RealSrcSpan, String)))
    dcenv (Unique
     -> Maybe (DataCon, NonEmpty (Int, Maybe (RealSrcSpan, String))))
    -> (Name -> Unique)
    -> Name
    -> Maybe (DataCon, NonEmpty (Int, Maybe (RealSrcSpan, String)))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique)
                -- Lookup is linear but lists will be small (< 100)
                InfoProvEnt -> Maybe InfoProvEnt
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InfoProvEnt -> Maybe InfoProvEnt)
    -> InfoProvEnt -> Maybe InfoProvEnt
    forall a b. (a -> b) -> a -> b
    $ CLabel
    -> Int
    -> String
    -> Module
    -> Maybe (RealSrcSpan, String)
    -> InfoProvEnt
    InfoProvEnt CLabel
    cl Int
    cn (TyCon -> String
    forall a. Outputable a => a -> String
    tyString (DataCon -> TyCon
    dataConTyCon DataCon
    dc)) Module
    this_mod (Maybe (Maybe (RealSrcSpan, String)) -> Maybe (RealSrcSpan, String)
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
    join (Maybe (Maybe (RealSrcSpan, String))
     -> Maybe (RealSrcSpan, String))
    -> Maybe (Maybe (RealSrcSpan, String))
    -> Maybe (RealSrcSpan, String)
    forall a b. (a -> b) -> a -> b
    $ Int
    -> [(Int, Maybe (RealSrcSpan, String))]
    -> Maybe (Maybe (RealSrcSpan, String))
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Int
    n (NonEmpty (Int, Maybe (RealSrcSpan, String))
    -> [(Int, Maybe (RealSrcSpan, String))]
    forall a. NonEmpty a -> [a]
    NE.toList NonEmpty (Int, Maybe (RealSrcSpan, String))
    ns))

            -- This catches things like prim closure types and anything else which doesn't have a
            -- source location
            simpleFallback :: InfoProvEnt
    simpleFallback = Module -> CmmInfoTable -> InfoProvEnt
    cmmInfoTableToInfoProvEnt Module
    this_mod CmmInfoTable
    cmit

        in InfoProvEnt -> Maybe InfoProvEnt -> InfoProvEnt
    forall a. a -> Maybe a -> a
    fromMaybe InfoProvEnt
    simpleFallback (Maybe InfoProvEnt
    lookupDataConMap Maybe InfoProvEnt -> Maybe InfoProvEnt -> Maybe InfoProvEnt
    forall a. Maybe a -> Maybe a -> Maybe a
    `firstJust` Maybe InfoProvEnt
    lookupClosureMap)) [CmmInfoTable]
    defns