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 [CmmStatic] 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       CmmNonInfo (Just existing) -> (old_info, [], make_gc_check stack_use existing)
  91       CmmInfo _ (Just existing) _ _ -> (old_info, [], make_gc_check stack_use existing)
  92       CmmNonInfo Nothing
  93           -> (CmmNonInfo (Just block_id),
  94               [make_gc_block block_id fun_label formals (CmmSafe NoC_SRT)],
  95               make_gc_check stack_use block_id)
  96       CmmInfo prof Nothing type_tag type_info
  97           -> (CmmInfo prof (Just block_id) type_tag type_info,
  98               [make_gc_block block_id fun_label formals (CmmSafe srt)],
  99               make_gc_check stack_use block_id)
 100              where
 101                srt = case type_info of
 102                        ConstrInfo _ _ _ -> NoC_SRT
 103                        FunInfo _ srt' _ _ _ _ -> srt'
 104                        ThunkInfo _ srt' -> srt'
 105                        ThunkSelectorInfo _ srt' -> srt'
 106                        ContInfo _ srt' -> srt'
 107
 108 -----------------------------------------------------------------------------
 109 -- |CPS a single CmmTop (proceedure)
 110 -- Only 'CmmProc' are transformed 'CmmData' will be left alone.
 111 -----------------------------------------------------------------------------
 112
 113 cpsProc :: UniqSupply
 114         -> GenCmmTop CmmStatic CmmInfo CmmStmt     -- ^Input proceedure
 115         -> [GenCmmTop CmmStatic [CmmStatic] CmmStmt]   -- ^Output proceedure and continuations
 116 cpsProc uniqSupply (CmmData sec dat) = [CmmData sec dat]
 117 cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
 118     where
 119       (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
 120       uniques :: [[Unique]]
 121       uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
 122       (gc_unique:stack_use_unique:info_uniques):adaptor_uniques:block_uniques = uniques
 123       proc_uniques = map (map uniqsFromSupply . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2
 124
 125       stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegRep spReg) KindPtr)
 126
 127       -- TODO: doc
 128       forced_gc :: (CmmInfo, [CmmBasicBlock], [CmmStmt])
 129       forced_gc = force_gc_block info stack_use (BlockId gc_unique) ident params
 130       (forced_info, gc_blocks, check_stmts) = forced_gc
 131
 132       forced_blocks =
 133           case blocks of
 134             (BasicBlock id stmts) : bs ->
 135                 (BasicBlock id (check_stmts ++ stmts)) : (bs ++ gc_blocks)
 136             [] -> [] -- If there is no code then we don't need a stack check
 137
 138       forced_gc_id = case forced_info of
 139                        CmmNonInfo (Just x) -> x
 140                        CmmInfo _ (Just x) _ _ -> x
 141
 142       -- Break the block at each function call.
 143       -- The part after the function call will have to become a continuation.
 144       broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
 145       broken_blocks =
 146           (\x -> (concatMap fst x, concatMap snd x)) $
 147           zipWith3 (breakBlock [forced_gc_id])
 148                      block_uniques
 149                      forced_blocks
 150                      (FunctionEntry forced_info ident params :
 151                       repeat ControlEntry)
 152
 153       f' = selectContinuations (fst broken_blocks)
 154       broken_blocks' = map (makeContinuationEntries f') $
 155                        concat $
 156                        zipWith (adaptBlockToFormat f')
 157                                adaptor_uniques
 158                                (snd broken_blocks)
 159
 160       -- Calculate live variables for each broken block.
 161       --
 162       -- Nothing can be live on entry to the first block
 163       -- so we could take the tail, but for now we wont
 164       -- to help future proof the code.
 165       live :: BlockEntryLiveness
 166       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks'
 167
 168       -- Calculate which blocks must be made into full fledged procedures.
 169       proc_points :: UniqSet BlockId
 170       proc_points = calculateProcPoints broken_blocks'
 171
 172       -- Construct a map so we can lookup a broken block by its 'BlockId'.
 173       block_env :: BlockEnv BrokenBlock
 174       block_env = blocksToBlockEnv broken_blocks'
 175
 176       -- Group the blocks into continuations based on the set of proc-points.
 177       continuations :: [Continuation (Either C_SRT CmmInfo)]
 178       continuations = map (gatherBlocksIntoContinuation live proc_points block_env)
 179                           (uniqSetToList proc_points)
 180
 181       -- Select the stack format on entry to each continuation.
 182       -- Return the max stack offset and an association list
 183       --
 184       -- This is an association list instead of a UniqFM because
 185       -- CLabel's don't have a 'Uniqueable' instance.
 186       formats :: [(CLabel,              -- key
 187                    (CmmFormals,         -- arguments
 188                     Maybe CLabel,       -- label in top slot
 189                     [Maybe LocalReg]))] -- slots
 190       formats = selectContinuationFormat live continuations
 191
 192       -- Do a little meta-processing on the stack formats such as
 193       -- getting the individual frame sizes and the maximum frame size
 194       formats' :: (WordOff, [(CLabel, ContinuationFormat)])
 195       formats' = processFormats formats continuations
 196
 197       -- Update the info table data on the continuations with
 198       -- the selected stack formats.
 199       continuations' :: [Continuation CmmInfo]
 200       continuations' = map (applyContinuationFormat (snd formats')) continuations
 201
 202       -- Do the actual CPS transform.
 203       cps_procs :: [CmmTop]
 204       cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
 205
 206       -- Convert the info tables from CmmInfo to [CmmStatic]
 207       -- We might want to put this in another pass eventually
 208       info_procs :: [RawCmmTop]
 209       info_procs = concat (zipWith mkInfoTable info_uniques cps_procs)
 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 (CmmNonInfo Nothing)
 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 _ _ _ (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                -> [Continuation (Either C_SRT CmmInfo)]
 307                -> (WordOff, [(CLabel, ContinuationFormat)])
 308 processFormats formats continuations = (max_size, formats')
 309     where
 310       max_size = maximum $
 311                  0 : map (continuationMaxStack formats') continuations
 312       formats' = map make_format formats
 313       make_format (label, (formals, top, stack)) =
 314           (label,
 315            ContinuationFormat {
 316              continuation_formals = formals,
 317              continuation_label = top,
 318              continuation_frame_size = stack_size stack +
 319                                 if isJust top
 320                                 then label_size
 321                                 else 0,
 322              continuation_stack = stack })
 323
 324       -- TODO: get rid of "+ 1" etc.
 325       label_size = 1 :: WordOff
 326
 327       stack_size [] = 0
 328       stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
 329       stack_size (Just reg:formats) = width + stack_size formats
 330           where
 331             width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 332             -- TODO: it would be better if we had a machRepWordWidth
 333
 334 continuationMaxStack :: [(CLabel, ContinuationFormat)]
 335                      -> Continuation a
 336                      -> WordOff
 337 continuationMaxStack _ (Continuation _ _ _ True _) = 0
 338 continuationMaxStack formats (Continuation _ label _ False blocks) =
 339     max_arg_size + continuation_frame_size stack_format
 340     where
 341       stack_format = maybe unknown_format id $ lookup label formats
 342       unknown_format = panic "Unknown format in continuationMaxStack"
 343
 344       max_arg_size = maximum $ 0 : map block_max_arg_size blocks
 345
 346       block_max_arg_size block =
 347           maximum (final_arg_size (brokenBlockExit block) :
 348                    map stmt_arg_size (brokenBlockStmts block))
 349
 350       final_arg_size (FinalReturn args) =
 351           argumentsSize (cmmExprRep . fst) args
 352       final_arg_size (FinalJump _ args) =
 353           argumentsSize (cmmExprRep . fst) args
 354       final_arg_size (FinalCall next _ _ args _ True) = 0
 355       final_arg_size (FinalCall next _ _ args _ False) =
 356           -- We have to account for the stack used when we build a frame
 357           -- for the *next* continuation from *this* continuation
 358           argumentsSize (cmmExprRep . fst) args +
 359           continuation_frame_size next_format
 360           where
 361             next_format = maybe unknown_format id $ lookup next' formats
 362             next' = mkReturnPtLabel $ getUnique next
 363
 364       final_arg_size _ = 0
 365
 366       stmt_arg_size (CmmJump _ args) =
 367           argumentsSize (cmmExprRep . fst) args
 368       stmt_arg_size (CmmCall _ _ _ (CmmSafe _)) =
 369           panic "Safe call in processFormats"
 370       stmt_arg_size (CmmReturn _) =
 371           panic "CmmReturn in processFormats"
 372       stmt_arg_size _ = 0
 373
 374 -----------------------------------------------------------------------------
 375 applyContinuationFormat :: [(CLabel, ContinuationFormat)]
 376                  -> Continuation (Either C_SRT CmmInfo)
 377                  -> Continuation CmmInfo
 378
 379 -- User written continuations
 380 applyContinuationFormat formats (Continuation
 381                           (Right (CmmInfo prof gc tag (ContInfo _ srt)))
 382                           label formals is_gc blocks) =
 383     Continuation (CmmInfo prof gc tag (ContInfo format srt))
 384                  label formals is_gc blocks
 385     where
 386       format = continuation_stack $ maybe unknown_block id $ lookup label formats
 387       unknown_block = panic "unknown BlockId in applyContinuationFormat"
 388
 389 -- Either user written non-continuation code or CPS generated proc-point
 390 applyContinuationFormat formats (Continuation
 391                           (Right info) label formals is_gc blocks) =
 392     Continuation info label formals is_gc blocks
 393
 394 -- CPS generated continuations
 395 applyContinuationFormat formats (Continuation
 396                           (Left srt) label formals is_gc blocks) =
 397     Continuation (CmmInfo prof gc tag (ContInfo (continuation_stack $ format) srt))
 398                  label formals is_gc blocks
 399     where
 400       gc = Nothing -- Generated continuations never need a stack check
 401       -- TODO prof: this is the same as the current implementation
 402       -- but I think it could be improved
 403       prof = ProfilingInfo zeroCLit zeroCLit
 404       tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
 405       format = maybe unknown_block id $ lookup label formats
 406       unknown_block = panic "unknown BlockId in applyContinuationFormat"
 407