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