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       Bool                      -- ^ True <=> GC block so ignore stack size
 147
 148   | FinalSwitch                 -- ^ Same as a 'CmmSwitch'
 149       CmmExpr                   -- ^ Scrutinee (zero based)
 150       [Maybe BlockId]           -- ^ Targets
 151
 152 -----------------------------------------------------------------------------
 153 -- Operations for broken blocks
 154 -----------------------------------------------------------------------------
 155
 156 -- Naively breaking at *every* CmmCall leads to sub-optimal code.
 157 -- In particular, a CmmCall followed by a CmmBranch would result
 158 -- in a continuation that has the single CmmBranch statement in it.
 159 -- It would be better have the CmmCall directly return to the block
 160 -- that the branch jumps to.
 161 --
 162 -- This requires the target of the branch to look like the parameter
 163 -- format that the CmmCall is expecting.  If other CmmCall/CmmBranch
 164 -- sequences go to the same place they might not be expecting the
 165 -- same format.  So this transformation uses the following solution.
 166 -- First the blocks are broken up but none of the blocks are marked
 167 -- as continuations yet.  This is the 'breakBlock' function.
 168 -- Second, the blocks "vote" on what other blocks need to be continuations
 169 -- and how they should be layed out.  Plurality wins, but other selection
 170 -- methods could be selected at a later time.
 171 -- This is the 'selectContinuations' function.
 172 -- Finally, the blocks are upgraded to 'ContEntry' continuations
 173 -- based on the results with the 'makeContinuationEntries' function,
 174 -- and the blocks that didn't get the format they wanted for their
 175 -- targets get a small adaptor block created for them by
 176 -- the 'adaptBlockToFormat' function.
 177 -- could be
 178
 179 breakProc ::
 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     -> CmmInfo                  -- ^ Info table for the procedure
 184     -> CLabel                   -- ^ Name of the procedure
 185     -> CmmFormals               -- ^ Parameters of the procedure
 186     -> [CmmBasicBlock]          -- ^ Blocks of the procecure
 187                                 -- (First block is the entry block)
 188     -> [BrokenBlock]
 189
 190 breakProc gc_block_idents uniques info ident params blocks =
 191     let
 192         (adaptor_uniques : block_uniques) = uniques
 193
 194         broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
 195         broken_blocks =
 196             let new_blocks =
 197                     zipWith3 (breakBlock gc_block_idents)
 198                              block_uniques
 199                              blocks
 200                              (FunctionEntry info ident params :
 201                               repeat ControlEntry)
 202             in (concatMap fst new_blocks, concatMap snd new_blocks)
 203
 204         selected = selectContinuations (fst broken_blocks)
 205
 206     in map (makeContinuationEntries selected) $
 207        concat $
 208        zipWith (adaptBlockToFormat selected)
 209                adaptor_uniques
 210                (snd broken_blocks)
 211
 212 -----------------------------------------------------------------------------
 213 -- | Takes a 'CmmBasicBlock' and breaks it up into a list of 'BrokenBlock'
 214 -- by splitting on each 'CmmCall' in the 'CmmBasicBlock'.
 215
 216 breakBlock ::
 217     [BlockId]                   -- ^ Any GC blocks that should be special
 218     -> [Unique]                 -- ^ An infinite list of uniques
 219                                 -- to create names of the new blocks with
 220     -> CmmBasicBlock            -- ^ Input block to break apart
 221     -> BlockEntryInfo           -- ^ Info for the first created 'BrokenBlock'
 222     -> ([(BlockId, ContFormat)], [BrokenBlock])
 223 breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry =
 224     breakBlock' uniques ident entry [] [] stmts
 225     where
 226       breakBlock' uniques current_id entry exits accum_stmts stmts =
 227           case stmts of
 228             [] -> panic "block doesn't end in jump, goto, return or switch"
 229
 230             -- Last statement.  Make the 'BrokenBlock'
 231             [CmmJump target arguments] ->
 232                 ([],
 233                  [BrokenBlock current_id entry accum_stmts
 234                               exits
 235                               (FinalJump target arguments)])
 236             [CmmReturn arguments] ->
 237                 ([],
 238                  [BrokenBlock current_id entry accum_stmts
 239                              exits
 240                              (FinalReturn arguments)])
 241             [CmmBranch target] ->
 242                 ([],
 243                  [BrokenBlock current_id entry accum_stmts
 244                              (target:exits)
 245                              (FinalBranch target)])
 246             [CmmSwitch expr targets] ->
 247                 ([],
 248                  [BrokenBlock current_id entry accum_stmts
 249                              (mapMaybe id targets ++ exits)
 250                              (FinalSwitch expr targets)])
 251
 252             -- These shouldn't happen in the middle of a block.
 253             -- They would cause dead code.
 254             (CmmJump _ _:_) -> panic "jump in middle of block"
 255             (CmmReturn _:_) -> panic "return in middle of block"
 256             (CmmBranch _:_) -> panic "branch in middle of block"
 257             (CmmSwitch _ _:_) -> panic "switch in middle of block"
 258
 259             -- Detect this special case to remain an inverse of
 260             -- 'cmmBlockFromBrokenBlock'
 261             [CmmCall target results arguments (CmmSafe srt),
 262              CmmBranch next_id] ->
 263                 ([cont_info], [block])
 264                 where
 265                   cont_info = (next_id,
 266                                ContFormat results srt
 267                                               (ident `elem` gc_block_idents))
 268                   block = do_call current_id entry accum_stmts exits next_id
 269                                 target results arguments srt
 270
 271             -- Break the block on safe calls (the main job of this function)
 272             (CmmCall target results arguments (CmmSafe srt) : stmts) ->
 273                 (cont_info : cont_infos, block : blocks)
 274                 where
 275                   next_id = BlockId $ head uniques
 276                   block = do_call current_id entry accum_stmts exits next_id
 277                                   target results arguments srt
 278
 279                   cont_info = (next_id, -- Entry convention for the
 280                                         -- continuation of the call
 281                                ContFormat results srt
 282                                               (ident `elem` gc_block_idents))
 283
 284                         -- Break up the part after the call
 285                   (cont_infos, blocks) = breakBlock' (tail uniques) next_id
 286                                          ControlEntry [] [] stmts
 287
 288             -- Unsafe calls don't need a continuation
 289             -- but they do need to be expanded
 290             (CmmCall target results arguments CmmUnsafe : stmts) ->
 291                 breakBlock' remaining_uniques current_id entry exits
 292                             (accum_stmts ++
 293                              arg_stmts ++
 294                              caller_save ++
 295                              [CmmCall target results new_args CmmUnsafe] ++
 296                              caller_load)
 297                             stmts
 298                 where
 299                   (remaining_uniques, arg_stmts, new_args) =
 300                       loadArgsIntoTemps uniques arguments
 301                   (caller_save, caller_load) = callerSaveVolatileRegs (Just [])
 302
 303             -- Default case.  Just keep accumulating statements
 304             -- and branch targets.
 305             (s : stmts) ->
 306                 breakBlock' uniques current_id entry
 307                             (cond_branch_target s++exits)
 308                             (accum_stmts++[s])
 309                             stmts
 310
 311       do_call current_id entry accum_stmts exits next_id
 312               target results arguments srt =
 313           BrokenBlock current_id entry accum_stmts (next_id:exits)
 314                       (FinalCall next_id target results arguments srt
 315                                      (current_id `elem` gc_block_idents))
 316
 317       cond_branch_target (CmmCondBranch _ target) = [target]
 318       cond_branch_target _ = []
 319
 320 -----------------------------------------------------------------------------
 321
 322 selectContinuations :: [(BlockId, ContFormat)] -> [(BlockId, ContFormat)]
 323 selectContinuations needed_continuations = formats
 324     where
 325       formats = map select_format format_groups
 326       format_groups = groupBy by_target needed_continuations
 327       by_target x y = fst x == fst y
 328
 329       select_format formats = winner
 330           where
 331             winner = head $ head $ sortBy more_votes format_votes
 332             format_votes = groupBy by_format formats
 333             by_format x y = snd x == snd y
 334             more_votes x y = compare (length y) (length x)
 335               -- sort so the most votes goes *first*
 336               -- (thus the order of x and y is reversed)
 337
 338 makeContinuationEntries formats
 339                         block@(BrokenBlock ident entry stmts targets exit) =
 340     case lookup ident formats of
 341       Nothing -> block
 342       Just (ContFormat formals srt is_gc) ->
 343           BrokenBlock ident (ContinuationEntry (map fst formals) srt is_gc)
 344                       stmts targets exit
 345
 346 adaptBlockToFormat :: [(BlockId, ContFormat)]
 347                    -> Unique
 348                    -> BrokenBlock
 349                    -> [BrokenBlock]
 350 adaptBlockToFormat formats unique
 351                    block@(BrokenBlock ident entry stmts targets
 352                                       exit@(FinalCall next target formals
 353                                                       actuals srt is_gc)) =
 354     if format_formals == formals &&
 355        format_srt == srt &&
 356        format_is_gc == is_gc
 357     then [block] -- Woohoo! This block got the continuation format it wanted
 358     else [adaptor_block, revised_block]
 359            -- This block didn't get the format it wanted for the
 360            -- continuation, so we have to build an adaptor.
 361     where
 362       (ContFormat format_formals format_srt format_is_gc) =
 363           maybe unknown_block id $ lookup next formats
 364       unknown_block = panic "unknown block in adaptBlockToFormat"
 365
 366       revised_block = BrokenBlock ident entry stmts revised_targets revised_exit
 367       revised_targets = adaptor_ident : delete next targets
 368       revised_exit = FinalCall
 369                        adaptor_ident -- ^ The only part that changed
 370                        target formals actuals srt is_gc
 371
 372       adaptor_block = mk_adaptor_block adaptor_ident
 373                   (ContinuationEntry (map fst formals) srt is_gc)
 374                   next format_formals
 375       adaptor_ident = BlockId unique
 376
 377       mk_adaptor_block :: BlockId -> BlockEntryInfo -> BlockId -> CmmHintFormals -> BrokenBlock
 378       mk_adaptor_block ident entry next formals =
 379           BrokenBlock ident entry [] [next] exit
 380               where
 381                 exit = FinalJump
 382                          (CmmLit (CmmLabel (mkReturnPtLabel (getUnique next))))
 383                          (map formal_to_actual format_formals)
 384
 385                 formal_to_actual (reg, hint) = ((CmmReg (CmmLocal reg)), hint)
 386                 -- TODO: Check if NoHint is right.  We're
 387                 -- jumping to a C-- function not a foreign one
 388                 -- so it might always be right.
 389 adaptBlockToFormat _ _ block = [block]
 390
 391 -----------------------------------------------------------------------------
 392 -- | Convert from a BrokenBlock back to an equivalent CmmBasicBlock
 393 -- Needed by liveness analysis
 394 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
 395 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
 396     BasicBlock ident (stmts++exit_stmt)
 397     where
 398       exit_stmt =
 399           case exit of
 400             FinalBranch target -> [CmmBranch target]
 401             FinalReturn arguments -> [CmmReturn arguments]
 402             FinalJump target arguments -> [CmmJump target arguments]
 403             FinalSwitch expr targets -> [CmmSwitch expr targets]
 404             FinalCall branch_target call_target results arguments srt _ ->
 405                 [CmmCall call_target results arguments (CmmSafe srt),
 406                  CmmBranch branch_target]
 407
 408 -----------------------------------------------------------------------------
 409 -- | Build a mapping so we can lookup a 'BrokenBlock' by its 'BlockId'
 410 blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
 411 blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks