CmmCPSGen.hs 20 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
module CmmCPSGen (
  -- | Converts continuations into full proceedures.
  -- The main work of the CPS transform that everything else is setting-up.
  continuationToProc,
  Continuation(..), continuationLabel,
  ContinuationFormat(..),
) where

#include "HsVersions.h"

import Cmm
import CLabel
import CmmBrokenBlock -- Data types only
import MachOp
import CmmUtils
import CmmCallConv

import CgProf (curCCS, curCCSAddr)
import CgUtils (cmmOffsetW)
import SMRep
import ForeignCall

import Constants
import StaticFlags
import Unique
import Maybe

import Panic

import MachRegs (callerSaveVolatileRegs)
  -- HACK: this is part of the NCG so we shouldn't use this, but we need
  -- it for now to eliminate the need for saved regs to be in CmmCall.
  -- The long term solution is to factor callerSaveVolatileRegs
  -- from nativeGen into CPS

-- The format for the call to a continuation
-- The fst is the arguments that must be passed to the continuation
-- by the continuation's caller.
-- The snd is the live values that must be saved on stack.
-- A Nothing indicates an ignored slot.
-- The head of each list is the stack top or the first parameter.

-- The format for live values for a particular continuation
-- All on stack for now.
-- Head element is the top of the stack (or just under the header).
-- Nothing means an empty slot.
-- Future possibilities include callee save registers (i.e. passing slots in register)
-- and heap memory (not sure if that's usefull at all though, but it may
-- be worth exploring the design space).

continuationLabel (Continuation _ l _ _ _) = l
data Continuation info =
  Continuation
     info              -- Left <=> Continuation created by the CPS
                       -- Right <=> Function or Proc point
     CLabel            -- Used to generate both info & entry labels
     CmmFormals        -- Argument locals live on entry (C-- procedure params)
     Bool              -- ^ True <=> GC block so ignore stack size
     [BrokenBlock]     -- Code, may be empty.  The first block is
                       -- the entry point.  The order is otherwise initially 
                       -- unimportant, but at some point the code gen will
                       -- fix the order.

		       -- the BlockId of the first block does not give rise
		       -- to a label.  To jump to the first block in a Proc,
		       -- use the appropriate CLabel.

data ContinuationFormat
    = ContinuationFormat {
        continuation_formals :: CmmFormals,
        continuation_label :: Maybe CLabel,	-- The label occupying the top slot
        continuation_frame_size :: WordOff,	-- Total frame size in words (not including arguments)
        continuation_stack :: [Maybe LocalReg]	-- local reg offsets from stack top
      }

-- A block can be a continuation of a call
-- A block can be a continuation of another block (w/ or w/o joins)
-- A block can be an entry to a function

-----------------------------------------------------------------------------
81
continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
82
83
84
85
                   -> CmmReg
                   -> [[Unique]]
                   -> Continuation CmmInfo
                   -> CmmTop
86
continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
87
88
89
90
91
92
93
94
95
96
97
98
99
                   (Continuation info label formals _ blocks) =
    CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False))
    where
      curr_format = maybe unknown_block id $ lookup label formats
      unknown_block = panic "unknown BlockId in continuationToProc"
      curr_stack = continuation_frame_size curr_format
      arg_stack = argumentsSize localRegRep formals

      param_stmts :: [CmmStmt]
      param_stmts = function_entry curr_format

      gc_stmts :: [CmmStmt]
      gc_stmts =
100
        assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
101
102
103
104
105
106
107
108

      update_stmts :: [CmmStmt]
      update_stmts =
          case info of
            CmmInfo _ (Just (UpdateFrame target args)) _ ->
                pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
                adjust_sp_reg (curr_stack - update_frame_size)
            CmmInfo _ Nothing _ -> []
109
110
111
112
113
114
115
116
117
118
119
120
121
122

-- At present neither the Cmm parser nor the code generator
-- produce code that will allow the target of a CmmCondBranch
-- or a CmmSwitch to become a continuation or a proc-point.
-- If future revisions, might allow these to happen
-- then special care will have to be take to allow for that case.
      continuationToProc' :: [Unique]
                          -> BrokenBlock
                          -> Bool
                          -> [CmmBasicBlock]
      continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
          prefix_blocks ++ [main_block]
          where
            prefix_blocks =
123
124
125
126
127
                if is_entry
                then [BasicBlock
                      (BlockId prefix_unique)
                      (param_stmts ++ [CmmBranch ident])]
                else []
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151

            prefix_unique : call_uniques = uniques
            toCLabel = mkReturnPtLabel . getUnique

            block_for_branch unique next
                | (Just cont_format) <- lookup (toCLabel next) formats
                = let
                    new_next = BlockId unique
                    cont_stack = continuation_frame_size cont_format
                    arguments = map formal_to_actual (continuation_formals cont_format)
                  in (new_next,
                     [BasicBlock new_next $
                      pack_continuation False curr_format cont_format ++
                      tail_call (curr_stack - cont_stack)
                              (CmmLit $ CmmLabel $ toCLabel next)
                              arguments])
                | otherwise
                = (next, [])

            block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
            block_for_branch' _ Nothing = (Nothing, [])
            block_for_branch' unique (Just next) = (Just new_next, new_blocks)
              where (new_next, new_blocks) = block_for_branch unique next

152
153
154
155
156
157
158
159
160
            main_block =
                case entry of
                  FunctionEntry _ _ _ ->
                      -- Ugh, the statements for an update frame must come
                      -- *after* the GC check that was added at the beginning
                      -- of the CPS pass.  So we have do edit the statements
                      -- a bit.  This depends on the knowledge that the
                      -- statements in the first block are only the GC check.
                      -- That's fragile but it works for now.
161
                      BasicBlock ident (gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts)
162
163
                  ControlEntry -> BasicBlock ident (stmts ++ postfix_stmts)
                  ContinuationEntry _ _ _ -> BasicBlock ident (stmts ++ postfix_stmts)
164
165
166
167
168
169
170
            postfix_stmts = case exit of
                        FinalBranch next ->
                            if (mkReturnPtLabel $ getUnique next) == label
                            then [CmmBranch next]
                            else case lookup (mkReturnPtLabel $ getUnique next) formats of
                              Nothing -> [CmmBranch next]
                              Just cont_format ->
Michael D. Adams's avatar
Michael D. Adams committed
171
                                pack_continuation True curr_format cont_format ++
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
                                tail_call (curr_stack - cont_stack)
                                          (CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next)
                                          arguments
                                where
                                  cont_stack = continuation_frame_size cont_format
                                  arguments = map formal_to_actual (continuation_formals cont_format)
                        FinalSwitch expr targets -> [CmmSwitch expr targets]
                        FinalReturn arguments ->
                            tail_call curr_stack
                                (CmmLoad (CmmReg spReg) wordRep)
                                arguments
                        FinalJump target arguments ->
                            tail_call curr_stack target arguments

                        -- A regular Cmm function call
                        FinalCall next (CmmForeignCall target CmmCallConv)
                            results arguments _ _ ->
                                pack_continuation True curr_format cont_format ++
                                tail_call (curr_stack - cont_stack)
                                              target arguments
                            where
                              cont_format = maybe unknown_block id $
                                            lookup (mkReturnPtLabel $ getUnique next) formats
                              cont_stack = continuation_frame_size cont_format

                        -- A safe foreign call
                        FinalCall next (CmmForeignCall target conv)
                            results arguments _ _ ->
                                target_stmts ++
                                foreignCall call_uniques' (CmmForeignCall new_target conv)
                                            results arguments
                            where
                              (call_uniques', target_stmts, new_target) =
                                  maybeAssignTemp call_uniques target

                        -- A safe prim call
                        FinalCall next (CmmPrim target)
                            results arguments _ _ ->
                                foreignCall call_uniques (CmmPrim target)
                                            results arguments

formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint)

foreignCall :: [Unique] -> CmmCallTarget -> CmmHintFormals -> CmmActuals -> [CmmStmt]
foreignCall uniques call results arguments =
    arg_stmts ++
    saveThreadState ++
    caller_save ++
    [CmmCall (CmmForeignCall suspendThread CCallConv)
		 [ (id,PtrHint) ]
		 [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
		 CmmUnsafe,
     CmmCall call results new_args CmmUnsafe,
     CmmCall (CmmForeignCall resumeThread CCallConv)
                 [ (new_base, PtrHint) ]
		 [ (CmmReg (CmmLocal id), PtrHint) ]
		 CmmUnsafe,
     -- Assign the result to BaseReg: we
     -- might now have a different Capability!
     CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
    caller_load ++
    loadThreadState tso_unique ++
    [CmmJump (CmmReg spReg) (map (formal_to_actual . fst) results)]
    where
      (_, arg_stmts, new_args) =
          loadArgsIntoTemps argument_uniques arguments
      (caller_save, caller_load) =
          callerSaveVolatileRegs (Just [{-only system regs-}])
      new_base = LocalReg base_unique (cmmRegRep (CmmGlobal BaseReg)) KindNonPtr
      id = LocalReg id_unique wordRep KindNonPtr
      tso_unique : base_unique : id_unique : argument_uniques = uniques

-- -----------------------------------------------------------------------------
-- Save/restore the thread state in the TSO

suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))

-- This stuff can't be done in suspendThread/resumeThread, because it
-- refers to global registers which aren't available in the C world.

saveThreadState =
  -- CurrentTSO->sp = Sp;
  [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
  closeNursery] ++
  -- and save the current cost centre stack in the TSO when profiling:
  if opt_SccProfilingOn
  then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
  else []

   -- CurrentNursery->free = Hp+1;
closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)

loadThreadState tso_unique =
  [
	-- tso = CurrentTSO;
  	CmmAssign (CmmLocal tso) stgCurrentTSO,
	-- Sp = tso->sp;
	CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
	                      wordRep),
	-- SpLim = tso->stack + RESERVED_STACK_WORDS;
	CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
			            rESERVED_STACK_WORDS)
  ] ++
  openNursery ++
  -- and load the current cost centre stack from the TSO when profiling:
  if opt_SccProfilingOn 
  then [CmmStore curCCSAddr 
	(CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep)]
  else []
  where tso = LocalReg tso_unique wordRep KindNonPtr -- TODO FIXME NOW


openNursery = [
        -- Hp = CurrentNursery->free - 1;
	CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),

        -- HpLim = CurrentNursery->start + 
	--		CurrentNursery->blocks*BLOCK_SIZE_W - 1;
	CmmAssign hpLim
	    (cmmOffsetExpr
		(CmmLoad nursery_bdescr_start wordRep)
		(cmmOffset
		  (CmmMachOp mo_wordMul [
		    CmmMachOp (MO_S_Conv I32 wordRep)
		      [CmmLoad nursery_bdescr_blocks I32],
		    CmmLit (mkIntCLit bLOCK_SIZE)
		   ])
		  (-1)
		)
	    )
   ]


nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks

tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS

-- The TSO struct has a variable header, and an optional StgTSOProfInfo in
-- the middle.  The fields we're interested in are after the StgTSOProfInfo.
tsoFieldB :: ByteOff -> ByteOff
tsoFieldB off
  | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
  | otherwise          = off + fixedHdrSize * wORD_SIZE

tsoProfFieldB :: ByteOff -> ByteOff
tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE

stgSp		  = CmmReg sp
stgHp		  = CmmReg hp
stgCurrentTSO	  = CmmReg currentTSO
stgCurrentNursery = CmmReg currentNursery

sp		  = CmmGlobal Sp
spLim		  = CmmGlobal SpLim
hp		  = CmmGlobal Hp
hpLim		  = CmmGlobal HpLim
currentTSO	  = CmmGlobal CurrentTSO
currentNursery 	  = CmmGlobal CurrentNursery

-----------------------------------------------------------------------------
-- Functions that generate CmmStmt sequences
-- for packing/unpacking continuations
-- and entering/exiting functions

tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
tail_call spRel target arguments
343
  = store_arguments ++ adjust_sp_reg spRel ++ jump where
344
345
346
347
348
349
350
351
352
    store_arguments =
        [stack_put spRel expr offset
         | ((expr, _), StackParam offset) <- argument_formats] ++
        [global_put expr global
         | ((expr, _), RegisterParam global) <- argument_formats]
    jump = [CmmJump target arguments]

    argument_formats = assignArguments (cmmExprRep . fst) arguments

353
354
355
356
357
adjust_sp_reg spRel =
    if spRel == 0
    then []
    else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]

358
assign_gc_stack_use stack_use arg_stack max_frame_size =
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
    if max_frame_size > arg_stack
    then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
    else [CmmAssign stack_use (CmmReg spLimReg)]
         -- Trick the optimizer into eliminating the branch for us
  
gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
gc_stack_check gc_block max_frame_size
  = check_stack_limit where
    check_stack_limit = [
     CmmCondBranch
     (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
                    [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
                     CmmReg spLimReg])
     gc_block]


pack_continuation :: Bool               -- ^ Whether to set the top/header
                                        -- of the stack.  We only need to
                                        -- set it if we are calling down
                                        -- as opposed to continuation
                                        -- adaptors.
                  -> ContinuationFormat -- ^ The current format
                  -> ContinuationFormat -- ^ The return point format
                  -> [CmmStmt]
pack_continuation allow_header_set
                      (ContinuationFormat _ curr_id curr_frame_size _)
                      (ContinuationFormat _ cont_id cont_frame_size live_regs)
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
  = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
  where
    continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
    continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal))
                            live_regs
    needs_header_set =
        case (curr_id, cont_id) of
          (Just x, Just y) -> x /= y
          _ -> isJust cont_id

    maybe_header = if allow_header_set && needs_header_set
                   then Just continuation_function
                   else Nothing

pack_frame :: WordOff         -- ^ Current frame size
           -> WordOff         -- ^ Next frame size
           -> Maybe CmmExpr   -- ^ Next frame header if any
           -> [Maybe CmmExpr] -- ^ Next frame data
           -> [CmmStmt]
pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
    store_live_values ++ set_stack_header
    where
408
409
410
    -- TODO: only save variables when actually needed
    -- (may be handled by latter pass)
    store_live_values =
411
412
        [stack_put spRel expr offset
         | (expr, offset) <- cont_offsets]
413
    set_stack_header =
414
415
416
        case next_frame_header of
          Nothing -> []
          Just expr -> [stack_put spRel expr 0]
417
418

    -- TODO: factor with function_entry and CmmInfo.hs(?)
419
    cont_offsets = mkOffsets label_size frame_args
420
421
422
423

    label_size = 1 :: WordOff

    mkOffsets size [] = []
424
425
    mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
    mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
426
        where
427
          width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE
428
429
          -- TODO: it would be better if we had a machRepWordWidth

430
431
    spRel = curr_frame_size - next_frame_size

432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493

-- Lazy adjustment of stack headers assumes all blocks
-- that could branch to eachother (i.e. control blocks)
-- have the same stack format (this causes a problem
-- only for proc-point).
function_entry :: ContinuationFormat -> [CmmStmt]
function_entry (ContinuationFormat formals _ _ live_regs)
  = load_live_values ++ load_args where
    -- TODO: only save variables when actually needed
    -- (may be handled by latter pass)
    load_live_values =
        [stack_get 0 reg offset
         | (reg, offset) <- curr_offsets]
    load_args =
        [stack_get 0 reg offset
         | (reg, StackParam offset) <- argument_formats] ++
        [global_get reg global
         | (reg, RegisterParam global) <- argument_formats]

    argument_formats = assignArguments (localRegRep) formals

    -- TODO: eliminate copy/paste with pack_continuation
    curr_offsets = mkOffsets label_size live_regs

    label_size = 1 :: WordOff

    mkOffsets size [] = []
    mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
    mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
        where
          width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
          -- TODO: it would be better if we had a machRepWordWidth

-----------------------------------------------------------------------------
-- Section: Stack and argument register puts and gets
-----------------------------------------------------------------------------
-- TODO: document

-- |Construct a 'CmmStmt' that will save a value on the stack
stack_put :: WordOff            -- ^ Offset from the real 'Sp' that 'offset'
                                -- is relative to (added to offset)
          -> CmmExpr            -- ^ What to store onto the stack
          -> WordOff            -- ^ Where on the stack to store it
                                -- (positive <=> higher addresses)
          -> CmmStmt
stack_put spRel expr offset =
    CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr

--------------------------------
-- |Construct a 
stack_get :: WordOff
          -> LocalReg
          -> WordOff
          -> CmmStmt
stack_get spRel reg offset =
    CmmAssign (CmmLocal reg)
              (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
                       (localRegRep reg))
global_put :: CmmExpr -> GlobalReg -> CmmStmt
global_put expr global = CmmAssign (CmmGlobal global) expr
global_get :: LocalReg -> GlobalReg -> CmmStmt
global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))