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