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