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