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(..),
9 #include "HsVersions.h"
13 import CmmBrokenBlock -- Data types only
18 import CgProf (curCCS, curCCSAddr)
19 import CgUtils (cmmOffsetW)
20 import CgInfoTbls (entryCode)
31 import MachRegs (callerSaveVolatileRegs)
32 -- HACK: this is part of the NCG so we shouldn't use this, but we need
33 -- it for now to eliminate the need for saved regs to be in CmmCall.
34 -- The long term solution is to factor callerSaveVolatileRegs
35 -- from nativeGen into CPS
37 -- The format for the call to a continuation
38 -- The fst is the arguments that must be passed to the continuation
39 -- by the continuation's caller.
40 -- The snd is the live values that must be saved on stack.
41 -- A Nothing indicates an ignored slot.
42 -- The head of each list is the stack top or the first parameter.
44 -- The format for live values for a particular continuation
45 -- All on stack for now.
46 -- Head element is the top of the stack (or just under the header).
47 -- Nothing means an empty slot.
48 -- Future possibilities include callee save registers (i.e. passing slots in register)
49 -- and heap memory (not sure if that's usefull at all though, but it may
50 -- be worth exploring the design space).
52 continuationLabel (Continuation _ l _ _ _) = l
53 data Continuation info =
55 info -- Left <=> Continuation created by the CPS
56 -- Right <=> Function or Proc point
57 CLabel -- Used to generate both info & entry labels
58 CmmFormals -- Argument locals live on entry (C-- procedure params)
59 Bool -- ^ True <=> GC block so ignore stack size
60 [BrokenBlock] -- Code, may be empty. The first block is
61 -- the entry point. The order is otherwise initially
62 -- unimportant, but at some point the code gen will
65 -- the BlockId of the first block does not give rise
66 -- to a label. To jump to the first block in a Proc,
67 -- use the appropriate CLabel.
69 data ContinuationFormat
70 = ContinuationFormat {
71 continuation_formals :: CmmFormals,
72 continuation_label :: Maybe CLabel, -- The label occupying the top slot
73 continuation_frame_size :: WordOff, -- Total frame size in words (not including arguments)
74 continuation_stack :: [Maybe LocalReg] -- local reg offsets from stack top
77 -- A block can be a continuation of a call
78 -- A block can be a continuation of another block (w/ or w/o joins)
79 -- A block can be an entry to a function
81 -----------------------------------------------------------------------------
82 continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
85 -> Continuation CmmInfo
87 continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
88 (Continuation info label formals _ blocks) =
89 CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False))
91 curr_format = maybe unknown_block id $ lookup label formats
92 unknown_block = panic "unknown BlockId in continuationToProc"
93 curr_stack = continuation_frame_size curr_format
94 arg_stack = argumentsSize localRegRep formals
96 param_stmts :: [CmmStmt]
97 param_stmts = function_entry curr_format
101 assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
103 update_stmts :: [CmmStmt]
106 CmmInfo _ (Just (UpdateFrame target args)) _ ->
107 pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
108 adjust_sp_reg (curr_stack - update_frame_size)
109 CmmInfo _ Nothing _ -> []
111 -- At present neither the Cmm parser nor the code generator
112 -- produce code that will allow the target of a CmmCondBranch
113 -- or a CmmSwitch to become a continuation or a proc-point.
114 -- If future revisions, might allow these to happen
115 -- then special care will have to be take to allow for that case.
116 continuationToProc' :: [Unique]
120 continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
121 prefix_blocks ++ [main_block]
126 (BlockId prefix_unique)
127 (param_stmts ++ [CmmBranch ident])]
130 prefix_unique : call_uniques = uniques
131 toCLabel = mkReturnPtLabel . getUnique
133 block_for_branch unique next
134 | (Just cont_format) <- lookup (toCLabel next) formats
136 new_next = BlockId unique
137 cont_stack = continuation_frame_size cont_format
138 arguments = map formal_to_actual (continuation_formals cont_format)
140 [BasicBlock new_next $
141 pack_continuation False curr_format cont_format ++
142 tail_call (curr_stack - cont_stack)
143 (CmmLit $ CmmLabel $ toCLabel next)
148 block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
149 block_for_branch' _ Nothing = (Nothing, [])
150 block_for_branch' unique (Just next) = (Just new_next, new_blocks)
151 where (new_next, new_blocks) = block_for_branch unique next
155 FunctionEntry _ _ _ ->
156 -- Ugh, the statements for an update frame must come
157 -- *after* the GC check that was added at the beginning
158 -- of the CPS pass. So we have do edit the statements
159 -- a bit. This depends on the knowledge that the
160 -- statements in the first block are only the GC check.
161 -- That's fragile but it works for now.
162 BasicBlock ident (gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts)
163 ControlEntry -> BasicBlock ident (stmts ++ postfix_stmts)
164 ContinuationEntry _ _ _ -> BasicBlock ident (stmts ++ postfix_stmts)
165 postfix_stmts = case exit of
167 if (mkReturnPtLabel $ getUnique next) == label
168 then [CmmBranch next]
169 else case lookup (mkReturnPtLabel $ getUnique next) formats of
170 Nothing -> [CmmBranch next]
172 pack_continuation True curr_format cont_format ++
173 tail_call (curr_stack - cont_stack)
174 (CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next)
177 cont_stack = continuation_frame_size cont_format
178 arguments = map formal_to_actual (continuation_formals cont_format)
179 FinalSwitch expr targets -> [CmmSwitch expr targets]
180 FinalReturn arguments ->
182 (entryCode (CmmLoad (CmmReg spReg) wordRep))
184 FinalJump target arguments ->
185 tail_call curr_stack target arguments
187 -- A regular Cmm function call
188 FinalCall next (CmmForeignCall target CmmCallConv)
189 results arguments _ _ ->
190 pack_continuation True curr_format cont_format ++
191 tail_call (curr_stack - cont_stack)
194 cont_format = maybe unknown_block id $
195 lookup (mkReturnPtLabel $ getUnique next) formats
196 cont_stack = continuation_frame_size cont_format
198 -- A safe foreign call
199 FinalCall next (CmmForeignCall target conv)
200 results arguments _ _ ->
202 foreignCall call_uniques' (CmmForeignCall new_target conv)
205 (call_uniques', target_stmts, new_target) =
206 maybeAssignTemp call_uniques target
209 FinalCall next (CmmPrim target)
210 results arguments _ _ ->
211 foreignCall call_uniques (CmmPrim target)
214 formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint)
216 foreignCall :: [Unique] -> CmmCallTarget -> CmmHintFormals -> CmmActuals -> [CmmStmt]
217 foreignCall uniques call results arguments =
221 [CmmCall (CmmForeignCall suspendThread CCallConv)
223 [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
225 CmmCall call results new_args CmmUnsafe,
226 CmmCall (CmmForeignCall resumeThread CCallConv)
227 [ (new_base, PtrHint) ]
228 [ (CmmReg (CmmLocal id), PtrHint) ]
230 -- Assign the result to BaseReg: we
231 -- might now have a different Capability!
232 CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
234 loadThreadState tso_unique ++
235 [CmmJump (CmmReg spReg) (map (formal_to_actual . fst) results)]
237 (_, arg_stmts, new_args) =
238 loadArgsIntoTemps argument_uniques arguments
239 (caller_save, caller_load) =
240 callerSaveVolatileRegs (Just [{-only system regs-}])
241 new_base = LocalReg base_unique (cmmRegRep (CmmGlobal BaseReg)) KindNonPtr
242 id = LocalReg id_unique wordRep KindNonPtr
243 tso_unique : base_unique : id_unique : argument_uniques = uniques
245 -- -----------------------------------------------------------------------------
246 -- Save/restore the thread state in the TSO
248 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
249 resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
251 -- This stuff can't be done in suspendThread/resumeThread, because it
252 -- refers to global registers which aren't available in the C world.
255 -- CurrentTSO->sp = Sp;
256 [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
258 -- and save the current cost centre stack in the TSO when profiling:
259 if opt_SccProfilingOn
260 then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
263 -- CurrentNursery->free = Hp+1;
264 closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
266 loadThreadState tso_unique =
269 CmmAssign (CmmLocal tso) stgCurrentTSO,
271 CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
273 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
274 CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
275 rESERVED_STACK_WORDS)
278 -- and load the current cost centre stack from the TSO when profiling:
279 if opt_SccProfilingOn
280 then [CmmStore curCCSAddr
281 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep)]
283 where tso = LocalReg tso_unique wordRep KindNonPtr -- TODO FIXME NOW
287 -- Hp = CurrentNursery->free - 1;
288 CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
290 -- HpLim = CurrentNursery->start +
291 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
294 (CmmLoad nursery_bdescr_start wordRep)
296 (CmmMachOp mo_wordMul [
297 CmmMachOp (MO_S_Conv I32 wordRep)
298 [CmmLoad nursery_bdescr_blocks I32],
299 CmmLit (mkIntCLit bLOCK_SIZE)
307 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
308 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
309 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
311 tso_SP = tsoFieldB oFFSET_StgTSO_sp
312 tso_STACK = tsoFieldB oFFSET_StgTSO_stack
313 tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
315 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
316 -- the middle. The fields we're interested in are after the StgTSOProfInfo.
317 tsoFieldB :: ByteOff -> ByteOff
319 | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
320 | otherwise = off + fixedHdrSize * wORD_SIZE
322 tsoProfFieldB :: ByteOff -> ByteOff
323 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
327 stgCurrentTSO = CmmReg currentTSO
328 stgCurrentNursery = CmmReg currentNursery
331 spLim = CmmGlobal SpLim
333 hpLim = CmmGlobal HpLim
334 currentTSO = CmmGlobal CurrentTSO
335 currentNursery = CmmGlobal CurrentNursery
337 -----------------------------------------------------------------------------
338 -- Functions that generate CmmStmt sequences
339 -- for packing/unpacking continuations
340 -- and entering/exiting functions
342 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
343 tail_call spRel target arguments
344 = store_arguments ++ adjust_sp_reg spRel ++ jump where
346 [stack_put spRel expr offset
347 | ((expr, _), StackParam offset) <- argument_formats] ++
348 [global_put expr global
349 | ((expr, _), RegisterParam global) <- argument_formats]
350 jump = [CmmJump target arguments]
352 argument_formats = assignArguments (cmmExprRep . fst) arguments
354 adjust_sp_reg spRel =
357 else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
359 assign_gc_stack_use stack_use arg_stack max_frame_size =
360 if max_frame_size > arg_stack
361 then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
362 else [CmmAssign stack_use (CmmReg spLimReg)]
363 -- Trick the optimizer into eliminating the branch for us
365 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
366 gc_stack_check gc_block max_frame_size
367 = check_stack_limit where
368 check_stack_limit = [
370 (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
371 [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
376 pack_continuation :: Bool -- ^ Whether to set the top/header
377 -- of the stack. We only need to
378 -- set it if we are calling down
379 -- as opposed to continuation
381 -> ContinuationFormat -- ^ The current format
382 -> ContinuationFormat -- ^ The return point format
384 pack_continuation allow_header_set
385 (ContinuationFormat _ curr_id curr_frame_size _)
386 (ContinuationFormat _ cont_id cont_frame_size live_regs)
387 = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
389 continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal))
392 case (curr_id, cont_id) of
393 (Just x, Just y) -> x /= y
396 maybe_header = if allow_header_set && needs_header_set
397 then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id
400 pack_frame :: WordOff -- ^ Current frame size
401 -> WordOff -- ^ Next frame size
402 -> Maybe CmmExpr -- ^ Next frame header if any
403 -> [Maybe CmmExpr] -- ^ Next frame data
405 pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
406 store_live_values ++ set_stack_header
408 -- TODO: only save variables when actually needed
409 -- (may be handled by latter pass)
411 [stack_put spRel expr offset
412 | (expr, offset) <- cont_offsets]
414 case next_frame_header of
416 Just expr -> [stack_put spRel expr 0]
418 -- TODO: factor with function_entry and CmmInfo.hs(?)
419 cont_offsets = mkOffsets label_size frame_args
421 label_size = 1 :: WordOff
423 mkOffsets size [] = []
424 mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
425 mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
427 width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE
428 -- TODO: it would be better if we had a machRepWordWidth
430 spRel = curr_frame_size - next_frame_size
433 -- Lazy adjustment of stack headers assumes all blocks
434 -- that could branch to eachother (i.e. control blocks)
435 -- have the same stack format (this causes a problem
436 -- only for proc-point).
437 function_entry :: ContinuationFormat -> [CmmStmt]
438 function_entry (ContinuationFormat formals _ _ live_regs)
439 = load_live_values ++ load_args where
440 -- TODO: only save variables when actually needed
441 -- (may be handled by latter pass)
443 [stack_get 0 reg offset
444 | (reg, offset) <- curr_offsets]
446 [stack_get 0 reg offset
447 | (reg, StackParam offset) <- argument_formats] ++
448 [global_get reg global
449 | (reg, RegisterParam global) <- argument_formats]
451 argument_formats = assignArguments (localRegRep) formals
453 -- TODO: eliminate copy/paste with pack_continuation
454 curr_offsets = mkOffsets label_size live_regs
456 label_size = 1 :: WordOff
458 mkOffsets size [] = []
459 mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
460 mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
462 width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
463 -- TODO: it would be better if we had a machRepWordWidth
465 -----------------------------------------------------------------------------
466 -- Section: Stack and argument register puts and gets
467 -----------------------------------------------------------------------------
470 -- |Construct a 'CmmStmt' that will save a value on the stack
471 stack_put :: WordOff -- ^ Offset from the real 'Sp' that 'offset'
472 -- is relative to (added to offset)
473 -> CmmExpr -- ^ What to store onto the stack
474 -> WordOff -- ^ Where on the stack to store it
475 -- (positive <=> higher addresses)
477 stack_put spRel expr offset =
478 CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
480 --------------------------------
486 stack_get spRel reg offset =
487 CmmAssign (CmmLocal reg)
488 (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
490 global_put :: CmmExpr -> GlobalReg -> CmmStmt
491 global_put expr global = CmmAssign (CmmGlobal global) expr
492 global_get :: LocalReg -> GlobalReg -> CmmStmt
493 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))