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