compiler/cmm/CmmBrokenBlock.hs

   1 module CmmBrokenBlock (
   2   BrokenBlock(..),
   3   BlockEntryInfo(..),
   4   FinalStmt(..),
   5   breakBlock,
   6   cmmBlockFromBrokenBlock,
   7   blocksToBlockEnv,
   8   ) where
   9
  10 #include "HsVersions.h"
  11
  12 import Cmm
  13 import CLabel
  14
  15 import Maybes
  16 import Panic
  17 import Unique
  18 import UniqFM
  19
  20 -----------------------------------------------------------------------------
  21 -- Data structures
  22 -----------------------------------------------------------------------------
  23
  24 -- |Similar to a 'CmmBlock' with a little extra information
  25 -- to help the CPS analysis.
  26 data BrokenBlock
  27   = BrokenBlock {
  28       brokenBlockId :: BlockId, -- ^ The block's label like a 'CmmBasicBlock'
  29       brokenBlockEntry :: BlockEntryInfo,
  30                                 -- ^ Ways this block can be entered
  31
  32       brokenBlockStmts :: [CmmStmt],
  33                                 -- ^ Body like a CmmBasicBlock
  34                                 -- (but without the last statement)
  35
  36       brokenBlockTargets :: [BlockId],
  37                                 -- ^ Blocks that this block could
  38                                 -- branch to one either by conditional
  39                                 -- branches or via the last statement
  40
  41       brokenBlockExit :: FinalStmt
  42                                 -- ^ The final statement of the block
  43     }
  44
  45 -- | How a block could be entered
  46 data BlockEntryInfo
  47   = FunctionEntry               -- ^ Block is the beginning of a function
  48       CLabel                    -- ^ The function name
  49       CmmFormals                -- ^ Aguments to function
  50
  51   | ContinuationEntry           -- ^ Return point of a function call
  52       CmmFormals                -- ^ return values (argument to continuation)
  53
  54   | ControlEntry                -- ^ Any other kind of block.
  55                                 -- Only entered due to control flow.
  56
  57   -- TODO: Consider adding ProcPointEntry
  58   -- no return values, but some live might end up as
  59   -- params or possibly in the frame
  60
  61
  62 -- | Final statement in a 'BlokenBlock'.
  63 -- Constructors and arguments match those in 'Cmm',
  64 -- but are restricted to branches, returns, jumps, calls and switches
  65 data FinalStmt
  66   = FinalBranch                 -- ^ Same as 'CmmBranch'
  67       BlockId                   -- ^ Target must be a ControlEntry
  68
  69   | FinalReturn                 -- ^ Same as 'CmmReturn'
  70       CmmActuals                -- ^ Return values
  71
  72   | FinalJump                   -- ^ Same as 'CmmJump'
  73       CmmExpr                   -- ^ The function to call
  74       CmmActuals                -- ^ Arguments of the call
  75
  76   | FinalCall                   -- ^ Same as 'CmmForeignCall'
  77                                 -- followed by 'CmmGoto'
  78       BlockId                   -- ^ Target of the 'CmmGoto'
  79                                 -- (must be a 'ContinuationEntry')
  80       CmmCallTarget             -- ^ The function to call
  81       CmmFormals                -- ^ Results from call
  82                                 -- (redundant with ContinuationEntry)
  83       CmmActuals                -- ^ Arguments to call
  84
  85   | FinalSwitch                 -- ^ Same as a 'CmmSwitch'
  86       CmmExpr                   -- ^ Scrutinee (zero based)
  87       [Maybe BlockId]           -- ^ Targets
  88
  89 -----------------------------------------------------------------------------
  90 -- Operations for broken blocks
  91 -----------------------------------------------------------------------------
  92
  93 -----------------------------------------------------------------------------
  94 -- | Takes a 'CmmBasicBlock' and breaks it up into a list of 'BrokenBlock'
  95 -- by splitting on each 'CmmCall' in the 'CmmBasicBlock'.
  96
  97 breakBlock ::
  98     [Unique]                    -- ^ An infinite list of uniques
  99                                 -- to create names of the new blocks with
 100     -> CmmBasicBlock            -- ^ Input block to break apart
 101     -> BlockEntryInfo           -- ^ Info for the first created 'BrokenBlock'
 102     -> [BrokenBlock]
 103 breakBlock uniques (BasicBlock ident stmts) entry =
 104     breakBlock' uniques ident entry [] [] stmts
 105     where
 106       breakBlock' uniques current_id entry exits accum_stmts stmts =
 107           case stmts of
 108             [] -> panic "block doesn't end in jump, goto, return or switch"
 109             [CmmJump target arguments] ->
 110                 [BrokenBlock current_id entry accum_stmts
 111                              exits
 112                              (FinalJump target arguments)]
 113             [CmmReturn arguments] ->
 114                 [BrokenBlock current_id entry accum_stmts
 115                              exits
 116                              (FinalReturn arguments)]
 117             [CmmBranch target] ->
 118                 [BrokenBlock current_id entry accum_stmts
 119                              (target:exits)
 120                              (FinalBranch target)]
 121             [CmmSwitch expr targets] ->
 122                 [BrokenBlock current_id entry accum_stmts
 123                              (mapMaybe id targets ++ exits)
 124                              (FinalSwitch expr targets)]
 125             (CmmJump _ _:_) -> panic "jump in middle of block"
 126             (CmmReturn _:_) -> panic "return in middle of block"
 127             (CmmBranch _:_) -> panic "branch in middle of block"
 128             (CmmSwitch _ _:_) -> panic "switch in middle of block"
 129
 130             -- Detect this special case to remain an inverse of
 131             -- 'cmmBlockFromBrokenBlock'
 132             [CmmCall target results arguments,
 133              CmmBranch next_id] -> [block]
 134               where
 135                 block = do_call current_id entry accum_stmts exits next_id
 136                                 target results arguments
 137             (CmmCall target results arguments:stmts) -> block : rest
 138               where
 139                 next_id = BlockId $ head uniques
 140                 block = do_call current_id entry accum_stmts exits next_id
 141                                 target results arguments
 142                 rest = breakBlock' (tail uniques) next_id
 143                                    (ContinuationEntry results) [] [] stmts
 144             (s:stmts) ->
 145                 breakBlock' uniques current_id entry
 146                             (cond_branch_target s++exits)
 147                             (accum_stmts++[s])
 148                             stmts
 149
 150       do_call current_id entry accum_stmts exits next_id
 151               target results arguments =
 152           BrokenBlock current_id entry accum_stmts (next_id:exits)
 153                       (FinalCall next_id target results arguments)
 154
 155       cond_branch_target (CmmCondBranch _ target) = [target]
 156       cond_branch_target _ = []
 157
 158 -----------------------------------------------------------------------------
 159 -- | Convert from a BrokenBlock back to an equivalent CmmBasicBlock
 160 -- Needed by liveness analysis
 161 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
 162 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
 163     BasicBlock ident (stmts++exit_stmt)
 164     where
 165       exit_stmt =
 166           case exit of
 167             FinalBranch target -> [CmmBranch target]
 168             FinalReturn arguments -> [CmmReturn arguments]
 169             FinalJump target arguments -> [CmmJump target arguments]
 170             FinalSwitch expr targets -> [CmmSwitch expr targets]
 171             FinalCall branch_target call_target results arguments ->
 172                 [CmmCall call_target results arguments,
 173                  CmmBranch branch_target]
 174
 175 -----------------------------------------------------------------------------
 176 -- | Build a mapping so we can lookup a 'BrokenBlock' by its 'BlockId'
 177 blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
 178 blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks