compiler/cmm/CmmCPS.hs

   1 module CmmCPS (cmmCPS) where
   2
   3 #include "HsVersions.h"
   4
   5 import Cmm
   6 import CmmLint
   7 import PprCmm
   8
   9 import Dataflow (fixedpoint)
  10 import CmmLive
  11
  12 import MachOp
  13 import ForeignCall
  14 import CLabel
  15 import SMRep
  16 import Constants
  17
  18 import DynFlags
  19 import ErrUtils
  20 import Maybes
  21 import Outputable
  22 import UniqSupply
  23 import UniqFM
  24 import UniqSet
  25 import Unique
  26
  27 import Monad
  28 import IO
  29 import Data.List
  30
  31 --------------------------------------------------------------------------------
  32
  33 -- The format for the call to a continuation
  34 -- The fst is the arguments that must be passed to the continuation
  35 -- by the continuation's caller.
  36 -- The snd is the live values that must be saved on stack.
  37 -- A Nothing indicates an ignored slot.
  38 -- The head of each list is the stack top or the first parameter.
  39
  40 -- The format for live values for a particular continuation
  41 -- All on stack for now.
  42 -- Head element is the top of the stack (or just under the header).
  43 -- Nothing means an empty slot.
  44 -- Future possibilities include callee save registers (i.e. passing slots in register)
  45 -- and heap memory (not sure if that's usefull at all though, but it may
  46 -- be worth exploring the design space).
  47
  48 data BrokenBlock
  49   = BrokenBlock {
  50       brokenBlockId :: BlockId, -- Like a CmmBasicBlock
  51       brokenBlockEntry :: BlockEntryInfo,
  52                                 -- How this block can be entered
  53
  54       brokenBlockStmts :: [CmmStmt],
  55                                 -- Like a CmmBasicBlock
  56                                 -- (but without the last statement)
  57
  58       brokenBlockTargets :: [BlockId],
  59                                 -- Blocks that this block could
  60                                 -- branch to one either by conditional
  61                                 -- branches or via the last statement
  62
  63       brokenBlockExit :: FinalStmt
  64                                 -- How the block can be left
  65     }
  66
  67 continuationLabel (Continuation _ _ l _ _) = l
  68 data Continuation =
  69   Continuation
  70      Bool              -- True => Function entry, False => Continuation/return point
  71      [CmmStatic]       -- Info table, may be empty
  72      CLabel            -- Used to generate both info & entry labels
  73      CmmFormals        -- Argument locals live on entry (C-- procedure params)
  74      [BrokenBlock]   -- Code, may be empty.  The first block is
  75                        -- the entry point.  The order is otherwise initially
  76                        -- unimportant, but at some point the code gen will
  77                        -- fix the order.
  78
  79                        -- the BlockId of the first block does not give rise
  80                        -- to a label.  To jump to the first block in a Proc,
  81                        -- use the appropriate CLabel.
  82
  83 data BlockEntryInfo
  84   = FunctionEntry               -- Beginning of a function
  85       CLabel                    -- The function name
  86       CmmFormals                -- Aguments to function
  87
  88   | ContinuationEntry           -- Return point of a call
  89       CmmFormals                -- return values (argument to continuation)
  90   -- TODO:
  91   -- | ProcPointEntry -- no return values, but some live might end up as params or possibly in the frame
  92
  93   | ControlEntry                -- A label in the input
  94
  95 -- Final statement in a BlokenBlock
  96 -- Constructors and arguments match those in Cmm,
  97 -- but are restricted to branches, returns, jumps, calls and switches
  98 data FinalStmt
  99   = FinalBranch
 100       BlockId -- next block (must be a ControlEntry)
 101
 102   | FinalReturn
 103       CmmActuals -- return values
 104
 105   | FinalJump
 106       CmmExpr -- the function to call
 107       CmmActuals -- arguments to call
 108
 109   | FinalCall
 110       BlockId -- next block after call (must be a ContinuationEntry)
 111       CmmCallTarget -- the function to call
 112       CmmFormals -- results from call (redundant with ContinuationEntry)
 113       CmmActuals -- arguments to call
 114       (Maybe [GlobalReg]) -- registers that must be saved (TODO)
 115
 116   | FinalSwitch
 117       CmmExpr [Maybe BlockId]   -- Table branch
 118
 119   -- TODO: | ProcPointExit (needed?)
 120
 121 -- Describes the layout of a stack frame for a continuation
 122 data StackFormat
 123     = StackFormat
 124          (Maybe CLabel)         -- The label occupying the top slot
 125          WordOff                -- Total frame size in words
 126          [(CmmReg, WordOff)]    -- local reg offsets from stack top
 127
 128 -- A block can be a continuation of a call
 129 -- A block can be a continuation of another block (w/ or w/o joins)
 130 -- A block can be an entry to a function
 131
 132 blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
 133 blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
 134
 135 -----------------------------------------------------------------------------
 136 calculateOwnership :: UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId)
 137 calculateOwnership proc_points blocks =
 138     fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
 139     where
 140       blocks_ufm :: BlockEnv BrokenBlock
 141       blocks_ufm = blocksToBlockEnv blocks
 142
 143       dependants :: BlockId -> [BlockId]
 144       dependants ident =
 145           brokenBlockTargets $ lookupWithDefaultUFM
 146                                  blocks_ufm unknown_block ident
 147
 148       update :: BlockId -> Maybe BlockId
 149              -> BlockEnv (UniqSet BlockId) -> Maybe (BlockEnv (UniqSet BlockId))
 150       update ident cause owners =
 151           case (cause, ident `elementOfUniqSet` proc_points) of
 152             (Nothing, True) -> Just $ addToUFM owners ident (unitUniqSet ident)
 153             (Nothing, False) -> Nothing
 154             (Just cause', True) -> Nothing
 155             (Just cause', False) ->
 156                 if (sizeUniqSet old) == (sizeUniqSet new)
 157                    then Nothing
 158                    else Just $ addToUFM owners ident new
 159                 where
 160                   old = lookupWithDefaultUFM owners emptyUniqSet ident
 161                   new = old `unionUniqSets` lookupWithDefaultUFM owners emptyUniqSet cause'
 162
 163       unknown_block = panic "unknown BlockId in selectStackFormat"
 164
 165 calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
 166 calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks
 167     where
 168       init_proc_points = mkUniqSet $
 169                          map brokenBlockId $
 170                          filter always_proc_point blocks
 171       always_proc_point BrokenBlock {
 172                               brokenBlockEntry = FunctionEntry _ _ } = True
 173       always_proc_point BrokenBlock {
 174                               brokenBlockEntry = ContinuationEntry _ } = True
 175       always_proc_point _ = False
 176
 177 calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
 178 calculateProcPoints' old_proc_points blocks =
 179     if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
 180       then old_proc_points
 181       else calculateProcPoints' new_proc_points blocks
 182     where
 183       owners = calculateOwnership old_proc_points blocks
 184       new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks))
 185
 186 calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId
 187 calculateProcPoints''  owners block =
 188     unionManyUniqSets (map (f parent_id) child_ids)
 189     where
 190       parent_id = brokenBlockId block
 191       child_ids = brokenBlockTargets block
 192       -- TODO: name for f
 193       f parent_id child_id =
 194           if needs_proc_point
 195             then unitUniqSet child_id
 196             else emptyUniqSet
 197           where
 198             parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
 199             child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
 200             needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners
 201
 202 collectNonProcPointTargets ::
 203     UniqSet BlockId -> BlockEnv BrokenBlock
 204     -> UniqSet BlockId -> BlockId -> UniqSet BlockId
 205 collectNonProcPointTargets proc_points blocks current_targets block =
 206     if sizeUniqSet current_targets == sizeUniqSet new_targets
 207        then current_targets
 208        else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
 209     where
 210       block' = lookupWithDefaultUFM blocks (panic "TODO") block
 211       targets =
 212         -- Note the subtlety that since the extra branch after a call
 213         -- will always be to a block that is a proc-point,
 214         -- this subtraction will always remove that case
 215         uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
 216         -- TODO: remove redundant uniqSetToList
 217       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 218
 219 buildContinuation ::
 220     UniqSet BlockId -> BlockEnv BrokenBlock
 221     -> BlockId -> Continuation
 222 buildContinuation proc_points blocks start =
 223   Continuation is_entry info_table clabel params body
 224     where
 225       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
 226       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
 227       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
 228       body = start_block : children_blocks
 229       info_table = [] -- TODO
 230       start_block_entry = brokenBlockEntry start_block
 231       is_entry = case start_block_entry of
 232                    FunctionEntry _ _ -> True
 233                    _ -> False
 234       clabel = case start_block_entry of
 235                  FunctionEntry label _ -> label
 236                  _ -> mkReturnPtLabel $ getUnique start
 237       params = case start_block_entry of
 238                  FunctionEntry _ args -> args
 239                  ContinuationEntry args -> args
 240                  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 selectStackFormat :: BlockEnv CmmLive -> [BrokenBlock] -> BlockEnv StackFormat
 246 selectStackFormat live blocks =
 247     fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
 248     where
 249       blocks_ufm :: BlockEnv BrokenBlock
 250       blocks_ufm = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
 251
 252       dependants :: BlockId -> [BlockId]
 253       dependants ident =
 254           brokenBlockTargets $ lookupWithDefaultUFM
 255                                  blocks_ufm unknown_block ident
 256
 257       update :: BlockId -> Maybe BlockId
 258              -> BlockEnv StackFormat -> Maybe (BlockEnv StackFormat)
 259       update ident cause formats =
 260           if ident `elemUFM` formats
 261              then Nothing -- Blocks only need to be updated once
 262              else case (cause,
 263                         brokenBlockEntry $ lookupWithDefaultUFM blocks_ufm
 264                                              unknown_block ident) of
 265                     -- Propagate only to blocks entered by branches
 266                     -- (not function entry blocks or continuation entry blocks)
 267                     (Just cause_name, ControlEntry) ->
 268                         Just $ addToUFM formats ident cause_format
 269                             where cause_format = lookupWithDefaultUFM
 270                                                    formats unknown_block
 271                                                    cause_name
 272                     -- Do initial calculates for function blocks
 273                     (Nothing, FunctionEntry _ _) ->
 274                         Just $
 275                              addToUFM formats ident $
 276                              StackFormat ident 0 []
 277                     -- Do initial calculates for continuation blocks
 278                     (Nothing, ContinuationEntry _) ->
 279                         Just $
 280                              addToUFM formats ident $
 281                              live_to_format ident $
 282                              lookupWithDefaultUFM live unknown_block ident
 283                     _ -> Nothing
 284
 285       unknown_block = panic "unknown BlockId in selectStackFormat"
 286
 287       live_to_format :: BlockId -> CmmLive -> StackFormat
 288       live_to_format label live =
 289           foldl extend_format
 290                     (StackFormat label retAddrSizeW [])
 291                     (uniqSetToList live)
 292
 293       extend_format :: StackFormat -> LocalReg -> StackFormat
 294       extend_format (StackFormat block size offsets) reg =
 295           StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)
 296
 297 selectStackFormat2 :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)]
 298 selectStackFormat2 live continuations =
 299     map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
 300     where
 301       selectStackFormat' (Continuation True info_table label formals blocks) =
 302           --let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 303           --in
 304           StackFormat (Just label) 0 []
 305       selectStackFormat' (Continuation False info_table label formals blocks) =
 306           -- TODO: assumes the first block is the entry block
 307           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 308           in live_to_format label formals $ lookupWithDefaultUFM live unknown_block ident
 309
 310       live_to_format :: CLabel -> CmmFormals -> CmmLive -> StackFormat
 311       live_to_format label formals live =
 312           foldl extend_format
 313                     (StackFormat (Just label) retAddrSizeW [])
 314                     (uniqSetToList (live `minusUniqSet` mkUniqSet (cmmFormalsToLiveLocals formals)))
 315
 316       extend_format :: StackFormat -> LocalReg -> StackFormat
 317       extend_format (StackFormat label size offsets) reg =
 318           StackFormat label (slot_size reg + size) ((CmmLocal reg, size) : offsets)
 319
 320       unknown_block = panic "unknown BlockId in selectStackFormat"
 321
 322 slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
 323
 324 constructContinuation :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
 325 constructContinuation formats (Continuation is_entry info label formals blocks) =
 326     CmmProc info label formals (map (constructContinuation2' label formats) blocks)
 327
 328 constructContinuation2' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
 329                        -> CmmBasicBlock
 330 constructContinuation2' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
 331     BasicBlock ident (prefix++stmts++postfix)
 332     where
 333       curr_format = maybe unknown_block id $ lookup curr_ident formats
 334       unknown_block = panic "unknown BlockId in constructContinuation"
 335       prefix = case entry of
 336                  ControlEntry -> []
 337                  FunctionEntry _ _ -> []
 338                  ContinuationEntry formals ->
 339                      unpack_continuation curr_format
 340       postfix = case exit of
 341                   FinalBranch next -> [CmmBranch next]
 342                   FinalSwitch expr targets -> [CmmSwitch expr targets]
 343                   FinalReturn arguments ->
 344                       exit_function curr_format
 345                                     (CmmLoad (CmmReg spReg) wordRep)
 346                                     arguments
 347                   FinalJump target arguments ->
 348                       exit_function curr_format target arguments
 349                   -- TODO: do something about global saves
 350                   FinalCall next (CmmForeignCall target CmmCallConv)
 351                             results arguments saves ->
 352                                 pack_continuation curr_format cont_format ++
 353                                 [CmmJump target arguments]
 354                             where
 355                               cont_format = maybe unknown_block id $
 356                                             lookup (mkReturnPtLabel $ getUnique next) formats
 357                   FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
 358
 359 --------------------------------------------------------------------------------
 360 -- Functions that generate CmmStmt sequences
 361 -- for packing/unpacking continuations
 362 -- and entering/exiting functions
 363
 364 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
 365 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
 366   = adjust_spReg ++ jump where
 367     adjust_spReg =
 368         if curr_frame_size == 0
 369         then []
 370         else [CmmAssign spReg
 371                  (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
 372     jump = [CmmJump target arguments]
 373
 374 enter_function :: WordOff -> [CmmStmt]
 375 enter_function max_frame_size
 376   = check_stack_limit where
 377     check_stack_limit = [
 378      CmmCondBranch
 379      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 380                     [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
 381      gc_block]
 382     gc_block = undefined -- TODO: get stack and heap checks to go to same
 383
 384 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
 385 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 386 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 387                        (StackFormat cont_id cont_frame_size cont_offsets)
 388   = save_live_values ++ set_stack_header ++ adjust_spReg where
 389     -- TODO: only save variables when actually needed
 390     save_live_values =
 391         [CmmStore
 392          (CmmRegOff
 393           spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
 394          (CmmReg reg)
 395          | (reg, offset) <- cont_offsets]
 396     needs_header =
 397       case (curr_id, cont_id) of
 398         (Just x, Just y) -> x /= y
 399         _ -> isJust cont_id
 400     set_stack_header =
 401       if not needs_header
 402          then []
 403          else [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
 404     continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
 405     adjust_spReg =
 406         if curr_frame_size == cont_frame_size
 407         then []
 408         else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
 409
 410 -- Lazy adjustment of stack headers assumes all blocks
 411 -- that could branch to eachother (i.e. control blocks)
 412 -- have the same stack format (this causes a problem
 413 -- only for proc-point).
 414 unpack_continuation :: StackFormat -> [CmmStmt]
 415 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 416   = load_live_values where
 417     -- TODO: only save variables when actually needed
 418     load_live_values =
 419         [CmmAssign
 420          reg
 421          (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
 422          | (reg, offset) <- curr_offsets]
 423
 424 -----------------------------------------------------------------------------
 425 -- Breaking basic blocks on function calls
 426 -----------------------------------------------------------------------------
 427
 428 -----------------------------------------------------------------------------
 429 -- Takes a basic block and breaks it up into a list of broken blocks
 430 --
 431 -- Takes a basic block and returns a list of basic blocks that
 432 -- each have at most 1 CmmCall in them which must occur at the end.
 433 -- Also returns with each basic block, the variables that will
 434 -- be arguments to the continuation of the block once the call (if any)
 435 -- returns.
 436
 437 breakBlock :: [Unique] -> CmmBasicBlock -> BlockEntryInfo -> [BrokenBlock]
 438 breakBlock uniques (BasicBlock ident stmts) entry =
 439     breakBlock' uniques ident entry [] [] stmts where
 440         breakBlock' uniques current_id entry exits accum_stmts stmts =
 441             case stmts of
 442               [] -> panic "block doesn't end in jump, goto or return"
 443               [CmmJump target arguments] ->
 444                   [BrokenBlock current_id entry accum_stmts
 445                                exits
 446                                (FinalJump target arguments)]
 447               [CmmReturn arguments] ->
 448                   [BrokenBlock current_id entry accum_stmts
 449                                exits
 450                                (FinalReturn arguments)]
 451               [CmmBranch target] ->
 452                   [BrokenBlock current_id entry accum_stmts
 453                                (target:exits)
 454                                (FinalBranch target)]
 455               [CmmSwitch expr targets] ->
 456                   [BrokenBlock current_id entry accum_stmts
 457                                (mapMaybe id targets ++ exits)
 458                                (FinalSwitch expr targets)]
 459               (CmmJump _ _:_) ->
 460                   panic "jump in middle of block"
 461               (CmmReturn _:_) ->
 462                   panic "return in middle of block"
 463               (CmmBranch _:_) ->
 464                   panic "branch in middle of block"
 465               (CmmSwitch _ _:_) ->
 466                   panic ("switch in middle of block" ++ (showSDoc $ ppr stmts))
 467               (CmmCall target results arguments saves:stmts) -> block : rest
 468                   where
 469                     new_id = BlockId $ head uniques
 470                     block = BrokenBlock current_id entry accum_stmts
 471                             (new_id:exits)
 472                             (FinalCall new_id target results arguments saves)
 473                     rest = breakBlock' (tail uniques) new_id
 474                            (ContinuationEntry results) [] [] stmts
 475               (s@(CmmCondBranch test target):stmts) ->
 476                   breakBlock' uniques current_id entry
 477                               (target:exits) (accum_stmts++[s]) stmts
 478               (s:stmts) ->
 479                   breakBlock' uniques current_id entry
 480                               exits (accum_stmts++[s]) stmts
 481
 482 --------------------------------
 483 -- Convert from a BrokenBlock
 484 -- to a CmmBasicBlock so the
 485 -- liveness analysis can run
 486 -- on it.
 487 --------------------------------
 488 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
 489 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
 490     BasicBlock ident (stmts++exit_stmt)
 491     where
 492       exit_stmt =
 493           case exit of
 494             FinalBranch target -> [CmmBranch target]
 495             FinalReturn arguments -> [CmmReturn arguments]
 496             FinalJump target arguments -> [CmmJump target arguments]
 497             FinalSwitch expr targets -> [CmmSwitch expr targets]
 498             FinalCall branch_target call_target results arguments saves ->
 499                 [CmmCall call_target results arguments saves,
 500                  CmmBranch branch_target]
 501
 502 -----------------------------------------------------------------------------
 503 -- CPS a single CmmTop (proceedure)
 504 -----------------------------------------------------------------------------
 505
 506 cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
 507 cpsProc uniqSupply x@(CmmData _ _) = [x]
 508 cpsProc uniqSupply x@(CmmProc info_table ident params blocks) =
 509     --[CmmProc info_table ident params cps_blocks]
 510     cps_continuations
 511     where
 512       uniqes :: [[Unique]]
 513       uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
 514
 515       -- Break the block at each function call
 516       broken_blocks :: [BrokenBlock]
 517       broken_blocks = concat $ zipWith3 breakBlock uniqes blocks
 518                                         (FunctionEntry ident params:repeat ControlEntry)
 519
 520       -- Calculate live variables for each broken block
 521       live :: BlockEntryLiveness
 522       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
 523              -- nothing can be live on entry to the first block so we could take the tail
 524
 525       proc_points :: UniqSet BlockId
 526       proc_points = calculateProcPoints broken_blocks
 527
 528       continuations :: [Continuation]
 529       continuations = map (buildContinuation proc_points (blocksToBlockEnv broken_blocks)) (uniqSetToList proc_points)
 530
 531       -- TODO: insert proc point code here
 532       --  * Branches and switches to proc points may cause new blocks to be created
 533       --    (or proc points could leave behind phantom blocks that just jump to them)
 534       --  * Proc points might get some live variables passed as arguments
 535
 536       -- TODO: let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks
 537
 538       --procs = groupBlocksIntoContinuations live broken_blocks
 539
 540       -- Select the stack format on entry to each block
 541       formats2 :: [(CLabel, StackFormat)]
 542       formats2 = selectStackFormat2 live continuations
 543
 544       -- Do the actual CPS transform
 545       cps_continuations :: [CmmTop]
 546       cps_continuations = map (constructContinuation formats2) continuations
 547
 548 --------------------------------------------------------------------------------
 549 cmmCPS :: DynFlags
 550        -> [Cmm]                 -- C-- with Proceedures
 551        -> IO [Cmm]              -- Output: CPS transformed C--
 552
 553 cmmCPS dflags abstractC = do
 554   when (dopt Opt_DoCmmLinting dflags) $
 555        do showPass dflags "CmmLint"
 556           case firstJust $ map cmmLint abstractC of
 557             Just err -> do printDump err
 558                            ghcExit dflags 1
 559             Nothing  -> return ()
 560   showPass dflags "CPS"
 561   -- TODO: check for use of branches to non-existant blocks
 562   -- TODO: check for use of Sp, SpLim, R1, R2, etc.
 563   -- TODO: find out if it is valid to create a new unique source like this
 564   uniqSupply <- mkSplitUniqSupply 'p'
 565   let supplies = listSplitUniqSupply uniqSupply
 566   let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
 567
 568   dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
 569   -- TODO: add option to dump Cmm to file
 570   return continuationC