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