CmmContFlowOpt.hs 7.62 KB
Newer Older
1
2
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations -fno-warn-incomplete-patterns #-}
3

4
module CmmContFlowOpt
5
    ( cmmCfgOpts
Simon Marlow's avatar
Simon Marlow committed
6
    , cmmCfgOptsProc
7
8
    , removeUnreachableBlocks
    , replaceLabels
9
10
11
    )
where

12
import BlockId
13
import Cmm
14
import CmmUtils
15
import Maybes
16

Simon Marlow's avatar
Simon Marlow committed
17
import Hoopl
Ian Lynagh's avatar
Ian Lynagh committed
18
import Control.Monad
19
import Prelude hiding (succ, unzip, zip)
20

21
22
23
24
25
-----------------------------------------------------------------------------
--
-- Control-flow optimisations
--
-----------------------------------------------------------------------------
26

27
cmmCfgOpts :: CmmGraph -> CmmGraph
28
cmmCfgOpts = removeUnreachableBlocks . blockConcat
29

Simon Marlow's avatar
Simon Marlow committed
30
31
32
cmmCfgOptsProc :: CmmDecl -> CmmDecl
cmmCfgOptsProc = optProc cmmCfgOpts

Simon Peyton Jones's avatar
Simon Peyton Jones committed
33
optProc :: (g -> g) -> GenCmmDecl d h g -> GenCmmDecl d h g
34
optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
35
optProc _   top                  = top
36

37

38
39
-----------------------------------------------------------------------------
--
40
-- Block concatenation
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
-- 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
71
--
72
73
74
75
76
77
78
79
80
81
82
--    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
83
  where
84
85
86
87
88
89
90
     -- 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
91

92
93
94
95
96
97
98
99
     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)
Simon Marlow's avatar
Simon Marlow committed
100
     maybe_concat block unchanged@(blocks, shortcut_map)
101
102
        | CmmBranch b' <- last
        , Just blk' <- mapLookup b' blocks
Simon Marlow's avatar
Simon Marlow committed
103
104
        , shouldConcatWith b' blk'
        = (mapInsert bid (splice head blk') blocks, shortcut_map)
105

106
107
108
        -- calls: if we can shortcut the continuation label, then
        -- we must *also* remember to substitute for the label in the
        -- code, because we will push it somewhere.
109
110
        | Just b'   <- callContinuation_maybe last
        , Just blk' <- mapLookup b' blocks
Simon Marlow's avatar
Simon Marlow committed
111
112
        , Just dest <- canShortcut blk'
        = (blocks, mapInsert b' dest shortcut_map)
113
114
           -- replaceLabels will substitute dest for b' everywhere, later

115
116
117
118
119
120
121
        -- non-calls: see if we can shortcut any of the successors.
        | Nothing <- callContinuation_maybe last
        = ( mapInsert bid (blockJoinTail head shortcut_last) blocks
          , shortcut_map )

        | otherwise
        = (blocks, shortcut_map)
122
        where
Simon Marlow's avatar
Simon Marlow committed
123
124
          (head, last) = blockSplitTail block
          bid = entryLabel block
125
126
127
128
129
          shortcut_last = mapSuccessors shortcut last
          shortcut l =
             case mapLookup l blocks of
               Just b | Just dest <- canShortcut b  -> dest
               _otherwise -> l
130
131
132
133
134
135
136

     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

Simon Marlow's avatar
Simon Marlow committed
137
     canShortcut :: CmmBlock -> Maybe BlockId
138
     canShortcut block
Simon Marlow's avatar
Simon Marlow committed
139
       | (_, middle, CmmBranch dest) <- blockSplit block
140
141
142
143
144
145
       , isEmptyBlock middle
       = Just dest
       | otherwise
       = Nothing

     backEdges :: BlockEnv Int -- number of predecessors for each block
Simon Marlow's avatar
Simon Marlow committed
146
147
     backEdges = mapInsertWith (+) entry_id 1 $ -- add 1 for the entry id
                   mapMap setSize $ predMap blocks
148
149

     splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
Simon Marlow's avatar
Simon Marlow committed
150
     splice head rest = head `blockAppend` snd (blockSplitHead rest)
151
152
153
154
155
156
157


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

Simon Marlow's avatar
Simon Marlow committed
158
okToDuplicate :: CmmBlock -> Bool
159
okToDuplicate block
Simon Marlow's avatar
Simon Marlow committed
160
  = case blockSplit block of (_, m, _) -> isEmptyBlock m
161
162
163
164
165
166
  -- 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.
167
168

replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
169
replaceLabels env g
Simon Marlow's avatar
Simon Marlow committed
170
171
  | mapNull env = g
  | otherwise   = replace_eid $ mapGraphNodes1 txnode g
172
   where
173
     replace_eid g = g {g_entry = lookup (g_entry g)}
174
175
176
177
     lookup id = mapLookup id env `orElse` id

     txnode :: CmmNode e x -> CmmNode e x
     txnode (CmmBranch bid)         = CmmBranch (lookup bid)
178
     txnode (CmmCondBranch p t f)   = mkCmmCondBranch (exp p) (lookup t) (lookup f)
179
180
181
182
183
184
185
     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
186
187
188
189
     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))
     exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
     exp e                                      = e

Simon Marlow's avatar
Simon Marlow committed
190
mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C
191
mkCmmCondBranch p t f = if t == f then CmmBranch t else CmmCondBranch p t f
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
192
193
194

----------------------------------------------------------------
-- Build a map from a block to its set of predecessors. Very useful.
195

196
197
198
199
200
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
201
202
203
204
205
206


-----------------------------------------------------------------------------
--
-- Removing unreachable blocks

207
removeUnreachableBlocks :: CmmGraph -> CmmGraph
208
209
210
211
removeUnreachableBlocks g
  | length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
  | otherwise = g
  where blocks = postorderDfs g