1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
|
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations -fno-warn-incomplete-patterns #-}
module CmmContFlowOpt
( cmmCfgOpts
, runCmmContFlowOpts
, removeUnreachableBlocks
, replaceLabels
)
where
import BlockId
import Cmm
import CmmUtils
import Digraph
import Maybes
import Outputable
import Compiler.Hoopl
import Control.Monad
import Prelude hiding (succ, unzip, zip)
-----------------------------------------------------------------------------
--
-- Control-flow optimisations
--
-----------------------------------------------------------------------------
runCmmContFlowOpts :: CmmGroup -> CmmGroup
runCmmContFlowOpts = map (optProc cmmCfgOpts)
cmmCfgOpts :: CmmGraph -> CmmGraph
cmmCfgOpts = removeUnreachableBlocks . blockConcat
optProc :: (g -> g) -> GenCmmDecl d h g -> GenCmmDecl d h g
optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
optProc _ top = top
-----------------------------------------------------------------------------
--
-- Block concatenation
--
-----------------------------------------------------------------------------
-- This optimisation does two things:
-- - If a block finishes with an unconditional branch, then we may
-- be able to concatenate the block it points to and remove the
-- branch. We do this either if the destination block is small
-- (e.g. just another branch), or if this is the only jump to
-- this particular destination block.
--
-- - If a block finishes in a call whose continuation block is a
-- goto, then we can shortcut the destination, making the
-- continuation block the destination of the goto.
--
-- Both transformations are improved by working from the end of the
-- graph towards the beginning, because we may be able to perform many
-- shortcuts in one go.
-- We need to walk over the blocks from the end back to the
-- beginning. We are going to maintain the "current" graph
-- (BlockEnv CmmBlock) as we go, and also a mapping from BlockId
-- to BlockId, representing continuation labels that we have
-- renamed. This latter mapping is important because we might
-- shortcut a CmmCall continuation. For example:
--
-- Sp[0] = L
-- call g returns to L
--
-- L: goto M
--
-- M: ...
--
-- So when we shortcut the L block, we need to replace not only
-- the continuation of the call, but also references to L in the
-- code (e.g. the assignment Sp[0] = L). So we keep track of
-- which labels we have renamed and apply the mapping at the end
-- with replaceLabels.
blockConcat :: CmmGraph -> CmmGraph
blockConcat g@CmmGraph { g_entry = entry_id }
= replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks
where
-- we might be able to shortcut the entry BlockId itself
new_entry
| Just entry_blk <- mapLookup entry_id new_blocks
, Just dest <- canShortcut entry_blk
= dest
| otherwise
= entry_id
blocks = postorderDfs g
(new_blocks, shortcut_map) =
foldr maybe_concat (toBlockMap g, mapEmpty) blocks
maybe_concat :: CmmBlock
-> (BlockEnv CmmBlock, BlockEnv BlockId)
-> (BlockEnv CmmBlock, BlockEnv BlockId)
maybe_concat block unchanged@(blocks, shortcut_map) =
| CmmBranch b' <- last
, Just blk' <- mapLookup b' blocks
, shouldConcatWith b' blocks
-> (mapInsert bid (splice head blk') blocks, shortcut_map)
| Just b' <- callContinuation_maybe last
, Just blk' <- mapLookup b' blocks
, Just dest <- canShortcut b' blk'
-> (blocks, mapInsert b' dest shortcut_map)
-- replaceLabels will substitute dest for b' everywhere, later
| otherwise = unchanged
where
(head, last) = blockTail block
bid = entryLabel b
shouldConcatWith b block
| num_preds b == 1 = True -- only one predecessor: go for it
| okToDuplicate block = True -- short enough to duplicate
| otherwise = False
where num_preds bid = mapLookup bid backEdges `orElse` 0
canShortcut :: Block C C -> Maybe BlockId
canShortcut block
| (_, middle, CmmBranch dest) <- blockHeadTail block
, isEmptyBlock middle
= Just dest
| otherwise
= Nothing
backEdges :: BlockEnv Int -- number of predecessors for each block
backEdges = mapMap setSize $ predMap blocks
ToDo: add 1 for the entry id
splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
splice head rest = head `cat` snd (blockHead rest)
callContinuation_maybe :: CmmNode O C -> Maybe BlockId
callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b
callContinuation_maybe (CmmForeignCall { succ = b }) = Just b
callContinuation_maybe _ = Nothing
okToDuplicate :: Block C C -> Bool
okToDuplicate block
= case blockToNodeList block of (_, m, _) -> null m
-- cheap and cheerful; we might expand this in the future to
-- e.g. spot blocks that represent a single instruction or two
------------------------------------------------------------------------
-- Map over the CmmGraph, replacing each label with its mapping in the
-- supplied BlockEnv.
replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
replaceLabels env g
| isEmptyMap env = g
| otherwise = replace_eid . mapGraphNodes1 txnode
where
replace_eid g = g {g_entry = lookup (g_entry g)}
lookup id = mapLookup id env `orElse` id
txnode :: CmmNode e x -> CmmNode e x
txnode (CmmBranch bid) = CmmBranch (lookup bid)
txnode (CmmCondBranch p t f) = mkCmmCondBranch (exp p) (lookup t) (lookup f)
txnode (CmmSwitch e arms) = CmmSwitch (exp e) (map (liftM lookup) arms)
txnode (CmmCall t k a res r) = CmmCall (exp t) (liftM lookup k) a res r
txnode fc@CmmForeignCall{} = fc{ args = map exp (args fc)
, succ = lookup (succ fc) }
txnode other = mapExpDeep exp other
exp :: CmmExpr -> CmmExpr
exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
exp e = e
mkCmmCondBranch :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
mkCmmCondBranch p t f = if t == f then CmmBranch t else CmmCondBranch p t f
----------------------------------------------------------------
-- Build a map from a block to its set of predecessors. Very useful.
predMap :: [CmmBlock] -> BlockEnv BlockSet
predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
where add_preds block env = foldl (add (entryLabel block)) env (successors block)
add bid env b' =
mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env
-----------------------------------------------------------------------------
--
-- Removing unreachable blocks
--
-----------------------------------------------------------------------------
removeUnreachableBlocks :: CmmGraph -> CmmGraph
removeUnreachableBlocks g
| length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
| otherwise = g
where blocks = postorderDfs g
|
