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