Fix warnings in CmmCPSGen
[ghc.git] / compiler / cmm / CmmCPSGen.hs
1 module CmmCPSGen (
2 -- | Converts continuations into full proceedures.
3 -- The main work of the CPS transform that everything else is setting-up.
4 continuationToProc,
5 Continuation(..), continuationLabel,
6 ContinuationFormat(..),
7 ) where
8
9 import BlockId
10 import Cmm
11 import CLabel
12 import CmmBrokenBlock -- Data types only
13 import CmmUtils
14 import CmmCallConv
15 import ClosureInfo
16
17 import CgProf
18 import CgUtils
19 import CgInfoTbls
20 import SMRep
21 import ForeignCall
22
23 import Constants
24 import StaticFlags
25 import Unique
26 import Maybe
27 import List
28 import FastString
29
30 import Panic
31
32 -- The format for the call to a continuation
33 -- The fst is the arguments that must be passed to the continuation
34 -- by the continuation's caller.
35 -- The snd is the live values that must be saved on stack.
36 -- A Nothing indicates an ignored slot.
37 -- The head of each list is the stack top or the first parameter.
38
39 -- The format for live values for a particular continuation
40 -- All on stack for now.
41 -- Head element is the top of the stack (or just under the header).
42 -- Nothing means an empty slot.
43 -- Future possibilities include callee save registers (i.e. passing slots in register)
44 -- and heap memory (not sure if that's usefull at all though, but it may
45 -- be worth exploring the design space).
46
47 continuationLabel :: Continuation (Either C_SRT CmmInfo) -> CLabel
48 continuationLabel (Continuation _ l _ _ _) = l
49 data Continuation info =
50 Continuation
51 info -- Left <=> Continuation created by the CPS
52 -- Right <=> Function or Proc point
53 CLabel -- Used to generate both info & entry labels
54 CmmFormals -- Argument locals live on entry (C-- procedure params)
55 Bool -- True <=> GC block so ignore stack size
56 [BrokenBlock] -- Code, may be empty. The first block is
57 -- the entry point. The order is otherwise initially
58 -- unimportant, but at some point the code gen will
59 -- fix the order.
60
61 -- the BlockId of the first block does not give rise
62 -- to a label. To jump to the first block in a Proc,
63 -- use the appropriate CLabel.
64
65 data ContinuationFormat
66 = ContinuationFormat {
67 continuation_formals :: CmmFormals,
68 continuation_label :: Maybe CLabel, -- The label occupying the top slot
69 continuation_frame_size :: WordOff, -- Total frame size in words (not including arguments)
70 continuation_stack :: [Maybe LocalReg] -- local reg offsets from stack top
71 }
72
73 -- A block can be a continuation of a call
74 -- A block can be a continuation of another block (w/ or w/o joins)
75 -- A block can be an entry to a function
76
77 -----------------------------------------------------------------------------
78 continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
79 -> CmmReg
80 -> [[[Unique]]]
81 -> Continuation CmmInfo
82 -> CmmTop
83 continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
84 (Continuation info label formals _ blocks) =
85 CmmProc info label formals (ListGraph blocks')
86 where
87 blocks' = concat $ zipWith3 continuationToProc' uniques blocks
88 (True : repeat False)
89 curr_format = maybe unknown_block id $ lookup label formats
90 unknown_block = panic "unknown BlockId in continuationToProc"
91 curr_stack = continuation_frame_size curr_format
92 arg_stack = argumentsSize localRegType formals
93
94 param_stmts :: [CmmStmt]
95 param_stmts = function_entry curr_format
96
97 gc_stmts :: [CmmStmt]
98 gc_stmts =
99 assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
100
101 update_stmts :: [CmmStmt]
102 update_stmts =
103 case info of
104 CmmInfo _ (Just (UpdateFrame target args)) _ ->
105 pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
106 adjust_sp_reg (curr_stack - update_frame_size)
107 CmmInfo _ Nothing _ -> []
108
109 continuationToProc' :: [[Unique]]
110 -> BrokenBlock
111 -> Bool
112 -> [CmmBasicBlock]
113 continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
114 prefix_blocks ++ [BasicBlock ident fixed_main_stmts] ++ concat new_blocks
115 where
116 prefix_blocks =
117 if is_entry
118 then [BasicBlock
119 (BlockId prefix_unique)
120 (param_stmts ++ [CmmBranch ident])]
121 else []
122
123 (prefix_unique : call_uniques) : new_block_uniques = uniques
124 toCLabel = mkReturnPtLabel . getUnique
125
126 block_for_branch :: Unique -> BlockId -> (BlockId, [CmmBasicBlock])
127 block_for_branch unique next
128 -- branches to the current function don't have to jump
129 | (mkReturnPtLabel $ getUnique next) == label
130 = (next, [])
131
132 -- branches to any other function have to jump
133 | (Just cont_format) <- lookup (toCLabel next) formats
134 = let
135 new_next = BlockId unique
136 cont_stack = continuation_frame_size cont_format
137 arguments = map formal_to_actual (continuation_formals cont_format)
138 in (new_next,
139 [BasicBlock new_next $
140 pack_continuation curr_format cont_format ++
141 tail_call (curr_stack - cont_stack)
142 (CmmLit $ CmmLabel $ toCLabel next)
143 arguments])
144
145 -- branches to blocks in the current function don't have to jump
146 | otherwise
147 = (next, [])
148
149 -- Wrapper for block_for_branch for when the target
150 -- is inside a 'Maybe'.
151 block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
152 block_for_branch' _ Nothing = (Nothing, [])
153 block_for_branch' unique (Just next) = (Just new_next, new_blocks)
154 where (new_next, new_blocks) = block_for_branch unique next
155
156 -- If the target of a switch, branch or cond branch becomes a proc point
157 -- then we have to make a new block what will then *jump* to the original target.
158 proc_point_fix unique (CmmCondBranch test target)
159 = (CmmCondBranch test new_target, new_blocks)
160 where (new_target, new_blocks) = block_for_branch (head unique) target
161 proc_point_fix unique (CmmSwitch test targets)
162 = (CmmSwitch test new_targets, concat new_blocks)
163 where (new_targets, new_blocks) =
164 unzip $ zipWith block_for_branch' unique targets
165 proc_point_fix unique (CmmBranch target)
166 = (CmmBranch new_target, new_blocks)
167 where (new_target, new_blocks) = block_for_branch (head unique) target
168 proc_point_fix _ other = (other, [])
169
170 (fixed_main_stmts, new_blocks) = unzip $ zipWith proc_point_fix new_block_uniques main_stmts
171 main_stmts =
172 case entry of
173 FunctionEntry _ _ _ ->
174 -- The statements for an update frame must come /after/
175 -- the GC check that was added at the beginning of the
176 -- CPS pass. So we have do edit the statements a bit.
177 -- This depends on the knowledge that the statements in
178 -- the first block are only the GC check. That's
179 -- fragile but it works for now.
180 gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts
181 ControlEntry -> stmts ++ postfix_stmts
182 ContinuationEntry _ _ _ -> stmts ++ postfix_stmts
183 postfix_stmts = case exit of
184 -- Branches and switches may get modified by proc_point_fix
185 FinalBranch next -> [CmmBranch next]
186 FinalSwitch expr targets -> [CmmSwitch expr targets]
187
188 -- A return is a tail call to the stack top
189 FinalReturn arguments ->
190 tail_call curr_stack
191 (entryCode (CmmLoad (CmmReg spReg) bWord))
192 arguments
193
194 -- A tail call
195 FinalJump target arguments ->
196 tail_call curr_stack target arguments
197
198 -- A regular Cmm function call
199 FinalCall next (CmmCallee target CmmCallConv)
200 _ arguments _ _ _ ->
201 pack_continuation curr_format cont_format ++
202 tail_call (curr_stack - cont_stack)
203 target arguments
204 where
205 cont_format = maybe unknown_block id $
206 lookup (mkReturnPtLabel $ getUnique next) formats
207 cont_stack = continuation_frame_size cont_format
208
209 -- A safe foreign call
210 FinalCall _ (CmmCallee target conv)
211 results arguments _ _ _ ->
212 target_stmts ++
213 foreignCall call_uniques' (CmmCallee new_target conv)
214 results arguments
215 where
216 (call_uniques', target_stmts, new_target) =
217 maybeAssignTemp call_uniques target
218
219 -- A safe prim call
220 FinalCall _ (CmmPrim target)
221 results arguments _ _ _ ->
222 foreignCall call_uniques (CmmPrim target)
223 results arguments
224
225 formal_to_actual :: LocalReg -> CmmHinted CmmExpr
226 formal_to_actual reg = CmmHinted (CmmReg (CmmLocal reg)) NoHint
227
228 foreignCall :: [Unique] -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> [CmmStmt]
229 foreignCall uniques call results arguments =
230 arg_stmts ++
231 saveThreadState ++
232 caller_save ++
233 [CmmCall (CmmCallee suspendThread CCallConv)
234 [ CmmHinted id AddrHint ]
235 [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ]
236 CmmUnsafe
237 CmmMayReturn,
238 CmmCall call results new_args CmmUnsafe CmmMayReturn,
239 CmmCall (CmmCallee resumeThread CCallConv)
240 [ CmmHinted new_base AddrHint ]
241 [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
242 CmmUnsafe
243 CmmMayReturn,
244 -- Assign the result to BaseReg: we
245 -- might now have a different Capability!
246 CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
247 caller_load ++
248 loadThreadState tso_unique ++
249 [CmmJump (CmmReg spReg) (map (formal_to_actual . hintlessCmm) results)]
250 where
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 (cmmRegType (CmmGlobal BaseReg))
256 id = LocalReg id_unique bWord
257 tso_unique : base_unique : id_unique : argument_uniques = uniques
258
259 -- -----------------------------------------------------------------------------
260 -- Save/restore the thread state in the TSO
261
262 suspendThread, resumeThread :: CmmExpr
263 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread")))
264 resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread")))
265
266 -- This stuff can't be done in suspendThread/resumeThread, because it
267 -- refers to global registers which aren't available in the C world.
268
269 saveThreadState :: [CmmStmt]
270 saveThreadState =
271 -- CurrentTSO->sp = Sp;
272 [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
273 closeNursery] ++
274 -- and save the current cost centre stack in the TSO when profiling:
275 if opt_SccProfilingOn
276 then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
277 else []
278
279 -- CurrentNursery->free = Hp+1;
280 closeNursery :: CmmStmt
281 closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
282
283 loadThreadState :: Unique -> [CmmStmt]
284 loadThreadState tso_unique =
285 [
286 -- tso = CurrentTSO;
287 CmmAssign (CmmLocal tso) stgCurrentTSO,
288 -- Sp = tso->sp;
289 CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
290 bWord),
291 -- SpLim = tso->stack + RESERVED_STACK_WORDS;
292 CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
293 rESERVED_STACK_WORDS)
294 ] ++
295 openNursery ++
296 -- and load the current cost centre stack from the TSO when profiling:
297 if opt_SccProfilingOn
298 then [CmmStore curCCSAddr
299 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord)]
300 else []
301 where tso = LocalReg tso_unique bWord -- TODO FIXME NOW
302
303
304 openNursery :: [CmmStmt]
305 openNursery = [
306 -- Hp = CurrentNursery->free - 1;
307 CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
308
309 -- HpLim = CurrentNursery->start +
310 -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
311 CmmAssign hpLim
312 (cmmOffsetExpr
313 (CmmLoad nursery_bdescr_start bWord)
314 (cmmOffset
315 (CmmMachOp mo_wordMul [
316 CmmMachOp (MO_SS_Conv W32 wordWidth)
317 [CmmLoad nursery_bdescr_blocks b32],
318 CmmLit (mkIntCLit bLOCK_SIZE)
319 ])
320 (-1)
321 )
322 )
323 ]
324
325
326 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
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
330
331 tso_SP, tso_STACK, tso_CCCS :: ByteOff
332 tso_SP = tsoFieldB oFFSET_StgTSO_sp
333 tso_STACK = tsoFieldB oFFSET_StgTSO_stack
334 tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
335
336 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
337 -- the middle. The fields we're interested in are after the StgTSOProfInfo.
338 tsoFieldB :: ByteOff -> ByteOff
339 tsoFieldB off
340 | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
341 | otherwise = off + fixedHdrSize * wORD_SIZE
342
343 tsoProfFieldB :: ByteOff -> ByteOff
344 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
345
346 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
347 stgSp = CmmReg sp
348 stgHp = CmmReg hp
349 stgCurrentTSO = CmmReg currentTSO
350 stgCurrentNursery = CmmReg currentNursery
351
352 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
353 sp = CmmGlobal Sp
354 spLim = CmmGlobal SpLim
355 hp = CmmGlobal Hp
356 hpLim = CmmGlobal HpLim
357 currentTSO = CmmGlobal CurrentTSO
358 currentNursery = CmmGlobal CurrentNursery
359
360 -----------------------------------------------------------------------------
361 -- Functions that generate CmmStmt sequences
362 -- for packing/unpacking continuations
363 -- and entering/exiting functions
364
365 tail_call :: WordOff -> CmmExpr -> HintedCmmActuals -> [CmmStmt]
366 tail_call spRel target arguments
367 = store_arguments ++ adjust_sp_reg spRel ++ jump where
368 store_arguments =
369 [stack_put spRel expr offset
370 | ((CmmHinted expr _), StackParam offset) <- argument_formats] ++
371 [global_put expr global
372 | ((CmmHinted expr _), RegisterParam global) <- argument_formats]
373 jump = [CmmJump target arguments]
374
375 argument_formats = assignArguments (cmmExprType . hintlessCmm) arguments
376
377 adjust_sp_reg :: Int -> [CmmStmt]
378 adjust_sp_reg spRel =
379 if spRel == 0
380 then []
381 else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
382
383 assign_gc_stack_use :: CmmReg -> Int -> Int -> [CmmStmt]
384 assign_gc_stack_use stack_use arg_stack max_frame_size =
385 if max_frame_size > arg_stack
386 then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
387 else [CmmAssign stack_use (CmmReg spLimReg)]
388 -- Trick the optimizer into eliminating the branch for us
389
390 {-
391 UNUSED 2008-12-29
392
393 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
394 gc_stack_check gc_block max_frame_size
395 = check_stack_limit where
396 check_stack_limit = [
397 CmmCondBranch
398 (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg)))
399 [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
400 CmmReg spLimReg])
401 gc_block]
402 -}
403
404 pack_continuation :: ContinuationFormat -- ^ The current format
405 -> ContinuationFormat -- ^ The return point format
406 -> [CmmStmt]
407 pack_continuation (ContinuationFormat _ curr_id curr_frame_size _)
408 (ContinuationFormat _ cont_id cont_frame_size live_regs)
409 = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
410 where
411 continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal))
412 live_regs
413 needs_header_set =
414 case (curr_id, cont_id) of
415 (Just x, Just y) -> x /= y
416 _ -> isJust cont_id
417
418 maybe_header = if needs_header_set
419 then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id
420 else Nothing
421
422 pack_frame :: WordOff -- ^ Current frame size
423 -> WordOff -- ^ Next frame size
424 -> Maybe CmmExpr -- ^ Next frame header if any
425 -> [Maybe CmmExpr] -- ^ Next frame data
426 -> [CmmStmt]
427 pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
428 store_live_values ++ set_stack_header
429 where
430 -- TODO: only save variables when actually needed
431 -- (may be handled by latter pass)
432 store_live_values =
433 [stack_put spRel expr offset
434 | (expr, offset) <- cont_offsets]
435 set_stack_header =
436 case next_frame_header of
437 Nothing -> []
438 Just expr -> [stack_put spRel expr 0]
439
440 -- TODO: factor with function_entry and CmmInfo.hs(?)
441 cont_offsets = mkOffsets label_size frame_args
442
443 label_size = 1 :: WordOff
444
445 mkOffsets _ [] = []
446 mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
447 mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
448 where
449 width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE
450 -- TODO: it would be better if we had a machRepWordWidth
451
452 spRel = curr_frame_size - next_frame_size
453
454
455 -- Lazy adjustment of stack headers assumes all blocks
456 -- that could branch to eachother (i.e. control blocks)
457 -- have the same stack format (this causes a problem
458 -- only for proc-point).
459 function_entry :: ContinuationFormat -> [CmmStmt]
460 function_entry (ContinuationFormat formals _ _ live_regs)
461 = load_live_values ++ load_args where
462 -- TODO: only save variables when actually needed
463 -- (may be handled by latter pass)
464 load_live_values =
465 [stack_get 0 reg offset
466 | (reg, offset) <- curr_offsets]
467 load_args =
468 [stack_get 0 reg offset
469 | (reg, StackParam offset) <- argument_formats] ++
470 [global_get reg global
471 | (reg, RegisterParam global) <- argument_formats]
472
473 argument_formats = assignArguments (localRegType) formals
474
475 -- TODO: eliminate copy/paste with pack_continuation
476 curr_offsets = mkOffsets label_size live_regs
477
478 label_size = 1 :: WordOff
479
480 mkOffsets _ [] = []
481 mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
482 mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
483 where
484 width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE
485 -- TODO: it would be better if we had a machRepWordWidth
486
487 -----------------------------------------------------------------------------
488 -- Section: Stack and argument register puts and gets
489 -----------------------------------------------------------------------------
490 -- TODO: document
491
492 -- |Construct a 'CmmStmt' that will save a value on the stack
493 stack_put :: WordOff -- ^ Offset from the real 'Sp' that 'offset'
494 -- is relative to (added to offset)
495 -> CmmExpr -- ^ What to store onto the stack
496 -> WordOff -- ^ Where on the stack to store it
497 -- (positive <=> higher addresses)
498 -> CmmStmt
499 stack_put spRel expr offset =
500 CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
501
502 --------------------------------
503 -- |Construct a
504 stack_get :: WordOff
505 -> LocalReg
506 -> WordOff
507 -> CmmStmt
508 stack_get spRel reg offset =
509 CmmAssign (CmmLocal reg)
510 (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
511 (localRegType reg))
512 global_put :: CmmExpr -> GlobalReg -> CmmStmt
513 global_put expr global = CmmAssign (CmmGlobal global) expr
514 global_get :: LocalReg -> GlobalReg -> CmmStmt
515 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))