CmmUtils.hs 21 KB
Newer Older
1
{-# LANGUAGE CPP, GADTs, RankNTypes #-}
Ian Lynagh's avatar
Ian Lynagh committed
2

3 4 5 6
-----------------------------------------------------------------------------
--
-- Cmm utilities.
--
Simon Marlow's avatar
Simon Marlow committed
7
-- (c) The University of Glasgow 2004-2006
8 9 10
--
-----------------------------------------------------------------------------

11
module CmmUtils(
12
        -- CmmType
13
        primRepCmmType, slotCmmType, slotForeignHint,
14
        typeCmmType, typeForeignHint, primRepForeignHint,
15

16
        -- CmmLit
17
        zeroCLit, mkIntCLit,
18 19
        mkWordCLit, packHalfWordsCLit,
        mkByteStringCLit,
20
        mkDataLits, mkRODataLits,
21
        mkStgWordCLit,
22

23
        -- CmmExpr
24 25
        mkIntExpr, zeroExpr,
        mkLblExpr,
26 27 28 29 30
        cmmRegOff,  cmmOffset,  cmmLabelOff,  cmmOffsetLit,  cmmOffsetExpr,
        cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,
        cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,
        cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,
        cmmNegate,
31 32 33 34 35
        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
        cmmSLtWord,
        cmmNeWord, cmmEqWord,
        cmmOrWord, cmmAndWord,
        cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,
36
        cmmToWord,
37

38
        isTrivialCmmExpr, hasNoGlobalRegs,
39

40 41 42 43
        -- Statics
        blankWord,

        -- Tagging
44 45
        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,
        cmmConstrTag1,
46

47 48 49
        -- Overlap and usage
        regsOverlap, regUsedIn,

50 51
        -- Liveness and bitmaps
        mkLiveness,
52

53 54 55 56
        -- * Operations that probably don't belong here
        modifyGraph,

        ofBlockMap, toBlockMap, insertBlock,
57 58
        ofBlockList, toBlockList, bodyToBlockList,
        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
59
        foldlGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
60

Peter Wortmann's avatar
Peter Wortmann committed
61
        -- * Ticks
Peter Wortmann's avatar
Peter Wortmann committed
62
        blockTicks
63 64 65 66
  ) where

#include "HsVersions.h"

67 68
import GhcPrelude

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

72 73 74
import SMRep
import Cmm
import BlockId
Simon Marlow's avatar
Simon Marlow committed
75
import CLabel
76
import Outputable
77
import DynFlags
78
import Util
79
import CodeGen.Platform
80 81 82 83

import Data.Word
import Data.Maybe
import Data.Bits
84 85 86 87
import Hoopl.Graph
import Hoopl.Label
import Hoopl.Block
import Hoopl.Collections
88

89 90
---------------------------------------------------
--
91
--      CmmTypes
92 93 94
--
---------------------------------------------------

95
primRepCmmType :: DynFlags -> PrimRep -> CmmType
96
primRepCmmType _      VoidRep          = panic "primRepCmmType:VoidRep"
97 98
primRepCmmType dflags LiftedRep        = gcWord dflags
primRepCmmType dflags UnliftedRep      = gcWord dflags
99 100 101 102 103 104 105 106 107
primRepCmmType dflags IntRep           = bWord dflags
primRepCmmType dflags WordRep          = bWord dflags
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)

108 109 110 111 112 113 114
slotCmmType :: DynFlags -> SlotTy -> CmmType
slotCmmType dflags PtrSlot    = gcWord dflags
slotCmmType dflags WordSlot   = bWord dflags
slotCmmType _      Word64Slot = b64
slotCmmType _      FloatSlot  = f32
slotCmmType _      DoubleSlot = f64

115 116 117 118 119 120 121 122 123 124 125
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
126

127
typeCmmType :: DynFlags -> UnaryType -> CmmType
128
typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)
129 130

primRepForeignHint :: PrimRep -> ForeignHint
131
primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"
132 133
primRepForeignHint LiftedRep    = AddrHint
primRepForeignHint UnliftedRep  = AddrHint
134 135 136 137
primRepForeignHint IntRep       = SignedHint
primRepForeignHint WordRep      = NoHint
primRepForeignHint Int64Rep     = SignedHint
primRepForeignHint Word64Rep    = NoHint
138
primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg
139 140
primRepForeignHint FloatRep     = NoHint
primRepForeignHint DoubleRep    = NoHint
141
primRepForeignHint (VecRep {})  = NoHint
142

143 144 145 146 147 148 149
slotForeignHint :: SlotTy -> ForeignHint
slotForeignHint PtrSlot       = AddrHint
slotForeignHint WordSlot      = NoHint
slotForeignHint Word64Slot    = NoHint
slotForeignHint FloatSlot     = NoHint
slotForeignHint DoubleSlot    = NoHint

150
typeForeignHint :: UnaryType -> ForeignHint
151
typeForeignHint = primRepForeignHint . typePrimRep1
152

153 154
---------------------------------------------------
--
155
--      CmmLit
156 157 158
--
---------------------------------------------------

159 160
-- XXX: should really be Integer, since Int doesn't necessarily cover
-- the full range of target Ints.
161 162
mkIntCLit :: DynFlags -> Int -> CmmLit
mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
163

164 165
mkIntExpr :: DynFlags -> Int -> CmmExpr
mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i
166

167 168
zeroCLit :: DynFlags -> CmmLit
zeroCLit dflags = CmmInt 0 (wordWidth dflags)
169

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

173 174 175
mkWordCLit :: DynFlags -> Integer -> CmmLit
mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)

176 177
mkByteStringCLit
  :: CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
178
-- We have to make a top-level decl for the string,
179
-- and return a literal pointing to it
180 181
mkByteStringCLit lbl bytes
  = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])
182
  where
183 184 185 186
    -- This can not happen for String literals (as there \NUL is replaced by
    -- C0 80). However, it can happen with Addr# literals.
    sec = if 0 `elem` bytes then ReadOnlyData else CString

Simon Peyton Jones's avatar
Simon Peyton Jones committed
187
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
188 189 190 191
-- Build a data-segment data block
mkDataLits section lbl lits
  = CmmData section (Statics lbl $ map CmmStaticLit lits)

Simon Peyton Jones's avatar
Simon Peyton Jones committed
192
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
193 194 195
-- Build a read-only data block
mkRODataLits lbl lits
  = mkDataLits section lbl lits
196
  where
197 198
    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl
            | otherwise                = Section ReadOnlyData lbl
199 200 201 202
    needsRelocation (CmmLabel _)      = True
    needsRelocation (CmmLabelOff _ _) = True
    needsRelocation _                 = False

203 204
mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
205

206
packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
207
-- Make a single word literal in which the lower_half_word is
208
-- at the lower address, and the upper_half_word is at the
209 210
-- higher address
-- ToDo: consider using half-word lits instead
211
--       but be careful: that's vulnerable when reversed
212
packHalfWordsCLit dflags lower_half_word upper_half_word
213
   = if wORDS_BIGENDIAN dflags
214 215
     then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u)
     else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags))
216 217
    where l = fromStgHalfWord lower_half_word
          u = fromStgHalfWord upper_half_word
218

219 220
---------------------------------------------------
--
221
--      CmmExpr
222 223 224
--
---------------------------------------------------

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

228
cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
229
-- assumes base and offset have the same CmmType
230 231
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]
232

233 234 235 236 237
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)
238 239 240
cmmOffset _ (CmmStackSlot area off) byte_off
  = CmmStackSlot area (off - byte_off)
  -- note stack area offsets increase towards lower addresses
241
cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
242 243
  = CmmMachOp (MO_Add rep)
              [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
244
cmmOffset dflags expr byte_off
245
  = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
246
  where
247
    width = cmmExprWidth dflags expr
248 249 250

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

cmmOffsetLit :: CmmLit -> Int -> CmmLit
255 256
cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off
cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
257 258
cmmOffsetLit (CmmLabelDiffOff l1 l2 m) byte_off
                                        = CmmLabelDiffOff l1 l2 (m+byte_off)
259
cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep
260
cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
261 262 263 264 265 266

cmmLabelOff :: CLabel -> Int -> CmmLit
-- Smart constructor for CmmLabelOff
cmmLabelOff lbl 0        = CmmLabel lbl
cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off

Gabor Greif's avatar
Gabor Greif committed
267
-- | Useful for creating an index into an array, with a statically known offset.
268
-- The type is the element type; used for making the multiplier
269 270
cmmIndex :: DynFlags
         -> Width       -- Width w
271 272 273
         -> CmmExpr     -- Address of vector of items of width w
         -> Int         -- Which element of the vector (0 based)
         -> CmmExpr     -- Address of i'th element
274
cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)
275 276

-- | Useful for creating an index into an array, with an unknown offset.
277 278
cmmIndexExpr :: DynFlags
             -> Width           -- Width w
279 280 281
             -> CmmExpr         -- Address of vector of items of width w
             -> CmmExpr         -- Which element of the vector (0 based)
             -> CmmExpr         -- Address of i'th element
282 283 284
cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)
cmmIndexExpr dflags width base idx =
  cmmOffsetExpr dflags base byte_off
285
  where
286
    idx_w = cmmExprWidth dflags idx
287
    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]
288

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

292 293 294 295
-- The "B" variants take byte offsets
cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
cmmRegOffB = cmmRegOff

296
cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
297 298
cmmOffsetB = cmmOffset

299
cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
300 301 302 303 304 305 306 307 308 309
cmmOffsetExprB = cmmOffsetExpr

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

cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
cmmOffsetLitB = cmmOffsetLit

-----------------------
-- The "W" variants take word offsets
310

311
cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
312
-- The second arg is a *word* offset; need to change it to bytes
313
cmmOffsetExprW dflags  e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)
314
cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off
315

316
cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
317
cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)
318

319
cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
320
cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)
321

322
cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
323
cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)
324

325
cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
326
cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)
327

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

-----------------------
332 333 334 335 336
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
  cmmSLtWord,
  cmmNeWord, cmmEqWord,
  cmmOrWord, cmmAndWord,
  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
337 338 339 340 341 342 343 344
  :: 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]
345
cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
346 347 348 349 350
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]
351

352 353 354
cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
cmmNegate _      (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
cmmNegate dflags e                       = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
355

356 357
blankWord :: DynFlags -> CmmStatic
blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
358

359 360 361 362 363 364 365 366
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

367 368
---------------------------------------------------
--
369
--      CmmExpr predicates
370 371 372
--
---------------------------------------------------

373
isTrivialCmmExpr :: CmmExpr -> Bool
374 375 376 377 378
isTrivialCmmExpr (CmmLoad _ _)      = False
isTrivialCmmExpr (CmmMachOp _ _)    = False
isTrivialCmmExpr (CmmLit _)         = True
isTrivialCmmExpr (CmmReg _)         = True
isTrivialCmmExpr (CmmRegOff _ _)    = True
379
isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
380

381
hasNoGlobalRegs :: CmmExpr -> Bool
382 383 384
hasNoGlobalRegs (CmmLoad e _)              = hasNoGlobalRegs e
hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es
hasNoGlobalRegs (CmmLit _)                 = True
385 386 387
hasNoGlobalRegs (CmmReg (CmmLocal _))      = True
hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
hasNoGlobalRegs _ = False
388

389 390
---------------------------------------------------
--
391
--      Tagging
392 393 394 395
--
---------------------------------------------------

-- Tag bits mask
396
cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
397 398
cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
399 400 401

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

-- Test if a closure pointer is untagged
408
cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
409 410

-- Get constructor tag, but one based.
411
cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
412 413


414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445
-----------------------------------------------------------------------------
-- 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 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'

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

446 447 448 449 450 451
--------------------------------------------
--
--        mkLiveness
--
---------------------------------------------

452 453 454 455
mkLiveness :: DynFlags -> [Maybe LocalReg] -> Liveness
mkLiveness _      [] = []
mkLiveness dflags (reg:regs)
  = take sizeW bits ++ mkLiveness dflags regs
456 457 458
  where
    sizeW = case reg of
              Nothing -> 1
459 460
              Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE dflags - 1)
                        `quot` wORD_SIZE dflags
461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480
                        -- number of words, rounded up
    bits = repeat $ is_non_ptr reg -- True <=> Non Ptr

    is_non_ptr Nothing    = True
    is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg)


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

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

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)}

481
toBlockMap :: CmmGraph -> LabelMap CmmBlock
482 483
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body

484
ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
485 486
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}

487
insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
488
insertBlock block map =
489
  ASSERT(isNothing $ mapLookup id map)
490 491 492 493 494 495
  mapInsert id block map
  where id = entryLabel block

toBlockList :: CmmGraph -> [CmmBlock]
toBlockList g = mapElems $ toBlockMap g

496 497 498 499 500 501 502 503 504 505 506
-- | like 'toBlockList', but the entry block always comes first
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)

507 508 509 510 511 512 513
-- | 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
514
-- defined in cmm/CmmNode.hs. -GBM
515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534
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

535
ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
Simon Marlow's avatar
Simon Marlow committed
536 537
ofBlockList entry blocks = CmmGraph { g_entry = entry
                                    , g_graph = GMany NothingO body NothingO }
538 539 540 541 542 543 544 545 546 547
  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 =
Peter Wortmann's avatar
Peter Wortmann committed
548 549
  ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $
  mapMap (mapBlock3' funs) $ toBlockMap g
550

551
mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
552
mapGraphNodes1 f = modifyGraph (mapGraph f)
553 554


555 556
foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g
557 558

postorderDfs :: CmmGraph -> [CmmBlock]
Simon Marlow's avatar
Simon Marlow committed
559
postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g)
560

Peter Wortmann's avatar
Peter Wortmann committed
561 562 563 564 565 566 567 568 569
-------------------------------------------------
-- Tick utilities

-- | Extract all tick annotations from the given block
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