CmmUtils.hs 21.4 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

35
        isTrivialCmmExpr, hasNoGlobalRegs,
36

37 38 39 40
        -- Statics
        blankWord,

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

44 45
        -- Liveness and bitmaps
        mkLiveness,
46

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

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

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

#include "HsVersions.h"

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

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

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

80 81
---------------------------------------------------
--
82
--      CmmTypes
83 84 85
--
---------------------------------------------------

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

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

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

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

128 129
---------------------------------------------------
--
130
--      CmmLit
131 132 133
--
---------------------------------------------------

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

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

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

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

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

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

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

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

190 191
---------------------------------------------------
--
192
--      CmmExpr
193 194 195
--
---------------------------------------------------

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

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

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

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

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

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

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

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

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

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

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

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

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

-----------------------
-- The "W" variants take word offsets
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 (wORD_SIZE dflags * n)
295

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

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

302 303
cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wORD_SIZE 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

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

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

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

334 335
---------------------------------------------------
--
336
--      CmmExpr predicates
337 338 339
--
---------------------------------------------------

340
isTrivialCmmExpr :: CmmExpr -> Bool
341 342 343 344 345
isTrivialCmmExpr (CmmLoad _ _)      = False
isTrivialCmmExpr (CmmMachOp _ _)    = False
isTrivialCmmExpr (CmmLit _)         = True
isTrivialCmmExpr (CmmReg _)         = True
isTrivialCmmExpr (CmmRegOff _ _)    = True
346
isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
347

348
hasNoGlobalRegs :: CmmExpr -> Bool
349 350 351
hasNoGlobalRegs (CmmLoad e _)              = hasNoGlobalRegs e
hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es
hasNoGlobalRegs (CmmLit _)                 = True
352 353 354
hasNoGlobalRegs (CmmReg (CmmLocal _))      = True
hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
hasNoGlobalRegs _ = False
355

356 357
---------------------------------------------------
--
358
--      Tagging
359 360 361 362 363
--
---------------------------------------------------

-- Tag bits mask
--cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
364
cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
365 366
cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
367 368 369

-- Used to untag a possibly tagged pointer
-- A static label need not be untagged
370
cmmUntag :: DynFlags -> CmmExpr -> CmmExpr
371
cmmUntag _ e@(CmmLit (CmmLabel _)) = e
372
-- Default case
373
cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
374 375

-- Test if a closure pointer is untagged
376 377
cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr
cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
378

379
cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
380
-- Get constructor tag, but one based.
381
cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
382 383 384 385 386 387 388 389


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

390 391 392 393
mkLiveness :: DynFlags -> [Maybe LocalReg] -> Liveness
mkLiveness _      [] = []
mkLiveness dflags (reg:regs)
  = take sizeW bits ++ mkLiveness dflags regs
394 395 396
  where
    sizeW = case reg of
              Nothing -> 1
397 398
              Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE dflags - 1)
                        `quot` wORD_SIZE dflags
399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418
                        -- 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)}

419
toBlockMap :: CmmGraph -> BlockEnv CmmBlock
420 421
toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body

422
ofBlockMap :: BlockId -> BlockEnv CmmBlock -> CmmGraph
423 424
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}

425
insertBlock :: CmmBlock -> BlockEnv CmmBlock -> BlockEnv CmmBlock
426 427 428 429 430 431 432 433
insertBlock block map =
  ASSERT (isNothing $ mapLookup id map)
  mapInsert id block map
  where id = entryLabel block

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

434 435 436 437 438 439 440 441 442 443 444
-- | 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)

445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472
-- | 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

473
ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
Simon Marlow's avatar
Simon Marlow committed
474 475
ofBlockList entry blocks = CmmGraph { g_entry = entry
                                    , g_graph = GMany NothingO body NothingO }
476 477 478 479 480 481 482 483 484 485
  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 =
486
  ofBlockMap (entryLabel $ mf $ CmmEntry $ g_entry g) $ mapMap (mapBlock3' funs) $ toBlockMap g
487

488
mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
489
mapGraphNodes1 f = modifyGraph (mapGraph f)
490 491


492 493 494 495
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
496
postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g)
497 498 499 500 501

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

-- Constructing forward and backward analysis-only pass
502 503
analFwd    :: DataflowLattice f -> FwdTransfer n f -> FwdPass UniqSM n f
analBwd    :: DataflowLattice f -> BwdTransfer n f -> BwdPass UniqSM n f
504 505 506 507 508

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
509
analRewFwd :: DataflowLattice f -> FwdTransfer n f
510 511
           -> FwdRewrite UniqSM n f
           -> FwdPass UniqSM n f
Simon Marlow's avatar
Simon Marlow committed
512 513 514

analRewBwd :: DataflowLattice f
           -> BwdTransfer n f
515 516
           -> BwdRewrite UniqSM n f
           -> BwdPass UniqSM n f
517 518 519 520 521

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
522 523
dataflowPassFwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
524 525
                -> FwdPass UniqSM n f
                -> UniqSM (GenCmmGraph n, BlockEnv f)
526 527 528 529
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
530 531
dataflowAnalFwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
532
                -> FwdPass UniqSM n f
533 534 535
                -> 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
536

Simon Marlow's avatar
Simon Marlow committed
537 538
dataflowAnalFwdBlocks :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
539 540
                -> FwdPass UniqSM n f
                -> UniqSM (BlockEnv f)
Simon Marlow's avatar
Simon Marlow committed
541 542 543 544 545
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
546 547
dataflowAnalBwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
548
                -> BwdPass UniqSM n f
549 550 551
                -> 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
552 553 554

dataflowPassBwd :: NonLocal n =>
                   GenCmmGraph n -> [(BlockId, f)]
555 556
                -> BwdPass UniqSM n f
                -> UniqSM (GenCmmGraph n, BlockEnv f)
557 558 559
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)