compiler/cmm/CmmCPS.hs

   1 module CmmCPS (cmmCPS) where
   2
   3 #include "HsVersions.h"
   4
   5 import Cmm
   6 import CmmLint
   7 import PprCmm
   8
   9 import Dataflow (fixedpoint)
  10 import CmmLive
  11
  12 import MachOp
  13 import ForeignCall
  14 import CLabel
  15 import SMRep
  16 import Constants
  17
  18 import DynFlags
  19 import ErrUtils
  20 import Maybes
  21 import Outputable
  22 import UniqSupply
  23 import UniqFM
  24 import UniqSet
  25 import Unique
  26
  27 import Monad
  28 import IO
  29 import Data.List
  30
  31 --------------------------------------------------------------------------------
  32
  33 -- The format for the call to a continuation
  34 -- The fst is the arguments that must be passed to the continuation
  35 -- by the continuation's caller.
  36 -- The snd is the live values that must be saved on stack.
  37 -- A Nothing indicates an ignored slot.
  38 -- The head of each list is the stack top or the first parameter.
  39
  40 -- The format for live values for a particular continuation
  41 -- All on stack for now.
  42 -- Head element is the top of the stack (or just under the header).
  43 -- Nothing means an empty slot.
  44 -- Future possibilities include callee save registers (i.e. passing slots in register)
  45 -- and heap memory (not sure if that's usefull at all though, but it may
  46 -- be worth exploring the design space).
  47
  48 data BrokenBlock
  49   = BrokenBlock {
  50       brokenBlockId :: BlockId, -- Like a CmmBasicBlock
  51       brokenBlockEntry :: BlockEntryInfo,
  52                                 -- How this block can be entered
  53
  54       brokenBlockStmts :: [CmmStmt],
  55                                 -- Like a CmmBasicBlock
  56                                 -- (but without the last statement)
  57
  58       brokenBlockTargets :: [BlockId],
  59                                 -- Blocks that this block could
  60                                 -- branch to one either by conditional
  61                                 -- branches or via the last statement
  62
  63       brokenBlockExit :: BlockExitInfo
  64                                 -- How the block can be left
  65     }
  66
  67
  68 data BlockEntryInfo
  69   = FunctionEntry               -- Beginning of function
  70
  71   | ContinuationEntry           -- Return point of a call
  72       CmmFormals                -- return values
  73   -- TODO:
  74   -- | ProcPointEntry -- no return values, but some live might end up as params or possibly in the frame
  75
  76   | ControlEntry                -- A label in the input
  77
  78 data BlockExitInfo
  79   = ControlExit
  80     BlockId -- next block (must be a ControlEntry)
  81
  82   | ReturnExit
  83     CmmActuals -- return values
  84
  85   | TailCallExit
  86     CmmExpr -- the function to call
  87     CmmActuals -- arguments to call
  88
  89   | CallExit
  90     BlockId -- next block after call (must be a ContinuationEntry)
  91     CmmCallTarget -- the function to call
  92     CmmFormals -- results from call (redundant with ContinuationEntry)
  93     CmmActuals -- arguments to call
  94     (Maybe [GlobalReg]) -- registers that must be saved (TODO)
  95   -- TODO: | ProcPointExit (needed?)
  96
  97 data StackFormat
  98     = StackFormat
  99          BlockId {- block that is the start of the continuation. may or may not be the current block -}
 100          WordOff {- total frame size -}
 101          [(CmmReg, WordOff)] {- local reg offsets from stack top -}
 102
 103 -- A block can be a continuation of a call
 104 -- A block can be a continuation of another block (w/ or w/o joins)
 105 -- A block can be an entry to a function
 106
 107 --------------------------------------------------------------------------------
 108 -- For now just select the continuation orders in the order they are in the set with no gaps
 109
 110 selectStackFormat2 :: BlockEnv CmmLive -> [BrokenBlock] -> BlockEnv StackFormat
 111 selectStackFormat2 live blocks = fixedpoint dependants update (map brokenBlockId blocks) emptyUFM where
 112   blocks_ufm = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
 113   dependants ident =
 114       brokenBlockTargets $ lookupWithDefaultUFM blocks_ufm (panic "TODO") ident
 115   update ident cause formats =
 116     let BrokenBlock _ entry _ _ _ = lookupWithDefaultUFM blocks_ufm (panic "unknown BlockId in selectStackFormat:live") ident in
 117     case cause of
 118       -- Propagate only to blocks entered by branches (not function entry blocks or continuation entry blocks)
 119       Just cause_name ->
 120           let cause_format = lookupWithDefaultUFM formats (panic "update signaled for block not in format") cause_name
 121           in case entry of
 122             ControlEntry -> Just $ addToUFM formats ident cause_format
 123             FunctionEntry -> Nothing
 124             ContinuationEntry _ -> Nothing
 125       -- Do initial calculates for function blocks
 126       Nothing ->
 127           case entry of
 128             ControlEntry -> Nothing
 129             FunctionEntry -> Just $ addToUFM formats ident $ StackFormat ident 0 []
 130             ContinuationEntry _ -> Just $ addToUFM formats ident $ live_to_format ident $ lookupWithDefaultUFM live (panic "TODO") ident
 131   live_to_format label live =
 132       foldl extend_format
 133                 (StackFormat label retAddrSizeW [])
 134                 (uniqSetToList live)
 135   extend_format :: StackFormat -> LocalReg -> StackFormat
 136   extend_format (StackFormat block size offsets) reg =
 137       StackFormat block (slot_size reg + size) ((CmmLocal reg, size) : offsets)
 138
 139 slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
 140
 141 constructContinuation2 :: BlockEnv StackFormat -> BrokenBlock -> CmmBasicBlock
 142 constructContinuation2 formats (BrokenBlock ident entry stmts _ exit) =
 143     BasicBlock ident (prefix++stmts++postfix)
 144     where
 145       curr_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique ident)) ident
 146       prefix = case entry of
 147                  ControlEntry -> []
 148                  FunctionEntry -> []
 149                  ContinuationEntry formals -> unpack_continuation curr_format
 150       postfix = case exit of
 151                   ControlExit next -> [CmmBranch next]
 152                   ReturnExit arguments -> exit_function curr_format (CmmLoad (CmmReg spReg) wordRep) arguments
 153                   TailCallExit target arguments -> exit_function curr_format target arguments
 154                   -- TODO: do something about global saves
 155                   CallExit next (CmmForeignCall target CmmCallConv) results arguments saves ->
 156                       let cont_format = lookupWithDefaultUFM formats (panic $ "format: unknown block " ++ (showSDoc $ ppr $ getUnique next)) next
 157                       in pack_continuation curr_format cont_format ++
 158                              [CmmJump target arguments]
 159                   CallExit next _ results arguments saves -> panic "unimplemented CmmCall"
 160
 161 --------------------------------------------------------------------------------
 162 -- Functions that generate CmmStmt sequences
 163 -- for packing/unpacking continuations
 164 -- and entering/exiting functions
 165
 166 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
 167 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
 168   = adjust_spReg ++ jump where
 169     adjust_spReg = [
 170      CmmAssign spReg
 171      (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
 172     jump = [CmmJump target arguments]
 173
 174 enter_function :: WordOff -> [CmmStmt]
 175 enter_function max_frame_size
 176   = check_stack_limit where
 177     check_stack_limit = [
 178      CmmCondBranch
 179      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 180                     [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
 181      gc_block]
 182     gc_block = undefined -- TODO: get stack and heap checks to go to same
 183
 184 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
 185 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 186 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 187                        (StackFormat cont_id cont_frame_size cont_offsets)
 188   = save_live_values ++ set_stack_header ++ adjust_spReg where
 189     -- TODO: only save variables when actually needed
 190     save_live_values =
 191         [CmmStore
 192          (CmmRegOff
 193           spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
 194          (CmmReg reg)
 195          | (reg, offset) <- cont_offsets]
 196     set_stack_header = -- TODO: only set when needed
 197         [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
 198     continuation_function = CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique cont_id
 199     adjust_spReg =
 200         if curr_frame_size == cont_frame_size
 201         then []
 202         else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
 203
 204 -- Lazy adjustment of stack headers assumes all blocks
 205 -- that could branch to eachother (i.e. control blocks)
 206 -- have the same stack format (this causes a problem
 207 -- only for proc-point).
 208 unpack_continuation :: StackFormat -> [CmmStmt]
 209 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 210   = load_live_values where
 211     -- TODO: only save variables when actually needed
 212     load_live_values =
 213         [CmmAssign
 214          reg
 215          (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
 216          | (reg, offset) <- curr_offsets]
 217
 218 -----------------------------------------------------------------------------
 219 -- Breaking basic blocks on function calls
 220 -----------------------------------------------------------------------------
 221
 222 -----------------------------------------------------------------------------
 223 -- Takes a basic block and returns a list of basic blocks that
 224 -- each have at most 1 CmmCall in them which must occur at the end.
 225 -- Also returns with each basic block, the variables that will
 226 -- be arguments to the continuation of the block once the call (if any)
 227 -- returns.
 228
 229 breakBlock uniques (BasicBlock ident stmts) entry =
 230     breakBlock' uniques ident entry [] [] stmts where
 231         breakBlock' uniques current_id entry exits accum_stmts stmts =
 232             case stmts of
 233               [] -> panic "block doesn't end in jump, goto or return"
 234               [CmmJump target arguments] ->
 235                   [BrokenBlock current_id entry accum_stmts exits
 236                                    (TailCallExit target arguments)]
 237               [CmmReturn arguments] ->
 238                   [BrokenBlock current_id entry accum_stmts exits
 239                                    (ReturnExit arguments)]
 240               [CmmBranch target] ->
 241                   [BrokenBlock current_id entry accum_stmts (target:exits)
 242                                    (ControlExit target)]
 243               (CmmJump _ _:_) ->
 244                   panic "jump in middle of block"
 245               (CmmReturn _:_) ->
 246                   panic "return in middle of block"
 247               (CmmBranch _:_) ->
 248                   panic "branch in middle of block"
 249               (CmmSwitch _ _:_) ->
 250                   panic "switch in block not implemented"
 251               (CmmCall target results arguments saves:stmts) ->
 252                   let new_id = BlockId $ head uniques
 253                       rest = breakBlock' (tail uniques) new_id (ContinuationEntry results) [] [] stmts
 254                   in BrokenBlock current_id entry accum_stmts (new_id:exits)
 255                          (CallExit new_id target results arguments saves) : rest
 256               (s@(CmmCondBranch test target):stmts) ->
 257                   breakBlock' uniques current_id entry (target:exits) (accum_stmts++[s]) stmts
 258               (s:stmts) ->
 259                   breakBlock' uniques current_id entry exits (accum_stmts++[s]) stmts
 260
 261 -----------------------------------------------------------------------------
 262 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
 263 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) = BasicBlock ident (stmts++exit_stmt)
 264     where
 265       exit_stmt =
 266           case exit of
 267             ControlExit target -> [CmmBranch target]
 268             ReturnExit arguments -> [CmmReturn arguments]
 269             TailCallExit target arguments -> [CmmJump target arguments]
 270             CallExit branch_target call_target results arguments saves -> [CmmCall call_target results arguments saves, CmmBranch branch_target]
 271
 272 -----------------------------------------------------------------------------
 273 -- CPS a single CmmTop (proceedure)
 274 -----------------------------------------------------------------------------
 275
 276 cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
 277 cpsProc uniqSupply x@(CmmData _ _) = [x]
 278 cpsProc uniqSupply x@(CmmProc info_table ident params blocks) =
 279   [CmmProc info_table ident params $ map (constructContinuation2 formats) broken_blocks]
 280     where
 281       uniqes :: [[Unique]]
 282       uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
 283
 284       broken_blocks :: [BrokenBlock]
 285       broken_blocks = concat $ zipWith3 breakBlock uniqes blocks (FunctionEntry:repeat ControlEntry)
 286
 287       live :: BlockEntryLiveness
 288       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
 289
 290       -- TODO: branches for proc points
 291       -- TODO: let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks
 292
 293       formats :: BlockEnv StackFormat   -- Stack format on entry
 294       formats = selectStackFormat2 live broken_blocks
 295
 296
 297 --------------------------------------------------------------------------------
 298 cmmCPS :: DynFlags
 299        -> [Cmm]                 -- C-- with Proceedures
 300        -> IO [Cmm]              -- Output: CPS transformed C--
 301
 302 cmmCPS dflags abstractC = do
 303   when (dopt Opt_DoCmmLinting dflags) $
 304        do showPass dflags "CmmLint"
 305           case firstJust $ map cmmLint abstractC of
 306             Just err -> do printDump err
 307                            ghcExit dflags 1
 308             Nothing  -> return ()
 309   showPass dflags "CPS"
 310   -- TODO: check for use of branches to non-existant blocks
 311   -- TODO: check for use of Sp, SpLim, R1, R2, etc.
 312   -- continuationC <- return abstractC
 313   -- TODO: find out if it is valid to create a new unique source like this
 314   uniqSupply <- mkSplitUniqSupply 'p'
 315   let supplies = listSplitUniqSupply uniqSupply
 316   let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
 317
 318   dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
 319   -- TODO: add option to dump Cmm to file
 320   return continuationC