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