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,
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 (Section sec lbl)  $ Statics lbl [CmmString bytes])
175 176
  where
    lbl = mkStringLitLabel uniq
177 178 179 180
    -- 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
181
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
182 183 184 185
-- 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
186
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
187 188 189
-- Build a read-only data block
mkRODataLits lbl lits
  = mkDataLits section lbl lits
190
  where
191 192
    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl
            | otherwise                = Section ReadOnlyData lbl
193 194 195 196
    needsRelocation (CmmLabel _)      = True
    needsRelocation (CmmLabelOff _ _) = True
    needsRelocation _                 = False

197 198
mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
199

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

213 214
---------------------------------------------------
--
215
--      CmmExpr
216 217 218
--
---------------------------------------------------

219 220 221
mkLblExpr :: CLabel -> CmmExpr
mkLblExpr lbl = CmmLit (CmmLabel lbl)

222
cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
223
-- assumes base and offset have the same CmmType
224 225
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]
226

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

-- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.
cmmRegOff :: CmmReg -> Int -> CmmExpr
245
cmmRegOff reg 0        = CmmReg reg
246 247 248
cmmRegOff reg byte_off = CmmRegOff reg byte_off

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

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

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

283 284
cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty
285

286 287 288 289
-- The "B" variants take byte offsets
cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
cmmRegOffB = cmmRegOff

290
cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
291 292
cmmOffsetB = cmmOffset

293
cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
294 295 296 297 298 299 300 301 302 303
cmmOffsetExprB = cmmOffsetExpr

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

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

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

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

310
cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
311
cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)
312

313
cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
314
cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)
315

316
cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
317
cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)
318

319
cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
320
cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)
321

322 323
cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty
324 325

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

347 348 349
cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
cmmNegate _      (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
cmmNegate dflags e                       = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
350

351 352
blankWord :: DynFlags -> CmmStatic
blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
353

354 355 356 357 358 359 360 361
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

362 363
---------------------------------------------------
--
364
--      CmmExpr predicates
365 366 367
--
---------------------------------------------------

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

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

384 385
---------------------------------------------------
--
386
--      Tagging
387 388 389 390 391
--
---------------------------------------------------

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

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

-- Test if a closure pointer is untagged
404 405
cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr
cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
406

407
cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
408
-- Get constructor tag, but one based.
409
cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
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 441 442 443
-----------------------------------------------------------------------------
-- 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

444 445 446 447 448 449
--------------------------------------------
--
--        mkLiveness
--
---------------------------------------------

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

479
toBlockMap :: CmmGraph -> BlockEnv CmmBlock
480 481
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body

482
ofBlockMap :: BlockId -> BlockEnv CmmBlock -> CmmGraph
483 484
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}

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

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

494 495 496 497 498 499 500 501 502 503 504
-- | 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)

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 530 531 532
-- | 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

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

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


553 554 555 556
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
557
postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g)
558

Peter Wortmann's avatar
Peter Wortmann committed
559 560 561 562 563 564 565 566 567
-------------------------------------------------
-- 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