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 BlockId
  10 import Cmm
  11 import CmmLint
  12 import PprCmm
  13
  14 import CmmLive
  15 import CmmBrokenBlock
  16 import CmmProcPoint
  17 import CmmCallConv
  18 import CmmCPSGen
  19 import CmmUtils
  20
  21 import ClosureInfo
  22 import CLabel
  23 import SMRep
  24 import Constants
  25
  26 import DynFlags
  27 import ErrUtils
  28 import Maybes
  29 import Outputable
  30 import UniqSupply
  31 import UniqSet
  32 import Unique
  33
  34 import Control.Monad
  35
  36 -----------------------------------------------------------------------------
  37 -- |Top level driver for the CPS pass
  38 -----------------------------------------------------------------------------
  39 cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
  40        -> [Cmm]    -- ^ Input C-- with Proceedures
  41        -> IO [Cmm] -- ^ Output CPS transformed C--
  42 cmmCPS dflags cmm_with_calls
  43   = do  { when (dopt Opt_DoCmmLinting dflags) $
  44                do showPass dflags "CmmLint"
  45                   case firstJust $ map cmmLint cmm_with_calls of
  46                     Just err -> do printDump err
  47                                    ghcExit dflags 1
  48                     Nothing  -> return ()
  49         ; showPass dflags "CPS"
  50
  51   -- TODO: more lint checking
  52   --        check for use of branches to non-existant blocks
  53   --        check for use of Sp, SpLim, R1, R2, etc.
  54
  55         ; uniqSupply <- mkSplitUniqSupply 'p'
  56         ; let supplies = listSplitUniqSupply uniqSupply
  57         ; 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   -- TODO: add option to dump Cmm to file
  62
  63         ; return cpsd_cmm }
  64
  65
  66 -----------------------------------------------------------------------------
  67 -- |CPS a single CmmTop (proceedure)
  68 -- Only 'CmmProc' are transformed 'CmmData' will be left alone.
  69 -----------------------------------------------------------------------------
  70
  71 doCpsProc :: UniqSupply -> Cmm -> Cmm
  72 doCpsProc s (Cmm c)
  73   = Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c
  74
  75 cpsProc :: UniqSupply
  76         -> CmmTop     -- ^Input procedure
  77         -> [CmmTop]   -- ^Output procedures;
  78                       --   a single input procedure is converted to
  79                       --   multiple output procedures
  80
  81 -- Data blocks don't need to be CPS transformed
  82 cpsProc _ proc@(CmmData _ _) = [proc]
  83
  84 -- Empty functions just don't work with the CPS algorithm, but
  85 -- they don't need the transformation anyway so just output them directly
  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 -- The plan is this:
  91 --
  92 --   * Introduce a stack-check block as the first block
  93 --   * The first blocks gets a FunctionEntry; the rest are ControlEntry
  94 --   * Now break each block into a bunch of blocks (at call sites);
  95 --      all but the first will be ContinuationEntry
  96 --
  97 cpsProc uniqSupply (CmmProc info ident params (ListGraph blocks)) = cps_procs
  98     where
  99       -- We need to be generating uniques for several things.
 100       -- We could make this function monadic to handle that
 101       -- but since there is no other reason to make it monadic,
 102       -- 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       stack_check_block_id = BlockId stack_check_block_unique
 112       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       -- Break the block at each function call.
 119       -- 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                      block_uniques
 125                      forced_blocks
 126                      (FunctionEntry info ident params :
 127                       repeat ControlEntry)
 128
 129       f' = selectContinuations (fst broken_blocks)
 130       broken_blocks' = map (makeContinuationEntries f') $
 131                        concat $
 132                        zipWith (adaptBlockToFormat f')
 133                                adaptor_uniques
 134                                (snd broken_blocks)
 135
 136       -- Calculate live variables for each broken block.
 137       --
 138       -- Nothing can be live on entry to the first block
 139       -- so we could take the tail, but for now we wont
 140       -- to help future proof the code.
 141       live :: BlockEntryLiveness
 142       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks'
 143
 144       -- Calculate which blocks must be made into full fledged procedures.
 145       proc_points :: UniqSet BlockId
 146       proc_points = calculateProcPoints broken_blocks'
 147
 148       -- Construct a map so we can lookup a broken block by its 'BlockId'.
 149       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       continuations = map (gatherBlocksIntoContinuation live proc_points block_env)
 155                           (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       -- This is an association list instead of a UniqFM because
 161       -- 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       -- Do a little meta-processing on the stack formats such as
 169       -- getting the individual frame sizes and the maximum frame size
 170       formats' :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
 171       formats'@(_, _, format_list) = processFormats formats update_frame continuations
 172
 173       -- Update the info table data on the continuations with
 174       -- the selected stack formats.
 175       continuations' :: [Continuation CmmInfo]
 176       continuations' = map (applyContinuationFormat format_list) continuations
 177
 178       -- Do the actual CPS transform.
 179       cps_procs :: [CmmTop]
 180       cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
 181
 182 make_stack_check :: BlockId -> CmmInfo -> CmmReg -> BlockId
 183                  -> GenBasicBlock CmmStmt
 184 make_stack_check stack_check_block_id info stack_use next_block_id =
 185     BasicBlock stack_check_block_id $
 186                    check_stmts ++ [CmmBranch next_block_id]
 187     where
 188       check_stmts =
 189           case info of
 190             -- If we are given a stack check handler,
 191             -- then great, well check the stack.
 192             CmmInfo (Just gc_block) _ _
 193                 -> [CmmCondBranch
 194                     (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg)))
 195                      [CmmReg stack_use, CmmReg spLimReg])
 196                     gc_block]
 197             -- If we aren't given a stack check handler,
 198             -- then humph! we just won't check the stack for them.
 199             CmmInfo Nothing _ _
 200                 -> []
 201 -----------------------------------------------------------------------------
 202
 203 collectNonProcPointTargets ::
 204     UniqSet BlockId -> BlockEnv BrokenBlock
 205     -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
 206 collectNonProcPointTargets proc_points blocks current_targets new_blocks =
 207     if sizeUniqSet current_targets == sizeUniqSet new_targets
 208        then current_targets
 209        else foldl
 210                 (collectNonProcPointTargets proc_points blocks)
 211                 new_targets
 212                 (map (:[]) targets)
 213     where
 214       blocks' = map (lookupWithDefaultBEnv blocks (panic "TODO")) new_blocks
 215       targets =
 216         -- Note the subtlety that since the extra branch after a call
 217         -- will always be to a block that is a proc-point,
 218         -- this subtraction will always remove that case
 219         uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
 220                           `minusUniqSet` proc_points
 221         -- TODO: remove redundant uniqSetToList
 222       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 223
 224 -- TODO: insert proc point code here
 225 --  * Branches and switches to proc points may cause new blocks to be created
 226 --    (or proc points could leave behind phantom blocks that just jump to them)
 227 --  * Proc points might get some live variables passed as arguments
 228
 229 gatherBlocksIntoContinuation ::
 230     BlockEntryLiveness -> UniqSet BlockId -> BlockEnv BrokenBlock
 231     -> BlockId -> Continuation (Either C_SRT CmmInfo)
 232 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       start_block = lookupWithDefaultBEnv blocks unknown_block start
 237       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       -- We can't properly annotate the continuation's stack parameters
 242       -- at this point because this is before stack selection
 243       -- but we want to keep the C_SRT around so we use 'Either'.
 244       info_table = case start_block_entry of
 245                      FunctionEntry info _ _ -> Right info
 246                      ContinuationEntry _ srt _ -> Left srt
 247                      ControlEntry -> Right (CmmInfo Nothing Nothing CmmNonInfoTable)
 248
 249       is_gc_cont = case start_block_entry of
 250                      FunctionEntry _ _ _ -> False
 251                      ContinuationEntry _ _ gc_cont -> gc_cont
 252                      ControlEntry -> False
 253
 254       start_block_entry = brokenBlockEntry start_block
 255       clabel = case start_block_entry of
 256                  FunctionEntry _ label _ -> label
 257                  _ -> mkReturnPtLabel $ getUnique start
 258       params = case start_block_entry of
 259                  FunctionEntry _ _ args -> args
 260                  ContinuationEntry args _ _ -> args
 261                  ControlEntry ->
 262                      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 selectContinuationFormat live continuations =
 273     map (\c -> (continuationLabel c, selectContinuationFormat' c)) continuations
 274     where
 275       -- User written continuations
 276       selectContinuationFormat' (Continuation
 277                           (Right (CmmInfo _ _ (CmmInfoTable _ _ _ (ContInfo format _))))
 278                           label formals _ _) =
 279           (formals, Just label, format)
 280       -- Either user written non-continuation code
 281       -- or CPS generated proc-points
 282       selectContinuationFormat' (Continuation (Right _) _ formals _ _) =
 283           (formals, Nothing, [])
 284       -- CPS generated continuations
 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           in (formals,
 289               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                -> (WordOff, WordOff, [(CLabel, ContinuationFormat)])
 299 processFormats formats update_frame continuations =
 300     (max_size + update_frame_size, update_frame_size, formats')
 301     where
 302       max_size = maximum $
 303                  0 : map (continuationMaxStack formats') continuations
 304       formats' = map make_format formats
 305       make_format (label, (formals, top, stack)) =
 306           (label,
 307            ContinuationFormat {
 308              continuation_formals = formals,
 309              continuation_label = top,
 310              continuation_frame_size = stack_size stack +
 311                                 if isJust top
 312                                 then label_size
 313                                 else 0,
 314              continuation_stack = stack })
 315
 316       update_frame_size = case update_frame of
 317                             Nothing -> 0
 318                             (Just (UpdateFrame _ args))
 319                                 -> label_size + update_size args
 320
 321       update_size [] = 0
 322       update_size (expr:exprs) = width + update_size exprs
 323           where
 324             width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE
 325             -- TODO: it would be better if we had a machRepWordWidth
 326
 327       -- TODO: get rid of "+ 1" etc.
 328       label_size = 1 :: WordOff
 329
 330       stack_size [] = 0
 331       stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
 332       stack_size (Just reg:formats) = width + stack_size formats
 333           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                      -> Continuation a
 339                      -> WordOff
 340 continuationMaxStack _ (Continuation _ _ _ True _) = 0
 341 continuationMaxStack formats (Continuation _ label _ False blocks) =
 342     max_arg_size + continuation_frame_size stack_format
 343     where
 344       stack_format = maybe unknown_format id $ lookup label formats
 345       unknown_format = panic "Unknown format in continuationMaxStack"
 346
 347       max_arg_size = maximum $ 0 : map block_max_arg_size blocks
 348
 349       block_max_arg_size block =
 350           maximum (final_arg_size (brokenBlockExit block) :
 351                    map stmt_arg_size (brokenBlockStmts block))
 352
 353       final_arg_size (FinalReturn args) =
 354           argumentsSize (cmmExprType . hintlessCmm) args
 355       final_arg_size (FinalJump _ args) =
 356           argumentsSize (cmmExprType . hintlessCmm) args
 357       final_arg_size (FinalCall _    _ _ _    _ _ True) = 0
 358       final_arg_size (FinalCall next _ _ args _ _ False) =
 359           -- We have to account for the stack used when we build a frame
 360           -- for the *next* continuation from *this* continuation
 361           argumentsSize (cmmExprType . hintlessCmm) args +
 362           continuation_frame_size next_format
 363           where
 364             next_format = maybe unknown_format id $ lookup next' formats
 365             next' = mkReturnPtLabel $ getUnique next
 366
 367       final_arg_size _ = 0
 368
 369       stmt_arg_size (CmmJump _ args) =
 370           argumentsSize (cmmExprType . hintlessCmm) args
 371       stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) =
 372           panic "Safe call in processFormats"
 373       stmt_arg_size (CmmReturn _) =
 374           panic "CmmReturn in processFormats"
 375       stmt_arg_size _ = 0
 376
 377 -----------------------------------------------------------------------------
 378 applyContinuationFormat :: [(CLabel, ContinuationFormat)]
 379                  -> Continuation (Either C_SRT CmmInfo)
 380                  -> Continuation CmmInfo
 381
 382 -- User written continuations
 383 applyContinuationFormat formats
 384    (Continuation (Right (CmmInfo gc update_frame
 385                              (CmmInfoTable clos prof tag (ContInfo _ srt))))
 386                  label formals is_gc blocks) =
 387     Continuation (CmmInfo gc update_frame (CmmInfoTable clos prof tag (ContInfo format srt)))
 388                  label formals is_gc blocks
 389     where
 390       format = continuation_stack $ maybe unknown_block id $ lookup label formats
 391       unknown_block = panic "unknown BlockId in applyContinuationFormat"
 392
 393 -- Either user written non-continuation code or CPS generated proc-point
 394 applyContinuationFormat _ (Continuation
 395                           (Right info) label formals is_gc blocks) =
 396     Continuation info label formals is_gc blocks
 397
 398 -- CPS generated continuations
 399 applyContinuationFormat formats (Continuation
 400                           (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       gc = Nothing -- Generated continuations never need a stack check
 405       -- TODO prof: this is the same as the current implementation
 406       -- but I think it could be improved
 407       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