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 = zipWith
 179                         (gatherBlocksIntoContinuation live proc_points block_env)
 180                         (uniqSetToList proc_points)
 181                         (Just forced_gc_id : repeat Nothing) {-dead-}
 182
 183       -- Select the stack format on entry to each continuation.
 184       -- Return the max stack offset and an association list
 185       --
 186       -- This is an association list instead of a UniqFM because
 187       -- CLabel's don't have a 'Uniqueable' instance.
 188       formats :: [(CLabel,              -- key
 189                    (CmmFormals,         -- arguments
 190                     Maybe CLabel,       -- label in top slot
 191                     [Maybe LocalReg]))] -- slots
 192       formats = selectContinuationFormat live continuations
 193
 194       -- Do a little meta-processing on the stack formats such as
 195       -- getting the individual frame sizes and the maximum frame size
 196       formats' :: (WordOff, [(CLabel, ContinuationFormat)])
 197       formats' = processFormats formats continuations
 198
 199       -- Update the info table data on the continuations with
 200       -- the selected stack formats.
 201       continuations' :: [Continuation CmmInfo]
 202       continuations' = map (applyContinuationFormat (snd formats')) continuations
 203
 204       -- Do the actual CPS transform.
 205       cps_procs :: [CmmTop]
 206       cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
 207
 208       -- Convert the info tables from CmmInfo to [CmmStatic]
 209       -- We might want to put this in another pass eventually
 210       info_procs :: [RawCmmTop]
 211       info_procs = concat (zipWith mkInfoTable info_uniques cps_procs)
 212
 213 --------------------------------------------------------------------------------
 214
 215 -----------------------------------------------------------------------------
 216
 217 collectNonProcPointTargets ::
 218     UniqSet BlockId -> BlockEnv BrokenBlock
 219     -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
 220 collectNonProcPointTargets proc_points blocks current_targets new_blocks =
 221     if sizeUniqSet current_targets == sizeUniqSet new_targets
 222        then current_targets
 223        else foldl
 224                 (collectNonProcPointTargets proc_points blocks)
 225                 new_targets
 226                 (map (:[]) targets)
 227     where
 228       blocks' = map (lookupWithDefaultUFM blocks (panic "TODO")) new_blocks
 229       targets =
 230         -- Note the subtlety that since the extra branch after a call
 231         -- will always be to a block that is a proc-point,
 232         -- this subtraction will always remove that case
 233         uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
 234                           `minusUniqSet` proc_points
 235         -- TODO: remove redundant uniqSetToList
 236       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 237
 238 -- TODO: insert proc point code here
 239 --  * Branches and switches to proc points may cause new blocks to be created
 240 --    (or proc points could leave behind phantom blocks that just jump to them)
 241 --  * Proc points might get some live variables passed as arguments
 242
 243 gatherBlocksIntoContinuation ::
 244     BlockEntryLiveness -> UniqSet BlockId -> BlockEnv BrokenBlock
 245     -> BlockId -> Maybe BlockId -> Continuation (Either C_SRT CmmInfo)
 246 gatherBlocksIntoContinuation live proc_points blocks start gc =
 247   Continuation info_table clabel params is_gc_cont body
 248     where
 249       --start_and_gc = [start] -- : maybeToList gc
 250       --children = (collectNonProcPointTargets proc_points blocks (mkUniqSet start_and_gc) start_and_gc) `minusUniqSet` (mkUniqSet start_and_gc)
 251       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
 252       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
 253       unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
 254       --gc_block = map (lookupWithDefaultUFM blocks (panic "TODO)"))
 255       --               (maybeToList gc)
 256       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
 257       body = start_block : {-gc_block ++ -} children_blocks
 258
 259       -- We can't properly annotate the continuation's stack parameters
 260       -- at this point because this is before stack selection
 261       -- but we want to keep the C_SRT around so we use 'Either'.
 262       info_table = case start_block_entry of
 263                      FunctionEntry info _ _ -> Right info
 264                      ContinuationEntry _ srt _ -> Left srt
 265                      ControlEntry -> Right (CmmNonInfo Nothing)
 266
 267       is_gc_cont = case start_block_entry of
 268                      FunctionEntry _ _ _ -> False
 269                      ContinuationEntry _ _ gc_cont -> gc_cont
 270                      ControlEntry -> False
 271
 272       start_block_entry = brokenBlockEntry start_block
 273       clabel = case start_block_entry of
 274                  FunctionEntry _ label _ -> label
 275                  _ -> mkReturnPtLabel $ getUnique start
 276       params = case start_block_entry of
 277                  FunctionEntry _ _ args -> args
 278                  ContinuationEntry args _ _ -> args
 279                  ControlEntry ->
 280                      uniqSetToList $
 281                      lookupWithDefaultUFM live unknown_block start
 282                      -- it's a proc-point, pass lives in parameter registers
 283
 284 --------------------------------------------------------------------------------
 285 -- For now just select the continuation orders in the order they are in the set with no gaps
 286
 287 selectContinuationFormat :: BlockEnv CmmLive
 288                   -> [Continuation (Either C_SRT CmmInfo)]
 289                   -> [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
 290 selectContinuationFormat live continuations =
 291     map (\c -> (continuationLabel c, selectContinuationFormat' c)) continuations
 292     where
 293       -- User written continuations
 294       selectContinuationFormat' (Continuation
 295                           (Right (CmmInfo _ _ _ (ContInfo format srt)))
 296                           label formals _ _) =
 297           (formals, Just label, format)
 298       -- Either user written non-continuation code
 299       -- or CPS generated proc-points
 300       selectContinuationFormat' (Continuation (Right _) _ formals _ _) =
 301           (formals, Nothing, [])
 302       -- CPS generated continuations
 303       selectContinuationFormat' (Continuation (Left srt) label formals _ blocks) =
 304           -- TODO: assumes the first block is the entry block
 305           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 306           in (formals,
 307               Just label,
 308               map Just $ uniqSetToList $
 309               lookupWithDefaultUFM live unknown_block ident)
 310
 311       unknown_block = panic "unknown BlockId in selectContinuationFormat"
 312
 313 processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
 314                -> [Continuation (Either C_SRT CmmInfo)]
 315                -> (WordOff, [(CLabel, ContinuationFormat)])
 316 processFormats formats continuations = (max_size, formats')
 317     where
 318       max_size = maximum $
 319                  0 : map (continuationMaxStack formats') continuations
 320       formats' = map make_format formats
 321       make_format (label, (formals, top, stack)) =
 322           (label,
 323            ContinuationFormat {
 324              continuation_formals = formals,
 325              continuation_label = top,
 326              continuation_frame_size = stack_size stack +
 327                                 if isJust top
 328                                 then label_size
 329                                 else 0,
 330              continuation_stack = stack })
 331
 332       -- TODO: get rid of "+ 1" etc.
 333       label_size = 1 :: WordOff
 334
 335       stack_size [] = 0
 336       stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
 337       stack_size (Just reg:formats) = width + stack_size formats
 338           where
 339             width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 340             -- TODO: it would be better if we had a machRepWordWidth
 341
 342 continuationMaxStack :: [(CLabel, ContinuationFormat)]
 343                      -> Continuation a
 344                      -> WordOff
 345 continuationMaxStack _ (Continuation _ _ _ True _) = 0
 346 continuationMaxStack formats (Continuation _ label _ False blocks) =
 347     max_arg_size + continuation_frame_size stack_format
 348     where
 349       stack_format = maybe unknown_format id $ lookup label formats
 350       unknown_format = panic "Unknown format in continuationMaxStack"
 351
 352       max_arg_size = maximum $ 0 : map block_max_arg_size blocks
 353
 354       block_max_arg_size block =
 355           maximum (final_arg_size (brokenBlockExit block) :
 356                    map stmt_arg_size (brokenBlockStmts block))
 357
 358       final_arg_size (FinalReturn args) =
 359           argumentsSize (cmmExprRep . fst) args
 360       final_arg_size (FinalJump _ args) =
 361           argumentsSize (cmmExprRep . fst) args
 362       final_arg_size (FinalCall next _ _ args _ True) = 0
 363       final_arg_size (FinalCall next _ _ args _ False) =
 364           -- We have to account for the stack used when we build a frame
 365           -- for the *next* continuation from *this* continuation
 366           argumentsSize (cmmExprRep . fst) args +
 367           continuation_frame_size next_format
 368           where
 369             next_format = maybe unknown_format id $ lookup next' formats
 370             next' = mkReturnPtLabel $ getUnique next
 371
 372       final_arg_size _ = 0
 373
 374       stmt_arg_size (CmmJump _ args) =
 375           argumentsSize (cmmExprRep . fst) args
 376       stmt_arg_size (CmmCall _ _ _ (CmmSafe _)) =
 377           panic "Safe call in processFormats"
 378       stmt_arg_size (CmmReturn _) =
 379           panic "CmmReturn in processFormats"
 380       stmt_arg_size _ = 0
 381
 382 -----------------------------------------------------------------------------
 383 applyContinuationFormat :: [(CLabel, ContinuationFormat)]
 384                  -> Continuation (Either C_SRT CmmInfo)
 385                  -> Continuation CmmInfo
 386
 387 -- User written continuations
 388 applyContinuationFormat formats (Continuation
 389                           (Right (CmmInfo prof gc tag (ContInfo _ srt)))
 390                           label formals is_gc blocks) =
 391     Continuation (CmmInfo prof gc tag (ContInfo format srt))
 392                  label formals is_gc blocks
 393     where
 394       format = continuation_stack $ maybe unknown_block id $ lookup label formats
 395       unknown_block = panic "unknown BlockId in applyContinuationFormat"
 396
 397 -- Either user written non-continuation code or CPS generated proc-point
 398 applyContinuationFormat formats (Continuation
 399                           (Right info) label formals is_gc blocks) =
 400     Continuation info label formals is_gc blocks
 401
 402 -- CPS generated continuations
 403 applyContinuationFormat formats (Continuation
 404                           (Left srt) label formals is_gc blocks) =
 405     Continuation (CmmInfo prof gc tag (ContInfo (continuation_stack $ format) srt))
 406                  label formals is_gc blocks
 407     where
 408       gc = Nothing -- Generated continuations never need a stack check
 409       -- TODO prof: this is the same as the current implementation
 410       -- but I think it could be improved
 411       prof = ProfilingInfo zeroCLit zeroCLit
 412       tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
 413       format = maybe unknown_block id $ lookup label formats
 414       unknown_block = panic "unknown BlockId in applyContinuationFormat"
 415