2 -- | Converts C-- with full proceedures and parameters
3 -- to a CPS transformed C-- with the stack made manifest.
7 #include "HsVersions.h"
41 -----------------------------------------------------------------------------
42 -- |Top level driver for the CPS pass
43 -----------------------------------------------------------------------------
44 cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
45 -> [GenCmm CmmStatic CmmInfo CmmStmt] -- ^ Input C-- with Proceedures
46 -> IO [GenCmm CmmStatic [CmmStatic] CmmStmt] -- ^ Output CPS transformed C--
47 cmmCPS dflags abstractC = do
48 when (dopt Opt_DoCmmLinting dflags) $
49 do showPass dflags "CmmLint"
50 case firstJust $ map cmmLint abstractC of
51 Just err -> do printDump err
56 -- TODO: more lint checking
57 -- check for use of branches to non-existant blocks
58 -- check for use of Sp, SpLim, R1, R2, etc.
60 uniqSupply <- mkSplitUniqSupply 'p'
61 let supplies = listSplitUniqSupply uniqSupply
62 let doCpsProc s (Cmm c) =
63 Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c
64 let continuationC = zipWith doCpsProc supplies abstractC
66 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
68 -- TODO: add option to dump Cmm to file
72 stg_gc_gen = mkRtsApFastLabel SLIT("gen_cg_TODO") --panic "Need the label for gc"
73 make_gc_block block_id fun_label formals safety = BasicBlock block_id stmts
75 stmts = [CmmCall stg_gc_gen_target [] [] safety,
76 CmmJump fun_expr actuals]
78 CmmForeignCall (CmmLit (CmmLabel stg_gc_gen)) CmmCallConv
79 actuals = map (\x -> (CmmReg (CmmLocal x), NoHint)) formals
80 fun_expr = CmmLit (CmmLabel fun_label)
82 force_gc_block old_info block_id fun_label formals blocks =
84 CmmNonInfo (Just _) -> (old_info, [])
85 CmmInfo _ (Just _) _ _ -> (old_info, [])
87 -> (CmmNonInfo (Just block_id),
88 [make_gc_block block_id fun_label formals (CmmSafe NoC_SRT)])
89 CmmInfo prof Nothing type_tag type_info
90 -> (CmmInfo prof (Just block_id) type_tag type_info,
91 [make_gc_block block_id fun_label formals (CmmSafe srt)])
93 srt = case type_info of
94 ConstrInfo _ _ _ -> NoC_SRT
95 FunInfo _ srt' _ _ _ _ -> srt'
96 ThunkInfo _ srt' -> srt'
97 ThunkSelectorInfo _ srt' -> srt'
98 ContInfo _ srt' -> srt'
100 -----------------------------------------------------------------------------
101 -- |CPS a single CmmTop (proceedure)
102 -- Only 'CmmProc' are transformed 'CmmData' will be left alone.
103 -----------------------------------------------------------------------------
105 cpsProc :: UniqSupply
106 -> GenCmmTop CmmStatic CmmInfo CmmStmt -- ^Input proceedure
107 -> [GenCmmTop CmmStatic [CmmStatic] CmmStmt] -- ^Output proceedure and continuations
108 cpsProc uniqSupply (CmmData sec dat) = [CmmData sec dat]
109 cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
111 uniques :: [[Unique]]
112 uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
113 (gc_unique:info_uniques):block_uniques = uniques
116 forced_gc :: (CmmInfo, [CmmBasicBlock])
117 forced_gc = force_gc_block info (BlockId gc_unique) ident params blocks
119 forced_info = fst forced_gc
120 forced_blocks = blocks ++ snd forced_gc
121 forced_gc_id = case forced_info of
122 CmmNonInfo (Just x) -> x
123 CmmInfo _ (Just x) _ _ -> x
125 -- Break the block at each function call.
126 -- The part after the function call will have to become a continuation.
127 broken_blocks :: [BrokenBlock]
129 concat $ zipWith3 breakBlock block_uniques forced_blocks
130 (FunctionEntry forced_info ident params:repeat ControlEntry)
132 -- Calculate live variables for each broken block.
134 -- Nothing can be live on entry to the first block
135 -- so we could take the tail, but for now we wont
136 -- to help future proof the code.
137 live :: BlockEntryLiveness
138 live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
140 -- Calculate which blocks must be made into full fledged procedures.
141 proc_points :: UniqSet BlockId
142 proc_points = calculateProcPoints broken_blocks
144 -- Construct a map so we can lookup a broken block by its 'BlockId'.
145 block_env :: BlockEnv BrokenBlock
146 block_env = blocksToBlockEnv broken_blocks
148 -- Group the blocks into continuations based on the set of proc-points.
149 continuations :: [Continuation (Either C_SRT CmmInfo)]
150 continuations = zipWith
151 (gatherBlocksIntoContinuation proc_points block_env)
152 (uniqSetToList proc_points)
153 (Just forced_gc_id : repeat Nothing)
155 -- Select the stack format on entry to each continuation.
156 -- Return the max stack offset and an association list
158 -- This is an association list instead of a UniqFM because
159 -- CLabel's don't have a 'Uniqueable' instance.
160 formats :: [(CLabel, -- key
161 (Maybe CLabel, -- label in top slot
162 [Maybe LocalReg]))] -- slots
163 formats = selectStackFormat live continuations
165 -- Do a little meta-processing on the stack formats such as
166 -- getting the individual frame sizes and the maximum frame size
167 formats' :: (WordOff, [(CLabel, StackFormat)])
168 formats' = processFormats formats continuations
170 -- Update the info table data on the continuations with
171 -- the selected stack formats.
172 continuations' :: [Continuation CmmInfo]
173 continuations' = map (applyStackFormat (snd formats')) continuations
175 -- Do the actual CPS transform.
176 cps_procs :: [CmmTop]
177 cps_procs = map (continuationToProc formats') continuations'
179 -- Convert the info tables from CmmInfo to [CmmStatic]
180 -- We might want to put this in another pass eventually
181 info_procs :: [RawCmmTop]
182 info_procs = concat (zipWith mkInfoTable info_uniques cps_procs)
184 --------------------------------------------------------------------------------
186 -- The format for the call to a continuation
187 -- The fst is the arguments that must be passed to the continuation
188 -- by the continuation's caller.
189 -- The snd is the live values that must be saved on stack.
190 -- A Nothing indicates an ignored slot.
191 -- The head of each list is the stack top or the first parameter.
193 -- The format for live values for a particular continuation
194 -- All on stack for now.
195 -- Head element is the top of the stack (or just under the header).
196 -- Nothing means an empty slot.
197 -- Future possibilities include callee save registers (i.e. passing slots in register)
198 -- and heap memory (not sure if that's usefull at all though, but it may
199 -- be worth exploring the design space).
201 continuationLabel (Continuation _ l _ _) = l
202 data Continuation info =
204 info -- Left <=> Continuation created by the CPS
205 -- Right <=> Function or Proc point
206 CLabel -- Used to generate both info & entry labels
207 CmmFormals -- Argument locals live on entry (C-- procedure params)
208 [BrokenBlock] -- Code, may be empty. The first block is
209 -- the entry point. The order is otherwise initially
210 -- unimportant, but at some point the code gen will
213 -- the BlockId of the first block does not give rise
214 -- to a label. To jump to the first block in a Proc,
215 -- use the appropriate CLabel.
219 stack_label :: Maybe CLabel, -- The label occupying the top slot
220 stack_frame_size :: WordOff, -- Total frame size in words (not including arguments)
221 stack_live :: [Maybe LocalReg] -- local reg offsets from stack top
224 -- A block can be a continuation of a call
225 -- A block can be a continuation of another block (w/ or w/o joins)
226 -- A block can be an entry to a function
228 -----------------------------------------------------------------------------
230 collectNonProcPointTargets ::
231 UniqSet BlockId -> BlockEnv BrokenBlock
232 -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
233 collectNonProcPointTargets proc_points blocks current_targets new_blocks =
234 if sizeUniqSet current_targets == sizeUniqSet new_targets
237 (collectNonProcPointTargets proc_points blocks)
241 blocks' = map (lookupWithDefaultUFM blocks (panic "TODO")) new_blocks
243 -- Note the subtlety that since the extra branch after a call
244 -- will always be to a block that is a proc-point,
245 -- this subtraction will always remove that case
246 uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
247 `minusUniqSet` proc_points
248 -- TODO: remove redundant uniqSetToList
249 new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
251 -- TODO: insert proc point code here
252 -- * Branches and switches to proc points may cause new blocks to be created
253 -- (or proc points could leave behind phantom blocks that just jump to them)
254 -- * Proc points might get some live variables passed as arguments
256 gatherBlocksIntoContinuation ::
257 UniqSet BlockId -> BlockEnv BrokenBlock
258 -> BlockId -> Maybe BlockId -> Continuation (Either C_SRT CmmInfo)
259 gatherBlocksIntoContinuation proc_points blocks start gc =
260 Continuation info_table clabel params body
262 start_and_gc = start : maybeToList gc
263 children = (collectNonProcPointTargets proc_points blocks (mkUniqSet start_and_gc) start_and_gc) `minusUniqSet` (mkUniqSet start_and_gc)
264 start_block = lookupWithDefaultUFM blocks (panic "TODO") start
265 gc_block = map (lookupWithDefaultUFM blocks (panic "TODO)")) (maybeToList gc)
266 children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
267 body = start_block : gc_block ++ children_blocks
269 -- We can't properly annotate the continuation's stack parameters
270 -- at this point because this is before stack selection
271 -- but we want to keep the C_SRT around so we use 'Either'.
272 info_table = case start_block_entry of
273 FunctionEntry info _ _ -> Right info
274 ContinuationEntry _ srt -> Left srt
275 ControlEntry -> Right (CmmNonInfo Nothing)
277 start_block_entry = brokenBlockEntry start_block
278 clabel = case start_block_entry of
279 FunctionEntry _ label _ -> label
280 _ -> mkReturnPtLabel $ getUnique start
281 params = case start_block_entry of
282 FunctionEntry _ _ args -> args
283 ContinuationEntry args _ -> args
284 ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
286 --------------------------------------------------------------------------------
287 -- For now just select the continuation orders in the order they are in the set with no gaps
289 selectStackFormat :: BlockEnv CmmLive
290 -> [Continuation (Either C_SRT CmmInfo)]
291 -> [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
292 selectStackFormat live continuations =
293 map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
295 selectStackFormat' (Continuation
296 (Right (CmmInfo _ _ _ (ContInfo format srt)))
297 label _ _) = (Just label, format)
298 selectStackFormat' (Continuation (Right _) _ _ _) = (Nothing, [])
299 selectStackFormat' (Continuation (Left srt) label _ blocks) =
300 -- TODO: assumes the first block is the entry block
301 let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
303 map Just $ uniqSetToList $
304 lookupWithDefaultUFM live unknown_block ident)
306 unknown_block = panic "unknown BlockId in selectStackFormat"
308 processFormats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
309 -> [Continuation (Either C_SRT CmmInfo)]
310 -> (WordOff, [(CLabel, StackFormat)])
311 processFormats formats continuations = (max_size, formats')
314 0 : map (continuationMaxStack formats') continuations
315 formats' = map make_format formats
316 make_format (label, format) =
319 stack_label = fst format,
320 stack_frame_size = stack_size (snd format) +
321 if isJust (fst format)
324 stack_live = snd format })
326 -- TODO: get rid of "+ 1" etc.
327 label_size = 1 :: WordOff
330 stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
331 stack_size (Just reg:formats) = width + stack_size formats
333 width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
334 -- TODO: it would be better if we had a machRepWordWidth
336 continuationMaxStack :: [(CLabel, StackFormat)]
339 continuationMaxStack formats (Continuation _ label _ blocks) =
340 max_arg_size + stack_frame_size stack_format
342 stack_format = maybe unknown_format id $ lookup label formats
343 unknown_format = panic "Unknown format in continuationMaxStack"
345 max_arg_size = maximum $ 0 : map block_max_arg_size blocks
347 block_max_arg_size block =
348 maximum (final_arg_size (brokenBlockExit block) :
349 map stmt_arg_size (brokenBlockStmts block))
351 final_arg_size (FinalReturn args) =
352 argumentsSize (cmmExprRep . fst) args
353 final_arg_size (FinalJump _ args) =
354 argumentsSize (cmmExprRep . fst) args
355 final_arg_size (FinalCall next _ _ args) =
356 -- We have to account for the stack used when we build a frame
357 -- for the *next* continuation from *this* continuation
358 argumentsSize (cmmExprRep . fst) args +
359 stack_frame_size next_format
361 next_format = maybe unknown_format id $ lookup next' formats
362 next' = mkReturnPtLabel $ getUnique next
366 stmt_arg_size (CmmJump _ args) =
367 argumentsSize (cmmExprRep . fst) args
368 stmt_arg_size (CmmCall _ _ _ (CmmSafe _)) =
369 panic "Safe call in processFormats"
370 stmt_arg_size (CmmReturn _) =
371 panic "CmmReturn in processFormats"
374 -----------------------------------------------------------------------------
375 applyStackFormat :: [(CLabel, StackFormat)]
376 -> Continuation (Either C_SRT CmmInfo)
377 -> Continuation CmmInfo
379 -- User written continuations
380 applyStackFormat formats (Continuation
381 (Right (CmmInfo prof gc tag (ContInfo _ srt)))
382 label formals blocks) =
383 Continuation (CmmInfo prof gc tag (ContInfo format srt))
386 format = stack_live $ maybe unknown_block id $ lookup label formats
387 unknown_block = panic "unknown BlockId in applyStackFormat"
389 -- User written non-continuation code
390 applyStackFormat formats (Continuation (Right info) label formals blocks) =
391 Continuation info label formals blocks
393 -- CPS generated continuations
394 applyStackFormat formats (Continuation (Left srt) label formals blocks) =
395 Continuation (CmmInfo prof gc tag (ContInfo (stack_live $ format) srt))
398 gc = Nothing -- Generated continuations never need a stack check
399 -- TODO prof: this is the same as the current implementation
400 -- but I think it could be improved
401 prof = ProfilingInfo zeroCLit zeroCLit
402 tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
403 format = maybe unknown_block id $ lookup label formats
404 unknown_block = panic "unknown BlockId in applyStackFormat"
406 -----------------------------------------------------------------------------
407 continuationToProc :: (WordOff, [(CLabel, StackFormat)])
408 -> Continuation CmmInfo
410 continuationToProc (max_stack, formats)
411 (Continuation info label formals blocks) =
412 CmmProc info label formals (map continuationToProc' blocks)
414 curr_format = maybe unknown_block id $ lookup label formats
415 unknown_block = panic "unknown BlockId in continuationToProc"
417 continuationToProc' :: BrokenBlock -> CmmBasicBlock
418 continuationToProc' (BrokenBlock ident entry stmts _ exit) =
419 BasicBlock ident (prefix++stmts++postfix)
421 prefix = case entry of
423 FunctionEntry (CmmInfo _ (Just gc_block) _ _) _ formals ->
424 gc_stack_check gc_block max_stack ++
425 function_entry formals curr_format
426 FunctionEntry (CmmInfo _ Nothing _ _) _ formals ->
427 panic "continuationToProc: missing GC block"
428 FunctionEntry (CmmNonInfo (Just gc_block)) _ formals ->
429 gc_stack_check gc_block max_stack ++
430 function_entry formals curr_format
431 FunctionEntry (CmmNonInfo Nothing) _ formals ->
432 panic "continuationToProc: missing non-info GC block"
433 ContinuationEntry formals _ ->
434 function_entry formals curr_format
435 postfix = case exit of
436 FinalBranch next -> [CmmBranch next]
437 FinalSwitch expr targets -> [CmmSwitch expr targets]
438 FinalReturn arguments ->
439 tail_call (stack_frame_size curr_format)
440 (CmmLoad (CmmReg spReg) wordRep)
442 FinalJump target arguments ->
443 tail_call (stack_frame_size curr_format) target arguments
444 FinalCall next (CmmForeignCall target CmmCallConv)
446 pack_continuation curr_format cont_format ++
447 tail_call (stack_frame_size curr_format - stack_frame_size cont_format)
450 cont_format = maybe unknown_block id $
451 lookup (mkReturnPtLabel $ getUnique next) formats
452 FinalCall next _ results arguments -> panic "unimplemented CmmCall"
454 -----------------------------------------------------------------------------
455 -- Functions that generate CmmStmt sequences
456 -- for packing/unpacking continuations
457 -- and entering/exiting functions
459 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
460 tail_call spRel target arguments
461 = store_arguments ++ adjust_spReg ++ jump where
463 [stack_put spRel expr offset
464 | ((expr, _), StackParam offset) <- argument_formats] ++
465 [global_put expr global
466 | ((expr, _), RegisterParam global) <- argument_formats]
470 else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
471 jump = [CmmJump target arguments]
473 argument_formats = assignArguments (cmmExprRep . fst) arguments
475 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
476 gc_stack_check gc_block max_frame_size
477 = check_stack_limit where
478 check_stack_limit = [
480 (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
481 [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
485 -- TODO: fix branches to proc point
486 -- (we have to insert a new block to marshel the continuation)
487 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
488 pack_continuation (StackFormat curr_id curr_frame_size _)
489 (StackFormat cont_id cont_frame_size live_regs)
490 = store_live_values ++ set_stack_header where
491 -- TODO: only save variables when actually needed
492 -- (may be handled by latter pass)
494 [stack_put spRel (CmmReg (CmmLocal reg)) offset
495 | (reg, offset) <- cont_offsets]
498 then [stack_put spRel continuation_function 0]
501 -- TODO: factor with function_entry and CmmInfo.hs(?)
502 cont_offsets = mkOffsets label_size live_regs
504 label_size = 1 :: WordOff
506 mkOffsets size [] = []
507 mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
508 mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
510 width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
511 -- TODO: it would be better if we had a machRepWordWidth
513 spRel = curr_frame_size - cont_frame_size
514 continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
516 case (curr_id, cont_id) of
517 (Just x, Just y) -> x /= y
520 -- Lazy adjustment of stack headers assumes all blocks
521 -- that could branch to eachother (i.e. control blocks)
522 -- have the same stack format (this causes a problem
523 -- only for proc-point).
524 function_entry :: CmmFormals -> StackFormat -> [CmmStmt]
525 function_entry formals (StackFormat _ _ live_regs)
526 = load_live_values ++ load_args where
527 -- TODO: only save variables when actually needed
528 -- (may be handled by latter pass)
530 [stack_get 0 reg offset
531 | (reg, offset) <- curr_offsets]
533 [stack_get 0 reg offset
534 | (reg, StackParam offset) <- argument_formats] ++
535 [global_get reg global
536 | (reg, RegisterParam global) <- argument_formats]
538 argument_formats = assignArguments (localRegRep) formals
540 -- TODO: eliminate copy/paste with pack_continuation
541 curr_offsets = mkOffsets label_size live_regs
543 label_size = 1 :: WordOff
545 mkOffsets size [] = []
546 mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
547 mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
549 width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
550 -- TODO: it would be better if we had a machRepWordWidth
552 -----------------------------------------------------------------------------
553 -- Section: Stack and argument register puts and gets
554 -----------------------------------------------------------------------------
557 -- |Construct a 'CmmStmt' that will save a value on the stack
558 stack_put :: WordOff -- ^ Offset from the real 'Sp' that 'offset'
559 -- is relative to (added to offset)
560 -> CmmExpr -- ^ What to store onto the stack
561 -> WordOff -- ^ Where on the stack to store it
562 -- (positive <=> higher addresses)
564 stack_put spRel expr offset =
565 CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
567 --------------------------------
573 stack_get spRel reg offset =
574 CmmAssign (CmmLocal reg)
575 (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
577 global_put :: CmmExpr -> GlobalReg -> CmmStmt
578 global_put expr global = CmmAssign (CmmGlobal global) expr
579 global_get :: LocalReg -> GlobalReg -> CmmStmt
580 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))