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