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 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 cmm_with_calls
  45   = do  { when (dopt Opt_DoCmmLinting dflags) $
  46                do showPass dflags "CmmLint"
  47                   case firstJust $ map cmmLint cmm_with_calls 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 cpsd_cmm = zipWith doCpsProc supplies cmm_with_calls
  60
  61         ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms cpsd_cmm)
  62
  63   -- TODO: add option to dump Cmm to file
  64
  65         ; return cpsd_cmm }
  66
  67
  68 -----------------------------------------------------------------------------
  69 -- |CPS a single CmmTop (proceedure)
  70 -- Only 'CmmProc' are transformed 'CmmData' will be left alone.
  71 -----------------------------------------------------------------------------
  72
  73 doCpsProc :: UniqSupply -> Cmm -> Cmm
  74 doCpsProc s (Cmm c)
  75   = Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c
  76
  77 cpsProc :: UniqSupply
  78         -> CmmTop     -- ^Input procedure
  79         -> [CmmTop]   -- ^Output procedures;
  80                       --   a single input procedure is converted to
  81                       --   multiple output procedures
  82
  83 -- Data blocks don't need to be CPS transformed
  84 cpsProc _ proc@(CmmData _ _) = [proc]
  85
  86 -- Empty functions just don't work with the CPS algorithm, but
  87 -- they don't need the transformation anyway so just output them directly
  88 cpsProc _ proc@(CmmProc _ _ _ (ListGraph []))
  89   = pprTrace "cpsProc: unexpected empty proc" (ppr proc) [proc]
  90
  91 -- CPS transform for those procs that actually need it
  92 -- The plan is this:
  93 --
  94 --   * Introduce a stack-check block as the first block
  95 --   * The first blocks gets a FunctionEntry; the rest are ControlEntry
  96 --   * Now break each block into a bunch of blocks (at call sites);
  97 --      all but the first will be ContinuationEntry
  98 --
  99 cpsProc uniqSupply (CmmProc info ident params (ListGraph blocks)) = cps_procs
 100     where
 101       -- We need to be generating uniques for several things.
 102       -- We could make this function monadic to handle that
 103       -- but since there is no other reason to make it monadic,
 104       -- we instead will just split them all up right here.
 105       (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
 106       uniques :: [[Unique]]
 107       uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
 108       (stack_check_block_unique:stack_use_unique:adaptor_uniques) :
 109        block_uniques = uniques
 110       proc_uniques = map (map (map uniqsFromSupply . listSplitUniqSupply) . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2
 111
 112       stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegType spReg))
 113       stack_check_block_id = BlockId stack_check_block_unique
 114       stack_check_block = make_stack_check stack_check_block_id info stack_use (blockId $ head blocks)
 115
 116       forced_blocks = stack_check_block : blocks
 117
 118       CmmInfo maybe_gc_block_id update_frame _ = info
 119
 120       -- Break the block at each function call.
 121       -- The part after the function call will have to become a continuation.
 122       broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
 123       broken_blocks =
 124           (\x -> (concatMap fst x, concatMap snd x)) $
 125           zipWith3 (breakBlock (maybeToList maybe_gc_block_id))
 126                      block_uniques
 127                      forced_blocks
 128                      (FunctionEntry info ident params :
 129                       repeat ControlEntry)
 130
 131       f' = selectContinuations (fst broken_blocks)
 132       broken_blocks' = map (makeContinuationEntries f') $
 133                        concat $
 134                        zipWith (adaptBlockToFormat f')
 135                                adaptor_uniques
 136                                (snd broken_blocks)
 137
 138       -- Calculate live variables for each broken block.
 139       --
 140       -- Nothing can be live on entry to the first block
 141       -- so we could take the tail, but for now we wont
 142       -- to help future proof the code.
 143       live :: BlockEntryLiveness
 144       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks'
 145
 146       -- Calculate which blocks must be made into full fledged procedures.
 147       proc_points :: UniqSet BlockId
 148       proc_points = calculateProcPoints broken_blocks'
 149
 150       -- Construct a map so we can lookup a broken block by its 'BlockId'.
 151       block_env :: BlockEnv BrokenBlock
 152       block_env = blocksToBlockEnv broken_blocks'
 153
 154       -- Group the blocks into continuations based on the set of proc-points.
 155       continuations :: [Continuation (Either C_SRT CmmInfo)]
 156       continuations = map (gatherBlocksIntoContinuation live proc_points block_env)
 157                           (uniqSetToList proc_points)
 158
 159       -- Select the stack format on entry to each continuation.
 160       -- Return the max stack offset and an association list
 161       --
 162       -- This is an association list instead of a UniqFM because
 163       -- CLabel's don't have a 'Uniqueable' instance.
 164       formats :: [(CLabel,              -- key
 165                    (CmmFormals,         -- arguments
 166                     Maybe CLabel,       -- label in top slot
 167                     [Maybe LocalReg]))] -- slots
 168       formats = selectContinuationFormat live continuations
 169
 170       -- Do a little meta-processing on the stack formats such as
 171       -- getting the individual frame sizes and the maximum frame size
 172       formats' :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
 173       formats'@(_, _, format_list) = processFormats formats update_frame continuations
 174
 175       -- Update the info table data on the continuations with
 176       -- the selected stack formats.
 177       continuations' :: [Continuation CmmInfo]
 178       continuations' = map (applyContinuationFormat format_list) continuations
 179
 180       -- Do the actual CPS transform.
 181       cps_procs :: [CmmTop]
 182       cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
 183
 184 make_stack_check :: BlockId -> CmmInfo -> CmmReg -> BlockId
 185                  -> GenBasicBlock CmmStmt
 186 make_stack_check stack_check_block_id info stack_use next_block_id =
 187     BasicBlock stack_check_block_id $
 188                    check_stmts ++ [CmmBranch next_block_id]
 189     where
 190       check_stmts =
 191           case info of
 192             -- If we are given a stack check handler,
 193             -- then great, well check the stack.
 194             CmmInfo (Just gc_block) _ _
 195                 -> [CmmCondBranch
 196                     (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg)))
 197                      [CmmReg stack_use, CmmReg spLimReg])
 198                     gc_block]
 199             -- If we aren't given a stack check handler,
 200             -- then humph! we just won't check the stack for them.
 201             CmmInfo Nothing _ _
 202                 -> []
 203 -----------------------------------------------------------------------------
 204
 205 collectNonProcPointTargets ::
 206     UniqSet BlockId -> BlockEnv BrokenBlock
 207     -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
 208 collectNonProcPointTargets proc_points blocks current_targets new_blocks =
 209     if sizeUniqSet current_targets == sizeUniqSet new_targets
 210        then current_targets
 211        else foldl
 212                 (collectNonProcPointTargets proc_points blocks)
 213                 new_targets
 214                 (map (:[]) targets)
 215     where
 216       blocks' = map (lookupWithDefaultBEnv blocks (panic "TODO")) new_blocks
 217       targets =
 218         -- Note the subtlety that since the extra branch after a call
 219         -- will always be to a block that is a proc-point,
 220         -- this subtraction will always remove that case
 221         uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
 222                           `minusUniqSet` proc_points
 223         -- TODO: remove redundant uniqSetToList
 224       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 225
 226 -- TODO: insert proc point code here
 227 --  * Branches and switches to proc points may cause new blocks to be created
 228 --    (or proc points could leave behind phantom blocks that just jump to them)
 229 --  * Proc points might get some live variables passed as arguments
 230
 231 gatherBlocksIntoContinuation ::
 232     BlockEntryLiveness -> UniqSet BlockId -> BlockEnv BrokenBlock
 233     -> BlockId -> Continuation (Either C_SRT CmmInfo)
 234 gatherBlocksIntoContinuation live proc_points blocks start =
 235   Continuation info_table clabel params is_gc_cont body
 236     where
 237       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
 238       start_block = lookupWithDefaultBEnv blocks unknown_block start
 239       children_blocks = map (lookupWithDefaultBEnv blocks unknown_block) (uniqSetToList children)
 240       unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
 241       body = start_block : children_blocks
 242
 243       -- We can't properly annotate the continuation's stack parameters
 244       -- at this point because this is before stack selection
 245       -- but we want to keep the C_SRT around so we use 'Either'.
 246       info_table = case start_block_entry of
 247                      FunctionEntry info _ _ -> Right info
 248                      ContinuationEntry _ srt _ -> Left srt
 249                      ControlEntry -> Right (CmmInfo Nothing Nothing CmmNonInfoTable)
 250
 251       is_gc_cont = case start_block_entry of
 252                      FunctionEntry _ _ _ -> False
 253                      ContinuationEntry _ _ gc_cont -> gc_cont
 254                      ControlEntry -> False
 255
 256       start_block_entry = brokenBlockEntry start_block
 257       clabel = case start_block_entry of
 258                  FunctionEntry _ label _ -> label
 259                  _ -> mkReturnPtLabel $ getUnique start
 260       params = case start_block_entry of
 261                  FunctionEntry _ _ args -> args
 262                  ContinuationEntry args _ _ -> args
 263                  ControlEntry ->
 264                      uniqSetToList $
 265                      lookupWithDefaultBEnv live unknown_block start
 266                      -- it's a proc-point, pass lives in parameter registers
 267
 268 --------------------------------------------------------------------------------
 269 -- For now just select the continuation orders in the order they are in the set with no gaps
 270
 271 selectContinuationFormat :: BlockEnv CmmLive
 272                   -> [Continuation (Either C_SRT CmmInfo)]
 273                   -> [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
 274 selectContinuationFormat live continuations =
 275     map (\c -> (continuationLabel c, selectContinuationFormat' c)) continuations
 276     where
 277       -- User written continuations
 278       selectContinuationFormat' (Continuation
 279                           (Right (CmmInfo _ _ (CmmInfoTable _ _ _ (ContInfo format _))))
 280                           label formals _ _) =
 281           (formals, Just label, format)
 282       -- Either user written non-continuation code
 283       -- or CPS generated proc-points
 284       selectContinuationFormat' (Continuation (Right _) _ formals _ _) =
 285           (formals, Nothing, [])
 286       -- CPS generated continuations
 287       selectContinuationFormat' (Continuation (Left _) label formals _ blocks) =
 288           -- TODO: assumes the first block is the entry block
 289           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 290           in (formals,
 291               Just label,
 292               map Just $ uniqSetToList $
 293               lookupWithDefaultBEnv live unknown_block ident)
 294
 295       unknown_block = panic "unknown BlockId in selectContinuationFormat"
 296
 297 processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
 298                -> Maybe UpdateFrame
 299                -> [Continuation (Either C_SRT CmmInfo)]
 300                -> (WordOff, WordOff, [(CLabel, ContinuationFormat)])
 301 processFormats formats update_frame continuations =
 302     (max_size + update_frame_size, update_frame_size, formats')
 303     where
 304       max_size = maximum $
 305                  0 : map (continuationMaxStack formats') continuations
 306       formats' = map make_format formats
 307       make_format (label, (formals, top, stack)) =
 308           (label,
 309            ContinuationFormat {
 310              continuation_formals = formals,
 311              continuation_label = top,
 312              continuation_frame_size = stack_size stack +
 313                                 if isJust top
 314                                 then label_size
 315                                 else 0,
 316              continuation_stack = stack })
 317
 318       update_frame_size = case update_frame of
 319                             Nothing -> 0
 320                             (Just (UpdateFrame _ args))
 321                                 -> label_size + update_size args
 322
 323       update_size [] = 0
 324       update_size (expr:exprs) = width + update_size exprs
 325           where
 326             width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE
 327             -- TODO: it would be better if we had a machRepWordWidth
 328
 329       -- TODO: get rid of "+ 1" etc.
 330       label_size = 1 :: WordOff
 331
 332       stack_size [] = 0
 333       stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
 334       stack_size (Just reg:formats) = width + stack_size formats
 335           where
 336             width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE
 337             -- TODO: it would be better if we had a machRepWordWidth
 338
 339 continuationMaxStack :: [(CLabel, ContinuationFormat)]
 340                      -> Continuation a
 341                      -> WordOff
 342 continuationMaxStack _ (Continuation _ _ _ True _) = 0
 343 continuationMaxStack formats (Continuation _ label _ False blocks) =
 344     max_arg_size + continuation_frame_size stack_format
 345     where
 346       stack_format = maybe unknown_format id $ lookup label formats
 347       unknown_format = panic "Unknown format in continuationMaxStack"
 348
 349       max_arg_size = maximum $ 0 : map block_max_arg_size blocks
 350
 351       block_max_arg_size block =
 352           maximum (final_arg_size (brokenBlockExit block) :
 353                    map stmt_arg_size (brokenBlockStmts block))
 354
 355       final_arg_size (FinalReturn args) =
 356           argumentsSize (cmmExprType . hintlessCmm) args
 357       final_arg_size (FinalJump _ args) =
 358           argumentsSize (cmmExprType . hintlessCmm) args
 359       final_arg_size (FinalCall _    _ _ _    _ _ True) = 0
 360       final_arg_size (FinalCall next _ _ args _ _ False) =
 361           -- We have to account for the stack used when we build a frame
 362           -- for the *next* continuation from *this* continuation
 363           argumentsSize (cmmExprType . hintlessCmm) args +
 364           continuation_frame_size next_format
 365           where
 366             next_format = maybe unknown_format id $ lookup next' formats
 367             next' = mkReturnPtLabel $ getUnique next
 368
 369       final_arg_size _ = 0
 370
 371       stmt_arg_size (CmmJump _ args) =
 372           argumentsSize (cmmExprType . hintlessCmm) args
 373       stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) =
 374           panic "Safe call in processFormats"
 375       stmt_arg_size (CmmReturn _) =
 376           panic "CmmReturn in processFormats"
 377       stmt_arg_size _ = 0
 378
 379 -----------------------------------------------------------------------------
 380 applyContinuationFormat :: [(CLabel, ContinuationFormat)]
 381                  -> Continuation (Either C_SRT CmmInfo)
 382                  -> Continuation CmmInfo
 383
 384 -- User written continuations
 385 applyContinuationFormat formats
 386    (Continuation (Right (CmmInfo gc update_frame
 387                              (CmmInfoTable clos prof tag (ContInfo _ srt))))
 388                  label formals is_gc blocks) =
 389     Continuation (CmmInfo gc update_frame (CmmInfoTable clos prof tag (ContInfo format srt)))
 390                  label formals is_gc blocks
 391     where
 392       format = continuation_stack $ maybe unknown_block id $ lookup label formats
 393       unknown_block = panic "unknown BlockId in applyContinuationFormat"
 394
 395 -- Either user written non-continuation code or CPS generated proc-point
 396 applyContinuationFormat _ (Continuation
 397                           (Right info) label formals is_gc blocks) =
 398     Continuation info label formals is_gc blocks
 399
 400 -- CPS generated continuations
 401 applyContinuationFormat formats (Continuation
 402                           (Left srt) label formals is_gc blocks) =
 403     Continuation (CmmInfo gc Nothing (CmmInfoTable undefined prof tag (ContInfo (continuation_stack $ format) srt)))
 404                  label formals is_gc blocks
 405     where
 406       gc = Nothing -- Generated continuations never need a stack check
 407       -- TODO prof: this is the same as the current implementation
 408       -- but I think it could be improved
 409       prof = ProfilingInfo zeroCLit zeroCLit
 410       tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
 411       format = maybe unknown_block id $ lookup label formats
 412       unknown_block = panic "unknown BlockId in applyContinuationFormat"
 413