compiler/cmm/CmmBrokenBlock.hs

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