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