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