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