Utils.hs 22.4 KB
Newer Older
1
{-# LANGUAGE GADTs, RankNTypes #-}
2
{-# LANGUAGE BangPatterns #-}
Ian Lynagh's avatar
Ian Lynagh committed
3

4 5
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

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

14
module GHC.Cmm.Utils(
15
        -- CmmType
16
        primRepCmmType, slotCmmType, slotForeignHint,
17
        typeCmmType, typeForeignHint, primRepForeignHint,
18

19
        -- CmmLit
20
        zeroCLit, mkIntCLit,
21 22
        mkWordCLit, packHalfWordsCLit,
        mkByteStringCLit,
23
        mkDataLits, mkRODataLits,
24
        mkStgWordCLit,
25

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

41 42
        cmmMkAssign,

43
        isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,
44

45 46 47
        baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
        currentTSOExpr, currentNurseryExpr, cccsExpr,

48 49 50 51
        -- Statics
        blankWord,

        -- Tagging
52 53
        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,
        cmmConstrTag1,
54

55 56 57
        -- Overlap and usage
        regsOverlap, regUsedIn,

58 59
        -- Liveness and bitmaps
        mkLiveness,
60

61 62 63
        -- * Operations that probably don't belong here
        modifyGraph,

64
        ofBlockMap, toBlockMap,
65 66
        ofBlockList, toBlockList, bodyToBlockList,
        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
67
        foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,
68

Peter Wortmann's avatar
Peter Wortmann committed
69
        -- * Ticks
Peter Wortmann's avatar
Peter Wortmann committed
70
        blockTicks
71 72
  ) where

73 74
import GhcPrelude

75
import TyCon    ( PrimRep(..), PrimElemRep(..) )
76
import GHC.Types.RepType  ( UnaryType, SlotTy (..), typePrimRep1 )
77

78
import GHC.Runtime.Heap.Layout
79 80 81
import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
82
import Outputable
Sylvain Henry's avatar
Sylvain Henry committed
83
import GHC.Driver.Session
84
import Unique
85
import GHC.Platform.Regs
86

87 88
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
89
import Data.Bits
90 91 92 93
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
94

95 96
---------------------------------------------------
--
97
--      CmmTypes
98 99 100
--
---------------------------------------------------

101
primRepCmmType :: DynFlags -> PrimRep -> CmmType
102
primRepCmmType _      VoidRep          = panic "primRepCmmType:VoidRep"
103 104
primRepCmmType dflags LiftedRep        = gcWord dflags
primRepCmmType dflags UnliftedRep      = gcWord dflags
105 106
primRepCmmType dflags IntRep           = bWord dflags
primRepCmmType dflags WordRep          = bWord dflags
Michal Terepeta's avatar
Michal Terepeta committed
107 108
primRepCmmType _      Int8Rep          = b8
primRepCmmType _      Word8Rep         = b8
109 110
primRepCmmType _      Int16Rep         = b16
primRepCmmType _      Word16Rep        = b16
John Ericson's avatar
John Ericson committed
111 112
primRepCmmType _      Int32Rep         = b32
primRepCmmType _      Word32Rep        = b32
113 114 115 116 117 118 119
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)

120 121 122 123 124 125 126
slotCmmType :: DynFlags -> SlotTy -> CmmType
slotCmmType dflags PtrSlot    = gcWord dflags
slotCmmType dflags WordSlot   = bWord dflags
slotCmmType _      Word64Slot = b64
slotCmmType _      FloatSlot  = f32
slotCmmType _      DoubleSlot = f64

127 128 129 130 131 132 133 134 135 136 137
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
138

139
typeCmmType :: DynFlags -> UnaryType -> CmmType
140
typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)
141 142

primRepForeignHint :: PrimRep -> ForeignHint
143
primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"
144 145
primRepForeignHint LiftedRep    = AddrHint
primRepForeignHint UnliftedRep  = AddrHint
146
primRepForeignHint IntRep       = SignedHint
Michal Terepeta's avatar
Michal Terepeta committed
147
primRepForeignHint Int8Rep      = SignedHint
148
primRepForeignHint Int16Rep     = SignedHint
John Ericson's avatar
John Ericson committed
149
primRepForeignHint Int32Rep     = SignedHint
Ben Gamari's avatar
Ben Gamari committed
150
primRepForeignHint Int64Rep     = SignedHint
Michal Terepeta's avatar
Michal Terepeta committed
151 152
primRepForeignHint WordRep      = NoHint
primRepForeignHint Word8Rep     = NoHint
153
primRepForeignHint Word16Rep    = NoHint
John Ericson's avatar
John Ericson committed
154
primRepForeignHint Word32Rep    = NoHint
155
primRepForeignHint Word64Rep    = NoHint
156
primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg
157 158
primRepForeignHint FloatRep     = NoHint
primRepForeignHint DoubleRep    = NoHint
159
primRepForeignHint (VecRep {})  = NoHint
160

161 162 163 164 165 166 167
slotForeignHint :: SlotTy -> ForeignHint
slotForeignHint PtrSlot       = AddrHint
slotForeignHint WordSlot      = NoHint
slotForeignHint Word64Slot    = NoHint
slotForeignHint FloatSlot     = NoHint
slotForeignHint DoubleSlot    = NoHint

168
typeForeignHint :: UnaryType -> ForeignHint
169
typeForeignHint = primRepForeignHint . typePrimRep1
170

171 172
---------------------------------------------------
--
173
--      CmmLit
174 175 176
--
---------------------------------------------------

177 178
-- XXX: should really be Integer, since Int doesn't necessarily cover
-- the full range of target Ints.
179 180
mkIntCLit :: DynFlags -> Int -> CmmLit
mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
181

182 183
mkIntExpr :: DynFlags -> Int -> CmmExpr
mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i
184

185 186
zeroCLit :: DynFlags -> CmmLit
zeroCLit dflags = CmmInt 0 (wordWidth dflags)
187

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

191 192 193
mkWordCLit :: DynFlags -> Integer -> CmmLit
mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)

194
mkByteStringCLit
195
  :: CLabel -> ByteString -> (CmmLit, GenCmmDecl RawCmmStatics info stmt)
196
-- We have to make a top-level decl for the string,
197
-- and return a literal pointing to it
198
mkByteStringCLit lbl bytes
199
  = (CmmLabel lbl, CmmData (Section sec lbl) $ RawCmmStatics lbl [CmmString bytes])
200
  where
201 202
    -- This can not happen for String literals (as there \NUL is replaced by
    -- C0 80). However, it can happen with Addr# literals.
203
    sec = if 0 `BS.elem` bytes then ReadOnlyData else CString
204

205
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt
206 207
-- Build a data-segment data block
mkDataLits section lbl lits
208
  = CmmData section (RawCmmStatics lbl $ map CmmStaticLit lits)
209

210
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt
211 212 213
-- Build a read-only data block
mkRODataLits lbl lits
  = mkDataLits section lbl lits
214
  where
215 216
    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl
            | otherwise                = Section ReadOnlyData lbl
217 218 219 220
    needsRelocation (CmmLabel _)      = True
    needsRelocation (CmmLabelOff _ _) = True
    needsRelocation _                 = False

221 222
mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
223

224
packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
225
-- Make a single word literal in which the lower_half_word is
226
-- at the lower address, and the upper_half_word is at the
227 228
-- higher address
-- ToDo: consider using half-word lits instead
229
--       but be careful: that's vulnerable when reversed
230
packHalfWordsCLit dflags lower_half_word upper_half_word
231
   = if wORDS_BIGENDIAN dflags
232 233
     then mkWordCLit dflags ((l `shiftL` halfWordSizeInBits dflags) .|. u)
     else mkWordCLit dflags (l .|. (u `shiftL` halfWordSizeInBits dflags))
234 235
    where l = fromStgHalfWord lower_half_word
          u = fromStgHalfWord upper_half_word
236

237 238
---------------------------------------------------
--
239
--      CmmExpr
240 241 242
--
---------------------------------------------------

243 244 245
mkLblExpr :: CLabel -> CmmExpr
mkLblExpr lbl = CmmLit (CmmLabel lbl)

246
cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
247
-- assumes base and offset have the same CmmType
248 249
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]
250

251 252 253 254 255
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)
256 257 258
cmmOffset _ (CmmStackSlot area off) byte_off
  = CmmStackSlot area (off - byte_off)
  -- note stack area offsets increase towards lower addresses
259
cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
260 261
  = CmmMachOp (MO_Add rep)
              [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
262
cmmOffset dflags expr byte_off
263
  = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
264
  where
265
    width = cmmExprWidth dflags expr
266 267 268

-- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.
cmmRegOff :: CmmReg -> Int -> CmmExpr
269
cmmRegOff reg 0        = CmmReg reg
270 271 272
cmmRegOff reg byte_off = CmmRegOff reg byte_off

cmmOffsetLit :: CmmLit -> Int -> CmmLit
273 274
cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off
cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
275 276
cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off
                                        = CmmLabelDiffOff l1 l2 (m+byte_off) w
277
cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep
278
cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
279 280 281 282 283 284

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
285
-- | Useful for creating an index into an array, with a statically known offset.
286
-- The type is the element type; used for making the multiplier
287 288
cmmIndex :: DynFlags
         -> Width       -- Width w
289 290 291
         -> CmmExpr     -- Address of vector of items of width w
         -> Int         -- Which element of the vector (0 based)
         -> CmmExpr     -- Address of i'th element
292
cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)
293 294

-- | Useful for creating an index into an array, with an unknown offset.
295 296
cmmIndexExpr :: DynFlags
             -> Width           -- Width w
297 298 299
             -> CmmExpr         -- Address of vector of items of width w
             -> CmmExpr         -- Which element of the vector (0 based)
             -> CmmExpr         -- Address of i'th element
300 301 302
cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)
cmmIndexExpr dflags width base idx =
  cmmOffsetExpr dflags base byte_off
303
  where
304
    idx_w = cmmExprWidth dflags idx
305
    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]
306

307 308
cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty
309

310 311 312 313
-- The "B" variants take byte offsets
cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
cmmRegOffB = cmmRegOff

314
cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
315 316
cmmOffsetB = cmmOffset

317
cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
318 319 320 321 322 323 324 325 326 327
cmmOffsetExprB = cmmOffsetExpr

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

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

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

329
cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
330
-- The second arg is a *word* offset; need to change it to bytes
331
cmmOffsetExprW dflags  e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)
332
cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off
333

334
cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
335
cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)
336

337
cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
338
cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)
339

340
cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
341
cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)
342

343
cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
344
cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)
345

346 347
cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty
348 349

-----------------------
350 351 352 353 354
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
  cmmSLtWord,
  cmmNeWord, cmmEqWord,
  cmmOrWord, cmmAndWord,
  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
355 356 357 358 359 360 361 362
  :: 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]
363
cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
364 365 366 367 368
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]
369

370 371 372
cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
cmmNegate _      (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
cmmNegate dflags e                       = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
373

374 375
blankWord :: DynFlags -> CmmStatic
blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
376

377 378 379 380 381 382 383 384
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

385 386 387 388 389 390 391
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)


392 393
---------------------------------------------------
--
394
--      CmmExpr predicates
395 396 397
--
---------------------------------------------------

398
isTrivialCmmExpr :: CmmExpr -> Bool
399 400 401 402 403
isTrivialCmmExpr (CmmLoad _ _)      = False
isTrivialCmmExpr (CmmMachOp _ _)    = False
isTrivialCmmExpr (CmmLit _)         = True
isTrivialCmmExpr (CmmReg _)         = True
isTrivialCmmExpr (CmmRegOff _ _)    = True
404
isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
405

406
hasNoGlobalRegs :: CmmExpr -> Bool
407 408 409
hasNoGlobalRegs (CmmLoad e _)              = hasNoGlobalRegs e
hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es
hasNoGlobalRegs (CmmLit _)                 = True
410 411 412
hasNoGlobalRegs (CmmReg (CmmLocal _))      = True
hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
hasNoGlobalRegs _ = False
413

414 415 416 417 418 419 420 421
isLit :: CmmExpr -> Bool
isLit (CmmLit _) = True
isLit _          = False

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

422 423
---------------------------------------------------
--
424
--      Tagging
425 426 427 428
--
---------------------------------------------------

-- Tag bits mask
429
cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
430 431
cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
432 433 434

-- Used to untag a possibly tagged pointer
-- A static label need not be untagged
435
cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
436
cmmUntag _ e@(CmmLit (CmmLabel _)) = e
437
-- Default case
438
cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
439 440

-- Test if a closure pointer is untagged
441
cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
442 443

-- Get constructor tag, but one based.
444
cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
445 446


447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467
-----------------------------------------------------------------------------
-- 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
468
-- assignments that conflict due to overlap. See #10521 and Note
469 470 471 472 473 474 475 476 477 478
-- [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

479 480 481 482 483 484
--------------------------------------------
--
--        mkLiveness
--
---------------------------------------------

485
mkLiveness :: DynFlags -> [LocalReg] -> Liveness
486 487
mkLiveness _      [] = []
mkLiveness dflags (reg:regs)
488
  = bits ++ mkLiveness dflags regs
489
  where
490 491 492 493 494 495
    sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1)
            `quot` wORD_SIZE dflags
            -- number of words, rounded up
    bits = replicate sizeW is_non_ptr -- True <=> Non Ptr

    is_non_ptr = not $ isGcPtrType (localRegType reg)
496 497 498 499 500 501 502 503 504 505 506 507 508 509 510


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

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

511
toBlockMap :: CmmGraph -> LabelMap CmmBlock
512 513
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body

514
ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
515 516 517 518 519
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}

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

520 521 522 523 524 525 526 527 528 529 530
-- | 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)

531 532 533 534 535 536 537
-- | 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
538
-- defined in cmm/CmmNode.hs. -GBM
539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558
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

559
ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
Simon Marlow's avatar
Simon Marlow committed
560 561
ofBlockList entry blocks = CmmGraph { g_entry = entry
                                    , g_graph = GMany NothingO body NothingO }
562 563 564 565 566 567 568 569 570 571
  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
572 573
  ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $
  mapMap (mapBlock3' funs) $ toBlockMap g
574

575
mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
576
mapGraphNodes1 f = modifyGraph (mapGraph f)
577 578


579 580
foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g
581

582 583 584
revPostorder :: CmmGraph -> [CmmBlock]
revPostorder g = {-# SCC "revPostorder" #-}
    revPostorderFrom (toBlockMap g) (g_entry g)
585

Peter Wortmann's avatar
Peter Wortmann committed
586 587 588 589 590 591 592 593 594
-------------------------------------------------
-- 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
595 596 597 598 599 600 601 602 603 604 605 606 607 608 609


-- -----------------------------------------------------------------------------
-- Access to common global registers

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