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