{-# LANGUAGE GADTs, RankNTypes #-}

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

module CmmUtils(
        -- CmmType
        primRepCmmType, slotCmmType, slotForeignHint,
        typeCmmType, typeForeignHint, primRepForeignHint,

        -- CmmLit
        zeroCLit, mkIntCLit,
        mkWordCLit, packHalfWordsCLit,
        mkByteStringCLit,
        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,

        isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,

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

        -- Statics
        blankWord,

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

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

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

import SMRep
import Cmm
import BlockId
import CLabel
import Outputable
import DynFlags
import CodeGen.Platform

import Data.Word
import Data.Bits
import Hoopl.Graph
import Hoopl.Label
import Hoopl.Block
import Hoopl.Collections

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

primRepCmmType :: DynFlags -> PrimRep -> CmmType
primRepCmmType :: DynFlags -> PrimRep -> CmmType
primRepCmmType _      VoidRep          = String -> CmmType
forall a. String -> a
panic "primRepCmmType:VoidRep"
primRepCmmType dflags :: DynFlags
dflags LiftedRep        = DynFlags -> CmmType
gcWord DynFlags
dflags
primRepCmmType dflags :: DynFlags
dflags UnliftedRep      = DynFlags -> CmmType
gcWord DynFlags
dflags
primRepCmmType dflags :: DynFlags
dflags IntRep           = DynFlags -> CmmType
bWord DynFlags
dflags
primRepCmmType dflags :: DynFlags
dflags WordRep          = DynFlags -> CmmType
bWord DynFlags
dflags
primRepCmmType _      Int8Rep          = CmmType
b8
primRepCmmType _      Word8Rep         = CmmType
b8
primRepCmmType _      Int16Rep         = CmmType
b16
primRepCmmType _      Word16Rep        = CmmType
b16
primRepCmmType _      Int64Rep         = CmmType
b64
primRepCmmType _      Word64Rep        = CmmType
b64
primRepCmmType dflags :: DynFlags
dflags AddrRep          = DynFlags -> CmmType
bWord DynFlags
dflags
primRepCmmType _      FloatRep         = CmmType
f32
primRepCmmType _      DoubleRep        = CmmType
f64
primRepCmmType _      (VecRep len :: Int
len rep :: PrimElemRep
rep) = Int -> CmmType -> CmmType
vec Int
len (PrimElemRep -> CmmType
primElemRepCmmType PrimElemRep
rep)

slotCmmType :: DynFlags -> SlotTy -> CmmType
slotCmmType :: DynFlags -> SlotTy -> CmmType
slotCmmType dflags :: DynFlags
dflags PtrSlot    = DynFlags -> CmmType
gcWord DynFlags
dflags
slotCmmType dflags :: DynFlags
dflags WordSlot   = DynFlags -> CmmType
bWord DynFlags
dflags
slotCmmType _      Word64Slot = CmmType
b64
slotCmmType _      FloatSlot  = CmmType
f32
slotCmmType _      DoubleSlot = CmmType
f64

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

typeCmmType :: DynFlags -> UnaryType -> CmmType
typeCmmType :: DynFlags -> UnaryType -> CmmType
typeCmmType dflags :: DynFlags
dflags ty :: UnaryType
ty = DynFlags -> PrimRep -> CmmType
primRepCmmType DynFlags
dflags (HasDebugCallStack => UnaryType -> PrimRep
UnaryType -> PrimRep
typePrimRep1 UnaryType
ty)

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

slotForeignHint :: SlotTy -> ForeignHint
slotForeignHint :: SlotTy -> ForeignHint
slotForeignHint PtrSlot       = ForeignHint
AddrHint
slotForeignHint WordSlot      = ForeignHint
NoHint
slotForeignHint Word64Slot    = ForeignHint
NoHint
slotForeignHint FloatSlot     = ForeignHint
NoHint
slotForeignHint DoubleSlot    = 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
. HasDebugCallStack => UnaryType -> PrimRep
UnaryType -> PrimRep
typePrimRep1

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

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

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

zeroCLit :: DynFlags -> CmmLit
zeroCLit :: DynFlags -> CmmLit
zeroCLit dflags :: DynFlags
dflags = Integer -> Width -> CmmLit
CmmInt 0 (DynFlags -> Width
wordWidth DynFlags
dflags)

zeroExpr :: DynFlags -> CmmExpr
zeroExpr :: DynFlags -> CmmExpr
zeroExpr dflags :: DynFlags
dflags = CmmLit -> CmmExpr
CmmLit (DynFlags -> CmmLit
zeroCLit DynFlags
dflags)

mkWordCLit :: DynFlags -> Integer -> CmmLit
mkWordCLit :: DynFlags -> Integer -> CmmLit
mkWordCLit dflags :: DynFlags
dflags wd :: Integer
wd = Integer -> Width -> CmmLit
CmmInt Integer
wd (DynFlags -> Width
wordWidth DynFlags
dflags)

mkByteStringCLit
  :: CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
-- We have to make a top-level decl for the string,
-- and return a literal pointing to it
mkByteStringCLit :: CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
mkByteStringCLit lbl :: CLabel
lbl bytes :: [Word8]
bytes
  = (CLabel -> CmmLit
CmmLabel CLabel
lbl, Section -> CmmStatics -> GenCmmDecl CmmStatics info stmt
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData (SectionType -> CLabel -> Section
Section SectionType
sec CLabel
lbl) (CmmStatics -> GenCmmDecl CmmStatics info stmt)
-> CmmStatics -> GenCmmDecl CmmStatics info stmt
forall a b. (a -> b) -> a -> b
$ CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
lbl [[Word8] -> CmmStatic
CmmString [Word8]
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 0 Word8 -> [Word8] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word8]
bytes then SectionType
ReadOnlyData else SectionType
CString

mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
-- Build a data-segment data block
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
mkDataLits section :: Section
section lbl :: CLabel
lbl lits :: [CmmLit]
lits
  = Section -> CmmStatics -> GenCmmDecl CmmStatics info stmt
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
section (CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
lbl ([CmmStatic] -> CmmStatics) -> [CmmStatic] -> CmmStatics
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 CmmStatics info stmt
-- Build a read-only data block
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
mkRODataLits lbl :: CLabel
lbl lits :: [CmmLit]
lits
  = Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
forall info stmt.
Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics 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 _)      = Bool
True
    needsRelocation (CmmLabelOff _ _) = Bool
True
    needsRelocation _                 = Bool
False

mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
mkStgWordCLit dflags :: DynFlags
dflags wd :: StgWord
wd = Integer -> Width -> CmmLit
CmmInt (StgWord -> Integer
fromStgWord StgWord
wd) (DynFlags -> Width
wordWidth DynFlags
dflags)

packHalfWordsCLit :: DynFlags -> 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 :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
packHalfWordsCLit dflags :: DynFlags
dflags lower_half_word :: StgHalfWord
lower_half_word upper_half_word :: StgHalfWord
upper_half_word
   = if DynFlags -> Bool
wORDS_BIGENDIAN DynFlags
dflags
     then DynFlags -> Integer -> CmmLit
mkWordCLit DynFlags
dflags ((Integer
l Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` DynFlags -> Int
hALF_WORD_SIZE_IN_BITS DynFlags
dflags) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
u)
     else DynFlags -> Integer -> CmmLit
mkWordCLit DynFlags
dflags (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` DynFlags -> Int
hALF_WORD_SIZE_IN_BITS DynFlags
dflags))
    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 lbl :: CLabel
lbl = CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
lbl)

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

cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset _ e :: CmmExpr
e                 0        = CmmExpr
e
cmmOffset _ (CmmReg reg :: CmmReg
reg)      byte_off :: Int
byte_off = CmmReg -> Int -> CmmExpr
cmmRegOff CmmReg
reg Int
byte_off
cmmOffset _ (CmmRegOff reg :: CmmReg
reg m :: Int
m) byte_off :: Int
byte_off = CmmReg -> Int -> CmmExpr
cmmRegOff CmmReg
reg (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
byte_off)
cmmOffset _ (CmmLit lit :: CmmLit
lit)      byte_off :: Int
byte_off = CmmLit -> CmmExpr
CmmLit (CmmLit -> Int -> CmmLit
cmmOffsetLit CmmLit
lit Int
byte_off)
cmmOffset _ (CmmStackSlot area :: Area
area off :: Int
off) byte_off :: Int
byte_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
cmmOffset _ (CmmMachOp (MO_Add rep :: Width
rep) [expr :: CmmExpr
expr, CmmLit (CmmInt byte_off1 :: Integer
byte_off1 _rep :: Width
_rep)]) byte_off2 :: Int
byte_off2
  = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
rep)
              [CmmExpr
expr, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
byte_off1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
byte_off2) Width
rep)]
cmmOffset dflags :: DynFlags
dflags expr :: CmmExpr
expr byte_off :: Int
byte_off
  = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
width) [CmmExpr
expr, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
byte_off) Width
width)]
  where
    width :: Width
width = DynFlags -> CmmExpr -> Width
cmmExprWidth DynFlags
dflags CmmExpr
expr

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

cmmOffsetLit :: CmmLit -> Int -> CmmLit
cmmOffsetLit :: CmmLit -> Int -> CmmLit
cmmOffsetLit (CmmLabel l :: CLabel
l)      byte_off :: Int
byte_off = CLabel -> Int -> CmmLit
cmmLabelOff CLabel
l Int
byte_off
cmmOffsetLit (CmmLabelOff l :: CLabel
l m :: Int
m) byte_off :: 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 l1 :: CLabel
l1 l2 :: CLabel
l2 m :: Int
m w :: Width
w) byte_off :: 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 m :: Integer
m rep :: Width
rep)    byte_off :: 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 _                 byte_off :: Int
byte_off = String -> SDoc -> CmmLit
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 lbl :: CLabel
lbl 0        = CLabel -> CmmLit
CmmLabel CLabel
lbl
cmmLabelOff lbl :: CLabel
lbl byte_off :: 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 :: DynFlags
         -> 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 :: DynFlags -> Width -> CmmExpr -> Int -> CmmExpr
cmmIndex dflags :: DynFlags
dflags width :: Width
width base :: CmmExpr
base idx :: Int
idx = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags 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 :: DynFlags
             -> 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 :: DynFlags -> Width -> CmmExpr -> CmmExpr -> CmmExpr
cmmIndexExpr dflags :: DynFlags
dflags width :: Width
width base :: CmmExpr
base (CmmLit (CmmInt n :: Integer
n _)) = DynFlags -> Width -> CmmExpr -> Int -> CmmExpr
cmmIndex DynFlags
dflags Width
width CmmExpr
base (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
cmmIndexExpr dflags :: DynFlags
dflags width :: Width
width base :: CmmExpr
base idx :: CmmExpr
idx =
  DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExpr DynFlags
dflags CmmExpr
base CmmExpr
byte_off
  where
    idx_w :: Width
idx_w = DynFlags -> CmmExpr -> Width
cmmExprWidth DynFlags
dflags CmmExpr
idx
    byte_off :: CmmExpr
byte_off = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Shl Width
idx_w) [CmmExpr
idx, DynFlags -> Int -> CmmExpr
mkIntExpr DynFlags
dflags (Width -> Int
widthInLog Width
width)]

cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
cmmLoadIndex dflags :: DynFlags
dflags ty :: CmmType
ty expr :: CmmExpr
expr ix :: Int
ix = CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> Width -> CmmExpr -> Int -> CmmExpr
cmmIndex DynFlags
dflags (CmmType -> Width
typeWidth CmmType
ty) CmmExpr
expr Int
ix) CmmType
ty

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

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

cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprB = DynFlags -> 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 :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
-- The second arg is a *word* offset; need to change it to bytes
cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprW dflags :: DynFlags
dflags  e :: CmmExpr
e (CmmLit (CmmInt n :: Integer
n _)) = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
dflags CmmExpr
e (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
cmmOffsetExprW dflags :: DynFlags
dflags e :: CmmExpr
e wd_off :: CmmExpr
wd_off = DynFlags -> Width -> CmmExpr -> CmmExpr -> CmmExpr
cmmIndexExpr DynFlags
dflags (DynFlags -> Width
wordWidth DynFlags
dflags) CmmExpr
e CmmExpr
wd_off

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

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

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

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

cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
cmmLoadIndexW dflags :: DynFlags
dflags base :: CmmExpr
base off :: Int
off ty :: CmmType
ty = CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
dflags CmmExpr
base Int
off) CmmType
ty

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

cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
cmmNegate _      (CmmLit (CmmInt n :: Integer
n rep :: Width
rep)) = CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (-Integer
n) Width
rep)
cmmNegate dflags :: DynFlags
dflags e :: CmmExpr
e                       = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_S_Neg (DynFlags -> CmmExpr -> Width
cmmExprWidth DynFlags
dflags CmmExpr
e)) [CmmExpr
e]

blankWord :: DynFlags -> CmmStatic
blankWord :: DynFlags -> CmmStatic
blankWord dflags :: DynFlags
dflags = Int -> CmmStatic
CmmUninitialised (DynFlags -> Int
wORD_SIZE DynFlags
dflags)

cmmToWord :: DynFlags -> CmmExpr -> CmmExpr
cmmToWord :: DynFlags -> CmmExpr -> CmmExpr
cmmToWord dflags :: DynFlags
dflags e :: 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 = DynFlags -> CmmExpr -> Width
cmmExprWidth DynFlags
dflags CmmExpr
e
    word :: Width
word = DynFlags -> Width
wordWidth DynFlags
dflags

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

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

hasNoGlobalRegs :: CmmExpr -> Bool
hasNoGlobalRegs :: CmmExpr -> Bool
hasNoGlobalRegs (CmmLoad e :: CmmExpr
e _)              = CmmExpr -> Bool
hasNoGlobalRegs CmmExpr
e
hasNoGlobalRegs (CmmMachOp _ es :: [CmmExpr]
es)           = (CmmExpr -> Bool) -> [CmmExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CmmExpr -> Bool
hasNoGlobalRegs [CmmExpr]
es
hasNoGlobalRegs (CmmLit _)                 = Bool
True
hasNoGlobalRegs (CmmReg (CmmLocal _))      = Bool
True
hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = Bool
True
hasNoGlobalRegs _ = Bool
False

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

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

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

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

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

-- Test if a closure pointer is untagged
cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr
cmmIsTagged dflags :: DynFlags
dflags e :: CmmExpr
e = DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmNeWord DynFlags
dflags (DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmAndWord DynFlags
dflags CmmExpr
e (DynFlags -> CmmExpr
cmmTagMask DynFlags
dflags)) (DynFlags -> CmmExpr
zeroExpr DynFlags
dflags)

-- Get constructor tag, but one based.
cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
cmmConstrTag1 dflags :: DynFlags
dflags e :: CmmExpr
e = DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmAndWord DynFlags
dflags CmmExpr
e (DynFlags -> CmmExpr
cmmTagMask DynFlags
dflags)


-----------------------------------------------------------------------------
-- 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 :: DynFlags -> CmmReg -> CmmReg -> Bool
regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool
regsOverlap dflags :: DynFlags
dflags (CmmGlobal g :: GlobalReg
g) (CmmGlobal g' :: GlobalReg
g')
  | Just real :: RealReg
real  <- Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe (DynFlags -> Platform
targetPlatform DynFlags
dflags) GlobalReg
g,
    Just real' :: RealReg
real' <- Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe (DynFlags -> Platform
targetPlatform DynFlags
dflags) GlobalReg
g',
    RealReg
real RealReg -> RealReg -> Bool
forall a. Eq a => a -> a -> Bool
== RealReg
real'
    = Bool
True
regsOverlap _ reg :: CmmReg
reg 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 Trac #10521 and Note
-- [Overlapping global registers].
regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool
regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool
regUsedIn dflags :: DynFlags
dflags = CmmReg -> CmmExpr -> Bool
regUsedIn_ where
  _   regUsedIn_ :: CmmReg -> CmmExpr -> Bool
`regUsedIn_` CmmLit _         = Bool
False
  reg :: CmmReg
reg `regUsedIn_` CmmLoad e :: CmmExpr
e  _     = CmmReg
reg CmmReg -> CmmExpr -> Bool
`regUsedIn_` CmmExpr
e
  reg :: CmmReg
reg `regUsedIn_` CmmReg reg' :: CmmReg
reg'      = DynFlags -> CmmReg -> CmmReg -> Bool
regsOverlap DynFlags
dflags CmmReg
reg CmmReg
reg'
  reg :: CmmReg
reg `regUsedIn_` CmmRegOff reg' :: CmmReg
reg' _ = DynFlags -> CmmReg -> CmmReg -> Bool
regsOverlap DynFlags
dflags CmmReg
reg CmmReg
reg'
  reg :: CmmReg
reg `regUsedIn_` CmmMachOp _ es :: [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
  _   `regUsedIn_` CmmStackSlot _ _ = Bool
False

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

mkLiveness :: DynFlags -> [LocalReg] -> Liveness
mkLiveness :: DynFlags -> [LocalReg] -> Liveness
mkLiveness _      [] = []
mkLiveness dflags :: DynFlags
dflags (reg :: LocalReg
reg:regs :: [LocalReg]
regs)
  = Liveness
bits Liveness -> Liveness -> Liveness
forall a. [a] -> [a] -> [a]
++ DynFlags -> [LocalReg] -> Liveness
mkLiveness DynFlags
dflags [LocalReg]
regs
  where
    sizeW :: Int
sizeW = (Width -> Int
widthInBytes (CmmType -> Width
typeWidth (LocalReg -> CmmType
localRegType LocalReg
reg)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
            Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` DynFlags -> Int
wORD_SIZE DynFlags
dflags
            -- 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 :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
modifyGraph f :: Graph n C C -> Graph n' C C
f g :: GenCmmGraph n
g = CmmGraph :: forall (n :: * -> * -> *). BlockId -> Graph n C C -> GenCmmGraph n
CmmGraph {g_entry :: BlockId
g_entry=GenCmmGraph n -> BlockId
forall (n :: * -> * -> *). 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 :: * -> * -> *). GenCmmGraph n -> Graph n C C
g_graph GenCmmGraph n
g)}

toBlockMap :: CmmGraph -> LabelMap CmmBlock
toBlockMap :: CmmGraph -> LabelMap CmmBlock
toBlockMap (CmmGraph {g_graph :: forall (n :: * -> * -> *). GenCmmGraph n -> Graph n C C
g_graph=GMany NothingO body :: LabelMap CmmBlock
body NothingO}) = LabelMap CmmBlock
body

ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap entry :: BlockId
entry bodyMap :: LabelMap CmmBlock
bodyMap = CmmGraph :: forall (n :: * -> * -> *). BlockId -> Graph n C C -> GenCmmGraph n
CmmGraph {g_entry :: BlockId
g_entry=BlockId
entry, g_graph :: Graph' Block CmmNode C C
g_graph=MaybeO C (Block CmmNode O C)
-> LabelMap CmmBlock
-> MaybeO C (Block CmmNode C O)
-> Graph' Block CmmNode C C
forall e (block :: (* -> * -> *) -> * -> * -> *) (n :: * -> * -> *)
       x.
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}

toBlockList :: CmmGraph -> [CmmBlock]
toBlockList :: CmmGraph -> [CmmBlock]
toBlockList g :: CmmGraph
g = LabelMap CmmBlock -> [CmmBlock]
forall (map :: * -> *) a. IsMap map => map a -> [a]
mapElems (LabelMap CmmBlock -> [CmmBlock])
-> LabelMap CmmBlock -> [CmmBlock]
forall a b. (a -> b) -> a -> b
$ CmmGraph -> LabelMap CmmBlock
toBlockMap CmmGraph
g

-- | like 'toBlockList', but the entry block always comes first
toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
toBlockListEntryFirst g :: CmmGraph
g
  | LabelMap CmmBlock -> 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 :: * -> * -> *). GenCmmGraph n -> BlockId
g_entry CmmGraph
g
    Just entry_block :: CmmBlock
entry_block = KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
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 (thing :: * -> * -> *) x.
NonLocal thing =>
thing C x -> BlockId
entryLabel) (LabelMap CmmBlock -> [CmmBlock]
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 cmm/CmmNode.hs. -GBM
toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]
toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]
toBlockListEntryFirstFalseFallthrough g :: CmmGraph
g
  | LabelMap CmmBlock -> 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 :: * -> * -> *). GenCmmGraph n -> BlockId
g_entry CmmGraph
g
    Just entry_block :: CmmBlock
entry_block = KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
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 _ [] = []
    dfs visited :: LabelSet
visited (block :: CmmBlock
block:bs :: [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 (thing :: * -> * -> *) x.
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block
            bs' :: [CmmBlock]
bs' = (BlockId -> [CmmBlock] -> [CmmBlock])
-> [CmmBlock] -> [BlockId] -> [CmmBlock]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr BlockId -> [CmmBlock] -> [CmmBlock]
add_id [CmmBlock]
bs (CmmBlock -> [BlockId]
forall (thing :: * -> * -> *) e.
NonLocal thing =>
thing e C -> [BlockId]
successors CmmBlock
block)
            add_id :: BlockId -> [CmmBlock] -> [CmmBlock]
add_id id :: BlockId
id bs :: [CmmBlock]
bs = case KeyOf LabelMap -> LabelMap CmmBlock -> Maybe CmmBlock
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
id LabelMap CmmBlock
m of
                              Just b :: CmmBlock
b  -> CmmBlock
b CmmBlock -> [CmmBlock] -> [CmmBlock]
forall a. a -> [a] -> [a]
: [CmmBlock]
bs
                              Nothing -> [CmmBlock]
bs

ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
ofBlockList entry :: BlockId
entry blocks :: [CmmBlock]
blocks = CmmGraph :: forall (n :: * -> * -> *). BlockId -> Graph n C C -> GenCmmGraph n
CmmGraph { g_entry :: BlockId
g_entry = BlockId
entry
                                    , g_graph :: Graph' Block CmmNode C C
g_graph = MaybeO C (Block CmmNode O C)
-> LabelMap CmmBlock
-> MaybeO C (Block CmmNode C O)
-> Graph' Block CmmNode C C
forall e (block :: (* -> * -> *) -> * -> * -> *) (n :: * -> * -> *)
       x.
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 (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (block :: * -> * -> *).
(NonLocal block, HasDebugCallStack) =>
block C C -> LabelMap (block C C) -> LabelMap (block C C)
addBlock LabelMap CmmBlock
forall (block :: (* -> * -> *) -> * -> * -> *) (n :: * -> * -> *).
Body' block n
emptyBody [CmmBlock]
blocks

bodyToBlockList :: Body CmmNode -> [CmmBlock]
bodyToBlockList :: LabelMap CmmBlock -> [CmmBlock]
bodyToBlockList body :: LabelMap CmmBlock
body = LabelMap CmmBlock -> [CmmBlock]
forall (map :: * -> *) a. IsMap map => map a -> [a]
mapElems LabelMap CmmBlock
body

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@(mf :: CmmNode C O -> CmmNode C O
mf,_,_) g :: CmmGraph
g =
  BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap (CmmNode C O -> BlockId
forall (thing :: * -> * -> *) x.
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 :: * -> * -> *). 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 (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 :: * -> * -> *) (n' :: * -> * -> *) e x.
(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 x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
mapGraphNodes1 f :: forall e x. CmmNode e x -> CmmNode e x
f = (Graph' Block CmmNode C C -> Graph' Block CmmNode C C)
-> CmmGraph -> CmmGraph
forall (n :: * -> * -> *) (n' :: * -> * -> *).
(Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
modifyGraph ((forall e x. CmmNode e x -> CmmNode e x)
-> Graph' Block CmmNode C C -> Graph' Block CmmNode C C
forall (n :: * -> * -> *) (n' :: * -> * -> *) e x.
(forall e1 x1. n e1 x1 -> n' e1 x1) -> Graph n e x -> Graph n' e x
mapGraph forall e x. CmmNode e x -> CmmNode e x
f)


foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks k :: a -> CmmBlock -> a
k z :: a
z g :: CmmGraph
g = (a -> CmmBlock -> a) -> a -> LabelMap CmmBlock -> a
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

revPostorder :: CmmGraph -> [CmmBlock]
revPostorder :: CmmGraph -> [CmmBlock]
revPostorder g :: CmmGraph
g = {-# SCC "revPostorder" #-}
    LabelMap CmmBlock -> BlockId -> [CmmBlock]
forall (block :: * -> * -> *).
NonLocal block =>
LabelMap (block C C) -> BlockId -> [block C C]
revPostorderFrom (CmmGraph -> LabelMap CmmBlock
toBlockMap CmmGraph
g) (CmmGraph -> BlockId
forall (n :: * -> * -> *). GenCmmGraph n -> BlockId
g_entry CmmGraph
g)

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

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