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 srt = BasicBlock block_id stmts
75 stmts = [CmmCall stg_gc_gen_target [] [] srt,
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 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 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, (Maybe CLabel, [Maybe LocalReg]))]
161 formats = selectStackFormat live continuations
163 -- Do a little meta-processing on the stack formats such as
164 -- getting the individual frame sizes and the maximum frame size
165 formats' :: (WordOff, [(CLabel, StackFormat)])
166 formats' = processFormats formats
168 -- TODO FIXME NOW: calculate a real max stack (including function call args)
169 -- TODO: from the maximum frame size get the maximum stack size.
170 -- The difference is due to the size taken by function calls.
172 -- Update the info table data on the continuations with
173 -- the selected stack formats.
174 continuations' :: [Continuation CmmInfo]
175 continuations' = map (applyStackFormat (snd formats')) continuations
177 -- Do the actual CPS transform.
178 cps_procs :: [CmmTop]
179 cps_procs = map (continuationToProc formats') continuations'
181 -- Convert the info tables from CmmInfo to [CmmStatic]
182 -- We might want to put this in another pass eventually
183 info_procs :: [RawCmmTop]
184 info_procs = concat (zipWith mkInfoTable info_uniques cps_procs)
186 --------------------------------------------------------------------------------
188 -- The format for the call to a continuation
189 -- The fst is the arguments that must be passed to the continuation
190 -- by the continuation's caller.
191 -- The snd is the live values that must be saved on stack.
192 -- A Nothing indicates an ignored slot.
193 -- The head of each list is the stack top or the first parameter.
195 -- The format for live values for a particular continuation
196 -- All on stack for now.
197 -- Head element is the top of the stack (or just under the header).
198 -- Nothing means an empty slot.
199 -- Future possibilities include callee save registers (i.e. passing slots in register)
200 -- and heap memory (not sure if that's usefull at all though, but it may
201 -- be worth exploring the design space).
203 continuationLabel (Continuation _ l _ _) = l
204 data Continuation info =
206 info --(Either C_SRT CmmInfo) -- Left <=> Continuation created by the CPS
207 -- Right <=> Function or Proc point
208 CLabel -- Used to generate both info & entry labels
209 CmmFormals -- Argument locals live on entry (C-- procedure params)
210 [BrokenBlock] -- Code, may be empty. The first block is
211 -- the entry point. The order is otherwise initially
212 -- unimportant, but at some point the code gen will
215 -- the BlockId of the first block does not give rise
216 -- to a label. To jump to the first block in a Proc,
217 -- use the appropriate CLabel.
221 stack_label :: Maybe CLabel, -- The label occupying the top slot
222 stack_frame_size :: WordOff, -- Total frame size in words (not including arguments)
223 stack_live :: [Maybe LocalReg] -- local reg offsets from stack top
226 -- A block can be a continuation of a call
227 -- A block can be a continuation of another block (w/ or w/o joins)
228 -- A block can be an entry to a function
230 -----------------------------------------------------------------------------
232 collectNonProcPointTargets ::
233 UniqSet BlockId -> BlockEnv BrokenBlock
234 -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
235 collectNonProcPointTargets proc_points blocks current_targets new_blocks =
236 if sizeUniqSet current_targets == sizeUniqSet new_targets
239 (collectNonProcPointTargets proc_points blocks)
243 blocks' = map (lookupWithDefaultUFM blocks (panic "TODO")) new_blocks
245 -- Note the subtlety that since the extra branch after a call
246 -- will always be to a block that is a proc-point,
247 -- this subtraction will always remove that case
248 uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
249 `minusUniqSet` proc_points
250 -- TODO: remove redundant uniqSetToList
251 new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
253 -- TODO: insert proc point code here
254 -- * Branches and switches to proc points may cause new blocks to be created
255 -- (or proc points could leave behind phantom blocks that just jump to them)
256 -- * Proc points might get some live variables passed as arguments
258 gatherBlocksIntoContinuation ::
259 UniqSet BlockId -> BlockEnv BrokenBlock
260 -> BlockId -> Maybe BlockId -> Continuation (Either C_SRT CmmInfo)
261 gatherBlocksIntoContinuation proc_points blocks start gc =
262 Continuation info_table clabel params body
264 start_and_gc = start : maybeToList gc
265 children = (collectNonProcPointTargets proc_points blocks (mkUniqSet start_and_gc) start_and_gc) `minusUniqSet` (mkUniqSet start_and_gc)
266 start_block = lookupWithDefaultUFM blocks (panic "TODO") start
267 gc_block = map (lookupWithDefaultUFM blocks (panic "TODO)")) (maybeToList gc)
268 children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
269 body = start_block : gc_block ++ children_blocks
271 -- We can't properly annotate the continuation's stack parameters
272 -- at this point because this is before stack selection
273 -- but we want to keep the C_SRT around so we use 'Either'.
274 info_table = case start_block_entry of
275 FunctionEntry info _ _ -> Right info
276 ContinuationEntry _ srt -> Left srt
277 ControlEntry -> Right (CmmNonInfo Nothing)
279 start_block_entry = brokenBlockEntry start_block
280 clabel = case start_block_entry of
281 FunctionEntry _ label _ -> label
282 _ -> mkReturnPtLabel $ getUnique start
283 params = case start_block_entry of
284 FunctionEntry _ _ args -> args
285 ContinuationEntry args _ -> args
286 ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
288 --------------------------------------------------------------------------------
289 -- For now just select the continuation orders in the order they are in the set with no gaps
291 selectStackFormat :: BlockEnv CmmLive
292 -> [Continuation (Either C_SRT CmmInfo)]
293 -> [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
294 selectStackFormat live continuations =
295 map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
297 selectStackFormat' (Continuation
298 (Right (CmmInfo _ _ _ (ContInfo format srt)))
299 label _ _) = (Just label, format)
300 selectStackFormat' (Continuation (Right _) _ _ _) = (Nothing, [])
301 selectStackFormat' (Continuation (Left srt) label _ blocks) =
302 -- TODO: assumes the first block is the entry block
303 let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
305 map Just $ uniqSetToList $
306 lookupWithDefaultUFM live unknown_block ident)
308 unknown_block = panic "unknown BlockId in selectStackFormat"
310 processFormats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
311 -> (WordOff, [(CLabel, StackFormat)])
312 processFormats formats = (max_size, formats')
314 max_size = foldl max 0 (map (stack_frame_size . snd) formats')
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 -----------------------------------------------------------------------------
337 applyStackFormat :: [(CLabel, StackFormat)]
338 -> Continuation (Either C_SRT CmmInfo)
339 -> Continuation CmmInfo
341 -- User written continuations
342 applyStackFormat formats (Continuation
343 (Right (CmmInfo prof gc tag (ContInfo _ srt)))
344 label formals blocks) =
345 Continuation (CmmInfo prof gc tag (ContInfo format srt))
348 format = stack_live $ maybe unknown_block id $ lookup label formats
349 unknown_block = panic "unknown BlockId in applyStackFormat"
351 -- User written non-continuation code
352 applyStackFormat formats (Continuation (Right info) label formals blocks) =
353 Continuation info label formals blocks
355 -- CPS generated continuations
356 applyStackFormat formats (Continuation (Left srt) label formals blocks) =
357 Continuation (CmmInfo prof gc tag (ContInfo (stack_live $ format) srt))
360 gc = Nothing -- Generated continuations never need a stack check
361 -- TODO prof: this is the same as the current implementation
362 -- but I think it could be improved
363 prof = ProfilingInfo zeroCLit zeroCLit
364 tag = if stack_frame_size format > mAX_SMALL_BITMAP_SIZE
367 format = maybe unknown_block id $ lookup label formats
368 unknown_block = panic "unknown BlockId in applyStackFormat"
370 -----------------------------------------------------------------------------
371 continuationToProc :: (WordOff, [(CLabel, StackFormat)])
372 -> Continuation CmmInfo
374 continuationToProc (max_stack, formats)
375 (Continuation info label formals blocks) =
376 CmmProc info label formals (map continuationToProc' blocks)
378 curr_format = maybe unknown_block id $ lookup label formats
379 unknown_block = panic "unknown BlockId in continuationToProc"
381 continuationToProc' :: BrokenBlock -> CmmBasicBlock
382 continuationToProc' (BrokenBlock ident entry stmts _ exit) =
383 BasicBlock ident (prefix++stmts++postfix)
385 prefix = case entry of
387 FunctionEntry (CmmInfo _ (Just gc_block) _ _) _ formals ->
388 gc_stack_check gc_block max_stack ++
389 function_entry formals curr_format
390 FunctionEntry (CmmInfo _ Nothing _ _) _ formals ->
391 panic "continuationToProc: missing GC block"
392 FunctionEntry (CmmNonInfo (Just gc_block)) _ formals ->
393 gc_stack_check gc_block max_stack ++
394 function_entry formals curr_format
395 FunctionEntry (CmmNonInfo Nothing) _ formals ->
396 panic "continuationToProc: missing non-info GC block"
397 ContinuationEntry formals _ ->
398 function_entry formals curr_format
399 postfix = case exit of
400 FinalBranch next -> [CmmBranch next]
401 FinalSwitch expr targets -> [CmmSwitch expr targets]
402 FinalReturn arguments ->
403 tail_call (stack_frame_size curr_format)
404 (CmmLoad (CmmReg spReg) wordRep)
406 FinalJump target arguments ->
407 tail_call (stack_frame_size curr_format) target arguments
408 FinalCall next (CmmForeignCall target CmmCallConv)
410 pack_continuation curr_format cont_format ++
411 tail_call (stack_frame_size curr_format - stack_frame_size cont_format)
414 cont_format = maybe unknown_block id $
415 lookup (mkReturnPtLabel $ getUnique next) formats
416 FinalCall next _ results arguments -> panic "unimplemented CmmCall"
418 -----------------------------------------------------------------------------
419 -- Functions that generate CmmStmt sequences
420 -- for packing/unpacking continuations
421 -- and entering/exiting functions
423 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
424 tail_call spRel target arguments
425 = store_arguments ++ adjust_spReg ++ jump where
427 [stack_put spRel expr offset
428 | ((expr, _), StackParam offset) <- argument_formats] ++
429 [global_put expr global
430 | ((expr, _), RegisterParam global) <- argument_formats]
434 else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
435 jump = [CmmJump target arguments]
437 argument_formats = assignArguments (cmmExprRep . fst) arguments
439 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
440 gc_stack_check gc_block max_frame_size
441 = check_stack_limit where
442 check_stack_limit = [
444 (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
445 [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
449 -- TODO: fix branches to proc point
450 -- (we have to insert a new block to marshel the continuation)
451 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
452 pack_continuation (StackFormat curr_id curr_frame_size _)
453 (StackFormat cont_id cont_frame_size live_regs)
454 = store_live_values ++ set_stack_header where
455 -- TODO: only save variables when actually needed
456 -- (may be handled by latter pass)
458 [stack_put spRel (CmmReg (CmmLocal reg)) offset
459 | (reg, offset) <- cont_offsets]
462 then [stack_put spRel continuation_function 0]
465 -- TODO: factor with function_entry and CmmInfo.hs(?)
466 cont_offsets = mkOffsets label_size live_regs
468 label_size = 1 :: WordOff
470 mkOffsets size [] = []
471 mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
472 mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
474 width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
475 -- TODO: it would be better if we had a machRepWordWidth
477 spRel = curr_frame_size - cont_frame_size
478 continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
480 case (curr_id, cont_id) of
481 (Just x, Just y) -> x /= y
484 -- Lazy adjustment of stack headers assumes all blocks
485 -- that could branch to eachother (i.e. control blocks)
486 -- have the same stack format (this causes a problem
487 -- only for proc-point).
488 function_entry :: CmmFormals -> StackFormat -> [CmmStmt]
489 function_entry formals (StackFormat _ _ live_regs)
490 = load_live_values ++ load_args where
491 -- TODO: only save variables when actually needed
492 -- (may be handled by latter pass)
494 [stack_get 0 reg offset
495 | (reg, offset) <- curr_offsets]
497 [stack_get 0 reg offset
498 | (reg, StackParam offset) <- argument_formats] ++
499 [global_get reg global
500 | (reg, RegisterParam global) <- argument_formats]
502 argument_formats = assignArguments (localRegRep) formals
504 -- TODO: eliminate copy/paste with pack_continuation
505 curr_offsets = mkOffsets label_size live_regs
507 label_size = 1 :: WordOff
509 mkOffsets size [] = []
510 mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
511 mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
513 width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
514 -- TODO: it would be better if we had a machRepWordWidth
516 -----------------------------------------------------------------------------
517 -- Section: Stack and argument register puts and gets
518 -----------------------------------------------------------------------------
521 -- |Construct a 'CmmStmt' that will save a value on the stack
522 stack_put :: WordOff -- ^ Offset from the real 'Sp' that 'offset'
523 -- is relative to (added to offset)
524 -> CmmExpr -- ^ What to store onto the stack
525 -> WordOff -- ^ Where on the stack to store it
526 -- (positive <=> higher addresses)
528 stack_put spRel expr offset =
529 CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
531 --------------------------------
537 stack_get spRel reg offset =
538 CmmAssign (CmmLocal reg)
539 (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
541 global_put :: CmmExpr -> GlobalReg -> CmmStmt
542 global_put expr global = CmmAssign (CmmGlobal global) expr
543 global_get :: LocalReg -> GlobalReg -> CmmStmt
544 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))