(F)SLIT -> (f)sLit in CgCon
[ghc-hetmet.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 Cmm
17 import CLabel
18 import CmmBrokenBlock -- Data types only
19 import MachOp
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      CmmFormalsWithoutKinds        -- 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 :: CmmFormalsWithoutKinds,
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 localRegRep 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                       -- Ugh, the statements for an update frame must come
180                       -- *after* the GC check that was added at the beginning
181                       -- of the CPS pass.  So we have do edit the statements
182                       -- a bit.  This depends on the knowledge that the
183                       -- statements in the first block are only the GC check.
184                       -- That's 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) wordRep))
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 -> CmmFormals -> CmmActuals -> [CmmStmt]
233 foreignCall uniques call results arguments =
234     arg_stmts ++
235     saveThreadState ++
236     caller_save ++
237     [CmmCall (CmmCallee suspendThread CCallConv)
238                  [ CmmHinted id PtrHint ]
239                  [ CmmHinted (CmmReg (CmmGlobal BaseReg)) PtrHint ]
240                  CmmUnsafe
241                  CmmMayReturn,
242      CmmCall call results new_args CmmUnsafe CmmMayReturn,
243      CmmCall (CmmCallee resumeThread CCallConv)
244                  [ CmmHinted new_base PtrHint ]
245                  [ CmmHinted (CmmReg (CmmLocal id)) PtrHint ]
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 (cmmRegRep (CmmGlobal BaseReg)) GCKindNonPtr
260       id = LocalReg id_unique wordRep GCKindNonPtr
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                               wordRep),
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) wordRep)]
300   else []
301   where tso = LocalReg tso_unique wordRep GCKindNonPtr -- TODO FIXME NOW
302
303
304 openNursery = [
305         -- Hp = CurrentNursery->free - 1;
306         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
307
308         -- HpLim = CurrentNursery->start + 
309         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
310         CmmAssign hpLim
311             (cmmOffsetExpr
312                 (CmmLoad nursery_bdescr_start wordRep)
313                 (cmmOffset
314                   (CmmMachOp mo_wordMul [
315                     CmmMachOp (MO_S_Conv I32 wordRep)
316                       [CmmLoad nursery_bdescr_blocks I32],
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 -> CmmActuals -> [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 (cmmExprRep . 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 $ cmmRegRep 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 = machRepByteWidth (cmmExprRep 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 (localRegRep) 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 = machRepByteWidth (localRegRep 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                        (localRegRep 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))