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)
30 import MachRegs (callerSaveVolatileRegs)
31 -- HACK: this is part of the NCG so we shouldn't use this, but we need
32 -- it for now to eliminate the need for saved regs to be in CmmCall.
33 -- The long term solution is to factor callerSaveVolatileRegs
34 -- from nativeGen into CPS
36 -- The format for the call to a continuation
37 -- The fst is the arguments that must be passed to the continuation
38 -- by the continuation's caller.
39 -- The snd is the live values that must be saved on stack.
40 -- A Nothing indicates an ignored slot.
41 -- The head of each list is the stack top or the first parameter.
43 -- The format for live values for a particular continuation
44 -- All on stack for now.
45 -- Head element is the top of the stack (or just under the header).
46 -- Nothing means an empty slot.
47 -- Future possibilities include callee save registers (i.e. passing slots in register)
48 -- and heap memory (not sure if that's usefull at all though, but it may
49 -- be worth exploring the design space).
51 continuationLabel (Continuation _ l _ _ _) = l
52 data Continuation info =
54 info -- Left <=> Continuation created by the CPS
55 -- Right <=> Function or Proc point
56 CLabel -- Used to generate both info & entry labels
57 CmmFormals -- Argument locals live on entry (C-- procedure params)
58 Bool -- ^ True <=> GC block so ignore stack size
59 [BrokenBlock] -- Code, may be empty. The first block is
60 -- the entry point. The order is otherwise initially
61 -- unimportant, but at some point the code gen will
64 -- the BlockId of the first block does not give rise
65 -- to a label. To jump to the first block in a Proc,
66 -- use the appropriate CLabel.
68 data ContinuationFormat
69 = ContinuationFormat {
70 continuation_formals :: CmmFormals,
71 continuation_label :: Maybe CLabel, -- The label occupying the top slot
72 continuation_frame_size :: WordOff, -- Total frame size in words (not including arguments)
73 continuation_stack :: [Maybe LocalReg] -- local reg offsets from stack top
76 -- A block can be a continuation of a call
77 -- A block can be a continuation of another block (w/ or w/o joins)
78 -- A block can be an entry to a function
80 -----------------------------------------------------------------------------
81 continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
84 -> Continuation CmmInfo
86 continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
87 (Continuation info label formals _ blocks) =
88 CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False))
90 curr_format = maybe unknown_block id $ lookup label formats
91 unknown_block = panic "unknown BlockId in continuationToProc"
92 curr_stack = continuation_frame_size curr_format
93 arg_stack = argumentsSize localRegRep formals
95 param_stmts :: [CmmStmt]
96 param_stmts = function_entry curr_format
100 assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
102 update_stmts :: [CmmStmt]
105 CmmInfo _ (Just (UpdateFrame target args)) _ ->
106 pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
107 adjust_sp_reg (curr_stack - update_frame_size)
108 CmmInfo _ Nothing _ -> []
110 -- At present neither the Cmm parser nor the code generator
111 -- produce code that will allow the target of a CmmCondBranch
112 -- or a CmmSwitch to become a continuation or a proc-point.
113 -- If future revisions, might allow these to happen
114 -- then special care will have to be take to allow for that case.
115 continuationToProc' :: [Unique]
119 continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
120 prefix_blocks ++ [main_block]
125 (BlockId prefix_unique)
126 (param_stmts ++ [CmmBranch ident])]
129 prefix_unique : call_uniques = uniques
130 toCLabel = mkReturnPtLabel . getUnique
132 block_for_branch unique next
133 | (Just cont_format) <- lookup (toCLabel next) formats
135 new_next = BlockId unique
136 cont_stack = continuation_frame_size cont_format
137 arguments = map formal_to_actual (continuation_formals cont_format)
139 [BasicBlock new_next $
140 pack_continuation False curr_format cont_format ++
141 tail_call (curr_stack - cont_stack)
142 (CmmLit $ CmmLabel $ toCLabel next)
147 block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
148 block_for_branch' _ Nothing = (Nothing, [])
149 block_for_branch' unique (Just next) = (Just new_next, new_blocks)
150 where (new_next, new_blocks) = block_for_branch unique next
154 FunctionEntry _ _ _ ->
155 -- Ugh, the statements for an update frame must come
156 -- *after* the GC check that was added at the beginning
157 -- of the CPS pass. So we have do edit the statements
158 -- a bit. This depends on the knowledge that the
159 -- statements in the first block are only the GC check.
160 -- That's fragile but it works for now.
161 BasicBlock ident (gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts)
162 ControlEntry -> BasicBlock ident (stmts ++ postfix_stmts)
163 ContinuationEntry _ _ _ -> BasicBlock ident (stmts ++ postfix_stmts)
164 postfix_stmts = case exit of
166 if (mkReturnPtLabel $ getUnique next) == label
167 then [CmmBranch next]
168 else case lookup (mkReturnPtLabel $ getUnique next) formats of
169 Nothing -> [CmmBranch next]
171 pack_continuation True curr_format cont_format ++
172 tail_call (curr_stack - cont_stack)
173 (CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next)
176 cont_stack = continuation_frame_size cont_format
177 arguments = map formal_to_actual (continuation_formals cont_format)
178 FinalSwitch expr targets -> [CmmSwitch expr targets]
179 FinalReturn arguments ->
181 (CmmLoad (CmmReg spReg) wordRep)
183 FinalJump target arguments ->
184 tail_call curr_stack target arguments
186 -- A regular Cmm function call
187 FinalCall next (CmmForeignCall target CmmCallConv)
188 results arguments _ _ ->
189 pack_continuation True curr_format cont_format ++
190 tail_call (curr_stack - cont_stack)
193 cont_format = maybe unknown_block id $
194 lookup (mkReturnPtLabel $ getUnique next) formats
195 cont_stack = continuation_frame_size cont_format
197 -- A safe foreign call
198 FinalCall next (CmmForeignCall target conv)
199 results arguments _ _ ->
201 foreignCall call_uniques' (CmmForeignCall new_target conv)
204 (call_uniques', target_stmts, new_target) =
205 maybeAssignTemp call_uniques target
208 FinalCall next (CmmPrim target)
209 results arguments _ _ ->
210 foreignCall call_uniques (CmmPrim target)
213 formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint)
215 foreignCall :: [Unique] -> CmmCallTarget -> CmmHintFormals -> CmmActuals -> [CmmStmt]
216 foreignCall uniques call results arguments =
220 [CmmCall (CmmForeignCall suspendThread CCallConv)
222 [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
224 CmmCall call results new_args CmmUnsafe,
225 CmmCall (CmmForeignCall resumeThread CCallConv)
226 [ (new_base, PtrHint) ]
227 [ (CmmReg (CmmLocal id), PtrHint) ]
229 -- Assign the result to BaseReg: we
230 -- might now have a different Capability!
231 CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
233 loadThreadState tso_unique ++
234 [CmmJump (CmmReg spReg) (map (formal_to_actual . fst) results)]
236 (_, arg_stmts, new_args) =
237 loadArgsIntoTemps argument_uniques arguments
238 (caller_save, caller_load) =
239 callerSaveVolatileRegs (Just [{-only system regs-}])
240 new_base = LocalReg base_unique (cmmRegRep (CmmGlobal BaseReg)) KindNonPtr
241 id = LocalReg id_unique wordRep KindNonPtr
242 tso_unique : base_unique : id_unique : argument_uniques = uniques
244 -- -----------------------------------------------------------------------------
245 -- Save/restore the thread state in the TSO
247 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
248 resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
250 -- This stuff can't be done in suspendThread/resumeThread, because it
251 -- refers to global registers which aren't available in the C world.
254 -- CurrentTSO->sp = Sp;
255 [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
257 -- and save the current cost centre stack in the TSO when profiling:
258 if opt_SccProfilingOn
259 then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
262 -- CurrentNursery->free = Hp+1;
263 closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
265 loadThreadState tso_unique =
268 CmmAssign (CmmLocal tso) stgCurrentTSO,
270 CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
272 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
273 CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
274 rESERVED_STACK_WORDS)
277 -- and load the current cost centre stack from the TSO when profiling:
278 if opt_SccProfilingOn
279 then [CmmStore curCCSAddr
280 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep)]
282 where tso = LocalReg tso_unique wordRep KindNonPtr -- TODO FIXME NOW
286 -- Hp = CurrentNursery->free - 1;
287 CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
289 -- HpLim = CurrentNursery->start +
290 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
293 (CmmLoad nursery_bdescr_start wordRep)
295 (CmmMachOp mo_wordMul [
296 CmmMachOp (MO_S_Conv I32 wordRep)
297 [CmmLoad nursery_bdescr_blocks I32],
298 CmmLit (mkIntCLit bLOCK_SIZE)
306 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
307 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
308 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
310 tso_SP = tsoFieldB oFFSET_StgTSO_sp
311 tso_STACK = tsoFieldB oFFSET_StgTSO_stack
312 tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
314 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
315 -- the middle. The fields we're interested in are after the StgTSOProfInfo.
316 tsoFieldB :: ByteOff -> ByteOff
318 | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
319 | otherwise = off + fixedHdrSize * wORD_SIZE
321 tsoProfFieldB :: ByteOff -> ByteOff
322 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
326 stgCurrentTSO = CmmReg currentTSO
327 stgCurrentNursery = CmmReg currentNursery
330 spLim = CmmGlobal SpLim
332 hpLim = CmmGlobal HpLim
333 currentTSO = CmmGlobal CurrentTSO
334 currentNursery = CmmGlobal CurrentNursery
336 -----------------------------------------------------------------------------
337 -- Functions that generate CmmStmt sequences
338 -- for packing/unpacking continuations
339 -- and entering/exiting functions
341 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
342 tail_call spRel target arguments
343 = store_arguments ++ adjust_sp_reg spRel ++ jump where
345 [stack_put spRel expr offset
346 | ((expr, _), StackParam offset) <- argument_formats] ++
347 [global_put expr global
348 | ((expr, _), RegisterParam global) <- argument_formats]
349 jump = [CmmJump target arguments]
351 argument_formats = assignArguments (cmmExprRep . fst) arguments
353 adjust_sp_reg spRel =
356 else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
358 assign_gc_stack_use stack_use arg_stack max_frame_size =
359 if max_frame_size > arg_stack
360 then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
361 else [CmmAssign stack_use (CmmReg spLimReg)]
362 -- Trick the optimizer into eliminating the branch for us
364 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
365 gc_stack_check gc_block max_frame_size
366 = check_stack_limit where
367 check_stack_limit = [
369 (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
370 [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
375 pack_continuation :: Bool -- ^ Whether to set the top/header
376 -- of the stack. We only need to
377 -- set it if we are calling down
378 -- as opposed to continuation
380 -> ContinuationFormat -- ^ The current format
381 -> ContinuationFormat -- ^ The return point format
383 pack_continuation allow_header_set
384 (ContinuationFormat _ curr_id curr_frame_size _)
385 (ContinuationFormat _ cont_id cont_frame_size live_regs)
386 = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
388 continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal))
391 case (curr_id, cont_id) of
392 (Just x, Just y) -> x /= y
395 maybe_header = if allow_header_set && needs_header_set
396 then maybe Nothing (Just . CmmLit . CmmLabel) cont_id
399 pack_frame :: WordOff -- ^ Current frame size
400 -> WordOff -- ^ Next frame size
401 -> Maybe CmmExpr -- ^ Next frame header if any
402 -> [Maybe CmmExpr] -- ^ Next frame data
404 pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
405 store_live_values ++ set_stack_header
407 -- TODO: only save variables when actually needed
408 -- (may be handled by latter pass)
410 [stack_put spRel expr offset
411 | (expr, offset) <- cont_offsets]
413 case next_frame_header of
415 Just expr -> [stack_put spRel expr 0]
417 -- TODO: factor with function_entry and CmmInfo.hs(?)
418 cont_offsets = mkOffsets label_size frame_args
420 label_size = 1 :: WordOff
422 mkOffsets size [] = []
423 mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
424 mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
426 width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE
427 -- TODO: it would be better if we had a machRepWordWidth
429 spRel = curr_frame_size - next_frame_size
432 -- Lazy adjustment of stack headers assumes all blocks
433 -- that could branch to eachother (i.e. control blocks)
434 -- have the same stack format (this causes a problem
435 -- only for proc-point).
436 function_entry :: ContinuationFormat -> [CmmStmt]
437 function_entry (ContinuationFormat formals _ _ live_regs)
438 = load_live_values ++ load_args where
439 -- TODO: only save variables when actually needed
440 -- (may be handled by latter pass)
442 [stack_get 0 reg offset
443 | (reg, offset) <- curr_offsets]
445 [stack_get 0 reg offset
446 | (reg, StackParam offset) <- argument_formats] ++
447 [global_get reg global
448 | (reg, RegisterParam global) <- argument_formats]
450 argument_formats = assignArguments (localRegRep) formals
452 -- TODO: eliminate copy/paste with pack_continuation
453 curr_offsets = mkOffsets label_size live_regs
455 label_size = 1 :: WordOff
457 mkOffsets size [] = []
458 mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
459 mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
461 width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
462 -- TODO: it would be better if we had a machRepWordWidth
464 -----------------------------------------------------------------------------
465 -- Section: Stack and argument register puts and gets
466 -----------------------------------------------------------------------------
469 -- |Construct a 'CmmStmt' that will save a value on the stack
470 stack_put :: WordOff -- ^ Offset from the real 'Sp' that 'offset'
471 -- is relative to (added to offset)
472 -> CmmExpr -- ^ What to store onto the stack
473 -> WordOff -- ^ Where on the stack to store it
474 -- (positive <=> higher addresses)
476 stack_put spRel expr offset =
477 CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
479 --------------------------------
485 stack_get spRel reg offset =
486 CmmAssign (CmmLocal reg)
487 (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
489 global_put :: CmmExpr -> GlobalReg -> CmmStmt
490 global_put expr global = CmmAssign (CmmGlobal global) expr
491 global_get :: LocalReg -> GlobalReg -> CmmStmt
492 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))