Allow resizing the stack for the graph allocator.
[ghc.git] / compiler / nativeGen / CFG.hs
1 --
2 -- Copyright (c) 2018 Andreas Klebinger
3 --
4
5 {-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
6 {-# LANGUAGE TupleSections #-}
7 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
8 {-# LANGUAGE CPP #-}
9
10 module CFG
11 ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..)
12 , TransitionSource(..)
13
14 --Modify the CFG
15 , addWeightEdge, addEdge, delEdge
16 , addNodesBetween, shortcutWeightMap
17 , reverseEdges, filterEdges
18 , addImmediateSuccessor
19 , mkWeightInfo, adjustEdgeWeight
20
21 --Query the CFG
22 , infoEdgeList, edgeList
23 , getSuccessorEdges, getSuccessors
24 , getSuccEdgesSorted, weightedEdgeList
25 , getEdgeInfo
26 , getCfgNodes, hasNode
27 , loopMembers
28
29 --Construction/Misc
30 , getCfg, getCfgProc, pprEdgeWeights, sanityCheckCfg
31
32 --Find backedges and update their weight
33 , optimizeCFG )
34 where
35
36 #include "HsVersions.h"
37
38 import GhcPrelude
39
40 import BlockId
41 import Cmm ( RawCmmDecl, GenCmmDecl( .. ), CmmBlock, succ, g_entry
42 , CmmGraph )
43 import CmmNode
44 import CmmUtils
45 import CmmSwitch
46 import Hoopl.Collections
47 import Hoopl.Label
48 import Hoopl.Block
49 import qualified Hoopl.Graph as G
50
51 import Util
52 import Digraph
53
54 import Outputable
55 -- DEBUGGING ONLY
56 --import Debug
57 --import OrdList
58 --import Debug.Trace
59 import PprCmm ()
60 import qualified DynFlags as D
61
62 import Data.List
63
64 -- import qualified Data.IntMap.Strict as M --TODO: LabelMap
65
66 type Edge = (BlockId, BlockId)
67 type Edges = [Edge]
68
69 newtype EdgeWeight
70 = EdgeWeight Int
71 deriving (Eq,Ord,Enum,Num,Real,Integral)
72
73 instance Outputable EdgeWeight where
74 ppr (EdgeWeight w) = ppr w
75
76 type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo)
77
78 -- | A control flow graph where edges have been annotated with a weight.
79 type CFG = EdgeInfoMap EdgeInfo
80
81 data CfgEdge
82 = CfgEdge
83 { edgeFrom :: !BlockId
84 , edgeTo :: !BlockId
85 , edgeInfo :: !EdgeInfo
86 }
87
88 -- | Careful! Since we assume there is at most one edge from A to B
89 -- the Eq instance does not consider weight.
90 instance Eq CfgEdge where
91 (==) (CfgEdge from1 to1 _) (CfgEdge from2 to2 _)
92 = from1 == from2 && to1 == to2
93
94 -- | Edges are sorted ascending pointwise by weight, source and destination
95 instance Ord CfgEdge where
96 compare (CfgEdge from1 to1 (EdgeInfo {edgeWeight = weight1}))
97 (CfgEdge from2 to2 (EdgeInfo {edgeWeight = weight2}))
98 | weight1 < weight2 || weight1 == weight2 && from1 < from2 ||
99 weight1 == weight2 && from1 == from2 && to1 < to2
100 = LT
101 | from1 == from2 && to1 == to2 && weight1 == weight2
102 = EQ
103 | otherwise
104 = GT
105
106 instance Outputable CfgEdge where
107 ppr (CfgEdge from1 to1 edgeInfo)
108 = parens (ppr from1 <+> text "-(" <> ppr edgeInfo <> text ")->" <+> ppr to1)
109
110 -- | Can we trace back a edge to a specific Cmm Node
111 -- or has it been introduced for codegen. We use this to maintain
112 -- some information which would otherwise be lost during the
113 -- Cmm <-> asm transition.
114 -- See also Note [Inverting Conditional Branches]
115 data TransitionSource
116 = CmmSource (CmmNode O C)
117 | AsmCodeGen
118 deriving (Eq)
119
120 -- | Information about edges
121 data EdgeInfo
122 = EdgeInfo
123 { transitionSource :: !TransitionSource
124 , edgeWeight :: !EdgeWeight
125 } deriving (Eq)
126
127 instance Outputable EdgeInfo where
128 ppr edgeInfo = text "weight:" <+> ppr (edgeWeight edgeInfo)
129
130 -- Allow specialization
131 {-# INLINEABLE mkWeightInfo #-}
132 -- | Convenience function, generate edge info based
133 -- on weight not originating from cmm.
134 mkWeightInfo :: Integral n => n -> EdgeInfo
135 mkWeightInfo = EdgeInfo AsmCodeGen . fromIntegral
136
137 -- | Adjust the weight between the blocks using the given function.
138 -- If there is no such edge returns the original map.
139 adjustEdgeWeight :: CFG -> (EdgeWeight -> EdgeWeight)
140 -> BlockId -> BlockId -> CFG
141 adjustEdgeWeight cfg f from to
142 | Just info <- getEdgeInfo from to cfg
143 , weight <- edgeWeight info
144 = addEdge from to (info { edgeWeight = f weight}) cfg
145 | otherwise = cfg
146
147 getCfgNodes :: CFG -> LabelSet
148 getCfgNodes m = mapFoldMapWithKey (\k v -> setFromList (k:mapKeys v)) m
149
150 hasNode :: CFG -> BlockId -> Bool
151 hasNode m node = mapMember node m || any (mapMember node) m
152
153 -- | Check if the nodes in the cfg and the set of blocks are the same.
154 -- In a case of a missmatch we panic and show the difference.
155 sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool
156 sanityCheckCfg m blockSet msg
157 | blockSet == cfgNodes
158 = True
159 | otherwise =
160 pprPanic "Block list and cfg nodes don't match" (
161 text "difference:" <+> ppr diff $$
162 text "blocks:" <+> ppr blockSet $$
163 text "cfg:" <+> ppr m $$
164 msg )
165 False
166 where
167 cfgNodes = getCfgNodes m :: LabelSet
168 diff = (setUnion cfgNodes blockSet) `setDifference` (setIntersection cfgNodes blockSet) :: LabelSet
169
170 -- | Filter the CFG with a custom function f.
171 -- Paramaeters are `f from to edgeInfo`
172 filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG
173 filterEdges f cfg =
174 mapMapWithKey filterSources cfg
175 where
176 filterSources from m =
177 mapFilterWithKey (\to w -> f from to w) m
178
179
180 {- Note [Updating the CFG during shortcutting]
181
182 See Note [What is shortcutting] in the control flow optimization
183 code (CmmContFlowOpt.hs) for a slightly more in depth explanation on shortcutting.
184
185 In the native backend we shortcut jumps at the assembly level. (AsmCodeGen.hs)
186 This means we remove blocks containing only one jump from the code
187 and instead redirecting all jumps targeting this block to the deleted
188 blocks jump target.
189
190 However we want to have an accurate representation of control
191 flow in the CFG. So we add/remove edges accordingly to account
192 for the eliminated blocks and new edges.
193
194 If we shortcut A -> B -> C to A -> C:
195 * We delete edges A -> B and B -> C
196 * Replacing them with the edge A -> C
197
198 We also try to preserve jump weights while doing so.
199
200 Note that:
201 * The edge B -> C can't have interesting weights since
202 the block B consists of a single unconditional jump without branching.
203 * We delete the edge A -> B and add the edge A -> C.
204 * The edge A -> B can be one of many edges originating from A so likely
205 has edge weights we want to preserve.
206
207 For this reason we simply store the edge info from the original A -> B
208 edge and apply this information to the new edge A -> C.
209
210 Sometimes we have a scenario where jump target C is not represented by an
211 BlockId but an immediate value. I'm only aware of this happening without
212 tables next to code currently.
213
214 Then we go from A ---> B - -> IMM to A - -> IMM where the dashed arrows
215 are not stored in the CFG.
216
217 In that case we simply delete the edge A -> B.
218
219 In terms of implementation the native backend first builds a mapping
220 from blocks suitable for shortcutting to their jump targets.
221 Then it redirects all jump instructions to these blocks using the
222 built up mapping.
223 This function (shortcutWeightMap) takes the same mapping and
224 applies the mapping to the CFG in the way layed out above.
225
226 -}
227 shortcutWeightMap :: CFG -> LabelMap (Maybe BlockId) -> CFG
228 shortcutWeightMap cfg cuts =
229 foldl' applyMapping cfg $ mapToList cuts
230 where
231 -- takes the tuple (B,C) from the notation in [Updating the CFG during shortcutting]
232 applyMapping :: CFG -> (BlockId,Maybe BlockId) -> CFG
233 --Shortcut immediate
234 applyMapping m (from, Nothing) =
235 mapDelete from .
236 fmap (mapDelete from) $ m
237 --Regular shortcut
238 applyMapping m (from, Just to) =
239 let updatedMap :: CFG
240 updatedMap
241 = fmap (shortcutEdge (from,to)) $
242 (mapDelete from m :: CFG )
243 --Sometimes we can shortcut multiple blocks like so:
244 -- A -> B -> C -> D -> E => A -> E
245 -- so we check for such chains.
246 in case mapLookup to cuts of
247 Nothing -> updatedMap
248 Just dest -> applyMapping updatedMap (to, dest)
249 --Redirect edge from B to C
250 shortcutEdge :: (BlockId, BlockId) -> LabelMap EdgeInfo -> LabelMap EdgeInfo
251 shortcutEdge (from, to) m =
252 case mapLookup from m of
253 Just info -> mapInsert to info $ mapDelete from m
254 Nothing -> m
255
256 -- | Sometimes we insert a block which should unconditionally be executed
257 -- after a given block. This function updates the CFG for these cases.
258 -- So we get A -> B => A -> A' -> B
259 -- \ \
260 -- -> C => -> C
261 --
262 addImmediateSuccessor :: BlockId -> BlockId -> CFG -> CFG
263 addImmediateSuccessor node follower cfg
264 = updateEdges . addWeightEdge node follower uncondWeight $ cfg
265 where
266 uncondWeight = fromIntegral . D.uncondWeight .
267 D.cfgWeightInfo $ D.unsafeGlobalDynFlags
268 targets = getSuccessorEdges cfg node
269 successors = map fst targets :: [BlockId]
270 updateEdges = addNewSuccs . remOldSuccs
271 remOldSuccs m = foldl' (flip (delEdge node)) m successors
272 addNewSuccs m =
273 foldl' (\m' (t,info) -> addEdge follower t info m') m targets
274
275 -- | Adds a new edge, overwrites existing edges if present
276 addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
277 addEdge from to info cfg =
278 mapAlter addDest from cfg
279 where
280 addDest Nothing = Just $ mapSingleton to info
281 addDest (Just wm) = Just $ mapInsert to info wm
282
283 -- | Adds a edge with the given weight to the cfg
284 -- If there already existed an edge it is overwritten.
285 -- `addWeightEdge from to weight cfg`
286 addWeightEdge :: BlockId -> BlockId -> EdgeWeight -> CFG -> CFG
287 addWeightEdge from to weight cfg =
288 addEdge from to (mkWeightInfo weight) cfg
289
290 delEdge :: BlockId -> BlockId -> CFG -> CFG
291 delEdge from to m =
292 mapAlter remDest from m
293 where
294 remDest Nothing = Nothing
295 remDest (Just wm) = Just $ mapDelete to wm
296
297 -- | Destinations from bid ordered by weight (descending)
298 getSuccEdgesSorted :: CFG -> BlockId -> [(BlockId,EdgeInfo)]
299 getSuccEdgesSorted m bid =
300 let destMap = mapFindWithDefault mapEmpty bid m
301 cfgEdges = mapToList destMap
302 sortedEdges = sortWith (negate . edgeWeight . snd) cfgEdges
303 in --pprTrace "getSuccEdgesSorted" (ppr bid <+> text "map:" <+> ppr m)
304 sortedEdges
305
306 -- | Get successors of a given node with edge weights.
307 getSuccessorEdges :: CFG -> BlockId -> [(BlockId,EdgeInfo)]
308 getSuccessorEdges m bid = maybe [] mapToList $ mapLookup bid m
309
310 getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo
311 getEdgeInfo from to m
312 | Just wm <- mapLookup from m
313 , Just info <- mapLookup to wm
314 = Just $! info
315 | otherwise
316 = Nothing
317
318 reverseEdges :: CFG -> CFG
319 reverseEdges cfg = foldr add mapEmpty flatElems
320 where
321 elems = mapToList $ fmap mapToList cfg :: [(BlockId,[(BlockId,EdgeInfo)])]
322 flatElems =
323 concatMap (\(from,ws) -> map (\(to,info) -> (to,from,info)) ws ) elems
324 add (to,from,info) m = addEdge to from info m
325
326 -- | Returns a unordered list of all edges with info
327 infoEdgeList :: CFG -> [CfgEdge]
328 infoEdgeList m =
329 mapFoldMapWithKey
330 (\from toMap ->
331 map (\(to,info) -> CfgEdge from to info) (mapToList toMap))
332 m
333
334 -- | Unordered list of edges with weight as Tuple (from,to,weight)
335 weightedEdgeList :: CFG -> [(BlockId,BlockId,EdgeWeight)]
336 weightedEdgeList m =
337 mapFoldMapWithKey
338 (\from toMap ->
339 map (\(to,info) ->
340 (from,to, edgeWeight info)) (mapToList toMap))
341 m
342 -- (\(from, tos) -> map (\(to,info) -> (from,to, edgeWeight info)) tos )
343
344 -- | Returns a unordered list of all edges without weights
345 edgeList :: CFG -> [Edge]
346 edgeList m =
347 mapFoldMapWithKey (\from toMap -> fmap (from,) (mapKeys toMap)) m
348
349 -- | Get successors of a given node without edge weights.
350 getSuccessors :: CFG -> BlockId -> [BlockId]
351 getSuccessors m bid
352 | Just wm <- mapLookup bid m
353 = mapKeys wm
354 | otherwise = []
355
356 pprEdgeWeights :: CFG -> SDoc
357 pprEdgeWeights m =
358 let edges = sort $ weightedEdgeList m
359 printEdge (from, to, weight)
360 = text "\t" <> ppr from <+> text "->" <+> ppr to <>
361 text "[label=\"" <> ppr weight <> text "\",weight=\"" <>
362 ppr weight <> text "\"];\n"
363 --for the case that there are no edges from/to this node.
364 --This should rarely happen but it can save a lot of time
365 --to immediately see it when it does.
366 printNode node
367 = text "\t" <> ppr node <> text ";\n"
368 getEdgeNodes (from, to, _weight) = [from,to]
369 edgeNodes = setFromList $ concatMap getEdgeNodes edges :: LabelSet
370 nodes = filter (\n -> (not . setMember n) edgeNodes) . mapKeys $ mapFilter null m
371 in
372 text "digraph {\n" <>
373 (foldl' (<>) empty (map printEdge edges)) <>
374 (foldl' (<>) empty (map printNode nodes)) <>
375 text "}\n"
376
377 {-# INLINE updateEdgeWeight #-} --Allows eliminating the tuple when possible
378 updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG
379 updateEdgeWeight f (from, to) cfg
380 | Just oldInfo <- getEdgeInfo from to cfg
381 = let oldWeight = edgeWeight oldInfo
382 newWeight = f oldWeight
383 in addEdge from to (oldInfo {edgeWeight = newWeight}) cfg
384 | otherwise
385 = panic "Trying to update invalid edge"
386
387 -- from to oldWeight => newWeight
388 mapWeights :: (BlockId -> BlockId -> EdgeWeight -> EdgeWeight) -> CFG -> CFG
389 mapWeights f cfg =
390 foldl' (\cfg (CfgEdge from to info) ->
391 let oldWeight = edgeWeight info
392 newWeight = f from to oldWeight
393 in addEdge from to (info {edgeWeight = newWeight}) cfg)
394 cfg (infoEdgeList cfg)
395
396
397 -- | Insert a block in the control flow between two other blocks.
398 -- We pass a list of tuples (A,B,C) where
399 -- * A -> C: Old edge
400 -- * A -> B -> C : New Arc, where B is the new block.
401 -- It's possible that a block has two jumps to the same block
402 -- in the assembly code. However we still only store a single edge for
403 -- these cases.
404 -- We assign the old edge info to the edge A -> B and assign B -> C the
405 -- weight of an unconditional jump.
406 addNodesBetween :: CFG -> [(BlockId,BlockId,BlockId)] -> CFG
407 addNodesBetween m updates =
408 foldl' updateWeight m .
409 weightUpdates $ updates
410 where
411 weight = fromIntegral . D.uncondWeight .
412 D.cfgWeightInfo $ D.unsafeGlobalDynFlags
413 -- We might add two blocks for different jumps along a single
414 -- edge. So we end up with edges: A -> B -> C , A -> D -> C
415 -- in this case after applying the first update the weight for A -> C
416 -- is no longer available. So we calculate future weights before updates.
417 weightUpdates = map getWeight
418 getWeight :: (BlockId,BlockId,BlockId) -> (BlockId,BlockId,BlockId,EdgeInfo)
419 getWeight (from,between,old)
420 | Just edgeInfo <- getEdgeInfo from old m
421 = (from,between,old,edgeInfo)
422 | otherwise
423 = pprPanic "Can't find weight for edge that should have one" (
424 text "triple" <+> ppr (from,between,old) $$
425 text "updates" <+> ppr updates )
426 updateWeight :: CFG -> (BlockId,BlockId,BlockId,EdgeInfo) -> CFG
427 updateWeight m (from,between,old,edgeInfo)
428 = addEdge from between edgeInfo .
429 addWeightEdge between old weight .
430 delEdge from old $ m
431
432 {-
433 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
434 ~~~ Note [CFG Edge Weights] ~~~
435 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
436
437 Edge weights assigned do not currently represent a specific
438 cost model and rather just a ranking of which blocks should
439 be placed next to each other given their connection type in
440 the CFG.
441 This is especially relevant if we whenever two blocks will
442 jump to the same target.
443
444 A B
445 \ /
446 C
447
448 Should A or B be placed in front of C? The block layout algorithm
449 decides this based on which edge (A,C)/(B,C) is heavier. So we
450 make a educated guess how often execution will transer control
451 along each edge as well as how much we gain by placing eg A before
452 C.
453
454 We rank edges in this order:
455 * Unconditional Control Transfer - They will always
456 transfer control to their target. Unless there is a info table
457 we can turn the jump into a fallthrough as well.
458 We use 20k as default, so it's easy to spot if values have been
459 modified but unlikely that we run into issues with overflow.
460 * If branches (likely) - We assume branches marked as likely
461 are taken more than 80% of the time.
462 By ranking them below unconditional jumps we make sure we
463 prefer the unconditional if there is a conditional and
464 unconditional edge towards a block.
465 * If branches (regular) - The false branch can potentially be turned
466 into a fallthrough so we prefer it slightly over the true branch.
467 * Unlikely branches - These can be assumed to be taken less than 20%
468 of the time. So we given them one of the lowest priorities.
469 * Switches - Switches at this level are implemented as jump tables
470 so have a larger number of successors. So without more information
471 we can only say that each individual successor is unlikely to be
472 jumped to and we rank them accordingly.
473 * Calls - We currently ignore calls completly:
474 * By the time we return from a call there is a good chance
475 that the address we return to has already been evicted from
476 cache eliminating a main advantage sequential placement brings.
477 * Calls always require a info table in front of their return
478 address. This reduces the chance that we return to the same
479 cache line further.
480
481
482 -}
483 -- | Generate weights for a Cmm proc based on some simple heuristics.
484 getCfgProc :: D.CfgWeights -> RawCmmDecl -> CFG
485 getCfgProc _ (CmmData {}) = mapEmpty
486 -- Sometimes GHC generates dummy procs which don't actually contain code.
487 -- But they might contain bottoms in some fields so we check for an empty
488 -- body first. In particular this happens with SplitObjs enabled.
489 getCfgProc weights (CmmProc _info _lab _live graph)
490 | null (toBlockList graph) = mapEmpty
491 | otherwise = getCfg weights graph
492
493 getCfg :: D.CfgWeights -> CmmGraph -> CFG
494 getCfg weights graph =
495 foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks
496 where
497 D.CFGWeights
498 { D.uncondWeight = uncondWeight
499 , D.condBranchWeight = condBranchWeight
500 , D.switchWeight = switchWeight
501 , D.callWeight = callWeight
502 , D.likelyCondWeight = likelyCondWeight
503 , D.unlikelyCondWeight = unlikelyCondWeight
504 -- Last two are used in other places
505 --, D.infoTablePenalty = infoTablePenalty
506 --, D.backEdgeBonus = backEdgeBonus
507 } = weights
508 -- Explicitly add all nodes to the cfg to ensure they are part of the
509 -- CFG.
510 edgelessCfg = mapFromList $ zip (map G.entryLabel blocks) (repeat mapEmpty)
511 insertEdge :: CFG -> ((BlockId,BlockId),EdgeInfo) -> CFG
512 insertEdge m ((from,to),weight) =
513 mapAlter f from m
514 where
515 f :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
516 f Nothing = Just $ mapSingleton to weight
517 f (Just destMap) = Just $ mapInsert to weight destMap
518 getBlockEdges :: CmmBlock -> [((BlockId,BlockId),EdgeInfo)]
519 getBlockEdges block =
520 case branch of
521 CmmBranch dest -> [mkEdge dest uncondWeight]
522 CmmCondBranch _c t f l
523 | l == Nothing ->
524 [mkEdge f condBranchWeight, mkEdge t condBranchWeight]
525 | l == Just True ->
526 [mkEdge f unlikelyCondWeight, mkEdge t likelyCondWeight]
527 | l == Just False ->
528 [mkEdge f likelyCondWeight, mkEdge t unlikelyCondWeight]
529 (CmmSwitch _e ids) ->
530 let switchTargets = switchTargetsToList ids
531 --Compiler performance hack - for very wide switches don't
532 --consider targets for layout.
533 adjustedWeight =
534 if (length switchTargets > 10) then -1 else switchWeight
535 in map (\x -> mkEdge x adjustedWeight) switchTargets
536 (CmmCall { cml_cont = Just cont}) -> [mkEdge cont callWeight]
537 (CmmForeignCall {Cmm.succ = cont}) -> [mkEdge cont callWeight]
538 (CmmCall { cml_cont = Nothing }) -> []
539 other ->
540 panic "Foo" $
541 ASSERT2(False, ppr "Unkown successor cause:" <>
542 (ppr branch <+> text "=>" <> ppr (G.successors other)))
543 map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other
544 where
545 bid = G.entryLabel block
546 mkEdgeInfo = EdgeInfo (CmmSource branch) . fromIntegral
547 mkEdge target weight = ((bid,target), mkEdgeInfo weight)
548 branch = lastNode block :: CmmNode O C
549
550 blocks = revPostorder graph :: [CmmBlock]
551
552 --Find back edges by BFS
553 findBackEdges :: BlockId -> CFG -> Edges
554 findBackEdges root cfg =
555 --pprTraceIt "Backedges:" $
556 map fst .
557 filter (\x -> snd x == Backward) $ typedEdges
558 where
559 edges = edgeList cfg :: [(BlockId,BlockId)]
560 getSuccs = getSuccessors cfg :: BlockId -> [BlockId]
561 typedEdges =
562 classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)]
563
564
565 optimizeCFG :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG
566 optimizeCFG _ (CmmData {}) cfg = cfg
567 optimizeCFG weights (CmmProc info _lab _live graph) cfg =
568 favourFewerPreds .
569 penalizeInfoTables info .
570 increaseBackEdgeWeight (g_entry graph) $ cfg
571 where
572
573 -- | Increase the weight of all backedges in the CFG
574 -- this helps to make loop jumpbacks the heaviest edges
575 increaseBackEdgeWeight :: BlockId -> CFG -> CFG
576 increaseBackEdgeWeight root cfg =
577 let backedges = findBackEdges root cfg
578 update weight
579 --Keep irrelevant edges irrelevant
580 | weight <= 0 = 0
581 | otherwise
582 = weight + fromIntegral (D.backEdgeBonus weights)
583 in foldl' (\cfg edge -> updateEdgeWeight update edge cfg)
584 cfg backedges
585
586 -- | Since we cant fall through info tables we penalize these.
587 penalizeInfoTables :: LabelMap a -> CFG -> CFG
588 penalizeInfoTables info cfg =
589 mapWeights fupdate cfg
590 where
591 fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight
592 fupdate _ to weight
593 | mapMember to info
594 = weight - (fromIntegral $ D.infoTablePenalty weights)
595 | otherwise = weight
596
597
598 {- Note [Optimize for Fallthrough]
599
600 -}
601 -- | If a block has two successors, favour the one with fewer
602 -- predecessors. (As that one is more likely to become a fallthrough)
603 favourFewerPreds :: CFG -> CFG
604 favourFewerPreds cfg =
605 let
606 revCfg =
607 reverseEdges $ filterEdges
608 (\_from -> fallthroughTarget) cfg
609
610 predCount n = length $ getSuccessorEdges revCfg n
611 nodes = getCfgNodes cfg
612
613 modifiers :: Int -> Int -> (EdgeWeight, EdgeWeight)
614 modifiers preds1 preds2
615 | preds1 < preds2 = ( 1,-1)
616 | preds1 == preds2 = ( 0, 0)
617 | otherwise = (-1, 1)
618
619 update cfg node
620 | [(s1,e1),(s2,e2)] <- getSuccessorEdges cfg node
621 , w1 <- edgeWeight e1
622 , w2 <- edgeWeight e2
623 --Only change the weights if there isn't already a ordering.
624 , w1 == w2
625 , (mod1,mod2) <- modifiers (predCount s1) (predCount s2)
626 = (\cfg' ->
627 (adjustEdgeWeight cfg' (+mod2) node s2))
628 (adjustEdgeWeight cfg (+mod1) node s1)
629 | otherwise
630 = cfg
631 in setFoldl update cfg nodes
632 where
633 fallthroughTarget :: BlockId -> EdgeInfo -> Bool
634 fallthroughTarget to (EdgeInfo source _weight)
635 | mapMember to info = False
636 | AsmCodeGen <- source = True
637 | CmmSource (CmmBranch {}) <- source = True
638 | CmmSource (CmmCondBranch {}) <- source = True
639 | otherwise = False
640
641 -- | Determine loop membership of blocks based on SCC analysis
642 -- Ideally we would replace this with a variant giving us loop
643 -- levels instead but the SCC code will do for now.
644 loopMembers :: CFG -> LabelMap Bool
645 loopMembers cfg =
646 foldl' (flip setLevel) mapEmpty sccs
647 where
648 mkNode :: BlockId -> Node BlockId BlockId
649 mkNode bid = DigraphNode bid bid (getSuccessors cfg bid)
650 nodes = map mkNode (setElems $ getCfgNodes cfg)
651
652 sccs = stronglyConnCompFromEdgedVerticesOrd nodes
653
654 setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool
655 setLevel (AcyclicSCC bid) m = mapInsert bid False m
656 setLevel (CyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids