1 module CmmCPS (cmmCPS) where
3 #include "HsVersions.h"
9 import Dataflow -- (fixedpoint, cmmLivenessComment, cmmLiveness, CmmLive)
29 --------------------------------------------------------------------------------
30 -- Monad for the CPSer
32 -- * State for the uniqSupply
34 data CPSState = CPSState { cps_uniqs :: UniqSupply }
36 data CPS a = CPS { runCPS :: CPSState -> (CPSState, a) }
38 instance Monad CPS where
39 return a = CPS $ \s -> (s, a)
40 (CPS m) >>= f = CPS $ \s ->
44 --------------------------------------------------------------------------------
47 getState = CPS $ \s -> (s, s)
48 putState s = CPS $ \_ -> (s, ())
52 let (us1, us2) = splitUniqSupply (cps_uniqs state)
53 putState $ state { cps_uniqs = us1 }
54 return $ BlockId (uniqFromSupply us2)
56 mapMCmmTop :: (Monad m) => (CmmTop -> m [CmmTop]) -> Cmm -> m Cmm
57 mapMCmmTop f (Cmm xs) = liftM Cmm $ liftM concat $ mapM f xs
59 --------------------------------------------------------------------------------
61 -- The format for the call to a continuation
62 -- The fst is the arguments that must be passed to the continuation
63 -- by the continuation's caller.
64 -- The snd is the live values that must be saved on stack.
65 -- A Nothing indicates an ignored slot.
66 -- The head of each list is the stack top or the first parameter.
68 -- The format for live values for a particular continuation
69 -- All on stack for now.
70 -- Head element is the top of the stack (or just under the header).
71 -- Nothing means an empty slot.
72 -- Future possibilities include callee save registers (i.e. passing slots in register)
73 -- and heap memory (not sure if that's usefull at all though, but it may
74 -- be worth exploring the design space).
78 BlockId -- Like a CmmBasicBlock
79 BlockEntryInfo -- How this block can be entered
80 [CmmStmt] -- Like a CmmBasicBlock (but without
81 -- the last statement)
82 BlockExitInfo -- How the block can be left
85 = FunctionEntry -- Beginning of function
87 | ContinuationEntry -- Return point of a call
88 CmmFormals {- return values -}
89 -- TODO | ProcPointEntry {- no return values, but some live might end up as params -}
91 | ControlEntry -- A label in the input
94 = ControlExit [BlockId] -- blocks branched to conditionally
95 BlockId -- next block (must be a ControlEntry)
97 | ReturnExit [BlockId] -- blocks branched to conditionally
98 CmmActuals -- return values
100 | TailCallExit [BlockId] -- blocks branched to conditionally
101 CmmExpr -- the function to call
102 CmmActuals -- arguments to call
104 | CallExit [BlockId] -- blocks branched to conditionally
105 BlockId -- next block after call (must be a ContinuationEntry)
106 CmmCallTarget -- the function to call
107 CmmFormals -- results from call (redundant with ContinuationEntry)
108 CmmActuals -- arguments to call
109 (Maybe [GlobalReg]) -- registers that must be saved (TODO)
110 -- TODO: | ProcPointExit (needed?)
113 = ControlBlock -- Consider whether a proc-point might want arguments on stack
114 | ContinuationBlock [(CmmReg,MachHint)] {- params -}
117 --type StackFormat = [Maybe LocalReg] -- TODO: consider params as part of format
120 BlockId {- block that is the start of the continuation. may or may not be the current block -}
121 WordOff {- total frame size -}
122 [(CmmReg, WordOff)] {- local reg offsets from stack top -}
124 -- A block can be a continuation of a call
125 -- A block can be a continuation of another block (w/ or w/o joins)
126 -- A block can be an entry to a function
128 --------------------------------------------------------------------------------
129 -- For now just select the continuation orders in the order they are in the set with no gaps
130 -- TODO: select a format that keeps blocks that can jump to each other the same
131 -- Assumed that jumps, calls
132 selectStackFormat :: UniqFM {-BlockId-} CmmFormals -> UniqFM {-BlockId-} CmmLive -> UniqFM {-BlockId-} [(CPSBlockInfo, CmmBasicBlock)] -> UniqFM {-BlockId-} StackFormat
133 selectStackFormat = undefined
135 selectStackFormat param live blocks = fixedpoint
136 listToUFM $ map live_to_format $ ufmToList live
138 live_to_format (unique, live) = (unique, format) where
139 format = foldl extend_format
140 (StackFormat (BlockId unique) retAddrSizeW [])
142 extend_format :: StackFormat -> LocalReg -> StackFormat
143 extend_format (StackFormat block size offsets) reg =
144 StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)
147 selectStackFormat2 :: UniqFM {-BlockId-} CmmLive -> [BrokenBlock] -> UniqFM {-BlockId-} StackFormat
148 selectStackFormat2 live blocks = fixedpoint dependants update (map brokenBlockId blocks) emptyUFM where
149 blocks_ufm = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
151 case lookupWithDefaultUFM blocks_ufm (panic "TODO") ident of
152 (BrokenBlock _ _ _ (ControlExit exits next)) -> next:exits
153 (BrokenBlock _ _ _ (ReturnExit exits _)) -> exits
154 (BrokenBlock _ _ _ (TailCallExit exits _ _)) -> exits
155 (BrokenBlock _ _ _ (CallExit exits _ _ _ _ _)) -> exits
156 update ident cause formats =
157 let BrokenBlock _ entry _ _ = lookupWithDefaultUFM blocks_ufm (panic "unknown BlockId in selectStackFormat:live") ident in
159 -- Propagate only to blocks entered by branches (not function entry blocks or continuation entry blocks)
161 let cause_format = lookupWithDefaultUFM formats (panic "update signaled for block not in format") cause_name
163 ControlEntry -> Just $ addToUFM formats ident cause_format
164 FunctionEntry -> Nothing
165 ContinuationEntry _ -> Nothing
166 -- Do initial calculates for function blocks
169 ControlEntry -> Nothing
170 FunctionEntry -> Just $ addToUFM formats ident $ StackFormat ident 0 []
171 ContinuationEntry _ -> Just $ addToUFM formats ident $ live_to_format ident $ lookupWithDefaultUFM live (panic "TODO") ident
172 live_to_format label live =
174 (StackFormat label retAddrSizeW [])
176 extend_format :: StackFormat -> LocalReg -> StackFormat
177 extend_format (StackFormat block size offsets) reg =
178 StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)
180 slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
182 transformReturn :: UniqFM {-BlockId-} CPSBlockInfo -> UniqFM {-BlockId-} StackFormat -> CmmBasicBlock -> CmmBasicBlock
183 transformReturn block_infos formats (BasicBlock ident stmts) =
184 -- NOTE: assumes that return/jump can *only* appear at end of block
186 CmmReturn arguments ->
189 exit_function curr_format (CmmLoad (CmmReg spReg) wordRep) arguments
190 CmmJump target arguments ->
193 exit_function curr_format target arguments
194 _ -> BasicBlock ident stmts
196 curr_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident
198 destructContinuation :: UniqFM {-BlockId-} CPSBlockInfo -> UniqFM {-BlockId-} StackFormat -> CmmBasicBlock -> CmmBasicBlock
199 destructContinuation block_infos formats (BasicBlock ident stmts) =
201 ControlBlock -> BasicBlock ident stmts
202 ContinuationBlock _ -> BasicBlock ident (unpack_continuation curr_format ++ stmts)
204 info = lookupWithDefaultUFM block_infos (panic $ "info: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident
205 curr_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident
207 constructContinuation2 :: UniqFM {-BlockId-} StackFormat -> BrokenBlock -> CmmBasicBlock
208 constructContinuation2 formats (BrokenBlock ident entry stmts exit) =
209 BasicBlock ident (prefix++stmts++postfix)
211 curr_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident
212 prefix = case entry of
215 ContinuationEntry formals -> unpack_continuation curr_format
216 postfix = case exit of
217 ControlExit _ next -> [CmmBranch next]
218 ReturnExit _ arguments -> exit_function curr_format (CmmLoad (CmmReg spReg) wordRep) arguments
219 TailCallExit _ target arguments -> exit_function curr_format target arguments
220 -- TODO: do something about global saves
221 CallExit _ next (CmmForeignCall target CmmCallConv) results arguments saves ->
222 let cont_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique next)) next
223 in pack_continuation curr_format cont_format ++
224 [CmmJump target arguments]
225 CallExit _ next _ results arguments saves -> panic "unimplemented CmmCall"
227 constructContinuation :: UniqFM {-BlockId-} CPSBlockInfo -> UniqFM {-BlockId-} StackFormat -> CmmBasicBlock -> CmmBasicBlock
228 constructContinuation block_infos formats (BasicBlock ident stmts) =
229 case last $ init stmts of
230 -- TODO: global_saves
231 --CmmCall (CmmForeignCall target CmmCallConv) results arguments (Just []) -> --TODO: handle globals
232 CmmCall (CmmForeignCall target CmmCallConv) results arguments _ ->
235 pack_continuation curr_format cont_format ++
236 [CmmJump target arguments]
237 CmmCall target results arguments _ -> panic "unimplemented CmmCall"
238 -- TODO: branches for proc-points
239 -- _ -> BasicBlock ident $ (init stmts) ++ build_block_branch
240 _ -> BasicBlock ident stmts
242 info = lookupWithDefaultUFM block_infos (panic $ "info: unknown block " ++ (showSDoc $ ppr $ getUnique next_block)) next_block
243 cont_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique next_block)) next_block
244 curr_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique next_block)) ident
245 next_block = case last stmts of
246 CmmBranch next -> next
247 -- TODO: blocks with jump at end
248 -- TODO: blocks with return at end
249 _ -> panic $ "basic block without a branch at the end (unimplemented) " ++ (showSDoc $ ppr $ stmts)
250 next_block_as_proc_expr = CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next_block
251 block_needs_call = True -- TODO: use a table (i.e. proc-point)
254 then [CmmJump next_block_as_proc_expr [] {- TODO: pass live -}] {- NOTE: a block can never be both a continuation and a controll block -}
255 else [CmmBranch next_block]
257 --------------------------------------------------------------------------------
258 -- Functions that generate CmmStmt sequences
259 -- for packing/unpacking continuations
260 -- and entering/exiting functions
262 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
263 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
264 = adjust_spReg ++ jump where
267 (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
268 jump = [CmmJump target arguments]
270 enter_function :: WordOff -> [CmmStmt]
271 enter_function max_frame_size
272 = check_stack_limit where
273 check_stack_limit = [
275 (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
276 [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
278 gc_block = undefined -- TODO: get stack and heap checks to go to same
280 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
281 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
282 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
283 (StackFormat cont_id cont_frame_size cont_offsets)
284 = save_live_values ++ set_stack_header ++ adjust_spReg where
285 -- TODO: only save variables when actually needed
289 spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
291 | (reg, offset) <- cont_offsets]
292 set_stack_header = -- TODO: only set when needed
293 [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
294 continuation_function = CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique cont_id
296 if curr_frame_size == cont_frame_size
298 else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
300 -- Lazy adjustment of stack headers assumes all blocks
301 -- that could branch to eachother (i.e. control blocks)
302 -- have the same stack format (this causes a problem
303 -- only for proc-point).
304 unpack_continuation :: StackFormat -> [CmmStmt]
305 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
306 = load_live_values where
307 -- TODO: only save variables when actually needed
311 (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
312 | (reg, offset) <- curr_offsets]
314 -- TODO: TBD when to adjust the stack
316 cpsProc :: CmmTop -> CPS [CmmTop]
317 cpsProc x@(CmmData _ _) = return [x]
318 cpsProc x@(CmmProc info_table ident params blocks) = do
320 broken_blocks <- liftM concat $ mapM breakBlock blocks
321 broken_blocks2 <- liftM concat (zipWithM breakBlock2 blocks (FunctionEntry:repeat ControlEntry))
322 -- broken_blocks :: [BrokenBlock]
324 let live = cmmLiveness (map snd broken_blocks)
325 let live2 :: BlockEntryLiveness
326 live2 = cmmLiveness2 broken_blocks2
328 let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks
330 let formats = selectStackFormat (panic "params to selectStackFormat" {-TODO-}) live (undefined)
331 let formats2 :: BlockEnv StackFormat -- Stack format on entry
332 formats2 = selectStackFormat2 live2 broken_blocks2
334 let block_infos = listToUFM $ map (\(info, block) -> (blockId block, info)) broken_blocks
335 --let blocks_with_live' = map (constructContinuation block_infos formats) blocks_with_live
336 --let blocks_with_live'' = map (destructContinuation block_infos formats) blocks_with_live'
337 --let blocks_with_live''' = map (transformReturn block_infos formats) blocks_with_live''
339 return $ [CmmProc info_table ident params $ map (constructContinuation2 formats2) broken_blocks2]
341 return $ [CmmProc info_table ident params $
342 map (constructContinuation block_infos formats .
343 destructContinuation block_infos formats .
344 transformReturn block_infos formats)
348 --------------------------------------------------------------------------------
349 -- Takes a basic block and returns a list of basic blocks that
350 -- each have at most 1 CmmCall in them which must occur at the end.
351 -- Also returns with each basic block, the variables that will
352 -- be arguments to the continuation of the block once the call (if any) returns.
354 cmmBlockifyCalls :: [CmmBasicBlock] -> CPS [(CPSBlockInfo, CmmBasicBlock)]
355 cmmBlockifyCalls blocks = liftM concat $ mapM breakBlock blocks
357 -- [(CmmReg,MachHint)] is the results from the previous block that are expected as parameters
358 --breakBlock :: CmmBasicBlock -> CPS [(Maybe BlockId, CmmBasicBlock)]
359 breakBlock :: CmmBasicBlock -> CPS [(CPSBlockInfo, CmmBasicBlock)]
360 breakBlock (BasicBlock ident stmts) = breakBlock' ident ControlBlock [] stmts
362 breakBlock' current_id block_info accum_stmts [] =
363 return [(block_info, BasicBlock current_id accum_stmts)]
364 -- TODO: notice a call just before a branch, jump, call, etc.
365 breakBlock' current_id block_info accum_stmts (stmt@(CmmCall _ results _ _):stmts) = do
366 new_id <- newLabelCPS
367 let new_block = (block_info, BasicBlock current_id (accum_stmts ++ [stmt, CmmBranch new_id]))
368 rest <- breakBlock' new_id (ContinuationBlock results) [] stmts
369 return $ (new_block:rest)
370 breakBlock' current_id arguments accum_stmts (stmt:stmts) =
371 breakBlock' current_id arguments (accum_stmts ++ [stmt]) stmts
373 breakBlock2 (BasicBlock ident stmts) entry = breakBlock2' ident entry [] [] stmts
375 breakBlock2' current_id block_info exits accum_stmts [] =
376 panic "block doesn't end in jump, goto or return"
377 breakBlock2' current_id entry exits accum_stmts [CmmJump target arguments] =
378 return [BrokenBlock current_id entry accum_stmts (TailCallExit exits target arguments)]
379 breakBlock2' current_id entry exits accum_stmts [CmmReturn arguments] =
380 return [BrokenBlock current_id entry accum_stmts (ReturnExit exits arguments)]
381 breakBlock2' current_id entry exits accum_stmts [CmmBranch target] =
382 return [BrokenBlock current_id entry accum_stmts (ControlExit exits target)]
383 breakBlock2' _ _ _ _ (CmmJump _ _:_) = panic "jump in middle of block"
384 breakBlock2' _ _ _ _ (CmmReturn _:_) = panic "return in middle of block"
385 breakBlock2' _ _ _ _ (CmmBranch _:_) = panic "branch in middle of block"
386 breakBlock2' _ _ _ _ (CmmSwitch _ _:_) = panic "switch in block not implemented"
387 breakBlock2' current_id entry exits accum_stmts (CmmCall target results arguments saves:stmts) = do
388 new_id <- newLabelCPS
389 rest <- breakBlock2' new_id (ContinuationEntry results) [] [] stmts
390 return $ BrokenBlock current_id entry accum_stmts (CallExit exits new_id target results arguments saves) : rest
391 breakBlock2' current_id entry exits accum_stmts (s@(CmmCondBranch test target):stmts) =
392 breakBlock2' current_id entry (target:exits) (accum_stmts++[s]) stmts
393 breakBlock2' current_id entry exits accum_stmts (s:stmts) =
394 breakBlock2' current_id entry exits (accum_stmts++[s]) stmts
396 brokenBlockTargets (BrokenBlock _ _ _ (TailCallExit exits _ _)) = exits
397 brokenBlockTargets (BrokenBlock _ _ _ (ReturnExit exits _)) = exits
398 brokenBlockTargets (BrokenBlock _ _ _ (ControlExit exits target)) = target:exits
399 brokenBlockTargets (BrokenBlock _ _ _ (CallExit exits next _ _ _ _)) = next:exits
401 brokenBlockId (BrokenBlock ident _ _ _) = ident
403 cmmBrokenBlockSources ::
404 [BrokenBlock] -> UniqFM {-BlockId-} (UniqSet BlockId)
405 cmmBrokenBlockSources blocks = foldr aux emptyUFM blocks where
406 aux block sourcesUFM =
407 foldr add_source_edges sourcesUFM targets where
408 add_source_edges t ufm =
409 addToUFM_Acc (flip addOneToUniqSet) unitUniqSet ufm t ident
410 targets = brokenBlockTargets block
411 ident = brokenBlockId block
413 cmmBrokenBlockNames :: [BrokenBlock] -> UniqFM {-BlockId-} BrokenBlock
414 cmmBrokenBlockNames blocks = listToUFM $ map block_name blocks where
415 block_name b = (brokenBlockId b, b)
417 cmmBrokenBlockDependants :: UniqFM {-BlockId-} (UniqSet BlockId) -> BlockId -> [BlockId]
418 cmmBrokenBlockDependants sources ident =
419 uniqSetToList $ lookupWithDefaultUFM sources emptyUniqSet ident
421 cmmBrokenBlockLive :: UniqFM {-BlockId-} CmmLive -> BrokenBlock -> CmmLive
422 cmmBrokenBlockLive other_live (BrokenBlock _ _ stmts exit) =
423 foldr ((.) . (cmmStmtLive other_live)) id stmts live_at_end
427 ControlExit _ _ -> emptyUniqSet
428 ReturnExit _ actuals -> foldr ((.) . cmmExprLive) id (map fst actuals) emptyUniqSet
429 TailCallExit _ target actuals ->
430 cmmExprLive target $ foldr ((.) . cmmExprLive) id (map fst actuals) $ emptyUniqSet
431 CallExit _ _ target _ actuals live ->
433 foldr ((.) . cmmExprLive) id (map fst actuals) $
436 only_local_regs [] = []
437 only_local_regs ((CmmGlobal _,_):args) = only_local_regs args
438 only_local_regs ((CmmLocal r,_):args) = r:only_local_regs args
441 (CmmForeignCall target _) -> cmmExprLive target
445 cmmBrokenBlockUpdate ::
446 UniqFM {-BlockId-} BrokenBlock
449 -> UniqFM {-BlockId-} CmmLive
450 -> Maybe (UniqFM {-BlockId-} CmmLive)
451 cmmBrokenBlockUpdate blocks node _ state =
452 let old_live = lookupWithDefaultUFM state (panic "unknown block id during liveness analysis") node
453 block = lookupWithDefaultUFM blocks (panic "unknown block id during liveness analysis") node
454 new_live = cmmBrokenBlockLive state block
455 in if (sizeUniqSet old_live) == (sizeUniqSet new_live)
457 else Just $ addToUFM state node new_live
460 cmmLiveness2 :: [BrokenBlock] -> UniqFM {-BlockId-} CmmLive
461 cmmLiveness2 blocks =
462 fixedpoint (cmmBrokenBlockDependants sources) (cmmBrokenBlockUpdate blocks')
463 (map brokenBlockId blocks) (listToUFM [(brokenBlockId b, emptyUniqSet) | b <- blocks]) where
464 sources = cmmBrokenBlockSources blocks
465 blocks' = cmmBrokenBlockNames blocks
467 --------------------------------------------------------------------------------
469 -> [Cmm] -- C-- with Proceedures
470 -> IO [Cmm] -- Output: CPS transformed C--
472 cmmCPS dflags abstractC = do
473 when (dopt Opt_DoCmmLinting dflags) $
474 do showPass dflags "CmmLint"
475 case firstJust $ map cmmLint abstractC of
476 Just err -> do printDump err
479 showPass dflags "CPS"
480 -- TODO: check for use of branches to non-existant blocks
481 -- TODO: check for use of Sp, SpLim, R1, R2, etc.
482 -- continuationC <- return abstractC
483 -- TODO: find out if it is valid to create a new unique source like this
484 uniqSupply <- mkSplitUniqSupply 'p'
485 let (_, continuationC) = runCPS (mapM (mapMCmmTop cpsProc) abstractC) (CPSState uniqSupply)
487 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
488 -- TODO: add option to dump Cmm to file