2 -- | Converts continuations into full proceedures.
3 -- The main work of the CPS transform that everything else is setting-up.
5 Continuation(..), continuationLabel,
6 ContinuationFormat(..),
12 import CmmBrokenBlock -- Data types only
31 -- The format for the call to a continuation
32 -- The fst is the arguments that must be passed to the continuation
33 -- by the continuation's caller.
34 -- The snd is the live values that must be saved on stack.
35 -- A Nothing indicates an ignored slot.
36 -- The head of each list is the stack top or the first parameter.
38 -- The format for live values for a particular continuation
39 -- All on stack for now.
40 -- Head element is the top of the stack (or just under the header).
41 -- Nothing means an empty slot.
42 -- Future possibilities include callee save registers (i.e. passing slots in register)
43 -- and heap memory (not sure if that's usefull at all though, but it may
44 -- be worth exploring the design space).
46 continuationLabel :: Continuation (Either C_SRT CmmInfo) -> CLabel
47 continuationLabel (Continuation _ l _ _ _) = l
48 data Continuation info =
50 info -- Left <=> Continuation created by the CPS
51 -- Right <=> Function or Proc point
52 CLabel -- Used to generate both info & entry labels
53 CmmFormals -- Argument locals live on entry (C-- procedure params)
54 Bool -- True <=> GC block so ignore stack size
55 [BrokenBlock] -- Code, may be empty. The first block is
56 -- the entry point. The order is otherwise initially
57 -- unimportant, but at some point the code gen will
60 -- the BlockId of the first block does not give rise
61 -- to a label. To jump to the first block in a Proc,
62 -- use the appropriate CLabel.
64 data ContinuationFormat
65 = ContinuationFormat {
66 continuation_formals :: CmmFormals,
67 continuation_label :: Maybe CLabel, -- The label occupying the top slot
68 continuation_frame_size :: WordOff, -- Total frame size in words (not including arguments)
69 continuation_stack :: [Maybe LocalReg] -- local reg offsets from stack top
72 -- A block can be a continuation of a call
73 -- A block can be a continuation of another block (w/ or w/o joins)
74 -- A block can be an entry to a function
76 -----------------------------------------------------------------------------
77 continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
80 -> Continuation CmmInfo
82 continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
83 (Continuation info label formals _ blocks) =
84 CmmProc info label formals (ListGraph blocks')
86 blocks' = concat $ zipWith3 continuationToProc' uniques blocks
88 curr_format = maybe unknown_block id $ lookup label formats
89 unknown_block = panic "unknown BlockId in continuationToProc"
90 curr_stack = continuation_frame_size curr_format
91 arg_stack = argumentsSize localRegType formals
93 param_stmts :: [CmmStmt]
94 param_stmts = function_entry curr_format
98 assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
100 update_stmts :: [CmmStmt]
103 CmmInfo _ (Just (UpdateFrame target args)) _ ->
104 pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
105 adjust_sp_reg (curr_stack - update_frame_size)
106 CmmInfo _ Nothing _ -> []
108 continuationToProc' :: [[Unique]]
112 continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
113 prefix_blocks ++ [BasicBlock ident fixed_main_stmts] ++ concat new_blocks
118 (BlockId prefix_unique)
119 (param_stmts ++ [CmmBranch ident])]
122 (prefix_unique : call_uniques) : new_block_uniques = uniques
123 toCLabel = mkReturnPtLabel . getUnique
125 block_for_branch :: Unique -> BlockId -> (BlockId, [CmmBasicBlock])
126 block_for_branch unique next
127 -- branches to the current function don't have to jump
128 | (mkReturnPtLabel $ getUnique next) == label
131 -- branches to any other function have to jump
132 | (Just cont_format) <- lookup (toCLabel next) formats
134 new_next = BlockId unique
135 cont_stack = continuation_frame_size cont_format
136 arguments = map formal_to_actual (continuation_formals cont_format)
138 [BasicBlock new_next $
139 pack_continuation curr_format cont_format ++
140 tail_call (curr_stack - cont_stack)
141 (CmmLit $ CmmLabel $ toCLabel next)
144 -- branches to blocks in the current function don't have to jump
148 -- Wrapper for block_for_branch for when the target
149 -- is inside a 'Maybe'.
150 block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
151 block_for_branch' _ Nothing = (Nothing, [])
152 block_for_branch' unique (Just next) = (Just new_next, new_blocks)
153 where (new_next, new_blocks) = block_for_branch unique next
155 -- If the target of a switch, branch or cond branch becomes a proc point
156 -- then we have to make a new block what will then *jump* to the original target.
157 proc_point_fix unique (CmmCondBranch test target)
158 = (CmmCondBranch test new_target, new_blocks)
159 where (new_target, new_blocks) = block_for_branch (head unique) target
160 proc_point_fix unique (CmmSwitch test targets)
161 = (CmmSwitch test new_targets, concat new_blocks)
162 where (new_targets, new_blocks) =
163 unzip $ zipWith block_for_branch' unique targets
164 proc_point_fix unique (CmmBranch target)
165 = (CmmBranch new_target, new_blocks)
166 where (new_target, new_blocks) = block_for_branch (head unique) target
167 proc_point_fix _ other = (other, [])
169 (fixed_main_stmts, new_blocks) = unzip $ zipWith proc_point_fix new_block_uniques main_stmts
172 FunctionEntry _ _ _ ->
173 -- The statements for an update frame must come /after/
174 -- the GC check that was added at the beginning of the
175 -- CPS pass. So we have do edit the statements a bit.
176 -- This depends on the knowledge that the statements in
177 -- the first block are only the GC check. That's
178 -- fragile but it works for now.
179 gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts
180 ControlEntry -> stmts ++ postfix_stmts
181 ContinuationEntry _ _ _ -> stmts ++ postfix_stmts
182 postfix_stmts = case exit of
183 -- Branches and switches may get modified by proc_point_fix
184 FinalBranch next -> [CmmBranch next]
185 FinalSwitch expr targets -> [CmmSwitch expr targets]
187 -- A return is a tail call to the stack top
188 FinalReturn arguments ->
190 (entryCode (CmmLoad (CmmReg spReg) bWord))
194 FinalJump target arguments ->
195 tail_call curr_stack target arguments
197 -- A regular Cmm function call
198 FinalCall next (CmmCallee target CmmCallConv)
200 pack_continuation curr_format cont_format ++
201 tail_call (curr_stack - cont_stack)
204 cont_format = maybe unknown_block id $
205 lookup (mkReturnPtLabel $ getUnique next) formats
206 cont_stack = continuation_frame_size cont_format
208 -- A safe foreign call
209 FinalCall _ (CmmCallee target conv)
210 results arguments _ _ _ ->
212 foreignCall call_uniques' (CmmCallee new_target conv)
215 (call_uniques', target_stmts, new_target) =
216 maybeAssignTemp call_uniques target
219 FinalCall _ (CmmPrim target)
220 results arguments _ _ _ ->
221 foreignCall call_uniques (CmmPrim target)
224 formal_to_actual :: LocalReg -> CmmHinted CmmExpr
225 formal_to_actual reg = CmmHinted (CmmReg (CmmLocal reg)) NoHint
227 foreignCall :: [Unique] -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> [CmmStmt]
228 foreignCall uniques call results arguments =
232 [CmmCall (CmmCallee suspendThread CCallConv)
233 [ CmmHinted id AddrHint ]
234 [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ]
237 CmmCall call results new_args CmmUnsafe CmmMayReturn,
238 CmmCall (CmmCallee resumeThread CCallConv)
239 [ CmmHinted new_base AddrHint ]
240 [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
243 -- Assign the result to BaseReg: we
244 -- might now have a different Capability!
245 CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
247 loadThreadState tso_unique ++
248 [CmmJump (CmmReg spReg) (map (formal_to_actual . hintlessCmm) results)]
250 (_, arg_stmts, new_args) =
251 loadArgsIntoTemps argument_uniques arguments
252 (caller_save, caller_load) =
253 callerSaveVolatileRegs (Just [{-only system regs-}])
254 new_base = LocalReg base_unique (cmmRegType (CmmGlobal BaseReg))
255 id = LocalReg id_unique bWord
256 tso_unique : base_unique : id_unique : argument_uniques = uniques
258 -- -----------------------------------------------------------------------------
259 -- Save/restore the thread state in the TSO
261 suspendThread, resumeThread :: CmmExpr
262 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread")))
263 resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread")))
265 -- This stuff can't be done in suspendThread/resumeThread, because it
266 -- refers to global registers which aren't available in the C world.
268 saveThreadState :: [CmmStmt]
270 -- CurrentTSO->sp = Sp;
271 [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
273 -- and save the current cost centre stack in the TSO when profiling:
274 if opt_SccProfilingOn
275 then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
278 -- CurrentNursery->free = Hp+1;
279 closeNursery :: CmmStmt
280 closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
282 loadThreadState :: Unique -> [CmmStmt]
283 loadThreadState tso_unique =
286 CmmAssign (CmmLocal tso) stgCurrentTSO,
288 CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
290 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
291 CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
292 rESERVED_STACK_WORDS)
295 -- and load the current cost centre stack from the TSO when profiling:
296 if opt_SccProfilingOn
297 then [CmmStore curCCSAddr
298 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord)]
300 where tso = LocalReg tso_unique bWord -- TODO FIXME NOW
303 openNursery :: [CmmStmt]
305 -- Hp = CurrentNursery->free - 1;
306 CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
308 -- HpLim = CurrentNursery->start +
309 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
312 (CmmLoad nursery_bdescr_start bWord)
314 (CmmMachOp mo_wordMul [
315 CmmMachOp (MO_SS_Conv W32 wordWidth)
316 [CmmLoad nursery_bdescr_blocks b32],
317 CmmLit (mkIntCLit bLOCK_SIZE)
325 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
326 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
327 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
328 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
330 tso_SP, tso_STACK, tso_CCCS :: ByteOff
331 tso_SP = tsoFieldB oFFSET_StgTSO_sp
332 tso_STACK = tsoFieldB oFFSET_StgTSO_stack
333 tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
335 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
336 -- the middle. The fields we're interested in are after the StgTSOProfInfo.
337 tsoFieldB :: ByteOff -> ByteOff
339 | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
340 | otherwise = off + fixedHdrSize * wORD_SIZE
342 tsoProfFieldB :: ByteOff -> ByteOff
343 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
345 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
348 stgCurrentTSO = CmmReg currentTSO
349 stgCurrentNursery = CmmReg currentNursery
351 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
353 spLim = CmmGlobal SpLim
355 hpLim = CmmGlobal HpLim
356 currentTSO = CmmGlobal CurrentTSO
357 currentNursery = CmmGlobal CurrentNursery
359 -----------------------------------------------------------------------------
360 -- Functions that generate CmmStmt sequences
361 -- for packing/unpacking continuations
362 -- and entering/exiting functions
364 tail_call :: WordOff -> CmmExpr -> HintedCmmActuals -> [CmmStmt]
365 tail_call spRel target arguments
366 = store_arguments ++ adjust_sp_reg spRel ++ jump where
368 [stack_put spRel expr offset
369 | ((CmmHinted expr _), StackParam offset) <- argument_formats] ++
370 [global_put expr global
371 | ((CmmHinted expr _), RegisterParam global) <- argument_formats]
372 jump = [CmmJump target arguments]
374 argument_formats = assignArguments (cmmExprType . hintlessCmm) arguments
376 adjust_sp_reg :: Int -> [CmmStmt]
377 adjust_sp_reg spRel =
380 else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
382 assign_gc_stack_use :: CmmReg -> Int -> Int -> [CmmStmt]
383 assign_gc_stack_use stack_use arg_stack max_frame_size =
384 if max_frame_size > arg_stack
385 then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
386 else [CmmAssign stack_use (CmmReg spLimReg)]
387 -- Trick the optimizer into eliminating the branch for us
392 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
393 gc_stack_check gc_block max_frame_size
394 = check_stack_limit where
395 check_stack_limit = [
397 (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg)))
398 [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
403 pack_continuation :: ContinuationFormat -- ^ The current format
404 -> ContinuationFormat -- ^ The return point format
406 pack_continuation (ContinuationFormat _ curr_id curr_frame_size _)
407 (ContinuationFormat _ cont_id cont_frame_size live_regs)
408 = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
410 continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal))
413 case (curr_id, cont_id) of
414 (Just x, Just y) -> x /= y
417 maybe_header = if needs_header_set
418 then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id
421 pack_frame :: WordOff -- ^ Current frame size
422 -> WordOff -- ^ Next frame size
423 -> Maybe CmmExpr -- ^ Next frame header if any
424 -> [Maybe CmmExpr] -- ^ Next frame data
426 pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
427 store_live_values ++ set_stack_header
429 -- TODO: only save variables when actually needed
430 -- (may be handled by latter pass)
432 [stack_put spRel expr offset
433 | (expr, offset) <- cont_offsets]
435 case next_frame_header of
437 Just expr -> [stack_put spRel expr 0]
439 -- TODO: factor with function_entry and CmmInfo.hs(?)
440 cont_offsets = mkOffsets label_size frame_args
442 label_size = 1 :: WordOff
445 mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
446 mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
448 width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE
449 -- TODO: it would be better if we had a machRepWordWidth
451 spRel = curr_frame_size - next_frame_size
454 -- Lazy adjustment of stack headers assumes all blocks
455 -- that could branch to eachother (i.e. control blocks)
456 -- have the same stack format (this causes a problem
457 -- only for proc-point).
458 function_entry :: ContinuationFormat -> [CmmStmt]
459 function_entry (ContinuationFormat formals _ _ live_regs)
460 = load_live_values ++ load_args where
461 -- TODO: only save variables when actually needed
462 -- (may be handled by latter pass)
464 [stack_get 0 reg offset
465 | (reg, offset) <- curr_offsets]
467 [stack_get 0 reg offset
468 | (reg, StackParam offset) <- argument_formats] ++
469 [global_get reg global
470 | (reg, RegisterParam global) <- argument_formats]
472 argument_formats = assignArguments (localRegType) formals
474 -- TODO: eliminate copy/paste with pack_continuation
475 curr_offsets = mkOffsets label_size live_regs
477 label_size = 1 :: WordOff
480 mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
481 mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
483 width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE
484 -- TODO: it would be better if we had a machRepWordWidth
486 -----------------------------------------------------------------------------
487 -- Section: Stack and argument register puts and gets
488 -----------------------------------------------------------------------------
491 -- |Construct a 'CmmStmt' that will save a value on the stack
492 stack_put :: WordOff -- ^ Offset from the real 'Sp' that 'offset'
493 -- is relative to (added to offset)
494 -> CmmExpr -- ^ What to store onto the stack
495 -> WordOff -- ^ Where on the stack to store it
496 -- (positive <=> higher addresses)
498 stack_put spRel expr offset =
499 CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
501 --------------------------------
507 stack_get spRel reg offset =
508 CmmAssign (CmmLocal reg)
509 (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
511 global_put :: CmmExpr -> GlobalReg -> CmmStmt
512 global_put expr global = CmmAssign (CmmGlobal global) expr
513 global_get :: LocalReg -> GlobalReg -> CmmStmt
514 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))