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