{-# 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,
        cmmLoadBWord, cmmLoadGCWord,
        cmmNegate,
        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
        cmmSLtWord,
        cmmNeWord, cmmEqWord,
        cmmOrWord, cmmAndWord,
        cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,
        cmmToWord,

        cmmMkAssign,

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

        -- Tagging
        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged,
        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,
        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
        foldlGraphBlocks, mapGraphNodes, 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 -> PrimRep -> CmmType
primRepCmmType Platform
platform = \case
   PrimRep
VoidRep          -> String -> CmmType
forall a. HasCallStack => String -> a
panic String
"primRepCmmType:VoidRep"
   PrimRep
LiftedRep        -> Platform -> CmmType
gcWord Platform
platform
   PrimRep
UnliftedRep      -> Platform -> CmmType
gcWord Platform
platform
   PrimRep
IntRep           -> Platform -> CmmType
bWord Platform
platform
   PrimRep
WordRep          -> Platform -> CmmType
bWord Platform
platform
   PrimRep
Int8Rep          -> CmmType
b8
   PrimRep
Word8Rep         -> CmmType
b8
   PrimRep
Int16Rep         -> CmmType
b16
   PrimRep
Word16Rep        -> CmmType
b16
   PrimRep
Int32Rep         -> CmmType
b32
   PrimRep
Word32Rep        -> CmmType
b32
   PrimRep
Int64Rep         -> CmmType
b64
   PrimRep
Word64Rep        -> CmmType
b64
   PrimRep
AddrRep          -> Platform -> CmmType
bWord Platform
platform
   PrimRep
FloatRep         -> CmmType
f32
   PrimRep
DoubleRep        -> CmmType
f64
   VecRep Int
len PrimElemRep
rep   -> Int -> CmmType -> CmmType
vec Int
len (PrimElemRep -> CmmType
primElemRepCmmType PrimElemRep
rep)

slotCmmType :: Platform -> SlotTy -> CmmType
slotCmmType :: Platform -> SlotTy -> CmmType
slotCmmType Platform
platform = \case
   SlotTy
PtrUnliftedSlot -> Platform -> CmmType
gcWord Platform
platform
   SlotTy
PtrLiftedSlot   -> Platform -> CmmType
gcWord Platform
platform
   SlotTy
WordSlot        -> Platform -> CmmType
bWord Platform
platform
   SlotTy
Word64Slot      -> CmmType
b64
   SlotTy
FloatSlot       -> CmmType
f32
   SlotTy
DoubleSlot      -> CmmType
f64
   VecSlot Int
l PrimElemRep
e     -> Int -> CmmType -> CmmType
vec Int
l (PrimElemRep -> CmmType
primElemRepCmmType PrimElemRep
e)

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

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

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

typeForeignHint :: UnaryType -> ForeignHint
typeForeignHint :: UnaryType -> ForeignHint
typeForeignHint = PrimRep -> ForeignHint
primRepForeignHint (PrimRep -> ForeignHint)
-> (UnaryType -> PrimRep) -> UnaryType -> ForeignHint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => UnaryType -> PrimRep
UnaryType -> PrimRep
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 -> Int -> CmmLit
mkIntCLit Platform
platform Int
i = Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
i) (Platform -> Width
wordWidth Platform
platform)

mkIntExpr :: Platform -> Int -> CmmExpr
mkIntExpr :: Platform -> Int -> CmmExpr
mkIntExpr Platform
platform Int
i = CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$! Platform -> Int -> CmmLit
mkIntCLit Platform
platform Int
i

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

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

mkWordCLit :: Platform -> Integer -> CmmLit
mkWordCLit :: Platform -> Integer -> CmmLit
mkWordCLit Platform
platform Integer
wd = Integer -> Width -> CmmLit
CmmInt Integer
wd (Platform -> Width
wordWidth Platform
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 :: forall (raw :: Bool) info stmt.
CLabel
-> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
mkByteStringCLit CLabel
lbl ByteString
bytes
  = (CLabel -> CmmLit
CmmLabel CLabel
lbl, Section
-> GenCmmStatics raw -> GenCmmDecl (GenCmmStatics raw) info stmt
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData (SectionType -> CLabel -> Section
Section SectionType
sec CLabel
lbl) (GenCmmStatics raw -> GenCmmDecl (GenCmmStatics raw) info stmt)
-> GenCmmStatics raw -> GenCmmDecl (GenCmmStatics raw) info stmt
forall a b. (a -> b) -> a -> b
$ CLabel -> [CmmStatic] -> GenCmmStatics raw
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl [ByteString -> CmmStatic
CmmString ByteString
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 :: SectionType
sec = if Word8
0 Word8 -> ByteString -> Bool
`BS.elem` ByteString
bytes then SectionType
ReadOnlyData else SectionType
CString

-- | We make a top-level decl for the embedded binary file, and return a label pointing to it
mkFileEmbedLit
  :: CLabel -> FilePath -> Int -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
mkFileEmbedLit :: forall (raw :: Bool) info stmt.
CLabel
-> String
-> Int
-> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
mkFileEmbedLit CLabel
lbl String
path Int
len
  = (CLabel -> CmmLit
CmmLabel CLabel
lbl, Section
-> GenCmmStatics raw -> GenCmmDecl (GenCmmStatics raw) info stmt
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (CLabel -> [CmmStatic] -> GenCmmStatics raw
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl [String -> Int -> CmmStatic
CmmFileEmbed String
path Int
len]))


-- | Build a data-segment data block
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
mkDataLits :: forall (raw :: Bool) info stmt.
Section
-> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
mkDataLits Section
section CLabel
lbl [CmmLit]
lits
  = Section
-> GenCmmStatics raw -> GenCmmDecl (GenCmmStatics raw) info stmt
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
section (CLabel -> [CmmStatic] -> GenCmmStatics raw
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl ([CmmStatic] -> GenCmmStatics raw)
-> [CmmStatic] -> GenCmmStatics raw
forall a b. (a -> b) -> a -> b
$ (CmmLit -> CmmStatic) -> [CmmLit] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map CmmLit -> CmmStatic
CmmStaticLit [CmmLit]
lits)

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

mkStgWordCLit :: Platform -> StgWord -> CmmLit
mkStgWordCLit :: Platform -> StgWord -> CmmLit
mkStgWordCLit Platform
platform StgWord
wd = Integer -> Width -> CmmLit
CmmInt (StgWord -> Integer
fromStgWord StgWord
wd) (Platform -> Width
wordWidth Platform
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 -> StgHalfWord -> StgHalfWord -> CmmLit
packHalfWordsCLit Platform
platform StgHalfWord
lower_half_word StgHalfWord
upper_half_word
   = case Platform -> ByteOrder
platformByteOrder Platform
platform of
       ByteOrder
BigEndian    -> Platform -> Integer -> CmmLit
mkWordCLit Platform
platform ((Integer
l Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Platform -> Int
halfWordSizeInBits Platform
platform) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
u)
       ByteOrder
LittleEndian -> Platform -> Integer -> CmmLit
mkWordCLit Platform
platform (Integer
l Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. (Integer
u Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Platform -> Int
halfWordSizeInBits Platform
platform))
    where l :: Integer
l = StgHalfWord -> Integer
fromStgHalfWord StgHalfWord
lower_half_word
          u :: Integer
u = StgHalfWord -> Integer
fromStgHalfWord StgHalfWord
upper_half_word

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

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

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

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

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

cmmOffsetLit :: CmmLit -> Int -> CmmLit
cmmOffsetLit :: CmmLit -> Int -> CmmLit
cmmOffsetLit (CmmLabel CLabel
l)      Int
byte_off = CLabel -> Int -> CmmLit
cmmLabelOff CLabel
l Int
byte_off
cmmOffsetLit (CmmLabelOff CLabel
l Int
m) Int
byte_off = CLabel -> Int -> CmmLit
cmmLabelOff CLabel
l (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
byte_off)
cmmOffsetLit (CmmLabelDiffOff CLabel
l1 CLabel
l2 Int
m Width
w) Int
byte_off
                                        = CLabel -> CLabel -> Int -> Width -> CmmLit
CmmLabelDiffOff CLabel
l1 CLabel
l2 (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
byte_off) Width
w
cmmOffsetLit (CmmInt Integer
m Width
rep)    Int
byte_off = Integer -> Width -> CmmLit
CmmInt (Integer
m Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
byte_off) Width
rep
cmmOffsetLit CmmLit
_                 Int
byte_off = String -> SDoc -> CmmLit
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"cmmOffsetLit" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
byte_off)

cmmLabelOff :: CLabel -> Int -> CmmLit
-- Smart constructor for CmmLabelOff
cmmLabelOff :: CLabel -> Int -> CmmLit
cmmLabelOff CLabel
lbl Int
0        = CLabel -> CmmLit
CmmLabel CLabel
lbl
cmmLabelOff CLabel
lbl Int
byte_off = CLabel -> Int -> CmmLit
CmmLabelOff CLabel
lbl Int
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 -> CmmExpr -> Int -> CmmExpr
cmmIndex Platform
platform Width
width CmmExpr
base Int
idx = Platform -> CmmExpr -> Int -> CmmExpr
cmmOffset Platform
platform CmmExpr
base (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Width -> Int
widthInBytes Width
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 -> CmmExpr -> CmmExpr -> CmmExpr
cmmIndexExpr Platform
platform Width
width CmmExpr
base (CmmLit (CmmInt Integer
n Width
_)) = Platform -> Width -> CmmExpr -> Int -> CmmExpr
cmmIndex Platform
platform Width
width CmmExpr
base (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
cmmIndexExpr Platform
platform Width
width CmmExpr
base CmmExpr
idx =
  Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExpr Platform
platform CmmExpr
base CmmExpr
byte_off
  where
    idx_w :: Width
idx_w = Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
idx
    byte_off :: CmmExpr
byte_off = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Shl Width
idx_w) [CmmExpr
idx, Platform -> Int -> CmmExpr
mkIntExpr Platform
platform (Width -> Int
widthInLog Width
width)]

cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr
cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr
cmmLoadIndex Platform
platform CmmType
ty CmmExpr
expr Int
ix =
    CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> Width -> CmmExpr -> Int -> CmmExpr
cmmIndex Platform
platform (CmmType -> Width
typeWidth CmmType
ty) CmmExpr
expr Int
ix) CmmType
ty AlignmentSpec
NaturallyAligned -- TODO: Audit uses

-- | Load a naturally-aligned non-pointer word.
cmmLoadBWord :: Platform -> CmmExpr -> CmmExpr
cmmLoadBWord :: Platform -> CmmExpr -> CmmExpr
cmmLoadBWord Platform
platform CmmExpr
ptr = CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
ptr (Platform -> CmmType
bWord Platform
platform) AlignmentSpec
NaturallyAligned

-- | Load a naturally-aligned GC pointer.
cmmLoadGCWord :: Platform -> CmmExpr -> CmmExpr
cmmLoadGCWord :: Platform -> CmmExpr -> CmmExpr
cmmLoadGCWord Platform
platform CmmExpr
ptr = CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
ptr (Platform -> CmmType
gcWord Platform
platform) AlignmentSpec
NaturallyAligned

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

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

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

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

cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
cmmOffsetLitB :: CmmLit -> Int -> CmmLit
cmmOffsetLitB = CmmLit -> Int -> CmmLit
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 -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprW Platform
platform  CmmExpr
e (CmmLit (CmmInt Integer
n Width
_)) = Platform -> CmmExpr -> Int -> CmmExpr
cmmOffsetW Platform
platform CmmExpr
e (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
cmmOffsetExprW Platform
platform CmmExpr
e CmmExpr
wd_off = Platform -> Width -> CmmExpr -> CmmExpr -> CmmExpr
cmmIndexExpr Platform
platform (Platform -> Width
wordWidth Platform
platform) CmmExpr
e CmmExpr
wd_off

cmmOffsetW :: Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffsetW :: Platform -> CmmExpr -> Int -> CmmExpr
cmmOffsetW Platform
platform CmmExpr
e Int
n = Platform -> CmmExpr -> Int -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
e (Platform -> Int -> Int
forall a. Num a => Platform -> a -> a
wordsToBytes Platform
platform Int
n)

cmmRegOffW :: Platform -> CmmReg -> WordOff -> CmmExpr
cmmRegOffW :: Platform -> CmmReg -> Int -> CmmExpr
cmmRegOffW Platform
platform CmmReg
reg Int
wd_off = CmmReg -> Int -> CmmExpr
cmmRegOffB CmmReg
reg (Platform -> Int -> Int
forall a. Num a => Platform -> a -> a
wordsToBytes Platform
platform Int
wd_off)

cmmOffsetLitW :: Platform -> CmmLit -> WordOff -> CmmLit
cmmOffsetLitW :: Platform -> CmmLit -> Int -> CmmLit
cmmOffsetLitW Platform
platform CmmLit
lit Int
wd_off = CmmLit -> Int -> CmmLit
cmmOffsetLitB CmmLit
lit (Platform -> Int -> Int
forall a. Num a => Platform -> a -> a
wordsToBytes Platform
platform Int
wd_off)

cmmLabelOffW :: Platform -> CLabel -> WordOff -> CmmLit
cmmLabelOffW :: Platform -> CLabel -> Int -> CmmLit
cmmLabelOffW Platform
platform CLabel
lbl Int
wd_off = CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
lbl (Platform -> Int -> Int
forall a. Num a => Platform -> a -> a
wordsToBytes Platform
platform Int
wd_off)

cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr
cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr
cmmLoadIndexW Platform
platform CmmExpr
base Int
off CmmType
ty =
    CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> CmmExpr -> Int -> CmmExpr
cmmOffsetW Platform
platform CmmExpr
base Int
off) CmmType
ty AlignmentSpec
NaturallyAligned -- TODO: Audit ses

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

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

cmmToWord :: Platform -> CmmExpr -> CmmExpr
cmmToWord :: Platform -> CmmExpr -> CmmExpr
cmmToWord Platform
platform CmmExpr
e
  | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
word  = CmmExpr
e
  | Bool
otherwise  = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv Width
w Width
word) [CmmExpr
e]
  where
    w :: Width
w = Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
e
    word :: Width
word = Platform -> Width
wordWidth Platform
platform

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


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

tAG_MASK :: Platform -> Int
tAG_MASK :: Platform -> Int
tAG_MASK Platform
platform = (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` PlatformConstants -> Int
pc_TAG_BITS (Platform -> PlatformConstants
platformConstants Platform
platform)) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

mAX_PTR_TAG :: Platform -> Int
mAX_PTR_TAG :: Platform -> Int
mAX_PTR_TAG = Platform -> Int
tAG_MASK

-- Tag bits mask
cmmTagMask, cmmPointerMask :: Platform -> CmmExpr
cmmTagMask :: Platform -> CmmExpr
cmmTagMask Platform
platform = Platform -> Int -> CmmExpr
mkIntExpr Platform
platform (Platform -> Int
tAG_MASK Platform
platform)
cmmPointerMask :: Platform -> CmmExpr
cmmPointerMask Platform
platform = Platform -> Int -> CmmExpr
mkIntExpr Platform
platform (Int -> Int
forall a. Bits a => a -> a
complement (Platform -> Int
tAG_MASK Platform
platform))

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

-- Test if a closure pointer is untagged/tagged.
cmmIsTagged :: Platform -> CmmExpr -> CmmExpr
cmmIsTagged Platform
platform CmmExpr
e = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmNeWord Platform
platform (Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmAndWord Platform
platform CmmExpr
e (Platform -> CmmExpr
cmmTagMask Platform
platform)) (Platform -> CmmExpr
zeroExpr Platform
platform)
cmmIsNotTagged :: Platform -> CmmExpr -> CmmExpr
cmmIsNotTagged Platform
platform CmmExpr
e = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmEqWord Platform
platform (Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmAndWord Platform
platform CmmExpr
e (Platform -> CmmExpr
cmmTagMask Platform
platform)) (Platform -> CmmExpr
zeroExpr Platform
platform)

-- Get constructor tag, but one based.
cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr
cmmConstrTag1 Platform
platform CmmExpr
e = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmAndWord Platform
platform CmmExpr
e (Platform -> CmmExpr
cmmTagMask Platform
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 -> CmmReg -> CmmReg -> Bool
regsOverlap Platform
platform (CmmGlobal GlobalReg
g) (CmmGlobal GlobalReg
g')
  | Just RealReg
real  <- Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform GlobalReg
g,
    Just RealReg
real' <- Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform GlobalReg
g',
    RealReg
real RealReg -> RealReg -> Bool
forall a. Eq a => a -> a -> Bool
== RealReg
real'
    = Bool
True
regsOverlap Platform
_ CmmReg
reg CmmReg
reg' = CmmReg
reg CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
== CmmReg
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 -> CmmReg -> CmmExpr -> Bool
regUsedIn Platform
platform = CmmReg -> CmmExpr -> Bool
regUsedIn_ where
  CmmReg
_   regUsedIn_ :: CmmReg -> CmmExpr -> Bool
`regUsedIn_` CmmLit CmmLit
_         = Bool
False
  CmmReg
reg `regUsedIn_` CmmLoad CmmExpr
e CmmType
_ AlignmentSpec
_    = CmmReg
reg CmmReg -> CmmExpr -> Bool
`regUsedIn_` CmmExpr
e
  CmmReg
reg `regUsedIn_` CmmReg CmmReg
reg'      = Platform -> CmmReg -> CmmReg -> Bool
regsOverlap Platform
platform CmmReg
reg CmmReg
reg'
  CmmReg
reg `regUsedIn_` CmmRegOff CmmReg
reg' Int
_ = Platform -> CmmReg -> CmmReg -> Bool
regsOverlap Platform
platform CmmReg
reg CmmReg
reg'
  CmmReg
reg `regUsedIn_` CmmMachOp MachOp
_ [CmmExpr]
es   = (CmmExpr -> Bool) -> [CmmExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CmmReg
reg CmmReg -> CmmExpr -> Bool
`regUsedIn_`) [CmmExpr]
es
  CmmReg
_   `regUsedIn_` CmmStackSlot Area
_ Int
_ = Bool
False

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

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

    is_non_ptr :: Bool
is_non_ptr = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CmmType -> Bool
isGcPtrType (LocalReg -> CmmType
localRegType LocalReg
reg)


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

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

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

ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap BlockId
entry LabelMap CmmBlock
bodyMap = CmmGraph {g_entry :: BlockId
g_entry=BlockId
entry, g_graph :: Graph CmmNode C C
g_graph=MaybeO C (Block CmmNode O C)
-> LabelMap CmmBlock
-> MaybeO C (Block CmmNode C O)
-> Graph CmmNode C C
forall (e :: Extensibility)
       (block :: (Extensibility -> Extensibility -> *)
                 -> Extensibility -> Extensibility -> *)
       (n :: Extensibility -> Extensibility -> *) (x :: Extensibility).
MaybeO e (block n O C)
-> Body' block n -> MaybeO x (block n C O) -> Graph' block n e x
GMany MaybeO C (Block CmmNode O C)
forall t. MaybeO C t
NothingO LabelMap CmmBlock
bodyMap MaybeO C (Block CmmNode C O)
forall t. MaybeO C t
NothingO}

-- | like 'toBlockList', but the entry block always comes first
toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
toBlockListEntryFirst CmmGraph
g
  | LabelMap CmmBlock -> Bool
forall a. LabelMap a -> Bool
forall (map :: * -> *) a. IsMap map => map a -> Bool
mapNull LabelMap CmmBlock
m  = []
  | Bool
otherwise  = CmmBlock
entry_block CmmBlock -> [CmmBlock] -> [CmmBlock]
forall a. a -> [a] -> [a]
: [CmmBlock]
others
  where
    m :: LabelMap CmmBlock
m = CmmGraph -> LabelMap CmmBlock
toBlockMap CmmGraph
g
    entry_id :: BlockId
entry_id = CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
g
    Just CmmBlock
entry_block = KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
entry_id LabelMap CmmBlock
m
    others :: [CmmBlock]
others = (CmmBlock -> Bool) -> [CmmBlock] -> [CmmBlock]
forall a. (a -> Bool) -> [a] -> [a]
filter ((BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockId
entry_id) (BlockId -> Bool) -> (CmmBlock -> BlockId) -> CmmBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmBlock -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel) (LabelMap CmmBlock -> [CmmBlock]
forall a. LabelMap a -> [a]
forall (map :: * -> *) a. IsMap map => map a -> [a]
mapElems LabelMap CmmBlock
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 :: CmmGraph -> [CmmBlock]
toBlockListEntryFirstFalseFallthrough CmmGraph
g
  | LabelMap CmmBlock -> Bool
forall a. LabelMap a -> Bool
forall (map :: * -> *) a. IsMap map => map a -> Bool
mapNull LabelMap CmmBlock
m  = []
  | Bool
otherwise  = LabelSet -> [CmmBlock] -> [CmmBlock]
dfs LabelSet
forall set. IsSet set => set
setEmpty [CmmBlock
entry_block]
  where
    m :: LabelMap CmmBlock
m = CmmGraph -> LabelMap CmmBlock
toBlockMap CmmGraph
g
    entry_id :: BlockId
entry_id = CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
g
    Just CmmBlock
entry_block = KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
entry_id LabelMap CmmBlock
m

    dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]
    dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]
dfs LabelSet
_ [] = []
    dfs LabelSet
visited (CmmBlock
block:[CmmBlock]
bs)
      | ElemOf LabelSet
BlockId
id ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` LabelSet
visited = LabelSet -> [CmmBlock] -> [CmmBlock]
dfs LabelSet
visited [CmmBlock]
bs
      | Bool
otherwise              = CmmBlock
block CmmBlock -> [CmmBlock] -> [CmmBlock]
forall a. a -> [a] -> [a]
: LabelSet -> [CmmBlock] -> [CmmBlock]
dfs (ElemOf LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf LabelSet
BlockId
id LabelSet
visited) [CmmBlock]
bs'
      where id :: BlockId
id = CmmBlock -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block
            bs' :: [CmmBlock]
bs' = (BlockId -> [CmmBlock] -> [CmmBlock])
-> [CmmBlock] -> [BlockId] -> [CmmBlock]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BlockId -> [CmmBlock] -> [CmmBlock]
add_id [CmmBlock]
bs (CmmBlock -> [BlockId]
forall (e :: Extensibility). Block CmmNode e C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmBlock
block)
            add_id :: BlockId -> [CmmBlock] -> [CmmBlock]
add_id BlockId
id [CmmBlock]
bs = case KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
id LabelMap CmmBlock
m of
                              Just CmmBlock
b  -> CmmBlock
b CmmBlock -> [CmmBlock] -> [CmmBlock]
forall a. a -> [a] -> [a]
: [CmmBlock]
bs
                              Maybe CmmBlock
Nothing -> [CmmBlock]
bs

ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
ofBlockList BlockId
entry [CmmBlock]
blocks = CmmGraph { g_entry :: BlockId
g_entry = BlockId
entry
                                    , g_graph :: Graph CmmNode C C
g_graph = MaybeO C (Block CmmNode O C)
-> LabelMap CmmBlock
-> MaybeO C (Block CmmNode C O)
-> Graph CmmNode C C
forall (e :: Extensibility)
       (block :: (Extensibility -> Extensibility -> *)
                 -> Extensibility -> Extensibility -> *)
       (n :: Extensibility -> Extensibility -> *) (x :: Extensibility).
MaybeO e (block n O C)
-> Body' block n -> MaybeO x (block n C O) -> Graph' block n e x
GMany MaybeO C (Block CmmNode O C)
forall t. MaybeO C t
NothingO LabelMap CmmBlock
body MaybeO C (Block CmmNode C O)
forall t. MaybeO C t
NothingO }
  where body :: LabelMap CmmBlock
body = (CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock)
-> LabelMap CmmBlock -> [CmmBlock] -> LabelMap CmmBlock
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (block :: Extensibility -> Extensibility -> *).
(NonLocal block, () :: Constraint) =>
block C C -> LabelMap (block C C) -> LabelMap (block C C)
addBlock LabelMap CmmBlock
forall (block :: (Extensibility -> Extensibility -> *)
                 -> Extensibility -> Extensibility -> *)
       (n :: Extensibility -> Extensibility -> *).
Body' block n
emptyBody [CmmBlock]
blocks

mapGraphNodes :: ( CmmNode C O -> CmmNode C O
                 , CmmNode O O -> CmmNode O O
                 , CmmNode O C -> CmmNode O C)
              -> CmmGraph -> CmmGraph
mapGraphNodes :: (CmmNode C O -> CmmNode C O, CmmNode O O -> CmmNode O O,
 CmmNode O C -> CmmNode O C)
-> CmmGraph -> CmmGraph
mapGraphNodes funs :: (CmmNode C O -> CmmNode C O, CmmNode O O -> CmmNode O O,
 CmmNode O C -> CmmNode O C)
funs@(CmmNode C O -> CmmNode C O
mf,CmmNode O O -> CmmNode O O
_,CmmNode O C -> CmmNode O C
_) CmmGraph
g =
  BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap (CmmNode C O -> BlockId
forall (x :: Extensibility). CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel (CmmNode C O -> BlockId) -> CmmNode C O -> BlockId
forall a b. (a -> b) -> a -> b
$ CmmNode C O -> CmmNode C O
mf (CmmNode C O -> CmmNode C O) -> CmmNode C O -> CmmNode C O
forall a b. (a -> b) -> a -> b
$ BlockId -> CmmTickScope -> CmmNode C O
CmmEntry (CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
g) CmmTickScope
GlobalScope) (LabelMap CmmBlock -> CmmGraph) -> LabelMap CmmBlock -> CmmGraph
forall a b. (a -> b) -> a -> b
$
  (CmmBlock -> CmmBlock) -> LabelMap CmmBlock -> LabelMap CmmBlock
forall a b. (a -> b) -> LabelMap a -> LabelMap b
forall (map :: * -> *) a b. IsMap map => (a -> b) -> map a -> map b
mapMap ((CmmNode C O -> CmmNode C O, CmmNode O O -> CmmNode O O,
 CmmNode O C -> CmmNode O C)
-> CmmBlock -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *)
       (n' :: Extensibility -> Extensibility -> *) (e :: Extensibility)
       (x :: Extensibility).
(n C O -> n' C O, n O O -> n' O O, n O C -> n' O C)
-> Block n e x -> Block n' e x
mapBlock3' (CmmNode C O -> CmmNode C O, CmmNode O O -> CmmNode O O,
 CmmNode O C -> CmmNode O C)
funs) (LabelMap CmmBlock -> LabelMap CmmBlock)
-> LabelMap CmmBlock -> LabelMap CmmBlock
forall a b. (a -> b) -> a -> b
$ CmmGraph -> LabelMap CmmBlock
toBlockMap CmmGraph
g

mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
mapGraphNodes1 :: (forall (e :: Extensibility) (x :: Extensibility).
 CmmNode e x -> CmmNode e x)
-> CmmGraph -> CmmGraph
mapGraphNodes1 forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
f = (Graph CmmNode C C -> Graph CmmNode C C) -> CmmGraph -> CmmGraph
forall (n :: Extensibility -> Extensibility -> *)
       (n' :: Extensibility -> Extensibility -> *).
(Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
modifyGraph ((forall (e :: Extensibility) (x :: Extensibility).
 CmmNode e x -> CmmNode e x)
-> Graph CmmNode C C -> Graph CmmNode C C
forall (n :: Extensibility -> Extensibility -> *)
       (n' :: Extensibility -> Extensibility -> *) (e :: Extensibility)
       (x :: Extensibility).
(forall (e1 :: Extensibility) (x1 :: Extensibility).
 n e1 x1 -> n' e1 x1)
-> Graph n e x -> Graph n' e x
mapGraph CmmNode e1 x1 -> CmmNode e1 x1
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
f)


foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks :: forall a. (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks a -> CmmBlock -> a
k a
z CmmGraph
g = (a -> CmmBlock -> a) -> a -> LabelMap CmmBlock -> a
forall b a. (b -> a -> b) -> b -> LabelMap a -> b
forall (map :: * -> *) b a.
IsMap map =>
(b -> a -> b) -> b -> map a -> b
mapFoldl a -> CmmBlock -> a
k a
z (LabelMap CmmBlock -> a) -> LabelMap CmmBlock -> a
forall a b. (a -> b) -> a -> b
$ CmmGraph -> LabelMap CmmBlock
toBlockMap CmmGraph
g

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

-- | Extract all tick annotations from the given block
blockTicks :: Block CmmNode C C -> [CmmTickish]
blockTicks :: CmmBlock -> [CmmTickish]
blockTicks CmmBlock
b = [CmmTickish] -> [CmmTickish]
forall a. [a] -> [a]
reverse ([CmmTickish] -> [CmmTickish]) -> [CmmTickish] -> [CmmTickish]
forall a b. (a -> b) -> a -> b
$ (forall (e :: Extensibility) (x :: Extensibility).
 CmmNode e x -> [CmmTickish] -> [CmmTickish])
-> forall (e :: Extensibility) (x :: Extensibility).
   Block CmmNode e x
   -> IndexedCO e [CmmTickish] [CmmTickish]
   -> IndexedCO x [CmmTickish] [CmmTickish]
forall (n :: Extensibility -> Extensibility -> *) a.
(forall (e :: Extensibility) (x :: Extensibility). n e x -> a -> a)
-> forall (e :: Extensibility) (x :: Extensibility).
   Block n e x -> IndexedCO e a a -> IndexedCO x a a
foldBlockNodesF CmmNode e x -> [CmmTickish] -> [CmmTickish]
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> [CmmTickish] -> [CmmTickish]
goStmt CmmBlock
b []
  where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
        goStmt :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> [CmmTickish] -> [CmmTickish]
goStmt  (CmmTick CmmTickish
t) [CmmTickish]
ts = CmmTickish
tCmmTickish -> [CmmTickish] -> [CmmTickish]
forall a. a -> [a] -> [a]
:[CmmTickish]
ts
        goStmt  CmmNode e x
_other      [CmmTickish]
ts = [CmmTickish]
ts


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

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