CmmCPS.hs 22 KB
Newer Older
1
2
3
4
5
6
7
8
module CmmCPS (cmmCPS) where

#include "HsVersions.h"

import Cmm
import CmmLint
import PprCmm

9
10
import Dataflow (fixedpoint)
import CmmLive
11
12
13
14

import MachOp
import ForeignCall
import CLabel
15
16
import SMRep
import Constants
17
18
19
20
21

import DynFlags
import ErrUtils
import Maybes
import Outputable
22
23
24
25
import UniqSupply
import UniqFM
import UniqSet
import Unique
26
27
28

import Monad
import IO
29
import Data.List
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47

--------------------------------------------------------------------------------

-- 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).

48
data BrokenBlock
49
50
51
52
53
54
55
56
57
58
59
60
61
62
  = BrokenBlock {
      brokenBlockId :: BlockId, -- Like a CmmBasicBlock
      brokenBlockEntry :: BlockEntryInfo,
                                -- How this block can be entered

      brokenBlockStmts :: [CmmStmt],
                                -- Like a CmmBasicBlock
                                -- (but without the last statement)

      brokenBlockTargets :: [BlockId],
                                -- Blocks that this block could
                                -- branch to one either by conditional
                                -- branches or via the last statement

63
      brokenBlockExit :: FinalStmt
64
65
66
                                -- How the block can be left
    }

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
continuationLabel (Continuation _ _ l _ _) = l
data Continuation =
  Continuation
     Bool              -- True => Function entry, False => Continuation/return point
     [CmmStatic]       -- Info table, may be empty
     CLabel            -- Used to generate both info & entry labels
     CmmFormals        -- Argument locals live on entry (C-- procedure params)
     [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.
82
83

data BlockEntryInfo
84
85
86
  = FunctionEntry		-- Beginning of a function
      CLabel                    -- The function name
      CmmFormals                -- Aguments to function
87
88

  | ContinuationEntry 		-- Return point of a call
89
      CmmFormals                -- return values (argument to continuation)
90
91
  -- TODO:
  -- | ProcPointEntry -- no return values, but some live might end up as params or possibly in the frame
92
93
94

  | ControlEntry		-- A label in the input

95
96
97
-- Final statement in a BlokenBlock
-- Constructors and arguments match those in Cmm,
-- but are restricted to branches, returns, jumps, calls and switches
98
99
data FinalStmt
  = FinalBranch
100
      BlockId -- next block (must be a ControlEntry)
101

102
  | FinalReturn
103
      CmmActuals -- return values
104

105
  | FinalJump
106
107
      CmmExpr -- the function to call
      CmmActuals -- arguments to call
108

109
  | FinalCall
110
111
112
113
114
115
116
117
118
      BlockId -- next block after call (must be a ContinuationEntry)
      CmmCallTarget -- the function to call
      CmmFormals -- results from call (redundant with ContinuationEntry)
      CmmActuals -- arguments to call
      (Maybe [GlobalReg]) -- registers that must be saved (TODO)

  | FinalSwitch
      CmmExpr [Maybe BlockId]   -- Table branch

119
120
  -- TODO: | ProcPointExit (needed?)

121
-- Describes the layout of a stack frame for a continuation
122
123
data StackFormat
    = StackFormat
124
125
126
         (Maybe CLabel)		-- The label occupying the top slot
         WordOff		-- Total frame size in words
         [(CmmReg, WordOff)]	-- local reg offsets from stack top
127
128
129
130
131

-- 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

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks

-----------------------------------------------------------------------------
calculateOwnership :: UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId)
calculateOwnership proc_points blocks =
    fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
    where
      blocks_ufm :: BlockEnv BrokenBlock
      blocks_ufm = blocksToBlockEnv blocks

      dependants :: BlockId -> [BlockId]
      dependants ident =
          brokenBlockTargets $ lookupWithDefaultUFM
                                 blocks_ufm unknown_block ident

      update :: BlockId -> Maybe BlockId
             -> BlockEnv (UniqSet BlockId) -> Maybe (BlockEnv (UniqSet BlockId))
      update ident cause owners =
          case (cause, ident `elementOfUniqSet` proc_points) of
            (Nothing, True) -> Just $ addToUFM owners ident (unitUniqSet ident)
            (Nothing, False) -> Nothing
            (Just cause', True) -> Nothing
            (Just cause', False) ->
                if (sizeUniqSet old) == (sizeUniqSet new)
                   then Nothing
                   else Just $ addToUFM owners ident new
                where
                  old = lookupWithDefaultUFM owners emptyUniqSet ident
                  new = old `unionUniqSets` lookupWithDefaultUFM owners emptyUniqSet cause'

      unknown_block = panic "unknown BlockId in selectStackFormat"

calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks
    where
      init_proc_points = mkUniqSet $
                         map brokenBlockId $
                         filter always_proc_point blocks
      always_proc_point BrokenBlock {
172
                              brokenBlockEntry = FunctionEntry _ _ } = True
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
      always_proc_point BrokenBlock {
                              brokenBlockEntry = ContinuationEntry _ } = True
      always_proc_point _ = False

calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
calculateProcPoints' old_proc_points blocks =
    if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
      then old_proc_points
      else calculateProcPoints' new_proc_points blocks
    where
      owners = calculateOwnership old_proc_points blocks
      new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks))

calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId
calculateProcPoints''  owners block =
    unionManyUniqSets (map (f parent_id) child_ids)
    where
      parent_id = brokenBlockId block
      child_ids = brokenBlockTargets block
192
      -- TODO: name for f
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
      f parent_id child_id = 
          if needs_proc_point
            then unitUniqSet child_id
            else emptyUniqSet
          where
            parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
            child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
            needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners

collectNonProcPointTargets ::
    UniqSet BlockId -> BlockEnv BrokenBlock
    -> UniqSet BlockId -> BlockId -> UniqSet BlockId
collectNonProcPointTargets proc_points blocks current_targets block =
    if sizeUniqSet current_targets == sizeUniqSet new_targets
       then current_targets
       else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
    where
      block' = lookupWithDefaultUFM blocks (panic "TODO") block
211
212
213
214
      targets =
        -- Note the subtlety that since the extra branch after a call
        -- will always be to a block that is a proc-point,
        -- this subtraction will always remove that case
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
        uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
        -- TODO: remove redundant uniqSetToList
      new_targets = current_targets `unionUniqSets` (mkUniqSet targets)

buildContinuation ::
    UniqSet BlockId -> BlockEnv BrokenBlock
    -> BlockId -> Continuation
buildContinuation proc_points blocks start =
  Continuation is_entry info_table clabel params body
    where
      children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
      start_block = lookupWithDefaultUFM blocks (panic "TODO") start
      children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
      body = start_block : children_blocks
      info_table = [] -- TODO
230
231
232
      start_block_entry = brokenBlockEntry start_block
      is_entry = case start_block_entry of
                   FunctionEntry _ _ -> True
233
                   _ -> False
234
235
236
237
238
239
240
      clabel = case start_block_entry of
                 FunctionEntry label _ -> label
                 _ -> mkReturnPtLabel $ getUnique start
      params = case start_block_entry of
                 FunctionEntry _ args -> args
                 ContinuationEntry args -> args
                 ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
241

242
--------------------------------------------------------------------------------
243
-- For now just select the continuation orders in the order they are in the set with no gaps
244

245
246
247
248
249
selectStackFormat2 :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)]
selectStackFormat2 live continuations =
    map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
    where
      selectStackFormat' (Continuation True info_table label formals blocks) =
250
251
252
          --let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
          --in
          StackFormat (Just label) 0 []
253
      selectStackFormat' (Continuation False info_table label formals blocks) =
254
          -- TODO: assumes the first block is the entry block
255
          let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
256
          in live_to_format label formals $ lookupWithDefaultUFM live unknown_block ident
257

258
259
      live_to_format :: CLabel -> CmmFormals -> CmmLive -> StackFormat
      live_to_format label formals live =
260
          foldl extend_format
261
262
                    (StackFormat (Just label) retAddrSizeW [])
                    (uniqSetToList (live `minusUniqSet` mkUniqSet (cmmFormalsToLiveLocals formals)))
263
264

      extend_format :: StackFormat -> LocalReg -> StackFormat
265
266
      extend_format (StackFormat label size offsets) reg =
          StackFormat label (slot_size reg + size) ((CmmLocal reg, size) : offsets)
267
268

      unknown_block = panic "unknown BlockId in selectStackFormat"
269
270
271

slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1

272
273
274
275
276
277
278
279
280
281
282
283
284
constructContinuation :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
constructContinuation formats (Continuation is_entry info label formals blocks) =
    CmmProc info label formals (map (constructContinuation2' label formats) blocks)

constructContinuation2' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
                       -> CmmBasicBlock
constructContinuation2' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
    BasicBlock ident (prefix++stmts++postfix)
    where
      curr_format = maybe unknown_block id $ lookup curr_ident formats
      unknown_block = panic "unknown BlockId in constructContinuation"
      prefix = case entry of
                 ControlEntry -> []
285
                 FunctionEntry _ _ -> []
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
                 ContinuationEntry formals ->
                     unpack_continuation curr_format
      postfix = case exit of
                  FinalBranch next -> [CmmBranch next]
                  FinalSwitch expr targets -> [CmmSwitch expr targets]
                  FinalReturn arguments ->
                      exit_function curr_format
                                    (CmmLoad (CmmReg spReg) wordRep)
                                    arguments
                  FinalJump target arguments ->
                      exit_function curr_format target arguments
                  -- TODO: do something about global saves
                  FinalCall next (CmmForeignCall target CmmCallConv)
                            results arguments saves ->
                                pack_continuation curr_format cont_format ++
                                [CmmJump target arguments]
                            where
                              cont_format = maybe unknown_block id $
                                            lookup (mkReturnPtLabel $ getUnique next) formats
                  FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"

307
308
309
310
311
312
313
314
--------------------------------------------------------------------------------
-- Functions that generate CmmStmt sequences
-- for packing/unpacking continuations
-- and entering/exiting functions

exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
  = adjust_spReg ++ jump where
315
316
317
318
319
    adjust_spReg =
        if curr_frame_size == 0
        then []
        else [CmmAssign spReg
                 (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
    jump = [CmmJump target arguments]

enter_function :: WordOff -> [CmmStmt]
enter_function max_frame_size
  = check_stack_limit where
    check_stack_limit = [
     CmmCondBranch
     (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
                    [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
     gc_block]
    gc_block = undefined -- TODO: get stack and heap checks to go to same

-- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
                       (StackFormat cont_id cont_frame_size cont_offsets)
  = save_live_values ++ set_stack_header ++ adjust_spReg where
    -- TODO: only save variables when actually needed
    save_live_values =
        [CmmStore
         (CmmRegOff
          spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
         (CmmReg reg)
         | (reg, offset) <- cont_offsets]
344
345
346
347
348
349
350
351
352
    needs_header =
      case (curr_id, cont_id) of
        (Just x, Just y) -> x /= y
        _ -> isJust cont_id
    set_stack_header =
      if not needs_header
         then []
         else [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
    continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
    adjust_spReg =
        if curr_frame_size == cont_frame_size
        then []
        else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]

-- 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).
unpack_continuation :: StackFormat -> [CmmStmt]
unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
  = load_live_values where
    -- TODO: only save variables when actually needed
    load_live_values =
        [CmmAssign
         reg
         (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
         | (reg, offset) <- curr_offsets]

372
373
374
-----------------------------------------------------------------------------
-- Breaking basic blocks on function calls
-----------------------------------------------------------------------------
375

376
-----------------------------------------------------------------------------
377
378
-- Takes a basic block and breaks it up into a list of broken blocks
--
379
380
381
-- Takes a basic block and returns a list of basic blocks that
-- each have at most 1 CmmCall in them which must occur at the end.
-- Also returns with each basic block, the variables that will
382
383
384
-- be arguments to the continuation of the block once the call (if any)
-- returns.

385
breakBlock :: [Unique] -> CmmBasicBlock -> BlockEntryInfo -> [BrokenBlock]
386
387
388
389
390
391
breakBlock uniques (BasicBlock ident stmts) entry =
    breakBlock' uniques ident entry [] [] stmts where
        breakBlock' uniques current_id entry exits accum_stmts stmts =
            case stmts of
              [] -> panic "block doesn't end in jump, goto or return"
              [CmmJump target arguments] ->
392
393
394
                  [BrokenBlock current_id entry accum_stmts
                               exits
                               (FinalJump target arguments)]
395
              [CmmReturn arguments] ->
396
397
398
                  [BrokenBlock current_id entry accum_stmts
                               exits
                               (FinalReturn arguments)]
399
              [CmmBranch target] ->
400
401
402
403
404
405
406
                  [BrokenBlock current_id entry accum_stmts
                               (target:exits)
                               (FinalBranch target)]
              [CmmSwitch expr targets] ->
                  [BrokenBlock current_id entry accum_stmts
                               (mapMaybe id targets ++ exits)
                               (FinalSwitch expr targets)]
407
408
409
410
411
412
413
              (CmmJump _ _:_) ->
                  panic "jump in middle of block"
              (CmmReturn _:_) ->
                  panic "return in middle of block"
              (CmmBranch _:_) ->
                  panic "branch in middle of block"
              (CmmSwitch _ _:_) ->
414
415
416
417
418
419
420
421
422
                  panic ("switch in middle of block" ++ (showSDoc $ ppr stmts))
              (CmmCall target results arguments saves:stmts) -> block : rest
                  where
                    new_id = BlockId $ head uniques
                    block = BrokenBlock current_id entry accum_stmts
                            (new_id:exits)
                            (FinalCall new_id target results arguments saves)
                    rest = breakBlock' (tail uniques) new_id
                           (ContinuationEntry results) [] [] stmts
423
              (s@(CmmCondBranch test target):stmts) ->
424
425
                  breakBlock' uniques current_id entry
                              (target:exits) (accum_stmts++[s]) stmts
426
              (s:stmts) ->
427
428
429
430
431
432
433
434
435
                  breakBlock' uniques current_id entry
                              exits (accum_stmts++[s]) stmts

--------------------------------
-- Convert from a BrokenBlock
-- to a CmmBasicBlock so the
-- liveness analysis can run
-- on it.
--------------------------------
436
cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
437
438
cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
    BasicBlock ident (stmts++exit_stmt)
439
    where
440
      exit_stmt =
441
          case exit of
442
443
444
            FinalBranch target -> [CmmBranch target]
            FinalReturn arguments -> [CmmReturn arguments]
            FinalJump target arguments -> [CmmJump target arguments]
445
446
447
448
            FinalSwitch expr targets -> [CmmSwitch expr targets]
            FinalCall branch_target call_target results arguments saves ->
                [CmmCall call_target results arguments saves,
                 CmmBranch branch_target]
449
450
451
452
453
454
455
456

-----------------------------------------------------------------------------
-- CPS a single CmmTop (proceedure)
-----------------------------------------------------------------------------

cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
cpsProc uniqSupply x@(CmmData _ _) = [x]
cpsProc uniqSupply x@(CmmProc info_table ident params blocks) =
457
458
    --[CmmProc info_table ident params cps_blocks]
    cps_continuations
459
460
461
462
    where
      uniqes :: [[Unique]]
      uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply

463
      -- Break the block at each function call
464
      broken_blocks :: [BrokenBlock]
465
      broken_blocks = concat $ zipWith3 breakBlock uniqes blocks
466
                                        (FunctionEntry ident params:repeat ControlEntry)
467
468

      -- Calculate live variables for each broken block
469
470
      live :: BlockEntryLiveness
      live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
471
             -- nothing can be live on entry to the first block so we could take the tail
472

473
474
475
476
477
478
479
480
481
482
483
      proc_points :: UniqSet BlockId
      proc_points = calculateProcPoints broken_blocks

      continuations :: [Continuation]
      continuations = map (buildContinuation proc_points (blocksToBlockEnv broken_blocks)) (uniqSetToList proc_points)

      -- TODO: insert proc point code here
      --  * Branches and switches to proc points may cause new blocks to be created
      --    (or proc points could leave behind phantom blocks that just jump to them)
      --  * Proc points might get some live variables passed as arguments

484
485
      -- TODO: let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks

486
487
488
489
490
491
492
493
494
      --procs = groupBlocksIntoContinuations live broken_blocks

      -- Select the stack format on entry to each block
      formats2 :: [(CLabel, StackFormat)]
      formats2 = selectStackFormat2 live continuations

      -- Do the actual CPS transform
      cps_continuations :: [CmmTop]
      cps_continuations = map (constructContinuation formats2) continuations
495

496
--------------------------------------------------------------------------------
497
498
499
500
501
502
503
504
505
506
507
508
cmmCPS :: DynFlags
       -> [Cmm]                 -- C-- with Proceedures
       -> IO [Cmm]		-- Output: CPS transformed C--

cmmCPS dflags abstractC = do
  when (dopt Opt_DoCmmLinting dflags) $
       do showPass dflags "CmmLint"
	  case firstJust $ map cmmLint abstractC of
	    Just err -> do printDump err
			   ghcExit dflags 1
	    Nothing  -> return ()
  showPass dflags "CPS"
509
510
511
512
  -- TODO: check for use of branches to non-existant blocks
  -- TODO: check for use of Sp, SpLim, R1, R2, etc.
  -- TODO: find out if it is valid to create a new unique source like this
  uniqSupply <- mkSplitUniqSupply 'p'
513
514
  let supplies = listSplitUniqSupply uniqSupply
  let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
515
516
517
518

  dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
  -- TODO: add option to dump Cmm to file
  return continuationC