CmmUtils.hs 20.8 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,
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
        foldGraphBlocks, 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
import TyCon    ( PrimRep(..), PrimElemRep(..) )
68
import RepType  ( UnaryType, SlotTy (..), typePrimRep )
69

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

import Data.Word
import Data.Maybe
import Data.Bits
Simon Marlow's avatar
Simon Marlow committed
83
import Hoopl
84

85 86
---------------------------------------------------
--
87
--      CmmTypes
88 89 90
--
---------------------------------------------------

91
primRepCmmType :: DynFlags -> PrimRep -> CmmType
92 93 94 95 96 97 98 99 100 101 102
primRepCmmType _      VoidRep          = panic "primRepCmmType:VoidRep"
primRepCmmType dflags PtrRep           = gcWord dflags
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)

103 104 105 106 107 108 109
slotCmmType :: DynFlags -> SlotTy -> CmmType
slotCmmType dflags PtrSlot    = gcWord dflags
slotCmmType dflags WordSlot   = bWord dflags
slotCmmType _      Word64Slot = b64
slotCmmType _      FloatSlot  = f32
slotCmmType _      DoubleSlot = f64

110 111 112 113 114 115 116 117 118 119 120
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
121

122 123
typeCmmType :: DynFlags -> UnaryType -> CmmType
typeCmmType dflags ty = primRepCmmType dflags (typePrimRep ty)
124 125

primRepForeignHint :: PrimRep -> ForeignHint
126 127 128 129 130 131
primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"
primRepForeignHint PtrRep       = AddrHint
primRepForeignHint IntRep       = SignedHint
primRepForeignHint WordRep      = NoHint
primRepForeignHint Int64Rep     = SignedHint
primRepForeignHint Word64Rep    = NoHint
132
primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg
133 134
primRepForeignHint FloatRep     = NoHint
primRepForeignHint DoubleRep    = NoHint
135
primRepForeignHint (VecRep {})  = NoHint
136

137 138 139 140 141 142 143
slotForeignHint :: SlotTy -> ForeignHint
slotForeignHint PtrSlot       = AddrHint
slotForeignHint WordSlot      = NoHint
slotForeignHint Word64Slot    = NoHint
slotForeignHint FloatSlot     = NoHint
slotForeignHint DoubleSlot    = NoHint

144
typeForeignHint :: UnaryType -> ForeignHint
145 146
typeForeignHint = primRepForeignHint . typePrimRep

147 148
---------------------------------------------------
--
149
--      CmmLit
150 151 152
--
---------------------------------------------------

153 154
-- XXX: should really be Integer, since Int doesn't necessarily cover
-- the full range of target Ints.
155 156
mkIntCLit :: DynFlags -> Int -> CmmLit
mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
157

158 159
mkIntExpr :: DynFlags -> Int -> CmmExpr
mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i
160

161 162
zeroCLit :: DynFlags -> CmmLit
zeroCLit dflags = CmmInt 0 (wordWidth dflags)
163

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

167 168 169
mkWordCLit :: DynFlags -> Integer -> CmmLit
mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)

Simon Peyton Jones's avatar
Simon Peyton Jones committed
170
mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
171
-- We have to make a top-level decl for the string,
172 173
-- and return a literal pointing to it
mkByteStringCLit uniq bytes
174
  = (CmmLabel lbl, CmmData sec $ Statics lbl [CmmString bytes])
175 176
  where
    lbl = mkStringLitLabel uniq
177
    sec = Section ReadOnlyData lbl
Simon Peyton Jones's avatar
Simon Peyton Jones committed
178
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
179 180 181 182
-- 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
183
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
184 185 186
-- Build a read-only data block
mkRODataLits lbl lits
  = mkDataLits section lbl lits
187
  where
188 189
    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl
            | otherwise                = Section ReadOnlyData lbl
190 191 192 193
    needsRelocation (CmmLabel _)      = True
    needsRelocation (CmmLabelOff _ _) = True
    needsRelocation _                 = False

194 195
mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
196

197
packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
198
-- Make a single word literal in which the lower_half_word is
199
-- at the lower address, and the upper_half_word is at the
200 201
-- higher address
-- ToDo: consider using half-word lits instead
202
--       but be careful: that's vulnerable when reversed
203
packHalfWordsCLit dflags lower_half_word upper_half_word
204
   = if wORDS_BIGENDIAN dflags
205 206
     then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u)
     else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags))
207 208
    where l = fromStgHalfWord lower_half_word
          u = fromStgHalfWord upper_half_word
209

210 211
---------------------------------------------------
--
212
--      CmmExpr
213 214 215
--
---------------------------------------------------

216 217 218
mkLblExpr :: CLabel -> CmmExpr
mkLblExpr lbl = CmmLit (CmmLabel lbl)

219
cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
220
-- assumes base and offset have the same CmmType
221 222
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]
223

224 225 226 227 228
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)
229 230 231
cmmOffset _ (CmmStackSlot area off) byte_off
  = CmmStackSlot area (off - byte_off)
  -- note stack area offsets increase towards lower addresses
232
cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
233 234
  = CmmMachOp (MO_Add rep)
              [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
235
cmmOffset dflags expr byte_off
236
  = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
237
  where
238
    width = cmmExprWidth dflags expr
239 240 241

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

cmmOffsetLit :: CmmLit -> Int -> CmmLit
246 247
cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off
cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
248 249
cmmOffsetLit (CmmLabelDiffOff l1 l2 m) byte_off
                                        = CmmLabelDiffOff l1 l2 (m+byte_off)
250
cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep
251
cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
252 253 254 255 256 257

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
258
-- | Useful for creating an index into an array, with a statically known offset.
259
-- The type is the element type; used for making the multiplier
260 261
cmmIndex :: DynFlags
         -> Width       -- Width w
262 263 264
         -> CmmExpr     -- Address of vector of items of width w
         -> Int         -- Which element of the vector (0 based)
         -> CmmExpr     -- Address of i'th element
265
cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)
266 267

-- | Useful for creating an index into an array, with an unknown offset.
268 269
cmmIndexExpr :: DynFlags
             -> Width           -- Width w
270 271 272
             -> CmmExpr         -- Address of vector of items of width w
             -> CmmExpr         -- Which element of the vector (0 based)
             -> CmmExpr         -- Address of i'th element
273 274 275
cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)
cmmIndexExpr dflags width base idx =
  cmmOffsetExpr dflags base byte_off
276
  where
277
    idx_w = cmmExprWidth dflags idx
278
    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]
279

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

283 284 285 286
-- The "B" variants take byte offsets
cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
cmmRegOffB = cmmRegOff

287
cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
288 289
cmmOffsetB = cmmOffset

290
cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
291 292 293 294 295 296 297 298 299 300
cmmOffsetExprB = cmmOffsetExpr

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

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

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

302
cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
303
-- The second arg is a *word* offset; need to change it to bytes
304
cmmOffsetExprW dflags  e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)
305
cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off
306

307
cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
308
cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)
309

310
cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
311
cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)
312

313
cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
314
cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)
315

316
cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
317
cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)
318

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

-----------------------
323 324 325 326 327
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
  cmmSLtWord,
  cmmNeWord, cmmEqWord,
  cmmOrWord, cmmAndWord,
  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
328 329 330 331 332 333 334 335 336
  :: 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]
--cmmShlWord dflags e1 e2 = CmmMachOp (mo_wordShl dflags) [e1, e2]
337
cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
338 339 340 341 342
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]
343

344 345 346
cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
cmmNegate _      (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
cmmNegate dflags e                       = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
347

348 349
blankWord :: DynFlags -> CmmStatic
blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
350

351 352 353 354 355 356 357 358
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

359 360
---------------------------------------------------
--
361
--      CmmExpr predicates
362 363 364
--
---------------------------------------------------

365
isTrivialCmmExpr :: CmmExpr -> Bool
366 367 368 369 370
isTrivialCmmExpr (CmmLoad _ _)      = False
isTrivialCmmExpr (CmmMachOp _ _)    = False
isTrivialCmmExpr (CmmLit _)         = True
isTrivialCmmExpr (CmmReg _)         = True
isTrivialCmmExpr (CmmRegOff _ _)    = True
371
isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
372

373
hasNoGlobalRegs :: CmmExpr -> Bool
374 375 376
hasNoGlobalRegs (CmmLoad e _)              = hasNoGlobalRegs e
hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es
hasNoGlobalRegs (CmmLit _)                 = True
377 378 379
hasNoGlobalRegs (CmmReg (CmmLocal _))      = True
hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
hasNoGlobalRegs _ = False
380

381 382
---------------------------------------------------
--
383
--      Tagging
384 385 386 387 388
--
---------------------------------------------------

-- Tag bits mask
--cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
389
cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
390 391
cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
392 393 394

-- Used to untag a possibly tagged pointer
-- A static label need not be untagged
395
cmmUntag :: DynFlags -> CmmExpr -> CmmExpr
396
cmmUntag _ e@(CmmLit (CmmLabel _)) = e
397
-- Default case
398
cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
399 400

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

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


409 410 411 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
-----------------------------------------------------------------------------
-- 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

441 442 443 444 445 446
--------------------------------------------
--
--        mkLiveness
--
---------------------------------------------

447 448 449 450
mkLiveness :: DynFlags -> [Maybe LocalReg] -> Liveness
mkLiveness _      [] = []
mkLiveness dflags (reg:regs)
  = take sizeW bits ++ mkLiveness dflags regs
451 452 453
  where
    sizeW = case reg of
              Nothing -> 1
454 455
              Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE dflags - 1)
                        `quot` wORD_SIZE dflags
456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475
                        -- 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)}

476
toBlockMap :: CmmGraph -> BlockEnv CmmBlock
477 478
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body

479
ofBlockMap :: BlockId -> BlockEnv CmmBlock -> CmmGraph
480 481
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}

482
insertBlock :: CmmBlock -> BlockEnv CmmBlock -> BlockEnv CmmBlock
483
insertBlock block map =
484
  ASSERT(isNothing $ mapLookup id map)
485 486 487 488 489 490
  mapInsert id block map
  where id = entryLabel block

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

491 492 493 494 495 496 497 498 499 500 501
-- | 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)

502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529
-- | 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
-- defind in cmm/CmmNode.hs. -GBM
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

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

546
mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
547
mapGraphNodes1 f = modifyGraph (mapGraph f)
548 549


550 551 552 553
foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a
foldGraphBlocks k z g = mapFold k z $ toBlockMap g

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

Peter Wortmann's avatar
Peter Wortmann committed
556 557 558 559 560 561 562 563 564
-------------------------------------------------
-- 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