2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
9 -- | Converts continuations into full proceedures.
10 -- The main work of the CPS transform that everything else is setting-up.
12 Continuation(..), continuationLabel,
13 ContinuationFormat(..),
16 #include "HsVersions.h"
20 import CmmBrokenBlock -- Data types only
40 -- The format for the call to a continuation
41 -- The fst is the arguments that must be passed to the continuation
42 -- by the continuation's caller.
43 -- The snd is the live values that must be saved on stack.
44 -- A Nothing indicates an ignored slot.
45 -- The head of each list is the stack top or the first parameter.
47 -- The format for live values for a particular continuation
48 -- All on stack for now.
49 -- Head element is the top of the stack (or just under the header).
50 -- Nothing means an empty slot.
51 -- Future possibilities include callee save registers (i.e. passing slots in register)
52 -- and heap memory (not sure if that's usefull at all though, but it may
53 -- be worth exploring the design space).
55 continuationLabel (Continuation _ l _ _ _) = l
56 data Continuation info =
58 info -- Left <=> Continuation created by the CPS
59 -- Right <=> Function or Proc point
60 CLabel -- Used to generate both info & entry labels
61 CmmFormalsWithoutKinds -- Argument locals live on entry (C-- procedure params)
62 Bool -- ^ True <=> GC block so ignore stack size
63 [BrokenBlock] -- Code, may be empty. The first block is
64 -- the entry point. The order is otherwise initially
65 -- unimportant, but at some point the code gen will
68 -- the BlockId of the first block does not give rise
69 -- to a label. To jump to the first block in a Proc,
70 -- use the appropriate CLabel.
72 data ContinuationFormat
73 = ContinuationFormat {
74 continuation_formals :: CmmFormalsWithoutKinds,
75 continuation_label :: Maybe CLabel, -- The label occupying the top slot
76 continuation_frame_size :: WordOff, -- Total frame size in words (not including arguments)
77 continuation_stack :: [Maybe LocalReg] -- local reg offsets from stack top
80 -- A block can be a continuation of a call
81 -- A block can be a continuation of another block (w/ or w/o joins)
82 -- A block can be an entry to a function
84 -----------------------------------------------------------------------------
85 continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
88 -> Continuation CmmInfo
90 continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
91 (Continuation info label formals _ blocks) =
92 CmmProc info label formals (ListGraph blocks')
94 blocks' = concat $ zipWith3 continuationToProc' uniques blocks
96 curr_format = maybe unknown_block id $ lookup label formats
97 unknown_block = panic "unknown BlockId in continuationToProc"
98 curr_stack = continuation_frame_size curr_format
99 arg_stack = argumentsSize localRegRep formals
101 param_stmts :: [CmmStmt]
102 param_stmts = function_entry curr_format
104 gc_stmts :: [CmmStmt]
106 assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
108 update_stmts :: [CmmStmt]
111 CmmInfo _ (Just (UpdateFrame target args)) _ ->
112 pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
113 adjust_sp_reg (curr_stack - update_frame_size)
114 CmmInfo _ Nothing _ -> []
116 continuationToProc' :: [[Unique]]
120 continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
121 prefix_blocks ++ [BasicBlock ident fixed_main_stmts] ++ concat new_blocks
126 (BlockId prefix_unique)
127 (param_stmts ++ [CmmBranch ident])]
130 (prefix_unique : call_uniques) : new_block_uniques = uniques
131 toCLabel = mkReturnPtLabel . getUnique
133 block_for_branch :: Unique -> BlockId -> (BlockId, [CmmBasicBlock])
134 block_for_branch unique next
135 -- branches to the current function don't have to jump
136 | (mkReturnPtLabel $ getUnique next) == label
139 -- branches to any other function have to jump
140 | (Just cont_format) <- lookup (toCLabel next) formats
142 new_next = BlockId unique
143 cont_stack = continuation_frame_size cont_format
144 arguments = map formal_to_actual (continuation_formals cont_format)
146 [BasicBlock new_next $
147 pack_continuation curr_format cont_format ++
148 tail_call (curr_stack - cont_stack)
149 (CmmLit $ CmmLabel $ toCLabel next)
152 -- branches to blocks in the current function don't have to jump
156 -- Wrapper for block_for_branch for when the target
157 -- is inside a 'Maybe'.
158 block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
159 block_for_branch' _ Nothing = (Nothing, [])
160 block_for_branch' unique (Just next) = (Just new_next, new_blocks)
161 where (new_next, new_blocks) = block_for_branch unique next
163 -- If the target of a switch, branch or cond branch becomes a proc point
164 -- then we have to make a new block what will then *jump* to the original target.
165 proc_point_fix unique (CmmCondBranch test target)
166 = (CmmCondBranch test new_target, new_blocks)
167 where (new_target, new_blocks) = block_for_branch (head unique) target
168 proc_point_fix unique (CmmSwitch test targets)
169 = (CmmSwitch test new_targets, concat new_blocks)
170 where (new_targets, new_blocks) =
171 unzip $ zipWith block_for_branch' unique targets
172 proc_point_fix unique (CmmBranch target)
173 = (CmmBranch new_target, new_blocks)
174 where (new_target, new_blocks) = block_for_branch (head unique) target
175 proc_point_fix _ other = (other, [])
177 (fixed_main_stmts, new_blocks) = unzip $ zipWith proc_point_fix new_block_uniques main_stmts
180 FunctionEntry _ _ _ ->
181 -- Ugh, the statements for an update frame must come
182 -- *after* the GC check that was added at the beginning
183 -- of the CPS pass. So we have do edit the statements
184 -- a bit. This depends on the knowledge that the
185 -- statements in the first block are only the GC check.
186 -- That's fragile but it works for now.
187 gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts
188 ControlEntry -> stmts ++ postfix_stmts
189 ContinuationEntry _ _ _ -> stmts ++ postfix_stmts
190 postfix_stmts = case exit of
191 -- Branches and switches may get modified by proc_point_fix
192 FinalBranch next -> [CmmBranch next]
193 FinalSwitch expr targets -> [CmmSwitch expr targets]
195 -- A return is a tail call to the stack top
196 FinalReturn arguments ->
198 (entryCode (CmmLoad (CmmReg spReg) wordRep))
202 FinalJump target arguments ->
203 tail_call curr_stack target arguments
205 -- A regular Cmm function call
206 FinalCall next (CmmCallee target CmmCallConv)
207 results arguments _ _ _ ->
208 pack_continuation curr_format cont_format ++
209 tail_call (curr_stack - cont_stack)
212 cont_format = maybe unknown_block id $
213 lookup (mkReturnPtLabel $ getUnique next) formats
214 cont_stack = continuation_frame_size cont_format
216 -- A safe foreign call
217 FinalCall next (CmmCallee target conv)
218 results arguments _ _ _ ->
220 foreignCall call_uniques' (CmmCallee new_target conv)
223 (call_uniques', target_stmts, new_target) =
224 maybeAssignTemp call_uniques target
227 FinalCall next (CmmPrim target)
228 results arguments _ _ _ ->
229 foreignCall call_uniques (CmmPrim target)
232 formal_to_actual reg = CmmHinted (CmmReg (CmmLocal reg)) NoHint
234 foreignCall :: [Unique] -> CmmCallTarget -> CmmFormals -> CmmActuals -> [CmmStmt]
235 foreignCall uniques call results arguments =
239 [CmmCall (CmmCallee suspendThread CCallConv)
240 [ CmmHinted id PtrHint ]
241 [ CmmHinted (CmmReg (CmmGlobal BaseReg)) PtrHint ]
244 CmmCall call results new_args CmmUnsafe CmmMayReturn,
245 CmmCall (CmmCallee resumeThread CCallConv)
246 [ CmmHinted new_base PtrHint ]
247 [ CmmHinted (CmmReg (CmmLocal id)) PtrHint ]
250 -- Assign the result to BaseReg: we
251 -- might now have a different Capability!
252 CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
254 loadThreadState tso_unique ++
255 [CmmJump (CmmReg spReg) (map (formal_to_actual . hintlessCmm) results)]
257 (_, arg_stmts, new_args) =
258 loadArgsIntoTemps argument_uniques arguments
259 (caller_save, caller_load) =
260 callerSaveVolatileRegs (Just [{-only system regs-}])
261 new_base = LocalReg base_unique (cmmRegRep (CmmGlobal BaseReg)) GCKindNonPtr
262 id = LocalReg id_unique wordRep GCKindNonPtr
263 tso_unique : base_unique : id_unique : argument_uniques = uniques
265 -- -----------------------------------------------------------------------------
266 -- Save/restore the thread state in the TSO
268 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
269 resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
271 -- This stuff can't be done in suspendThread/resumeThread, because it
272 -- refers to global registers which aren't available in the C world.
275 -- CurrentTSO->sp = Sp;
276 [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
278 -- and save the current cost centre stack in the TSO when profiling:
279 if opt_SccProfilingOn
280 then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
283 -- CurrentNursery->free = Hp+1;
284 closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
286 loadThreadState tso_unique =
289 CmmAssign (CmmLocal tso) stgCurrentTSO,
291 CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
293 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
294 CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
295 rESERVED_STACK_WORDS)
298 -- and load the current cost centre stack from the TSO when profiling:
299 if opt_SccProfilingOn
300 then [CmmStore curCCSAddr
301 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep)]
303 where tso = LocalReg tso_unique wordRep GCKindNonPtr -- TODO FIXME NOW
307 -- Hp = CurrentNursery->free - 1;
308 CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
310 -- HpLim = CurrentNursery->start +
311 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
314 (CmmLoad nursery_bdescr_start wordRep)
316 (CmmMachOp mo_wordMul [
317 CmmMachOp (MO_S_Conv I32 wordRep)
318 [CmmLoad nursery_bdescr_blocks I32],
319 CmmLit (mkIntCLit bLOCK_SIZE)
327 nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
328 nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
329 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
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
347 stgCurrentTSO = CmmReg currentTSO
348 stgCurrentNursery = CmmReg currentNursery
351 spLim = CmmGlobal SpLim
353 hpLim = CmmGlobal HpLim
354 currentTSO = CmmGlobal CurrentTSO
355 currentNursery = CmmGlobal CurrentNursery
357 -----------------------------------------------------------------------------
358 -- Functions that generate CmmStmt sequences
359 -- for packing/unpacking continuations
360 -- and entering/exiting functions
362 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
363 tail_call spRel target arguments
364 = store_arguments ++ adjust_sp_reg spRel ++ jump where
366 [stack_put spRel expr offset
367 | ((CmmHinted expr _), StackParam offset) <- argument_formats] ++
368 [global_put expr global
369 | ((CmmHinted expr _), RegisterParam global) <- argument_formats]
370 jump = [CmmJump target arguments]
372 argument_formats = assignArguments (cmmExprRep . hintlessCmm) arguments
374 adjust_sp_reg spRel =
377 else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
379 assign_gc_stack_use stack_use arg_stack max_frame_size =
380 if max_frame_size > arg_stack
381 then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
382 else [CmmAssign stack_use (CmmReg spLimReg)]
383 -- Trick the optimizer into eliminating the branch for us
385 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
386 gc_stack_check gc_block max_frame_size
387 = check_stack_limit where
388 check_stack_limit = [
390 (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
391 [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
396 pack_continuation :: ContinuationFormat -- ^ The current format
397 -> ContinuationFormat -- ^ The return point format
399 pack_continuation (ContinuationFormat _ curr_id curr_frame_size _)
400 (ContinuationFormat _ cont_id cont_frame_size live_regs)
401 = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
403 continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal))
406 case (curr_id, cont_id) of
407 (Just x, Just y) -> x /= y
410 maybe_header = if needs_header_set
411 then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id
414 pack_frame :: WordOff -- ^ Current frame size
415 -> WordOff -- ^ Next frame size
416 -> Maybe CmmExpr -- ^ Next frame header if any
417 -> [Maybe CmmExpr] -- ^ Next frame data
419 pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
420 store_live_values ++ set_stack_header
422 -- TODO: only save variables when actually needed
423 -- (may be handled by latter pass)
425 [stack_put spRel expr offset
426 | (expr, offset) <- cont_offsets]
428 case next_frame_header of
430 Just expr -> [stack_put spRel expr 0]
432 -- TODO: factor with function_entry and CmmInfo.hs(?)
433 cont_offsets = mkOffsets label_size frame_args
435 label_size = 1 :: WordOff
437 mkOffsets size [] = []
438 mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
439 mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
441 width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE
442 -- TODO: it would be better if we had a machRepWordWidth
444 spRel = curr_frame_size - next_frame_size
447 -- Lazy adjustment of stack headers assumes all blocks
448 -- that could branch to eachother (i.e. control blocks)
449 -- have the same stack format (this causes a problem
450 -- only for proc-point).
451 function_entry :: ContinuationFormat -> [CmmStmt]
452 function_entry (ContinuationFormat formals _ _ live_regs)
453 = load_live_values ++ load_args where
454 -- TODO: only save variables when actually needed
455 -- (may be handled by latter pass)
457 [stack_get 0 reg offset
458 | (reg, offset) <- curr_offsets]
460 [stack_get 0 reg offset
461 | (reg, StackParam offset) <- argument_formats] ++
462 [global_get reg global
463 | (reg, RegisterParam global) <- argument_formats]
465 argument_formats = assignArguments (localRegRep) formals
467 -- TODO: eliminate copy/paste with pack_continuation
468 curr_offsets = mkOffsets label_size live_regs
470 label_size = 1 :: WordOff
472 mkOffsets size [] = []
473 mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
474 mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
476 width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
477 -- TODO: it would be better if we had a machRepWordWidth
479 -----------------------------------------------------------------------------
480 -- Section: Stack and argument register puts and gets
481 -----------------------------------------------------------------------------
484 -- |Construct a 'CmmStmt' that will save a value on the stack
485 stack_put :: WordOff -- ^ Offset from the real 'Sp' that 'offset'
486 -- is relative to (added to offset)
487 -> CmmExpr -- ^ What to store onto the stack
488 -> WordOff -- ^ Where on the stack to store it
489 -- (positive <=> higher addresses)
491 stack_put spRel expr offset =
492 CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
494 --------------------------------
500 stack_get spRel reg offset =
501 CmmAssign (CmmLocal reg)
502 (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
504 global_put :: CmmExpr -> GlobalReg -> CmmStmt
505 global_put expr global = CmmAssign (CmmGlobal global) expr
506 global_get :: LocalReg -> GlobalReg -> CmmStmt
507 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))