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 import CmmCPSData
  12 import CmmProcPoint
  13
  14 import MachOp
  15 import ForeignCall
  16 import CLabel
  17 import SMRep
  18 import Constants
  19
  20 import DynFlags
  21 import ErrUtils
  22 import Maybes
  23 import Outputable
  24 import UniqSupply
  25 import UniqFM
  26 import UniqSet
  27 import Unique
  28
  29 import Monad
  30 import IO
  31 import Data.List
  32
  33 --------------------------------------------------------------------------------
  34
  35 -- The format for the call to a continuation
  36 -- The fst is the arguments that must be passed to the continuation
  37 -- by the continuation's caller.
  38 -- The snd is the live values that must be saved on stack.
  39 -- A Nothing indicates an ignored slot.
  40 -- The head of each list is the stack top or the first parameter.
  41
  42 -- The format for live values for a particular continuation
  43 -- All on stack for now.
  44 -- Head element is the top of the stack (or just under the header).
  45 -- Nothing means an empty slot.
  46 -- Future possibilities include callee save registers (i.e. passing slots in register)
  47 -- and heap memory (not sure if that's usefull at all though, but it may
  48 -- be worth exploring the design space).
  49
  50 continuationLabel (Continuation _ _ l _ _) = l
  51 data Continuation =
  52   Continuation
  53      Bool              -- True => Function entry, False => Continuation/return point
  54      [CmmStatic]       -- Info table, may be empty
  55      CLabel            -- Used to generate both info & entry labels
  56      CmmFormals        -- Argument locals live on entry (C-- procedure params)
  57      [BrokenBlock]   -- Code, may be empty.  The first block is
  58                        -- the entry point.  The order is otherwise initially
  59                        -- unimportant, but at some point the code gen will
  60                        -- fix the order.
  61
  62                        -- the BlockId of the first block does not give rise
  63                        -- to a label.  To jump to the first block in a Proc,
  64                        -- use the appropriate CLabel.
  65
  66 -- Describes the layout of a stack frame for a continuation
  67 data StackFormat
  68     = StackFormat
  69          (Maybe CLabel)         -- The label occupying the top slot
  70          WordOff                -- Total frame size in words
  71          [(CmmReg, WordOff)]    -- local reg offsets from stack top
  72
  73 -- A block can be a continuation of a call
  74 -- A block can be a continuation of another block (w/ or w/o joins)
  75 -- A block can be an entry to a function
  76
  77 -----------------------------------------------------------------------------
  78
  79 collectNonProcPointTargets ::
  80     UniqSet BlockId -> BlockEnv BrokenBlock
  81     -> UniqSet BlockId -> BlockId -> UniqSet BlockId
  82 collectNonProcPointTargets proc_points blocks current_targets block =
  83     if sizeUniqSet current_targets == sizeUniqSet new_targets
  84        then current_targets
  85        else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
  86     where
  87       block' = lookupWithDefaultUFM blocks (panic "TODO") block
  88       targets =
  89         -- Note the subtlety that since the extra branch after a call
  90         -- will always be to a block that is a proc-point,
  91         -- this subtraction will always remove that case
  92         uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
  93         -- TODO: remove redundant uniqSetToList
  94       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
  95
  96 buildContinuation ::
  97     UniqSet BlockId -> BlockEnv BrokenBlock
  98     -> BlockId -> Continuation
  99 buildContinuation proc_points blocks start =
 100   Continuation is_entry info_table clabel params body
 101     where
 102       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
 103       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
 104       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
 105       body = start_block : children_blocks
 106       info_table = [] -- TODO
 107       start_block_entry = brokenBlockEntry start_block
 108       is_entry = case start_block_entry of
 109                    FunctionEntry _ _ -> True
 110                    _ -> False
 111       clabel = case start_block_entry of
 112                  FunctionEntry label _ -> label
 113                  _ -> mkReturnPtLabel $ getUnique start
 114       params = case start_block_entry of
 115                  FunctionEntry _ args -> args
 116                  ContinuationEntry args -> args
 117                  ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
 118
 119 --------------------------------------------------------------------------------
 120 -- For now just select the continuation orders in the order they are in the set with no gaps
 121
 122 selectStackFormat2 :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)]
 123 selectStackFormat2 live continuations =
 124     map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
 125     where
 126       selectStackFormat' (Continuation True info_table label formals blocks) =
 127           --let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 128           --in
 129           StackFormat (Just label) 0 []
 130       selectStackFormat' (Continuation False info_table label formals blocks) =
 131           -- TODO: assumes the first block is the entry block
 132           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 133           in live_to_format label formals $ lookupWithDefaultUFM live unknown_block ident
 134
 135       live_to_format :: CLabel -> CmmFormals -> CmmLive -> StackFormat
 136       live_to_format label formals live =
 137           foldl extend_format
 138                     (StackFormat (Just label) retAddrSizeW [])
 139                     (uniqSetToList (live `minusUniqSet` mkUniqSet (cmmFormalsToLiveLocals formals)))
 140
 141       extend_format :: StackFormat -> LocalReg -> StackFormat
 142       extend_format (StackFormat label size offsets) reg =
 143           StackFormat label (slot_size reg + size) ((CmmLocal reg, size) : offsets)
 144
 145       unknown_block = panic "unknown BlockId in selectStackFormat"
 146
 147 slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
 148
 149 constructContinuation :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
 150 constructContinuation formats (Continuation is_entry info label formals blocks) =
 151     CmmProc info label formals (map (constructContinuation2' label formats) blocks)
 152
 153 constructContinuation2' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
 154                        -> CmmBasicBlock
 155 constructContinuation2' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
 156     BasicBlock ident (prefix++stmts++postfix)
 157     where
 158       curr_format = maybe unknown_block id $ lookup curr_ident formats
 159       unknown_block = panic "unknown BlockId in constructContinuation"
 160       prefix = case entry of
 161                  ControlEntry -> []
 162                  FunctionEntry _ _ -> []
 163                  ContinuationEntry formals ->
 164                      unpack_continuation curr_format
 165       postfix = case exit of
 166                   FinalBranch next -> [CmmBranch next]
 167                   FinalSwitch expr targets -> [CmmSwitch expr targets]
 168                   FinalReturn arguments ->
 169                       exit_function curr_format
 170                                     (CmmLoad (CmmReg spReg) wordRep)
 171                                     arguments
 172                   FinalJump target arguments ->
 173                       exit_function curr_format target arguments
 174                   -- TODO: do something about global saves
 175                   FinalCall next (CmmForeignCall target CmmCallConv)
 176                             results arguments saves ->
 177                                 pack_continuation curr_format cont_format ++
 178                                 [CmmJump target arguments]
 179                             where
 180                               cont_format = maybe unknown_block id $
 181                                             lookup (mkReturnPtLabel $ getUnique next) formats
 182                   FinalCall next _ results arguments saves -> panic "unimplemented CmmCall"
 183
 184 --------------------------------------------------------------------------------
 185 -- Functions that generate CmmStmt sequences
 186 -- for packing/unpacking continuations
 187 -- and entering/exiting functions
 188
 189 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
 190 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
 191   = adjust_spReg ++ jump where
 192     adjust_spReg =
 193         if curr_frame_size == 0
 194         then []
 195         else [CmmAssign spReg
 196                  (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
 197     jump = [CmmJump target arguments]
 198
 199 enter_function :: WordOff -> [CmmStmt]
 200 enter_function max_frame_size
 201   = check_stack_limit where
 202     check_stack_limit = [
 203      CmmCondBranch
 204      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 205                     [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
 206      gc_block]
 207     gc_block = undefined -- TODO: get stack and heap checks to go to same
 208
 209 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
 210 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 211 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 212                        (StackFormat cont_id cont_frame_size cont_offsets)
 213   = save_live_values ++ set_stack_header ++ adjust_spReg where
 214     -- TODO: only save variables when actually needed
 215     save_live_values =
 216         [CmmStore
 217          (CmmRegOff
 218           spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
 219          (CmmReg reg)
 220          | (reg, offset) <- cont_offsets]
 221     needs_header =
 222       case (curr_id, cont_id) of
 223         (Just x, Just y) -> x /= y
 224         _ -> isJust cont_id
 225     set_stack_header =
 226       if not needs_header
 227          then []
 228          else [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
 229     continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
 230     adjust_spReg =
 231         if curr_frame_size == cont_frame_size
 232         then []
 233         else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
 234
 235 -- Lazy adjustment of stack headers assumes all blocks
 236 -- that could branch to eachother (i.e. control blocks)
 237 -- have the same stack format (this causes a problem
 238 -- only for proc-point).
 239 unpack_continuation :: StackFormat -> [CmmStmt]
 240 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 241   = load_live_values where
 242     -- TODO: only save variables when actually needed
 243     load_live_values =
 244         [CmmAssign
 245          reg
 246          (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
 247          | (reg, offset) <- curr_offsets]
 248
 249 -----------------------------------------------------------------------------
 250 -- Breaking basic blocks on function calls
 251 -----------------------------------------------------------------------------
 252
 253 -----------------------------------------------------------------------------
 254 -- Takes a basic block and breaks it up into a list of broken blocks
 255 --
 256 -- Takes a basic block and returns a list of basic blocks that
 257 -- each have at most 1 CmmCall in them which must occur at the end.
 258 -- Also returns with each basic block, the variables that will
 259 -- be arguments to the continuation of the block once the call (if any)
 260 -- returns.
 261
 262 breakBlock :: [Unique] -> CmmBasicBlock -> BlockEntryInfo -> [BrokenBlock]
 263 breakBlock uniques (BasicBlock ident stmts) entry =
 264     breakBlock' uniques ident entry [] [] stmts where
 265         breakBlock' uniques current_id entry exits accum_stmts stmts =
 266             case stmts of
 267               [] -> panic "block doesn't end in jump, goto or return"
 268               [CmmJump target arguments] ->
 269                   [BrokenBlock current_id entry accum_stmts
 270                                exits
 271                                (FinalJump target arguments)]
 272               [CmmReturn arguments] ->
 273                   [BrokenBlock current_id entry accum_stmts
 274                                exits
 275                                (FinalReturn arguments)]
 276               [CmmBranch target] ->
 277                   [BrokenBlock current_id entry accum_stmts
 278                                (target:exits)
 279                                (FinalBranch target)]
 280               [CmmSwitch expr targets] ->
 281                   [BrokenBlock current_id entry accum_stmts
 282                                (mapMaybe id targets ++ exits)
 283                                (FinalSwitch expr targets)]
 284               (CmmJump _ _:_) ->
 285                   panic "jump in middle of block"
 286               (CmmReturn _:_) ->
 287                   panic "return in middle of block"
 288               (CmmBranch _:_) ->
 289                   panic "branch in middle of block"
 290               (CmmSwitch _ _:_) ->
 291                   panic ("switch in middle of block" ++ (showSDoc $ ppr stmts))
 292               (CmmCall target results arguments saves:stmts) -> block : rest
 293                   where
 294                     new_id = BlockId $ head uniques
 295                     block = BrokenBlock current_id entry accum_stmts
 296                             (new_id:exits)
 297                             (FinalCall new_id target results arguments saves)
 298                     rest = breakBlock' (tail uniques) new_id
 299                            (ContinuationEntry results) [] [] stmts
 300               (s@(CmmCondBranch test target):stmts) ->
 301                   breakBlock' uniques current_id entry
 302                               (target:exits) (accum_stmts++[s]) stmts
 303               (s:stmts) ->
 304                   breakBlock' uniques current_id entry
 305                               exits (accum_stmts++[s]) stmts
 306
 307 --------------------------------
 308 -- Convert from a BrokenBlock
 309 -- to a CmmBasicBlock so the
 310 -- liveness analysis can run
 311 -- on it.
 312 --------------------------------
 313 cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
 314 cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
 315     BasicBlock ident (stmts++exit_stmt)
 316     where
 317       exit_stmt =
 318           case exit of
 319             FinalBranch target -> [CmmBranch target]
 320             FinalReturn arguments -> [CmmReturn arguments]
 321             FinalJump target arguments -> [CmmJump target arguments]
 322             FinalSwitch expr targets -> [CmmSwitch expr targets]
 323             FinalCall branch_target call_target results arguments saves ->
 324                 [CmmCall call_target results arguments saves,
 325                  CmmBranch branch_target]
 326
 327 -----------------------------------------------------------------------------
 328 -- CPS a single CmmTop (proceedure)
 329 -----------------------------------------------------------------------------
 330
 331 cpsProc :: UniqSupply -> CmmTop -> [CmmTop]
 332 cpsProc uniqSupply x@(CmmData _ _) = [x]
 333 cpsProc uniqSupply x@(CmmProc info_table ident params blocks) =
 334     --[CmmProc info_table ident params cps_blocks]
 335     cps_continuations
 336     where
 337       uniqes :: [[Unique]]
 338       uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
 339
 340       -- Break the block at each function call
 341       broken_blocks :: [BrokenBlock]
 342       broken_blocks = concat $ zipWith3 breakBlock uniqes blocks
 343                                         (FunctionEntry ident params:repeat ControlEntry)
 344
 345       -- Calculate live variables for each broken block
 346       live :: BlockEntryLiveness
 347       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
 348              -- nothing can be live on entry to the first block so we could take the tail
 349
 350       proc_points :: UniqSet BlockId
 351       proc_points = calculateProcPoints broken_blocks
 352
 353       continuations :: [Continuation]
 354       continuations = map (buildContinuation proc_points (blocksToBlockEnv broken_blocks)) (uniqSetToList proc_points)
 355
 356       -- TODO: insert proc point code here
 357       --  * Branches and switches to proc points may cause new blocks to be created
 358       --    (or proc points could leave behind phantom blocks that just jump to them)
 359       --  * Proc points might get some live variables passed as arguments
 360
 361       -- TODO: let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks
 362
 363       --procs = groupBlocksIntoContinuations live broken_blocks
 364
 365       -- Select the stack format on entry to each block
 366       formats2 :: [(CLabel, StackFormat)]
 367       formats2 = selectStackFormat2 live continuations
 368
 369       -- Do the actual CPS transform
 370       cps_continuations :: [CmmTop]
 371       cps_continuations = map (constructContinuation formats2) continuations
 372
 373 --------------------------------------------------------------------------------
 374 cmmCPS :: DynFlags
 375        -> [Cmm]                 -- C-- with Proceedures
 376        -> IO [Cmm]              -- Output: CPS transformed C--
 377
 378 cmmCPS dflags abstractC = do
 379   when (dopt Opt_DoCmmLinting dflags) $
 380        do showPass dflags "CmmLint"
 381           case firstJust $ map cmmLint abstractC of
 382             Just err -> do printDump err
 383                            ghcExit dflags 1
 384             Nothing  -> return ()
 385   showPass dflags "CPS"
 386   -- TODO: check for use of branches to non-existant blocks
 387   -- TODO: check for use of Sp, SpLim, R1, R2, etc.
 388   -- TODO: find out if it is valid to create a new unique source like this
 389   uniqSupply <- mkSplitUniqSupply 'p'
 390   let supplies = listSplitUniqSupply uniqSupply
 391   let continuationC = zipWith (\s (Cmm c) -> Cmm $ concat $ zipWith (cpsProc) (listSplitUniqSupply s) c) supplies abstractC
 392
 393   dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
 394   -- TODO: add option to dump Cmm to file
 395   return continuationC