Cleanups, remove commented-out code
[ghc.git] / compiler / cmm / CmmUtils.hs
1 {-# LANGUAGE CPP, GADTs, RankNTypes #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Cmm utilities.
6 --
7 -- (c) The University of Glasgow 2004-2006
8 --
9 -----------------------------------------------------------------------------
10
11 module CmmUtils(
12 -- CmmType
13 primRepCmmType, slotCmmType, slotForeignHint,
14 typeCmmType, typeForeignHint, primRepForeignHint,
15
16 -- CmmLit
17 zeroCLit, mkIntCLit,
18 mkWordCLit, packHalfWordsCLit,
19 mkByteStringCLit,
20 mkDataLits, mkRODataLits,
21 mkStgWordCLit,
22
23 -- CmmExpr
24 mkIntExpr, zeroExpr,
25 mkLblExpr,
26 cmmRegOff, cmmOffset, cmmLabelOff, cmmOffsetLit, cmmOffsetExpr,
27 cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,
28 cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,
29 cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,
30 cmmNegate,
31 cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
32 cmmSLtWord,
33 cmmNeWord, cmmEqWord,
34 cmmOrWord, cmmAndWord,
35 cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,
36 cmmToWord,
37
38 isTrivialCmmExpr, hasNoGlobalRegs,
39
40 -- Statics
41 blankWord,
42
43 -- Tagging
44 cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,
45 cmmConstrTag1,
46
47 -- Overlap and usage
48 regsOverlap, regUsedIn,
49
50 -- Liveness and bitmaps
51 mkLiveness,
52
53 -- * Operations that probably don't belong here
54 modifyGraph,
55
56 ofBlockMap, toBlockMap, insertBlock,
57 ofBlockList, toBlockList, bodyToBlockList,
58 toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
59 foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
60
61 -- * Ticks
62 blockTicks
63 ) where
64
65 #include "HsVersions.h"
66
67 import TyCon ( PrimRep(..), PrimElemRep(..) )
68 import RepType ( UnaryType, SlotTy (..), typePrimRep1 )
69
70 import SMRep
71 import Cmm
72 import BlockId
73 import CLabel
74 import Outputable
75 import DynFlags
76 import Util
77 import CodeGen.Platform
78
79 import Data.Word
80 import Data.Maybe
81 import Data.Bits
82 import Hoopl.Graph
83 import Hoopl.Label
84 import Hoopl.Block
85 import Hoopl.Collections
86
87 ---------------------------------------------------
88 --
89 -- CmmTypes
90 --
91 ---------------------------------------------------
92
93 primRepCmmType :: DynFlags -> PrimRep -> CmmType
94 primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep"
95 primRepCmmType dflags LiftedRep = gcWord dflags
96 primRepCmmType dflags UnliftedRep = gcWord dflags
97 primRepCmmType dflags IntRep = bWord dflags
98 primRepCmmType dflags WordRep = bWord dflags
99 primRepCmmType _ Int64Rep = b64
100 primRepCmmType _ Word64Rep = b64
101 primRepCmmType dflags AddrRep = bWord dflags
102 primRepCmmType _ FloatRep = f32
103 primRepCmmType _ DoubleRep = f64
104 primRepCmmType _ (VecRep len rep) = vec len (primElemRepCmmType rep)
105
106 slotCmmType :: DynFlags -> SlotTy -> CmmType
107 slotCmmType dflags PtrSlot = gcWord dflags
108 slotCmmType dflags WordSlot = bWord dflags
109 slotCmmType _ Word64Slot = b64
110 slotCmmType _ FloatSlot = f32
111 slotCmmType _ DoubleSlot = f64
112
113 primElemRepCmmType :: PrimElemRep -> CmmType
114 primElemRepCmmType Int8ElemRep = b8
115 primElemRepCmmType Int16ElemRep = b16
116 primElemRepCmmType Int32ElemRep = b32
117 primElemRepCmmType Int64ElemRep = b64
118 primElemRepCmmType Word8ElemRep = b8
119 primElemRepCmmType Word16ElemRep = b16
120 primElemRepCmmType Word32ElemRep = b32
121 primElemRepCmmType Word64ElemRep = b64
122 primElemRepCmmType FloatElemRep = f32
123 primElemRepCmmType DoubleElemRep = f64
124
125 typeCmmType :: DynFlags -> UnaryType -> CmmType
126 typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)
127
128 primRepForeignHint :: PrimRep -> ForeignHint
129 primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep"
130 primRepForeignHint LiftedRep = AddrHint
131 primRepForeignHint UnliftedRep = AddrHint
132 primRepForeignHint IntRep = SignedHint
133 primRepForeignHint WordRep = NoHint
134 primRepForeignHint Int64Rep = SignedHint
135 primRepForeignHint Word64Rep = NoHint
136 primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg
137 primRepForeignHint FloatRep = NoHint
138 primRepForeignHint DoubleRep = NoHint
139 primRepForeignHint (VecRep {}) = NoHint
140
141 slotForeignHint :: SlotTy -> ForeignHint
142 slotForeignHint PtrSlot = AddrHint
143 slotForeignHint WordSlot = NoHint
144 slotForeignHint Word64Slot = NoHint
145 slotForeignHint FloatSlot = NoHint
146 slotForeignHint DoubleSlot = NoHint
147
148 typeForeignHint :: UnaryType -> ForeignHint
149 typeForeignHint = primRepForeignHint . typePrimRep1
150
151 ---------------------------------------------------
152 --
153 -- CmmLit
154 --
155 ---------------------------------------------------
156
157 -- XXX: should really be Integer, since Int doesn't necessarily cover
158 -- the full range of target Ints.
159 mkIntCLit :: DynFlags -> Int -> CmmLit
160 mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
161
162 mkIntExpr :: DynFlags -> Int -> CmmExpr
163 mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i
164
165 zeroCLit :: DynFlags -> CmmLit
166 zeroCLit dflags = CmmInt 0 (wordWidth dflags)
167
168 zeroExpr :: DynFlags -> CmmExpr
169 zeroExpr dflags = CmmLit (zeroCLit dflags)
170
171 mkWordCLit :: DynFlags -> Integer -> CmmLit
172 mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)
173
174 mkByteStringCLit
175 :: CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
176 -- We have to make a top-level decl for the string,
177 -- and return a literal pointing to it
178 mkByteStringCLit lbl bytes
179 = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])
180 where
181 -- This can not happen for String literals (as there \NUL is replaced by
182 -- C0 80). However, it can happen with Addr# literals.
183 sec = if 0 `elem` bytes then ReadOnlyData else CString
184
185 mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
186 -- Build a data-segment data block
187 mkDataLits section lbl lits
188 = CmmData section (Statics lbl $ map CmmStaticLit lits)
189
190 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
191 -- Build a read-only data block
192 mkRODataLits lbl lits
193 = mkDataLits section lbl lits
194 where
195 section | any needsRelocation lits = Section RelocatableReadOnlyData lbl
196 | otherwise = Section ReadOnlyData lbl
197 needsRelocation (CmmLabel _) = True
198 needsRelocation (CmmLabelOff _ _) = True
199 needsRelocation _ = False
200
201 mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
202 mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
203
204 packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
205 -- Make a single word literal in which the lower_half_word is
206 -- at the lower address, and the upper_half_word is at the
207 -- higher address
208 -- ToDo: consider using half-word lits instead
209 -- but be careful: that's vulnerable when reversed
210 packHalfWordsCLit dflags lower_half_word upper_half_word
211 = if wORDS_BIGENDIAN dflags
212 then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u)
213 else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags))
214 where l = fromStgHalfWord lower_half_word
215 u = fromStgHalfWord upper_half_word
216
217 ---------------------------------------------------
218 --
219 -- CmmExpr
220 --
221 ---------------------------------------------------
222
223 mkLblExpr :: CLabel -> CmmExpr
224 mkLblExpr lbl = CmmLit (CmmLabel lbl)
225
226 cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
227 -- assumes base and offset have the same CmmType
228 cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n)
229 cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off]
230
231 cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr
232 cmmOffset _ e 0 = e
233 cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off
234 cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
235 cmmOffset _ (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off)
236 cmmOffset _ (CmmStackSlot area off) byte_off
237 = CmmStackSlot area (off - byte_off)
238 -- note stack area offsets increase towards lower addresses
239 cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
240 = CmmMachOp (MO_Add rep)
241 [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
242 cmmOffset dflags expr byte_off
243 = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
244 where
245 width = cmmExprWidth dflags expr
246
247 -- Smart constructor for CmmRegOff. Same caveats as cmmOffset above.
248 cmmRegOff :: CmmReg -> Int -> CmmExpr
249 cmmRegOff reg 0 = CmmReg reg
250 cmmRegOff reg byte_off = CmmRegOff reg byte_off
251
252 cmmOffsetLit :: CmmLit -> Int -> CmmLit
253 cmmOffsetLit (CmmLabel l) byte_off = cmmLabelOff l byte_off
254 cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
255 cmmOffsetLit (CmmLabelDiffOff l1 l2 m) byte_off
256 = CmmLabelDiffOff l1 l2 (m+byte_off)
257 cmmOffsetLit (CmmInt m rep) byte_off = CmmInt (m + fromIntegral byte_off) rep
258 cmmOffsetLit _ byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
259
260 cmmLabelOff :: CLabel -> Int -> CmmLit
261 -- Smart constructor for CmmLabelOff
262 cmmLabelOff lbl 0 = CmmLabel lbl
263 cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off
264
265 -- | Useful for creating an index into an array, with a statically known offset.
266 -- The type is the element type; used for making the multiplier
267 cmmIndex :: DynFlags
268 -> Width -- Width w
269 -> CmmExpr -- Address of vector of items of width w
270 -> Int -- Which element of the vector (0 based)
271 -> CmmExpr -- Address of i'th element
272 cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)
273
274 -- | Useful for creating an index into an array, with an unknown offset.
275 cmmIndexExpr :: DynFlags
276 -> Width -- Width w
277 -> CmmExpr -- Address of vector of items of width w
278 -> CmmExpr -- Which element of the vector (0 based)
279 -> CmmExpr -- Address of i'th element
280 cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)
281 cmmIndexExpr dflags width base idx =
282 cmmOffsetExpr dflags base byte_off
283 where
284 idx_w = cmmExprWidth dflags idx
285 byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]
286
287 cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
288 cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty
289
290 -- The "B" variants take byte offsets
291 cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
292 cmmRegOffB = cmmRegOff
293
294 cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
295 cmmOffsetB = cmmOffset
296
297 cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
298 cmmOffsetExprB = cmmOffsetExpr
299
300 cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
301 cmmLabelOffB = cmmLabelOff
302
303 cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
304 cmmOffsetLitB = cmmOffsetLit
305
306 -----------------------
307 -- The "W" variants take word offsets
308
309 cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
310 -- The second arg is a *word* offset; need to change it to bytes
311 cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)
312 cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off
313
314 cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
315 cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)
316
317 cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
318 cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)
319
320 cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
321 cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)
322
323 cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
324 cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)
325
326 cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
327 cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty
328
329 -----------------------
330 cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
331 cmmSLtWord,
332 cmmNeWord, cmmEqWord,
333 cmmOrWord, cmmAndWord,
334 cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
335 :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
336 cmmOrWord dflags e1 e2 = CmmMachOp (mo_wordOr dflags) [e1, e2]
337 cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]
338 cmmNeWord dflags e1 e2 = CmmMachOp (mo_wordNe dflags) [e1, e2]
339 cmmEqWord dflags e1 e2 = CmmMachOp (mo_wordEq dflags) [e1, e2]
340 cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]
341 cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]
342 cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]
343 cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
344 cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]
345 cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]
346 cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]
347 cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]
348 cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]
349
350 cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
351 cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
352 cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
353
354 blankWord :: DynFlags -> CmmStatic
355 blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
356
357 cmmToWord :: DynFlags -> CmmExpr -> CmmExpr
358 cmmToWord dflags e
359 | w == word = e
360 | otherwise = CmmMachOp (MO_UU_Conv w word) [e]
361 where
362 w = cmmExprWidth dflags e
363 word = wordWidth dflags
364
365 ---------------------------------------------------
366 --
367 -- CmmExpr predicates
368 --
369 ---------------------------------------------------
370
371 isTrivialCmmExpr :: CmmExpr -> Bool
372 isTrivialCmmExpr (CmmLoad _ _) = False
373 isTrivialCmmExpr (CmmMachOp _ _) = False
374 isTrivialCmmExpr (CmmLit _) = True
375 isTrivialCmmExpr (CmmReg _) = True
376 isTrivialCmmExpr (CmmRegOff _ _) = True
377 isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
378
379 hasNoGlobalRegs :: CmmExpr -> Bool
380 hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e
381 hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es
382 hasNoGlobalRegs (CmmLit _) = True
383 hasNoGlobalRegs (CmmReg (CmmLocal _)) = True
384 hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
385 hasNoGlobalRegs _ = False
386
387 ---------------------------------------------------
388 --
389 -- Tagging
390 --
391 ---------------------------------------------------
392
393 -- Tag bits mask
394 cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
395 cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
396 cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
397
398 -- Used to untag a possibly tagged pointer
399 -- A static label need not be untagged
400 cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
401 cmmUntag _ e@(CmmLit (CmmLabel _)) = e
402 -- Default case
403 cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
404
405 -- Test if a closure pointer is untagged
406 cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
407
408 -- Get constructor tag, but one based.
409 cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
410
411
412 -----------------------------------------------------------------------------
413 -- Overlap and usage
414
415 -- | Returns True if the two STG registers overlap on the specified
416 -- platform, in the sense that writing to one will clobber the
417 -- other. This includes the case that the two registers are the same
418 -- STG register. See Note [Overlapping global registers] for details.
419 regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool
420 regsOverlap dflags (CmmGlobal g) (CmmGlobal g')
421 | Just real <- globalRegMaybe (targetPlatform dflags) g,
422 Just real' <- globalRegMaybe (targetPlatform dflags) g',
423 real == real'
424 = True
425 regsOverlap _ reg reg' = reg == reg'
426
427 -- | Returns True if the STG register is used by the expression, in
428 -- the sense that a store to the register might affect the value of
429 -- the expression.
430 --
431 -- We must check for overlapping registers and not just equal
432 -- registers here, otherwise CmmSink may incorrectly reorder
433 -- assignments that conflict due to overlap. See Trac #10521 and Note
434 -- [Overlapping global registers].
435 regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool
436 regUsedIn dflags = regUsedIn_ where
437 _ `regUsedIn_` CmmLit _ = False
438 reg `regUsedIn_` CmmLoad e _ = reg `regUsedIn_` e
439 reg `regUsedIn_` CmmReg reg' = regsOverlap dflags reg reg'
440 reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'
441 reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es
442 _ `regUsedIn_` CmmStackSlot _ _ = False
443
444 --------------------------------------------
445 --
446 -- mkLiveness
447 --
448 ---------------------------------------------
449
450 mkLiveness :: DynFlags -> [Maybe LocalReg] -> Liveness
451 mkLiveness _ [] = []
452 mkLiveness dflags (reg:regs)
453 = take sizeW bits ++ mkLiveness dflags regs
454 where
455 sizeW = case reg of
456 Nothing -> 1
457 Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE dflags - 1)
458 `quot` wORD_SIZE dflags
459 -- number of words, rounded up
460 bits = repeat $ is_non_ptr reg -- True <=> Non Ptr
461
462 is_non_ptr Nothing = True
463 is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg)
464
465
466 -- ============================================== -
467 -- ============================================== -
468 -- ============================================== -
469
470 ---------------------------------------------------
471 --
472 -- Manipulating CmmGraphs
473 --
474 ---------------------------------------------------
475
476 modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
477 modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
478
479 toBlockMap :: CmmGraph -> LabelMap CmmBlock
480 toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
481
482 ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
483 ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
484
485 insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
486 insertBlock block map =
487 ASSERT(isNothing $ mapLookup id map)
488 mapInsert id block map
489 where id = entryLabel block
490
491 toBlockList :: CmmGraph -> [CmmBlock]
492 toBlockList g = mapElems $ toBlockMap g
493
494 -- | like 'toBlockList', but the entry block always comes first
495 toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
496 toBlockListEntryFirst g
497 | mapNull m = []
498 | otherwise = entry_block : others
499 where
500 m = toBlockMap g
501 entry_id = g_entry g
502 Just entry_block = mapLookup entry_id m
503 others = filter ((/= entry_id) . entryLabel) (mapElems m)
504
505 -- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks
506 -- so that the false case of a conditional jumps to the next block in the output
507 -- list of blocks. This matches the way OldCmm blocks were output since in
508 -- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches
509 -- have both true and false successors. Block ordering can make a big difference
510 -- in performance in the LLVM backend. Note that we rely crucially on the order
511 -- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode
512 -- defined in cmm/CmmNode.hs. -GBM
513 toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]
514 toBlockListEntryFirstFalseFallthrough g
515 | mapNull m = []
516 | otherwise = dfs setEmpty [entry_block]
517 where
518 m = toBlockMap g
519 entry_id = g_entry g
520 Just entry_block = mapLookup entry_id m
521
522 dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]
523 dfs _ [] = []
524 dfs visited (block:bs)
525 | id `setMember` visited = dfs visited bs
526 | otherwise = block : dfs (setInsert id visited) bs'
527 where id = entryLabel block
528 bs' = foldr add_id bs (successors block)
529 add_id id bs = case mapLookup id m of
530 Just b -> b : bs
531 Nothing -> bs
532
533 ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
534 ofBlockList entry blocks = CmmGraph { g_entry = entry
535 , g_graph = GMany NothingO body NothingO }
536 where body = foldr addBlock emptyBody blocks
537
538 bodyToBlockList :: Body CmmNode -> [CmmBlock]
539 bodyToBlockList body = mapElems body
540
541 mapGraphNodes :: ( CmmNode C O -> CmmNode C O
542 , CmmNode O O -> CmmNode O O
543 , CmmNode O C -> CmmNode O C)
544 -> CmmGraph -> CmmGraph
545 mapGraphNodes funs@(mf,_,_) g =
546 ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $
547 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 foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a
554 foldGraphBlocks k z g = mapFold k z $ toBlockMap g
555
556 postorderDfs :: CmmGraph -> [CmmBlock]
557 postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g)
558
559 -------------------------------------------------
560 -- Tick utilities
561
562 -- | Extract all tick annotations from the given block
563 blockTicks :: Block CmmNode C C -> [CmmTickish]
564 blockTicks b = reverse $ foldBlockNodesF goStmt b []
565 where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
566 goStmt (CmmTick t) ts = t:ts
567 goStmt _other ts = ts