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 -- |Top level driver for the CPS pass
  39 -----------------------------------------------------------------------------
  40 cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
  41        -> [Cmm]    -- ^ Input C-- with Proceedures
  42        -> IO [Cmm] -- ^ Output CPS transformed C--
  43 cmmCPS dflags abstractC = do
  44   when (dopt Opt_DoCmmLinting dflags) $
  45        do showPass dflags "CmmLint"
  46           case firstJust $ map cmmLint abstractC of
  47             Just err -> do printDump err
  48                            ghcExit dflags 1
  49             Nothing  -> return ()
  50   showPass dflags "CPS"
  51
  52   -- TODO: more lint checking
  53   --        check for use of branches to non-existant blocks
  54   --        check for use of Sp, SpLim, R1, R2, etc.
  55
  56   uniqSupply <- mkSplitUniqSupply 'p'
  57   let supplies = listSplitUniqSupply uniqSupply
  58   let doCpsProc s (Cmm c) =
  59           Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c
  60   let continuationC = zipWith doCpsProc supplies abstractC
  61
  62   dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
  63
  64   -- TODO: add option to dump Cmm to file
  65
  66   return continuationC
  67
  68 -----------------------------------------------------------------------------
  69 -- |CPS a single CmmTop (proceedure)
  70 -- Only 'CmmProc' are transformed 'CmmData' will be left alone.
  71 -----------------------------------------------------------------------------
  72
  73 cpsProc :: UniqSupply
  74         -> CmmTop     -- ^Input proceedure
  75         -> [CmmTop]   -- ^Output proceedure and continuations
  76 cpsProc uniqSupply x@(CmmData _ _) = [x]
  77 cpsProc uniqSupply x@(CmmProc info_table ident params blocks) = cps_procs
  78     where
  79       uniqes :: [[Unique]]
  80       uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
  81
  82       -- Break the block at each function call.
  83       -- The part after the function call will have to become a continuation.
  84       broken_blocks :: [BrokenBlock]
  85       broken_blocks =
  86           concat $ zipWith3 breakBlock uniqes blocks
  87                      (FunctionEntry ident params:repeat ControlEntry)
  88
  89       -- Calculate live variables for each broken block.
  90       --
  91       -- Nothing can be live on entry to the first block
  92       -- so we could take the tail, but for now we wont
  93       -- to help future proof the code.
  94       live :: BlockEntryLiveness
  95       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
  96
  97       -- Calculate which blocks must be made into full fledged procedures.
  98       proc_points :: UniqSet BlockId
  99       proc_points = calculateProcPoints broken_blocks
 100
 101       -- Construct a map so we can lookup a broken block by its 'BlockId'.
 102       block_env :: BlockEnv BrokenBlock
 103       block_env = blocksToBlockEnv broken_blocks
 104
 105       -- Group the blocks into continuations based on the set of proc-points.
 106       continuations :: [Continuation]
 107       continuations = map (gatherBlocksIntoContinuation proc_points block_env)
 108                           (uniqSetToList proc_points)
 109
 110       -- Select the stack format on entry to each continuation.
 111       --
 112       -- This is an association list instead of a UniqFM because
 113       -- CLabel's don't have a 'Uniqueable' instance.
 114       formats :: [(CLabel, StackFormat)]
 115       formats = selectStackFormat live continuations
 116
 117       -- Do the actual CPS transform.
 118       cps_procs :: [CmmTop]
 119       cps_procs = map (continuationToProc formats) continuations
 120
 121 --------------------------------------------------------------------------------
 122
 123 -- The format for the call to a continuation
 124 -- The fst is the arguments that must be passed to the continuation
 125 -- by the continuation's caller.
 126 -- The snd is the live values that must be saved on stack.
 127 -- A Nothing indicates an ignored slot.
 128 -- The head of each list is the stack top or the first parameter.
 129
 130 -- The format for live values for a particular continuation
 131 -- All on stack for now.
 132 -- Head element is the top of the stack (or just under the header).
 133 -- Nothing means an empty slot.
 134 -- Future possibilities include callee save registers (i.e. passing slots in register)
 135 -- and heap memory (not sure if that's usefull at all though, but it may
 136 -- be worth exploring the design space).
 137
 138 continuationLabel (Continuation _ _ l _ _) = l
 139 data Continuation =
 140   Continuation
 141      Bool              -- True => Function entry, False => Continuation/return point
 142      [CmmStatic]       -- Info table, may be empty
 143      CLabel            -- Used to generate both info & entry labels
 144      CmmFormals        -- Argument locals live on entry (C-- procedure params)
 145      [BrokenBlock]   -- Code, may be empty.  The first block is
 146                        -- the entry point.  The order is otherwise initially
 147                        -- unimportant, but at some point the code gen will
 148                        -- fix the order.
 149
 150                        -- the BlockId of the first block does not give rise
 151                        -- to a label.  To jump to the first block in a Proc,
 152                        -- use the appropriate CLabel.
 153
 154 -- Describes the layout of a stack frame for a continuation
 155 data StackFormat
 156     = StackFormat
 157          (Maybe CLabel)         -- The label occupying the top slot
 158          WordOff                -- Total frame size in words
 159          [(CmmReg, WordOff)]    -- local reg offsets from stack top
 160
 161 -- A block can be a continuation of a call
 162 -- A block can be a continuation of another block (w/ or w/o joins)
 163 -- A block can be an entry to a function
 164
 165 -----------------------------------------------------------------------------
 166
 167 collectNonProcPointTargets ::
 168     UniqSet BlockId -> BlockEnv BrokenBlock
 169     -> UniqSet BlockId -> BlockId -> UniqSet BlockId
 170 collectNonProcPointTargets proc_points blocks current_targets block =
 171     if sizeUniqSet current_targets == sizeUniqSet new_targets
 172        then current_targets
 173        else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
 174     where
 175       block' = lookupWithDefaultUFM blocks (panic "TODO") block
 176       targets =
 177         -- Note the subtlety that since the extra branch after a call
 178         -- will always be to a block that is a proc-point,
 179         -- this subtraction will always remove that case
 180         uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
 181         -- TODO: remove redundant uniqSetToList
 182       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 183
 184 -- TODO: insert proc point code here
 185 --  * Branches and switches to proc points may cause new blocks to be created
 186 --    (or proc points could leave behind phantom blocks that just jump to them)
 187 --  * Proc points might get some live variables passed as arguments
 188
 189 gatherBlocksIntoContinuation ::
 190     UniqSet BlockId -> BlockEnv BrokenBlock
 191     -> BlockId -> Continuation
 192 gatherBlocksIntoContinuation proc_points blocks start =
 193   Continuation is_entry info_table clabel params body
 194     where
 195       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
 196       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
 197       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
 198       body = start_block : children_blocks
 199       info_table = [] -- TODO
 200       start_block_entry = brokenBlockEntry start_block
 201       is_entry = case start_block_entry of
 202                    FunctionEntry _ _ -> True
 203                    _ -> False
 204       clabel = case start_block_entry of
 205                  FunctionEntry label _ -> label
 206                  _ -> mkReturnPtLabel $ getUnique start
 207       params = case start_block_entry of
 208                  FunctionEntry _ args -> args
 209                  ContinuationEntry args -> args
 210                  ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
 211
 212 --------------------------------------------------------------------------------
 213 -- For now just select the continuation orders in the order they are in the set with no gaps
 214
 215 selectStackFormat :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)]
 216 selectStackFormat live continuations =
 217     map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
 218     where
 219       selectStackFormat' (Continuation True info_table label formals blocks) =
 220           --let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 221           --in
 222           StackFormat (Just label) 0 []
 223       selectStackFormat' (Continuation False info_table label formals blocks) =
 224           -- TODO: assumes the first block is the entry block
 225           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 226           in live_to_format label formals $ lookupWithDefaultUFM live unknown_block ident
 227
 228       live_to_format :: CLabel -> CmmFormals -> CmmLive -> StackFormat
 229       live_to_format label formals live =
 230           foldl extend_format
 231                     (StackFormat (Just label) retAddrSizeW [])
 232                     (uniqSetToList (live `minusUniqSet` mkUniqSet (cmmFormalsToLiveLocals formals)))
 233
 234       extend_format :: StackFormat -> LocalReg -> StackFormat
 235       extend_format (StackFormat label size offsets) reg =
 236           StackFormat label (slot_size reg + size) ((CmmLocal reg, size) : offsets)
 237
 238       slot_size :: LocalReg -> Int
 239       slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
 240
 241       unknown_block = panic "unknown BlockId in selectStackFormat"
 242
 243 continuationToProc :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
 244 continuationToProc formats (Continuation is_entry info label formals blocks) =
 245     CmmProc info label formals (map (continuationToProc' label formats) blocks)
 246     where
 247       continuationToProc' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
 248                              -> CmmBasicBlock
 249       continuationToProc' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
 250           BasicBlock ident (prefix++stmts++postfix)
 251           where
 252             curr_format = maybe unknown_block id $ lookup curr_ident formats
 253             unknown_block = panic "unknown BlockId in continuationToProc"
 254             prefix = case entry of
 255                        ControlEntry -> []
 256                        FunctionEntry _ _ -> []
 257                        ContinuationEntry formals ->
 258                            unpack_continuation curr_format
 259             postfix = case exit of
 260                         FinalBranch next -> [CmmBranch next]
 261                         FinalSwitch expr targets -> [CmmSwitch expr targets]
 262                         FinalReturn arguments ->
 263                             exit_function curr_format
 264                                 (CmmLoad (CmmReg spReg) wordRep)
 265                                 arguments
 266                         FinalJump target arguments ->
 267                             exit_function curr_format target arguments
 268                         FinalCall next (CmmForeignCall target CmmCallConv)
 269                             results arguments ->
 270                                 pack_continuation curr_format cont_format ++
 271                                 [CmmJump target arguments]
 272                             where
 273                               cont_format = maybe unknown_block id $
 274                                             lookup (mkReturnPtLabel $ getUnique next) formats
 275                         FinalCall next _ results arguments -> panic "unimplemented CmmCall"
 276
 277 --------------------------------------------------------------------------------
 278 -- Functions that generate CmmStmt sequences
 279 -- for packing/unpacking continuations
 280 -- and entering/exiting functions
 281
 282 exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
 283 exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
 284   = adjust_spReg ++ jump where
 285     adjust_spReg =
 286         if curr_frame_size == 0
 287         then []
 288         else [CmmAssign spReg
 289                  (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
 290     jump = [CmmJump target arguments]
 291
 292 enter_function :: WordOff -> [CmmStmt]
 293 enter_function max_frame_size
 294   = check_stack_limit where
 295     check_stack_limit = [
 296      CmmCondBranch
 297      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 298                     [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
 299      gc_block]
 300     gc_block = undefined -- TODO: get stack and heap checks to go to same
 301
 302 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
 303 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 304 pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 305                        (StackFormat cont_id cont_frame_size cont_offsets)
 306   = save_live_values ++ set_stack_header ++ adjust_spReg where
 307     -- TODO: only save variables when actually needed
 308     save_live_values =
 309         [CmmStore
 310          (CmmRegOff
 311           spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
 312          (CmmReg reg)
 313          | (reg, offset) <- cont_offsets]
 314     needs_header =
 315       case (curr_id, cont_id) of
 316         (Just x, Just y) -> x /= y
 317         _ -> isJust cont_id
 318     set_stack_header =
 319       if not needs_header
 320          then []
 321          else [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
 322     continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
 323     adjust_spReg =
 324         if curr_frame_size == cont_frame_size
 325         then []
 326         else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
 327
 328 -- Lazy adjustment of stack headers assumes all blocks
 329 -- that could branch to eachother (i.e. control blocks)
 330 -- have the same stack format (this causes a problem
 331 -- only for proc-point).
 332 unpack_continuation :: StackFormat -> [CmmStmt]
 333 unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
 334   = load_live_values where
 335     -- TODO: only save variables when actually needed
 336     load_live_values =
 337         [CmmAssign
 338          reg
 339          (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
 340          | (reg, offset) <- curr_offsets]
 341