← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to compiler/cmm/CmmContFlowOpt.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
compiler/cmm/CmmContFlowOpt.hs
 
1
 
 
2
module CmmContFlowOpt
 
3
    ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ
 
4
    , branchChainElimZ, removeUnreachableBlocksZ, predMap
 
5
    , replaceLabelsZ, replaceBranches, runCmmContFlowOptsZs
 
6
    )
 
7
where
 
8
 
 
9
import BlockId
 
10
import Cmm
 
11
import CmmTx
 
12
import qualified ZipCfg as G
 
13
import ZipCfg
 
14
import ZipCfgCmmRep
 
15
 
 
16
import Maybes
 
17
import Control.Monad
 
18
import Outputable
 
19
import Prelude hiding (unzip, zip)
 
20
import Util
 
21
 
 
22
------------------------------------
 
23
runCmmContFlowOptsZs :: [CmmZ] -> [CmmZ]
 
24
runCmmContFlowOptsZs prog
 
25
  = [ runTx (runCmmOpts cmmCfgOptsZ) cmm_top
 
26
    | cmm_top <- prog ]
 
27
 
 
28
cmmCfgOpts  :: Tx (ListGraph CmmStmt)
 
29
cmmCfgOptsZ :: Tx (a, CmmGraph)
 
30
 
 
31
cmmCfgOpts  = branchChainElim  -- boring, but will get more exciting later
 
32
cmmCfgOptsZ g =
 
33
  optGraph
 
34
    (branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ) g
 
35
        -- Here branchChainElim can ultimately be replaced
 
36
        -- with a more exciting combination of optimisations
 
37
 
 
38
runCmmOpts :: Tx g -> Tx (GenCmm d h g)
 
39
-- Lifts a transformer on a single graph to one on the whole program
 
40
runCmmOpts opt = mapProcs (optProc opt)
 
41
 
 
42
optProc :: Tx g -> Tx (GenCmmTop d h g)
 
43
optProc _   top@(CmmData {}) = noTx top
 
44
optProc opt (CmmProc info lbl formals g) =
 
45
  fmap (CmmProc info lbl formals) (opt g)
 
46
 
 
47
optGraph :: Tx g -> Tx (a, g)
 
48
optGraph opt (a, g) = fmap (\g' -> (a, g')) (opt g)
 
49
 
 
50
------------------------------------
 
51
mapProcs :: Tx (GenCmmTop d h s) -> Tx (GenCmm d h s)
 
52
mapProcs f (Cmm tops) = fmap Cmm (mapTx f tops)
 
53
 
 
54
----------------------------------------------------------------
 
55
branchChainElim :: Tx (ListGraph CmmStmt)
 
56
-- If L is not captured in an instruction, we can remove any
 
57
-- basic block of the form L: goto L', and replace L with L' everywhere else.
 
58
-- How does L get captured? In a CallArea.
 
59
branchChainElim (ListGraph blocks)
 
60
  | null lone_branch_blocks     -- No blocks to remove
 
61
  = noTx (ListGraph blocks)
 
62
  | otherwise
 
63
  = aTx (ListGraph new_blocks)
 
64
  where
 
65
    (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
 
66
    new_blocks = map (replaceLabels env) others
 
67
    env = mkClosureBlockEnv lone_branch_blocks
 
68
 
 
69
isLoneBranch :: CmmBasicBlock -> Either (BlockId, BlockId) CmmBasicBlock
 
70
isLoneBranch (BasicBlock id [CmmBranch target]) | id /= target = Left (id, target)
 
71
isLoneBranch other_block                                       = Right other_block
 
72
   -- An infinite loop is not a link in a branch chain!
 
73
 
 
74
replaceLabels :: BlockEnv BlockId -> CmmBasicBlock -> CmmBasicBlock
 
75
replaceLabels env (BasicBlock id stmts)
 
76
  = BasicBlock id (map replace stmts)
 
77
  where
 
78
    replace (CmmBranch id)       = CmmBranch (lookup id)
 
79
    replace (CmmCondBranch e id) = CmmCondBranch e (lookup id)
 
80
    replace (CmmSwitch e tbl)    = CmmSwitch e (map (fmap lookup) tbl)
 
81
    replace other_stmt           = other_stmt
 
82
 
 
83
    lookup id = lookupBlockEnv env id `orElse` id 
 
84
----------------------------------------------------------------
 
85
branchChainElimZ :: Tx CmmGraph
 
86
-- Remove any basic block of the form L: goto L',
 
87
-- and replace L with L' everywhere else,
 
88
-- unless L is the successor of a call instruction and L'
 
89
-- is the entry block. You don't want to set the successor
 
90
-- of a function call to the entry block because there is no good way
 
91
-- to store both the infotables for the call and from the callee,
 
92
-- while putting the stack pointer in a consistent place.
 
93
--
 
94
-- JD isn't quite sure when it's safe to share continuations for different
 
95
-- function calls -- have to think about where the SP will be,
 
96
-- so we'll table that problem for now by leaving all call successors alone.
 
97
branchChainElimZ g@(G.LGraph eid _)
 
98
  | null lone_branch_blocks     -- No blocks to remove
 
99
  = noTx g
 
100
  | otherwise
 
101
  = aTx $ replaceLabelsZ env $ G.of_block_list eid (self_branches ++ others)
 
102
  where
 
103
    blocks = G.to_block_list g
 
104
    (lone_branch_blocks, others) = partitionWith isLoneBranchZ blocks
 
105
    env = mkClosureBlockEnvZ lone_branch_blocks
 
106
    self_branches =
 
107
      let loop_to (id, _) =
 
108
            if lookup id == id then
 
109
              Just (G.Block id (G.ZLast (G.mkBranchNode id)))
 
110
            else
 
111
              Nothing
 
112
      in  mapMaybe loop_to lone_branch_blocks
 
113
    lookup id = lookupBlockEnv env id `orElse` id 
 
114
 
 
115
    call_succs = foldl add emptyBlockSet blocks
 
116
      where add succs b =
 
117
              case G.last (G.unzip b) of
 
118
                LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet succs k
 
119
                _ -> succs
 
120
    isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
 
121
    isLoneBranchZ (G.Block id (G.ZLast (G.LastOther (LastBranch target))))
 
122
        | id /= target && not (elemBlockSet id call_succs) = Left (id,target)
 
123
    isLoneBranchZ other = Right other
 
124
       -- An infinite loop is not a link in a branch chain!
 
125
 
 
126
maybeReplaceLabels :: (Last -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph
 
127
maybeReplaceLabels lpred env =
 
128
  replace_eid . G.map_nodes id middle last
 
129
   where
 
130
     replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks
 
131
     middle = mapExpDeepMiddle exp
 
132
     last l = if lpred l then mapExpDeepLast exp (last' l) else l
 
133
     last' (LastBranch bid) = LastBranch (lookup bid)
 
134
     last' (LastCondBranch p t f) = LastCondBranch p (lookup t) (lookup f)
 
135
     last' (LastSwitch e arms) = LastSwitch e (map (liftM lookup) arms)
 
136
     last' (LastCall t k a res r) = LastCall t (liftM lookup k) a res r
 
137
     exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
 
138
     exp   (CmmStackSlot (CallArea (Young id)) i) =
 
139
       CmmStackSlot (CallArea (Young (lookup id))) i
 
140
     exp e = e
 
141
     lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id 
 
142
 
 
143
replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph
 
144
replaceLabelsZ = maybeReplaceLabels (const True)
 
145
 
 
146
-- replaceBranchLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
 
147
-- replaceBranchLabels env g@(LGraph _ _) = maybeReplaceLabels lpred env g
 
148
--   where lpred (LastBranch _) = True
 
149
--         lpred _ = False
 
150
 
 
151
replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
 
152
replaceBranches env g = map_nodes id id last g
 
153
  where
 
154
    last (LastBranch id)          = LastBranch (lookup id)
 
155
    last (LastCondBranch e ti fi) = LastCondBranch e (lookup ti) (lookup fi)
 
156
    last (LastSwitch e tbl)       = LastSwitch e (map (fmap lookup) tbl)
 
157
    last l@(LastCall {})          = l
 
158
    lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id 
 
159
 
 
160
----------------------------------------------------------------
 
161
-- Build a map from a block to its set of predecessors. Very useful.
 
162
predMap :: G.LastNode l => G.LGraph m l -> BlockEnv BlockSet
 
163
predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges
 
164
  where add_preds b env = foldl (add b) env (G.succs b)
 
165
        add (G.Block bid _) env b' =
 
166
          extendBlockEnv env b' $
 
167
                extendBlockSet (lookupBlockEnv env b' `orElse` emptyBlockSet) bid
 
168
----------------------------------------------------------------
 
169
-- If a block B branches to a label L, L is not the entry block,
 
170
-- and L has no other predecessors,
 
171
-- then we can splice the block starting with L onto the end of B.
 
172
-- Because this optimization can be inhibited by unreachable blocks,
 
173
-- we first take a pass to drops unreachable blocks.
 
174
-- Order matters, so we work bottom up (reverse postorder DFS).
 
175
--
 
176
-- To ensure correctness, we have to make sure that the BlockId of the block
 
177
-- we are about to eliminate is not named in another instruction.
 
178
--
 
179
-- Note: This optimization does _not_ subsume branch chain elimination.
 
180
blockConcatZ  :: Tx CmmGraph
 
181
blockConcatZ = removeUnreachableBlocksZ `seqTx` blockConcatZ'
 
182
blockConcatZ' :: Tx CmmGraph
 
183
blockConcatZ' g@(G.LGraph eid blocks) =
 
184
  tx $ replaceLabelsZ concatMap $ G.LGraph eid blocks'
 
185
  where (changed, blocks', concatMap) =
 
186
           foldr maybe_concat (False, blocks, emptyBlockEnv) $ G.postorder_dfs g
 
187
        maybe_concat b@(G.Block bid _) (changed, blocks', concatMap) =
 
188
          let unchanged = (changed, extendBlockEnv blocks' bid b, concatMap)
 
189
          in case G.goto_end $ G.unzip b of
 
190
               (h, G.LastOther (LastBranch b')) ->
 
191
                  if canConcatWith b' then
 
192
                    (True, extendBlockEnv blocks' bid $ splice blocks' h b',
 
193
                     extendBlockEnv concatMap b' bid)
 
194
                  else unchanged
 
195
               _ -> unchanged
 
196
        num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0
 
197
        canConcatWith b' = b' /= eid && num_preds b' == 1
 
198
        backEdges = predMap g
 
199
        splice blocks' h bid' =
 
200
          case lookupBlockEnv blocks' bid' of
 
201
            Just (G.Block _ t) -> G.zip $ G.ZBlock h t
 
202
            Nothing -> panic "unknown successor block"
 
203
        tx = if changed then aTx else noTx
 
204
----------------------------------------------------------------
 
205
mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
 
206
mkClosureBlockEnv blocks = mkBlockEnv $ map follow blocks
 
207
    where singleEnv = mkBlockEnv blocks
 
208
          follow (id, next) = (id, endChain id next)
 
209
          endChain orig id = case lookupBlockEnv singleEnv id of
 
210
                               Just id' | id /= orig -> endChain orig id'
 
211
                               _ -> id
 
212
mkClosureBlockEnvZ :: [(BlockId, BlockId)] -> BlockEnv BlockId
 
213
mkClosureBlockEnvZ blocks = mkBlockEnv $ map follow blocks
 
214
    where singleEnv = mkBlockEnv blocks
 
215
          follow (id, next) = (id, endChain id next)
 
216
          endChain orig id = case lookupBlockEnv singleEnv id of
 
217
                               Just id' | id /= orig -> endChain orig id'
 
218
                               _ -> id
 
219
----------------------------------------------------------------
 
220
removeUnreachableBlocksZ :: Tx CmmGraph
 
221
removeUnreachableBlocksZ g@(G.LGraph id blocks) =
 
222
  if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id blocks'
 
223
  else noTx g
 
224
    where blocks' = G.postorder_dfs g