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