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