1 module CmmBrokenBlock (
6 cmmBlockFromBrokenBlock,
11 makeContinuationEntries,
14 #include "HsVersions.h"
19 import MachOp (MachHint(..))
30 import MachRegs (callerSaveVolatileRegs)
31 -- HACK: this is part of the NCG so we shouldn't use this, but we need
32 -- it for now to eliminate the need for saved regs to be in CmmCall.
33 -- The long term solution is to factor callerSaveVolatileRegs
34 -- from nativeGen into codeGen
36 -- This module takes a 'CmmBasicBlock' which might have 'CmmCall'
37 -- statements in it with 'CmmSafe' set and breaks it up at each such call.
38 -- It also collects information about the block for later use
39 -- by the CPS algorithm.
41 -----------------------------------------------------------------------------
43 -----------------------------------------------------------------------------
45 -- |Similar to a 'CmmBlock' with a little extra information
46 -- to help the CPS analysis.
49 brokenBlockId :: BlockId, -- ^ The block's label like a 'CmmBasicBlock'
50 brokenBlockEntry :: BlockEntryInfo,
51 -- ^ Ways this block can be entered
53 brokenBlockStmts :: [CmmStmt],
54 -- ^ Body like a CmmBasicBlock
55 -- (but without the last statement)
57 brokenBlockTargets :: [BlockId],
58 -- ^ Blocks that this block could
59 -- branch to either by conditional
60 -- branches or via the last statement
62 brokenBlockExit :: FinalStmt
63 -- ^ The final statement of the block
66 -- | How a block could be entered
68 = FunctionEntry -- ^ Block is the beginning of a function
69 CmmInfo -- ^ Function header info
70 CLabel -- ^ The function name
71 CmmFormals -- ^ Aguments to function
73 | ContinuationEntry -- ^ Return point of a function call
74 CmmFormals -- ^ return values (argument to continuation)
75 C_SRT -- ^ SRT for the continuation's info table
76 Bool -- ^ True <=> GC block so ignore stack size
78 | ControlEntry -- ^ Any other kind of block.
79 -- Only entered due to control flow.
81 -- TODO: Consider adding ProcPointEntry
82 -- no return values, but some live might end up as
83 -- params or possibly in the frame
85 data ContFormat = ContFormat
86 CmmHintFormals -- ^ return values (argument to continuation)
87 C_SRT -- ^ SRT for the continuation's info table
88 Bool -- ^ True <=> GC block so ignore stack size
91 -- | Final statement in a 'BlokenBlock'.
92 -- Constructors and arguments match those in 'Cmm',
93 -- but are restricted to branches, returns, jumps, calls and switches
95 = FinalBranch -- ^ Same as 'CmmBranch'
96 BlockId -- ^ Target must be a ControlEntry
98 | FinalReturn -- ^ Same as 'CmmReturn'
99 CmmActuals -- ^ Return values
101 | FinalJump -- ^ Same as 'CmmJump'
102 CmmExpr -- ^ The function to call
103 CmmActuals -- ^ Arguments of the call
105 | FinalCall -- ^ Same as 'CmmForeignCall'
106 -- followed by 'CmmGoto'
107 BlockId -- ^ Target of the 'CmmGoto'
108 -- (must be a 'ContinuationEntry')
109 CmmCallTarget -- ^ The function to call
110 CmmHintFormals -- ^ Results from call
111 -- (redundant with ContinuationEntry)
112 CmmActuals -- ^ Arguments to call
113 C_SRT -- ^ SRT for the continuation's info table
114 Bool -- ^ True <=> GC block so ignore stack size
116 | FinalSwitch -- ^ Same as a 'CmmSwitch'
117 CmmExpr -- ^ Scrutinee (zero based)
118 [Maybe BlockId] -- ^ Targets
120 -----------------------------------------------------------------------------
121 -- Operations for broken blocks
122 -----------------------------------------------------------------------------
124 -- Naively breaking at *every* CmmCall leads to sub-optimal code.
125 -- In particular, a CmmCall followed by a CmmBranch would result
126 -- in a continuation that has the single CmmBranch statement in it.
127 -- It would be better have the CmmCall directly return to the block
128 -- that the branch jumps to.
130 -- This requires the target of the branch to look like the parameter
131 -- format that the CmmCall is expecting. If other CmmCall/CmmBranch
132 -- sequences go to the same place they might not be expecting the
133 -- same format. So this transformation uses the following solution.
134 -- First the blocks are broken up but none of the blocks are marked
135 -- as continuations yet. This is the 'breakBlock' function.
136 -- Second, the blocks "vote" on what other blocks need to be continuations
137 -- and how they should be layed out. Plurality wins, but other selection
138 -- methods could be selected at a later time.
139 -- This is the 'selectContinuations' function.
140 -- Finally, the blocks are upgraded to 'ContEntry' continuations
141 -- based on the results with the 'makeContinuationEntries' function,
142 -- and the blocks that didn't get the format they wanted for their
143 -- targets get a small adaptor block created for them by
144 -- the 'adaptBlockToFormat' function.
148 [BlockId] -- ^ Any GC blocks that should be special
149 -> [[Unique]] -- ^ An infinite list of uniques
150 -- to create names of the new blocks with
151 -> CmmInfo -- ^ Info table for the procedure
152 -> CLabel -- ^ Name of the procedure
153 -> CmmFormals -- ^ Parameters of the procedure
154 -> [CmmBasicBlock] -- ^ Blocks of the procecure
155 -- (First block is the entry block)
158 breakProc gc_block_idents uniques info ident params blocks =
160 (adaptor_uniques : block_uniques) = uniques
162 broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
165 zipWith3 (breakBlock gc_block_idents)
168 (FunctionEntry info ident params :
170 in (concatMap fst new_blocks, concatMap snd new_blocks)
172 selected = selectContinuations (fst broken_blocks)
174 in map (makeContinuationEntries selected) $
176 zipWith (adaptBlockToFormat selected)
180 -----------------------------------------------------------------------------
181 -- | Takes a 'CmmBasicBlock' and breaks it up into a list of 'BrokenBlock'
182 -- by splitting on each 'CmmCall' in the 'CmmBasicBlock'.
185 [BlockId] -- ^ Any GC blocks that should be special
186 -> [Unique] -- ^ An infinite list of uniques
187 -- to create names of the new blocks with
188 -> CmmBasicBlock -- ^ Input block to break apart
189 -> BlockEntryInfo -- ^ Info for the first created 'BrokenBlock'
190 -> ([(BlockId, ContFormat)], [BrokenBlock])
191 breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry =
192 breakBlock' uniques ident entry [] [] stmts
194 breakBlock' uniques current_id entry exits accum_stmts stmts =
196 [] -> panic "block doesn't end in jump, goto, return or switch"
198 -- Last statement. Make the 'BrokenBlock'
199 [CmmJump target arguments] ->
201 [BrokenBlock current_id entry accum_stmts
203 (FinalJump target arguments)])
204 [CmmReturn arguments] ->
206 [BrokenBlock current_id entry accum_stmts
208 (FinalReturn arguments)])
209 [CmmBranch target] ->
211 [BrokenBlock current_id entry accum_stmts
213 (FinalBranch target)])
214 [CmmSwitch expr targets] ->
216 [BrokenBlock current_id entry accum_stmts
217 (mapMaybe id targets ++ exits)
218 (FinalSwitch expr targets)])
220 -- These shouldn't happen in the middle of a block.
221 -- They would cause dead code.
222 (CmmJump _ _:_) -> panic "jump in middle of block"
223 (CmmReturn _:_) -> panic "return in middle of block"
224 (CmmBranch _:_) -> panic "branch in middle of block"
225 (CmmSwitch _ _:_) -> panic "switch in middle of block"
227 -- Detect this special case to remain an inverse of
228 -- 'cmmBlockFromBrokenBlock'
229 [CmmCall target results arguments (CmmSafe srt),
230 CmmBranch next_id] ->
231 ([cont_info], [block])
233 cont_info = (next_id,
234 ContFormat results srt
235 (ident `elem` gc_block_idents))
236 block = do_call current_id entry accum_stmts exits next_id
237 target results arguments srt
239 -- Break the block on safe calls (the main job of this function)
240 (CmmCall target results arguments (CmmSafe srt) : stmts) ->
241 (cont_info : cont_infos, block : blocks)
243 next_id = BlockId $ head uniques
244 block = do_call current_id entry accum_stmts exits next_id
245 target results arguments srt
246 cont_info = (next_id,
247 ContFormat results srt
248 (ident `elem` gc_block_idents))
249 (cont_infos, blocks) = breakBlock' (tail uniques) next_id
250 ControlEntry [] [] stmts
252 -- Unsafe calls don't need a continuation
253 -- but they do need to be expanded
254 (CmmCall target results arguments CmmUnsafe : stmts) ->
255 breakBlock' remaining_uniques current_id entry exits
259 [CmmCall target results new_args CmmUnsafe] ++
263 (remaining_uniques, arg_stmts, new_args) =
264 loadArgsIntoTemps uniques arguments
265 (caller_save, caller_load) = callerSaveVolatileRegs (Just [])
267 -- Default case. Just keep accumulating statements
268 -- and branch targets.
270 breakBlock' uniques current_id entry
271 (cond_branch_target s++exits)
275 do_call current_id entry accum_stmts exits next_id
276 target results arguments srt =
277 BrokenBlock current_id entry accum_stmts (next_id:exits)
278 (FinalCall next_id target results arguments srt
279 (current_id `elem` gc_block_idents))
281 cond_branch_target (CmmCondBranch _ target) = [target]
282 cond_branch_target _ = []
284 -----------------------------------------------------------------------------
286 selectContinuations :: [(BlockId, ContFormat)] -> [(BlockId, ContFormat)]
287 selectContinuations needed_continuations = formats
289 formats = map select_format format_groups
290 format_groups = groupBy by_target needed_continuations
291 by_target x y = fst x == fst y
293 select_format formats = winner
295 winner = head $ head $ sortBy more_votes format_votes
296 format_votes = groupBy by_format formats
297 by_format x y = snd x == snd y
298 more_votes x y = compare (length y) (length x)
299 -- sort so the most votes goes *first*
300 -- (thus the order of x and y is reversed)
302 makeContinuationEntries formats
303 block@(BrokenBlock ident entry stmts targets exit) =
304 case lookup ident formats of
306 Just (ContFormat formals srt is_gc) ->
307 BrokenBlock ident (ContinuationEntry (map fst formals) srt is_gc)
310 adaptBlockToFormat :: [(BlockId, ContFormat)]
314 adaptBlockToFormat formats unique
315 block@(BrokenBlock ident entry stmts targets
316 exit@(FinalCall next target formals
317 actuals srt is_gc)) =
318 if format_formals == formals &&
320 format_is_gc == is_gc
321 then [block] -- Woohoo! This block got the continuation format it wanted
322 else [adaptor_block, revised_block]
323 -- This block didn't get the format it wanted for the
324 -- continuation, so we have to build an adaptor.
326 (ContFormat format_formals format_srt format_is_gc) =
327 maybe unknown_block id $ lookup next formats
328 unknown_block = panic "unknown block in adaptBlockToFormat"
330 revised_block = BrokenBlock ident entry stmts revised_targets revised_exit
331 revised_targets = adaptor_ident : delete next targets
332 revised_exit = FinalCall
333 adaptor_ident -- ^ The only part that changed
334 target formals actuals srt is_gc
336 adaptor_block = mk_adaptor_block adaptor_ident
337 (ContinuationEntry (map fst formals) srt is_gc)
339 adaptor_ident = BlockId unique
341 mk_adaptor_block :: BlockId -> BlockEntryInfo -> BlockId -> CmmHintFormals -> BrokenBlock
342 mk_adaptor_block ident entry next formals =
343 BrokenBlock ident entry [] [next] exit
346 (CmmLit (CmmLabel (mkReturnPtLabel (getUnique next))))
347 (map formal_to_actual format_formals)
349 formal_to_actual (reg, hint) = ((CmmReg (CmmLocal reg)), hint)
350 -- TODO: Check if NoHint is right. We're
351 -- jumping to a C-- function not a foreign one
352 -- so it might always be right.
353 adaptBlockToFormat _ _ block = [block]
355 -----------------------------------------------------------------------------
356 -- | Convert from a BrokenBlock back to an equivalent CmmBasicBlock
357 -- Needed by liveness analysis
358 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
359 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
360 BasicBlock ident (stmts++exit_stmt)
364 FinalBranch target -> [CmmBranch target]
365 FinalReturn arguments -> [CmmReturn arguments]
366 FinalJump target arguments -> [CmmJump target arguments]
367 FinalSwitch expr targets -> [CmmSwitch expr targets]
368 FinalCall branch_target call_target results arguments srt _ ->
369 [CmmCall call_target results arguments (CmmSafe srt),
370 CmmBranch branch_target]
372 -----------------------------------------------------------------------------
373 -- | Build a mapping so we can lookup a 'BrokenBlock' by its 'BlockId'
374 blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
375 blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks