compiler/cmm/CmmCPS.hs

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