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?)
123 BlockId {- block that is the start of the continuation. may or may not be the current block -}
124 WordOff {- total frame size -}
125 [(CmmReg, WordOff)] {- local reg offsets from stack top -}
127 -- A block can be a continuation of a call
128 -- A block can be a continuation of another block (w/ or w/o joins)
129 -- A block can be an entry to a function
131 blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
132 blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
134 -----------------------------------------------------------------------------
135 calculateOwnership :: UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId)
136 calculateOwnership proc_points blocks =
137 fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
139 blocks_ufm :: BlockEnv BrokenBlock
140 blocks_ufm = blocksToBlockEnv blocks
142 dependants :: BlockId -> [BlockId]
144 brokenBlockTargets $ lookupWithDefaultUFM
145 blocks_ufm unknown_block ident
147 update :: BlockId -> Maybe BlockId
148 -> BlockEnv (UniqSet BlockId) -> Maybe (BlockEnv (UniqSet BlockId))
149 update ident cause owners =
150 case (cause, ident `elementOfUniqSet` proc_points) of
151 (Nothing, True) -> Just $ addToUFM owners ident (unitUniqSet ident)
152 (Nothing, False) -> Nothing
153 (Just cause', True) -> Nothing
154 (Just cause', False) ->
155 if (sizeUniqSet old) == (sizeUniqSet new)
157 else Just $ addToUFM owners ident new
159 old = lookupWithDefaultUFM owners emptyUniqSet ident
160 new = old `unionUniqSets` lookupWithDefaultUFM owners emptyUniqSet cause'
162 unknown_block = panic "unknown BlockId in selectStackFormat"
164 calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
165 calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks
167 init_proc_points = mkUniqSet $
169 filter always_proc_point blocks
170 always_proc_point BrokenBlock {
171 brokenBlockEntry = FunctionEntry _ _ } = True
172 always_proc_point BrokenBlock {
173 brokenBlockEntry = ContinuationEntry _ } = True
174 always_proc_point _ = False
176 calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
177 calculateProcPoints' old_proc_points blocks =
178 if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
180 else calculateProcPoints' new_proc_points blocks
182 owners = calculateOwnership old_proc_points blocks
183 new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks))
185 calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId
186 calculateProcPoints'' owners block =
187 unionManyUniqSets (map (f parent_id) child_ids)
189 parent_id = brokenBlockId block
190 child_ids = brokenBlockTargets block
191 f parent_id child_id =
193 then unitUniqSet child_id
196 parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
197 child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
198 needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners
199 --needs_proc_point = sizeUniqSet (parent_owners `unionUniqSets` child_owners) /= sizeUniqSet parent_owners
201 cmmCondBranchTargets (CmmCondBranch _ target) = [target]
202 cmmCondBranchTargets _ = []
204 finalBranchOrSwitchTargets (FinalBranch target) = [target]
205 finalBranchOrSwitchTargets (FinalSwitch _ targets) = mapCatMaybes id targets
206 finalBranchOrSwitchTargets _ = []
208 collectNonProcPointTargets ::
209 UniqSet BlockId -> BlockEnv BrokenBlock
210 -> UniqSet BlockId -> BlockId -> UniqSet BlockId
211 collectNonProcPointTargets proc_points blocks current_targets block =
212 if sizeUniqSet current_targets == sizeUniqSet new_targets
214 else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
216 block' = lookupWithDefaultUFM blocks (panic "TODO") block
217 targets = -- We can't use the brokenBlockTargets b/c we don't want to follow the final goto after a call -- brokenBlockTargets block'
218 --finalBranchOrSwitchTargets (brokenBlockExit block') ++ concatMap cmmCondBranchTargets (brokenBlockStmts block')
219 uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
220 -- TODO: remove redundant uniqSetToList
221 new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
224 UniqSet BlockId -> BlockEnv BrokenBlock
225 -> BlockId -> Continuation
226 buildContinuation proc_points blocks start =
227 Continuation is_entry info_table clabel params body
229 children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
230 start_block = lookupWithDefaultUFM blocks (panic "TODO") start
231 children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
232 body = start_block : children_blocks
233 info_table = [] -- TODO
234 start_block_entry = brokenBlockEntry start_block
235 is_entry = case start_block_entry of
236 FunctionEntry _ _ -> True
238 clabel = case start_block_entry of
239 FunctionEntry label _ -> label
240 _ -> mkReturnPtLabel $ getUnique start
241 params = case start_block_entry of
242 FunctionEntry _ args -> args
243 ContinuationEntry args -> args
244 ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
246 --------------------------------------------------------------------------------
247 -- For now just select the continuation orders in the order they are in the set with no gaps
249 selectStackFormat :: BlockEnv CmmLive -> [BrokenBlock] -> BlockEnv StackFormat
250 selectStackFormat live blocks =
251 fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
253 blocks_ufm :: BlockEnv BrokenBlock
254 blocks_ufm = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
256 dependants :: BlockId -> [BlockId]
258 brokenBlockTargets $ lookupWithDefaultUFM
259 blocks_ufm unknown_block ident
261 update :: BlockId -> Maybe BlockId
262 -> BlockEnv StackFormat -> Maybe (BlockEnv StackFormat)
263 update ident cause formats =
264 if ident `elemUFM` formats
265 then Nothing -- Blocks only need to be updated once
267 brokenBlockEntry $ lookupWithDefaultUFM blocks_ufm
268 unknown_block ident) of
269 -- Propagate only to blocks entered by branches
270 -- (not function entry blocks or continuation entry blocks)
271 (Just cause_name, ControlEntry) ->
272 Just $ addToUFM formats ident cause_format
273 where cause_format = lookupWithDefaultUFM
274 formats unknown_block
276 -- Do initial calculates for function blocks
277 (Nothing, FunctionEntry _ _) ->
279 addToUFM formats ident $
280 StackFormat ident 0 []
281 -- Do initial calculates for continuation blocks
282 (Nothing, ContinuationEntry _) ->
284 addToUFM formats ident $
285 live_to_format ident $
286 lookupWithDefaultUFM live unknown_block ident
289 unknown_block = panic "unknown BlockId in selectStackFormat"
291 live_to_format :: BlockId -> CmmLive -> StackFormat
292 live_to_format label live =
294 (StackFormat label retAddrSizeW [])
297 extend_format :: StackFormat -> LocalReg -> StackFormat
298 extend_format (StackFormat block size offsets) reg =
299 StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)
301 selectStackFormat2 :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)]
302 selectStackFormat2 live continuations =
303 map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
305 selectStackFormat' (Continuation True info_table label formals blocks) =
306 let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
307 in StackFormat ident 0 []
308 selectStackFormat' (Continuation False info_table label formals blocks) =
309 let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
310 in live_to_format ident $ lookupWithDefaultUFM live unknown_block ident
312 live_to_format :: BlockId -> CmmLive -> StackFormat
313 live_to_format label live =
315 (StackFormat label retAddrSizeW [])
318 extend_format :: StackFormat -> LocalReg -> StackFormat
319 extend_format (StackFormat block size offsets) reg =
320 StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)
322 unknown_block = panic "unknown BlockId in selectStackFormat"
324 slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
326 constructContinuation :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
327 constructContinuation formats (Continuation is_entry info label formals blocks) =
328 CmmProc info label formals (map (constructContinuation2' label formats) blocks)
331 BasicBlock ident (prefix++stmts++postfix)
334 curr_format = lookupWithDefaultUFM formats unknown_block ident
335 unknown_block = panic "unknown BlockId in constructContinuation"
336 prefix = case entry of
338 FunctionEntry _ -> []
339 ContinuationEntry formals ->
340 unpack_continuation curr_format
341 postfix = case exit of
342 FinalBranch next -> [CmmBranch next]
343 FinalSwitch expr targets -> [CmmSwitch expr targets]
344 FinalReturn arguments ->
345 exit_function curr_format
346 (CmmLoad (CmmReg spReg) wordRep)
348 FinalJump target arguments ->
349 exit_function curr_format target arguments
350 -- TODO: do something about global saves
351 FinalCall next (CmmForeignCall target CmmCallConv)
352 results arguments saves ->
353 pack_continuation curr_format cont_format ++
354 [CmmJump target arguments]
356 cont_format = lookupWithDefaultUFM formats
358 FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
361 constructContinuation2' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
363 constructContinuation2' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
364 BasicBlock ident (prefix++stmts++postfix)
366 curr_format = maybe unknown_block id $ lookup curr_ident formats
367 unknown_block = panic "unknown BlockId in constructContinuation"
368 prefix = case entry of
370 FunctionEntry _ _ -> []
371 ContinuationEntry formals ->
372 unpack_continuation curr_format
373 postfix = case exit of
374 FinalBranch next -> [CmmBranch next]
375 FinalSwitch expr targets -> [CmmSwitch expr targets]
376 FinalReturn arguments ->
377 exit_function curr_format
378 (CmmLoad (CmmReg spReg) wordRep)
380 FinalJump target arguments ->
381 exit_function curr_format target arguments
382 -- TODO: do something about global saves
383 FinalCall next (CmmForeignCall target CmmCallConv)
384 results arguments saves ->
385 pack_continuation curr_format cont_format ++
386 [CmmJump target arguments]
388 cont_format = maybe unknown_block id $
389 lookup (mkReturnPtLabel $ getUnique next) formats
390 FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
392 constructContinuation2 :: BlockEnv StackFormat -> BrokenBlock
394 constructContinuation2 formats (BrokenBlock ident entry stmts _ exit) =
395 BasicBlock ident (prefix++stmts++postfix)
397 curr_format = lookupWithDefaultUFM formats unknown_block ident
398 unknown_block = panic "unknown BlockId in constructContinuation"
399 prefix = case entry of
401 FunctionEntry _ -> []
402 ContinuationEntry formals ->
403 unpack_continuation curr_format
404 postfix = case exit of
405 FinalBranch next -> [CmmBranch next]
406 FinalSwitch expr targets -> [CmmSwitch expr targets]
407 FinalReturn arguments ->
408 exit_function curr_format
409 (CmmLoad (CmmReg spReg) wordRep)
411 FinalJump target arguments ->
412 exit_function curr_format target arguments
413 -- TODO: do something about global saves
414 FinalCall next (CmmForeignCall target CmmCallConv)
415 results arguments saves ->
416 pack_continuation curr_format cont_format ++
417 [CmmJump target arguments]
419 cont_format = lookupWithDefaultUFM formats
421 FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
423 --------------------------------------------------------------------------------
424 -- Functions that generate CmmStmt sequences
425 -- for packing/unpacking continuations
426 -- and entering/exiting functions
428 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
429 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
430 = adjust_spReg ++ jump where
433 (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
434 jump = [CmmJump target arguments]
436 enter_function :: WordOff -> [CmmStmt]
437 enter_function max_frame_size
438 = check_stack_limit where
439 check_stack_limit = [
441 (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
442 [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
444 gc_block = undefined -- TODO: get stack and heap checks to go to same
446 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
447 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
448 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
449 (StackFormat cont_id cont_frame_size cont_offsets)
450 = save_live_values ++ set_stack_header ++ adjust_spReg where
451 -- TODO: only save variables when actually needed
455 spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
457 | (reg, offset) <- cont_offsets]
458 set_stack_header = -- TODO: only set when needed
459 [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
460 continuation_function = CmmLit $ CmmLabel $ mkReturnPtLabel {-TODO: use the correct function -} $ getUnique cont_id
462 if curr_frame_size == cont_frame_size
464 else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
466 -- Lazy adjustment of stack headers assumes all blocks
467 -- that could branch to eachother (i.e. control blocks)
468 -- have the same stack format (this causes a problem
469 -- only for proc-point).
470 unpack_continuation :: StackFormat -> [CmmStmt]
471 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
472 = load_live_values where
473 -- TODO: only save variables when actually needed
477 (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
478 | (reg, offset) <- curr_offsets]
480 -----------------------------------------------------------------------------
481 -- Breaking basic blocks on function calls
482 -----------------------------------------------------------------------------
484 -----------------------------------------------------------------------------
485 -- Takes a basic block and breaks it up into a list of broken blocks
487 -- Takes a basic block and returns a list of basic blocks that
488 -- each have at most 1 CmmCall in them which must occur at the end.
489 -- Also returns with each basic block, the variables that will
490 -- be arguments to the continuation of the block once the call (if any)
493 breakBlock :: [Unique] -> CmmBasicBlock -> BlockEntryInfo -> [BrokenBlock]
494 breakBlock uniques (BasicBlock ident stmts) entry =
495 breakBlock' uniques ident entry [] [] stmts where
496 breakBlock' uniques current_id entry exits accum_stmts stmts =
498 [] -> panic "block doesn't end in jump, goto or return"
499 [CmmJump target arguments] ->
500 [BrokenBlock current_id entry accum_stmts
502 (FinalJump target arguments)]
503 [CmmReturn arguments] ->
504 [BrokenBlock current_id entry accum_stmts
506 (FinalReturn arguments)]
507 [CmmBranch target] ->
508 [BrokenBlock current_id entry accum_stmts
510 (FinalBranch target)]
511 [CmmSwitch expr targets] ->
512 [BrokenBlock current_id entry accum_stmts
513 (mapMaybe id targets ++ exits)
514 (FinalSwitch expr targets)]
516 panic "jump in middle of block"
518 panic "return in middle of block"
520 panic "branch in middle of block"
522 panic ("switch in middle of block" ++ (showSDoc $ ppr stmts))
523 (CmmCall target results arguments saves:stmts) -> block : rest
525 new_id = BlockId $ head uniques
526 block = BrokenBlock current_id entry accum_stmts
528 (FinalCall new_id target results arguments saves)
529 rest = breakBlock' (tail uniques) new_id
530 (ContinuationEntry results) [] [] stmts
531 (s@(CmmCondBranch test target):stmts) ->
532 breakBlock' uniques current_id entry
533 (target:exits) (accum_stmts++[s]) stmts
535 breakBlock' uniques current_id entry
536 exits (accum_stmts++[s]) stmts
538 --------------------------------
539 -- Convert from a BrokenBlock
540 -- to a CmmBasicBlock so the
541 -- liveness analysis can run
543 --------------------------------
544 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
545 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
546 BasicBlock ident (stmts++exit_stmt)
550 FinalBranch target -> [CmmBranch target]
551 FinalReturn arguments -> [CmmReturn arguments]
552 FinalJump target arguments -> [CmmJump target arguments]
553 FinalSwitch expr targets -> [CmmSwitch expr targets]
554 FinalCall branch_target call_target results arguments saves ->
555 [CmmCall call_target results arguments saves,
556 CmmBranch branch_target]
558 -----------------------------------------------------------------------------
559 -- CPS a single CmmTop (proceedure)
560 -----------------------------------------------------------------------------
562 cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
563 cpsProc uniqSupply x@(CmmData _ _) = [x]
564 cpsProc uniqSupply x@(CmmProc info_table ident params blocks) =
565 --[CmmProc info_table ident params cps_blocks]
569 uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
571 -- Break the block at each function call
572 broken_blocks :: [BrokenBlock]
573 broken_blocks = concat $ zipWith3 breakBlock uniqes blocks
574 (FunctionEntry ident params:repeat ControlEntry)
576 -- Calculate live variables for each broken block
577 live :: BlockEntryLiveness
578 live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
580 proc_points :: UniqSet BlockId
581 proc_points = calculateProcPoints broken_blocks
583 continuations :: [Continuation]
584 continuations = map (buildContinuation proc_points (blocksToBlockEnv broken_blocks)) (uniqSetToList proc_points)
586 -- TODO: insert proc point code here
587 -- * Branches and switches to proc points may cause new blocks to be created
588 -- (or proc points could leave behind phantom blocks that just jump to them)
589 -- * Proc points might get some live variables passed as arguments
591 -- TODO: let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks
593 --procs = groupBlocksIntoContinuations live broken_blocks
595 -- Select the stack format on entry to each block
596 formats :: BlockEnv StackFormat
597 formats = selectStackFormat live broken_blocks
599 formats2 :: [(CLabel, StackFormat)]
600 formats2 = selectStackFormat2 live continuations
602 -- Do the actual CPS transform
603 cps_blocks :: [CmmBasicBlock]
604 cps_blocks = map (constructContinuation2 formats) broken_blocks
606 cps_continuations :: [CmmTop]
607 cps_continuations = map (constructContinuation formats2) continuations
609 --------------------------------------------------------------------------------
611 -> [Cmm] -- C-- with Proceedures
612 -> IO [Cmm] -- Output: CPS transformed C--
614 cmmCPS dflags abstractC = do
615 when (dopt Opt_DoCmmLinting dflags) $
616 do showPass dflags "CmmLint"
617 case firstJust $ map cmmLint abstractC of
618 Just err -> do printDump err
621 showPass dflags "CPS"
622 -- TODO: check for use of branches to non-existant blocks
623 -- TODO: check for use of Sp, SpLim, R1, R2, etc.
624 -- TODO: find out if it is valid to create a new unique source like this
625 uniqSupply <- mkSplitUniqSupply 'p'
626 let supplies = listSplitUniqSupply uniqSupply
627 let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
629 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
630 -- TODO: add option to dump Cmm to file