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