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)
32 import MachRegs (callerSaveVolatileRegs)
33 -- HACK: this is part of the NCG so we shouldn't use this, but we need
34 -- it for now to eliminate the need for saved regs to be in CmmCall.
35 -- The long term solution is to factor callerSaveVolatileRegs
36 -- from nativeGen into CPS
38 -- The format for the call to a continuation
39 -- The fst is the arguments that must be passed to the continuation
40 -- by the continuation's caller.
41 -- The snd is the live values that must be saved on stack.
42 -- A Nothing indicates an ignored slot.
43 -- The head of each list is the stack top or the first parameter.
45 -- The format for live values for a particular continuation
46 -- All on stack for now.
47 -- Head element is the top of the stack (or just under the header).
48 -- Nothing means an empty slot.
49 -- Future possibilities include callee save registers (i.e. passing slots in register)
50 -- and heap memory (not sure if that's usefull at all though, but it may
51 -- be worth exploring the design space).
53 continuationLabel (Continuation _ l _ _ _) = l
54 data Continuation info =
56 info -- Left <=> Continuation created by the CPS
57 -- Right <=> Function or Proc point
58 CLabel -- Used to generate both info & entry labels
59 CmmFormals -- Argument locals live on entry (C-- procedure params)
60 Bool -- ^ True <=> GC block so ignore stack size
61 [BrokenBlock] -- Code, may be empty. The first block is
62 -- the entry point. The order is otherwise initially
63 -- unimportant, but at some point the code gen will
66 -- the BlockId of the first block does not give rise
67 -- to a label. To jump to the first block in a Proc,
68 -- use the appropriate CLabel.
70 data ContinuationFormat
71 = ContinuationFormat {
72 continuation_formals :: CmmFormals,
73 continuation_label :: Maybe CLabel, -- The label occupying the top slot
74 continuation_frame_size :: WordOff, -- Total frame size in words (not including arguments)
75 continuation_stack :: [Maybe LocalReg] -- local reg offsets from stack top
78 -- A block can be a continuation of a call
79 -- A block can be a continuation of another block (w/ or w/o joins)
80 -- A block can be an entry to a function
82 -----------------------------------------------------------------------------
83 continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
86 -> Continuation CmmInfo
88 continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
89 (Continuation info label formals _ blocks) =
90 CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False))
92 curr_format = maybe unknown_block id $ lookup label formats
93 unknown_block = panic "unknown BlockId in continuationToProc"
94 curr_stack = continuation_frame_size curr_format
95 arg_stack = argumentsSize localRegRep formals
97 param_stmts :: [CmmStmt]
98 param_stmts = function_entry curr_format
100 gc_stmts :: [CmmStmt]
102 assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
104 update_stmts :: [CmmStmt]
107 CmmInfo _ (Just (UpdateFrame target args)) _ ->
108 pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
109 adjust_sp_reg (curr_stack - update_frame_size)
110 CmmInfo _ Nothing _ -> []
112 continuationToProc' :: [[Unique]]
116 continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
117 prefix_blocks ++ [BasicBlock ident fixed_main_stmts] ++ concat new_blocks
122 (BlockId prefix_unique)
123 (param_stmts ++ [CmmBranch ident])]
126 (prefix_unique : call_uniques) : new_block_uniques = uniques
127 toCLabel = mkReturnPtLabel . getUnique
129 block_for_branch :: Unique -> BlockId -> (BlockId, [CmmBasicBlock])
130 block_for_branch unique next
131 -- branches to the current function don't have to jump
132 | (mkReturnPtLabel $ getUnique next) == label
135 -- branches to any other function have to jump
136 | (Just cont_format) <- lookup (toCLabel next) formats
138 new_next = BlockId unique
139 cont_stack = continuation_frame_size cont_format
140 arguments = map formal_to_actual (continuation_formals cont_format)
142 [BasicBlock new_next $
143 pack_continuation curr_format cont_format ++
144 tail_call (curr_stack - cont_stack)
145 (CmmLit $ CmmLabel $ toCLabel next)
148 -- branches to blocks in the current function don't have to jump
152 -- Wrapper for block_for_branch for when the target
153 -- is inside a 'Maybe'.
154 block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
155 block_for_branch' _ Nothing = (Nothing, [])
156 block_for_branch' unique (Just next) = (Just new_next, new_blocks)
157 where (new_next, new_blocks) = block_for_branch unique next
159 -- If the target of a switch, branch or cond branch becomes a proc point
160 -- then we have to make a new block what will then *jump* to the original target.
161 proc_point_fix unique (CmmCondBranch test target)
162 = (CmmCondBranch test new_target, new_blocks)
163 where (new_target, new_blocks) = block_for_branch (head unique) target
164 proc_point_fix unique (CmmSwitch test targets)
165 = (CmmSwitch test new_targets, concat new_blocks)
166 where (new_targets, new_blocks) =
167 unzip $ zipWith block_for_branch' unique targets
168 proc_point_fix unique (CmmBranch target)
169 = (CmmBranch new_target, new_blocks)
170 where (new_target, new_blocks) = block_for_branch (head unique) target
171 proc_point_fix _ other = (other, [])
173 (fixed_main_stmts, new_blocks) = unzip $ zipWith proc_point_fix new_block_uniques main_stmts
176 FunctionEntry _ _ _ ->
177 -- Ugh, the statements for an update frame must come
178 -- *after* the GC check that was added at the beginning
179 -- of the CPS pass. So we have do edit the statements
180 -- a bit. This depends on the knowledge that the
181 -- statements in the first block are only the GC check.
182 -- That's fragile but it works for now.
183 gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts
184 ControlEntry -> stmts ++ postfix_stmts
185 ContinuationEntry _ _ _ -> stmts ++ postfix_stmts
186 postfix_stmts = case exit of
187 -- Branches and switches may get modified by proc_point_fix
188 FinalBranch next -> [CmmBranch next]
189 FinalSwitch expr targets -> [CmmSwitch expr targets]
191 -- A return is a tail call to the stack top
192 FinalReturn arguments ->
194 (entryCode (CmmLoad (CmmReg spReg) wordRep))
198 FinalJump target arguments ->
199 tail_call curr_stack target arguments
201 -- A regular Cmm function call
202 FinalCall next (CmmForeignCall target CmmCallConv)
203 results arguments _ _ ->
204 pack_continuation curr_format cont_format ++
205 tail_call (curr_stack - cont_stack)
208 cont_format = maybe unknown_block id $
209 lookup (mkReturnPtLabel $ getUnique next) formats
210 cont_stack = continuation_frame_size cont_format
212 -- A safe foreign call
213 FinalCall next (CmmForeignCall target conv)
214 results arguments _ _ ->
216 foreignCall call_uniques' (CmmForeignCall new_target conv)
219 (call_uniques', target_stmts, new_target) =
220 maybeAssignTemp call_uniques target
223 FinalCall next (CmmPrim target)
224 results arguments _ _ ->
225 foreignCall call_uniques (CmmPrim target)
228 formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint)
230 foreignCall :: [Unique] -> CmmCallTarget -> CmmHintFormals -> CmmActuals -> [CmmStmt]
231 foreignCall uniques call results arguments =
235 [CmmCall (CmmForeignCall suspendThread CCallConv)
237 [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
239 CmmCall call results new_args CmmUnsafe,
240 CmmCall (CmmForeignCall resumeThread CCallConv)
241 [ (new_base, PtrHint) ]
242 [ (CmmReg (CmmLocal id), PtrHint) ]
244 -- Assign the result to BaseReg: we
245 -- might now have a different Capability!
246 CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
248 loadThreadState tso_unique ++
249 [CmmJump (CmmReg spReg) (map (formal_to_actual . fst) results)]
251 (_, arg_stmts, new_args) =
252 loadArgsIntoTemps argument_uniques arguments
253 (caller_save, caller_load) =
254 callerSaveVolatileRegs (Just [{-only system regs-}])
255 new_base = LocalReg base_unique (cmmRegRep (CmmGlobal BaseReg)) KindNonPtr
256 id = LocalReg id_unique wordRep KindNonPtr
257 tso_unique : base_unique : id_unique : argument_uniques = uniques
259 -- -----------------------------------------------------------------------------
260 -- Save/restore the thread state in the TSO
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.
269 -- CurrentTSO->sp = Sp;
270 [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
272 -- and save the current cost centre stack in the TSO when profiling:
273 if opt_SccProfilingOn
274 then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
277 -- CurrentNursery->free = Hp+1;
278 closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
280 loadThreadState tso_unique =
283 CmmAssign (CmmLocal tso) stgCurrentTSO,
285 CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
287 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
288 CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
289 rESERVED_STACK_WORDS)
292 -- and load the current cost centre stack from the TSO when profiling:
293 if opt_SccProfilingOn
294 then [CmmStore curCCSAddr
295 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep)]
297 where tso = LocalReg tso_unique wordRep KindNonPtr -- TODO FIXME NOW
301 -- Hp = CurrentNursery->free - 1;
302 CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
304 -- HpLim = CurrentNursery->start +
305 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
308 (CmmLoad nursery_bdescr_start wordRep)
310 (CmmMachOp mo_wordMul [
311 CmmMachOp (MO_S_Conv I32 wordRep)
312 [CmmLoad nursery_bdescr_blocks I32],
313 CmmLit (mkIntCLit bLOCK_SIZE)
321 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
322 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
323 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
325 tso_SP = tsoFieldB oFFSET_StgTSO_sp
326 tso_STACK = tsoFieldB oFFSET_StgTSO_stack
327 tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
329 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
330 -- the middle. The fields we're interested in are after the StgTSOProfInfo.
331 tsoFieldB :: ByteOff -> ByteOff
333 | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
334 | otherwise = off + fixedHdrSize * wORD_SIZE
336 tsoProfFieldB :: ByteOff -> ByteOff
337 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
341 stgCurrentTSO = CmmReg currentTSO
342 stgCurrentNursery = CmmReg currentNursery
345 spLim = CmmGlobal SpLim
347 hpLim = CmmGlobal HpLim
348 currentTSO = CmmGlobal CurrentTSO
349 currentNursery = CmmGlobal CurrentNursery
351 -----------------------------------------------------------------------------
352 -- Functions that generate CmmStmt sequences
353 -- for packing/unpacking continuations
354 -- and entering/exiting functions
356 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
357 tail_call spRel target arguments
358 = store_arguments ++ adjust_sp_reg spRel ++ jump where
360 [stack_put spRel expr offset
361 | ((expr, _), StackParam offset) <- argument_formats] ++
362 [global_put expr global
363 | ((expr, _), RegisterParam global) <- argument_formats]
364 jump = [CmmJump target arguments]
366 argument_formats = assignArguments (cmmExprRep . fst) arguments
368 adjust_sp_reg spRel =
371 else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
373 assign_gc_stack_use stack_use arg_stack max_frame_size =
374 if max_frame_size > arg_stack
375 then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
376 else [CmmAssign stack_use (CmmReg spLimReg)]
377 -- Trick the optimizer into eliminating the branch for us
379 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
380 gc_stack_check gc_block max_frame_size
381 = check_stack_limit where
382 check_stack_limit = [
384 (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
385 [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
390 pack_continuation :: ContinuationFormat -- ^ The current format
391 -> ContinuationFormat -- ^ The return point format
393 pack_continuation (ContinuationFormat _ curr_id curr_frame_size _)
394 (ContinuationFormat _ cont_id cont_frame_size live_regs)
395 = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
397 continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal))
400 case (curr_id, cont_id) of
401 (Just x, Just y) -> x /= y
404 maybe_header = if needs_header_set
405 then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id
408 pack_frame :: WordOff -- ^ Current frame size
409 -> WordOff -- ^ Next frame size
410 -> Maybe CmmExpr -- ^ Next frame header if any
411 -> [Maybe CmmExpr] -- ^ Next frame data
413 pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
414 store_live_values ++ set_stack_header
416 -- TODO: only save variables when actually needed
417 -- (may be handled by latter pass)
419 [stack_put spRel expr offset
420 | (expr, offset) <- cont_offsets]
422 case next_frame_header of
424 Just expr -> [stack_put spRel expr 0]
426 -- TODO: factor with function_entry and CmmInfo.hs(?)
427 cont_offsets = mkOffsets label_size frame_args
429 label_size = 1 :: WordOff
431 mkOffsets size [] = []
432 mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
433 mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
435 width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE
436 -- TODO: it would be better if we had a machRepWordWidth
438 spRel = curr_frame_size - next_frame_size
441 -- Lazy adjustment of stack headers assumes all blocks
442 -- that could branch to eachother (i.e. control blocks)
443 -- have the same stack format (this causes a problem
444 -- only for proc-point).
445 function_entry :: ContinuationFormat -> [CmmStmt]
446 function_entry (ContinuationFormat formals _ _ live_regs)
447 = load_live_values ++ load_args where
448 -- TODO: only save variables when actually needed
449 -- (may be handled by latter pass)
451 [stack_get 0 reg offset
452 | (reg, offset) <- curr_offsets]
454 [stack_get 0 reg offset
455 | (reg, StackParam offset) <- argument_formats] ++
456 [global_get reg global
457 | (reg, RegisterParam global) <- argument_formats]
459 argument_formats = assignArguments (localRegRep) formals
461 -- TODO: eliminate copy/paste with pack_continuation
462 curr_offsets = mkOffsets label_size live_regs
464 label_size = 1 :: WordOff
466 mkOffsets size [] = []
467 mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
468 mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
470 width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
471 -- TODO: it would be better if we had a machRepWordWidth
473 -----------------------------------------------------------------------------
474 -- Section: Stack and argument register puts and gets
475 -----------------------------------------------------------------------------
478 -- |Construct a 'CmmStmt' that will save a value on the stack
479 stack_put :: WordOff -- ^ Offset from the real 'Sp' that 'offset'
480 -- is relative to (added to offset)
481 -> CmmExpr -- ^ What to store onto the stack
482 -> WordOff -- ^ Where on the stack to store it
483 -- (positive <=> higher addresses)
485 stack_put spRel expr offset =
486 CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
488 --------------------------------
494 stack_get spRel reg offset =
495 CmmAssign (CmmLocal reg)
496 (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
498 global_put :: CmmExpr -> GlobalReg -> CmmStmt
499 global_put expr global = CmmAssign (CmmGlobal global) expr
500 global_get :: LocalReg -> GlobalReg -> CmmStmt
501 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))