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