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 -- See Note [An example of CPS conversion]
  63 data BlockEntryInfo
  64   = FunctionEntry               -- ^ Block is the beginning of a function
  65       CmmInfo                   -- ^ Function header info
  66       CLabel                    -- ^ The function name
  67       CmmFormals                -- ^ Aguments to function
  68                 -- Only the formal parameters are live
  69
  70   | ContinuationEntry           -- ^ Return point of a function call
  71       CmmFormals                -- ^ return values (argument to continuation)
  72       C_SRT                     -- ^ SRT for the continuation's info table
  73       Bool                      -- ^ True <=> GC block so ignore stack size
  74                 -- Live variables, other than
  75                 -- the return values, are on the stack
  76
  77   | ControlEntry                -- ^ Any other kind of block.
  78                                 -- Only entered due to control flow.
  79
  80   -- TODO: Consider adding ProcPointEntry
  81   -- no return values, but some live might end up as
  82   -- params or possibly in the frame
  83
  84 {-      Note [An example of CPS conversion]
  85
  86 This is NR's and SLPJ's guess about how things might work;
  87 it may not be consistent with the actual code (particularly
  88 in the matter of what's in parameters and what's on the stack).
  89
  90 f(x,y) {
  91    if x>2 then goto L
  92    x = x+1
  93 L: if x>1 then y = g(y)
  94         else x = x+1 ;
  95    return( x+y )
  96 }
  97         BECOMES
  98
  99 f(x,y) {   // FunctionEntry
 100    if x>2 then goto L
 101    x = x+1
 102 L:         // ControlEntry
 103    if x>1 then push x; push f1; jump g(y)
 104         else x=x+1; jump f2(x, y)
 105 }
 106
 107 f1(y) {    // ContinuationEntry
 108   pop x; jump f2(x, y);
 109 }
 110
 111 f2(x, y) { // ProcPointEntry
 112   return (z+y);
 113 }
 114
 115 -}
 116
 117 data ContFormat = ContFormat
 118       CmmHintFormals            -- ^ return values (argument to continuation)
 119       C_SRT                     -- ^ SRT for the continuation's info table
 120       Bool                      -- ^ True <=> GC block so ignore stack size
 121   deriving (Eq)
 122
 123 -- | Final statement in a 'BlokenBlock'.
 124 -- Constructors and arguments match those in 'Cmm',
 125 -- but are restricted to branches, returns, jumps, calls and switches
 126 data FinalStmt
 127   = FinalBranch                 -- ^ Same as 'CmmBranch'
 128       BlockId                   -- ^ Target must be a ControlEntry
 129
 130   | FinalReturn                 -- ^ Same as 'CmmReturn'
 131       CmmActuals                -- ^ Return values
 132
 133   | FinalJump                   -- ^ Same as 'CmmJump'
 134       CmmExpr                   -- ^ The function to call
 135       CmmActuals                -- ^ Arguments of the call
 136
 137   | FinalCall                   -- ^ Same as 'CmmCallee'
 138                                 -- followed by 'CmmGoto'
 139       BlockId                   -- ^ Target of the 'CmmGoto'
 140                                 -- (must be a 'ContinuationEntry')
 141       CmmCallTarget             -- ^ The function to call
 142       CmmHintFormals                -- ^ Results from call
 143                                 -- (redundant with ContinuationEntry)
 144       CmmActuals                -- ^ Arguments to call
 145       C_SRT                     -- ^ SRT for the continuation's info table
 146       CmmReturnInfo             -- ^ Does the function return?
 147       Bool                      -- ^ True <=> GC block so ignore stack size
 148
 149   | FinalSwitch                 -- ^ Same as a 'CmmSwitch'
 150       CmmExpr                   -- ^ Scrutinee (zero based)
 151       [Maybe BlockId]           -- ^ Targets
 152
 153 -----------------------------------------------------------------------------
 154 -- Operations for broken blocks
 155 -----------------------------------------------------------------------------
 156
 157 -- Naively breaking at *every* CmmCall leads to sub-optimal code.
 158 -- In particular, a CmmCall followed by a CmmBranch would result
 159 -- in a continuation that has the single CmmBranch statement in it.
 160 -- It would be better have the CmmCall directly return to the block
 161 -- that the branch jumps to.
 162 --
 163 -- This requires the target of the branch to look like the parameter
 164 -- format that the CmmCall is expecting.  If other CmmCall/CmmBranch
 165 -- sequences go to the same place they might not be expecting the
 166 -- same format.  So this transformation uses the following solution.
 167 -- First the blocks are broken up but none of the blocks are marked
 168 -- as continuations yet.  This is the 'breakBlock' function.
 169 -- Second, the blocks "vote" on what other blocks need to be continuations
 170 -- and how they should be layed out.  Plurality wins, but other selection
 171 -- methods could be selected at a later time.
 172 -- This is the 'selectContinuations' function.
 173 -- Finally, the blocks are upgraded to 'ContEntry' continuations
 174 -- based on the results with the 'makeContinuationEntries' function,
 175 -- and the blocks that didn't get the format they wanted for their
 176 -- targets get a small adaptor block created for them by
 177 -- the 'adaptBlockToFormat' function.
 178 -- could be
 179
 180 breakProc ::
 181     [BlockId]                   -- ^ Any GC blocks that should be special
 182     -> [[Unique]]               -- ^ An infinite list of uniques
 183                                 -- to create names of the new blocks with
 184     -> CmmInfo                  -- ^ Info table for the procedure
 185     -> CLabel                   -- ^ Name of the procedure
 186     -> CmmFormals               -- ^ Parameters of the procedure
 187     -> [CmmBasicBlock]          -- ^ Blocks of the procecure
 188                                 -- (First block is the entry block)
 189     -> [BrokenBlock]
 190
 191 breakProc gc_block_idents uniques info ident params blocks =
 192     let
 193         (adaptor_uniques : block_uniques) = uniques
 194
 195         broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
 196         broken_blocks =
 197             let new_blocks =
 198                     zipWith3 (breakBlock gc_block_idents)
 199                              block_uniques
 200                              blocks
 201                              (FunctionEntry info ident params :
 202                               repeat ControlEntry)
 203             in (concatMap fst new_blocks, concatMap snd new_blocks)
 204
 205         selected = selectContinuations (fst broken_blocks)
 206
 207     in map (makeContinuationEntries selected) $
 208        concat $
 209        zipWith (adaptBlockToFormat selected)
 210                adaptor_uniques
 211                (snd broken_blocks)
 212
 213 -----------------------------------------------------------------------------
 214 -- | Takes a 'CmmBasicBlock' and breaks it up into a list of 'BrokenBlock'
 215 -- by splitting on each 'CmmCall' in the 'CmmBasicBlock'.
 216
 217 breakBlock ::
 218     [BlockId]                   -- ^ Any GC blocks that should be special
 219     -> [Unique]                 -- ^ An infinite list of uniques
 220                                 -- to create names of the new blocks with
 221     -> CmmBasicBlock            -- ^ Input block to break apart
 222     -> BlockEntryInfo           -- ^ Info for the first created 'BrokenBlock'
 223     -> ([(BlockId, ContFormat)], [BrokenBlock])
 224 breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry =
 225     breakBlock' uniques ident entry [] [] stmts
 226     where
 227       breakBlock' uniques current_id entry exits accum_stmts stmts =
 228           case stmts of
 229             [] -> panic "block doesn't end in jump, goto, return or switch"
 230
 231             -- Last statement.  Make the 'BrokenBlock'
 232             [CmmJump target arguments] ->
 233                 ([],
 234                  [BrokenBlock current_id entry accum_stmts
 235                               exits
 236                               (FinalJump target arguments)])
 237             [CmmReturn arguments] ->
 238                 ([],
 239                  [BrokenBlock current_id entry accum_stmts
 240                              exits
 241                              (FinalReturn arguments)])
 242             [CmmBranch target] ->
 243                 ([],
 244                  [BrokenBlock current_id entry accum_stmts
 245                              (target:exits)
 246                              (FinalBranch target)])
 247             [CmmSwitch expr targets] ->
 248                 ([],
 249                  [BrokenBlock current_id entry accum_stmts
 250                              (mapMaybe id targets ++ exits)
 251                              (FinalSwitch expr targets)])
 252
 253             -- These shouldn't happen in the middle of a block.
 254             -- They would cause dead code.
 255             (CmmJump _ _:_) -> panic "jump in middle of block"
 256             (CmmReturn _:_) -> panic "return in middle of block"
 257             (CmmBranch _:_) -> panic "branch in middle of block"
 258             (CmmSwitch _ _:_) -> panic "switch in middle of block"
 259
 260             -- Detect this special case to remain an inverse of
 261             -- 'cmmBlockFromBrokenBlock'
 262             [CmmCall target results arguments (CmmSafe srt) ret,
 263              CmmBranch next_id] ->
 264                 ([cont_info], [block])
 265                 where
 266                   cont_info = (next_id,
 267                                ContFormat results srt
 268                                               (ident `elem` gc_block_idents))
 269                   block = do_call current_id entry accum_stmts exits next_id
 270                                 target results arguments srt ret
 271
 272             -- Break the block on safe calls (the main job of this function)
 273             (CmmCall target results arguments (CmmSafe srt) ret : stmts) ->
 274                 (cont_info : cont_infos, block : blocks)
 275                 where
 276                   next_id = BlockId $ head uniques
 277                   block = do_call current_id entry accum_stmts exits next_id
 278                                   target results arguments srt ret
 279
 280                   cont_info = (next_id, -- Entry convention for the
 281                                         -- continuation of the call
 282                                ContFormat results srt
 283                                               (ident `elem` gc_block_idents))
 284
 285                         -- Break up the part after the call
 286                   (cont_infos, blocks) = breakBlock' (tail uniques) next_id
 287                                          ControlEntry [] [] stmts
 288
 289             -- Unsafe calls don't need a continuation
 290             -- but they do need to be expanded
 291             (CmmCall target results arguments CmmUnsafe ret : stmts) ->
 292                 breakBlock' remaining_uniques current_id entry exits
 293                             (accum_stmts ++
 294                              arg_stmts ++
 295                              caller_save ++
 296                              [CmmCall target results new_args CmmUnsafe ret] ++
 297                              caller_load)
 298                             stmts
 299                 where
 300                   (remaining_uniques, arg_stmts, new_args) =
 301                       loadArgsIntoTemps uniques arguments
 302                   (caller_save, caller_load) = callerSaveVolatileRegs (Just [])
 303
 304             -- Default case.  Just keep accumulating statements
 305             -- and branch targets.
 306             (s : stmts) ->
 307                 breakBlock' uniques current_id entry
 308                             (cond_branch_target s++exits)
 309                             (accum_stmts++[s])
 310                             stmts
 311
 312       do_call current_id entry accum_stmts exits next_id
 313               target results arguments srt ret =
 314           BrokenBlock current_id entry accum_stmts (next_id:exits)
 315                       (FinalCall next_id target results arguments srt ret
 316                                      (current_id `elem` gc_block_idents))
 317
 318       cond_branch_target (CmmCondBranch _ target) = [target]
 319       cond_branch_target _ = []
 320
 321 -----------------------------------------------------------------------------
 322
 323 selectContinuations :: [(BlockId, ContFormat)] -> [(BlockId, ContFormat)]
 324 selectContinuations needed_continuations = formats
 325     where
 326       formats = map select_format format_groups
 327       format_groups = groupBy by_target needed_continuations
 328       by_target x y = fst x == fst y
 329
 330       select_format formats = winner
 331           where
 332             winner = head $ head $ sortBy more_votes format_votes
 333             format_votes = groupBy by_format formats
 334             by_format x y = snd x == snd y
 335             more_votes x y = compare (length y) (length x)
 336               -- sort so the most votes goes *first*
 337               -- (thus the order of x and y is reversed)
 338
 339 makeContinuationEntries formats
 340                         block@(BrokenBlock ident entry stmts targets exit) =
 341     case lookup ident formats of
 342       Nothing -> block
 343       Just (ContFormat formals srt is_gc) ->
 344           BrokenBlock ident (ContinuationEntry (map fst formals) srt is_gc)
 345                       stmts targets exit
 346
 347 adaptBlockToFormat :: [(BlockId, ContFormat)]
 348                    -> Unique
 349                    -> BrokenBlock
 350                    -> [BrokenBlock]
 351 adaptBlockToFormat formats unique
 352                    block@(BrokenBlock ident entry stmts targets
 353                                       exit@(FinalCall next target formals
 354                                                       actuals srt ret is_gc)) =
 355     if format_formals == formals &&
 356        format_srt == srt &&
 357        format_is_gc == is_gc
 358     then [block] -- Woohoo! This block got the continuation format it wanted
 359     else [adaptor_block, revised_block]
 360            -- This block didn't get the format it wanted for the
 361            -- continuation, so we have to build an adaptor.
 362     where
 363       (ContFormat format_formals format_srt format_is_gc) =
 364           maybe unknown_block id $ lookup next formats
 365       unknown_block = panic "unknown block in adaptBlockToFormat"
 366
 367       revised_block = BrokenBlock ident entry stmts revised_targets revised_exit
 368       revised_targets = adaptor_ident : delete next targets
 369       revised_exit = FinalCall
 370                        adaptor_ident -- ^ The only part that changed
 371                        target formals actuals srt ret is_gc
 372
 373       adaptor_block = mk_adaptor_block adaptor_ident
 374                   (ContinuationEntry (map fst formals) srt is_gc)
 375                   next format_formals
 376       adaptor_ident = BlockId unique
 377
 378       mk_adaptor_block :: BlockId -> BlockEntryInfo -> BlockId -> CmmHintFormals -> BrokenBlock
 379       mk_adaptor_block ident entry next formals =
 380           BrokenBlock ident entry [] [next] exit
 381               where
 382                 exit = FinalJump
 383                          (CmmLit (CmmLabel (mkReturnPtLabel (getUnique next))))
 384                          (map formal_to_actual format_formals)
 385
 386                 formal_to_actual (reg, hint) = ((CmmReg (CmmLocal reg)), hint)
 387                 -- TODO: Check if NoHint is right.  We're
 388                 -- jumping to a C-- function not a foreign one
 389                 -- so it might always be right.
 390 adaptBlockToFormat _ _ block = [block]
 391
 392 -----------------------------------------------------------------------------
 393 -- | Convert from a BrokenBlock back to an equivalent CmmBasicBlock
 394 -- Needed by liveness analysis
 395 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
 396 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
 397     BasicBlock ident (stmts++exit_stmt)
 398     where
 399       exit_stmt =
 400           case exit of
 401             FinalBranch target -> [CmmBranch target]
 402             FinalReturn arguments -> [CmmReturn arguments]
 403             FinalJump target arguments -> [CmmJump target arguments]
 404             FinalSwitch expr targets -> [CmmSwitch expr targets]
 405             FinalCall branch_target call_target results arguments srt ret _ ->
 406                 [CmmCall call_target results arguments (CmmSafe srt) ret,
 407                  CmmBranch branch_target]
 408
 409 -----------------------------------------------------------------------------
 410 -- | Build a mapping so we can lookup a 'BrokenBlock' by its 'BlockId'
 411 blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
 412 blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks