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 function
  85       CmmFormals                -- aguments to function
  86
  87   | ContinuationEntry           -- Return point of a call
  88       CmmFormals                -- return values (argument to continuation)
  89   -- TODO:
  90   -- | ProcPointEntry -- no return values, but some live might end up as params or possibly in the frame
  91
  92   | ControlEntry                -- A label in the input
  93
  94 -- Final statement in a BlokenBlock
  95 -- Constructors and arguments match those in Cmm,
  96 -- but are restricted to branches, returns, jumps, calls and switches
  97 data FinalStmt
  98   = FinalBranch
  99       BlockId -- next block (must be a ControlEntry)
 100
 101   | FinalReturn
 102       CmmActuals -- return values
 103
 104   | FinalJump
 105       CmmExpr -- the function to call
 106       CmmActuals -- arguments to call
 107
 108   | FinalCall
 109       BlockId -- next block after call (must be a ContinuationEntry)
 110       CmmCallTarget -- the function to call
 111       CmmFormals -- results from call (redundant with ContinuationEntry)
 112       CmmActuals -- arguments to call
 113       (Maybe [GlobalReg]) -- registers that must be saved (TODO)
 114
 115   | FinalSwitch
 116       CmmExpr [Maybe BlockId]   -- Table branch
 117
 118   -- TODO: | ProcPointExit (needed?)
 119
 120 data StackFormat
 121     = StackFormat
 122          BlockId {- block that is the start of the continuation. may or may not be the current block -}
 123          WordOff {- total frame size -}
 124          [(CmmReg, WordOff)] {- local reg offsets from stack top -}
 125
 126 -- A block can be a continuation of a call
 127 -- A block can be a continuation of another block (w/ or w/o joins)
 128 -- A block can be an entry to a function
 129
 130 blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
 131 blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
 132
 133 -----------------------------------------------------------------------------
 134 calculateOwnership :: UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId)
 135 calculateOwnership proc_points blocks =
 136     fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
 137     where
 138       blocks_ufm :: BlockEnv BrokenBlock
 139       blocks_ufm = blocksToBlockEnv blocks
 140
 141       dependants :: BlockId -> [BlockId]
 142       dependants ident =
 143           brokenBlockTargets $ lookupWithDefaultUFM
 144                                  blocks_ufm unknown_block ident
 145
 146       update :: BlockId -> Maybe BlockId
 147              -> BlockEnv (UniqSet BlockId) -> Maybe (BlockEnv (UniqSet BlockId))
 148       update ident cause owners =
 149           case (cause, ident `elementOfUniqSet` proc_points) of
 150             (Nothing, True) -> Just $ addToUFM owners ident (unitUniqSet ident)
 151             (Nothing, False) -> Nothing
 152             (Just cause', True) -> Nothing
 153             (Just cause', False) ->
 154                 if (sizeUniqSet old) == (sizeUniqSet new)
 155                    then Nothing
 156                    else Just $ addToUFM owners ident new
 157                 where
 158                   old = lookupWithDefaultUFM owners emptyUniqSet ident
 159                   new = old `unionUniqSets` lookupWithDefaultUFM owners emptyUniqSet cause'
 160
 161       unknown_block = panic "unknown BlockId in selectStackFormat"
 162
 163 calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
 164 calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks
 165     where
 166       init_proc_points = mkUniqSet $
 167                          map brokenBlockId $
 168                          filter always_proc_point blocks
 169       always_proc_point BrokenBlock {
 170                               brokenBlockEntry = FunctionEntry _ } = True
 171       always_proc_point BrokenBlock {
 172                               brokenBlockEntry = ContinuationEntry _ } = True
 173       always_proc_point _ = False
 174
 175 calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
 176 calculateProcPoints' old_proc_points blocks =
 177     if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
 178       then old_proc_points
 179       else calculateProcPoints' new_proc_points blocks
 180     where
 181       owners = calculateOwnership old_proc_points blocks
 182       new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks))
 183
 184 calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId
 185 calculateProcPoints''  owners block =
 186     unionManyUniqSets (map (f parent_id) child_ids)
 187     where
 188       parent_id = brokenBlockId block
 189       child_ids = brokenBlockTargets block
 190       f parent_id child_id =
 191           if needs_proc_point
 192             then unitUniqSet child_id
 193             else emptyUniqSet
 194           where
 195             parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
 196             child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
 197             needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners
 198             --needs_proc_point = sizeUniqSet (parent_owners `unionUniqSets` child_owners) /= sizeUniqSet parent_owners
 199
 200 cmmCondBranchTargets (CmmCondBranch _ target) = [target]
 201 cmmCondBranchTargets _ = []
 202
 203 finalBranchOrSwitchTargets (FinalBranch target) = [target]
 204 finalBranchOrSwitchTargets (FinalSwitch _ targets) = mapCatMaybes id targets
 205 finalBranchOrSwitchTargets _ = []
 206
 207 collectNonProcPointTargets ::
 208     UniqSet BlockId -> BlockEnv BrokenBlock
 209     -> UniqSet BlockId -> BlockId -> UniqSet BlockId
 210 collectNonProcPointTargets proc_points blocks current_targets block =
 211     if sizeUniqSet current_targets == sizeUniqSet new_targets
 212        then current_targets
 213        else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
 214     where
 215       block' = lookupWithDefaultUFM blocks (panic "TODO") block
 216       targets = -- We can't use the brokenBlockTargets b/c we don't want to follow the final goto after a call -- brokenBlockTargets block'
 217         --finalBranchOrSwitchTargets (brokenBlockExit block') ++ concatMap cmmCondBranchTargets (brokenBlockStmts block')
 218         uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
 219         -- TODO: remove redundant uniqSetToList
 220       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 221
 222 buildContinuation ::
 223     UniqSet BlockId -> BlockEnv BrokenBlock
 224     -> BlockId -> Continuation
 225 buildContinuation proc_points blocks start =
 226   Continuation is_entry info_table clabel params body
 227     where
 228       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
 229       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
 230       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
 231       body = start_block : children_blocks
 232       info_table = [] -- TODO
 233       is_entry = case start_block of
 234                    BrokenBlock { brokenBlockEntry = FunctionEntry _ } -> True
 235                    _ -> False
 236       clabel = mkReturnPtLabel $ getUnique start
 237       params = case start_block of
 238                  BrokenBlock { brokenBlockEntry = FunctionEntry args } -> args
 239                  BrokenBlock { brokenBlockEntry = ContinuationEntry args } -> args
 240                  BrokenBlock { brokenBlockEntry = 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 StackFormat ident 0 []
 304       selectStackFormat' (Continuation False info_table label formals blocks) =
 305           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 306           in live_to_format ident $ lookupWithDefaultUFM live unknown_block ident
 307
 308       live_to_format :: BlockId -> CmmLive -> StackFormat
 309       live_to_format label live =
 310           foldl extend_format
 311                     (StackFormat label retAddrSizeW [])
 312                     (uniqSetToList live)
 313
 314       extend_format :: StackFormat -> LocalReg -> StackFormat
 315       extend_format (StackFormat block size offsets) reg =
 316           StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)
 317
 318       unknown_block = panic "unknown BlockId in selectStackFormat"
 319
 320 slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
 321
 322 constructContinuation :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
 323 constructContinuation formats (Continuation is_entry info label formals blocks) =
 324     CmmProc info label formals (map (constructContinuation2' label formats) blocks)
 325
 326 {-
 327     BasicBlock ident (prefix++stmts++postfix)
 328     where
 329
 330       curr_format = lookupWithDefaultUFM formats unknown_block ident
 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 = lookupWithDefaultUFM formats
 353                                               unknown_block next
 354                   FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
 355 -}
 356
 357 constructContinuation2' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
 358                        -> CmmBasicBlock
 359 constructContinuation2' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
 360     BasicBlock ident (prefix++stmts++postfix)
 361     where
 362       curr_format = maybe unknown_block id $ lookup curr_ident formats
 363       unknown_block = panic "unknown BlockId in constructContinuation"
 364       prefix = case entry of
 365                  ControlEntry -> []
 366                  FunctionEntry _ -> []
 367                  ContinuationEntry formals ->
 368                      unpack_continuation curr_format
 369       postfix = case exit of
 370                   FinalBranch next -> [CmmBranch next]
 371                   FinalSwitch expr targets -> [CmmSwitch expr targets]
 372                   FinalReturn arguments ->
 373                       exit_function curr_format
 374                                     (CmmLoad (CmmReg spReg) wordRep)
 375                                     arguments
 376                   FinalJump target arguments ->
 377                       exit_function curr_format target arguments
 378                   -- TODO: do something about global saves
 379                   FinalCall next (CmmForeignCall target CmmCallConv)
 380                             results arguments saves ->
 381                                 pack_continuation curr_format cont_format ++
 382                                 [CmmJump target arguments]
 383                             where
 384                               cont_format = maybe unknown_block id $
 385                                             lookup (mkReturnPtLabel $ getUnique next) formats
 386                   FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
 387
 388 constructContinuation2 :: BlockEnv StackFormat -> BrokenBlock
 389                        -> CmmBasicBlock
 390 constructContinuation2 formats (BrokenBlock ident entry stmts _ exit) =
 391     BasicBlock ident (prefix++stmts++postfix)
 392     where
 393       curr_format = lookupWithDefaultUFM formats unknown_block ident
 394       unknown_block = panic "unknown BlockId in constructContinuation"
 395       prefix = case entry of
 396                  ControlEntry -> []
 397                  FunctionEntry _ -> []
 398                  ContinuationEntry formals ->
 399                      unpack_continuation curr_format
 400       postfix = case exit of
 401                   FinalBranch next -> [CmmBranch next]
 402                   FinalSwitch expr targets -> [CmmSwitch expr targets]
 403                   FinalReturn arguments ->
 404                       exit_function curr_format
 405                                     (CmmLoad (CmmReg spReg) wordRep)
 406                                     arguments
 407                   FinalJump target arguments ->
 408                       exit_function curr_format target arguments
 409                   -- TODO: do something about global saves
 410                   FinalCall next (CmmForeignCall target CmmCallConv)
 411                             results arguments saves ->
 412                                 pack_continuation curr_format cont_format ++
 413                                 [CmmJump target arguments]
 414                             where
 415                               cont_format = lookupWithDefaultUFM formats
 416                                               unknown_block next
 417                   FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
 418
 419 --------------------------------------------------------------------------------
 420 -- Functions that generate CmmStmt sequences
 421 -- for packing/unpacking continuations
 422 -- and entering/exiting functions
 423
 424 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
 425 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
 426   = adjust_spReg ++ jump where
 427     adjust_spReg = [
 428      CmmAssign spReg
 429      (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
 430     jump = [CmmJump target arguments]
 431
 432 enter_function :: WordOff -> [CmmStmt]
 433 enter_function max_frame_size
 434   = check_stack_limit where
 435     check_stack_limit = [
 436      CmmCondBranch
 437      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 438                     [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
 439      gc_block]
 440     gc_block = undefined -- TODO: get stack and heap checks to go to same
 441
 442 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
 443 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 444 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 445                        (StackFormat cont_id cont_frame_size cont_offsets)
 446   = save_live_values ++ set_stack_header ++ adjust_spReg where
 447     -- TODO: only save variables when actually needed
 448     save_live_values =
 449         [CmmStore
 450          (CmmRegOff
 451           spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
 452          (CmmReg reg)
 453          | (reg, offset) <- cont_offsets]
 454     set_stack_header = -- TODO: only set when needed
 455         [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     adjust_spReg =
 458         if curr_frame_size == cont_frame_size
 459         then []
 460         else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
 461
 462 -- Lazy adjustment of stack headers assumes all blocks
 463 -- that could branch to eachother (i.e. control blocks)
 464 -- have the same stack format (this causes a problem
 465 -- only for proc-point).
 466 unpack_continuation :: StackFormat -> [CmmStmt]
 467 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 468   = load_live_values where
 469     -- TODO: only save variables when actually needed
 470     load_live_values =
 471         [CmmAssign
 472          reg
 473          (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
 474          | (reg, offset) <- curr_offsets]
 475
 476 -----------------------------------------------------------------------------
 477 -- Breaking basic blocks on function calls
 478 -----------------------------------------------------------------------------
 479
 480 -----------------------------------------------------------------------------
 481 -- Takes a basic block and breaks it up into a list of broken blocks
 482 --
 483 -- Takes a basic block and returns a list of basic blocks that
 484 -- each have at most 1 CmmCall in them which must occur at the end.
 485 -- Also returns with each basic block, the variables that will
 486 -- be arguments to the continuation of the block once the call (if any)
 487 -- returns.
 488
 489 breakBlock :: [Unique] -> CmmBasicBlock -> BlockEntryInfo -> [BrokenBlock]
 490 breakBlock uniques (BasicBlock ident stmts) entry =
 491     breakBlock' uniques ident entry [] [] stmts where
 492         breakBlock' uniques current_id entry exits accum_stmts stmts =
 493             case stmts of
 494               [] -> panic "block doesn't end in jump, goto or return"
 495               [CmmJump target arguments] ->
 496                   [BrokenBlock current_id entry accum_stmts
 497                                exits
 498                                (FinalJump target arguments)]
 499               [CmmReturn arguments] ->
 500                   [BrokenBlock current_id entry accum_stmts
 501                                exits
 502                                (FinalReturn arguments)]
 503               [CmmBranch target] ->
 504                   [BrokenBlock current_id entry accum_stmts
 505                                (target:exits)
 506                                (FinalBranch target)]
 507               [CmmSwitch expr targets] ->
 508                   [BrokenBlock current_id entry accum_stmts
 509                                (mapMaybe id targets ++ exits)
 510                                (FinalSwitch expr targets)]
 511               (CmmJump _ _:_) ->
 512                   panic "jump in middle of block"
 513               (CmmReturn _:_) ->
 514                   panic "return in middle of block"
 515               (CmmBranch _:_) ->
 516                   panic "branch in middle of block"
 517               (CmmSwitch _ _:_) ->
 518                   panic ("switch in middle of block" ++ (showSDoc $ ppr stmts))
 519               (CmmCall target results arguments saves:stmts) -> block : rest
 520                   where
 521                     new_id = BlockId $ head uniques
 522                     block = BrokenBlock current_id entry accum_stmts
 523                             (new_id:exits)
 524                             (FinalCall new_id target results arguments saves)
 525                     rest = breakBlock' (tail uniques) new_id
 526                            (ContinuationEntry results) [] [] stmts
 527               (s@(CmmCondBranch test target):stmts) ->
 528                   breakBlock' uniques current_id entry
 529                               (target:exits) (accum_stmts++[s]) stmts
 530               (s:stmts) ->
 531                   breakBlock' uniques current_id entry
 532                               exits (accum_stmts++[s]) stmts
 533
 534 --------------------------------
 535 -- Convert from a BrokenBlock
 536 -- to a CmmBasicBlock so the
 537 -- liveness analysis can run
 538 -- on it.
 539 --------------------------------
 540 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
 541 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
 542     BasicBlock ident (stmts++exit_stmt)
 543     where
 544       exit_stmt =
 545           case exit of
 546             FinalBranch target -> [CmmBranch target]
 547             FinalReturn arguments -> [CmmReturn arguments]
 548             FinalJump target arguments -> [CmmJump target arguments]
 549             FinalSwitch expr targets -> [CmmSwitch expr targets]
 550             FinalCall branch_target call_target results arguments saves ->
 551                 [CmmCall call_target results arguments saves,
 552                  CmmBranch branch_target]
 553
 554 -----------------------------------------------------------------------------
 555 -- CPS a single CmmTop (proceedure)
 556 -----------------------------------------------------------------------------
 557
 558 cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
 559 cpsProc uniqSupply x@(CmmData _ _) = [x]
 560 cpsProc uniqSupply x@(CmmProc info_table ident params blocks) =
 561     --[CmmProc info_table ident params cps_blocks]
 562     cps_continuations
 563     where
 564       uniqes :: [[Unique]]
 565       uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
 566
 567       -- Break the block at each function call
 568       broken_blocks :: [BrokenBlock]
 569       broken_blocks = concat $ zipWith3 breakBlock uniqes blocks
 570                                         (FunctionEntry params:repeat ControlEntry)
 571
 572       -- Calculate live variables for each broken block
 573       live :: BlockEntryLiveness
 574       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
 575
 576       proc_points :: UniqSet BlockId
 577       proc_points = calculateProcPoints broken_blocks
 578
 579       continuations :: [Continuation]
 580       continuations = map (buildContinuation proc_points (blocksToBlockEnv broken_blocks)) (uniqSetToList proc_points)
 581
 582       -- TODO: insert proc point code here
 583       --  * Branches and switches to proc points may cause new blocks to be created
 584       --    (or proc points could leave behind phantom blocks that just jump to them)
 585       --  * Proc points might get some live variables passed as arguments
 586
 587       -- TODO: let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks
 588
 589       --procs = groupBlocksIntoContinuations live broken_blocks
 590
 591       -- Select the stack format on entry to each block
 592       formats :: BlockEnv StackFormat
 593       formats = selectStackFormat live broken_blocks
 594
 595       formats2 :: [(CLabel, StackFormat)]
 596       formats2 = selectStackFormat2 live continuations
 597
 598       -- Do the actual CPS transform
 599       cps_blocks :: [CmmBasicBlock]
 600       cps_blocks = map (constructContinuation2 formats) broken_blocks
 601
 602       cps_continuations :: [CmmTop]
 603       cps_continuations = map (constructContinuation formats2) continuations
 604
 605 --------------------------------------------------------------------------------
 606 cmmCPS :: DynFlags
 607        -> [Cmm]                 -- C-- with Proceedures
 608        -> IO [Cmm]              -- Output: CPS transformed C--
 609
 610 cmmCPS dflags abstractC = do
 611   when (dopt Opt_DoCmmLinting dflags) $
 612        do showPass dflags "CmmLint"
 613           case firstJust $ map cmmLint abstractC of
 614             Just err -> do printDump err
 615                            ghcExit dflags 1
 616             Nothing  -> return ()
 617   showPass dflags "CPS"
 618   -- TODO: check for use of branches to non-existant blocks
 619   -- TODO: check for use of Sp, SpLim, R1, R2, etc.
 620   -- TODO: find out if it is valid to create a new unique source like this
 621   uniqSupply <- mkSplitUniqSupply 'p'
 622   let supplies = listSplitUniqSupply uniqSupply
 623   let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
 624
 625   dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
 626   -- TODO: add option to dump Cmm to file
 627   return continuationC