CmmCPS.hs 27.5 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
84

data BlockEntryInfo
  = FunctionEntry		-- Beginning of function
85
      CmmFormals                -- aguments to function
86
87

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

  | ControlEntry		-- A label in the input

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

101
  | FinalReturn
102
      CmmActuals -- return values
103

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

108
  | FinalCall
109
110
111
112
113
114
115
116
117
      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

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

data StackFormat
    = StackFormat
122
123
124
         BlockId {- block that is the start of the continuation. may or may not be the current block -}
         WordOff {- total frame size -}
         [(CmmReg, WordOff)] {- local reg offsets from stack top -}
125
126
127
128
129

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

130
131
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
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
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 {
                              brokenBlockEntry = FunctionEntry _ } = True
      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
      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
            --needs_proc_point = sizeUniqSet (parent_owners `unionUniqSets` child_owners) /= sizeUniqSet parent_owners

cmmCondBranchTargets (CmmCondBranch _ target) = [target]
cmmCondBranchTargets _ = []

finalBranchOrSwitchTargets (FinalBranch target) = [target]
finalBranchOrSwitchTargets (FinalSwitch _ targets) = mapCatMaybes id targets
finalBranchOrSwitchTargets _ = []

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
      targets = -- We can't use the brokenBlockTargets b/c we don't want to follow the final goto after a call -- brokenBlockTargets block'
        --finalBranchOrSwitchTargets (brokenBlockExit block') ++ concatMap cmmCondBranchTargets (brokenBlockStmts block')
        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
      is_entry = case start_block of
                   BrokenBlock { brokenBlockEntry = FunctionEntry _ } -> True
                   _ -> False
      clabel = mkReturnPtLabel $ getUnique start
      params = case start_block of
                 BrokenBlock { brokenBlockEntry = FunctionEntry args } -> args
                 BrokenBlock { brokenBlockEntry = ContinuationEntry args } -> args
                 BrokenBlock { brokenBlockEntry = ControlEntry } -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers

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
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
selectStackFormat :: BlockEnv CmmLive -> [BrokenBlock] -> BlockEnv StackFormat
selectStackFormat live blocks =
    fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
    where
      blocks_ufm :: BlockEnv BrokenBlock
      blocks_ufm = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks

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

      update :: BlockId -> Maybe BlockId
             -> BlockEnv StackFormat -> Maybe (BlockEnv StackFormat)
      update ident cause formats =
          if ident `elemUFM` formats
             then Nothing -- Blocks only need to be updated once
             else case (cause,
                        brokenBlockEntry $ lookupWithDefaultUFM blocks_ufm
                                             unknown_block ident) of
                    -- Propagate only to blocks entered by branches
                    -- (not function entry blocks or continuation entry blocks)
                    (Just cause_name, ControlEntry) ->
                        Just $ addToUFM formats ident cause_format
                            where cause_format = lookupWithDefaultUFM
                                                   formats unknown_block
                                                   cause_name
                    -- Do initial calculates for function blocks
                    (Nothing, FunctionEntry _) ->
                        Just $
                             addToUFM formats ident $
                             StackFormat ident 0 []
                    -- Do initial calculates for continuation blocks
                    (Nothing, ContinuationEntry _) ->
                        Just $
                             addToUFM formats ident $
                             live_to_format ident $
                             lookupWithDefaultUFM live unknown_block ident
                    _ -> Nothing

      unknown_block = panic "unknown BlockId in selectStackFormat"

      live_to_format :: BlockId -> CmmLive -> StackFormat
      live_to_format label live =
          foldl extend_format
                    (StackFormat label retAddrSizeW [])
                    (uniqSetToList live)

      extend_format :: StackFormat -> LocalReg -> StackFormat
      extend_format (StackFormat block size offsets) reg =
          StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)

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) =
          let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
          in StackFormat ident 0 []
      selectStackFormat' (Continuation False info_table label formals blocks) =
          let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
          in live_to_format ident $ lookupWithDefaultUFM live unknown_block ident          

      live_to_format :: BlockId -> CmmLive -> StackFormat
      live_to_format label live =
          foldl extend_format
                    (StackFormat label retAddrSizeW [])
                    (uniqSetToList live)

      extend_format :: StackFormat -> LocalReg -> StackFormat
      extend_format (StackFormat block size offsets) reg =
          StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)

      unknown_block = panic "unknown BlockId in selectStackFormat"
319
320
321

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

322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
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
386
387
388
389
constructContinuation :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
constructContinuation formats (Continuation is_entry info label formals blocks) =
    CmmProc info label formals (map (constructContinuation2' label formats) blocks)

{-
    BasicBlock ident (prefix++stmts++postfix)
    where
      
      curr_format = lookupWithDefaultUFM formats unknown_block ident
      unknown_block = panic "unknown BlockId in constructContinuation"
      prefix = case entry of
                 ControlEntry -> []
                 FunctionEntry _ -> []
                 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 = lookupWithDefaultUFM formats
                                              unknown_block next
                  FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
-}

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 -> []
                 FunctionEntry _ -> []
                 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"

constructContinuation2 :: BlockEnv StackFormat -> BrokenBlock
                       -> CmmBasicBlock
390
constructContinuation2 formats (BrokenBlock ident entry stmts _ exit) =
391
392
    BasicBlock ident (prefix++stmts++postfix)
    where
393
394
      curr_format = lookupWithDefaultUFM formats unknown_block ident
      unknown_block = panic "unknown BlockId in constructContinuation"
395
396
      prefix = case entry of
                 ControlEntry -> []
397
398
399
                 FunctionEntry _ -> []
                 ContinuationEntry formals ->
                     unpack_continuation curr_format
400
      postfix = case exit of
401
                  FinalBranch next -> [CmmBranch next]
402
403
404
405
406
407
408
                  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
409
                  -- TODO: do something about global saves
410
411
412
413
414
415
416
                  FinalCall next (CmmForeignCall target CmmCallConv)
                            results arguments saves ->
                                pack_continuation curr_format cont_format ++
                                [CmmJump target arguments]
                            where
                              cont_format = lookupWithDefaultUFM formats
                                              unknown_block next
417
                  FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
418

419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
--------------------------------------------------------------------------------
-- 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
    adjust_spReg = [
     CmmAssign spReg
     (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
    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]
    set_stack_header = -- TODO: only set when needed
        [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
456
    continuation_function = CmmLit $ CmmLabel $ mkReturnPtLabel {-TODO: use the correct function -} $ getUnique cont_id
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
    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]

476
477
478
-----------------------------------------------------------------------------
-- Breaking basic blocks on function calls
-----------------------------------------------------------------------------
479

480
-----------------------------------------------------------------------------
481
482
-- Takes a basic block and breaks it up into a list of broken blocks
--
483
484
485
-- 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
486
487
488
-- be arguments to the continuation of the block once the call (if any)
-- returns.

489
breakBlock :: [Unique] -> CmmBasicBlock -> BlockEntryInfo -> [BrokenBlock]
490
491
492
493
494
495
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] ->
496
497
498
                  [BrokenBlock current_id entry accum_stmts
                               exits
                               (FinalJump target arguments)]
499
              [CmmReturn arguments] ->
500
501
502
                  [BrokenBlock current_id entry accum_stmts
                               exits
                               (FinalReturn arguments)]
503
              [CmmBranch target] ->
504
505
506
507
508
509
510
                  [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)]
511
512
513
514
515
516
517
              (CmmJump _ _:_) ->
                  panic "jump in middle of block"
              (CmmReturn _:_) ->
                  panic "return in middle of block"
              (CmmBranch _:_) ->
                  panic "branch in middle of block"
              (CmmSwitch _ _:_) ->
518
519
520
521
522
523
524
525
526
                  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
527
              (s@(CmmCondBranch test target):stmts) ->
528
529
                  breakBlock' uniques current_id entry
                              (target:exits) (accum_stmts++[s]) stmts
530
              (s:stmts) ->
531
532
533
534
535
536
537
538
539
                  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.
--------------------------------
540
cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
541
542
cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
    BasicBlock ident (stmts++exit_stmt)
543
    where
544
      exit_stmt =
545
          case exit of
546
547
548
            FinalBranch target -> [CmmBranch target]
            FinalReturn arguments -> [CmmReturn arguments]
            FinalJump target arguments -> [CmmJump target arguments]
549
550
551
552
            FinalSwitch expr targets -> [CmmSwitch expr targets]
            FinalCall branch_target call_target results arguments saves ->
                [CmmCall call_target results arguments saves,
                 CmmBranch branch_target]
553
554
555
556
557
558
559
560

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

cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
cpsProc uniqSupply x@(CmmData _ _) = [x]
cpsProc uniqSupply x@(CmmProc info_table ident params blocks) =
561
562
    --[CmmProc info_table ident params cps_blocks]
    cps_continuations
563
564
565
566
    where
      uniqes :: [[Unique]]
      uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply

567
      -- Break the block at each function call
568
      broken_blocks :: [BrokenBlock]
569
570
571
572
      broken_blocks = concat $ zipWith3 breakBlock uniqes blocks
                                        (FunctionEntry params:repeat ControlEntry)

      -- Calculate live variables for each broken block
573
574
575
      live :: BlockEntryLiveness
      live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks

576
577
578
579
580
581
582
583
584
585
586
      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

587
588
      -- TODO: let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks

589
590
591
592
593
594
595
596
597
598
599
600
      --procs = groupBlocksIntoContinuations live broken_blocks

      -- Select the stack format on entry to each block
      formats :: BlockEnv StackFormat
      formats = selectStackFormat live broken_blocks

      formats2 :: [(CLabel, StackFormat)]
      formats2 = selectStackFormat2 live continuations

      -- Do the actual CPS transform
      cps_blocks :: [CmmBasicBlock]
      cps_blocks = map (constructContinuation2 formats) broken_blocks
601

602
603
      cps_continuations :: [CmmTop]
      cps_continuations = map (constructContinuation formats2) continuations
604

605
--------------------------------------------------------------------------------
606
607
608
609
610
611
612
613
614
615
616
617
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"
618
619
620
621
  -- 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'
622
623
  let supplies = listSplitUniqSupply uniqSupply
  let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
624
625
626
627

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