Fix warnings in StgCmmProf
[ghc-hetmet.git] / compiler / cmm / CmmBrokenBlock.hs
1 {-# OPTIONS -w #-}
2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
6 -- for details
7
8 module CmmBrokenBlock (
9   BrokenBlock(..),
10   BlockEntryInfo(..),
11   FinalStmt(..),
12   breakBlock,
13   cmmBlockFromBrokenBlock,
14   blocksToBlockEnv,
15   adaptBlockToFormat,
16   selectContinuations,
17   ContFormat,
18   makeContinuationEntries
19   ) where
20
21 #include "HsVersions.h"
22
23 import BlockId
24 import Cmm
25 import CmmUtils
26 import CLabel
27
28 import CgUtils (callerSaveVolatileRegs)
29 import ClosureInfo
30
31 import Maybes
32 import List
33 import Panic
34 import UniqSupply
35 import Unique
36 import UniqFM
37
38 -- This module takes a 'CmmBasicBlock' which might have 'CmmCall'
39 -- statements in it with 'CmmSafe' set and breaks it up at each such call.
40 -- It also collects information about the block for later use
41 -- by the CPS algorithm.
42
43 -----------------------------------------------------------------------------
44 -- Data structures
45 -----------------------------------------------------------------------------
46
47 -- |Similar to a 'CmmBlock' with a little extra information
48 -- to help the CPS analysis.
49 data BrokenBlock
50   = BrokenBlock {
51       brokenBlockId :: BlockId, -- ^ The block's label like a 'CmmBasicBlock'
52       brokenBlockEntry :: BlockEntryInfo,
53                                 -- ^ Ways this block can be entered
54
55       brokenBlockStmts :: [CmmStmt],
56                                 -- ^ Body like a CmmBasicBlock
57                                 -- (but without the last statement)
58
59       brokenBlockTargets :: [BlockId],
60                                 -- ^ Blocks that this block could
61                                 -- branch to either by conditional
62                                 -- branches or via the last statement
63
64       brokenBlockExit :: FinalStmt
65                                 -- ^ The final statement of the block
66     }
67
68 -- | How a block could be entered
69 -- See Note [An example of CPS conversion]
70 data BlockEntryInfo
71   = FunctionEntry CmmInfo CLabel CmmFormals
72       -- ^ Block is the beginning of a function, parameters are:
73       --   1. Function header info
74       --   2. The function name
75       --   3. Aguments to function
76       -- Only the formal parameters are live
77
78   | ContinuationEntry CmmFormals C_SRT Bool
79       -- ^ Return point of a function call, parameters are:
80       --   1. return values (argument to continuation)
81       --   2. SRT for the continuation's info table
82       --   3. True <=> GC block so ignore stack size
83       -- Live variables, other than
84       -- the return values, are on the stack
85
86   | ControlEntry
87       -- ^ Any other kind of block.  Only entered due to control flow.
88
89   -- TODO: Consider adding ProcPointEntry
90   -- no return values, but some live might end up as
91   -- params or possibly in the frame
92
93 {-      Note [An example of CPS conversion]
94
95 This is NR's and SLPJ's guess about how things might work;
96 it may not be consistent with the actual code (particularly
97 in the matter of what's in parameters and what's on the stack).
98
99 f(x,y) {
100    if x>2 then goto L
101    x = x+1
102 L: if x>1 then y = g(y)
103         else x = x+1 ;
104    return( x+y )
105 }
106         BECOMES
107
108 f(x,y) {   // FunctionEntry
109    if x>2 then goto L
110    x = x+1
111 L:         // ControlEntry
112    if x>1 then push x; push f1; jump g(y)
113         else x=x+1; jump f2(x, y)
114 }
115
116 f1(y) {    // ContinuationEntry
117   pop x; jump f2(x, y);
118 }
119   
120 f2(x, y) { // ProcPointEntry
121   return (z+y);
122 }
123
124 -}
125
126 data ContFormat = ContFormat HintedCmmFormals C_SRT Bool
127       -- ^ Arguments
128       --   1. return values (argument to continuation)
129       --   2. SRT for the continuation's info table
130       --   3. True <=> GC block so ignore stack size
131   deriving (Eq)
132
133 -- | Final statement in a 'BlokenBlock'.
134 -- Constructors and arguments match those in 'Cmm',
135 -- but are restricted to branches, returns, jumps, calls and switches
136 data FinalStmt
137   = FinalBranch BlockId
138     -- ^ Same as 'CmmBranch'.  Target must be a ControlEntry
139
140   | FinalReturn HintedCmmActuals
141     -- ^ Same as 'CmmReturn'. Parameter is the return values.
142
143   | FinalJump CmmExpr HintedCmmActuals
144     -- ^ Same as 'CmmJump'.  Parameters:
145     --   1. The function to call,
146     --   2. Arguments of the call
147
148   | FinalCall BlockId CmmCallTarget HintedCmmFormals HintedCmmActuals
149               C_SRT   CmmReturnInfo Bool
150       -- ^ Same as 'CmmCallee' followed by 'CmmGoto'.  Parameters:
151       --   1. Target of the 'CmmGoto' (must be a 'ContinuationEntry')
152       --   2. The function to call
153       --   3. Results from call (redundant with ContinuationEntry)
154       --   4. Arguments to call
155       --   5. SRT for the continuation's info table
156       --   6. Does the function return?
157       --   7. True <=> GC block so ignore stack size
158
159   | FinalSwitch CmmExpr [Maybe BlockId]
160       -- ^ Same as a 'CmmSwitch'.  Paremeters:
161       --   1. Scrutinee (zero based)
162       --   2. Targets
163
164 -----------------------------------------------------------------------------
165 -- Operations for broken blocks
166 -----------------------------------------------------------------------------
167
168 -- Naively breaking at *every* CmmCall leads to sub-optimal code.
169 -- In particular, a CmmCall followed by a CmmBranch would result
170 -- in a continuation that has the single CmmBranch statement in it.
171 -- It would be better have the CmmCall directly return to the block
172 -- that the branch jumps to.
173 --
174 -- This requires the target of the branch to look like the parameter
175 -- format that the CmmCall is expecting.  If other CmmCall/CmmBranch
176 -- sequences go to the same place they might not be expecting the
177 -- same format.  So this transformation uses the following solution.
178 -- First the blocks are broken up but none of the blocks are marked
179 -- as continuations yet.  This is the 'breakBlock' function.
180 -- Second, the blocks "vote" on what other blocks need to be continuations
181 -- and how they should be layed out.  Plurality wins, but other selection
182 -- methods could be selected at a later time.
183 -- This is the 'selectContinuations' function.
184 -- Finally, the blocks are upgraded to 'ContEntry' continuations
185 -- based on the results with the 'makeContinuationEntries' function,
186 -- and the blocks that didn't get the format they wanted for their
187 -- targets get a small adaptor block created for them by
188 -- the 'adaptBlockToFormat' function.
189 -- could be 
190
191 breakProc ::
192     [BlockId]                   -- ^ Any GC blocks that should be special
193     -> [[Unique]]               -- ^ An infinite list of uniques
194                                 -- to create names of the new blocks with
195     -> CmmInfo                  -- ^ Info table for the procedure
196     -> CLabel                   -- ^ Name of the procedure
197     -> CmmFormals               -- ^ Parameters of the procedure
198     -> [CmmBasicBlock]          -- ^ Blocks of the procecure
199                                 -- (First block is the entry block)
200     -> [BrokenBlock]
201
202 breakProc gc_block_idents uniques info ident params blocks =
203     let
204         (adaptor_uniques : block_uniques) = uniques
205
206         broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
207         broken_blocks =
208             let new_blocks =
209                     zipWith3 (breakBlock gc_block_idents)
210                              block_uniques
211                              blocks
212                              (FunctionEntry info ident params :
213                               repeat ControlEntry)
214             in (concatMap fst new_blocks, concatMap snd new_blocks)
215
216         selected = selectContinuations (fst broken_blocks)
217
218     in map (makeContinuationEntries selected) $
219        concat $
220        zipWith (adaptBlockToFormat selected)
221                adaptor_uniques
222                (snd broken_blocks)
223
224 -----------------------------------------------------------------------------
225 -- | Takes a 'CmmBasicBlock' and breaks it up into a list of 'BrokenBlock'
226 -- by splitting on each 'CmmCall' in the 'CmmBasicBlock'.
227
228 breakBlock ::
229     [BlockId]                   -- ^ Any GC blocks that should be special
230     -> [Unique]                 -- ^ An infinite list of uniques
231                                 -- to create names of the new blocks with
232     -> CmmBasicBlock            -- ^ Input block to break apart
233     -> BlockEntryInfo           -- ^ Info for the first created 'BrokenBlock'
234     -> ([(BlockId, ContFormat)], [BrokenBlock])
235 breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry =
236     breakBlock' uniques ident entry [] [] stmts
237     where
238       breakBlock' uniques current_id entry exits accum_stmts stmts =
239           case stmts of
240             [] -> panic "block doesn't end in jump, goto, return or switch"
241
242             -- Last statement.  Make the 'BrokenBlock'
243             [CmmJump target arguments] ->
244                 ([],
245                  [BrokenBlock current_id entry accum_stmts
246                               exits
247                               (FinalJump target arguments)])
248             [CmmReturn arguments] ->
249                 ([],
250                  [BrokenBlock current_id entry accum_stmts
251                              exits
252                              (FinalReturn arguments)])
253             [CmmBranch target] ->
254                 ([],
255                  [BrokenBlock current_id entry accum_stmts
256                              (target:exits)
257                              (FinalBranch target)])
258             [CmmSwitch expr targets] ->
259                 ([],
260                  [BrokenBlock current_id entry accum_stmts
261                              (mapMaybe id targets ++ exits)
262                              (FinalSwitch expr targets)])
263
264             -- These shouldn't happen in the middle of a block.
265             -- They would cause dead code.
266             (CmmJump _ _:_) -> panic "jump in middle of block"
267             (CmmReturn _:_) -> panic "return in middle of block"
268             (CmmBranch _:_) -> panic "branch in middle of block"
269             (CmmSwitch _ _:_) -> panic "switch in middle of block"
270
271             -- Detect this special case to remain an inverse of
272             -- 'cmmBlockFromBrokenBlock'
273             [CmmCall target results arguments (CmmSafe srt) ret,
274              CmmBranch next_id] ->
275                 ([cont_info], [block])
276                 where
277                   cont_info = (next_id,
278                                ContFormat results srt
279                                               (ident `elem` gc_block_idents))
280                   block = do_call current_id entry accum_stmts exits next_id
281                                 target results arguments srt ret
282
283             -- Break the block on safe calls (the main job of this function)
284             (CmmCall target results arguments (CmmSafe srt) ret : stmts) ->
285                 (cont_info : cont_infos, block : blocks)
286                 where
287                   next_id = BlockId $ head uniques
288                   block = do_call current_id entry accum_stmts exits next_id
289                                   target results arguments srt ret
290
291                   cont_info = (next_id, -- Entry convention for the 
292                                         -- continuation of the call
293                                ContFormat results srt
294                                               (ident `elem` gc_block_idents))
295
296                         -- Break up the part after the call
297                   (cont_infos, blocks) = breakBlock' (tail uniques) next_id
298                                          ControlEntry [] [] stmts
299
300             -- Unsafe calls don't need a continuation
301             -- but they do need to be expanded
302             (CmmCall target results arguments CmmUnsafe ret : stmts) ->
303                 breakBlock' remaining_uniques current_id entry exits
304                             (accum_stmts ++
305                              arg_stmts ++
306                              caller_save ++
307                              [CmmCall target results new_args CmmUnsafe ret] ++
308                              caller_load)
309                             stmts
310                 where
311                   (remaining_uniques, arg_stmts, new_args) =
312                       loadArgsIntoTemps uniques arguments
313                   (caller_save, caller_load) = callerSaveVolatileRegs (Just [])
314
315             -- Default case.  Just keep accumulating statements
316             -- and branch targets.
317             (s : stmts) ->
318                 breakBlock' uniques current_id entry
319                             (cond_branch_target s++exits)
320                             (accum_stmts++[s])
321                             stmts
322
323       do_call current_id entry accum_stmts exits next_id
324               target results arguments srt ret =
325           BrokenBlock current_id entry accum_stmts (next_id:exits)
326                       (FinalCall next_id target results arguments srt ret
327                                      (current_id `elem` gc_block_idents))
328
329       cond_branch_target (CmmCondBranch _ target) = [target]
330       cond_branch_target _ = []
331
332 -----------------------------------------------------------------------------
333
334 selectContinuations :: [(BlockId, ContFormat)] -> [(BlockId, ContFormat)]
335 selectContinuations needed_continuations = formats
336     where
337       formats = map select_format format_groups
338       format_groups = groupBy by_target needed_continuations
339       by_target x y = fst x == fst y
340
341       select_format formats = winner
342           where
343             winner = head $ head $ sortBy more_votes format_votes
344             format_votes = groupBy by_format formats
345             by_format x y = snd x == snd y
346             more_votes x y = compare (length y) (length x)
347               -- sort so the most votes goes *first*
348               -- (thus the order of x and y is reversed)
349
350 makeContinuationEntries formats
351                         block@(BrokenBlock ident entry stmts targets exit) =
352     case lookup ident formats of
353       Nothing -> block
354       Just (ContFormat formals srt is_gc) ->
355           BrokenBlock ident (ContinuationEntry (map hintlessCmm formals) srt is_gc)
356                       stmts targets exit
357
358 adaptBlockToFormat :: [(BlockId, ContFormat)]
359                    -> Unique
360                    -> BrokenBlock
361                    -> [BrokenBlock]
362 adaptBlockToFormat formats unique
363                    block@(BrokenBlock ident entry stmts targets
364                                       exit@(FinalCall next target formals
365                                                       actuals srt ret is_gc)) =
366     if format_formals == formals &&
367        format_srt == srt &&
368        format_is_gc == is_gc
369     then [block] -- Woohoo! This block got the continuation format it wanted
370     else [adaptor_block, revised_block]
371            -- This block didn't get the format it wanted for the
372            -- continuation, so we have to build an adaptor.
373     where
374       (ContFormat format_formals format_srt format_is_gc) =
375           maybe unknown_block id $ lookup next formats
376       unknown_block = panic "unknown block in adaptBlockToFormat"
377
378       revised_block = BrokenBlock ident entry stmts revised_targets revised_exit
379       revised_targets = adaptor_ident : delete next targets
380       revised_exit = FinalCall
381                        adaptor_ident -- The only part that changed
382                        target formals actuals srt ret is_gc
383
384       adaptor_block = mk_adaptor_block adaptor_ident
385                   (ContinuationEntry (map hintlessCmm formals) srt is_gc) next
386       adaptor_ident = BlockId unique
387
388       mk_adaptor_block :: BlockId -> BlockEntryInfo -> BlockId -> BrokenBlock
389       mk_adaptor_block ident entry next =
390           BrokenBlock ident entry [] [next] exit
391               where
392                 exit = FinalJump
393                          (CmmLit (CmmLabel (mkReturnPtLabel (getUnique next))))
394                          (map formal_to_actual format_formals)
395
396                 formal_to_actual (CmmHinted reg hint)
397                      = (CmmHinted (CmmReg (CmmLocal reg)) hint)
398                 -- TODO: Check if NoHint is right.  We're
399                 -- jumping to a C-- function not a foreign one
400                 -- so it might always be right.
401 adaptBlockToFormat _ _ block = [block]
402
403 -----------------------------------------------------------------------------
404 -- | Convert from a BrokenBlock back to an equivalent CmmBasicBlock
405 -- Needed by liveness analysis
406 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
407 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
408     BasicBlock ident (stmts++exit_stmt)
409     where
410       exit_stmt =
411           case exit of
412             FinalBranch target -> [CmmBranch target]
413             FinalReturn arguments -> [CmmReturn arguments]
414             FinalJump target arguments -> [CmmJump target arguments]
415             FinalSwitch expr targets -> [CmmSwitch expr targets]
416             FinalCall branch_target call_target results arguments srt ret _ ->
417                 [CmmCall call_target results arguments (CmmSafe srt) ret,
418                  CmmBranch branch_target]
419
420 -----------------------------------------------------------------------------
421 -- | Build a mapping so we can lookup a 'BrokenBlock' by its 'BlockId'
422 blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
423 blocksToBlockEnv blocks = mkBlockEnv $ map (\b -> (brokenBlockId b, b)) blocks