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 :: a    -- Used at more than one type
 239       unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
 240       body = start_block : children_blocks
 241
 242       -- We can't properly annotate the continuation's stack parameters
 243       -- at this point because this is before stack selection
 244       -- but we want to keep the C_SRT around so we use 'Either'.
 245       info_table = case start_block_entry of
 246                      FunctionEntry info _ _ -> Right info
 247                      ContinuationEntry _ srt _ -> Left srt
 248                      ControlEntry -> Right (CmmInfo Nothing Nothing CmmNonInfoTable)
 249
 250       is_gc_cont = case start_block_entry of
 251                      FunctionEntry _ _ _ -> False
 252                      ContinuationEntry _ _ gc_cont -> gc_cont
 253                      ControlEntry -> False
 254
 255       start_block_entry = brokenBlockEntry start_block
 256       clabel = case start_block_entry of
 257                  FunctionEntry _ label _ -> label
 258                  _ -> mkReturnPtLabel $ getUnique start
 259       params = case start_block_entry of
 260                  FunctionEntry _ _ args -> args
 261                  ContinuationEntry args _ _ -> args
 262                  ControlEntry ->
 263                      uniqSetToList $
 264                      lookupWithDefaultBEnv live unknown_block start
 265                      -- it's a proc-point, pass lives in parameter registers
 266
 267 --------------------------------------------------------------------------------
 268 -- For now just select the continuation orders in the order they are in the set with no gaps
 269
 270 selectContinuationFormat :: BlockEnv CmmLive
 271                   -> [Continuation (Either C_SRT CmmInfo)]
 272                   -> [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
 273 selectContinuationFormat live continuations =
 274     map (\c -> (continuationLabel c, selectContinuationFormat' c)) continuations
 275     where
 276       -- User written continuations
 277       selectContinuationFormat' (Continuation
 278                           (Right (CmmInfo _ _ (CmmInfoTable _ _ _ (ContInfo format _))))
 279                           label formals _ _) =
 280           (formals, Just label, format)
 281       -- Either user written non-continuation code
 282       -- or CPS generated proc-points
 283       selectContinuationFormat' (Continuation (Right _) _ formals _ _) =
 284           (formals, Nothing, [])
 285       -- CPS generated continuations
 286       selectContinuationFormat' (Continuation (Left _) label formals _ blocks) =
 287           -- TODO: assumes the first block is the entry block
 288           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 289           in (formals,
 290               Just label,
 291               map Just $ uniqSetToList $
 292               lookupWithDefaultBEnv live unknown_block ident)
 293
 294       unknown_block = panic "unknown BlockId in selectContinuationFormat"
 295
 296 processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
 297                -> Maybe UpdateFrame
 298                -> [Continuation (Either C_SRT CmmInfo)]
 299                -> (WordOff, WordOff, [(CLabel, ContinuationFormat)])
 300 processFormats formats update_frame continuations =
 301     (max_size + update_frame_size, update_frame_size, formats')
 302     where
 303       max_size = maximum $
 304                  0 : map (continuationMaxStack formats') continuations
 305       formats' = map make_format formats
 306       make_format (label, (formals, top, stack)) =
 307           (label,
 308            ContinuationFormat {
 309              continuation_formals = formals,
 310              continuation_label = top,
 311              continuation_frame_size = stack_size stack +
 312                                 if isJust top
 313                                 then label_size
 314                                 else 0,
 315              continuation_stack = stack })
 316
 317       update_frame_size = case update_frame of
 318                             Nothing -> 0
 319                             (Just (UpdateFrame _ args))
 320                                 -> label_size + update_size args
 321
 322       update_size [] = 0
 323       update_size (expr:exprs) = width + update_size exprs
 324           where
 325             width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE
 326             -- TODO: it would be better if we had a machRepWordWidth
 327
 328       -- TODO: get rid of "+ 1" etc.
 329       label_size = 1 :: WordOff
 330
 331       stack_size [] = 0
 332       stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
 333       stack_size (Just reg:formats) = width + stack_size formats
 334           where
 335             width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE
 336             -- TODO: it would be better if we had a machRepWordWidth
 337
 338 continuationMaxStack :: [(CLabel, ContinuationFormat)]
 339                      -> Continuation a
 340                      -> WordOff
 341 continuationMaxStack _ (Continuation _ _ _ True _) = 0
 342 continuationMaxStack formats (Continuation _ label _ False blocks) =
 343     max_arg_size + continuation_frame_size stack_format
 344     where
 345       stack_format = maybe unknown_format id $ lookup label formats
 346       unknown_format = panic "Unknown format in continuationMaxStack"
 347
 348       max_arg_size = maximum $ 0 : map block_max_arg_size blocks
 349
 350       block_max_arg_size block =
 351           maximum (final_arg_size (brokenBlockExit block) :
 352                    map stmt_arg_size (brokenBlockStmts block))
 353
 354       final_arg_size (FinalReturn args) =
 355           argumentsSize (cmmExprType . hintlessCmm) args
 356       final_arg_size (FinalJump _ args) =
 357           argumentsSize (cmmExprType . hintlessCmm) args
 358       final_arg_size (FinalCall _    _ _ _    _ _ True) = 0
 359       final_arg_size (FinalCall next _ _ args _ _ False) =
 360           -- We have to account for the stack used when we build a frame
 361           -- for the *next* continuation from *this* continuation
 362           argumentsSize (cmmExprType . hintlessCmm) args +
 363           continuation_frame_size next_format
 364           where
 365             next_format = maybe unknown_format id $ lookup next' formats
 366             next' = mkReturnPtLabel $ getUnique next
 367
 368       final_arg_size _ = 0
 369
 370       stmt_arg_size (CmmJump _ args) =
 371           argumentsSize (cmmExprType . hintlessCmm) args
 372       stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) =
 373           panic "Safe call in processFormats"
 374       stmt_arg_size (CmmReturn _) =
 375           panic "CmmReturn in processFormats"
 376       stmt_arg_size _ = 0
 377
 378 -----------------------------------------------------------------------------
 379 applyContinuationFormat :: [(CLabel, ContinuationFormat)]
 380                  -> Continuation (Either C_SRT CmmInfo)
 381                  -> Continuation CmmInfo
 382
 383 -- User written continuations
 384 applyContinuationFormat formats
 385    (Continuation (Right (CmmInfo gc update_frame
 386                              (CmmInfoTable clos prof tag (ContInfo _ srt))))
 387                  label formals is_gc blocks) =
 388     Continuation (CmmInfo gc update_frame (CmmInfoTable clos prof tag (ContInfo format srt)))
 389                  label formals is_gc blocks
 390     where
 391       format = continuation_stack $ maybe unknown_block id $ lookup label formats
 392       unknown_block = panic "unknown BlockId in applyContinuationFormat"
 393
 394 -- Either user written non-continuation code or CPS generated proc-point
 395 applyContinuationFormat _ (Continuation
 396                           (Right info) label formals is_gc blocks) =
 397     Continuation info label formals is_gc blocks
 398
 399 -- CPS generated continuations
 400 applyContinuationFormat formats (Continuation
 401                           (Left srt) label formals is_gc blocks) =
 402     Continuation (CmmInfo gc Nothing (CmmInfoTable undefined prof tag (ContInfo (continuation_stack $ format) srt)))
 403                  label formals is_gc blocks
 404     where
 405       gc = Nothing -- Generated continuations never need a stack check
 406       -- TODO prof: this is the same as the current implementation
 407       -- but I think it could be improved
 408       prof = ProfilingInfo zeroCLit zeroCLit
 409       tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
 410       format = maybe unknown_block id $ lookup label formats
 411       unknown_block = panic "unknown BlockId in applyContinuationFormat"
 412