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