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

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

        cmmMkAssign,

        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 Unique
import GHC.Platform.Regs

import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
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 DynFlags
_      PrimRep
VoidRep          = String -> CmmType
forall a. String -> a
panic String
"primRepCmmType:VoidRep"
primRepCmmType DynFlags
dflags PrimRep
LiftedRep        = DynFlags -> CmmType
gcWord DynFlags
dflags
primRepCmmType DynFlags
dflags PrimRep
UnliftedRep      = DynFlags -> CmmType
gcWord DynFlags
dflags
primRepCmmType DynFlags
dflags PrimRep
IntRep           = DynFlags -> CmmType
bWord DynFlags
dflags
primRepCmmType DynFlags
dflags PrimRep
WordRep          = DynFlags -> CmmType
bWord DynFlags
dflags
primRepCmmType DynFlags
_      PrimRep
Int8Rep          = CmmType
b8
primRepCmmType DynFlags
_      PrimRep
Word8Rep         = CmmType
b8
primRepCmmType DynFlags
_      PrimRep
Int16Rep         = CmmType
b16
primRepCmmType DynFlags
_      PrimRep
Word16Rep        = CmmType
b16
primRepCmmType DynFlags
_      PrimRep
Int32Rep         = CmmType
b32
primRepCmmType DynFlags
_      PrimRep
Word32Rep        = CmmType
b32
primRepCmmType DynFlags
_      PrimRep
Int64Rep         = CmmType
b64
primRepCmmType DynFlags
_      PrimRep
Word64Rep        = CmmType
b64
primRepCmmType DynFlags
dflags PrimRep
AddrRep          = DynFlags -> CmmType
bWord DynFlags
dflags
primRepCmmType DynFlags
_      PrimRep
FloatRep         = CmmType
f32
primRepCmmType DynFlags
_      PrimRep
DoubleRep        = CmmType
f64
primRepCmmType DynFlags
_      (VecRep Int
len PrimElemRep
rep) = Int -> CmmType -> CmmType
vec Int
len (PrimElemRep -> CmmType
primElemRepCmmType PrimElemRep
rep)

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

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 :: DynFlags -> UnaryType -> CmmType
typeCmmType :: DynFlags -> UnaryType -> CmmType
typeCmmType DynFlags
dflags UnaryType
ty = DynFlags -> PrimRep -> CmmType
primRepCmmType DynFlags
dflags (HasDebugCallStack => UnaryType -> PrimRep
UnaryType -> PrimRep
typePrimRep1 UnaryType
ty)

primRepForeignHint :: PrimRep -> ForeignHint
primRepForeignHint :: PrimRep -> ForeignHint
primRepForeignHint PrimRep
VoidRep      = String -> ForeignHint
forall a. 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

slotForeignHint :: SlotTy -> ForeignHint
slotForeignHint :: SlotTy -> ForeignHint
slotForeignHint SlotTy
PtrSlot       = ForeignHint
AddrHint
slotForeignHint SlotTy
WordSlot      = ForeignHint
NoHint
slotForeignHint SlotTy
Word64Slot    = ForeignHint
NoHint
slotForeignHint SlotTy
FloatSlot     = ForeignHint
NoHint
slotForeignHint SlotTy
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 DynFlags
dflags 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 DynFlags
dflags 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 DynFlags
dflags = Integer -> Width -> CmmLit
CmmInt Integer
0 (DynFlags -> Width
wordWidth DynFlags
dflags)

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

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

mkByteStringCLit
  :: CLabel -> ByteString -> (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 -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)
mkByteStringCLit CLabel
lbl ByteString
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 [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

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 CLabel
lbl [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 CLabel
lbl [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 CLabel
_)      = Bool
True
    needsRelocation (CmmLabelOff CLabel
_ Int
_) = Bool
True
    needsRelocation CmmLit
_                 = Bool
False

mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
mkStgWordCLit DynFlags
dflags 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 DynFlags
dflags StgHalfWord
lower_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
halfWordSizeInBits 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
halfWordSizeInBits 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 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 DynFlags
dflags CmmExpr
e (CmmLit (CmmInt Integer
n Width
_)) = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
e (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
cmmOffsetExpr DynFlags
dflags CmmExpr
e 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 DynFlags
_ CmmExpr
e                 Int
0        = CmmExpr
e
cmmOffset DynFlags
_ (CmmReg CmmReg
reg)      Int
byte_off = CmmReg -> Int -> CmmExpr
cmmRegOff CmmReg
reg Int
byte_off
cmmOffset DynFlags
_ (CmmRegOff CmmReg
reg Int
m) Int
byte_off = CmmReg -> Int -> CmmExpr
cmmRegOff CmmReg
reg (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
byte_off)
cmmOffset DynFlags
_ (CmmLit CmmLit
lit)      Int
byte_off = CmmLit -> CmmExpr
CmmLit (CmmLit -> Int -> CmmLit
cmmOffsetLit CmmLit
lit Int
byte_off)
cmmOffset DynFlags
_ (CmmStackSlot Area
area Int
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 DynFlags
_ (CmmMachOp (MO_Add Width
rep) [CmmExpr
expr, CmmLit (CmmInt Integer
byte_off1 Width
_rep)]) 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 DynFlags
dflags CmmExpr
expr 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 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 :: 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 DynFlags
dflags Width
width CmmExpr
base 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 DynFlags
dflags Width
width CmmExpr
base (CmmLit (CmmInt Integer
n Width
_)) = DynFlags -> Width -> CmmExpr -> Int -> CmmExpr
cmmIndex DynFlags
dflags Width
width CmmExpr
base (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
cmmIndexExpr DynFlags
dflags Width
width CmmExpr
base 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 DynFlags
dflags CmmType
ty CmmExpr
expr 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 DynFlags
dflags  CmmExpr
e (CmmLit (CmmInt Integer
n Width
_)) = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
dflags CmmExpr
e (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
cmmOffsetExprW DynFlags
dflags CmmExpr
e 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 DynFlags
dflags CmmExpr
e 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 DynFlags
dflags CmmReg
reg 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 DynFlags
dflags CmmLit
lit 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 DynFlags
dflags CLabel
lbl 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 DynFlags
dflags CmmExpr
base Int
off 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 DynFlags
dflags  CmmExpr
e1 CmmExpr
e2 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordOr DynFlags
dflags)  [CmmExpr
e1, CmmExpr
e2]
cmmAndWord :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmAndWord DynFlags
dflags CmmExpr
e1 CmmExpr
e2 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordAnd DynFlags
dflags) [CmmExpr
e1, CmmExpr
e2]
cmmNeWord :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmNeWord DynFlags
dflags  CmmExpr
e1 CmmExpr
e2 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordNe DynFlags
dflags)  [CmmExpr
e1, CmmExpr
e2]
cmmEqWord :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmEqWord DynFlags
dflags  CmmExpr
e1 CmmExpr
e2 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordEq DynFlags
dflags)  [CmmExpr
e1, CmmExpr
e2]
cmmULtWord :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmULtWord DynFlags
dflags CmmExpr
e1 CmmExpr
e2 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordULt DynFlags
dflags) [CmmExpr
e1, CmmExpr
e2]
cmmUGeWord :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmUGeWord DynFlags
dflags CmmExpr
e1 CmmExpr
e2 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordUGe DynFlags
dflags) [CmmExpr
e1, CmmExpr
e2]
cmmUGtWord :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmUGtWord DynFlags
dflags CmmExpr
e1 CmmExpr
e2 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordUGt DynFlags
dflags) [CmmExpr
e1, CmmExpr
e2]
cmmSLtWord :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmSLtWord DynFlags
dflags CmmExpr
e1 CmmExpr
e2 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordSLt DynFlags
dflags) [CmmExpr
e1, CmmExpr
e2]
cmmUShrWord :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmUShrWord DynFlags
dflags CmmExpr
e1 CmmExpr
e2 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordUShr DynFlags
dflags) [CmmExpr
e1, CmmExpr
e2]
cmmAddWord :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmAddWord DynFlags
dflags CmmExpr
e1 CmmExpr
e2 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordAdd DynFlags
dflags) [CmmExpr
e1, CmmExpr
e2]
cmmSubWord :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmSubWord DynFlags
dflags CmmExpr
e1 CmmExpr
e2 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordSub DynFlags
dflags) [CmmExpr
e1, CmmExpr
e2]
cmmMulWord :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmMulWord DynFlags
dflags CmmExpr
e1 CmmExpr
e2 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordMul DynFlags
dflags) [CmmExpr
e1, CmmExpr
e2]
cmmQuotWord :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmQuotWord DynFlags
dflags CmmExpr
e1 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 DynFlags
_      (CmmLit (CmmInt Integer
n Width
rep)) = CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (-Integer
n) Width
rep)
cmmNegate DynFlags
dflags 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 DynFlags
dflags = Int -> CmmStatic
CmmUninitialised (DynFlags -> Int
wORD_SIZE DynFlags
dflags)

cmmToWord :: DynFlags -> CmmExpr -> CmmExpr
cmmToWord :: DynFlags -> CmmExpr -> CmmExpr
cmmToWord DynFlags
dflags 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

cmmMkAssign :: DynFlags -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)
cmmMkAssign :: DynFlags -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)
cmmMkAssign DynFlags
dflags CmmExpr
expr Unique
uq =
  let !ty :: CmmType
ty = DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags 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)


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

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

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

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

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

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

-- Tag bits mask
cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
cmmTagMask :: DynFlags -> CmmExpr
cmmTagMask DynFlags
dflags = DynFlags -> Int -> CmmExpr
mkIntExpr DynFlags
dflags (DynFlags -> Int
tAG_MASK DynFlags
dflags)
cmmPointerMask :: DynFlags -> CmmExpr
cmmPointerMask 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 DynFlags
_ e :: CmmExpr
e@(CmmLit (CmmLabel CLabel
_)) = CmmExpr
e
-- Default case
cmmUntag DynFlags
dflags 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 DynFlags
dflags 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 DynFlags
dflags 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 DynFlags
dflags (CmmGlobal GlobalReg
g) (CmmGlobal GlobalReg
g')
  | Just RealReg
real  <- Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe (DynFlags -> Platform
targetPlatform DynFlags
dflags) GlobalReg
g,
    Just 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 DynFlags
_ 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 :: DynFlags -> CmmReg -> CmmExpr -> Bool
regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool
regUsedIn DynFlags
dflags = CmmReg -> CmmExpr -> Bool
regUsedIn_ where
  CmmReg
_   regUsedIn_ :: CmmReg -> CmmExpr -> Bool
`regUsedIn_` CmmLit CmmLit
_         = Bool
False
  CmmReg
reg `regUsedIn_` CmmLoad CmmExpr
e  CmmType
_     = CmmReg
reg CmmReg -> CmmExpr -> Bool
`regUsedIn_` CmmExpr
e
  CmmReg
reg `regUsedIn_` CmmReg CmmReg
reg'      = DynFlags -> CmmReg -> CmmReg -> Bool
regsOverlap DynFlags
dflags CmmReg
reg CmmReg
reg'
  CmmReg
reg `regUsedIn_` CmmRegOff CmmReg
reg' Int
_ = DynFlags -> CmmReg -> CmmReg -> Bool
regsOverlap DynFlags
dflags 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 :: DynFlags -> [LocalReg] -> Liveness
mkLiveness :: DynFlags -> [LocalReg] -> Liveness
mkLiveness DynFlags
_      [] = []
mkLiveness DynFlags
dflags (LocalReg
reg:[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
- Int
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 Graph n C C -> Graph n' C C
f GenCmmGraph n
g = CmmGraph :: forall (n :: Extensibility -> Extensibility -> *).
BlockId -> Graph n C C -> GenCmmGraph n
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)}

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

ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap BlockId
entry LabelMap CmmBlock
bodyMap = CmmGraph :: forall (n :: Extensibility -> Extensibility -> *).
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 :: 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}

toBlockList :: CmmGraph -> [CmmBlock]
toBlockList :: CmmGraph -> [CmmBlock]
toBlockList 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 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 :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
g
    Just 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 :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
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 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 :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
g
    Just 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 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 (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
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 :: 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 (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 :: forall (n :: Extensibility -> Extensibility -> *).
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 :: 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 (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
forall (block :: Extensibility -> Extensibility -> *).
(NonLocal block, HasDebugCallStack) =>
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

bodyToBlockList :: Body CmmNode -> [CmmBlock]
bodyToBlockList :: LabelMap CmmBlock -> [CmmBlock]
bodyToBlockList 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@(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 (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 (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' Block CmmNode C C -> Graph' Block 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' Block CmmNode C C -> Graph' Block 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 forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
f)


foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks a -> CmmBlock -> a
k a
z 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 CmmGraph
g = {-# SCC "revPostorder" #-}
    LabelMap CmmBlock -> BlockId -> [CmmBlock]
forall (block :: Extensibility -> Extensibility -> *).
NonLocal block =>
LabelMap (block C C) -> BlockId -> [block C C]
revPostorderFrom (CmmGraph -> LabelMap CmmBlock
toBlockMap CmmGraph
g) (CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
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 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])
-> CmmBlock
-> IndexedCO C [CmmTickish] [CmmTickish]
-> IndexedCO C [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 forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> [CmmTickish] -> [CmmTickish]
goStmt CmmBlock
b []
  where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
        goStmt :: 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