compiler/cmm/CmmBrokenBlock.hs

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