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 data StackFormat
 122     = StackFormat
 123          BlockId {- block that is the start of the continuation. may or may not be the current block -}
 124          WordOff {- total frame size -}
 125          [(CmmReg, WordOff)] {- local reg offsets from stack top -}
 126
 127 -- A block can be a continuation of a call
 128 -- A block can be a continuation of another block (w/ or w/o joins)
 129 -- A block can be an entry to a function
 130
 131 blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
 132 blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
 133
 134 -----------------------------------------------------------------------------
 135 calculateOwnership :: UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId)
 136 calculateOwnership proc_points blocks =
 137     fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
 138     where
 139       blocks_ufm :: BlockEnv BrokenBlock
 140       blocks_ufm = blocksToBlockEnv blocks
 141
 142       dependants :: BlockId -> [BlockId]
 143       dependants ident =
 144           brokenBlockTargets $ lookupWithDefaultUFM
 145                                  blocks_ufm unknown_block ident
 146
 147       update :: BlockId -> Maybe BlockId
 148              -> BlockEnv (UniqSet BlockId) -> Maybe (BlockEnv (UniqSet BlockId))
 149       update ident cause owners =
 150           case (cause, ident `elementOfUniqSet` proc_points) of
 151             (Nothing, True) -> Just $ addToUFM owners ident (unitUniqSet ident)
 152             (Nothing, False) -> Nothing
 153             (Just cause', True) -> Nothing
 154             (Just cause', False) ->
 155                 if (sizeUniqSet old) == (sizeUniqSet new)
 156                    then Nothing
 157                    else Just $ addToUFM owners ident new
 158                 where
 159                   old = lookupWithDefaultUFM owners emptyUniqSet ident
 160                   new = old `unionUniqSets` lookupWithDefaultUFM owners emptyUniqSet cause'
 161
 162       unknown_block = panic "unknown BlockId in selectStackFormat"
 163
 164 calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
 165 calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks
 166     where
 167       init_proc_points = mkUniqSet $
 168                          map brokenBlockId $
 169                          filter always_proc_point blocks
 170       always_proc_point BrokenBlock {
 171                               brokenBlockEntry = FunctionEntry _ _ } = True
 172       always_proc_point BrokenBlock {
 173                               brokenBlockEntry = ContinuationEntry _ } = True
 174       always_proc_point _ = False
 175
 176 calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
 177 calculateProcPoints' old_proc_points blocks =
 178     if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
 179       then old_proc_points
 180       else calculateProcPoints' new_proc_points blocks
 181     where
 182       owners = calculateOwnership old_proc_points blocks
 183       new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks))
 184
 185 calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId
 186 calculateProcPoints''  owners block =
 187     unionManyUniqSets (map (f parent_id) child_ids)
 188     where
 189       parent_id = brokenBlockId block
 190       child_ids = brokenBlockTargets block
 191       -- TODO: name for f
 192       f parent_id child_id =
 193           if needs_proc_point
 194             then unitUniqSet child_id
 195             else emptyUniqSet
 196           where
 197             parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
 198             child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
 199             needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners
 200
 201 collectNonProcPointTargets ::
 202     UniqSet BlockId -> BlockEnv BrokenBlock
 203     -> UniqSet BlockId -> BlockId -> UniqSet BlockId
 204 collectNonProcPointTargets proc_points blocks current_targets block =
 205     if sizeUniqSet current_targets == sizeUniqSet new_targets
 206        then current_targets
 207        else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
 208     where
 209       block' = lookupWithDefaultUFM blocks (panic "TODO") block
 210       targets =
 211         -- Note the subtlety that since the extra branch after a call
 212         -- will always be to a block that is a proc-point,
 213         -- this subtraction will always remove that case
 214         uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
 215         -- TODO: remove redundant uniqSetToList
 216       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 217
 218 buildContinuation ::
 219     UniqSet BlockId -> BlockEnv BrokenBlock
 220     -> BlockId -> Continuation
 221 buildContinuation proc_points blocks start =
 222   Continuation is_entry info_table clabel params body
 223     where
 224       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
 225       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
 226       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
 227       body = start_block : children_blocks
 228       info_table = [] -- TODO
 229       start_block_entry = brokenBlockEntry start_block
 230       is_entry = case start_block_entry of
 231                    FunctionEntry _ _ -> True
 232                    _ -> False
 233       clabel = case start_block_entry of
 234                  FunctionEntry label _ -> label
 235                  _ -> mkReturnPtLabel $ getUnique start
 236       params = case start_block_entry of
 237                  FunctionEntry _ args -> args
 238                  ContinuationEntry args -> args
 239                  ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
 240
 241 --------------------------------------------------------------------------------
 242 -- For now just select the continuation orders in the order they are in the set with no gaps
 243
 244 selectStackFormat :: BlockEnv CmmLive -> [BrokenBlock] -> BlockEnv StackFormat
 245 selectStackFormat live blocks =
 246     fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
 247     where
 248       blocks_ufm :: BlockEnv BrokenBlock
 249       blocks_ufm = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
 250
 251       dependants :: BlockId -> [BlockId]
 252       dependants ident =
 253           brokenBlockTargets $ lookupWithDefaultUFM
 254                                  blocks_ufm unknown_block ident
 255
 256       update :: BlockId -> Maybe BlockId
 257              -> BlockEnv StackFormat -> Maybe (BlockEnv StackFormat)
 258       update ident cause formats =
 259           if ident `elemUFM` formats
 260              then Nothing -- Blocks only need to be updated once
 261              else case (cause,
 262                         brokenBlockEntry $ lookupWithDefaultUFM blocks_ufm
 263                                              unknown_block ident) of
 264                     -- Propagate only to blocks entered by branches
 265                     -- (not function entry blocks or continuation entry blocks)
 266                     (Just cause_name, ControlEntry) ->
 267                         Just $ addToUFM formats ident cause_format
 268                             where cause_format = lookupWithDefaultUFM
 269                                                    formats unknown_block
 270                                                    cause_name
 271                     -- Do initial calculates for function blocks
 272                     (Nothing, FunctionEntry _ _) ->
 273                         Just $
 274                              addToUFM formats ident $
 275                              StackFormat ident 0 []
 276                     -- Do initial calculates for continuation blocks
 277                     (Nothing, ContinuationEntry _) ->
 278                         Just $
 279                              addToUFM formats ident $
 280                              live_to_format ident $
 281                              lookupWithDefaultUFM live unknown_block ident
 282                     _ -> Nothing
 283
 284       unknown_block = panic "unknown BlockId in selectStackFormat"
 285
 286       live_to_format :: BlockId -> CmmLive -> StackFormat
 287       live_to_format label live =
 288           foldl extend_format
 289                     (StackFormat label retAddrSizeW [])
 290                     (uniqSetToList live)
 291
 292       extend_format :: StackFormat -> LocalReg -> StackFormat
 293       extend_format (StackFormat block size offsets) reg =
 294           StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)
 295
 296 selectStackFormat2 :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)]
 297 selectStackFormat2 live continuations =
 298     map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
 299     where
 300       selectStackFormat' (Continuation True info_table label formals blocks) =
 301           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 302           in StackFormat ident 0 []
 303       selectStackFormat' (Continuation False info_table label formals blocks) =
 304           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 305           in live_to_format ident $ lookupWithDefaultUFM live unknown_block ident
 306
 307       live_to_format :: BlockId -> CmmLive -> StackFormat
 308       live_to_format label live =
 309           foldl extend_format
 310                     (StackFormat label retAddrSizeW [])
 311                     (uniqSetToList live)
 312
 313       extend_format :: StackFormat -> LocalReg -> StackFormat
 314       extend_format (StackFormat block size offsets) reg =
 315           StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)
 316
 317       unknown_block = panic "unknown BlockId in selectStackFormat"
 318
 319 slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
 320
 321 constructContinuation :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
 322 constructContinuation formats (Continuation is_entry info label formals blocks) =
 323     CmmProc info label formals (map (constructContinuation2' label formats) blocks)
 324
 325 constructContinuation2' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
 326                        -> CmmBasicBlock
 327 constructContinuation2' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
 328     BasicBlock ident (prefix++stmts++postfix)
 329     where
 330       curr_format = maybe unknown_block id $ lookup curr_ident formats
 331       unknown_block = panic "unknown BlockId in constructContinuation"
 332       prefix = case entry of
 333                  ControlEntry -> []
 334                  FunctionEntry _ _ -> []
 335                  ContinuationEntry formals ->
 336                      unpack_continuation curr_format
 337       postfix = case exit of
 338                   FinalBranch next -> [CmmBranch next]
 339                   FinalSwitch expr targets -> [CmmSwitch expr targets]
 340                   FinalReturn arguments ->
 341                       exit_function curr_format
 342                                     (CmmLoad (CmmReg spReg) wordRep)
 343                                     arguments
 344                   FinalJump target arguments ->
 345                       exit_function curr_format target arguments
 346                   -- TODO: do something about global saves
 347                   FinalCall next (CmmForeignCall target CmmCallConv)
 348                             results arguments saves ->
 349                                 pack_continuation curr_format cont_format ++
 350                                 [CmmJump target arguments]
 351                             where
 352                               cont_format = maybe unknown_block id $
 353                                             lookup (mkReturnPtLabel $ getUnique next) formats
 354                   FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
 355
 356 --------------------------------------------------------------------------------
 357 -- Functions that generate CmmStmt sequences
 358 -- for packing/unpacking continuations
 359 -- and entering/exiting functions
 360
 361 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
 362 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
 363   = adjust_spReg ++ jump where
 364     adjust_spReg = [
 365      CmmAssign spReg
 366      (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
 367     jump = [CmmJump target arguments]
 368
 369 enter_function :: WordOff -> [CmmStmt]
 370 enter_function max_frame_size
 371   = check_stack_limit where
 372     check_stack_limit = [
 373      CmmCondBranch
 374      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 375                     [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
 376      gc_block]
 377     gc_block = undefined -- TODO: get stack and heap checks to go to same
 378
 379 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
 380 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 381 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 382                        (StackFormat cont_id cont_frame_size cont_offsets)
 383   = save_live_values ++ set_stack_header ++ adjust_spReg where
 384     -- TODO: only save variables when actually needed
 385     save_live_values =
 386         [CmmStore
 387          (CmmRegOff
 388           spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
 389          (CmmReg reg)
 390          | (reg, offset) <- cont_offsets]
 391     set_stack_header = -- TODO: only set when needed
 392         [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
 393     continuation_function = CmmLit $ CmmLabel $ mkReturnPtLabel {-TODO: use the correct function -} $ getUnique cont_id
 394     adjust_spReg =
 395         if curr_frame_size == cont_frame_size
 396         then []
 397         else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
 398
 399 -- Lazy adjustment of stack headers assumes all blocks
 400 -- that could branch to eachother (i.e. control blocks)
 401 -- have the same stack format (this causes a problem
 402 -- only for proc-point).
 403 unpack_continuation :: StackFormat -> [CmmStmt]
 404 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 405   = load_live_values where
 406     -- TODO: only save variables when actually needed
 407     load_live_values =
 408         [CmmAssign
 409          reg
 410          (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
 411          | (reg, offset) <- curr_offsets]
 412
 413 -----------------------------------------------------------------------------
 414 -- Breaking basic blocks on function calls
 415 -----------------------------------------------------------------------------
 416
 417 -----------------------------------------------------------------------------
 418 -- Takes a basic block and breaks it up into a list of broken blocks
 419 --
 420 -- Takes a basic block and returns a list of basic blocks that
 421 -- each have at most 1 CmmCall in them which must occur at the end.
 422 -- Also returns with each basic block, the variables that will
 423 -- be arguments to the continuation of the block once the call (if any)
 424 -- returns.
 425
 426 breakBlock :: [Unique] -> CmmBasicBlock -> BlockEntryInfo -> [BrokenBlock]
 427 breakBlock uniques (BasicBlock ident stmts) entry =
 428     breakBlock' uniques ident entry [] [] stmts where
 429         breakBlock' uniques current_id entry exits accum_stmts stmts =
 430             case stmts of
 431               [] -> panic "block doesn't end in jump, goto or return"
 432               [CmmJump target arguments] ->
 433                   [BrokenBlock current_id entry accum_stmts
 434                                exits
 435                                (FinalJump target arguments)]
 436               [CmmReturn arguments] ->
 437                   [BrokenBlock current_id entry accum_stmts
 438                                exits
 439                                (FinalReturn arguments)]
 440               [CmmBranch target] ->
 441                   [BrokenBlock current_id entry accum_stmts
 442                                (target:exits)
 443                                (FinalBranch target)]
 444               [CmmSwitch expr targets] ->
 445                   [BrokenBlock current_id entry accum_stmts
 446                                (mapMaybe id targets ++ exits)
 447                                (FinalSwitch expr targets)]
 448               (CmmJump _ _:_) ->
 449                   panic "jump in middle of block"
 450               (CmmReturn _:_) ->
 451                   panic "return in middle of block"
 452               (CmmBranch _:_) ->
 453                   panic "branch in middle of block"
 454               (CmmSwitch _ _:_) ->
 455                   panic ("switch in middle of block" ++ (showSDoc $ ppr stmts))
 456               (CmmCall target results arguments saves:stmts) -> block : rest
 457                   where
 458                     new_id = BlockId $ head uniques
 459                     block = BrokenBlock current_id entry accum_stmts
 460                             (new_id:exits)
 461                             (FinalCall new_id target results arguments saves)
 462                     rest = breakBlock' (tail uniques) new_id
 463                            (ContinuationEntry results) [] [] stmts
 464               (s@(CmmCondBranch test target):stmts) ->
 465                   breakBlock' uniques current_id entry
 466                               (target:exits) (accum_stmts++[s]) stmts
 467               (s:stmts) ->
 468                   breakBlock' uniques current_id entry
 469                               exits (accum_stmts++[s]) stmts
 470
 471 --------------------------------
 472 -- Convert from a BrokenBlock
 473 -- to a CmmBasicBlock so the
 474 -- liveness analysis can run
 475 -- on it.
 476 --------------------------------
 477 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
 478 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
 479     BasicBlock ident (stmts++exit_stmt)
 480     where
 481       exit_stmt =
 482           case exit of
 483             FinalBranch target -> [CmmBranch target]
 484             FinalReturn arguments -> [CmmReturn arguments]
 485             FinalJump target arguments -> [CmmJump target arguments]
 486             FinalSwitch expr targets -> [CmmSwitch expr targets]
 487             FinalCall branch_target call_target results arguments saves ->
 488                 [CmmCall call_target results arguments saves,
 489                  CmmBranch branch_target]
 490
 491 -----------------------------------------------------------------------------
 492 -- CPS a single CmmTop (proceedure)
 493 -----------------------------------------------------------------------------
 494
 495 cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
 496 cpsProc uniqSupply x@(CmmData _ _) = [x]
 497 cpsProc uniqSupply x@(CmmProc info_table ident params blocks) =
 498     --[CmmProc info_table ident params cps_blocks]
 499     cps_continuations
 500     where
 501       uniqes :: [[Unique]]
 502       uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
 503
 504       -- Break the block at each function call
 505       broken_blocks :: [BrokenBlock]
 506       broken_blocks = concat $ zipWith3 breakBlock uniqes blocks
 507                                         (FunctionEntry ident params:repeat ControlEntry)
 508
 509       -- Calculate live variables for each broken block
 510       live :: BlockEntryLiveness
 511       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
 512              -- nothing can be live on entry to the first block so we could take the tail
 513
 514       proc_points :: UniqSet BlockId
 515       proc_points = calculateProcPoints broken_blocks
 516
 517       continuations :: [Continuation]
 518       continuations = map (buildContinuation proc_points (blocksToBlockEnv broken_blocks)) (uniqSetToList proc_points)
 519
 520       -- TODO: insert proc point code here
 521       --  * Branches and switches to proc points may cause new blocks to be created
 522       --    (or proc points could leave behind phantom blocks that just jump to them)
 523       --  * Proc points might get some live variables passed as arguments
 524
 525       -- TODO: let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks
 526
 527       --procs = groupBlocksIntoContinuations live broken_blocks
 528
 529       -- Select the stack format on entry to each block
 530       formats2 :: [(CLabel, StackFormat)]
 531       formats2 = selectStackFormat2 live continuations
 532
 533       -- Do the actual CPS transform
 534       cps_continuations :: [CmmTop]
 535       cps_continuations = map (constructContinuation formats2) continuations
 536
 537 --------------------------------------------------------------------------------
 538 cmmCPS :: DynFlags
 539        -> [Cmm]                 -- C-- with Proceedures
 540        -> IO [Cmm]              -- Output: CPS transformed C--
 541
 542 cmmCPS dflags abstractC = do
 543   when (dopt Opt_DoCmmLinting dflags) $
 544        do showPass dflags "CmmLint"
 545           case firstJust $ map cmmLint abstractC of
 546             Just err -> do printDump err
 547                            ghcExit dflags 1
 548             Nothing  -> return ()
 549   showPass dflags "CPS"
 550   -- TODO: check for use of branches to non-existant blocks
 551   -- TODO: check for use of Sp, SpLim, R1, R2, etc.
 552   -- TODO: find out if it is valid to create a new unique source like this
 553   uniqSupply <- mkSplitUniqSupply 'p'
 554   let supplies = listSplitUniqSupply uniqSupply
 555   let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
 556
 557   dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
 558   -- TODO: add option to dump Cmm to file
 559   return continuationC