GHC/Cmm/Utils.hs

    {-# LANGUAGE GADTs, RankNTypes #-}
    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE LambdaCase #-}

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

    -----------------------------------------------------------------------------
    --
    -- Cmm utilities.
    --
    -- (c) The University of Glasgow 2004-2006
    --
    -----------------------------------------------------------------------------

    module GHC.Cmm.Utils(
            -- CmmType
            primRepCmmType, slotCmmType,
            typeCmmType, typeForeignHint, primRepForeignHint,

            -- CmmLit
            zeroCLit, mkIntCLit,
            mkWordCLit, packHalfWordsCLit,
            mkByteStringCLit, mkFileEmbedLit,
            mkDataLits, mkRODataLits,
            mkStgWordCLit,

            -- CmmExpr
            mkIntExpr, zeroExpr,
            mkLblExpr,
            cmmRegOff,  cmmOffset,  cmmLabelOff,  cmmOffsetLit,  cmmOffsetExpr,
            cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,
            cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,
            cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,
            cmmNegate,
            cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
            cmmSLtWord,
            cmmNeWord, cmmEqWord,
            cmmOrWord, cmmAndWord,
            cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,
            cmmToWord,

            cmmMkAssign,

            isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,

            baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
            currentTSOExpr, currentNurseryExpr, cccsExpr,

            -- Tagging
            cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,
            cmmConstrTag1, mAX_PTR_TAG, tAG_MASK,

            -- Overlap and usage
            regsOverlap, regUsedIn,

            -- Liveness and bitmaps
            mkLiveness,

            -- * Operations that probably don't belong here
            modifyGraph,

            ofBlockMap, toBlockMap,
            ofBlockList, toBlockList, bodyToBlockList,
            toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
            foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,

            -- * Ticks
            blockTicks
      ) where

    import GHC.Prelude

    import GHC.Core.TyCon     ( PrimRep(..), PrimElemRep(..) )
    import GHC.Types.RepType  ( UnaryType, SlotTy (..), typePrimRep1 )

    import GHC.Platform
    import GHC.Runtime.Heap.Layout
    import GHC.Cmm
    import GHC.Cmm.BlockId
    import GHC.Cmm.CLabel
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Types.Unique
    import GHC.Platform.Regs

    import Data.ByteString (ByteString)
    import qualified Data.ByteString as BS
    import GHC.Cmm.Dataflow.Graph
    import GHC.Cmm.Dataflow.Label
    import GHC.Cmm.Dataflow.Block
    import GHC.Cmm.Dataflow.Collections

    ---------------------------------------------------
    --
    --      CmmTypes
    --
    ---------------------------------------------------

    primRepCmmType :: Platform -> PrimRep -> CmmType
    primRepCmmType platform = \case
       VoidRep          -> panic "primRepCmmType:VoidRep"
       LiftedRep        -> gcWord platform
       UnliftedRep      -> gcWord platform
       IntRep           -> bWord platform
       WordRep          -> bWord platform
       Int8Rep          -> b8
       Word8Rep         -> b8
       Int16Rep         -> b16
       Word16Rep        -> b16
       Int32Rep         -> b32
       Word32Rep        -> b32
       Int64Rep         -> b64
       Word64Rep        -> b64
       AddrRep          -> bWord platform
       FloatRep         -> f32
       DoubleRep        -> f64
       (VecRep len rep) -> vec len (primElemRepCmmType rep)

    slotCmmType :: Platform -> SlotTy -> CmmType
    slotCmmType platform = \case
       PtrUnliftedSlot -> gcWord platform
       PtrLiftedSlot   -> gcWord platform
       WordSlot        -> bWord platform
       Word64Slot      -> b64
       FloatSlot       -> f32
       DoubleSlot      -> f64

    primElemRepCmmType :: PrimElemRep -> CmmType
    primElemRepCmmType Int8ElemRep   = b8
    primElemRepCmmType Int16ElemRep  = b16
    primElemRepCmmType Int32ElemRep  = b32
    primElemRepCmmType Int64ElemRep  = b64
    primElemRepCmmType Word8ElemRep  = b8
    primElemRepCmmType Word16ElemRep = b16
    primElemRepCmmType Word32ElemRep = b32
    primElemRepCmmType Word64ElemRep = b64
    primElemRepCmmType FloatElemRep  = f32
    primElemRepCmmType DoubleElemRep = f64

    typeCmmType :: Platform -> UnaryType -> CmmType
    typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty)

    primRepForeignHint :: PrimRep -> ForeignHint
    primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"
    primRepForeignHint LiftedRep    = AddrHint
    primRepForeignHint UnliftedRep  = AddrHint
    primRepForeignHint IntRep       = SignedHint
    primRepForeignHint Int8Rep      = SignedHint
    primRepForeignHint Int16Rep     = SignedHint
    primRepForeignHint Int32Rep     = SignedHint
    primRepForeignHint Int64Rep     = SignedHint
    primRepForeignHint WordRep      = NoHint
    primRepForeignHint Word8Rep     = NoHint
    primRepForeignHint Word16Rep    = NoHint
    primRepForeignHint Word32Rep    = NoHint
    primRepForeignHint Word64Rep    = NoHint
    primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg
    primRepForeignHint FloatRep     = NoHint
    primRepForeignHint DoubleRep    = NoHint
    primRepForeignHint (VecRep {})  = NoHint

    typeForeignHint :: UnaryType -> ForeignHint
    typeForeignHint = primRepForeignHint . typePrimRep1

    ---------------------------------------------------
    --
    --      CmmLit
    --
    ---------------------------------------------------

    -- XXX: should really be Integer, since Int doesn't necessarily cover
    -- the full range of target Ints.
    mkIntCLit :: Platform -> Int -> CmmLit
    mkIntCLit platform i = CmmInt (toInteger i) (wordWidth platform)

    mkIntExpr :: Platform -> Int -> CmmExpr
    mkIntExpr platform i = CmmLit $! mkIntCLit platform i

    zeroCLit :: Platform -> CmmLit
    zeroCLit platform = CmmInt 0 (wordWidth platform)

    zeroExpr :: Platform -> CmmExpr
    zeroExpr platform = CmmLit (zeroCLit platform)

    mkWordCLit :: Platform -> Integer -> CmmLit
    mkWordCLit platform wd = CmmInt wd (wordWidth platform)

    -- | We make a top-level decl for the string, and return a label pointing to it
    mkByteStringCLit
      :: CLabel -> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
    mkByteStringCLit lbl bytes
      = (CmmLabel lbl, CmmData (Section sec lbl) $ CmmStaticsRaw lbl [CmmString bytes])
      where
        -- This can not happen for String literals (as there \NUL is replaced by
        -- C0 80). However, it can happen with Addr# literals.
        sec = if 0 `BS.elem` bytes then ReadOnlyData else CString

    -- | We make a top-level decl for the embedded binary file, and return a label pointing to it
    mkFileEmbedLit
      :: CLabel -> FilePath -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
    mkFileEmbedLit lbl path
      = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path]))

    -- | Build a data-segment data block
    mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
    mkDataLits section lbl lits
      = CmmData section (CmmStaticsRaw lbl $ map CmmStaticLit lits)

    mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
    -- Build a read-only data block
    mkRODataLits lbl lits
      = mkDataLits section lbl lits
      where
        section | any needsRelocation lits = Section RelocatableReadOnlyData lbl
                | otherwise                = Section ReadOnlyData lbl
        needsRelocation (CmmLabel _)      = True
        needsRelocation (CmmLabelOff _ _) = True
        needsRelocation _                 = False

    mkStgWordCLit :: Platform -> StgWord -> CmmLit
    mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform)

    packHalfWordsCLit :: Platform -> StgHalfWord -> StgHalfWord -> CmmLit
    -- Make a single word literal in which the lower_half_word is
    -- at the lower address, and the upper_half_word is at the
    -- higher address
    -- ToDo: consider using half-word lits instead
    --       but be careful: that's vulnerable when reversed
    packHalfWordsCLit platform lower_half_word upper_half_word
       = case platformByteOrder platform of
           BigEndian    -> mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u)
           LittleEndian -> mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform))
        where l = fromStgHalfWord lower_half_word
              u = fromStgHalfWord upper_half_word

    ---------------------------------------------------
    --
    --      CmmExpr
    --
    ---------------------------------------------------

    mkLblExpr :: CLabel -> CmmExpr
    mkLblExpr lbl = CmmLit (CmmLabel lbl)

    cmmOffsetExpr :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
    -- assumes base and offset have the same CmmType
    cmmOffsetExpr platform e (CmmLit (CmmInt n _)) = cmmOffset platform e (fromInteger n)
    cmmOffsetExpr platform e byte_off = CmmMachOp (MO_Add (cmmExprWidth platform e)) [e, byte_off]

    cmmOffset :: Platform -> CmmExpr -> Int -> CmmExpr
    cmmOffset _platform e 0        = e
    cmmOffset platform  e byte_off = case e of
       CmmReg reg            -> cmmRegOff reg byte_off
       CmmRegOff reg m       -> cmmRegOff reg (m+byte_off)
       CmmLit lit            -> CmmLit (cmmOffsetLit lit byte_off)
       CmmStackSlot area off -> CmmStackSlot area (off - byte_off)
      -- note stack area offsets increase towards lower addresses
       CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]
          -> let !lit_off = (byte_off1 + toInteger byte_off)
             in CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt lit_off rep)]
       _ -> let !width = cmmExprWidth platform e
            in
            CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)]

    -- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.
    cmmRegOff :: CmmReg -> Int -> CmmExpr
    cmmRegOff reg 0        = CmmReg reg
    cmmRegOff reg byte_off = CmmRegOff reg byte_off

    cmmOffsetLit :: CmmLit -> Int -> CmmLit
    cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off
    cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
    cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off
                                            = CmmLabelDiffOff l1 l2 (m+byte_off) w
    cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep
    cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)

    cmmLabelOff :: CLabel -> Int -> CmmLit
    -- Smart constructor for CmmLabelOff
    cmmLabelOff lbl 0        = CmmLabel lbl
    cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off

    -- | Useful for creating an index into an array, with a statically known offset.
    -- The type is the element type; used for making the multiplier
    cmmIndex :: Platform
             -> Width       -- Width w
             -> CmmExpr     -- Address of vector of items of width w
             -> Int         -- Which element of the vector (0 based)
             -> CmmExpr     -- Address of i'th element
    cmmIndex platform width base idx = cmmOffset platform base (idx * widthInBytes width)

    -- | Useful for creating an index into an array, with an unknown offset.
    cmmIndexExpr :: Platform
                 -> Width           -- Width w
                 -> CmmExpr         -- Address of vector of items of width w
                 -> CmmExpr         -- Which element of the vector (0 based)
                 -> CmmExpr         -- Address of i'th element
    cmmIndexExpr platform width base (CmmLit (CmmInt n _)) = cmmIndex platform width base (fromInteger n)
    cmmIndexExpr platform width base idx =
      cmmOffsetExpr platform base byte_off
      where
        idx_w = cmmExprWidth platform idx
        byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)]

    cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr
    cmmLoadIndex platform ty expr ix = CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty

    -- The "B" variants take byte offsets
    cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
    cmmRegOffB = cmmRegOff

    cmmOffsetB :: Platform -> CmmExpr -> ByteOff -> CmmExpr
    cmmOffsetB = cmmOffset

    cmmOffsetExprB :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
    cmmOffsetExprB = cmmOffsetExpr

    cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
    cmmLabelOffB = cmmLabelOff

    cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
    cmmOffsetLitB = cmmOffsetLit

    -----------------------
    -- The "W" variants take word offsets

    cmmOffsetExprW :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
    -- The second arg is a *word* offset; need to change it to bytes
    cmmOffsetExprW platform  e (CmmLit (CmmInt n _)) = cmmOffsetW platform e (fromInteger n)
    cmmOffsetExprW platform e wd_off = cmmIndexExpr platform (wordWidth platform) e wd_off

    cmmOffsetW :: Platform -> CmmExpr -> WordOff -> CmmExpr
    cmmOffsetW platform e n = cmmOffsetB platform e (wordsToBytes platform n)

    cmmRegOffW :: Platform -> CmmReg -> WordOff -> CmmExpr
    cmmRegOffW platform reg wd_off = cmmRegOffB reg (wordsToBytes platform wd_off)

    cmmOffsetLitW :: Platform -> CmmLit -> WordOff -> CmmLit
    cmmOffsetLitW platform lit wd_off = cmmOffsetLitB lit (wordsToBytes platform wd_off)

    cmmLabelOffW :: Platform -> CLabel -> WordOff -> CmmLit
    cmmLabelOffW platform lbl wd_off = cmmLabelOffB lbl (wordsToBytes platform wd_off)

    cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr
    cmmLoadIndexW platform base off ty = CmmLoad (cmmOffsetW platform base off) ty

    -----------------------
    cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
      cmmSLtWord,
      cmmNeWord, cmmEqWord,
      cmmOrWord, cmmAndWord,
      cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
      :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
    cmmOrWord platform  e1 e2 = CmmMachOp (mo_wordOr platform)  [e1, e2]
    cmmAndWord platform e1 e2 = CmmMachOp (mo_wordAnd platform) [e1, e2]
    cmmNeWord platform  e1 e2 = CmmMachOp (mo_wordNe platform)  [e1, e2]
    cmmEqWord platform  e1 e2 = CmmMachOp (mo_wordEq platform)  [e1, e2]
    cmmULtWord platform e1 e2 = CmmMachOp (mo_wordULt platform) [e1, e2]
    cmmUGeWord platform e1 e2 = CmmMachOp (mo_wordUGe platform) [e1, e2]
    cmmUGtWord platform e1 e2 = CmmMachOp (mo_wordUGt platform) [e1, e2]
    cmmSLtWord platform e1 e2 = CmmMachOp (mo_wordSLt platform) [e1, e2]
    cmmUShrWord platform e1 e2 = CmmMachOp (mo_wordUShr platform) [e1, e2]
    cmmAddWord platform e1 e2 = CmmMachOp (mo_wordAdd platform) [e1, e2]
    cmmSubWord platform e1 e2 = CmmMachOp (mo_wordSub platform) [e1, e2]
    cmmMulWord platform e1 e2 = CmmMachOp (mo_wordMul platform) [e1, e2]
    cmmQuotWord platform e1 e2 = CmmMachOp (mo_wordUQuot platform) [e1, e2]

    cmmNegate :: Platform -> CmmExpr -> CmmExpr
    cmmNegate platform = \case
       (CmmLit (CmmInt n rep))
         -> CmmLit (CmmInt (-n) rep)
       e -> CmmMachOp (MO_S_Neg (cmmExprWidth platform e)) [e]

    cmmToWord :: Platform -> CmmExpr -> CmmExpr
    cmmToWord platform e
      | w == word  = e
      | otherwise  = CmmMachOp (MO_UU_Conv w word) [e]
      where
        w = cmmExprWidth platform e
        word = wordWidth platform

    cmmMkAssign :: Platform -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)
    cmmMkAssign platform expr uq =
      let !ty = cmmExprType platform expr
          reg = (CmmLocal (LocalReg uq ty))
      in  (CmmAssign reg expr, CmmReg reg)

    ---------------------------------------------------
    --
    --      CmmExpr predicates
    --
    ---------------------------------------------------

    isTrivialCmmExpr :: CmmExpr -> Bool
    isTrivialCmmExpr (CmmLoad _ _)      = False
    isTrivialCmmExpr (CmmMachOp _ _)    = False
    isTrivialCmmExpr (CmmLit _)         = True
    isTrivialCmmExpr (CmmReg _)         = True
    isTrivialCmmExpr (CmmRegOff _ _)    = True
    isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"

    hasNoGlobalRegs :: CmmExpr -> Bool
    hasNoGlobalRegs (CmmLoad e _)              = hasNoGlobalRegs e
    hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es
    hasNoGlobalRegs (CmmLit _)                 = True
    hasNoGlobalRegs (CmmReg (CmmLocal _))      = True
    hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
    hasNoGlobalRegs _ = False

    isLit :: CmmExpr -> Bool
    isLit (CmmLit _) = True
    isLit _          = False

    isComparisonExpr :: CmmExpr -> Bool
    isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
    isComparisonExpr _                  = False

    ---------------------------------------------------
    --
    --      Tagging
    --
    ---------------------------------------------------

    tAG_MASK :: Platform -> Int
    tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1

    mAX_PTR_TAG :: Platform -> Int
    mAX_PTR_TAG = tAG_MASK

    -- Tag bits mask
    cmmTagMask, cmmPointerMask :: Platform -> CmmExpr
    cmmTagMask platform = mkIntExpr platform (tAG_MASK platform)
    cmmPointerMask platform = mkIntExpr platform (complement (tAG_MASK platform))

    -- Used to untag a possibly tagged pointer
    -- A static label need not be untagged
    cmmUntag, cmmIsTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr
    cmmUntag _ e@(CmmLit (CmmLabel _)) = e
    -- Default case
    cmmUntag platform e = cmmAndWord platform e (cmmPointerMask platform)

    -- Test if a closure pointer is untagged
    cmmIsTagged platform e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform)

    -- Get constructor tag, but one based.
    cmmConstrTag1 platform e = cmmAndWord platform e (cmmTagMask platform)

    -----------------------------------------------------------------------------
    -- Overlap and usage

    -- | Returns True if the two STG registers overlap on the specified
    -- platform, in the sense that writing to one will clobber the
    -- other. This includes the case that the two registers are the same
    -- STG register. See Note [Overlapping global registers] for details.
    regsOverlap :: Platform -> CmmReg -> CmmReg -> Bool
    regsOverlap platform (CmmGlobal g) (CmmGlobal g')
      | Just real  <- globalRegMaybe platform g,
        Just real' <- globalRegMaybe platform g',
        real == real'
        = True
    regsOverlap _ reg reg' = reg == reg'

    -- | Returns True if the STG register is used by the expression, in
    -- the sense that a store to the register might affect the value of
    -- the expression.
    --
    -- We must check for overlapping registers and not just equal
    -- registers here, otherwise CmmSink may incorrectly reorder
    -- assignments that conflict due to overlap. See #10521 and Note
    -- [Overlapping global registers].
    regUsedIn :: Platform -> CmmReg -> CmmExpr -> Bool
    regUsedIn platform = regUsedIn_ where
      _   `regUsedIn_` CmmLit _         = False
      reg `regUsedIn_` CmmLoad e  _     = reg `regUsedIn_` e
      reg `regUsedIn_` CmmReg reg'      = regsOverlap platform reg reg'
      reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap platform reg reg'
      reg `regUsedIn_` CmmMachOp _ es   = any (reg `regUsedIn_`) es
      _   `regUsedIn_` CmmStackSlot _ _ = False

    --------------------------------------------
    --
    --        mkLiveness
    --
    ---------------------------------------------

    mkLiveness :: Platform -> [LocalReg] -> Liveness
    mkLiveness _      [] = []
    mkLiveness platform (reg:regs)
      = bits ++ mkLiveness platform regs
      where
        word_size = platformWordSizeInBytes platform
        sizeW = (widthInBytes (typeWidth (localRegType reg)) + word_size - 1)
                `quot` word_size
                -- number of words, rounded up
        bits = replicate sizeW is_non_ptr -- True <=> Non Ptr

        is_non_ptr = not $ isGcPtrType (localRegType reg)

    -- ============================================== -
    -- ============================================== -
    -- ============================================== -

    ---------------------------------------------------
    --
    --      Manipulating CmmGraphs
    --
    ---------------------------------------------------

    modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
    modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}

    toBlockMap :: CmmGraph -> LabelMap CmmBlock
    toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body

    ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
    ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}

    toBlockList :: CmmGraph -> [CmmBlock]
    toBlockList g = mapElems $ toBlockMap g

    -- | like 'toBlockList', but the entry block always comes first
    toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
    toBlockListEntryFirst g
      | mapNull m  = []
      | otherwise  = entry_block : others
      where
        m = toBlockMap g
        entry_id = g_entry g
        Just entry_block = mapLookup entry_id m
        others = filter ((/= entry_id) . entryLabel) (mapElems m)

    -- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks
    -- so that the false case of a conditional jumps to the next block in the output
    -- list of blocks. This matches the way OldCmm blocks were output since in
    -- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches
    -- have both true and false successors. Block ordering can make a big difference
    -- in performance in the LLVM backend. Note that we rely crucially on the order
    -- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode
    -- defined in "GHC.Cmm.Node". -GBM
    toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]
    toBlockListEntryFirstFalseFallthrough g
      | mapNull m  = []
      | otherwise  = dfs setEmpty [entry_block]
      where
        m = toBlockMap g
        entry_id = g_entry g
        Just entry_block = mapLookup entry_id m

        dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]
        dfs _ [] = []
        dfs visited (block:bs)
          | id `setMember` visited = dfs visited bs
          | otherwise              = block : dfs (setInsert id visited) bs'
          where id = entryLabel block
                bs' = foldr add_id bs (successors block)
                add_id id bs = case mapLookup id m of
                                  Just b  -> b : bs
                                  Nothing -> bs

    ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
    ofBlockList entry blocks = CmmGraph { g_entry = entry
                                        , g_graph = GMany NothingO body NothingO }
      where body = foldr addBlock emptyBody blocks

    bodyToBlockList :: Body CmmNode -> [CmmBlock]
    bodyToBlockList body = mapElems body

    mapGraphNodes :: ( CmmNode C O -> CmmNode C O
                     , CmmNode O O -> CmmNode O O
                     , CmmNode O C -> CmmNode O C)
                  -> CmmGraph -> CmmGraph
    mapGraphNodes funs@(mf,_,_) g =
      ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $
      mapMap (mapBlock3' funs) $ toBlockMap g

    mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
    mapGraphNodes1 f = modifyGraph (mapGraph f)

    foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
    foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g

    revPostorder :: CmmGraph -> [CmmBlock]
    revPostorder g = {-# SCC "revPostorder" #-}
        revPostorderFrom (toBlockMap g) (g_entry g)

    -------------------------------------------------
    -- Tick utilities

    -- | Extract all tick annotations from the given block
    blockTicks :: Block CmmNode C C -> [CmmTickish]
    blockTicks b = reverse $ foldBlockNodesF goStmt b []
      where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
            goStmt  (CmmTick t) ts = t:ts
            goStmt  _other      ts = ts

    -- -----------------------------------------------------------------------------
    -- Access to common global registers

    baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,
      spLimExpr, hpLimExpr, cccsExpr :: CmmExpr
    baseExpr = CmmReg baseReg
    spExpr = CmmReg spReg
    spLimExpr = CmmReg spLimReg
    hpExpr = CmmReg hpReg
    hpLimExpr = CmmReg hpLimReg
    currentTSOExpr = CmmReg currentTSOReg
    currentNurseryExpr = CmmReg currentNurseryReg
    cccsExpr = CmmReg cccsReg