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