CmmUtils.hs 21.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 14
        primRepCmmType, primRepForeignHint,
        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
        -- Liveness and bitmaps
        mkLiveness,
49

50 51 52 53
        -- * Operations that probably don't belong here
        modifyGraph,

        ofBlockMap, toBlockMap, insertBlock,
54 55
        ofBlockList, toBlockList, bodyToBlockList,
        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
56
        foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
57

58
        analFwd, analBwd, analRewFwd, analRewBwd,
59
        dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd,
Peter Wortmann's avatar
Peter Wortmann committed
60 61 62
        dataflowAnalFwdBlocks,

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

#include "HsVersions.h"

68
import TyCon    ( PrimRep(..), PrimElemRep(..) )
69
import Type     ( UnaryType, typePrimRep )
70

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

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

86 87
---------------------------------------------------
--
88
--      CmmTypes
89 90 91
--
---------------------------------------------------

92
primRepCmmType :: DynFlags -> PrimRep -> CmmType
93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114
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)

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
115

116 117
typeCmmType :: DynFlags -> UnaryType -> CmmType
typeCmmType dflags ty = primRepCmmType dflags (typePrimRep ty)
118 119

primRepForeignHint :: PrimRep -> ForeignHint
120 121 122 123 124 125
primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"
primRepForeignHint PtrRep       = AddrHint
primRepForeignHint IntRep       = SignedHint
primRepForeignHint WordRep      = NoHint
primRepForeignHint Int64Rep     = SignedHint
primRepForeignHint Word64Rep    = NoHint
126
primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg
127 128
primRepForeignHint FloatRep     = NoHint
primRepForeignHint DoubleRep    = NoHint
129
primRepForeignHint (VecRep {})  = NoHint
130

131
typeForeignHint :: UnaryType -> ForeignHint
132 133
typeForeignHint = primRepForeignHint . typePrimRep

134 135
---------------------------------------------------
--
136
--      CmmLit
137 138 139
--
---------------------------------------------------

140 141
-- XXX: should really be Integer, since Int doesn't necessarily cover
-- the full range of target Ints.
142 143
mkIntCLit :: DynFlags -> Int -> CmmLit
mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
144

145 146
mkIntExpr :: DynFlags -> Int -> CmmExpr
mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i
147

148 149
zeroCLit :: DynFlags -> CmmLit
zeroCLit dflags = CmmInt 0 (wordWidth dflags)
150

151 152
zeroExpr :: DynFlags -> CmmExpr
zeroExpr dflags = CmmLit (zeroCLit dflags)
153

154 155 156
mkWordCLit :: DynFlags -> Integer -> CmmLit
mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)

Simon Peyton Jones's avatar
Simon Peyton Jones committed
157
mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
158
-- We have to make a top-level decl for the string,
159 160 161 162 163
-- and return a literal pointing to it
mkByteStringCLit uniq bytes
  = (CmmLabel lbl, CmmData ReadOnlyData $ Statics lbl [CmmString bytes])
  where
    lbl = mkStringLitLabel uniq
Simon Peyton Jones's avatar
Simon Peyton Jones committed
164
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
165 166 167 168
-- 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
169
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
170 171 172
-- Build a read-only data block
mkRODataLits lbl lits
  = mkDataLits section lbl lits
173
  where
174 175 176 177 178 179
    section | any needsRelocation lits = RelocatableReadOnlyData
            | otherwise                = ReadOnlyData
    needsRelocation (CmmLabel _)      = True
    needsRelocation (CmmLabelOff _ _) = True
    needsRelocation _                 = False

180 181
mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
182

183
packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
184
-- Make a single word literal in which the lower_half_word is
185
-- at the lower address, and the upper_half_word is at the
186 187
-- higher address
-- ToDo: consider using half-word lits instead
188
--       but be careful: that's vulnerable when reversed
189
packHalfWordsCLit dflags lower_half_word upper_half_word
190
   = if wORDS_BIGENDIAN dflags
191 192
     then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u)
     else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags))
193 194
    where l = fromStgHalfWord lower_half_word
          u = fromStgHalfWord upper_half_word
195

196 197
---------------------------------------------------
--
198
--      CmmExpr
199 200 201
--
---------------------------------------------------

202 203 204
mkLblExpr :: CLabel -> CmmExpr
mkLblExpr lbl = CmmLit (CmmLabel lbl)

205
cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
206
-- assumes base and offset have the same CmmType
207 208
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]
209

210 211 212 213 214
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)
215 216 217
cmmOffset _ (CmmStackSlot area off) byte_off
  = CmmStackSlot area (off - byte_off)
  -- note stack area offsets increase towards lower addresses
218
cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
219 220
  = CmmMachOp (MO_Add rep)
              [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
221
cmmOffset dflags expr byte_off
222
  = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
223
  where
224
    width = cmmExprWidth dflags expr
225 226 227

-- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.
cmmRegOff :: CmmReg -> Int -> CmmExpr
228
cmmRegOff reg 0        = CmmReg reg
229 230 231
cmmRegOff reg byte_off = CmmRegOff reg byte_off

cmmOffsetLit :: CmmLit -> Int -> CmmLit
232 233
cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off
cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
234 235
cmmOffsetLit (CmmLabelDiffOff l1 l2 m) byte_off
                                        = CmmLabelDiffOff l1 l2 (m+byte_off)
236
cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep
237
cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
238 239 240 241 242 243 244

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

-- | Useful for creating an index into an array, with a staticaly known offset.
245
-- The type is the element type; used for making the multiplier
246 247
cmmIndex :: DynFlags
         -> Width       -- Width w
248 249 250
         -> CmmExpr     -- Address of vector of items of width w
         -> Int         -- Which element of the vector (0 based)
         -> CmmExpr     -- Address of i'th element
251
cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)
252 253

-- | Useful for creating an index into an array, with an unknown offset.
254 255
cmmIndexExpr :: DynFlags
             -> Width           -- Width w
256 257 258
             -> CmmExpr         -- Address of vector of items of width w
             -> CmmExpr         -- Which element of the vector (0 based)
             -> CmmExpr         -- Address of i'th element
259 260 261
cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)
cmmIndexExpr dflags width base idx =
  cmmOffsetExpr dflags base byte_off
262
  where
263
    idx_w = cmmExprWidth dflags idx
264
    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]
265

266 267
cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty
268

269 270 271 272
-- The "B" variants take byte offsets
cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
cmmRegOffB = cmmRegOff

273
cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
274 275
cmmOffsetB = cmmOffset

276
cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
277 278 279 280 281 282 283 284 285 286
cmmOffsetExprB = cmmOffsetExpr

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

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

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

288
cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
289
-- The second arg is a *word* offset; need to change it to bytes
290
cmmOffsetExprW dflags  e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)
291
cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off
292

293
cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
294
cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)
295

296
cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
297
cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)
298

299
cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
300
cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)
301

302
cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
303
cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)
304

305 306
cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty
307 308

-----------------------
309 310 311 312 313
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
  cmmSLtWord,
  cmmNeWord, cmmEqWord,
  cmmOrWord, cmmAndWord,
  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
314 315 316 317 318 319 320 321 322
  :: 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]
323
cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
324 325 326 327 328
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]
329

330 331 332
cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
cmmNegate _      (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
cmmNegate dflags e                       = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
333

334 335
blankWord :: DynFlags -> CmmStatic
blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
336

337 338 339 340 341 342 343 344
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

345 346
---------------------------------------------------
--
347
--      CmmExpr predicates
348 349 350
--
---------------------------------------------------

351
isTrivialCmmExpr :: CmmExpr -> Bool
352 353 354 355 356
isTrivialCmmExpr (CmmLoad _ _)      = False
isTrivialCmmExpr (CmmMachOp _ _)    = False
isTrivialCmmExpr (CmmLit _)         = True
isTrivialCmmExpr (CmmReg _)         = True
isTrivialCmmExpr (CmmRegOff _ _)    = True
357
isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
358

359
hasNoGlobalRegs :: CmmExpr -> Bool
360 361 362
hasNoGlobalRegs (CmmLoad e _)              = hasNoGlobalRegs e
hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es
hasNoGlobalRegs (CmmLit _)                 = True
363 364 365
hasNoGlobalRegs (CmmReg (CmmLocal _))      = True
hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
hasNoGlobalRegs _ = False
366

367 368
---------------------------------------------------
--
369
--      Tagging
370 371 372 373 374
--
---------------------------------------------------

-- Tag bits mask
--cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
375
cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
376 377
cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
378 379 380

-- Used to untag a possibly tagged pointer
-- A static label need not be untagged
381
cmmUntag :: DynFlags -> CmmExpr -> CmmExpr
382
cmmUntag _ e@(CmmLit (CmmLabel _)) = e
383
-- Default case
384
cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
385 386

-- Test if a closure pointer is untagged
387 388
cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr
cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
389

390
cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
391
-- Get constructor tag, but one based.
392
cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
393 394 395 396 397 398 399 400


--------------------------------------------
--
--        mkLiveness
--
---------------------------------------------

401 402 403 404
mkLiveness :: DynFlags -> [Maybe LocalReg] -> Liveness
mkLiveness _      [] = []
mkLiveness dflags (reg:regs)
  = take sizeW bits ++ mkLiveness dflags regs
405 406 407
  where
    sizeW = case reg of
              Nothing -> 1
408 409
              Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE dflags - 1)
                        `quot` wORD_SIZE dflags
410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429
                        -- 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)}

430
toBlockMap :: CmmGraph -> BlockEnv CmmBlock
431 432
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body

433
ofBlockMap :: BlockId -> BlockEnv CmmBlock -> CmmGraph
434 435
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}

436
insertBlock :: CmmBlock -> BlockEnv CmmBlock -> BlockEnv CmmBlock
437
insertBlock block map =
438
  ASSERT(isNothing $ mapLookup id map)
439 440 441 442 443 444
  mapInsert id block map
  where id = entryLabel block

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

445 446 447 448 449 450 451 452 453 454 455
-- | 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)

456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483
-- | 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

484
ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
Simon Marlow's avatar
Simon Marlow committed
485 486
ofBlockList entry blocks = CmmGraph { g_entry = entry
                                    , g_graph = GMany NothingO body NothingO }
487 488 489 490 491 492 493 494 495 496
  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
497 498
  ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $
  mapMap (mapBlock3' funs) $ toBlockMap g
499

500
mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
501
mapGraphNodes1 f = modifyGraph (mapGraph f)
502 503


504 505 506 507
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
508
postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g)
509 510 511 512 513

-------------------------------------------------
-- Running dataflow analysis and/or rewrites

-- Constructing forward and backward analysis-only pass
514 515
analFwd    :: DataflowLattice f -> FwdTransfer n f -> FwdPass UniqSM n f
analBwd    :: DataflowLattice f -> BwdTransfer n f -> BwdPass UniqSM n f
516 517 518 519 520

analFwd lat xfer = analRewFwd lat xfer noFwdRewrite
analBwd lat xfer = analRewBwd lat xfer noBwdRewrite

-- Constructing forward and backward analysis + rewrite pass
Simon Marlow's avatar
Simon Marlow committed
521
analRewFwd :: DataflowLattice f -> FwdTransfer n f
522 523
           -> FwdRewrite UniqSM n f
           -> FwdPass UniqSM n f
Simon Marlow's avatar
Simon Marlow committed
524 525 526

analRewBwd :: DataflowLattice f
           -> BwdTransfer n f
527 528
           -> BwdRewrite UniqSM n f
           -> BwdPass UniqSM n f
529 530 531 532 533

analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew}
analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew}

-- Running forward and backward dataflow analysis + optional rewrite
Simon Marlow's avatar
Simon Marlow committed
534 535
dataflowPassFwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
536 537
                -> FwdPass UniqSM n f
                -> UniqSM (GenCmmGraph n, BlockEnv f)
538 539 540 541
dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
  (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
  return (CmmGraph {g_entry=entry, g_graph=graph}, facts)

Simon Marlow's avatar
Simon Marlow committed
542 543
dataflowAnalFwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
544
                -> FwdPass UniqSM n f
545 546 547
                -> BlockEnv f
dataflowAnalFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd =
  analyzeFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
Simon Marlow's avatar
Simon Marlow committed
548

549 550
dataflowAnalFwdBlocks :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
551 552
                -> FwdPass UniqSM n f
                -> UniqSM (BlockEnv f)
553 554 555 556 557
dataflowAnalFwdBlocks (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
--  (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
--  return facts
  return (analyzeFwdBlocks fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts))

Simon Marlow's avatar
Simon Marlow committed
558 559
dataflowAnalBwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
560
                -> BwdPass UniqSM n f
561 562 563
                -> BlockEnv f
dataflowAnalBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd =
  analyzeBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
Simon Marlow's avatar
Simon Marlow committed
564 565 566

dataflowPassBwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
567 568
                -> BwdPass UniqSM n f
                -> UniqSM (GenCmmGraph n, BlockEnv f)
569 570 571
dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
  (graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
  return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
Peter Wortmann's avatar
Peter Wortmann committed
572 573 574 575 576 577 578 579 580 581

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