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               -- ^ Block is the beginning of a function
  73       CmmInfo                   -- ^ Function header info
  74       CLabel                    -- ^ The function name
  75       CmmFormalsWithoutKinds                -- ^ Aguments to function
  76                 -- Only the formal parameters are live
  77
  78   | ContinuationEntry           -- ^ Return point of a function call
  79       CmmFormalsWithoutKinds                -- ^ return values (argument to continuation)
  80       C_SRT                     -- ^ SRT for the continuation's info table
  81       Bool                      -- ^ True <=> GC block so ignore stack size
  82                 -- Live variables, other than
  83                 -- the return values, are on the stack
  84
  85   | ControlEntry                -- ^ Any other kind of block.
  86                                 -- Only entered due to control flow.
  87
  88   -- TODO: Consider adding ProcPointEntry
  89   -- no return values, but some live might end up as
  90   -- params or possibly in the frame
  91
  92 {-      Note [An example of CPS conversion]
  93
  94 This is NR's and SLPJ's guess about how things might work;
  95 it may not be consistent with the actual code (particularly
  96 in the matter of what's in parameters and what's on the stack).
  97
  98 f(x,y) {
  99    if x>2 then goto L
 100    x = x+1
 101 L: if x>1 then y = g(y)
 102         else x = x+1 ;
 103    return( x+y )
 104 }
 105         BECOMES
 106
 107 f(x,y) {   // FunctionEntry
 108    if x>2 then goto L
 109    x = x+1
 110 L:         // ControlEntry
 111    if x>1 then push x; push f1; jump g(y)
 112         else x=x+1; jump f2(x, y)
 113 }
 114
 115 f1(y) {    // ContinuationEntry
 116   pop x; jump f2(x, y);
 117 }
 118
 119 f2(x, y) { // ProcPointEntry
 120   return (z+y);
 121 }
 122
 123 -}
 124
 125 data ContFormat = ContFormat
 126       CmmFormals            -- ^ return values (argument to continuation)
 127       C_SRT                     -- ^ SRT for the continuation's info table
 128       Bool                      -- ^ True <=> GC block so ignore stack size
 129   deriving (Eq)
 130
 131 -- | Final statement in a 'BlokenBlock'.
 132 -- Constructors and arguments match those in 'Cmm',
 133 -- but are restricted to branches, returns, jumps, calls and switches
 134 data FinalStmt
 135   = FinalBranch                 -- ^ Same as 'CmmBranch'
 136       BlockId                   -- ^ Target must be a ControlEntry
 137
 138   | FinalReturn                 -- ^ Same as 'CmmReturn'
 139       CmmActuals                -- ^ Return values
 140
 141   | FinalJump                   -- ^ Same as 'CmmJump'
 142       CmmExpr                   -- ^ The function to call
 143       CmmActuals                -- ^ Arguments of the call
 144
 145   | FinalCall                   -- ^ Same as 'CmmCallee'
 146                                 -- followed by 'CmmGoto'
 147       BlockId                   -- ^ Target of the 'CmmGoto'
 148                                 -- (must be a 'ContinuationEntry')
 149       CmmCallTarget             -- ^ The function to call
 150       CmmFormals                -- ^ Results from call
 151                                 -- (redundant with ContinuationEntry)
 152       CmmActuals                -- ^ Arguments to call
 153       C_SRT                     -- ^ SRT for the continuation's info table
 154       CmmReturnInfo             -- ^ Does the function return?
 155       Bool                      -- ^ True <=> GC block so ignore stack size
 156
 157   | FinalSwitch                 -- ^ Same as a 'CmmSwitch'
 158       CmmExpr                   -- ^ Scrutinee (zero based)
 159       [Maybe BlockId]           -- ^ Targets
 160
 161 -----------------------------------------------------------------------------
 162 -- Operations for broken blocks
 163 -----------------------------------------------------------------------------
 164
 165 -- Naively breaking at *every* CmmCall leads to sub-optimal code.
 166 -- In particular, a CmmCall followed by a CmmBranch would result
 167 -- in a continuation that has the single CmmBranch statement in it.
 168 -- It would be better have the CmmCall directly return to the block
 169 -- that the branch jumps to.
 170 --
 171 -- This requires the target of the branch to look like the parameter
 172 -- format that the CmmCall is expecting.  If other CmmCall/CmmBranch
 173 -- sequences go to the same place they might not be expecting the
 174 -- same format.  So this transformation uses the following solution.
 175 -- First the blocks are broken up but none of the blocks are marked
 176 -- as continuations yet.  This is the 'breakBlock' function.
 177 -- Second, the blocks "vote" on what other blocks need to be continuations
 178 -- and how they should be layed out.  Plurality wins, but other selection
 179 -- methods could be selected at a later time.
 180 -- This is the 'selectContinuations' function.
 181 -- Finally, the blocks are upgraded to 'ContEntry' continuations
 182 -- based on the results with the 'makeContinuationEntries' function,
 183 -- and the blocks that didn't get the format they wanted for their
 184 -- targets get a small adaptor block created for them by
 185 -- the 'adaptBlockToFormat' function.
 186 -- could be
 187
 188 breakProc ::
 189     [BlockId]                   -- ^ Any GC blocks that should be special
 190     -> [[Unique]]               -- ^ An infinite list of uniques
 191                                 -- to create names of the new blocks with
 192     -> CmmInfo                  -- ^ Info table for the procedure
 193     -> CLabel                   -- ^ Name of the procedure
 194     -> CmmFormalsWithoutKinds               -- ^ Parameters of the procedure
 195     -> [CmmBasicBlock]          -- ^ Blocks of the procecure
 196                                 -- (First block is the entry block)
 197     -> [BrokenBlock]
 198
 199 breakProc gc_block_idents uniques info ident params blocks =
 200     let
 201         (adaptor_uniques : block_uniques) = uniques
 202
 203         broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
 204         broken_blocks =
 205             let new_blocks =
 206                     zipWith3 (breakBlock gc_block_idents)
 207                              block_uniques
 208                              blocks
 209                              (FunctionEntry info ident params :
 210                               repeat ControlEntry)
 211             in (concatMap fst new_blocks, concatMap snd new_blocks)
 212
 213         selected = selectContinuations (fst broken_blocks)
 214
 215     in map (makeContinuationEntries selected) $
 216        concat $
 217        zipWith (adaptBlockToFormat selected)
 218                adaptor_uniques
 219                (snd broken_blocks)
 220
 221 -----------------------------------------------------------------------------
 222 -- | Takes a 'CmmBasicBlock' and breaks it up into a list of 'BrokenBlock'
 223 -- by splitting on each 'CmmCall' in the 'CmmBasicBlock'.
 224
 225 breakBlock ::
 226     [BlockId]                   -- ^ Any GC blocks that should be special
 227     -> [Unique]                 -- ^ An infinite list of uniques
 228                                 -- to create names of the new blocks with
 229     -> CmmBasicBlock            -- ^ Input block to break apart
 230     -> BlockEntryInfo           -- ^ Info for the first created 'BrokenBlock'
 231     -> ([(BlockId, ContFormat)], [BrokenBlock])
 232 breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry =
 233     breakBlock' uniques ident entry [] [] stmts
 234     where
 235       breakBlock' uniques current_id entry exits accum_stmts stmts =
 236           case stmts of
 237             [] -> panic "block doesn't end in jump, goto, return or switch"
 238
 239             -- Last statement.  Make the 'BrokenBlock'
 240             [CmmJump target arguments] ->
 241                 ([],
 242                  [BrokenBlock current_id entry accum_stmts
 243                               exits
 244                               (FinalJump target arguments)])
 245             [CmmReturn arguments] ->
 246                 ([],
 247                  [BrokenBlock current_id entry accum_stmts
 248                              exits
 249                              (FinalReturn arguments)])
 250             [CmmBranch target] ->
 251                 ([],
 252                  [BrokenBlock current_id entry accum_stmts
 253                              (target:exits)
 254                              (FinalBranch target)])
 255             [CmmSwitch expr targets] ->
 256                 ([],
 257                  [BrokenBlock current_id entry accum_stmts
 258                              (mapMaybe id targets ++ exits)
 259                              (FinalSwitch expr targets)])
 260
 261             -- These shouldn't happen in the middle of a block.
 262             -- They would cause dead code.
 263             (CmmJump _ _:_) -> panic "jump in middle of block"
 264             (CmmReturn _:_) -> panic "return in middle of block"
 265             (CmmBranch _:_) -> panic "branch in middle of block"
 266             (CmmSwitch _ _:_) -> panic "switch in middle of block"
 267
 268             -- Detect this special case to remain an inverse of
 269             -- 'cmmBlockFromBrokenBlock'
 270             [CmmCall target results arguments (CmmSafe srt) ret,
 271              CmmBranch next_id] ->
 272                 ([cont_info], [block])
 273                 where
 274                   cont_info = (next_id,
 275                                ContFormat results srt
 276                                               (ident `elem` gc_block_idents))
 277                   block = do_call current_id entry accum_stmts exits next_id
 278                                 target results arguments srt ret
 279
 280             -- Break the block on safe calls (the main job of this function)
 281             (CmmCall target results arguments (CmmSafe srt) ret : stmts) ->
 282                 (cont_info : cont_infos, block : blocks)
 283                 where
 284                   next_id = BlockId $ head uniques
 285                   block = do_call current_id entry accum_stmts exits next_id
 286                                   target results arguments srt ret
 287
 288                   cont_info = (next_id, -- Entry convention for the
 289                                         -- continuation of the call
 290                                ContFormat results srt
 291                                               (ident `elem` gc_block_idents))
 292
 293                         -- Break up the part after the call
 294                   (cont_infos, blocks) = breakBlock' (tail uniques) next_id
 295                                          ControlEntry [] [] stmts
 296
 297             -- Unsafe calls don't need a continuation
 298             -- but they do need to be expanded
 299             (CmmCall target results arguments CmmUnsafe ret : stmts) ->
 300                 breakBlock' remaining_uniques current_id entry exits
 301                             (accum_stmts ++
 302                              arg_stmts ++
 303                              caller_save ++
 304                              [CmmCall target results new_args CmmUnsafe ret] ++
 305                              caller_load)
 306                             stmts
 307                 where
 308                   (remaining_uniques, arg_stmts, new_args) =
 309                       loadArgsIntoTemps uniques arguments
 310                   (caller_save, caller_load) = callerSaveVolatileRegs (Just [])
 311
 312             -- Default case.  Just keep accumulating statements
 313             -- and branch targets.
 314             (s : stmts) ->
 315                 breakBlock' uniques current_id entry
 316                             (cond_branch_target s++exits)
 317                             (accum_stmts++[s])
 318                             stmts
 319
 320       do_call current_id entry accum_stmts exits next_id
 321               target results arguments srt ret =
 322           BrokenBlock current_id entry accum_stmts (next_id:exits)
 323                       (FinalCall next_id target results arguments srt ret
 324                                      (current_id `elem` gc_block_idents))
 325
 326       cond_branch_target (CmmCondBranch _ target) = [target]
 327       cond_branch_target _ = []
 328
 329 -----------------------------------------------------------------------------
 330
 331 selectContinuations :: [(BlockId, ContFormat)] -> [(BlockId, ContFormat)]
 332 selectContinuations needed_continuations = formats
 333     where
 334       formats = map select_format format_groups
 335       format_groups = groupBy by_target needed_continuations
 336       by_target x y = fst x == fst y
 337
 338       select_format formats = winner
 339           where
 340             winner = head $ head $ sortBy more_votes format_votes
 341             format_votes = groupBy by_format formats
 342             by_format x y = snd x == snd y
 343             more_votes x y = compare (length y) (length x)
 344               -- sort so the most votes goes *first*
 345               -- (thus the order of x and y is reversed)
 346
 347 makeContinuationEntries formats
 348                         block@(BrokenBlock ident entry stmts targets exit) =
 349     case lookup ident formats of
 350       Nothing -> block
 351       Just (ContFormat formals srt is_gc) ->
 352           BrokenBlock ident (ContinuationEntry (map kindlessCmm formals) srt is_gc)
 353                       stmts targets exit
 354
 355 adaptBlockToFormat :: [(BlockId, ContFormat)]
 356                    -> Unique
 357                    -> BrokenBlock
 358                    -> [BrokenBlock]
 359 adaptBlockToFormat formats unique
 360                    block@(BrokenBlock ident entry stmts targets
 361                                       exit@(FinalCall next target formals
 362                                                       actuals srt ret is_gc)) =
 363     if format_formals == formals &&
 364        format_srt == srt &&
 365        format_is_gc == is_gc
 366     then [block] -- Woohoo! This block got the continuation format it wanted
 367     else [adaptor_block, revised_block]
 368            -- This block didn't get the format it wanted for the
 369            -- continuation, so we have to build an adaptor.
 370     where
 371       (ContFormat format_formals format_srt format_is_gc) =
 372           maybe unknown_block id $ lookup next formats
 373       unknown_block = panic "unknown block in adaptBlockToFormat"
 374
 375       revised_block = BrokenBlock ident entry stmts revised_targets revised_exit
 376       revised_targets = adaptor_ident : delete next targets
 377       revised_exit = FinalCall
 378                        adaptor_ident -- ^ The only part that changed
 379                        target formals actuals srt ret is_gc
 380
 381       adaptor_block = mk_adaptor_block adaptor_ident
 382                   (ContinuationEntry (map kindlessCmm formals) srt is_gc)
 383                   next format_formals
 384       adaptor_ident = BlockId unique
 385
 386       mk_adaptor_block :: BlockId -> BlockEntryInfo -> BlockId -> CmmFormals -> BrokenBlock
 387       mk_adaptor_block ident entry next formals =
 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 (CmmKinded reg hint)
 395                      = (CmmKinded (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 = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks