compiler/cmm/CmmCPS.hs

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