compiler/cmm/CmmBrokenBlock.hs

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