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