Add support for producing position-independent executables
[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 --cmmShlWord dflags e1 e2 = CmmMachOp (mo_wordShl dflags) [e1, e2]
344 cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
345 cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]
346 cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]
347 cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]
348 cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]
349 cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]
350
351 cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
352 cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
353 cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
354
355 blankWord :: DynFlags -> CmmStatic
356 blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
357
358 cmmToWord :: DynFlags -> CmmExpr -> CmmExpr
359 cmmToWord dflags e
360 | w == word = e
361 | otherwise = CmmMachOp (MO_UU_Conv w word) [e]
362 where
363 w = cmmExprWidth dflags e
364 word = wordWidth dflags
365
366 ---------------------------------------------------
367 --
368 -- CmmExpr predicates
369 --
370 ---------------------------------------------------
371
372 isTrivialCmmExpr :: CmmExpr -> Bool
373 isTrivialCmmExpr (CmmLoad _ _) = False
374 isTrivialCmmExpr (CmmMachOp _ _) = False
375 isTrivialCmmExpr (CmmLit _) = True
376 isTrivialCmmExpr (CmmReg _) = True
377 isTrivialCmmExpr (CmmRegOff _ _) = True
378 isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
379
380 hasNoGlobalRegs :: CmmExpr -> Bool
381 hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e
382 hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es
383 hasNoGlobalRegs (CmmLit _) = True
384 hasNoGlobalRegs (CmmReg (CmmLocal _)) = True
385 hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
386 hasNoGlobalRegs _ = False
387
388 ---------------------------------------------------
389 --
390 -- Tagging
391 --
392 ---------------------------------------------------
393
394 -- Tag bits mask
395 --cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
396 cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
397 cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
398 cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
399
400 -- Used to untag a possibly tagged pointer
401 -- A static label need not be untagged
402 cmmUntag :: DynFlags -> CmmExpr -> CmmExpr
403 cmmUntag _ e@(CmmLit (CmmLabel _)) = e
404 -- Default case
405 cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
406
407 -- Test if a closure pointer is untagged
408 cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr
409 cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
410
411 cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
412 -- Get constructor tag, but one based.
413 cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
414
415
416 -----------------------------------------------------------------------------
417 -- Overlap and usage
418
419 -- | Returns True if the two STG registers overlap on the specified
420 -- platform, in the sense that writing to one will clobber the
421 -- other. This includes the case that the two registers are the same
422 -- STG register. See Note [Overlapping global registers] for details.
423 regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool
424 regsOverlap dflags (CmmGlobal g) (CmmGlobal g')
425 | Just real <- globalRegMaybe (targetPlatform dflags) g,
426 Just real' <- globalRegMaybe (targetPlatform dflags) g',
427 real == real'
428 = True
429 regsOverlap _ reg reg' = reg == reg'
430
431 -- | Returns True if the STG register is used by the expression, in
432 -- the sense that a store to the register might affect the value of
433 -- the expression.
434 --
435 -- We must check for overlapping registers and not just equal
436 -- registers here, otherwise CmmSink may incorrectly reorder
437 -- assignments that conflict due to overlap. See Trac #10521 and Note
438 -- [Overlapping global registers].
439 regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool
440 regUsedIn dflags = regUsedIn_ where
441 _ `regUsedIn_` CmmLit _ = False
442 reg `regUsedIn_` CmmLoad e _ = reg `regUsedIn_` e
443 reg `regUsedIn_` CmmReg reg' = regsOverlap dflags reg reg'
444 reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'
445 reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es
446 _ `regUsedIn_` CmmStackSlot _ _ = False
447
448 --------------------------------------------
449 --
450 -- mkLiveness
451 --
452 ---------------------------------------------
453
454 mkLiveness :: DynFlags -> [Maybe LocalReg] -> Liveness
455 mkLiveness _ [] = []
456 mkLiveness dflags (reg:regs)
457 = take sizeW bits ++ mkLiveness dflags regs
458 where
459 sizeW = case reg of
460 Nothing -> 1
461 Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE dflags - 1)
462 `quot` wORD_SIZE dflags
463 -- number of words, rounded up
464 bits = repeat $ is_non_ptr reg -- True <=> Non Ptr
465
466 is_non_ptr Nothing = True
467 is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg)
468
469
470 -- ============================================== -
471 -- ============================================== -
472 -- ============================================== -
473
474 ---------------------------------------------------
475 --
476 -- Manipulating CmmGraphs
477 --
478 ---------------------------------------------------
479
480 modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
481 modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
482
483 toBlockMap :: CmmGraph -> LabelMap CmmBlock
484 toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
485
486 ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
487 ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
488
489 insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
490 insertBlock block map =
491 ASSERT(isNothing $ mapLookup id map)
492 mapInsert id block map
493 where id = entryLabel block
494
495 toBlockList :: CmmGraph -> [CmmBlock]
496 toBlockList g = mapElems $ toBlockMap g
497
498 -- | like 'toBlockList', but the entry block always comes first
499 toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
500 toBlockListEntryFirst g
501 | mapNull m = []
502 | otherwise = entry_block : others
503 where
504 m = toBlockMap g
505 entry_id = g_entry g
506 Just entry_block = mapLookup entry_id m
507 others = filter ((/= entry_id) . entryLabel) (mapElems m)
508
509 -- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks
510 -- so that the false case of a conditional jumps to the next block in the output
511 -- list of blocks. This matches the way OldCmm blocks were output since in
512 -- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches
513 -- have both true and false successors. Block ordering can make a big difference
514 -- in performance in the LLVM backend. Note that we rely crucially on the order
515 -- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode
516 -- defined in cmm/CmmNode.hs. -GBM
517 toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]
518 toBlockListEntryFirstFalseFallthrough g
519 | mapNull m = []
520 | otherwise = dfs setEmpty [entry_block]
521 where
522 m = toBlockMap g
523 entry_id = g_entry g
524 Just entry_block = mapLookup entry_id m
525
526 dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]
527 dfs _ [] = []
528 dfs visited (block:bs)
529 | id `setMember` visited = dfs visited bs
530 | otherwise = block : dfs (setInsert id visited) bs'
531 where id = entryLabel block
532 bs' = foldr add_id bs (successors block)
533 add_id id bs = case mapLookup id m of
534 Just b -> b : bs
535 Nothing -> bs
536
537 ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
538 ofBlockList entry blocks = CmmGraph { g_entry = entry
539 , g_graph = GMany NothingO body NothingO }
540 where body = foldr addBlock emptyBody blocks
541
542 bodyToBlockList :: Body CmmNode -> [CmmBlock]
543 bodyToBlockList body = mapElems body
544
545 mapGraphNodes :: ( CmmNode C O -> CmmNode C O
546 , CmmNode O O -> CmmNode O O
547 , CmmNode O C -> CmmNode O C)
548 -> CmmGraph -> CmmGraph
549 mapGraphNodes funs@(mf,_,_) g =
550 ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $
551 mapMap (mapBlock3' funs) $ toBlockMap g
552
553 mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
554 mapGraphNodes1 f = modifyGraph (mapGraph f)
555
556
557 foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a
558 foldGraphBlocks k z g = mapFold k z $ toBlockMap g
559
560 postorderDfs :: CmmGraph -> [CmmBlock]
561 postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g)
562
563 -------------------------------------------------
564 -- Tick utilities
565
566 -- | Extract all tick annotations from the given block
567 blockTicks :: Block CmmNode C C -> [CmmTickish]
568 blockTicks b = reverse $ foldBlockNodesF goStmt b []
569 where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
570 goStmt (CmmTick t) ts = t:ts
571 goStmt _other ts = ts