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