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