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 CmmInfo
  18 import CmmUtils
  19
  20 import Bitmap
  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 -----------------------------------------------------------------------------
  73 -- |CPS a single CmmTop (proceedure)
  74 -- Only 'CmmProc' are transformed 'CmmData' will be left alone.
  75 -----------------------------------------------------------------------------
  76
  77 cpsProc :: UniqSupply
  78         -> GenCmmTop CmmStatic CmmInfo CmmStmt     -- ^Input proceedure
  79         -> [GenCmmTop CmmStatic [CmmStatic] CmmStmt]   -- ^Output proceedure and continuations
  80 cpsProc uniqSupply (CmmData sec dat) = [CmmData sec dat]
  81 cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
  82     where
  83       uniques :: [[Unique]]
  84       uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
  85       info_uniques:block_uniques = uniques
  86
  87       -- Break the block at each function call.
  88       -- The part after the function call will have to become a continuation.
  89       broken_blocks :: [BrokenBlock]
  90       broken_blocks =
  91           concat $ zipWith3 breakBlock block_uniques blocks
  92                      (FunctionEntry info ident params:repeat ControlEntry)
  93
  94       -- Calculate live variables for each broken block.
  95       --
  96       -- Nothing can be live on entry to the first block
  97       -- so we could take the tail, but for now we wont
  98       -- to help future proof the code.
  99       live :: BlockEntryLiveness
 100       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks
 101
 102       -- Calculate which blocks must be made into full fledged procedures.
 103       proc_points :: UniqSet BlockId
 104       proc_points = calculateProcPoints broken_blocks
 105
 106       -- Construct a map so we can lookup a broken block by its 'BlockId'.
 107       block_env :: BlockEnv BrokenBlock
 108       block_env = blocksToBlockEnv broken_blocks
 109
 110       -- Group the blocks into continuations based on the set of proc-points.
 111       continuations :: [Continuation (Either C_SRT CmmInfo)]
 112       continuations = map (gatherBlocksIntoContinuation proc_points block_env)
 113                           (uniqSetToList proc_points)
 114
 115       -- Select the stack format on entry to each continuation.
 116       -- Return the max stack offset and an association list
 117       --
 118       -- This is an association list instead of a UniqFM because
 119       -- CLabel's don't have a 'Uniqueable' instance.
 120       formats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
 121       formats = selectStackFormat live continuations
 122
 123       -- Do a little meta-processing on the stack formats such as
 124       -- getting the individual frame sizes and the maximum frame size
 125       formats' :: (WordOff, [(CLabel, StackFormat)])
 126       formats' = processFormats formats
 127
 128       -- TODO FIXME NOW: calculate a real max stack (including function call args)
 129       -- TODO: from the maximum frame size get the maximum stack size.
 130       -- The difference is due to the size taken by function calls.
 131
 132       -- Update the info table data on the continuations with
 133       -- the selected stack formats.
 134       continuations' :: [Continuation CmmInfo]
 135       continuations' = map (applyStackFormat (snd formats')) continuations
 136
 137       -- Do the actual CPS transform.
 138       cps_procs :: [CmmTop]
 139       cps_procs = map (continuationToProc formats') continuations'
 140
 141       -- Convert the info tables from CmmInfo to [CmmStatic]
 142       -- We might want to put this in another pass eventually
 143       info_procs :: [RawCmmTop]
 144       info_procs = concat (zipWith mkInfoTable info_uniques cps_procs)
 145
 146 --------------------------------------------------------------------------------
 147
 148 -- The format for the call to a continuation
 149 -- The fst is the arguments that must be passed to the continuation
 150 -- by the continuation's caller.
 151 -- The snd is the live values that must be saved on stack.
 152 -- A Nothing indicates an ignored slot.
 153 -- The head of each list is the stack top or the first parameter.
 154
 155 -- The format for live values for a particular continuation
 156 -- All on stack for now.
 157 -- Head element is the top of the stack (or just under the header).
 158 -- Nothing means an empty slot.
 159 -- Future possibilities include callee save registers (i.e. passing slots in register)
 160 -- and heap memory (not sure if that's usefull at all though, but it may
 161 -- be worth exploring the design space).
 162
 163 continuationLabel (Continuation _ l _ _) = l
 164 data Continuation info =
 165   Continuation
 166      info --(Either C_SRT CmmInfo)   -- Left <=> Continuation created by the CPS
 167                        -- Right <=> Function or Proc point
 168      CLabel            -- Used to generate both info & entry labels
 169      CmmFormals        -- Argument locals live on entry (C-- procedure params)
 170      [BrokenBlock]     -- Code, may be empty.  The first block is
 171                        -- the entry point.  The order is otherwise initially
 172                        -- unimportant, but at some point the code gen will
 173                        -- fix the order.
 174
 175                        -- the BlockId of the first block does not give rise
 176                        -- to a label.  To jump to the first block in a Proc,
 177                        -- use the appropriate CLabel.
 178
 179 data StackFormat
 180     = StackFormat {
 181          stack_label :: Maybe CLabel,   -- The label occupying the top slot
 182          stack_frame_size :: WordOff,   -- Total frame size in words (not including arguments)
 183          stack_live :: [Maybe LocalReg] -- local reg offsets from stack top
 184       }
 185
 186 -- A block can be a continuation of a call
 187 -- A block can be a continuation of another block (w/ or w/o joins)
 188 -- A block can be an entry to a function
 189
 190 -----------------------------------------------------------------------------
 191
 192 collectNonProcPointTargets ::
 193     UniqSet BlockId -> BlockEnv BrokenBlock
 194     -> UniqSet BlockId -> BlockId -> UniqSet BlockId
 195 collectNonProcPointTargets proc_points blocks current_targets block =
 196     if sizeUniqSet current_targets == sizeUniqSet new_targets
 197        then current_targets
 198        else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
 199     where
 200       block' = lookupWithDefaultUFM blocks (panic "TODO") block
 201       targets =
 202         -- Note the subtlety that since the extra branch after a call
 203         -- will always be to a block that is a proc-point,
 204         -- this subtraction will always remove that case
 205         uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
 206         -- TODO: remove redundant uniqSetToList
 207       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 208
 209 -- TODO: insert proc point code here
 210 --  * Branches and switches to proc points may cause new blocks to be created
 211 --    (or proc points could leave behind phantom blocks that just jump to them)
 212 --  * Proc points might get some live variables passed as arguments
 213
 214 gatherBlocksIntoContinuation ::
 215     UniqSet BlockId -> BlockEnv BrokenBlock
 216     -> BlockId -> Continuation (Either C_SRT CmmInfo)
 217 gatherBlocksIntoContinuation proc_points blocks start =
 218   Continuation info_table clabel params body
 219     where
 220       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
 221       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
 222       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
 223       body = start_block : children_blocks
 224
 225       -- We can't properly annotate the continuation's stack parameters
 226       -- at this point because this is before stack selection
 227       -- but we want to keep the C_SRT around so we use 'Either'.
 228       info_table = case start_block_entry of
 229                      FunctionEntry info _ _ -> Right info
 230                      ContinuationEntry _ srt -> Left srt
 231                      ControlEntry -> Right CmmNonInfo
 232
 233       start_block_entry = brokenBlockEntry start_block
 234       clabel = case start_block_entry of
 235                  FunctionEntry _ label _ -> label
 236                  _ -> mkReturnPtLabel $ getUnique start
 237       params = case start_block_entry of
 238                  FunctionEntry _ _ args -> args
 239                  ContinuationEntry args _ -> args
 240                  ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
 241
 242 --------------------------------------------------------------------------------
 243 -- For now just select the continuation orders in the order they are in the set with no gaps
 244
 245 selectStackFormat :: BlockEnv CmmLive
 246                   -> [Continuation (Either C_SRT CmmInfo)]
 247                   -> [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
 248 selectStackFormat live continuations =
 249     map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
 250     where
 251       selectStackFormat' (Continuation
 252                           (Right (CmmInfo _ _ _ (ContInfo format srt)))
 253                           label _ _) = (Just label, format)
 254       selectStackFormat' (Continuation (Right _) _ _ _) = (Nothing, [])
 255       selectStackFormat' (Continuation (Left srt) label _ blocks) =
 256           -- TODO: assumes the first block is the entry block
 257           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 258           in (Just label,
 259               map Just $ uniqSetToList $
 260               lookupWithDefaultUFM live unknown_block ident)
 261
 262       unknown_block = panic "unknown BlockId in selectStackFormat"
 263
 264 processFormats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
 265                -> (WordOff, [(CLabel, StackFormat)])
 266 processFormats formats = (max_size, formats')
 267     where
 268       max_size = foldl max 0 (map (stack_frame_size . snd) formats')
 269       formats' = map make_format formats
 270       make_format (label, format) =
 271           (label,
 272            StackFormat {
 273              stack_label = fst format,
 274              stack_frame_size = stack_size (snd format) +
 275                                 if isJust (fst format)
 276                                 then label_size
 277                                 else 0,
 278              stack_live = snd format })
 279
 280       -- TODO: get rid of "+ 1" etc.
 281       label_size = 1 :: WordOff
 282
 283       stack_size [] = 0
 284       stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
 285       stack_size (Just reg:formats) = width + stack_size formats
 286           where
 287             width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 288             -- TODO: it would be better if we had a machRepWordWidth
 289
 290 -----------------------------------------------------------------------------
 291 applyStackFormat :: [(CLabel, StackFormat)]
 292                  -> Continuation (Either C_SRT CmmInfo)
 293                  -> Continuation CmmInfo
 294
 295 -- User written continuations
 296 applyStackFormat formats (Continuation
 297                           (Right (CmmInfo prof gc tag (ContInfo _ srt)))
 298                           label formals blocks) =
 299     Continuation (CmmInfo prof gc tag (ContInfo format srt))
 300                  label formals blocks
 301     where
 302       format = stack_live $ maybe unknown_block id $ lookup label formats
 303       unknown_block = panic "unknown BlockId in applyStackFormat"
 304
 305 -- User written non-continuation code
 306 applyStackFormat formats (Continuation (Right info) label formals blocks) =
 307     Continuation info label formals blocks
 308
 309 -- CPS generated continuations
 310 applyStackFormat formats (Continuation (Left srt) label formals blocks) =
 311     Continuation (CmmInfo prof gc tag (ContInfo (stack_live $ format) srt))
 312                  label formals blocks
 313     where
 314       gc = Nothing -- Generated continuations never need a stack check
 315       -- TODO prof: this is the same as the current implementation
 316       -- but I think it could be improved
 317       prof = ProfilingInfo zeroCLit zeroCLit
 318       tag = if stack_frame_size format > mAX_SMALL_BITMAP_SIZE
 319             then rET_BIG
 320             else rET_SMALL
 321       format = maybe unknown_block id $ lookup label formats
 322       unknown_block = panic "unknown BlockId in applyStackFormat"
 323
 324 -----------------------------------------------------------------------------
 325 continuationToProc :: (WordOff, [(CLabel, StackFormat)])
 326                    -> Continuation CmmInfo
 327                    -> CmmTop
 328 continuationToProc (max_stack, formats)
 329                    (Continuation info label formals blocks) =
 330     CmmProc info label formals (map continuationToProc' blocks)
 331     where
 332       curr_format = maybe unknown_block id $ lookup label formats
 333       unknown_block = panic "unknown BlockId in continuationToProc"
 334
 335       continuationToProc' :: BrokenBlock -> CmmBasicBlock
 336       continuationToProc' (BrokenBlock ident entry stmts _ exit) =
 337           BasicBlock ident (prefix++stmts++postfix)
 338           where
 339             prefix = case entry of
 340                        ControlEntry -> []
 341                        FunctionEntry (CmmInfo _ (Just gc_block) _ _) _ formals ->
 342                            gc_stack_check gc_block max_stack ++
 343                            function_entry formals curr_format
 344                        FunctionEntry (CmmInfo _ Nothing _ _) _ formals ->
 345                            panic "continuationToProc: TODO generate GC block" ++
 346                            function_entry formals curr_format
 347                        FunctionEntry CmmNonInfo _ formals ->
 348                            panic "TODO: gc_stack_check gc_block max_stack" ++
 349                            function_entry formals curr_format
 350                        ContinuationEntry formals _ ->
 351                            function_entry formals curr_format
 352             postfix = case exit of
 353                         FinalBranch next -> [CmmBranch next]
 354                         FinalSwitch expr targets -> [CmmSwitch expr targets]
 355                         FinalReturn arguments ->
 356                             tail_call (stack_frame_size curr_format)
 357                                 (CmmLoad (CmmReg spReg) wordRep)
 358                                 arguments
 359                         FinalJump target arguments ->
 360                             tail_call (stack_frame_size curr_format) target arguments
 361                         FinalCall next (CmmForeignCall target CmmCallConv)
 362                             results arguments ->
 363                                 pack_continuation curr_format cont_format ++
 364                                 tail_call (stack_frame_size curr_format - stack_frame_size cont_format)
 365                                               target arguments
 366                             where
 367                               cont_format = maybe unknown_block id $
 368                                             lookup (mkReturnPtLabel $ getUnique next) formats
 369                         FinalCall next _ results arguments -> panic "unimplemented CmmCall"
 370
 371 -----------------------------------------------------------------------------
 372 -- Functions that generate CmmStmt sequences
 373 -- for packing/unpacking continuations
 374 -- and entering/exiting functions
 375
 376 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
 377 tail_call spRel target arguments
 378   = store_arguments ++ adjust_spReg ++ jump where
 379     store_arguments =
 380         [stack_put spRel expr offset
 381          | ((expr, _), StackParam offset) <- argument_formats] ++
 382         [global_put expr global
 383          | ((expr, _), RegisterParam global) <- argument_formats]
 384     adjust_spReg =
 385         if spRel == 0
 386         then []
 387         else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
 388     jump = [CmmJump target arguments]
 389
 390     argument_formats = assignArguments (cmmExprRep . fst) arguments
 391
 392 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
 393 gc_stack_check gc_block max_frame_size
 394   = check_stack_limit where
 395     check_stack_limit = [
 396      CmmCondBranch
 397      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 398                     [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
 399      gc_block]
 400
 401 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
 402 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 403 pack_continuation (StackFormat curr_id curr_frame_size _)
 404                        (StackFormat cont_id cont_frame_size live_regs)
 405   = store_live_values ++ set_stack_header where
 406     -- TODO: only save variables when actually needed
 407     -- (may be handled by latter pass)
 408     store_live_values =
 409         [stack_put spRel (CmmReg (CmmLocal reg)) offset
 410          | (reg, offset) <- cont_offsets]
 411     set_stack_header =
 412         if needs_header_set
 413         then [stack_put spRel continuation_function 0]
 414         else []
 415
 416     -- TODO: factor with function_entry and CmmInfo.hs(?)
 417     cont_offsets = mkOffsets label_size live_regs
 418
 419     label_size = 1 :: WordOff
 420
 421     mkOffsets size [] = []
 422     mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
 423     mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
 424         where
 425           width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 426           -- TODO: it would be better if we had a machRepWordWidth
 427
 428     spRel = curr_frame_size - cont_frame_size
 429     continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
 430     needs_header_set =
 431         case (curr_id, cont_id) of
 432           (Just x, Just y) -> x /= y
 433           _ -> isJust cont_id
 434
 435 -- Lazy adjustment of stack headers assumes all blocks
 436 -- that could branch to eachother (i.e. control blocks)
 437 -- have the same stack format (this causes a problem
 438 -- only for proc-point).
 439 function_entry :: CmmFormals -> StackFormat -> [CmmStmt]
 440 function_entry formals (StackFormat _ _ live_regs)
 441   = load_live_values ++ load_args where
 442     -- TODO: only save variables when actually needed
 443     -- (may be handled by latter pass)
 444     load_live_values =
 445         [stack_get 0 reg offset
 446          | (reg, offset) <- curr_offsets]
 447     load_args =
 448         [stack_get 0 reg offset
 449          | (reg, StackParam offset) <- argument_formats] ++
 450         [global_get reg global
 451          | (reg, RegisterParam global) <- argument_formats]
 452
 453     argument_formats = assignArguments (localRegRep) formals
 454
 455     -- TODO: eliminate copy/paste with pack_continuation
 456     curr_offsets = mkOffsets label_size live_regs
 457
 458     label_size = 1 :: WordOff
 459
 460     mkOffsets size [] = []
 461     mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
 462     mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
 463         where
 464           width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 465           -- TODO: it would be better if we had a machRepWordWidth
 466
 467 -----------------------------------------------------------------------------
 468 -- Section: Stack and argument register puts and gets
 469 -----------------------------------------------------------------------------
 470 -- TODO: document
 471
 472 -- |Construct a 'CmmStmt' that will save a value on the stack
 473 stack_put :: WordOff            -- ^ Offset from the real 'Sp' that 'offset'
 474                                 -- is relative to (added to offset)
 475           -> CmmExpr            -- ^ What to store onto the stack
 476           -> WordOff            -- ^ Where on the stack to store it
 477                                 -- (positive <=> higher addresses)
 478           -> CmmStmt
 479 stack_put spRel expr offset =
 480     CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
 481
 482 --------------------------------
 483 -- |Construct a
 484 stack_get :: WordOff
 485           -> LocalReg
 486           -> WordOff
 487           -> CmmStmt
 488 stack_get spRel reg offset =
 489     CmmAssign (CmmLocal reg)
 490               (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
 491                        (localRegRep reg))
 492 global_put :: CmmExpr -> GlobalReg -> CmmStmt
 493 global_put expr global = CmmAssign (CmmGlobal global) expr
 494 global_get :: LocalReg -> GlobalReg -> CmmStmt
 495 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))
 496