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 CmmLive
  14 import CmmBrokenBlock
  15 import CmmProcPoint
  16 import CmmCallConv
  17 import CmmCPSGen
  18 import CmmUtils
  19
  20 import ClosureInfo
  21 import MachOp
  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 UniqFM
  32 import UniqSet
  33 import Unique
  34
  35 import Monad
  36 import IO
  37 import Data.List
  38
  39 -----------------------------------------------------------------------------
  40 -- |Top level driver for the CPS pass
  41 -----------------------------------------------------------------------------
  42 cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
  43        -> [Cmm]    -- ^ Input C-- with Proceedures
  44        -> IO [Cmm] -- ^ Output CPS transformed C--
  45 cmmCPS dflags cmm_with_calls
  46   = do  { when (dopt Opt_DoCmmLinting dflags) $
  47                do showPass dflags "CmmLint"
  48                   case firstJust $ map cmmLint cmm_with_calls of
  49                     Just err -> do printDump err
  50                                    ghcExit dflags 1
  51                     Nothing  -> return ()
  52         ; showPass dflags "CPS"
  53
  54   -- TODO: more lint checking
  55   --        check for use of branches to non-existant blocks
  56   --        check for use of Sp, SpLim, R1, R2, etc.
  57
  58         ; uniqSupply <- mkSplitUniqSupply 'p'
  59         ; let supplies = listSplitUniqSupply uniqSupply
  60         ; let cpsd_cmm = zipWith doCpsProc supplies cmm_with_calls
  61
  62         ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms cpsd_cmm)
  63
  64   -- TODO: add option to dump Cmm to file
  65
  66         ; return cpsd_cmm }
  67
  68
  69 -----------------------------------------------------------------------------
  70 -- |CPS a single CmmTop (proceedure)
  71 -- Only 'CmmProc' are transformed 'CmmData' will be left alone.
  72 -----------------------------------------------------------------------------
  73
  74 doCpsProc :: UniqSupply -> Cmm -> Cmm
  75 doCpsProc s (Cmm c)
  76   = Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c
  77
  78 cpsProc :: UniqSupply
  79         -> CmmTop     -- ^Input procedure
  80         -> [CmmTop]   -- ^Output procedures;
  81                       --   a single input procedure is converted to
  82                       --   multiple output procedures
  83
  84 -- Data blocks don't need to be CPS transformed
  85 cpsProc uniqSupply proc@(CmmData _ _) = [proc]
  86
  87 -- Empty functions just don't work with the CPS algorithm, but
  88 -- they don't need the transformation anyway so just output them directly
  89 cpsProc uniqSupply proc@(CmmProc _ _ _ [])
  90   = pprTrace "cpsProc: unexpected empty proc" (ppr proc) [proc]
  91
  92 -- CPS transform for those procs that actually need it
  93 -- The plan is this:
  94 --
  95 --   * Introduce a stack-check block as the first block
  96 --   * The first blocks gets a FunctionEntry; the rest are ControlEntry
  97 --   * Now break each block into a bunch of blocks (at call sites);
  98 --      all but the first will be ContinuationEntry
  99 --
 100 cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
 101     where
 102       -- We need to be generating uniques for several things.
 103       -- We could make this function monadic to handle that
 104       -- but since there is no other reason to make it monadic,
 105       -- we instead will just split them all up right here.
 106       (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
 107       uniques :: [[Unique]]
 108       uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
 109       (stack_check_block_unique:stack_use_unique:adaptor_uniques) :
 110        block_uniques = uniques
 111       proc_uniques = map (map (map uniqsFromSupply . listSplitUniqSupply) . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2
 112
 113       stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegRep spReg) KindPtr)
 114       stack_check_block_id = BlockId stack_check_block_unique
 115       stack_check_block = make_stack_check stack_check_block_id info stack_use (blockId $ head blocks)
 116
 117       forced_blocks = stack_check_block : blocks
 118
 119       CmmInfo maybe_gc_block_id update_frame _ = info
 120
 121       -- Break the block at each function call.
 122       -- The part after the function call will have to become a continuation.
 123       broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
 124       broken_blocks =
 125           (\x -> (concatMap fst x, concatMap snd x)) $
 126           zipWith3 (breakBlock (maybeToList maybe_gc_block_id))
 127                      block_uniques
 128                      forced_blocks
 129                      (FunctionEntry info ident params :
 130                       repeat ControlEntry)
 131
 132       f' = selectContinuations (fst broken_blocks)
 133       broken_blocks' = map (makeContinuationEntries f') $
 134                        concat $
 135                        zipWith (adaptBlockToFormat f')
 136                                adaptor_uniques
 137                                (snd broken_blocks)
 138
 139       -- Calculate live variables for each broken block.
 140       --
 141       -- Nothing can be live on entry to the first block
 142       -- so we could take the tail, but for now we wont
 143       -- to help future proof the code.
 144       live :: BlockEntryLiveness
 145       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks'
 146
 147       -- Calculate which blocks must be made into full fledged procedures.
 148       proc_points :: UniqSet BlockId
 149       proc_points = calculateProcPoints broken_blocks'
 150
 151       -- Construct a map so we can lookup a broken block by its 'BlockId'.
 152       block_env :: BlockEnv BrokenBlock
 153       block_env = blocksToBlockEnv broken_blocks'
 154
 155       -- Group the blocks into continuations based on the set of proc-points.
 156       continuations :: [Continuation (Either C_SRT CmmInfo)]
 157       continuations = map (gatherBlocksIntoContinuation live proc_points block_env)
 158                           (uniqSetToList proc_points)
 159
 160       -- Select the stack format on entry to each continuation.
 161       -- Return the max stack offset and an association list
 162       --
 163       -- This is an association list instead of a UniqFM because
 164       -- CLabel's don't have a 'Uniqueable' instance.
 165       formats :: [(CLabel,              -- key
 166                    (CmmFormals,         -- arguments
 167                     Maybe CLabel,       -- label in top slot
 168                     [Maybe LocalReg]))] -- slots
 169       formats = selectContinuationFormat live continuations
 170
 171       -- Do a little meta-processing on the stack formats such as
 172       -- getting the individual frame sizes and the maximum frame size
 173       formats' :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
 174       formats'@(_, _, format_list) = processFormats formats update_frame continuations
 175
 176       -- Update the info table data on the continuations with
 177       -- the selected stack formats.
 178       continuations' :: [Continuation CmmInfo]
 179       continuations' = map (applyContinuationFormat format_list) continuations
 180
 181       -- Do the actual CPS transform.
 182       cps_procs :: [CmmTop]
 183       cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
 184
 185 make_stack_check stack_check_block_id info stack_use next_block_id =
 186     BasicBlock stack_check_block_id $
 187                    check_stmts ++ [CmmBranch next_block_id]
 188     where
 189       check_stmts =
 190           case info of
 191             -- If we are given a stack check handler,
 192             -- then great, well check the stack.
 193             CmmInfo (Just gc_block) _ _
 194                 -> [CmmCondBranch
 195                     (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 196                      [CmmReg stack_use, CmmReg spLimReg])
 197                     gc_block]
 198             -- If we aren't given a stack check handler,
 199             -- then humph! we just won't check the stack for them.
 200             CmmInfo Nothing _ _
 201                 -> []
 202 -----------------------------------------------------------------------------
 203
 204 collectNonProcPointTargets ::
 205     UniqSet BlockId -> BlockEnv BrokenBlock
 206     -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
 207 collectNonProcPointTargets proc_points blocks current_targets new_blocks =
 208     if sizeUniqSet current_targets == sizeUniqSet new_targets
 209        then current_targets
 210        else foldl
 211                 (collectNonProcPointTargets proc_points blocks)
 212                 new_targets
 213                 (map (:[]) targets)
 214     where
 215       blocks' = map (lookupWithDefaultUFM blocks (panic "TODO")) new_blocks
 216       targets =
 217         -- Note the subtlety that since the extra branch after a call
 218         -- will always be to a block that is a proc-point,
 219         -- this subtraction will always remove that case
 220         uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
 221                           `minusUniqSet` proc_points
 222         -- TODO: remove redundant uniqSetToList
 223       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 224
 225 -- TODO: insert proc point code here
 226 --  * Branches and switches to proc points may cause new blocks to be created
 227 --    (or proc points could leave behind phantom blocks that just jump to them)
 228 --  * Proc points might get some live variables passed as arguments
 229
 230 gatherBlocksIntoContinuation ::
 231     BlockEntryLiveness -> UniqSet BlockId -> BlockEnv BrokenBlock
 232     -> BlockId -> Continuation (Either C_SRT CmmInfo)
 233 gatherBlocksIntoContinuation live proc_points blocks start =
 234   Continuation info_table clabel params is_gc_cont body
 235     where
 236       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
 237       start_block = lookupWithDefaultUFM blocks unknown_block start
 238       children_blocks = map (lookupWithDefaultUFM blocks unknown_block) (uniqSetToList children)
 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                      lookupWithDefaultUFM 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 srt))))
 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 srt) 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               lookupWithDefaultUFM 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 = machRepByteWidth (cmmExprRep 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 = machRepByteWidth (localRegRep 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 (cmmExprRep . fst) args
 356       final_arg_size (FinalJump _ args) =
 357           argumentsSize (cmmExprRep . fst) args
 358       final_arg_size (FinalCall next _ _ args _ _ 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 (cmmExprRep . fst) 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 (cmmExprRep . fst) 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 (Continuation
 385                           (Right (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo _ srt))))
 386                           label formals is_gc blocks) =
 387     Continuation (CmmInfo gc update_frame (CmmInfoTable 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 formats (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 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