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