compiler/cmm/CmmBrokenBlock.hs

   1 module CmmBrokenBlock (
   2   BrokenBlock(..),
   3   BlockEntryInfo(..),
   4   FinalStmt(..),
   5   breakBlock,
   6   cmmBlockFromBrokenBlock,
   7   blocksToBlockEnv,
   8   adaptBlockToFormat,
   9   selectContinuations,
  10   ContFormat,
  11   makeContinuationEntries,
  12   ) where
  13
  14 #include "HsVersions.h"
  15
  16 import Cmm
  17 import CmmUtils
  18 import CLabel
  19 import MachOp (MachHint(..))
  20
  21 import CgUtils (callerSaveVolatileRegs)
  22 import ClosureInfo
  23
  24 import Maybes
  25 import List
  26 import Panic
  27 import UniqSupply
  28 import Unique
  29 import UniqFM
  30
  31 -- This module takes a 'CmmBasicBlock' which might have 'CmmCall'
  32 -- statements in it with 'CmmSafe' set and breaks it up at each such call.
  33 -- It also collects information about the block for later use
  34 -- by the CPS algorithm.
  35
  36 -----------------------------------------------------------------------------
  37 -- Data structures
  38 -----------------------------------------------------------------------------
  39
  40 -- |Similar to a 'CmmBlock' with a little extra information
  41 -- to help the CPS analysis.
  42 data BrokenBlock
  43   = BrokenBlock {
  44       brokenBlockId :: BlockId, -- ^ The block's label like a 'CmmBasicBlock'
  45       brokenBlockEntry :: BlockEntryInfo,
  46                                 -- ^ Ways this block can be entered
  47
  48       brokenBlockStmts :: [CmmStmt],
  49                                 -- ^ Body like a CmmBasicBlock
  50                                 -- (but without the last statement)
  51
  52       brokenBlockTargets :: [BlockId],
  53                                 -- ^ Blocks that this block could
  54                                 -- branch to either by conditional
  55                                 -- branches or via the last statement
  56
  57       brokenBlockExit :: FinalStmt
  58                                 -- ^ The final statement of the block
  59     }
  60
  61 -- | How a block could be entered
  62 data BlockEntryInfo
  63   = FunctionEntry               -- ^ Block is the beginning of a function
  64       CmmInfo                   -- ^ Function header info
  65       CLabel                    -- ^ The function name
  66       CmmFormals                -- ^ Aguments to function
  67
  68   | ContinuationEntry           -- ^ Return point of a function call
  69       CmmFormals                -- ^ return values (argument to continuation)
  70       C_SRT                     -- ^ SRT for the continuation's info table
  71       Bool                      -- ^ True <=> GC block so ignore stack size
  72
  73   | ControlEntry                -- ^ Any other kind of block.
  74                                 -- Only entered due to control flow.
  75
  76   -- TODO: Consider adding ProcPointEntry
  77   -- no return values, but some live might end up as
  78   -- params or possibly in the frame
  79
  80 data ContFormat = ContFormat
  81       CmmHintFormals            -- ^ return values (argument to continuation)
  82       C_SRT                     -- ^ SRT for the continuation's info table
  83       Bool                      -- ^ True <=> GC block so ignore stack size
  84   deriving (Eq)
  85
  86 -- | Final statement in a 'BlokenBlock'.
  87 -- Constructors and arguments match those in 'Cmm',
  88 -- but are restricted to branches, returns, jumps, calls and switches
  89 data FinalStmt
  90   = FinalBranch                 -- ^ Same as 'CmmBranch'
  91       BlockId                   -- ^ Target must be a ControlEntry
  92
  93   | FinalReturn                 -- ^ Same as 'CmmReturn'
  94       CmmActuals                -- ^ Return values
  95
  96   | FinalJump                   -- ^ Same as 'CmmJump'
  97       CmmExpr                   -- ^ The function to call
  98       CmmActuals                -- ^ Arguments of the call
  99
 100   | FinalCall                   -- ^ Same as 'CmmForeignCall'
 101                                 -- followed by 'CmmGoto'
 102       BlockId                   -- ^ Target of the 'CmmGoto'
 103                                 -- (must be a 'ContinuationEntry')
 104       CmmCallTarget             -- ^ The function to call
 105       CmmHintFormals                -- ^ Results from call
 106                                 -- (redundant with ContinuationEntry)
 107       CmmActuals                -- ^ Arguments to call
 108       C_SRT                     -- ^ SRT for the continuation's info table
 109       Bool                      -- ^ True <=> GC block so ignore stack size
 110
 111   | FinalSwitch                 -- ^ Same as a 'CmmSwitch'
 112       CmmExpr                   -- ^ Scrutinee (zero based)
 113       [Maybe BlockId]           -- ^ Targets
 114
 115 -----------------------------------------------------------------------------
 116 -- Operations for broken blocks
 117 -----------------------------------------------------------------------------
 118
 119 -- Naively breaking at *every* CmmCall leads to sub-optimal code.
 120 -- In particular, a CmmCall followed by a CmmBranch would result
 121 -- in a continuation that has the single CmmBranch statement in it.
 122 -- It would be better have the CmmCall directly return to the block
 123 -- that the branch jumps to.
 124 --
 125 -- This requires the target of the branch to look like the parameter
 126 -- format that the CmmCall is expecting.  If other CmmCall/CmmBranch
 127 -- sequences go to the same place they might not be expecting the
 128 -- same format.  So this transformation uses the following solution.
 129 -- First the blocks are broken up but none of the blocks are marked
 130 -- as continuations yet.  This is the 'breakBlock' function.
 131 -- Second, the blocks "vote" on what other blocks need to be continuations
 132 -- and how they should be layed out.  Plurality wins, but other selection
 133 -- methods could be selected at a later time.
 134 -- This is the 'selectContinuations' function.
 135 -- Finally, the blocks are upgraded to 'ContEntry' continuations
 136 -- based on the results with the 'makeContinuationEntries' function,
 137 -- and the blocks that didn't get the format they wanted for their
 138 -- targets get a small adaptor block created for them by
 139 -- the 'adaptBlockToFormat' function.
 140 -- could be
 141
 142 breakProc ::
 143     [BlockId]                   -- ^ Any GC blocks that should be special
 144     -> [[Unique]]               -- ^ An infinite list of uniques
 145                                 -- to create names of the new blocks with
 146     -> CmmInfo                  -- ^ Info table for the procedure
 147     -> CLabel                   -- ^ Name of the procedure
 148     -> CmmFormals               -- ^ Parameters of the procedure
 149     -> [CmmBasicBlock]          -- ^ Blocks of the procecure
 150                                 -- (First block is the entry block)
 151     -> [BrokenBlock]
 152
 153 breakProc gc_block_idents uniques info ident params blocks =
 154     let
 155         (adaptor_uniques : block_uniques) = uniques
 156
 157         broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
 158         broken_blocks =
 159             let new_blocks =
 160                     zipWith3 (breakBlock gc_block_idents)
 161                              block_uniques
 162                              blocks
 163                              (FunctionEntry info ident params :
 164                               repeat ControlEntry)
 165             in (concatMap fst new_blocks, concatMap snd new_blocks)
 166
 167         selected = selectContinuations (fst broken_blocks)
 168
 169     in map (makeContinuationEntries selected) $
 170        concat $
 171        zipWith (adaptBlockToFormat selected)
 172                adaptor_uniques
 173                (snd broken_blocks)
 174
 175 -----------------------------------------------------------------------------
 176 -- | Takes a 'CmmBasicBlock' and breaks it up into a list of 'BrokenBlock'
 177 -- by splitting on each 'CmmCall' in the 'CmmBasicBlock'.
 178
 179 breakBlock ::
 180     [BlockId]                   -- ^ Any GC blocks that should be special
 181     -> [Unique]                 -- ^ An infinite list of uniques
 182                                 -- to create names of the new blocks with
 183     -> CmmBasicBlock            -- ^ Input block to break apart
 184     -> BlockEntryInfo           -- ^ Info for the first created 'BrokenBlock'
 185     -> ([(BlockId, ContFormat)], [BrokenBlock])
 186 breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry =
 187     breakBlock' uniques ident entry [] [] stmts
 188     where
 189       breakBlock' uniques current_id entry exits accum_stmts stmts =
 190           case stmts of
 191             [] -> panic "block doesn't end in jump, goto, return or switch"
 192
 193             -- Last statement.  Make the 'BrokenBlock'
 194             [CmmJump target arguments] ->
 195                 ([],
 196                  [BrokenBlock current_id entry accum_stmts
 197                               exits
 198                               (FinalJump target arguments)])
 199             [CmmReturn arguments] ->
 200                 ([],
 201                  [BrokenBlock current_id entry accum_stmts
 202                              exits
 203                              (FinalReturn arguments)])
 204             [CmmBranch target] ->
 205                 ([],
 206                  [BrokenBlock current_id entry accum_stmts
 207                              (target:exits)
 208                              (FinalBranch target)])
 209             [CmmSwitch expr targets] ->
 210                 ([],
 211                  [BrokenBlock current_id entry accum_stmts
 212                              (mapMaybe id targets ++ exits)
 213                              (FinalSwitch expr targets)])
 214
 215             -- These shouldn't happen in the middle of a block.
 216             -- They would cause dead code.
 217             (CmmJump _ _:_) -> panic "jump in middle of block"
 218             (CmmReturn _:_) -> panic "return in middle of block"
 219             (CmmBranch _:_) -> panic "branch in middle of block"
 220             (CmmSwitch _ _:_) -> panic "switch in middle of block"
 221
 222             -- Detect this special case to remain an inverse of
 223             -- 'cmmBlockFromBrokenBlock'
 224             [CmmCall target results arguments (CmmSafe srt),
 225              CmmBranch next_id] ->
 226                 ([cont_info], [block])
 227                 where
 228                   cont_info = (next_id,
 229                                ContFormat results srt
 230                                               (ident `elem` gc_block_idents))
 231                   block = do_call current_id entry accum_stmts exits next_id
 232                                 target results arguments srt
 233
 234             -- Break the block on safe calls (the main job of this function)
 235             (CmmCall target results arguments (CmmSafe srt) : stmts) ->
 236                 (cont_info : cont_infos, block : blocks)
 237                 where
 238                   next_id = BlockId $ head uniques
 239                   block = do_call current_id entry accum_stmts exits next_id
 240                                   target results arguments srt
 241                   cont_info = (next_id,
 242                                ContFormat results srt
 243                                               (ident `elem` gc_block_idents))
 244                   (cont_infos, blocks) = breakBlock' (tail uniques) next_id
 245                                          ControlEntry [] [] stmts
 246
 247             -- Unsafe calls don't need a continuation
 248             -- but they do need to be expanded
 249             (CmmCall target results arguments CmmUnsafe : stmts) ->
 250                 breakBlock' remaining_uniques current_id entry exits
 251                             (accum_stmts ++
 252                              arg_stmts ++
 253                              caller_save ++
 254                              [CmmCall target results new_args CmmUnsafe] ++
 255                              caller_load)
 256                             stmts
 257                 where
 258                   (remaining_uniques, arg_stmts, new_args) =
 259                       loadArgsIntoTemps uniques arguments
 260                   (caller_save, caller_load) = callerSaveVolatileRegs (Just [])
 261
 262             -- Default case.  Just keep accumulating statements
 263             -- and branch targets.
 264             (s : stmts) ->
 265                 breakBlock' uniques current_id entry
 266                             (cond_branch_target s++exits)
 267                             (accum_stmts++[s])
 268                             stmts
 269
 270       do_call current_id entry accum_stmts exits next_id
 271               target results arguments srt =
 272           BrokenBlock current_id entry accum_stmts (next_id:exits)
 273                       (FinalCall next_id target results arguments srt
 274                                      (current_id `elem` gc_block_idents))
 275
 276       cond_branch_target (CmmCondBranch _ target) = [target]
 277       cond_branch_target _ = []
 278
 279 -----------------------------------------------------------------------------
 280
 281 selectContinuations :: [(BlockId, ContFormat)] -> [(BlockId, ContFormat)]
 282 selectContinuations needed_continuations = formats
 283     where
 284       formats = map select_format format_groups
 285       format_groups = groupBy by_target needed_continuations
 286       by_target x y = fst x == fst y
 287
 288       select_format formats = winner
 289           where
 290             winner = head $ head $ sortBy more_votes format_votes
 291             format_votes = groupBy by_format formats
 292             by_format x y = snd x == snd y
 293             more_votes x y = compare (length y) (length x)
 294               -- sort so the most votes goes *first*
 295               -- (thus the order of x and y is reversed)
 296
 297 makeContinuationEntries formats
 298                         block@(BrokenBlock ident entry stmts targets exit) =
 299     case lookup ident formats of
 300       Nothing -> block
 301       Just (ContFormat formals srt is_gc) ->
 302           BrokenBlock ident (ContinuationEntry (map fst formals) srt is_gc)
 303                       stmts targets exit
 304
 305 adaptBlockToFormat :: [(BlockId, ContFormat)]
 306                    -> Unique
 307                    -> BrokenBlock
 308                    -> [BrokenBlock]
 309 adaptBlockToFormat formats unique
 310                    block@(BrokenBlock ident entry stmts targets
 311                                       exit@(FinalCall next target formals
 312                                                       actuals srt is_gc)) =
 313     if format_formals == formals &&
 314        format_srt == srt &&
 315        format_is_gc == is_gc
 316     then [block] -- Woohoo! This block got the continuation format it wanted
 317     else [adaptor_block, revised_block]
 318            -- This block didn't get the format it wanted for the
 319            -- continuation, so we have to build an adaptor.
 320     where
 321       (ContFormat format_formals format_srt format_is_gc) =
 322           maybe unknown_block id $ lookup next formats
 323       unknown_block = panic "unknown block in adaptBlockToFormat"
 324
 325       revised_block = BrokenBlock ident entry stmts revised_targets revised_exit
 326       revised_targets = adaptor_ident : delete next targets
 327       revised_exit = FinalCall
 328                        adaptor_ident -- ^ The only part that changed
 329                        target formals actuals srt is_gc
 330
 331       adaptor_block = mk_adaptor_block adaptor_ident
 332                   (ContinuationEntry (map fst formals) srt is_gc)
 333                   next format_formals
 334       adaptor_ident = BlockId unique
 335
 336       mk_adaptor_block :: BlockId -> BlockEntryInfo -> BlockId -> CmmHintFormals -> BrokenBlock
 337       mk_adaptor_block ident entry next formals =
 338           BrokenBlock ident entry [] [next] exit
 339               where
 340                 exit = FinalJump
 341                          (CmmLit (CmmLabel (mkReturnPtLabel (getUnique next))))
 342                          (map formal_to_actual format_formals)
 343
 344                 formal_to_actual (reg, hint) = ((CmmReg (CmmLocal reg)), hint)
 345                 -- TODO: Check if NoHint is right.  We're
 346                 -- jumping to a C-- function not a foreign one
 347                 -- so it might always be right.
 348 adaptBlockToFormat _ _ block = [block]
 349
 350 -----------------------------------------------------------------------------
 351 -- | Convert from a BrokenBlock back to an equivalent CmmBasicBlock
 352 -- Needed by liveness analysis
 353 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
 354 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
 355     BasicBlock ident (stmts++exit_stmt)
 356     where
 357       exit_stmt =
 358           case exit of
 359             FinalBranch target -> [CmmBranch target]
 360             FinalReturn arguments -> [CmmReturn arguments]
 361             FinalJump target arguments -> [CmmJump target arguments]
 362             FinalSwitch expr targets -> [CmmSwitch expr targets]
 363             FinalCall branch_target call_target results arguments srt _ ->
 364                 [CmmCall call_target results arguments (CmmSafe srt),
 365                  CmmBranch branch_target]
 366
 367 -----------------------------------------------------------------------------
 368 -- | Build a mapping so we can lookup a 'BrokenBlock' by its 'BlockId'
 369 blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
 370 blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks