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, cmmLivenessComment, cmmLiveness, CmmLive)
  10
  11 import MachOp
  12 import ForeignCall
  13 import CLabel
  14 import SMRep
  15 import Constants
  16
  17 import DynFlags
  18 import ErrUtils
  19 import Maybes
  20 import Outputable
  21 import UniqSupply
  22 import UniqFM
  23 import UniqSet
  24 import Unique
  25
  26 import Monad
  27 import IO
  28
  29 --------------------------------------------------------------------------------
  30 -- Monad for the CPSer
  31 -- Contains:
  32 --  * State for the uniqSupply
  33
  34 data CPSState = CPSState { cps_uniqs :: UniqSupply }
  35
  36 data CPS a = CPS { runCPS :: CPSState -> (CPSState, a) }
  37
  38 instance Monad CPS where
  39   return a = CPS $ \s -> (s, a)
  40   (CPS m) >>= f = CPS $ \s ->
  41     let (s', m') = m s
  42     in runCPS (f m') s'
  43
  44 --------------------------------------------------------------------------------
  45 -- Utility functions
  46
  47 getState = CPS $ \s -> (s, s)
  48 putState s = CPS $ \_ -> (s, ())
  49
  50 newLabelCPS = do
  51   state <- getState
  52   let (us1, us2) = splitUniqSupply (cps_uniqs state)
  53   putState $ state { cps_uniqs = us1 }
  54   return $ BlockId (uniqFromSupply us2)
  55
  56 mapMCmmTop :: (Monad m) => (CmmTop -> m [CmmTop]) -> Cmm -> m Cmm
  57 mapMCmmTop f (Cmm xs) = liftM Cmm $ liftM concat $ mapM f xs
  58
  59 --------------------------------------------------------------------------------
  60
  61 -- The format for the call to a continuation
  62 -- The fst is the arguments that must be passed to the continuation
  63 -- by the continuation's caller.
  64 -- The snd is the live values that must be saved on stack.
  65 -- A Nothing indicates an ignored slot.
  66 -- The head of each list is the stack top or the first parameter.
  67
  68 -- The format for live values for a particular continuation
  69 -- All on stack for now.
  70 -- Head element is the top of the stack (or just under the header).
  71 -- Nothing means an empty slot.
  72 -- Future possibilities include callee save registers (i.e. passing slots in register)
  73 -- and heap memory (not sure if that's usefull at all though, but it may
  74 -- be worth exploring the design space).
  75
  76 data BrokenBlock
  77   = BrokenBlock
  78        BlockId                  -- Like a CmmBasicBlock
  79        BlockEntryInfo           -- How this block can be entered
  80        [CmmStmt]                -- Like a CmmBasicBlock (but without
  81                                 --      the last statement)
  82        BlockExitInfo            -- How the block can be left
  83
  84 data BlockEntryInfo
  85   = FunctionEntry               -- Beginning of function
  86
  87   | ContinuationEntry           -- Return point of a call
  88         CmmFormals {- return values -}
  89   -- TODO | ProcPointEntry {- no return values, but some live might end up as params -}
  90
  91   | ControlEntry                -- A label in the input
  92
  93 data BlockExitInfo
  94   = ControlExit [BlockId] -- blocks branched to conditionally
  95     BlockId -- next block (must be a ControlEntry)
  96
  97   | ReturnExit [BlockId] -- blocks branched to conditionally
  98     CmmActuals -- return values
  99
 100   | TailCallExit [BlockId] -- blocks branched to conditionally
 101     CmmExpr -- the function to call
 102     CmmActuals -- arguments to call
 103
 104   | CallExit [BlockId] -- blocks branched to conditionally
 105     BlockId -- next block after call (must be a ContinuationEntry)
 106     CmmCallTarget -- the function to call
 107     CmmFormals -- results from call (redundant with ContinuationEntry)
 108     CmmActuals -- arguments to call
 109     (Maybe [GlobalReg]) -- registers that must be saved (TODO)
 110   -- TODO: | ProcPointExit (needed?)
 111
 112 data CPSBlockInfo
 113   = ControlBlock -- Consider whether a proc-point might want arguments on stack
 114   | ContinuationBlock [(CmmReg,MachHint)] {- params -}
 115   | EntryBlock
 116
 117 --type StackFormat = [Maybe LocalReg] -- TODO: consider params as part of format
 118 data StackFormat
 119     = StackFormat
 120          BlockId {- block that is the start of the continuation. may or may not be the current block -}
 121          WordOff {- total frame size -}
 122          [(CmmReg, WordOff)] {- local reg offsets from stack top -}
 123
 124 -- A block can be a continuation of a call
 125 -- A block can be a continuation of another block (w/ or w/o joins)
 126 -- A block can be an entry to a function
 127
 128 --------------------------------------------------------------------------------
 129 -- For now just select the continuation orders in the order they are in the set with no gaps
 130 -- TODO: select a format that keeps blocks that can jump to each other the same
 131 -- Assumed that jumps, calls
 132 selectStackFormat :: UniqFM {-BlockId-} CmmFormals -> UniqFM {-BlockId-} CmmLive -> UniqFM {-BlockId-} [(CPSBlockInfo, CmmBasicBlock)] -> UniqFM {-BlockId-} StackFormat
 133 selectStackFormat = undefined
 134 {-
 135 selectStackFormat param live blocks = fixedpoint
 136 listToUFM $ map live_to_format $ ufmToList live
 137     where
 138       live_to_format (unique, live) = (unique, format) where
 139           format = foldl extend_format
 140                     (StackFormat (BlockId unique) retAddrSizeW [])
 141                     (uniqSetToList live)
 142       extend_format :: StackFormat -> LocalReg -> StackFormat
 143       extend_format (StackFormat block size offsets) reg =
 144           StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)
 145 -}
 146
 147 selectStackFormat2 :: UniqFM {-BlockId-} CmmLive -> [BrokenBlock] -> UniqFM {-BlockId-} StackFormat
 148 selectStackFormat2 live blocks = fixedpoint dependants update (map brokenBlockId blocks) emptyUFM where
 149   blocks_ufm = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
 150   dependants ident =
 151       case lookupWithDefaultUFM blocks_ufm (panic "TODO") ident of
 152         (BrokenBlock _ _ _ (ControlExit exits next)) -> next:exits
 153         (BrokenBlock _ _ _ (ReturnExit exits _)) -> exits
 154         (BrokenBlock _ _ _ (TailCallExit exits _ _)) -> exits
 155         (BrokenBlock _ _ _ (CallExit exits _ _ _ _ _)) -> exits
 156   update ident cause formats =
 157     let BrokenBlock _ entry _ _ = lookupWithDefaultUFM blocks_ufm (panic "unknown BlockId in selectStackFormat:live") ident in
 158     case cause of
 159       -- Propagate only to blocks entered by branches (not function entry blocks or continuation entry blocks)
 160       Just cause_name ->
 161           let cause_format = lookupWithDefaultUFM formats (panic "update signaled for block not in format") cause_name
 162           in case entry of
 163             ControlEntry -> Just $ addToUFM formats ident cause_format
 164             FunctionEntry -> Nothing
 165             ContinuationEntry _ -> Nothing
 166       -- Do initial calculates for function blocks
 167       Nothing ->
 168           case entry of
 169             ControlEntry -> Nothing
 170             FunctionEntry -> Just $ addToUFM formats ident $ StackFormat ident 0 []
 171             ContinuationEntry _ -> Just $ addToUFM formats ident $ live_to_format ident $ lookupWithDefaultUFM live (panic "TODO") ident
 172   live_to_format label live =
 173       foldl extend_format
 174                 (StackFormat label retAddrSizeW [])
 175                 (uniqSetToList live)
 176   extend_format :: StackFormat -> LocalReg -> StackFormat
 177   extend_format (StackFormat block size offsets) reg =
 178       StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)
 179
 180 slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
 181
 182 transformReturn :: UniqFM {-BlockId-} CPSBlockInfo -> UniqFM {-BlockId-} StackFormat -> CmmBasicBlock -> CmmBasicBlock
 183 transformReturn block_infos formats (BasicBlock ident stmts) =
 184   -- NOTE: assumes that return/jump can *only* appear at end of block
 185   case last stmts of
 186     CmmReturn arguments ->
 187         BasicBlock ident $
 188                   (init stmts) ++
 189                   exit_function curr_format (CmmLoad (CmmReg spReg) wordRep) arguments
 190     CmmJump target arguments ->
 191         BasicBlock ident $
 192                   (init stmts) ++
 193                   exit_function curr_format target arguments
 194     _ -> BasicBlock ident stmts
 195   where
 196   curr_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident
 197
 198 destructContinuation :: UniqFM {-BlockId-} CPSBlockInfo -> UniqFM {-BlockId-} StackFormat -> CmmBasicBlock -> CmmBasicBlock
 199 destructContinuation block_infos formats (BasicBlock ident stmts) =
 200   case info of
 201     ControlBlock -> BasicBlock ident stmts
 202     ContinuationBlock _ -> BasicBlock ident (unpack_continuation curr_format ++ stmts)
 203   where
 204   info = lookupWithDefaultUFM block_infos (panic $ "info: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident
 205   curr_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident
 206
 207 constructContinuation2 :: UniqFM {-BlockId-} StackFormat -> BrokenBlock -> CmmBasicBlock
 208 constructContinuation2 formats (BrokenBlock ident entry stmts exit) =
 209     BasicBlock ident (prefix++stmts++postfix)
 210     where
 211       curr_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident
 212       prefix = case entry of
 213                  ControlEntry -> []
 214                  FunctionEntry -> []
 215                  ContinuationEntry formals -> unpack_continuation curr_format
 216       postfix = case exit of
 217                   ControlExit _ next -> [CmmBranch next]
 218                   ReturnExit _ arguments -> exit_function curr_format (CmmLoad (CmmReg spReg) wordRep) arguments
 219                   TailCallExit _ target arguments -> exit_function curr_format target arguments
 220                   -- TODO: do something about global saves
 221                   CallExit _ next (CmmForeignCall target CmmCallConv) results arguments saves ->
 222                       let cont_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique next)) next
 223                       in pack_continuation curr_format cont_format ++
 224                              [CmmJump target arguments]
 225                   CallExit _ next _ results arguments saves -> panic "unimplemented CmmCall"
 226
 227 constructContinuation :: UniqFM {-BlockId-} CPSBlockInfo -> UniqFM {-BlockId-} StackFormat -> CmmBasicBlock -> CmmBasicBlock
 228 constructContinuation block_infos formats (BasicBlock ident stmts) =
 229   case last $ init stmts of
 230     -- TODO: global_saves
 231     --CmmCall (CmmForeignCall target CmmCallConv) results arguments (Just []) -> --TODO: handle globals
 232     CmmCall (CmmForeignCall target CmmCallConv) results arguments _ ->
 233         BasicBlock ident $
 234                    init (init stmts) ++
 235                    pack_continuation curr_format cont_format ++
 236                    [CmmJump target arguments]
 237     CmmCall target results arguments _ -> panic "unimplemented CmmCall"
 238     -- TODO: branches for proc-points
 239     -- _ -> BasicBlock ident $ (init stmts) ++ build_block_branch
 240     _ -> BasicBlock ident stmts
 241   where
 242   info = lookupWithDefaultUFM block_infos (panic $ "info: unknown block " ++ (showSDoc $ ppr $ getUnique next_block)) next_block
 243   cont_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique next_block)) next_block
 244   curr_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique next_block)) ident
 245   next_block = case last stmts of
 246     CmmBranch next -> next
 247     -- TODO: blocks with jump at end
 248     -- TODO: blocks with return at end
 249     _ -> panic $ "basic block without a branch at the end (unimplemented) " ++ (showSDoc $ ppr $ stmts)
 250   next_block_as_proc_expr = CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next_block
 251   block_needs_call = True -- TODO: use a table (i.e. proc-point)
 252   build_block_branch =
 253     if block_needs_call
 254        then [CmmJump next_block_as_proc_expr [] {- TODO: pass live -}] {- NOTE: a block can never be both a continuation and a controll block -}
 255        else [CmmBranch next_block]
 256
 257 --------------------------------------------------------------------------------
 258 -- Functions that generate CmmStmt sequences
 259 -- for packing/unpacking continuations
 260 -- and entering/exiting functions
 261
 262 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
 263 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
 264   = adjust_spReg ++ jump where
 265     adjust_spReg = [
 266      CmmAssign spReg
 267      (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
 268     jump = [CmmJump target arguments]
 269
 270 enter_function :: WordOff -> [CmmStmt]
 271 enter_function max_frame_size
 272   = check_stack_limit where
 273     check_stack_limit = [
 274      CmmCondBranch
 275      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 276                     [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
 277      gc_block]
 278     gc_block = undefined -- TODO: get stack and heap checks to go to same
 279
 280 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
 281 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 282 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 283                        (StackFormat cont_id cont_frame_size cont_offsets)
 284   = save_live_values ++ set_stack_header ++ adjust_spReg where
 285     -- TODO: only save variables when actually needed
 286     save_live_values =
 287         [CmmStore
 288          (CmmRegOff
 289           spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
 290          (CmmReg reg)
 291          | (reg, offset) <- cont_offsets]
 292     set_stack_header = -- TODO: only set when needed
 293         [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
 294     continuation_function = CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique cont_id
 295     adjust_spReg =
 296         if curr_frame_size == cont_frame_size
 297         then []
 298         else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
 299
 300 -- Lazy adjustment of stack headers assumes all blocks
 301 -- that could branch to eachother (i.e. control blocks)
 302 -- have the same stack format (this causes a problem
 303 -- only for proc-point).
 304 unpack_continuation :: StackFormat -> [CmmStmt]
 305 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 306   = load_live_values where
 307     -- TODO: only save variables when actually needed
 308     load_live_values =
 309         [CmmAssign
 310          reg
 311          (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
 312          | (reg, offset) <- curr_offsets]
 313
 314 -- TODO: TBD when to adjust the stack
 315
 316 cpsProc :: CmmTop -> CPS [CmmTop]
 317 cpsProc x@(CmmData _ _) = return [x]
 318 cpsProc x@(CmmProc info_table ident params blocks) = do
 319
 320   broken_blocks <- liftM concat $ mapM breakBlock blocks
 321   broken_blocks2 <- liftM concat (zipWithM breakBlock2 blocks (FunctionEntry:repeat ControlEntry))
 322         -- broken_blocks :: [BrokenBlock]
 323
 324    let live = cmmLiveness (map snd broken_blocks)
 325   let live2 :: BlockEntryLiveness
 326       live2 = cmmLiveness2 broken_blocks2
 327
 328   let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks
 329
 330   let formats = selectStackFormat (panic "params to selectStackFormat" {-TODO-}) live (undefined)
 331   let formats2 :: BlockEnv StackFormat  -- Stack format on entry
 332       formats2 = selectStackFormat2 live2 broken_blocks2
 333
 334   let block_infos = listToUFM $ map (\(info, block) -> (blockId block, info)) broken_blocks
 335   --let blocks_with_live' = map (constructContinuation block_infos formats) blocks_with_live
 336   --let blocks_with_live'' = map (destructContinuation block_infos formats) blocks_with_live'
 337   --let blocks_with_live''' = map (transformReturn block_infos formats) blocks_with_live''
 338
 339   return $ [CmmProc info_table ident params $ map (constructContinuation2 formats2) broken_blocks2]
 340 {-
 341   return $ [CmmProc info_table ident params $
 342             map (constructContinuation block_infos formats .
 343                  destructContinuation block_infos formats .
 344                  transformReturn block_infos formats)
 345             blocks_with_live]
 346 -}
 347
 348 --------------------------------------------------------------------------------
 349 -- Takes a basic block and returns a list of basic blocks that
 350 -- each have at most 1 CmmCall in them which must occur at the end.
 351 -- Also returns with each basic block, the variables that will
 352 -- be arguments to the continuation of the block once the call (if any) returns.
 353
 354 cmmBlockifyCalls :: [CmmBasicBlock] -> CPS [(CPSBlockInfo, CmmBasicBlock)]
 355 cmmBlockifyCalls blocks = liftM concat $ mapM breakBlock blocks
 356
 357 -- [(CmmReg,MachHint)] is the results from the previous block that are expected as parameters
 358 --breakBlock :: CmmBasicBlock -> CPS [(Maybe BlockId, CmmBasicBlock)]
 359 breakBlock :: CmmBasicBlock -> CPS [(CPSBlockInfo, CmmBasicBlock)]
 360 breakBlock (BasicBlock ident stmts) = breakBlock' ident ControlBlock [] stmts
 361
 362 breakBlock' current_id block_info accum_stmts [] =
 363   return [(block_info, BasicBlock current_id accum_stmts)]
 364 -- TODO: notice a call just before a branch, jump, call, etc.
 365 breakBlock' current_id block_info accum_stmts (stmt@(CmmCall _ results _ _):stmts) = do
 366   new_id <- newLabelCPS
 367   let new_block = (block_info, BasicBlock current_id (accum_stmts ++ [stmt, CmmBranch new_id]))
 368   rest <- breakBlock' new_id (ContinuationBlock results) [] stmts
 369   return $ (new_block:rest)
 370 breakBlock' current_id arguments accum_stmts (stmt:stmts) =
 371   breakBlock' current_id arguments (accum_stmts ++ [stmt]) stmts
 372
 373 breakBlock2 (BasicBlock ident stmts) entry = breakBlock2' ident entry [] [] stmts
 374
 375 breakBlock2' current_id block_info exits accum_stmts [] =
 376     panic "block doesn't end in jump, goto or return"
 377 breakBlock2' current_id entry exits accum_stmts [CmmJump target arguments] =
 378     return [BrokenBlock current_id entry accum_stmts (TailCallExit exits target arguments)]
 379 breakBlock2' current_id entry exits accum_stmts [CmmReturn arguments] =
 380     return [BrokenBlock current_id entry accum_stmts (ReturnExit exits arguments)]
 381 breakBlock2' current_id entry exits accum_stmts [CmmBranch target] =
 382     return [BrokenBlock current_id entry accum_stmts (ControlExit exits target)]
 383 breakBlock2' _ _ _ _ (CmmJump _ _:_) = panic "jump in middle of block"
 384 breakBlock2' _ _ _ _ (CmmReturn _:_) = panic "return in middle of block"
 385 breakBlock2' _ _ _ _ (CmmBranch _:_) = panic "branch in middle of block"
 386 breakBlock2' _ _ _ _ (CmmSwitch _ _:_) = panic "switch in block not implemented"
 387 breakBlock2' current_id entry exits accum_stmts (CmmCall target results arguments saves:stmts) = do
 388   new_id <- newLabelCPS
 389   rest <- breakBlock2' new_id (ContinuationEntry results) [] [] stmts
 390   return $ BrokenBlock current_id entry accum_stmts (CallExit exits new_id target results arguments saves) : rest
 391 breakBlock2' current_id entry exits accum_stmts (s@(CmmCondBranch test target):stmts) =
 392     breakBlock2' current_id entry (target:exits) (accum_stmts++[s]) stmts
 393 breakBlock2' current_id entry exits accum_stmts (s:stmts) =
 394     breakBlock2' current_id entry exits (accum_stmts++[s]) stmts
 395
 396 brokenBlockTargets (BrokenBlock _ _ _ (TailCallExit exits _ _)) = exits
 397 brokenBlockTargets (BrokenBlock _ _ _ (ReturnExit exits _)) = exits
 398 brokenBlockTargets (BrokenBlock _ _ _ (ControlExit exits target)) = target:exits
 399 brokenBlockTargets (BrokenBlock _ _ _ (CallExit exits next _ _ _ _)) = next:exits
 400
 401 brokenBlockId (BrokenBlock ident _ _ _) = ident
 402
 403 cmmBrokenBlockSources ::
 404     [BrokenBlock] -> UniqFM {-BlockId-} (UniqSet BlockId)
 405 cmmBrokenBlockSources blocks = foldr aux emptyUFM blocks where
 406     aux block sourcesUFM  =
 407         foldr add_source_edges sourcesUFM targets where
 408             add_source_edges t ufm =
 409                 addToUFM_Acc (flip addOneToUniqSet) unitUniqSet ufm t ident
 410             targets = brokenBlockTargets block
 411             ident = brokenBlockId block
 412
 413 cmmBrokenBlockNames :: [BrokenBlock] -> UniqFM {-BlockId-} BrokenBlock
 414 cmmBrokenBlockNames blocks = listToUFM $ map block_name blocks where
 415     block_name b = (brokenBlockId b, b)
 416
 417 cmmBrokenBlockDependants :: UniqFM {-BlockId-} (UniqSet BlockId) -> BlockId -> [BlockId]
 418 cmmBrokenBlockDependants sources ident =
 419     uniqSetToList $ lookupWithDefaultUFM sources emptyUniqSet ident
 420
 421 cmmBrokenBlockLive :: UniqFM {-BlockId-} CmmLive -> BrokenBlock -> CmmLive
 422 cmmBrokenBlockLive other_live (BrokenBlock _ _ stmts exit) =
 423     foldr ((.) . (cmmStmtLive other_live)) id stmts live_at_end
 424     where
 425       live_at_end =
 426           case exit of
 427             ControlExit _ _ -> emptyUniqSet
 428             ReturnExit _ actuals -> foldr ((.) . cmmExprLive) id (map fst actuals) emptyUniqSet
 429             TailCallExit _ target actuals ->
 430                 cmmExprLive target $ foldr ((.) . cmmExprLive) id (map fst actuals) $ emptyUniqSet
 431             CallExit _ _ target _ actuals live ->
 432                 target_liveness $
 433                 foldr ((.) . cmmExprLive) id (map fst actuals) $
 434                 emptyUniqSet
 435                 where
 436                   only_local_regs [] = []
 437                   only_local_regs ((CmmGlobal _,_):args) = only_local_regs args
 438                   only_local_regs ((CmmLocal r,_):args) = r:only_local_regs args
 439                   target_liveness =
 440                     case target of
 441                       (CmmForeignCall target _) -> cmmExprLive target
 442                       (CmmPrim _) -> id
 443
 444
 445 cmmBrokenBlockUpdate ::
 446     UniqFM {-BlockId-} BrokenBlock
 447     -> BlockId
 448     -> Maybe BlockId
 449     -> UniqFM {-BlockId-} CmmLive
 450     -> Maybe (UniqFM {-BlockId-} CmmLive)
 451 cmmBrokenBlockUpdate blocks node _ state =
 452     let old_live = lookupWithDefaultUFM state (panic "unknown block id during liveness analysis") node
 453         block = lookupWithDefaultUFM blocks (panic "unknown block id during liveness analysis") node
 454         new_live = cmmBrokenBlockLive state block
 455     in if (sizeUniqSet old_live) == (sizeUniqSet new_live)
 456        then Nothing
 457        else Just $ addToUFM state node new_live
 458
 459
 460 cmmLiveness2 :: [BrokenBlock] -> UniqFM {-BlockId-} CmmLive
 461 cmmLiveness2 blocks =
 462     fixedpoint (cmmBrokenBlockDependants sources) (cmmBrokenBlockUpdate blocks')
 463                (map brokenBlockId blocks) (listToUFM [(brokenBlockId b, emptyUniqSet) | b <- blocks]) where
 464                    sources = cmmBrokenBlockSources blocks
 465                    blocks' = cmmBrokenBlockNames blocks
 466
 467 --------------------------------------------------------------------------------
 468 cmmCPS :: DynFlags
 469        -> [Cmm]                 -- C-- with Proceedures
 470        -> IO [Cmm]              -- Output: CPS transformed C--
 471
 472 cmmCPS dflags abstractC = do
 473   when (dopt Opt_DoCmmLinting dflags) $
 474        do showPass dflags "CmmLint"
 475           case firstJust $ map cmmLint abstractC of
 476             Just err -> do printDump err
 477                            ghcExit dflags 1
 478             Nothing  -> return ()
 479   showPass dflags "CPS"
 480   -- TODO: check for use of branches to non-existant blocks
 481   -- TODO: check for use of Sp, SpLim, R1, R2, etc.
 482   -- continuationC <- return abstractC
 483   -- TODO: find out if it is valid to create a new unique source like this
 484   uniqSupply <- mkSplitUniqSupply 'p'
 485   let (_, continuationC) = runCPS (mapM (mapMCmmTop cpsProc) abstractC) (CPSState uniqSupply)
 486
 487   dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
 488   -- TODO: add option to dump Cmm to file
 489   return continuationC