CmmUtils.hs 21.6 KB
Newer Older
1
{-# LANGUAGE GADTs #-}
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 31 32
        cmmRegOff,  cmmOffset,  cmmLabelOff,  cmmOffsetLit,  cmmOffsetExpr,
        cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,
        cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,
        cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,
        cmmNegate,
        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
        cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
33
        cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord,
34
        cmmToWord,
35

36
        isTrivialCmmExpr, hasNoGlobalRegs,
37

38 39 40 41
        -- Statics
        blankWord,

        -- Tagging
42 43
        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,
        cmmConstrTag1,
44

45 46
        -- Liveness and bitmaps
        mkLiveness,
47

48 49 50 51
        -- * Operations that probably don't belong here
        modifyGraph,

        ofBlockMap, toBlockMap, insertBlock,
52 53
        ofBlockList, toBlockList, bodyToBlockList,
        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
54
        foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
55

56
        analFwd, analBwd, analRewFwd, analRewBwd,
Simon Marlow's avatar
Simon Marlow committed
57 58
        dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd,
        dataflowAnalFwdBlocks
59 60 61 62
  ) where

#include "HsVersions.h"

63
import TyCon    ( PrimRep(..), PrimElemRep(..) )
64
import Type     ( UnaryType, typePrimRep )
65

66 67 68
import SMRep
import Cmm
import BlockId
Simon Marlow's avatar
Simon Marlow committed
69
import CLabel
70
import Outputable
71 72
import Unique
import UniqSupply
73
import DynFlags
74
import Util
75 76 77 78

import Data.Word
import Data.Maybe
import Data.Bits
Simon Marlow's avatar
Simon Marlow committed
79
import Hoopl
80

81 82
---------------------------------------------------
--
83
--      CmmTypes
84 85 86
--
---------------------------------------------------

87
primRepCmmType :: DynFlags -> PrimRep -> CmmType
88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
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
110

111 112
typeCmmType :: DynFlags -> UnaryType -> CmmType
typeCmmType dflags ty = primRepCmmType dflags (typePrimRep ty)
113 114

primRepForeignHint :: PrimRep -> ForeignHint
115 116 117 118 119 120
primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"
primRepForeignHint PtrRep       = AddrHint
primRepForeignHint IntRep       = SignedHint
primRepForeignHint WordRep      = NoHint
primRepForeignHint Int64Rep     = SignedHint
primRepForeignHint Word64Rep    = NoHint
121
primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg
122 123
primRepForeignHint FloatRep     = NoHint
primRepForeignHint DoubleRep    = NoHint
124
primRepForeignHint (VecRep {})  = NoHint
125

126
typeForeignHint :: UnaryType -> ForeignHint
127 128
typeForeignHint = primRepForeignHint . typePrimRep

129 130
---------------------------------------------------
--
131
--      CmmLit
132 133 134
--
---------------------------------------------------

135 136
-- XXX: should really be Integer, since Int doesn't necessarily cover
-- the full range of target Ints.
137 138
mkIntCLit :: DynFlags -> Int -> CmmLit
mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
139

140 141
mkIntExpr :: DynFlags -> Int -> CmmExpr
mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i
142

143 144
zeroCLit :: DynFlags -> CmmLit
zeroCLit dflags = CmmInt 0 (wordWidth dflags)
145

146 147
zeroExpr :: DynFlags -> CmmExpr
zeroExpr dflags = CmmLit (zeroCLit dflags)
148

149 150 151
mkWordCLit :: DynFlags -> Integer -> CmmLit
mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)

Simon Peyton Jones's avatar
Simon Peyton Jones committed
152
mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
153
-- We have to make a top-level decl for the string,
154 155 156 157 158
-- 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
159
mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
160 161 162 163
-- 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
164
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
165 166 167
-- Build a read-only data block
mkRODataLits lbl lits
  = mkDataLits section lbl lits
168
  where
169 170 171 172 173 174
    section | any needsRelocation lits = RelocatableReadOnlyData
            | otherwise                = ReadOnlyData
    needsRelocation (CmmLabel _)      = True
    needsRelocation (CmmLabelOff _ _) = True
    needsRelocation _                 = False

175 176
mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
177

178
packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
179
-- Make a single word literal in which the lower_half_word is
180
-- at the lower address, and the upper_half_word is at the
181 182
-- higher address
-- ToDo: consider using half-word lits instead
183
--       but be careful: that's vulnerable when reversed
184
packHalfWordsCLit dflags lower_half_word upper_half_word
185
   = if wORDS_BIGENDIAN dflags
ian@well-typed.com's avatar
ian@well-typed.com committed
186 187
     then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u)
     else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags))
188 189
    where l = fromStgHalfWord lower_half_word
          u = fromStgHalfWord upper_half_word
190

191 192
---------------------------------------------------
--
193
--      CmmExpr
194 195 196
--
---------------------------------------------------

197 198 199
mkLblExpr :: CLabel -> CmmExpr
mkLblExpr lbl = CmmLit (CmmLabel lbl)

200
cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
201
-- assumes base and offset have the same CmmType
202 203
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]
204 205 206 207 208 209 210 211

-- NB. Do *not* inspect the value of the offset in these smart constructors!!!
-- because the offset is sometimes involved in a loop in the code generator
-- (we don't know the real Hp offset until we've generated code for the entire
-- basic block, for example).  So we cannot eliminate zero offsets at this
-- stage; they're eliminated later instead (either during printing or
-- a later optimisation step on Cmm).
--
212 213 214 215 216
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)
217 218 219
cmmOffset _ (CmmStackSlot area off) byte_off
  = CmmStackSlot area (off - byte_off)
  -- note stack area offsets increase towards lower addresses
220
cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
221 222
  = CmmMachOp (MO_Add rep)
              [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
223
cmmOffset dflags expr byte_off
224
  = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
225
  where
226
    width = cmmExprWidth dflags expr
227 228 229

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

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

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.
247
-- The type is the element type; used for making the multiplier
248 249
cmmIndex :: DynFlags
         -> Width       -- Width w
250 251 252
         -> CmmExpr     -- Address of vector of items of width w
         -> Int         -- Which element of the vector (0 based)
         -> CmmExpr     -- Address of i'th element
253
cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)
254 255

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

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

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

275
cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
276 277
cmmOffsetB = cmmOffset

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

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

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

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

294
cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
295
cmmOffsetW dflags e n = cmmOffsetB dflags e (wORD_SIZE dflags * n)
296

297 298
cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE dflags)
299

300 301
cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wORD_SIZE dflags * wd_off)
302

303 304
cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wORD_SIZE dflags * wd_off)
305

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

-----------------------
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
  cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
312
  cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord
313 314 315 316 317 318 319 320 321 322 323 324 325 326
  :: 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]
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]
327

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

332 333
blankWord :: DynFlags -> CmmStatic
blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
334

335 336 337 338 339 340 341 342
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

343 344
---------------------------------------------------
--
345
--      CmmExpr predicates
346 347 348
--
---------------------------------------------------

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

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

365 366
---------------------------------------------------
--
367
--      Tagging
368 369 370 371 372
--
---------------------------------------------------

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

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

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

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


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

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

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

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

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

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

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

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

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

497
mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
498
mapGraphNodes1 f = modifyGraph (mapGraph f)
499 500


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

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

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

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
518
analRewFwd :: DataflowLattice f -> FwdTransfer n f
519 520
           -> FwdRewrite UniqSM n f
           -> FwdPass UniqSM n f
Simon Marlow's avatar
Simon Marlow committed
521 522 523

analRewBwd :: DataflowLattice f
           -> BwdTransfer n f
524 525
           -> BwdRewrite UniqSM n f
           -> BwdPass UniqSM n f
526 527 528 529 530

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
531 532
dataflowPassFwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
533 534
                -> FwdPass UniqSM n f
                -> UniqSM (GenCmmGraph n, BlockEnv f)
535 536 537 538
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
539 540
dataflowAnalFwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
541
                -> FwdPass UniqSM n f
542 543 544
                -> 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
545

Simon Marlow's avatar
Simon Marlow committed
546 547
dataflowAnalFwdBlocks :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
548 549
                -> FwdPass UniqSM n f
                -> UniqSM (BlockEnv f)
Simon Marlow's avatar
Simon Marlow committed
550 551 552 553 554
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
555 556
dataflowAnalBwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
557
                -> BwdPass UniqSM n f
558 559 560
                -> 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
561 562 563

dataflowPassBwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
564 565
                -> BwdPass UniqSM n f
                -> UniqSM (GenCmmGraph n, BlockEnv f)
566 567 568
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)