CmmCPS.hs 17.2 KB
Newer Older
1 2 3 4 5
module CmmCPS (
  -- | Converts C-- with full proceedures and parameters
  -- to a CPS transformed C-- with the stack made manifest.
  cmmCPS
) where
6 7 8

#include "HsVersions.h"

9
import BlockId
10 11 12 13
import Cmm
import CmmLint
import PprCmm

14
import CmmLive
15
import CmmBrokenBlock
16
import CmmProcPoint
Michael D. Adams's avatar
Michael D. Adams committed
17
import CmmCallConv
18
import CmmCPSGen
19
import CmmUtils
20

21
import ClosureInfo
22
import CLabel
23 24
import SMRep
import Constants
25 26 27 28 29

import DynFlags
import ErrUtils
import Maybes
import Outputable
30 31 32
import UniqSupply
import UniqSet
import Unique
33 34

import Monad
35

36 37 38 39
-----------------------------------------------------------------------------
-- |Top level driver for the CPS pass
-----------------------------------------------------------------------------
cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
40 41 42 43 44 45 46 47 48 49
       -> [Cmm]    -- ^ Input C-- with Proceedures
       -> IO [Cmm] -- ^ Output CPS transformed C--
cmmCPS dflags cmm_with_calls
  = do	{ when (dopt Opt_DoCmmLinting dflags) $
	       do showPass dflags "CmmLint"
		  case firstJust $ map cmmLint cmm_with_calls of
		    Just err -> do printDump err
				   ghcExit dflags 1
		    Nothing  -> return ()
	; showPass dflags "CPS"
50 51 52 53 54

  -- TODO: more lint checking
  --        check for use of branches to non-existant blocks
  --        check for use of Sp, SpLim, R1, R2, etc.

55 56 57
	; uniqSupply <- mkSplitUniqSupply 'p'
	; let supplies = listSplitUniqSupply uniqSupply
	; let cpsd_cmm = zipWith doCpsProc supplies cmm_with_calls
58

59
	; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms cpsd_cmm)
60 61 62

  -- TODO: add option to dump Cmm to file

63
	; return cpsd_cmm }
64

65

66 67 68 69 70
-----------------------------------------------------------------------------
-- |CPS a single CmmTop (proceedure)
-- Only 'CmmProc' are transformed 'CmmData' will be left alone.
-----------------------------------------------------------------------------

71 72 73 74
doCpsProc :: UniqSupply -> Cmm -> Cmm
doCpsProc s (Cmm c) 
  = Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c

75
cpsProc :: UniqSupply 
76 77 78 79
        -> CmmTop     -- ^Input procedure
        -> [CmmTop]   -- ^Output procedures; 
		      --   a single input procedure is converted to
		      --   multiple output procedures
80 81

-- Data blocks don't need to be CPS transformed
Ian Lynagh's avatar
Ian Lynagh committed
82
cpsProc _ proc@(CmmData _ _) = [proc]
83 84 85

-- Empty functions just don't work with the CPS algorithm, but
-- they don't need the transformation anyway so just output them directly
Ian Lynagh's avatar
Ian Lynagh committed
86
cpsProc _ proc@(CmmProc _ _ _ (ListGraph []))
87
  = pprTrace "cpsProc: unexpected empty proc" (ppr proc) [proc]
88 89

-- CPS transform for those procs that actually need it
90 91 92 93 94 95 96
-- The plan is this:
--
--   * Introduce a stack-check block as the first block
--   * The first blocks gets a FunctionEntry; the rest are ControlEntry
--   * Now break each block into a bunch of blocks (at call sites); 
--	all but the first will be ContinuationEntry
--
97
cpsProc uniqSupply (CmmProc info ident params (ListGraph blocks)) = cps_procs
98
    where
99 100 101 102
      -- We need to be generating uniques for several things.
      -- We could make this function monadic to handle that
      -- but since there is no other reason to make it monadic,
      -- we instead will just split them all up right here.
103
      (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
104
      uniques :: [[Unique]]
105
      uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
106
      (stack_check_block_unique:stack_use_unique:adaptor_uniques) :
107
       block_uniques = uniques
108
      proc_uniques = map (map (map uniqsFromSupply . listSplitUniqSupply) . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2
109

110
      stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegType spReg))
111 112
      stack_check_block_id = BlockId stack_check_block_unique
      stack_check_block = make_stack_check stack_check_block_id info stack_use (blockId $ head blocks)
113

114
      forced_blocks = stack_check_block : blocks
115

116
      CmmInfo maybe_gc_block_id update_frame _ = info
117 118 119

      -- Break the block at each function call.
      -- The part after the function call will have to become a continuation.
120
      broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
121
      broken_blocks =
122
          (\x -> (concatMap fst x, concatMap snd x)) $
123
          zipWith3 (breakBlock (maybeToList maybe_gc_block_id))
124 125
                     block_uniques
                     forced_blocks
126
                     (FunctionEntry info ident params :
127 128 129 130 131 132 133 134
                      repeat ControlEntry)

      f' = selectContinuations (fst broken_blocks)
      broken_blocks' = map (makeContinuationEntries f') $
                       concat $
                       zipWith (adaptBlockToFormat f')
                               adaptor_uniques
                               (snd broken_blocks)
135 136 137 138 139 140 141

      -- Calculate live variables for each broken block.
      --
      -- Nothing can be live on entry to the first block
      -- so we could take the tail, but for now we wont
      -- to help future proof the code.
      live :: BlockEntryLiveness
142
      live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks'
143 144 145

      -- Calculate which blocks must be made into full fledged procedures.
      proc_points :: UniqSet BlockId
146
      proc_points = calculateProcPoints broken_blocks'
147 148 149

      -- Construct a map so we can lookup a broken block by its 'BlockId'.
      block_env :: BlockEnv BrokenBlock
150
      block_env = blocksToBlockEnv broken_blocks'
151 152

      -- Group the blocks into continuations based on the set of proc-points.
153
      continuations :: [Continuation (Either C_SRT CmmInfo)]
154 155
      continuations = map (gatherBlocksIntoContinuation live proc_points block_env)
                          (uniqSetToList proc_points)
156 157

      -- Select the stack format on entry to each continuation.
158
      -- Return the max stack offset and an association list
159 160 161
      --
      -- This is an association list instead of a UniqFM because
      -- CLabel's don't have a 'Uniqueable' instance.
162
      formats :: [(CLabel,              -- key
163
                   (CmmFormals,         -- arguments
164
                    Maybe CLabel,       -- label in top slot
165
                    [Maybe LocalReg]))] -- slots
166
      formats = selectContinuationFormat live continuations
167

168 169
      -- Do a little meta-processing on the stack formats such as
      -- getting the individual frame sizes and the maximum frame size
170 171
      formats' :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
      formats'@(_, _, format_list) = processFormats formats update_frame continuations
172 173 174 175

      -- Update the info table data on the continuations with
      -- the selected stack formats.
      continuations' :: [Continuation CmmInfo]
176
      continuations' = map (applyContinuationFormat format_list) continuations
177

178 179
      -- Do the actual CPS transform.
      cps_procs :: [CmmTop]
180
      cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
181

Ian Lynagh's avatar
Ian Lynagh committed
182 183
make_stack_check :: BlockId -> CmmInfo -> CmmReg -> BlockId
                 -> GenBasicBlock CmmStmt
184 185 186 187 188 189 190 191 192 193
make_stack_check stack_check_block_id info stack_use next_block_id =
    BasicBlock stack_check_block_id $
                   check_stmts ++ [CmmBranch next_block_id]
    where
      check_stmts =
          case info of
            -- If we are given a stack check handler,
            -- then great, well check the stack.
            CmmInfo (Just gc_block) _ _
                -> [CmmCondBranch
194
                    (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg)))
195 196 197 198 199 200
                     [CmmReg stack_use, CmmReg spLimReg])
                    gc_block]
            -- If we aren't given a stack check handler,
            -- then humph! we just won't check the stack for them.
            CmmInfo Nothing _ _
                -> []
201 202 203 204
-----------------------------------------------------------------------------

collectNonProcPointTargets ::
    UniqSet BlockId -> BlockEnv BrokenBlock
205 206
    -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
collectNonProcPointTargets proc_points blocks current_targets new_blocks =
207 208
    if sizeUniqSet current_targets == sizeUniqSet new_targets
       then current_targets
209 210 211 212
       else foldl
                (collectNonProcPointTargets proc_points blocks)
                new_targets
                (map (:[]) targets)
213
    where
214
      blocks' = map (lookupWithDefaultBEnv blocks (panic "TODO")) new_blocks
215 216 217 218
      targets =
        -- Note the subtlety that since the extra branch after a call
        -- will always be to a block that is a proc-point,
        -- this subtraction will always remove that case
219 220
        uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
                          `minusUniqSet` proc_points
221 222 223
        -- TODO: remove redundant uniqSetToList
      new_targets = current_targets `unionUniqSets` (mkUniqSet targets)

224 225 226 227 228 229
-- TODO: insert proc point code here
--  * Branches and switches to proc points may cause new blocks to be created
--    (or proc points could leave behind phantom blocks that just jump to them)
--  * Proc points might get some live variables passed as arguments

gatherBlocksIntoContinuation ::
230
    BlockEntryLiveness -> UniqSet BlockId -> BlockEnv BrokenBlock
231 232
    -> BlockId -> Continuation (Either C_SRT CmmInfo)
gatherBlocksIntoContinuation live proc_points blocks start =
233
  Continuation info_table clabel params is_gc_cont body
234
    where
235
      children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
236 237
      start_block = lookupWithDefaultBEnv blocks unknown_block start
      children_blocks = map (lookupWithDefaultBEnv blocks unknown_block) (uniqSetToList children)
238
      unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
239
      body = start_block : children_blocks
240 241 242 243 244 245

      -- We can't properly annotate the continuation's stack parameters
      -- at this point because this is before stack selection
      -- but we want to keep the C_SRT around so we use 'Either'.
      info_table = case start_block_entry of
                     FunctionEntry info _ _ -> Right info
246
                     ContinuationEntry _ srt _ -> Left srt
247
                     ControlEntry -> Right (CmmInfo Nothing Nothing CmmNonInfoTable)
248

249 250 251 252 253
      is_gc_cont = case start_block_entry of
                     FunctionEntry _ _ _ -> False
                     ContinuationEntry _ _ gc_cont -> gc_cont
                     ControlEntry -> False

254 255
      start_block_entry = brokenBlockEntry start_block
      clabel = case start_block_entry of
256
                 FunctionEntry _ label _ -> label
257 258
                 _ -> mkReturnPtLabel $ getUnique start
      params = case start_block_entry of
259
                 FunctionEntry _ _ args -> args
260 261 262
                 ContinuationEntry args _ _ -> args
                 ControlEntry ->
                     uniqSetToList $
263
                     lookupWithDefaultBEnv live unknown_block start
264
                     -- it's a proc-point, pass lives in parameter registers
265

266
--------------------------------------------------------------------------------
267
-- For now just select the continuation orders in the order they are in the set with no gaps
268

269
selectContinuationFormat :: BlockEnv CmmLive
270
                  -> [Continuation (Either C_SRT CmmInfo)]
271
                  -> [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
272 273
selectContinuationFormat live continuations =
    map (\c -> (continuationLabel c, selectContinuationFormat' c)) continuations
274
    where
275
      -- User written continuations
276
      selectContinuationFormat' (Continuation
Ian Lynagh's avatar
Ian Lynagh committed
277
                          (Right (CmmInfo _ _ (CmmInfoTable _ _ _ (ContInfo format _))))
278 279
                          label formals _ _) =
          (formals, Just label, format)
280 281
      -- Either user written non-continuation code
      -- or CPS generated proc-points
282 283 284
      selectContinuationFormat' (Continuation (Right _) _ formals _ _) =
          (formals, Nothing, [])
      -- CPS generated continuations
Ian Lynagh's avatar
Ian Lynagh committed
285
      selectContinuationFormat' (Continuation (Left _) label formals _ blocks) =
286
          -- TODO: assumes the first block is the entry block
287
          let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
288 289
          in (formals,
              Just label,
290
              map Just $ uniqSetToList $
291
              lookupWithDefaultBEnv live unknown_block ident)
292

293
      unknown_block = panic "unknown BlockId in selectContinuationFormat"
294

295
processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
296
               -> Maybe UpdateFrame
297
               -> [Continuation (Either C_SRT CmmInfo)]
298 299 300
               -> (WordOff, WordOff, [(CLabel, ContinuationFormat)])
processFormats formats update_frame continuations =
    (max_size + update_frame_size, update_frame_size, formats')
301
    where
302 303
      max_size = maximum $
                 0 : map (continuationMaxStack formats') continuations
304
      formats' = map make_format formats
305
      make_format (label, (formals, top, stack)) =
306
          (label,
307 308 309 310 311
           ContinuationFormat {
             continuation_formals = formals,
             continuation_label = top,
             continuation_frame_size = stack_size stack +
                                if isJust top
312 313
                                then label_size
                                else 0,
314
             continuation_stack = stack })
315

316 317 318 319 320 321 322 323
      update_frame_size = case update_frame of
                            Nothing -> 0
                            (Just (UpdateFrame _ args))
                                -> label_size + update_size args

      update_size [] = 0
      update_size (expr:exprs) = width + update_size exprs
          where
324
            width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE
325 326
            -- TODO: it would be better if we had a machRepWordWidth

327 328 329 330 331 332 333
      -- TODO: get rid of "+ 1" etc.
      label_size = 1 :: WordOff

      stack_size [] = 0
      stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
      stack_size (Just reg:formats) = width + stack_size formats
          where
334
            width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE
335
            -- TODO: it would be better if we had a machRepWordWidth
336

337
continuationMaxStack :: [(CLabel, ContinuationFormat)]
338 339
                     -> Continuation a
                     -> WordOff
340 341 342
continuationMaxStack _ (Continuation _ _ _ True _) = 0
continuationMaxStack formats (Continuation _ label _ False blocks) =
    max_arg_size + continuation_frame_size stack_format
343 344 345 346 347 348 349 350 351 352 353
    where
      stack_format = maybe unknown_format id $ lookup label formats
      unknown_format = panic "Unknown format in continuationMaxStack"

      max_arg_size = maximum $ 0 : map block_max_arg_size blocks

      block_max_arg_size block =
          maximum (final_arg_size (brokenBlockExit block) :
                   map stmt_arg_size (brokenBlockStmts block))

      final_arg_size (FinalReturn args) =
354
          argumentsSize (cmmExprType . hintlessCmm) args
355
      final_arg_size (FinalJump _ args) =
356
          argumentsSize (cmmExprType . hintlessCmm) args
Ian Lynagh's avatar
Ian Lynagh committed
357
      final_arg_size (FinalCall _    _ _ _    _ _ True) = 0
358
      final_arg_size (FinalCall next _ _ args _ _ False) =
359 360
          -- We have to account for the stack used when we build a frame
          -- for the *next* continuation from *this* continuation
361
          argumentsSize (cmmExprType . hintlessCmm) args +
362
          continuation_frame_size next_format
363 364 365 366 367 368 369
          where 
            next_format = maybe unknown_format id $ lookup next' formats
            next' = mkReturnPtLabel $ getUnique next

      final_arg_size _ = 0

      stmt_arg_size (CmmJump _ args) =
370
          argumentsSize (cmmExprType . hintlessCmm) args
371
      stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) =
372 373 374 375 376
          panic "Safe call in processFormats"
      stmt_arg_size (CmmReturn _) =
          panic "CmmReturn in processFormats"
      stmt_arg_size _ = 0

377
-----------------------------------------------------------------------------
378
applyContinuationFormat :: [(CLabel, ContinuationFormat)]
379 380 381 382
                 -> Continuation (Either C_SRT CmmInfo)
                 -> Continuation CmmInfo

-- User written continuations
383 384 385 386 387
applyContinuationFormat formats
   (Continuation (Right (CmmInfo gc update_frame
                             (CmmInfoTable clos prof tag (ContInfo _ srt))))
                 label formals is_gc blocks) =
    Continuation (CmmInfo gc update_frame (CmmInfoTable clos prof tag (ContInfo format srt)))
388
                 label formals is_gc blocks
389
    where
390 391
      format = continuation_stack $ maybe unknown_block id $ lookup label formats
      unknown_block = panic "unknown BlockId in applyContinuationFormat"
392

393
-- Either user written non-continuation code or CPS generated proc-point
Ian Lynagh's avatar
Ian Lynagh committed
394
applyContinuationFormat _ (Continuation
395 396
                          (Right info) label formals is_gc blocks) =
    Continuation info label formals is_gc blocks
397

398
-- CPS generated continuations
399 400
applyContinuationFormat formats (Continuation
                          (Left srt) label formals is_gc blocks) =
401
    Continuation (CmmInfo gc Nothing (CmmInfoTable undefined prof tag (ContInfo (continuation_stack $ format) srt)))
402
                 label formals is_gc blocks
403
    where
404 405 406 407
      gc = Nothing -- Generated continuations never need a stack check
      -- TODO prof: this is the same as the current implementation
      -- but I think it could be improved
      prof = ProfilingInfo zeroCLit zeroCLit
408
      tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
409
      format = maybe unknown_block id $ lookup label formats
410
      unknown_block = panic "unknown BlockId in applyContinuationFormat"
411