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          stack_label :: Maybe CLabel,   -- The label occupying the top slot
 159          stack_frame_size :: WordOff,   -- Total frame size in words (not including arguments)
 160          stack_live :: [(CmmReg, WordOff)]      -- local reg offsets from stack top
 161                        -- TODO: see if the above can be LocalReg
 162       }
 163
 164 -- A block can be a continuation of a call
 165 -- A block can be a continuation of another block (w/ or w/o joins)
 166 -- A block can be an entry to a function
 167
 168 -----------------------------------------------------------------------------
 169
 170 collectNonProcPointTargets ::
 171     UniqSet BlockId -> BlockEnv BrokenBlock
 172     -> UniqSet BlockId -> BlockId -> UniqSet BlockId
 173 collectNonProcPointTargets proc_points blocks current_targets block =
 174     if sizeUniqSet current_targets == sizeUniqSet new_targets
 175        then current_targets
 176        else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
 177     where
 178       block' = lookupWithDefaultUFM blocks (panic "TODO") block
 179       targets =
 180         -- Note the subtlety that since the extra branch after a call
 181         -- will always be to a block that is a proc-point,
 182         -- this subtraction will always remove that case
 183         uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
 184         -- TODO: remove redundant uniqSetToList
 185       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 186
 187 -- TODO: insert proc point code here
 188 --  * Branches and switches to proc points may cause new blocks to be created
 189 --    (or proc points could leave behind phantom blocks that just jump to them)
 190 --  * Proc points might get some live variables passed as arguments
 191
 192 gatherBlocksIntoContinuation ::
 193     UniqSet BlockId -> BlockEnv BrokenBlock
 194     -> BlockId -> Continuation
 195 gatherBlocksIntoContinuation proc_points blocks start =
 196   Continuation is_entry info_table clabel params body
 197     where
 198       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
 199       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
 200       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
 201       body = start_block : children_blocks
 202       info_table = [] -- TODO
 203       start_block_entry = brokenBlockEntry start_block
 204       is_entry = case start_block_entry of
 205                    FunctionEntry _ _ -> True
 206                    _ -> False
 207       clabel = case start_block_entry of
 208                  FunctionEntry label _ -> label
 209                  _ -> mkReturnPtLabel $ getUnique start
 210       params = case start_block_entry of
 211                  FunctionEntry _ args -> args
 212                  ContinuationEntry args -> args
 213                  ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
 214
 215 --------------------------------------------------------------------------------
 216 -- For now just select the continuation orders in the order they are in the set with no gaps
 217
 218 selectStackFormat :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)]
 219 selectStackFormat live continuations =
 220     map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
 221     where
 222       selectStackFormat' (Continuation True info_table label formals blocks) =
 223           StackFormat (Just label) 0 []
 224       selectStackFormat' (Continuation False info_table label formals blocks) =
 225           -- TODO: assumes the first block is the entry block
 226           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 227           in live_to_format label formals $ lookupWithDefaultUFM live unknown_block ident
 228
 229       live_to_format :: CLabel -> CmmFormals -> CmmLive -> StackFormat
 230       live_to_format label formals live =
 231           foldl extend_format
 232                     (StackFormat (Just label) retAddrSizeW [])
 233                     (uniqSetToList (live `minusUniqSet` mkUniqSet (cmmFormalsToLiveLocals formals)))
 234
 235       extend_format :: StackFormat -> LocalReg -> StackFormat
 236       extend_format (StackFormat label size offsets) reg =
 237           StackFormat label (slot_size reg + size) ((CmmLocal reg, size) : offsets)
 238
 239       slot_size :: LocalReg -> Int
 240       slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
 241
 242       unknown_block = panic "unknown BlockId in selectStackFormat"
 243
 244 continuationToProc :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
 245 continuationToProc formats (Continuation is_entry info label formals blocks) =
 246     CmmProc info label formals (map (continuationToProc' label formats) blocks)
 247     where
 248       continuationToProc' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
 249                              -> CmmBasicBlock
 250       continuationToProc' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
 251           BasicBlock ident (prefix++stmts++postfix)
 252           where
 253             curr_format = maybe unknown_block id $ lookup curr_ident formats
 254             unknown_block = panic "unknown BlockId in continuationToProc"
 255             prefix = case entry of
 256                        ControlEntry -> []
 257                        FunctionEntry _ formals -> -- TODO: gc_stack_check
 258                            function_entry formals curr_format
 259                        ContinuationEntry formals ->
 260                            function_entry formals curr_format
 261             postfix = case exit of
 262                         FinalBranch next -> [CmmBranch next]
 263                         FinalSwitch expr targets -> [CmmSwitch expr targets]
 264                         FinalReturn arguments ->
 265                             tail_call (stack_frame_size curr_format)
 266                                 (CmmLoad (CmmReg spReg) wordRep)
 267                                 arguments
 268                         FinalJump target arguments ->
 269                             tail_call (stack_frame_size curr_format) target arguments
 270                         FinalCall next (CmmForeignCall target CmmCallConv)
 271                             results arguments ->
 272                                 pack_continuation curr_format cont_format ++
 273                                 tail_call (stack_frame_size curr_format - stack_frame_size cont_format)
 274                                               target arguments
 275                             where
 276                               cont_format = maybe unknown_block id $
 277                                             lookup (mkReturnPtLabel $ getUnique next) formats
 278                         FinalCall next _ results arguments -> panic "unimplemented CmmCall"
 279
 280 --------------------------------------------------------------------------------
 281 -- Functions that generate CmmStmt sequences
 282 -- for packing/unpacking continuations
 283 -- and entering/exiting functions
 284
 285 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
 286 tail_call spRel target arguments
 287   = store_arguments ++ adjust_spReg ++ jump where
 288     store_arguments =
 289         [stack_put spRel expr offset
 290          | ((expr, _), StackParam offset) <- argument_formats] ++
 291         [global_put expr global
 292          | ((expr, _), RegisterParam global) <- argument_formats]
 293     adjust_spReg =
 294         if spRel == 0
 295         then []
 296         else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
 297     jump = [CmmJump target arguments]
 298
 299     argument_formats = assignArguments (cmmExprRep . fst) arguments
 300
 301 gc_stack_check :: WordOff -> [CmmStmt]
 302 gc_stack_check max_frame_size
 303   = check_stack_limit where
 304     check_stack_limit = [
 305      CmmCondBranch
 306      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 307                     [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
 308      gc_block]
 309     gc_block = panic "gc_check not implemented" -- TODO: get stack and heap checks to go to same
 310
 311 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
 312 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 313 pack_continuation (StackFormat curr_id curr_frame_size _)
 314                        (StackFormat cont_id cont_frame_size cont_offsets)
 315   = store_live_values ++ set_stack_header where
 316     -- TODO: only save variables when actually needed (may be handled by latter pass)
 317     store_live_values =
 318         [stack_put spRel (CmmReg reg) offset
 319          | (reg, offset) <- cont_offsets]
 320     set_stack_header =
 321         if not needs_header
 322         then []
 323         else [stack_put spRel continuation_function 0]
 324
 325     spRel = curr_frame_size - cont_frame_size
 326     continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
 327     needs_header =
 328         case (curr_id, cont_id) of
 329           (Just x, Just y) -> x /= y
 330           _ -> isJust cont_id
 331
 332 -- Lazy adjustment of stack headers assumes all blocks
 333 -- that could branch to eachother (i.e. control blocks)
 334 -- have the same stack format (this causes a problem
 335 -- only for proc-point).
 336 function_entry :: CmmFormals -> StackFormat -> [CmmStmt]
 337 function_entry formals (StackFormat _ _ curr_offsets)
 338   = load_live_values ++ load_args where
 339     -- TODO: only save variables when actually needed (may be handled by latter pass)
 340     load_live_values =
 341         [stack_get 0 reg offset
 342          | (reg, offset) <- curr_offsets]
 343     load_args =
 344         [stack_get 0 reg offset
 345          | ((reg, _), StackParam offset) <- argument_formats] ++
 346         [global_get reg global
 347          | ((reg, _), RegisterParam global) <- argument_formats]
 348
 349     argument_formats = assignArguments (cmmRegRep . fst) formals
 350
 351 -----------------------------------------------------------------------------
 352 -- Section: Stack and argument register puts and gets
 353 -----------------------------------------------------------------------------
 354 -- TODO: document
 355
 356 -- |Construct a 'CmmStmt' that will save a value on the stack
 357 stack_put :: WordOff            -- ^ Offset from the real 'Sp' that 'offset'
 358                                 -- is relative to (added to offset)
 359           -> CmmExpr            -- ^ What to store onto the stack
 360           -> WordOff            -- ^ Where on the stack to store it
 361                                 -- (positive <=> higher addresses)
 362           -> CmmStmt
 363 stack_put spRel expr offset =
 364     CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
 365
 366 --------------------------------
 367 -- |Construct a
 368 stack_get :: WordOff
 369           -> CmmReg
 370           -> WordOff
 371           -> CmmStmt
 372 stack_get spRel reg offset =
 373     CmmAssign reg (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) (cmmRegRep reg))
 374 global_put :: CmmExpr -> GlobalReg -> CmmStmt
 375 global_put expr global = CmmAssign (CmmGlobal global) expr
 376 global_get :: CmmReg -> GlobalReg -> CmmStmt
 377 global_get reg global = CmmAssign reg (CmmReg (CmmGlobal global))
 378