1{-# LANGUAGE GADTs, RankNTypes #-} 2{-# LANGUAGE BangPatterns #-} 3 4----------------------------------------------------------------------------- 5-- 6-- Cmm utilities. 7-- 8-- (c) The University of Glasgow 2004-2006 9-- 10----------------------------------------------------------------------------- 11 12module CmmUtils( 13 -- CmmType 14 primRepCmmType, slotCmmType, 15 typeCmmType, typeForeignHint, primRepForeignHint, 16 17 -- CmmLit 18 zeroCLit, mkIntCLit, 19 mkWordCLit, packHalfWordsCLit, 20 mkByteStringCLit, 21 mkDataLits, mkRODataLits, 22 mkStgWordCLit, 23 24 -- CmmExpr 25 mkIntExpr, zeroExpr, 26 mkLblExpr, 27 cmmRegOff, cmmOffset, cmmLabelOff, cmmOffsetLit, cmmOffsetExpr, 28 cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB, 29 cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW, 30 cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW, 31 cmmNegate, 32 cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord, 33 cmmSLtWord, 34 cmmNeWord, cmmEqWord, 35 cmmOrWord, cmmAndWord, 36 cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord, 37 cmmToWord, 38 39 cmmMkAssign, 40 41 isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr, 42 43 baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr, 44 currentTSOExpr, currentNurseryExpr, cccsExpr, 45 46 -- Statics 47 blankWord, 48 49 -- Tagging 50 cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, 51 cmmConstrTag1, 52 53 -- Overlap and usage 54 regsOverlap, regUsedIn, 55 56 -- Liveness and bitmaps 57 mkLiveness, 58 59 -- * Operations that probably don't belong here 60 modifyGraph, 61 62 ofBlockMap, toBlockMap, 63 ofBlockList, toBlockList, bodyToBlockList, 64 toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough, 65 foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1, 66 67 -- * Ticks 68 blockTicks 69 ) where 70 71import GhcPrelude 72 73import TyCon ( PrimRep(..), PrimElemRep(..) ) 74import RepType ( UnaryType, SlotTy (..), typePrimRep1 ) 75 76import SMRep 77import Cmm 78import BlockId 79import CLabel 80import Outputable 81import DynFlags 82import Unique 83import GHC.Platform.Regs 84 85import Data.ByteString (ByteString) 86import qualified Data.ByteString as BS 87import Data.Bits 88import Hoopl.Graph 89import Hoopl.Label 90import Hoopl.Block 91import Hoopl.Collections 92 93--------------------------------------------------- 94-- 95-- CmmTypes 96-- 97--------------------------------------------------- 98 99primRepCmmType :: DynFlags -> PrimRep -> CmmType 100primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep" 101primRepCmmType dflags LiftedRep = gcWord dflags 102primRepCmmType dflags UnliftedRep = gcWord dflags 103primRepCmmType dflags IntRep = bWord dflags 104primRepCmmType dflags WordRep = bWord dflags 105primRepCmmType _ Int8Rep = b8 106primRepCmmType _ Word8Rep = b8 107primRepCmmType _ Int16Rep = b16 108primRepCmmType _ Word16Rep = b16 109primRepCmmType _ Int32Rep = b32 110primRepCmmType _ Word32Rep = b32 111primRepCmmType _ Int64Rep = b64 112primRepCmmType _ Word64Rep = b64 113primRepCmmType dflags AddrRep = bWord dflags 114primRepCmmType _ FloatRep = f32 115primRepCmmType _ DoubleRep = f64 116primRepCmmType _ (VecRep len rep) = vec len (primElemRepCmmType rep) 117 118slotCmmType :: DynFlags -> SlotTy -> CmmType 119slotCmmType dflags PtrLiftedSlot = gcWord dflags 120slotCmmType dflags PtrUnliftedSlot = gcWord dflags 121slotCmmType dflags WordSlot = bWord dflags 122slotCmmType _ Word64Slot = b64 123slotCmmType _ FloatSlot = f32 124slotCmmType _ DoubleSlot = f64 125 126primElemRepCmmType :: PrimElemRep -> CmmType 127primElemRepCmmType Int8ElemRep = b8 128primElemRepCmmType Int16ElemRep = b16 129primElemRepCmmType Int32ElemRep = b32 130primElemRepCmmType Int64ElemRep = b64 131primElemRepCmmType Word8ElemRep = b8 132primElemRepCmmType Word16ElemRep = b16 133primElemRepCmmType Word32ElemRep = b32 134primElemRepCmmType Word64ElemRep = b64 135primElemRepCmmType FloatElemRep = f32 136primElemRepCmmType DoubleElemRep = f64 137 138typeCmmType :: DynFlags -> UnaryType -> CmmType 139typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty) 140 141primRepForeignHint :: PrimRep -> ForeignHint 142primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" 143primRepForeignHint LiftedRep = AddrHint 144primRepForeignHint UnliftedRep = AddrHint 145primRepForeignHint IntRep = SignedHint 146primRepForeignHint Int8Rep = SignedHint 147primRepForeignHint Int16Rep = SignedHint 148primRepForeignHint Int32Rep = SignedHint 149primRepForeignHint Int64Rep = SignedHint 150primRepForeignHint WordRep = NoHint 151primRepForeignHint Word8Rep = NoHint 152primRepForeignHint Word16Rep = NoHint 153primRepForeignHint Word32Rep = NoHint 154primRepForeignHint Word64Rep = NoHint 155primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg 156primRepForeignHint FloatRep = NoHint 157primRepForeignHint DoubleRep = NoHint 158primRepForeignHint (VecRep {}) = NoHint 159 160typeForeignHint :: UnaryType -> ForeignHint 161typeForeignHint = primRepForeignHint . typePrimRep1 162 163--------------------------------------------------- 164-- 165-- CmmLit 166-- 167--------------------------------------------------- 168 169-- XXX: should really be Integer, since Int doesn't necessarily cover 170-- the full range of target Ints. 171mkIntCLit :: DynFlags -> Int -> CmmLit 172mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags) 173 174mkIntExpr :: DynFlags -> Int -> CmmExpr 175mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i 176 177zeroCLit :: DynFlags -> CmmLit 178zeroCLit dflags = CmmInt 0 (wordWidth dflags) 179 180zeroExpr :: DynFlags -> CmmExpr 181zeroExpr dflags = CmmLit (zeroCLit dflags) 182 183mkWordCLit :: DynFlags -> Integer -> CmmLit 184mkWordCLit dflags wd = CmmInt wd (wordWidth dflags) 185 186mkByteStringCLit 187 :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt) 188-- We have to make a top-level decl for the string, 189-- and return a literal pointing to it 190mkByteStringCLit lbl bytes 191 = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes]) 192 where 193 -- This can not happen for String literals (as there \NUL is replaced by 194 -- C0 80). However, it can happen with Addr# literals. 195 sec = if 0 `BS.elem` bytes then ReadOnlyData else CString 196 197mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt 198-- Build a data-segment data block 199mkDataLits section lbl lits 200 = CmmData section (Statics lbl $ map CmmStaticLit lits) 201 202mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt 203-- Build a read-only data block 204mkRODataLits lbl lits 205 = mkDataLits section lbl lits 206 where 207 section | any needsRelocation lits = Section RelocatableReadOnlyData lbl 208 | otherwise = Section ReadOnlyData lbl 209 needsRelocation (CmmLabel _) = True 210 needsRelocation (CmmLabelOff _ _) = True 211 needsRelocation _ = False 212 213mkStgWordCLit :: DynFlags -> StgWord -> CmmLit 214mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags) 215 216packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit 217-- Make a single word literal in which the lower_half_word is 218-- at the lower address, and the upper_half_word is at the 219-- higher address 220-- ToDo: consider using half-word lits instead 221-- but be careful: that's vulnerable when reversed 222packHalfWordsCLit dflags lower_half_word upper_half_word 223 = if wORDS_BIGENDIAN dflags 224 then mkWordCLit dflags ((l `shiftL` halfWordSizeInBits dflags) .|. u) 225 else mkWordCLit dflags (l .|. (u `shiftL` halfWordSizeInBits dflags)) 226 where l = fromStgHalfWord lower_half_word 227 u = fromStgHalfWord upper_half_word 228 229--------------------------------------------------- 230-- 231-- CmmExpr 232-- 233--------------------------------------------------- 234 235mkLblExpr :: CLabel -> CmmExpr 236mkLblExpr lbl = CmmLit (CmmLabel lbl) 237 238cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr 239-- assumes base and offset have the same CmmType 240cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n) 241cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off] 242 243cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr 244cmmOffset _ e 0 = e 245cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off 246cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off) 247cmmOffset _ (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off) 248cmmOffset _ (CmmStackSlot area off) byte_off 249 = CmmStackSlot area (off - byte_off) 250 -- note stack area offsets increase towards lower addresses 251cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2 252 = CmmMachOp (MO_Add rep) 253 [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)] 254cmmOffset dflags expr byte_off 255 = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)] 256 where 257 width = cmmExprWidth dflags expr 258 259-- Smart constructor for CmmRegOff. Same caveats as cmmOffset above. 260cmmRegOff :: CmmReg -> Int -> CmmExpr 261cmmRegOff reg 0 = CmmReg reg 262cmmRegOff reg byte_off = CmmRegOff reg byte_off 263 264cmmOffsetLit :: CmmLit -> Int -> CmmLit 265cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off 266cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off) 267cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off 268 = CmmLabelDiffOff l1 l2 (m+byte_off) w 269cmmOffsetLit (CmmInt m rep) byte_off = CmmInt (m + fromIntegral byte_off) rep 270cmmOffsetLit _ byte_off = pprPanic "cmmOffsetLit" (ppr byte_off) 271 272cmmLabelOff :: CLabel -> Int -> CmmLit 273-- Smart constructor for CmmLabelOff 274cmmLabelOff lbl 0 = CmmLabel lbl 275cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off 276 277-- | Useful for creating an index into an array, with a statically known offset. 278-- The type is the element type; used for making the multiplier 279cmmIndex :: DynFlags 280 -> Width -- Width w 281 -> CmmExpr -- Address of vector of items of width w 282 -> Int -- Which element of the vector (0 based) 283 -> CmmExpr -- Address of i'th element 284cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width) 285 286-- | Useful for creating an index into an array, with an unknown offset. 287cmmIndexExpr :: DynFlags 288 -> Width -- Width w 289 -> CmmExpr -- Address of vector of items of width w 290 -> CmmExpr -- Which element of the vector (0 based) 291 -> CmmExpr -- Address of i'th element 292cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n) 293cmmIndexExpr dflags width base idx = 294 cmmOffsetExpr dflags base byte_off 295 where 296 idx_w = cmmExprWidth dflags idx 297 byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)] 298 299cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr 300cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty 301 302-- The "B" variants take byte offsets 303cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr 304cmmRegOffB = cmmRegOff 305 306cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr 307cmmOffsetB = cmmOffset 308 309cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr 310cmmOffsetExprB = cmmOffsetExpr 311 312cmmLabelOffB :: CLabel -> ByteOff -> CmmLit 313cmmLabelOffB = cmmLabelOff 314 315cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit 316cmmOffsetLitB = cmmOffsetLit 317 318----------------------- 319-- The "W" variants take word offsets 320 321cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr 322-- The second arg is a *word* offset; need to change it to bytes 323cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n) 324cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off 325 326cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr 327cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n) 328 329cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr 330cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off) 331 332cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit 333cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off) 334 335cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit 336cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off) 337 338cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr 339cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty 340 341----------------------- 342cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord, 343 cmmSLtWord, 344 cmmNeWord, cmmEqWord, 345 cmmOrWord, cmmAndWord, 346 cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord 347 :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr 348cmmOrWord dflags e1 e2 = CmmMachOp (mo_wordOr dflags) [e1, e2] 349cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2] 350cmmNeWord dflags e1 e2 = CmmMachOp (mo_wordNe dflags) [e1, e2] 351cmmEqWord dflags e1 e2 = CmmMachOp (mo_wordEq dflags) [e1, e2] 352cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2] 353cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2] 354cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2] 355cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2] 356cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2] 357cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2] 358cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2] 359cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2] 360cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2] 361 362cmmNegate :: DynFlags -> CmmExpr -> CmmExpr 363cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) 364cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e] 365 366blankWord :: DynFlags -> CmmStatic 367blankWord dflags = CmmUninitialised (wORD_SIZE dflags) 368 369cmmToWord :: DynFlags -> CmmExpr -> CmmExpr 370cmmToWord dflags e 371 | w == word = e 372 | otherwise = CmmMachOp (MO_UU_Conv w word) [e] 373 where 374 w = cmmExprWidth dflags e 375 word = wordWidth dflags 376 377cmmMkAssign :: DynFlags -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr) 378cmmMkAssign dflags expr uq = 379 let !ty = cmmExprType dflags expr 380 reg = (CmmLocal (LocalReg uq ty)) 381 in (CmmAssign reg expr, CmmReg reg) 382 383 384--------------------------------------------------- 385-- 386-- CmmExpr predicates 387-- 388--------------------------------------------------- 389 390isTrivialCmmExpr :: CmmExpr -> Bool 391isTrivialCmmExpr (CmmLoad _ _) = False 392isTrivialCmmExpr (CmmMachOp _ _) = False 393isTrivialCmmExpr (CmmLit _) = True 394isTrivialCmmExpr (CmmReg _) = True 395isTrivialCmmExpr (CmmRegOff _ _) = True 396isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" 397 398hasNoGlobalRegs :: CmmExpr -> Bool 399hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e 400hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es 401hasNoGlobalRegs (CmmLit _) = True 402hasNoGlobalRegs (CmmReg (CmmLocal _)) = True 403hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True 404hasNoGlobalRegs _ = False 405 406isLit :: CmmExpr -> Bool 407isLit (CmmLit _) = True 408isLit _ = False 409 410isComparisonExpr :: CmmExpr -> Bool 411isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op 412isComparisonExpr _ = False 413 414--------------------------------------------------- 415-- 416-- Tagging 417-- 418--------------------------------------------------- 419 420-- Tag bits mask 421cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr 422cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags) 423cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags)) 424 425-- Used to untag a possibly tagged pointer 426-- A static label need not be untagged 427cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr 428cmmUntag _ e@(CmmLit (CmmLabel _)) = e 429-- Default case 430cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags) 431 432-- Test if a closure pointer is untagged 433cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags) 434 435-- Get constructor tag, but one based. 436cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags) 437 438 439----------------------------------------------------------------------------- 440-- Overlap and usage 441 442-- | Returns True if the two STG registers overlap on the specified 443-- platform, in the sense that writing to one will clobber the 444-- other. This includes the case that the two registers are the same 445-- STG register. See Note [Overlapping global registers] for details. 446regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool 447regsOverlap dflags (CmmGlobal g) (CmmGlobal g') 448 | Just real <- globalRegMaybe (targetPlatform dflags) g, 449 Just real' <- globalRegMaybe (targetPlatform dflags) g', 450 real == real' 451 = True 452regsOverlap _ reg reg' = reg == reg' 453 454-- | Returns True if the STG register is used by the expression, in 455-- the sense that a store to the register might affect the value of 456-- the expression. 457-- 458-- We must check for overlapping registers and not just equal 459-- registers here, otherwise CmmSink may incorrectly reorder 460-- assignments that conflict due to overlap. See #10521 and Note 461-- [Overlapping global registers]. 462regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool 463regUsedIn dflags = regUsedIn_ where 464 _ `regUsedIn_` CmmLit _ = False 465 reg `regUsedIn_` CmmLoad e _ = reg `regUsedIn_` e 466 reg `regUsedIn_` CmmReg reg' = regsOverlap dflags reg reg' 467 reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg' 468 reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es 469 _ `regUsedIn_` CmmStackSlot _ _ = False 470 471-------------------------------------------- 472-- 473-- mkLiveness 474-- 475--------------------------------------------- 476 477mkLiveness :: DynFlags -> [LocalReg] -> Liveness 478mkLiveness _ [] = [] 479mkLiveness dflags (reg:regs) 480 = bits ++ mkLiveness dflags regs 481 where 482 sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1) 483 `quot` wORD_SIZE dflags 484 -- number of words, rounded up 485 bits = replicate sizeW is_non_ptr -- True <=> Non Ptr 486 487 is_non_ptr = not $ isGcPtrType (localRegType reg) 488 489 490-- ============================================== - 491-- ============================================== - 492-- ============================================== - 493 494--------------------------------------------------- 495-- 496-- Manipulating CmmGraphs 497-- 498--------------------------------------------------- 499 500modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' 501modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} 502 503toBlockMap :: CmmGraph -> LabelMap CmmBlock 504toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body 505 506ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph 507ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} 508 509toBlockList :: CmmGraph -> [CmmBlock] 510toBlockList g = mapElems $ toBlockMap g 511 512-- | like 'toBlockList', but the entry block always comes first 513toBlockListEntryFirst :: CmmGraph -> [CmmBlock] 514toBlockListEntryFirst g 515 | mapNull m = [] 516 | otherwise = entry_block : others 517 where 518 m = toBlockMap g 519 entry_id = g_entry g 520 Just entry_block = mapLookup entry_id m 521 others = filter ((/= entry_id) . entryLabel) (mapElems m) 522 523-- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks 524-- so that the false case of a conditional jumps to the next block in the output 525-- list of blocks. This matches the way OldCmm blocks were output since in 526-- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches 527-- have both true and false successors. Block ordering can make a big difference 528-- in performance in the LLVM backend. Note that we rely crucially on the order 529-- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode 530-- defined in cmm/CmmNode.hs. -GBM 531toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock] 532toBlockListEntryFirstFalseFallthrough g 533 | mapNull m = [] 534 | otherwise = dfs setEmpty [entry_block] 535 where 536 m = toBlockMap g 537 entry_id = g_entry g 538 Just entry_block = mapLookup entry_id m 539 540 dfs :: LabelSet -> [CmmBlock] -> [CmmBlock] 541 dfs _ [] = [] 542 dfs visited (block:bs) 543 | id `setMember` visited = dfs visited bs 544 | otherwise = block : dfs (setInsert id visited) bs' 545 where id = entryLabel block 546 bs' = foldr add_id bs (successors block) 547 add_id id bs = case mapLookup id m of 548 Just b -> b : bs 549 Nothing -> bs 550 551ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph 552ofBlockList entry blocks = CmmGraph { g_entry = entry 553 , g_graph = GMany NothingO body NothingO } 554 where body = foldr addBlock emptyBody blocks 555 556bodyToBlockList :: Body CmmNode -> [CmmBlock] 557bodyToBlockList body = mapElems body 558 559mapGraphNodes :: ( CmmNode C O -> CmmNode C O 560 , CmmNode O O -> CmmNode O O 561 , CmmNode O C -> CmmNode O C) 562 -> CmmGraph -> CmmGraph 563mapGraphNodes funs@(mf,_,_) g = 564 ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $ 565 mapMap (mapBlock3' funs) $ toBlockMap g 566 567mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph 568mapGraphNodes1 f = modifyGraph (mapGraph f) 569 570 571foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a 572foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g 573 574revPostorder :: CmmGraph -> [CmmBlock] 575revPostorder g = {-# SCC "revPostorder" #-} 576 revPostorderFrom (toBlockMap g) (g_entry g) 577 578------------------------------------------------- 579-- Tick utilities 580 581-- | Extract all tick annotations from the given block 582blockTicks :: Block CmmNode C C -> [CmmTickish] 583blockTicks b = reverse $ foldBlockNodesF goStmt b [] 584 where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish] 585 goStmt (CmmTick t) ts = t:ts 586 goStmt _other ts = ts 587 588 589-- ----------------------------------------------------------------------------- 590-- Access to common global registers 591 592baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr, 593 spLimExpr, hpLimExpr, cccsExpr :: CmmExpr 594baseExpr = CmmReg baseReg 595spExpr = CmmReg spReg 596spLimExpr = CmmReg spLimReg 597hpExpr = CmmReg hpReg 598hpLimExpr = CmmReg hpLimReg 599currentTSOExpr = CmmReg currentTSOReg 600currentNurseryExpr = CmmReg currentNurseryReg 601cccsExpr = CmmReg cccsReg 602