1 module CmmCPS (cmmCPS) where
3 #include "HsVersions.h"
9 import Dataflow (fixedpoint)
31 --------------------------------------------------------------------------------
33 -- The format for the call to a continuation
34 -- The fst is the arguments that must be passed to the continuation
35 -- by the continuation's caller.
36 -- The snd is the live values that must be saved on stack.
37 -- A Nothing indicates an ignored slot.
38 -- The head of each list is the stack top or the first parameter.
40 -- The format for live values for a particular continuation
41 -- All on stack for now.
42 -- Head element is the top of the stack (or just under the header).
43 -- Nothing means an empty slot.
44 -- Future possibilities include callee save registers (i.e. passing slots in register)
45 -- and heap memory (not sure if that's usefull at all though, but it may
46 -- be worth exploring the design space).
50 brokenBlockId :: BlockId, -- Like a CmmBasicBlock
51 brokenBlockEntry :: BlockEntryInfo,
52 -- How this block can be entered
54 brokenBlockStmts :: [CmmStmt],
55 -- Like a CmmBasicBlock
56 -- (but without the last statement)
58 brokenBlockTargets :: [BlockId],
59 -- Blocks that this block could
60 -- branch to one either by conditional
61 -- branches or via the last statement
63 brokenBlockExit :: FinalStmt
64 -- How the block can be left
67 continuationLabel (Continuation _ _ l _ _) = l
70 Bool -- True => Function entry, False => Continuation/return point
71 [CmmStatic] -- Info table, may be empty
72 CLabel -- Used to generate both info & entry labels
73 CmmFormals -- Argument locals live on entry (C-- procedure params)
74 [BrokenBlock] -- Code, may be empty. The first block is
75 -- the entry point. The order is otherwise initially
76 -- unimportant, but at some point the code gen will
79 -- the BlockId of the first block does not give rise
80 -- to a label. To jump to the first block in a Proc,
81 -- use the appropriate CLabel.
84 = FunctionEntry -- Beginning of a function
85 CLabel -- The function name
86 CmmFormals -- Aguments to function
88 | ContinuationEntry -- Return point of a call
89 CmmFormals -- return values (argument to continuation)
91 -- | ProcPointEntry -- no return values, but some live might end up as params or possibly in the frame
93 | ControlEntry -- A label in the input
95 -- Final statement in a BlokenBlock
96 -- Constructors and arguments match those in Cmm,
97 -- but are restricted to branches, returns, jumps, calls and switches
100 BlockId -- next block (must be a ControlEntry)
103 CmmActuals -- return values
106 CmmExpr -- the function to call
107 CmmActuals -- arguments to call
110 BlockId -- next block after call (must be a ContinuationEntry)
111 CmmCallTarget -- the function to call
112 CmmFormals -- results from call (redundant with ContinuationEntry)
113 CmmActuals -- arguments to call
114 (Maybe [GlobalReg]) -- registers that must be saved (TODO)
117 CmmExpr [Maybe BlockId] -- Table branch
119 -- TODO: | ProcPointExit (needed?)
121 -- Describes the layout of a stack frame for a continuation
124 (Maybe CLabel) -- The label occupying the top slot
125 WordOff -- Total frame size in words
126 [(CmmReg, WordOff)] -- local reg offsets from stack top
128 -- A block can be a continuation of a call
129 -- A block can be a continuation of another block (w/ or w/o joins)
130 -- A block can be an entry to a function
132 blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
133 blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
135 -----------------------------------------------------------------------------
136 calculateOwnership :: UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId)
137 calculateOwnership proc_points blocks =
138 fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
140 blocks_ufm :: BlockEnv BrokenBlock
141 blocks_ufm = blocksToBlockEnv blocks
143 dependants :: BlockId -> [BlockId]
145 brokenBlockTargets $ lookupWithDefaultUFM
146 blocks_ufm unknown_block ident
148 update :: BlockId -> Maybe BlockId
149 -> BlockEnv (UniqSet BlockId) -> Maybe (BlockEnv (UniqSet BlockId))
150 update ident cause owners =
151 case (cause, ident `elementOfUniqSet` proc_points) of
152 (Nothing, True) -> Just $ addToUFM owners ident (unitUniqSet ident)
153 (Nothing, False) -> Nothing
154 (Just cause', True) -> Nothing
155 (Just cause', False) ->
156 if (sizeUniqSet old) == (sizeUniqSet new)
158 else Just $ addToUFM owners ident new
160 old = lookupWithDefaultUFM owners emptyUniqSet ident
161 new = old `unionUniqSets` lookupWithDefaultUFM owners emptyUniqSet cause'
163 unknown_block = panic "unknown BlockId in selectStackFormat"
165 calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
166 calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks
168 init_proc_points = mkUniqSet $
170 filter always_proc_point blocks
171 always_proc_point BrokenBlock {
172 brokenBlockEntry = FunctionEntry _ _ } = True
173 always_proc_point BrokenBlock {
174 brokenBlockEntry = ContinuationEntry _ } = True
175 always_proc_point _ = False
177 calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
178 calculateProcPoints' old_proc_points blocks =
179 if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
181 else calculateProcPoints' new_proc_points blocks
183 owners = calculateOwnership old_proc_points blocks
184 new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks))
186 calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId
187 calculateProcPoints'' owners block =
188 unionManyUniqSets (map (f parent_id) child_ids)
190 parent_id = brokenBlockId block
191 child_ids = brokenBlockTargets block
193 f parent_id child_id =
195 then unitUniqSet child_id
198 parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
199 child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
200 needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners
202 collectNonProcPointTargets ::
203 UniqSet BlockId -> BlockEnv BrokenBlock
204 -> UniqSet BlockId -> BlockId -> UniqSet BlockId
205 collectNonProcPointTargets proc_points blocks current_targets block =
206 if sizeUniqSet current_targets == sizeUniqSet new_targets
208 else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
210 block' = lookupWithDefaultUFM blocks (panic "TODO") block
212 -- Note the subtlety that since the extra branch after a call
213 -- will always be to a block that is a proc-point,
214 -- this subtraction will always remove that case
215 uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
216 -- TODO: remove redundant uniqSetToList
217 new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
220 UniqSet BlockId -> BlockEnv BrokenBlock
221 -> BlockId -> Continuation
222 buildContinuation proc_points blocks start =
223 Continuation is_entry info_table clabel params body
225 children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
226 start_block = lookupWithDefaultUFM blocks (panic "TODO") start
227 children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
228 body = start_block : children_blocks
229 info_table = [] -- TODO
230 start_block_entry = brokenBlockEntry start_block
231 is_entry = case start_block_entry of
232 FunctionEntry _ _ -> True
234 clabel = case start_block_entry of
235 FunctionEntry label _ -> label
236 _ -> mkReturnPtLabel $ getUnique start
237 params = case start_block_entry of
238 FunctionEntry _ args -> args
239 ContinuationEntry args -> args
240 ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
242 --------------------------------------------------------------------------------
243 -- For now just select the continuation orders in the order they are in the set with no gaps
245 selectStackFormat :: BlockEnv CmmLive -> [BrokenBlock] -> BlockEnv StackFormat
246 selectStackFormat live blocks =
247 fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
249 blocks_ufm :: BlockEnv BrokenBlock
250 blocks_ufm = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
252 dependants :: BlockId -> [BlockId]
254 brokenBlockTargets $ lookupWithDefaultUFM
255 blocks_ufm unknown_block ident
257 update :: BlockId -> Maybe BlockId
258 -> BlockEnv StackFormat -> Maybe (BlockEnv StackFormat)
259 update ident cause formats =
260 if ident `elemUFM` formats
261 then Nothing -- Blocks only need to be updated once
263 brokenBlockEntry $ lookupWithDefaultUFM blocks_ufm
264 unknown_block ident) of
265 -- Propagate only to blocks entered by branches
266 -- (not function entry blocks or continuation entry blocks)
267 (Just cause_name, ControlEntry) ->
268 Just $ addToUFM formats ident cause_format
269 where cause_format = lookupWithDefaultUFM
270 formats unknown_block
272 -- Do initial calculates for function blocks
273 (Nothing, FunctionEntry _ _) ->
275 addToUFM formats ident $
276 StackFormat ident 0 []
277 -- Do initial calculates for continuation blocks
278 (Nothing, ContinuationEntry _) ->
280 addToUFM formats ident $
281 live_to_format ident $
282 lookupWithDefaultUFM live unknown_block ident
285 unknown_block = panic "unknown BlockId in selectStackFormat"
287 live_to_format :: BlockId -> CmmLive -> StackFormat
288 live_to_format label live =
290 (StackFormat label retAddrSizeW [])
293 extend_format :: StackFormat -> LocalReg -> StackFormat
294 extend_format (StackFormat block size offsets) reg =
295 StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)
297 selectStackFormat2 :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)]
298 selectStackFormat2 live continuations =
299 map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
301 selectStackFormat' (Continuation True info_table label formals blocks) =
302 --let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
304 StackFormat (Just label) 0 []
305 selectStackFormat' (Continuation False info_table label formals blocks) =
306 -- TODO: assumes the first block is the entry block
307 let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
308 in live_to_format label formals $ lookupWithDefaultUFM live unknown_block ident
310 live_to_format :: CLabel -> CmmFormals -> CmmLive -> StackFormat
311 live_to_format label formals live =
313 (StackFormat (Just label) retAddrSizeW [])
314 (uniqSetToList (live `minusUniqSet` mkUniqSet (cmmFormalsToLiveLocals formals)))
316 extend_format :: StackFormat -> LocalReg -> StackFormat
317 extend_format (StackFormat label size offsets) reg =
318 StackFormat label (slot_size reg + size) ((CmmLocal reg, size) : offsets)
320 unknown_block = panic "unknown BlockId in selectStackFormat"
322 slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
324 constructContinuation :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
325 constructContinuation formats (Continuation is_entry info label formals blocks) =
326 CmmProc info label formals (map (constructContinuation2' label formats) blocks)
328 constructContinuation2' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
330 constructContinuation2' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
331 BasicBlock ident (prefix++stmts++postfix)
333 curr_format = maybe unknown_block id $ lookup curr_ident formats
334 unknown_block = panic "unknown BlockId in constructContinuation"
335 prefix = case entry of
337 FunctionEntry _ _ -> []
338 ContinuationEntry formals ->
339 unpack_continuation curr_format
340 postfix = case exit of
341 FinalBranch next -> [CmmBranch next]
342 FinalSwitch expr targets -> [CmmSwitch expr targets]
343 FinalReturn arguments ->
344 exit_function curr_format
345 (CmmLoad (CmmReg spReg) wordRep)
347 FinalJump target arguments ->
348 exit_function curr_format target arguments
349 -- TODO: do something about global saves
350 FinalCall next (CmmForeignCall target CmmCallConv)
351 results arguments saves ->
352 pack_continuation curr_format cont_format ++
353 [CmmJump target arguments]
355 cont_format = maybe unknown_block id $
356 lookup (mkReturnPtLabel $ getUnique next) formats
357 FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
359 --------------------------------------------------------------------------------
360 -- Functions that generate CmmStmt sequences
361 -- for packing/unpacking continuations
362 -- and entering/exiting functions
364 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
365 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
366 = adjust_spReg ++ jump where
368 if curr_frame_size == 0
370 else [CmmAssign spReg
371 (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
372 jump = [CmmJump target arguments]
374 enter_function :: WordOff -> [CmmStmt]
375 enter_function max_frame_size
376 = check_stack_limit where
377 check_stack_limit = [
379 (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
380 [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
382 gc_block = undefined -- TODO: get stack and heap checks to go to same
384 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
385 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
386 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
387 (StackFormat cont_id cont_frame_size cont_offsets)
388 = save_live_values ++ set_stack_header ++ adjust_spReg where
389 -- TODO: only save variables when actually needed
393 spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
395 | (reg, offset) <- cont_offsets]
397 case (curr_id, cont_id) of
398 (Just x, Just y) -> x /= y
403 else [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
404 continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
406 if curr_frame_size == cont_frame_size
408 else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
410 -- Lazy adjustment of stack headers assumes all blocks
411 -- that could branch to eachother (i.e. control blocks)
412 -- have the same stack format (this causes a problem
413 -- only for proc-point).
414 unpack_continuation :: StackFormat -> [CmmStmt]
415 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
416 = load_live_values where
417 -- TODO: only save variables when actually needed
421 (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
422 | (reg, offset) <- curr_offsets]
424 -----------------------------------------------------------------------------
425 -- Breaking basic blocks on function calls
426 -----------------------------------------------------------------------------
428 -----------------------------------------------------------------------------
429 -- Takes a basic block and breaks it up into a list of broken blocks
431 -- Takes a basic block and returns a list of basic blocks that
432 -- each have at most 1 CmmCall in them which must occur at the end.
433 -- Also returns with each basic block, the variables that will
434 -- be arguments to the continuation of the block once the call (if any)
437 breakBlock :: [Unique] -> CmmBasicBlock -> BlockEntryInfo -> [BrokenBlock]
438 breakBlock uniques (BasicBlock ident stmts) entry =
439 breakBlock' uniques ident entry [] [] stmts where
440 breakBlock' uniques current_id entry exits accum_stmts stmts =
442 [] -> panic "block doesn't end in jump, goto or return"
443 [CmmJump target arguments] ->
444 [BrokenBlock current_id entry accum_stmts
446 (FinalJump target arguments)]
447 [CmmReturn arguments] ->
448 [BrokenBlock current_id entry accum_stmts
450 (FinalReturn arguments)]
451 [CmmBranch target] ->
452 [BrokenBlock current_id entry accum_stmts
454 (FinalBranch target)]
455 [CmmSwitch expr targets] ->
456 [BrokenBlock current_id entry accum_stmts
457 (mapMaybe id targets ++ exits)
458 (FinalSwitch expr targets)]
460 panic "jump in middle of block"
462 panic "return in middle of block"
464 panic "branch in middle of block"
466 panic ("switch in middle of block" ++ (showSDoc $ ppr stmts))
467 (CmmCall target results arguments saves:stmts) -> block : rest
469 new_id = BlockId $ head uniques
470 block = BrokenBlock current_id entry accum_stmts
472 (FinalCall new_id target results arguments saves)
473 rest = breakBlock' (tail uniques) new_id
474 (ContinuationEntry results) [] [] stmts
475 (s@(CmmCondBranch test target):stmts) ->
476 breakBlock' uniques current_id entry
477 (target:exits) (accum_stmts++[s]) stmts
479 breakBlock' uniques current_id entry
480 exits (accum_stmts++[s]) stmts
482 --------------------------------
483 -- Convert from a BrokenBlock
484 -- to a CmmBasicBlock so the
485 -- liveness analysis can run
487 --------------------------------
488 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
489 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
490 BasicBlock ident (stmts++exit_stmt)
494 FinalBranch target -> [CmmBranch target]
495 FinalReturn arguments -> [CmmReturn arguments]
496 FinalJump target arguments -> [CmmJump target arguments]
497 FinalSwitch expr targets -> [CmmSwitch expr targets]
498 FinalCall branch_target call_target results arguments saves ->
499 [CmmCall call_target results arguments saves,
500 CmmBranch branch_target]
502 -----------------------------------------------------------------------------
503 -- CPS a single CmmTop (proceedure)
504 -----------------------------------------------------------------------------
506 cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
507 cpsProc uniqSupply x@(CmmData _ _) = [x]
508 cpsProc uniqSupply x@(CmmProc info_table ident params blocks) =
509 --[CmmProc info_table ident params cps_blocks]
513 uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
515 -- Break the block at each function call
516 broken_blocks :: [BrokenBlock]
517 broken_blocks = concat $ zipWith3 breakBlock uniqes blocks
518 (FunctionEntry ident params:repeat ControlEntry)
520 -- Calculate live variables for each broken block
521 live :: BlockEntryLiveness
522 live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
523 -- nothing can be live on entry to the first block so we could take the tail
525 proc_points :: UniqSet BlockId
526 proc_points = calculateProcPoints broken_blocks
528 continuations :: [Continuation]
529 continuations = map (buildContinuation proc_points (blocksToBlockEnv broken_blocks)) (uniqSetToList proc_points)
531 -- TODO: insert proc point code here
532 -- * Branches and switches to proc points may cause new blocks to be created
533 -- (or proc points could leave behind phantom blocks that just jump to them)
534 -- * Proc points might get some live variables passed as arguments
536 -- TODO: let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks
538 --procs = groupBlocksIntoContinuations live broken_blocks
540 -- Select the stack format on entry to each block
541 formats2 :: [(CLabel, StackFormat)]
542 formats2 = selectStackFormat2 live continuations
544 -- Do the actual CPS transform
545 cps_continuations :: [CmmTop]
546 cps_continuations = map (constructContinuation formats2) continuations
548 --------------------------------------------------------------------------------
550 -> [Cmm] -- C-- with Proceedures
551 -> IO [Cmm] -- Output: CPS transformed C--
553 cmmCPS dflags abstractC = do
554 when (dopt Opt_DoCmmLinting dflags) $
555 do showPass dflags "CmmLint"
556 case firstJust $ map cmmLint abstractC of
557 Just err -> do printDump err
560 showPass dflags "CPS"
561 -- TODO: check for use of branches to non-existant blocks
562 -- TODO: check for use of Sp, SpLim, R1, R2, etc.
563 -- TODO: find out if it is valid to create a new unique source like this
564 uniqSupply <- mkSplitUniqSupply 'p'
565 let supplies = listSplitUniqSupply uniqSupply
566 let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
568 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
569 -- TODO: add option to dump Cmm to file