module CmmUtils(
primRepCmmType, slotCmmType, slotForeignHint,
typeCmmType, typeForeignHint, primRepForeignHint,
zeroCLit, mkIntCLit,
mkWordCLit, packHalfWordsCLit,
mkByteStringCLit,
mkDataLits, mkRODataLits,
mkStgWordCLit,
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,
blankWord,
cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,
cmmConstrTag1,
regsOverlap, regUsedIn,
mkLiveness,
modifyGraph,
ofBlockMap, toBlockMap,
ofBlockList, toBlockList, bodyToBlockList,
toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,
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
primRepCmmType :: DynFlags -> PrimRep -> CmmType
primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep"
primRepCmmType dflags LiftedRep = gcWord dflags
primRepCmmType dflags UnliftedRep = gcWord dflags
primRepCmmType dflags IntRep = bWord dflags
primRepCmmType dflags WordRep = bWord dflags
primRepCmmType _ Int8Rep = b8
primRepCmmType _ Word8Rep = b8
primRepCmmType _ Int16Rep = b16
primRepCmmType _ Word16Rep = b16
primRepCmmType _ Int32Rep = b32
primRepCmmType _ Word32Rep = b32
primRepCmmType _ Int64Rep = b64
primRepCmmType _ Word64Rep = b64
primRepCmmType dflags AddrRep = bWord dflags
primRepCmmType _ FloatRep = f32
primRepCmmType _ DoubleRep = f64
primRepCmmType _ (VecRep len rep) = vec len (primElemRepCmmType rep)
slotCmmType :: DynFlags -> SlotTy -> CmmType
slotCmmType dflags PtrSlot = gcWord dflags
slotCmmType dflags WordSlot = bWord dflags
slotCmmType _ Word64Slot = b64
slotCmmType _ FloatSlot = f32
slotCmmType _ DoubleSlot = f64
primElemRepCmmType :: PrimElemRep -> CmmType
primElemRepCmmType Int8ElemRep = b8
primElemRepCmmType Int16ElemRep = b16
primElemRepCmmType Int32ElemRep = b32
primElemRepCmmType Int64ElemRep = b64
primElemRepCmmType Word8ElemRep = b8
primElemRepCmmType Word16ElemRep = b16
primElemRepCmmType Word32ElemRep = b32
primElemRepCmmType Word64ElemRep = b64
primElemRepCmmType FloatElemRep = f32
primElemRepCmmType DoubleElemRep = f64
typeCmmType :: DynFlags -> UnaryType -> CmmType
typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)
primRepForeignHint :: PrimRep -> ForeignHint
primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep"
primRepForeignHint LiftedRep = AddrHint
primRepForeignHint UnliftedRep = AddrHint
primRepForeignHint IntRep = SignedHint
primRepForeignHint Int8Rep = SignedHint
primRepForeignHint Int16Rep = SignedHint
primRepForeignHint Int32Rep = SignedHint
primRepForeignHint Int64Rep = SignedHint
primRepForeignHint WordRep = NoHint
primRepForeignHint Word8Rep = NoHint
primRepForeignHint Word16Rep = NoHint
primRepForeignHint Word32Rep = NoHint
primRepForeignHint Word64Rep = NoHint
primRepForeignHint AddrRep = AddrHint
primRepForeignHint FloatRep = NoHint
primRepForeignHint DoubleRep = NoHint
primRepForeignHint (VecRep {}) = NoHint
slotForeignHint :: SlotTy -> ForeignHint
slotForeignHint PtrSlot = AddrHint
slotForeignHint WordSlot = NoHint
slotForeignHint Word64Slot = NoHint
slotForeignHint FloatSlot = NoHint
slotForeignHint DoubleSlot = NoHint
typeForeignHint :: UnaryType -> ForeignHint
typeForeignHint = primRepForeignHint . typePrimRep1
mkIntCLit :: DynFlags -> Int -> CmmLit
mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
mkIntExpr :: DynFlags -> Int -> CmmExpr
mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i
zeroCLit :: DynFlags -> CmmLit
zeroCLit dflags = CmmInt 0 (wordWidth dflags)
zeroExpr :: DynFlags -> CmmExpr
zeroExpr dflags = CmmLit (zeroCLit dflags)
mkWordCLit :: DynFlags -> Integer -> CmmLit
mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)
mkByteStringCLit
:: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)
mkByteStringCLit lbl bytes
= (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])
where
sec = if 0 `BS.elem` bytes then ReadOnlyData else CString
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
mkDataLits section lbl lits
= CmmData section (Statics lbl $ map CmmStaticLit lits)
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
mkRODataLits lbl lits
= mkDataLits section lbl lits
where
section | any needsRelocation lits = Section RelocatableReadOnlyData lbl
| otherwise = Section ReadOnlyData lbl
needsRelocation (CmmLabel _) = True
needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False
mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
packHalfWordsCLit dflags lower_half_word upper_half_word
= if wORDS_BIGENDIAN dflags
then mkWordCLit dflags ((l `shiftL` halfWordSizeInBits dflags) .|. u)
else mkWordCLit dflags (l .|. (u `shiftL` halfWordSizeInBits dflags))
where l = fromStgHalfWord lower_half_word
u = fromStgHalfWord upper_half_word
mkLblExpr :: CLabel -> CmmExpr
mkLblExpr lbl = CmmLit (CmmLabel lbl)
cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n)
cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off]
cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset _ e 0 = e
cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off
cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
cmmOffset _ (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off)
cmmOffset _ (CmmStackSlot area off) byte_off
= CmmStackSlot area (off byte_off)
cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
= CmmMachOp (MO_Add rep)
[expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
cmmOffset dflags expr byte_off
= CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
where
width = cmmExprWidth dflags expr
cmmRegOff :: CmmReg -> Int -> CmmExpr
cmmRegOff reg 0 = CmmReg reg
cmmRegOff reg byte_off = CmmRegOff reg byte_off
cmmOffsetLit :: CmmLit -> Int -> CmmLit
cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off
cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off
= CmmLabelDiffOff l1 l2 (m+byte_off) w
cmmOffsetLit (CmmInt m rep) byte_off = CmmInt (m + fromIntegral byte_off) rep
cmmOffsetLit _ byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
cmmLabelOff :: CLabel -> Int -> CmmLit
cmmLabelOff lbl 0 = CmmLabel lbl
cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off
cmmIndex :: DynFlags
-> Width
-> CmmExpr
-> Int
-> CmmExpr
cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)
cmmIndexExpr :: DynFlags
-> Width
-> CmmExpr
-> CmmExpr
-> CmmExpr
cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)
cmmIndexExpr dflags width base idx =
cmmOffsetExpr dflags base byte_off
where
idx_w = cmmExprWidth dflags idx
byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]
cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty
cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
cmmRegOffB = cmmRegOff
cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB = cmmOffset
cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprB = cmmOffsetExpr
cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
cmmLabelOffB = cmmLabelOff
cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
cmmOffsetLitB = cmmOffsetLit
cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)
cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off
cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)
cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)
cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)
cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)
cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
cmmSLtWord,
cmmNeWord, cmmEqWord,
cmmOrWord, cmmAndWord,
cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
:: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOrWord dflags e1 e2 = CmmMachOp (mo_wordOr dflags) [e1, e2]
cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]
cmmNeWord dflags e1 e2 = CmmMachOp (mo_wordNe dflags) [e1, e2]
cmmEqWord dflags e1 e2 = CmmMachOp (mo_wordEq dflags) [e1, e2]
cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]
cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]
cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]
cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]
cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]
cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]
cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]
cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]
cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (n) rep)
cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
blankWord :: DynFlags -> CmmStatic
blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
cmmToWord :: DynFlags -> CmmExpr -> CmmExpr
cmmToWord dflags e
| w == word = e
| otherwise = CmmMachOp (MO_UU_Conv w word) [e]
where
w = cmmExprWidth dflags e
word = wordWidth dflags
cmmMkAssign :: DynFlags -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)
cmmMkAssign dflags expr uq =
let !ty = cmmExprType dflags expr
reg = (CmmLocal (LocalReg uq ty))
in (CmmAssign reg expr, CmmReg reg)
isTrivialCmmExpr :: CmmExpr -> Bool
isTrivialCmmExpr (CmmLoad _ _) = False
isTrivialCmmExpr (CmmMachOp _ _) = False
isTrivialCmmExpr (CmmLit _) = True
isTrivialCmmExpr (CmmReg _) = True
isTrivialCmmExpr (CmmRegOff _ _) = True
isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
hasNoGlobalRegs :: CmmExpr -> Bool
hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e
hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es
hasNoGlobalRegs (CmmLit _) = True
hasNoGlobalRegs (CmmReg (CmmLocal _)) = True
hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
hasNoGlobalRegs _ = False
isLit :: CmmExpr -> Bool
isLit (CmmLit _) = True
isLit _ = False
isComparisonExpr :: CmmExpr -> Bool
isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
isComparisonExpr _ = False
cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
cmmUntag _ e@(CmmLit (CmmLabel _)) = e
cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool
regsOverlap dflags (CmmGlobal g) (CmmGlobal g')
| Just real <- globalRegMaybe (targetPlatform dflags) g,
Just real' <- globalRegMaybe (targetPlatform dflags) g',
real == real'
= True
regsOverlap _ reg reg' = reg == reg'
regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool
regUsedIn dflags = regUsedIn_ where
_ `regUsedIn_` CmmLit _ = False
reg `regUsedIn_` CmmLoad e _ = reg `regUsedIn_` e
reg `regUsedIn_` CmmReg reg' = regsOverlap dflags reg reg'
reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'
reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es
_ `regUsedIn_` CmmStackSlot _ _ = False
mkLiveness :: DynFlags -> [LocalReg] -> Liveness
mkLiveness _ [] = []
mkLiveness dflags (reg:regs)
= bits ++ mkLiveness dflags regs
where
sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags 1)
`quot` wORD_SIZE dflags
bits = replicate sizeW is_non_ptr
is_non_ptr = not $ isGcPtrType (localRegType reg)
modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
toBlockMap :: CmmGraph -> LabelMap CmmBlock
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
toBlockList :: CmmGraph -> [CmmBlock]
toBlockList g = mapElems $ toBlockMap g
toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
toBlockListEntryFirst g
| mapNull m = []
| otherwise = entry_block : others
where
m = toBlockMap g
entry_id = g_entry g
Just entry_block = mapLookup entry_id m
others = filter ((/= entry_id) . entryLabel) (mapElems m)
toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]
toBlockListEntryFirstFalseFallthrough g
| mapNull m = []
| otherwise = dfs setEmpty [entry_block]
where
m = toBlockMap g
entry_id = g_entry g
Just entry_block = mapLookup entry_id m
dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]
dfs _ [] = []
dfs visited (block:bs)
| id `setMember` visited = dfs visited bs
| otherwise = block : dfs (setInsert id visited) bs'
where id = entryLabel block
bs' = foldr add_id bs (successors block)
add_id id bs = case mapLookup id m of
Just b -> b : bs
Nothing -> bs
ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
ofBlockList entry blocks = CmmGraph { g_entry = entry
, g_graph = GMany NothingO body NothingO }
where body = foldr addBlock emptyBody blocks
bodyToBlockList :: Body CmmNode -> [CmmBlock]
bodyToBlockList body = mapElems body
mapGraphNodes :: ( CmmNode C O -> CmmNode C O
, CmmNode O O -> CmmNode O O
, CmmNode O C -> CmmNode O C)
-> CmmGraph -> CmmGraph
mapGraphNodes funs@(mf,_,_) g =
ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $
mapMap (mapBlock3' funs) $ toBlockMap g
mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
mapGraphNodes1 f = modifyGraph (mapGraph f)
foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g
revPostorder :: CmmGraph -> [CmmBlock]
revPostorder g =
revPostorderFrom (toBlockMap g) (g_entry g)
blockTicks :: Block CmmNode C C -> [CmmTickish]
blockTicks b = reverse $ foldBlockNodesF goStmt b []
where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
goStmt (CmmTick t) ts = t:ts
goStmt _other ts = ts
baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,
spLimExpr, hpLimExpr, cccsExpr :: CmmExpr
baseExpr = CmmReg baseReg
spExpr = CmmReg spReg
spLimExpr = CmmReg spLimReg
hpExpr = CmmReg hpReg
hpLimExpr = CmmReg hpLimReg
currentTSOExpr = CmmReg currentTSOReg
currentNurseryExpr = CmmReg currentNurseryReg
cccsExpr = CmmReg cccsReg