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 Cmm
  24 import CmmUtils
  25 import CLabel
  26 import MachOp (MachHint(..))
  27
  28 import CgUtils (callerSaveVolatileRegs)
  29 import ClosureInfo
  30
  31 import Maybes
  32 import List
  33 import Panic
  34 import UniqSupply
  35 import Unique
  36 import UniqFM
  37
  38 -- This module takes a 'CmmBasicBlock' which might have 'CmmCall'
  39 -- statements in it with 'CmmSafe' set and breaks it up at each such call.
  40 -- It also collects information about the block for later use
  41 -- by the CPS algorithm.
  42
  43 -----------------------------------------------------------------------------
  44 -- Data structures
  45 -----------------------------------------------------------------------------
  46
  47 -- |Similar to a 'CmmBlock' with a little extra information
  48 -- to help the CPS analysis.
  49 data BrokenBlock
  50   = BrokenBlock {
  51       brokenBlockId :: BlockId, -- ^ The block's label like a 'CmmBasicBlock'
  52       brokenBlockEntry :: BlockEntryInfo,
  53                                 -- ^ Ways this block can be entered
  54
  55       brokenBlockStmts :: [CmmStmt],
  56                                 -- ^ Body like a CmmBasicBlock
  57                                 -- (but without the last statement)
  58
  59       brokenBlockTargets :: [BlockId],
  60                                 -- ^ Blocks that this block could
  61                                 -- branch to either by conditional
  62                                 -- branches or via the last statement
  63
  64       brokenBlockExit :: FinalStmt
  65                                 -- ^ The final statement of the block
  66     }
  67
  68 -- | How a block could be entered
  69 -- See Note [An example of CPS conversion]
  70 data BlockEntryInfo
  71   = FunctionEntry               -- ^ Block is the beginning of a function
  72       CmmInfo                   -- ^ Function header info
  73       CLabel                    -- ^ The function name
  74       CmmFormals                -- ^ Aguments to function
  75                 -- Only the formal parameters are live
  76
  77   | ContinuationEntry           -- ^ Return point of a function call
  78       CmmFormals                -- ^ return values (argument to continuation)
  79       C_SRT                     -- ^ SRT for the continuation's info table
  80       Bool                      -- ^ True <=> GC block so ignore stack size
  81                 -- Live variables, other than
  82                 -- the return values, are on the stack
  83
  84   | ControlEntry                -- ^ Any other kind of block.
  85                                 -- Only entered due to control flow.
  86
  87   -- TODO: Consider adding ProcPointEntry
  88   -- no return values, but some live might end up as
  89   -- params or possibly in the frame
  90
  91 {-      Note [An example of CPS conversion]
  92
  93 This is NR's and SLPJ's guess about how things might work;
  94 it may not be consistent with the actual code (particularly
  95 in the matter of what's in parameters and what's on the stack).
  96
  97 f(x,y) {
  98    if x>2 then goto L
  99    x = x+1
 100 L: if x>1 then y = g(y)
 101         else x = x+1 ;
 102    return( x+y )
 103 }
 104         BECOMES
 105
 106 f(x,y) {   // FunctionEntry
 107    if x>2 then goto L
 108    x = x+1
 109 L:         // ControlEntry
 110    if x>1 then push x; push f1; jump g(y)
 111         else x=x+1; jump f2(x, y)
 112 }
 113
 114 f1(y) {    // ContinuationEntry
 115   pop x; jump f2(x, y);
 116 }
 117
 118 f2(x, y) { // ProcPointEntry
 119   return (z+y);
 120 }
 121
 122 -}
 123
 124 data ContFormat = ContFormat
 125       CmmHintFormals            -- ^ return values (argument to continuation)
 126       C_SRT                     -- ^ SRT for the continuation's info table
 127       Bool                      -- ^ True <=> GC block so ignore stack size
 128   deriving (Eq)
 129
 130 -- | Final statement in a 'BlokenBlock'.
 131 -- Constructors and arguments match those in 'Cmm',
 132 -- but are restricted to branches, returns, jumps, calls and switches
 133 data FinalStmt
 134   = FinalBranch                 -- ^ Same as 'CmmBranch'
 135       BlockId                   -- ^ Target must be a ControlEntry
 136
 137   | FinalReturn                 -- ^ Same as 'CmmReturn'
 138       CmmActuals                -- ^ Return values
 139
 140   | FinalJump                   -- ^ Same as 'CmmJump'
 141       CmmExpr                   -- ^ The function to call
 142       CmmActuals                -- ^ Arguments of the call
 143
 144   | FinalCall                   -- ^ Same as 'CmmCallee'
 145                                 -- followed by 'CmmGoto'
 146       BlockId                   -- ^ Target of the 'CmmGoto'
 147                                 -- (must be a 'ContinuationEntry')
 148       CmmCallTarget             -- ^ The function to call
 149       CmmHintFormals                -- ^ Results from call
 150                                 -- (redundant with ContinuationEntry)
 151       CmmActuals                -- ^ Arguments to call
 152       C_SRT                     -- ^ SRT for the continuation's info table
 153       CmmReturnInfo             -- ^ Does the function return?
 154       Bool                      -- ^ True <=> GC block so ignore stack size
 155
 156   | FinalSwitch                 -- ^ Same as a 'CmmSwitch'
 157       CmmExpr                   -- ^ Scrutinee (zero based)
 158       [Maybe BlockId]           -- ^ Targets
 159
 160 -----------------------------------------------------------------------------
 161 -- Operations for broken blocks
 162 -----------------------------------------------------------------------------
 163
 164 -- Naively breaking at *every* CmmCall leads to sub-optimal code.
 165 -- In particular, a CmmCall followed by a CmmBranch would result
 166 -- in a continuation that has the single CmmBranch statement in it.
 167 -- It would be better have the CmmCall directly return to the block
 168 -- that the branch jumps to.
 169 --
 170 -- This requires the target of the branch to look like the parameter
 171 -- format that the CmmCall is expecting.  If other CmmCall/CmmBranch
 172 -- sequences go to the same place they might not be expecting the
 173 -- same format.  So this transformation uses the following solution.
 174 -- First the blocks are broken up but none of the blocks are marked
 175 -- as continuations yet.  This is the 'breakBlock' function.
 176 -- Second, the blocks "vote" on what other blocks need to be continuations
 177 -- and how they should be layed out.  Plurality wins, but other selection
 178 -- methods could be selected at a later time.
 179 -- This is the 'selectContinuations' function.
 180 -- Finally, the blocks are upgraded to 'ContEntry' continuations
 181 -- based on the results with the 'makeContinuationEntries' function,
 182 -- and the blocks that didn't get the format they wanted for their
 183 -- targets get a small adaptor block created for them by
 184 -- the 'adaptBlockToFormat' function.
 185 -- could be
 186
 187 breakProc ::
 188     [BlockId]                   -- ^ Any GC blocks that should be special
 189     -> [[Unique]]               -- ^ An infinite list of uniques
 190                                 -- to create names of the new blocks with
 191     -> CmmInfo                  -- ^ Info table for the procedure
 192     -> CLabel                   -- ^ Name of the procedure
 193     -> CmmFormals               -- ^ Parameters of the procedure
 194     -> [CmmBasicBlock]          -- ^ Blocks of the procecure
 195                                 -- (First block is the entry block)
 196     -> [BrokenBlock]
 197
 198 breakProc gc_block_idents uniques info ident params blocks =
 199     let
 200         (adaptor_uniques : block_uniques) = uniques
 201
 202         broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
 203         broken_blocks =
 204             let new_blocks =
 205                     zipWith3 (breakBlock gc_block_idents)
 206                              block_uniques
 207                              blocks
 208                              (FunctionEntry info ident params :
 209                               repeat ControlEntry)
 210             in (concatMap fst new_blocks, concatMap snd new_blocks)
 211
 212         selected = selectContinuations (fst broken_blocks)
 213
 214     in map (makeContinuationEntries selected) $
 215        concat $
 216        zipWith (adaptBlockToFormat selected)
 217                adaptor_uniques
 218                (snd broken_blocks)
 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 formats
 347                         block@(BrokenBlock ident entry stmts targets exit) =
 348     case lookup ident formats of
 349       Nothing -> block
 350       Just (ContFormat formals srt is_gc) ->
 351           BrokenBlock ident (ContinuationEntry (map fst formals) srt is_gc)
 352                       stmts targets exit
 353
 354 adaptBlockToFormat :: [(BlockId, ContFormat)]
 355                    -> Unique
 356                    -> BrokenBlock
 357                    -> [BrokenBlock]
 358 adaptBlockToFormat formats unique
 359                    block@(BrokenBlock ident entry stmts targets
 360                                       exit@(FinalCall next target formals
 361                                                       actuals srt ret is_gc)) =
 362     if format_formals == formals &&
 363        format_srt == srt &&
 364        format_is_gc == is_gc
 365     then [block] -- Woohoo! This block got the continuation format it wanted
 366     else [adaptor_block, revised_block]
 367            -- This block didn't get the format it wanted for the
 368            -- continuation, so we have to build an adaptor.
 369     where
 370       (ContFormat format_formals format_srt format_is_gc) =
 371           maybe unknown_block id $ lookup next formats
 372       unknown_block = panic "unknown block in adaptBlockToFormat"
 373
 374       revised_block = BrokenBlock ident entry stmts revised_targets revised_exit
 375       revised_targets = adaptor_ident : delete next targets
 376       revised_exit = FinalCall
 377                        adaptor_ident -- ^ The only part that changed
 378                        target formals actuals srt ret is_gc
 379
 380       adaptor_block = mk_adaptor_block adaptor_ident
 381                   (ContinuationEntry (map fst formals) srt is_gc)
 382                   next format_formals
 383       adaptor_ident = BlockId unique
 384
 385       mk_adaptor_block :: BlockId -> BlockEntryInfo -> BlockId -> CmmHintFormals -> BrokenBlock
 386       mk_adaptor_block ident entry next formals =
 387           BrokenBlock ident entry [] [next] exit
 388               where
 389                 exit = FinalJump
 390                          (CmmLit (CmmLabel (mkReturnPtLabel (getUnique next))))
 391                          (map formal_to_actual format_formals)
 392
 393                 formal_to_actual (reg, hint) = ((CmmReg (CmmLocal reg)), hint)
 394                 -- TODO: Check if NoHint is right.  We're
 395                 -- jumping to a C-- function not a foreign one
 396                 -- so it might always be right.
 397 adaptBlockToFormat _ _ block = [block]
 398
 399 -----------------------------------------------------------------------------
 400 -- | Convert from a BrokenBlock back to an equivalent CmmBasicBlock
 401 -- Needed by liveness analysis
 402 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
 403 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
 404     BasicBlock ident (stmts++exit_stmt)
 405     where
 406       exit_stmt =
 407           case exit of
 408             FinalBranch target -> [CmmBranch target]
 409             FinalReturn arguments -> [CmmReturn arguments]
 410             FinalJump target arguments -> [CmmJump target arguments]
 411             FinalSwitch expr targets -> [CmmSwitch expr targets]
 412             FinalCall branch_target call_target results arguments srt ret _ ->
 413                 [CmmCall call_target results arguments (CmmSafe srt) ret,
 414                  CmmBranch branch_target]
 415
 416 -----------------------------------------------------------------------------
 417 -- | Build a mapping so we can lookup a 'BrokenBlock' by its 'BlockId'
 418 blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
 419 blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks