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 CgProf (curCCS, curCCSAddr)
  21 import CgUtils (cmmOffsetW)
  22 import Bitmap
  23 import ClosureInfo
  24 import MachOp
  25 import ForeignCall
  26 import CLabel
  27 import SMRep
  28 import Constants
  29
  30 import StaticFlags
  31 import DynFlags
  32 import ErrUtils
  33 import Maybes
  34 import Outputable
  35 import UniqSupply
  36 import UniqFM
  37 import UniqSet
  38 import Unique
  39
  40 import Monad
  41 import IO
  42 import Data.List
  43
  44 import MachRegs (callerSaveVolatileRegs)
  45   -- HACK: this is part of the NCG so we shouldn't use this, but we need
  46   -- it for now to eliminate the need for saved regs to be in CmmCall.
  47   -- The long term solution is to factor callerSaveVolatileRegs
  48   -- from nativeGen into CPS
  49
  50 -----------------------------------------------------------------------------
  51 -- |Top level driver for the CPS pass
  52 -----------------------------------------------------------------------------
  53 cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
  54        -> [GenCmm CmmStatic CmmInfo CmmStmt]    -- ^ Input C-- with Proceedures
  55        -> IO [GenCmm CmmStatic [CmmStatic] CmmStmt] -- ^ Output CPS transformed C--
  56 cmmCPS dflags abstractC = do
  57   when (dopt Opt_DoCmmLinting dflags) $
  58        do showPass dflags "CmmLint"
  59           case firstJust $ map cmmLint abstractC of
  60             Just err -> do printDump err
  61                            ghcExit dflags 1
  62             Nothing  -> return ()
  63   showPass dflags "CPS"
  64
  65   -- TODO: more lint checking
  66   --        check for use of branches to non-existant blocks
  67   --        check for use of Sp, SpLim, R1, R2, etc.
  68
  69   uniqSupply <- mkSplitUniqSupply 'p'
  70   let supplies = listSplitUniqSupply uniqSupply
  71   let doCpsProc s (Cmm c) =
  72           Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c
  73   let continuationC = zipWith doCpsProc supplies abstractC
  74
  75   dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
  76
  77   -- TODO: add option to dump Cmm to file
  78
  79   return continuationC
  80
  81 stg_gc_gen = mkRtsApFastLabel SLIT("gen_cg_TODO") --panic "Need the label for gc"
  82 make_gc_block block_id fun_label formals safety = BasicBlock block_id stmts
  83     where
  84       stmts = [CmmCall stg_gc_gen_target [] [] safety,
  85                CmmJump fun_expr actuals]
  86       stg_gc_gen_target =
  87           CmmForeignCall (CmmLit (CmmLabel stg_gc_gen)) CmmCallConv
  88       actuals = map (\x -> (CmmReg (CmmLocal x), NoHint)) formals
  89       fun_expr = CmmLit (CmmLabel fun_label)
  90
  91 make_gc_check stack_use gc_block =
  92     [CmmCondBranch
  93      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
  94                     [CmmReg stack_use, CmmReg spLimReg])
  95     gc_block]
  96
  97 force_gc_block old_info stack_use block_id fun_label formals =
  98     case old_info of
  99       CmmNonInfo (Just existing) -> (old_info, [], make_gc_check stack_use existing)
 100       CmmInfo _ (Just existing) _ _ -> (old_info, [], make_gc_check stack_use existing)
 101       CmmNonInfo Nothing
 102           -> (CmmNonInfo (Just block_id),
 103               [make_gc_block block_id fun_label formals (CmmSafe NoC_SRT)],
 104               make_gc_check stack_use block_id)
 105       CmmInfo prof Nothing type_tag type_info
 106           -> (CmmInfo prof (Just block_id) type_tag type_info,
 107               [make_gc_block block_id fun_label formals (CmmSafe srt)],
 108               make_gc_check stack_use block_id)
 109              where
 110                srt = case type_info of
 111                        ConstrInfo _ _ _ -> NoC_SRT
 112                        FunInfo _ srt' _ _ _ _ -> srt'
 113                        ThunkInfo _ srt' -> srt'
 114                        ThunkSelectorInfo _ srt' -> srt'
 115                        ContInfo _ srt' -> srt'
 116
 117 -----------------------------------------------------------------------------
 118 -- |CPS a single CmmTop (proceedure)
 119 -- Only 'CmmProc' are transformed 'CmmData' will be left alone.
 120 -----------------------------------------------------------------------------
 121
 122 cpsProc :: UniqSupply
 123         -> GenCmmTop CmmStatic CmmInfo CmmStmt     -- ^Input proceedure
 124         -> [GenCmmTop CmmStatic [CmmStatic] CmmStmt]   -- ^Output proceedure and continuations
 125 cpsProc uniqSupply (CmmData sec dat) = [CmmData sec dat]
 126 cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
 127     where
 128       (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
 129       uniques :: [[Unique]]
 130       uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
 131       (gc_unique:stack_use_unique:info_uniques):adaptor_uniques:block_uniques = uniques
 132       proc_uniques = map (map uniqsFromSupply . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2
 133
 134       stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegRep spReg) KindPtr)
 135
 136       -- TODO: doc
 137       forced_gc :: (CmmInfo, [CmmBasicBlock], [CmmStmt])
 138       forced_gc = force_gc_block info stack_use (BlockId gc_unique) ident params
 139       (forced_info, gc_blocks, check_stmts) = forced_gc
 140
 141       forced_blocks =
 142           case blocks of
 143             (BasicBlock id stmts) : bs ->
 144                 (BasicBlock id (check_stmts ++ stmts)) : (bs ++ gc_blocks)
 145             [] -> [] -- If there is no code then we don't need a stack check
 146
 147       forced_gc_id = case forced_info of
 148                        CmmNonInfo (Just x) -> x
 149                        CmmInfo _ (Just x) _ _ -> x
 150
 151       -- Break the block at each function call.
 152       -- The part after the function call will have to become a continuation.
 153       broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
 154       broken_blocks =
 155           (\x -> (concatMap fst x, concatMap snd x)) $
 156           zipWith3 (breakBlock [forced_gc_id])
 157                      block_uniques
 158                      forced_blocks
 159                      (FunctionEntry forced_info ident params :
 160                       repeat ControlEntry)
 161
 162       f' = selectContinuations (fst broken_blocks)
 163       broken_blocks' = map (makeContinuationEntries f') $
 164                        concat $
 165                        zipWith (adaptBlockToFormat f')
 166                                adaptor_uniques
 167                                (snd broken_blocks)
 168
 169       -- Calculate live variables for each broken block.
 170       --
 171       -- Nothing can be live on entry to the first block
 172       -- so we could take the tail, but for now we wont
 173       -- to help future proof the code.
 174       live :: BlockEntryLiveness
 175       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks'
 176
 177       -- Calculate which blocks must be made into full fledged procedures.
 178       proc_points :: UniqSet BlockId
 179       proc_points = calculateProcPoints broken_blocks'
 180
 181       -- Construct a map so we can lookup a broken block by its 'BlockId'.
 182       block_env :: BlockEnv BrokenBlock
 183       block_env = blocksToBlockEnv broken_blocks'
 184
 185       -- Group the blocks into continuations based on the set of proc-points.
 186       continuations :: [Continuation (Either C_SRT CmmInfo)]
 187       continuations = zipWith
 188                         (gatherBlocksIntoContinuation live proc_points block_env)
 189                         (uniqSetToList proc_points)
 190                         (Just forced_gc_id : repeat Nothing) {-dead-}
 191
 192       -- Select the stack format on entry to each continuation.
 193       -- Return the max stack offset and an association list
 194       --
 195       -- This is an association list instead of a UniqFM because
 196       -- CLabel's don't have a 'Uniqueable' instance.
 197       formats :: [(CLabel,              -- key
 198                    (CmmFormals,         -- arguments
 199                     Maybe CLabel,       -- label in top slot
 200                     [Maybe LocalReg]))] -- slots
 201       formats = selectContinuationFormat live continuations
 202
 203       -- Do a little meta-processing on the stack formats such as
 204       -- getting the individual frame sizes and the maximum frame size
 205       formats' :: (WordOff, [(CLabel, ContinuationFormat)])
 206       formats' = processFormats formats continuations
 207
 208       -- Update the info table data on the continuations with
 209       -- the selected stack formats.
 210       continuations' :: [Continuation CmmInfo]
 211       continuations' = map (applyContinuationFormat (snd formats')) continuations
 212
 213       -- Do the actual CPS transform.
 214       cps_procs :: [CmmTop]
 215       cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
 216
 217       -- Convert the info tables from CmmInfo to [CmmStatic]
 218       -- We might want to put this in another pass eventually
 219       info_procs :: [RawCmmTop]
 220       info_procs = concat (zipWith mkInfoTable info_uniques cps_procs)
 221
 222 --------------------------------------------------------------------------------
 223
 224 -- The format for the call to a continuation
 225 -- The fst is the arguments that must be passed to the continuation
 226 -- by the continuation's caller.
 227 -- The snd is the live values that must be saved on stack.
 228 -- A Nothing indicates an ignored slot.
 229 -- The head of each list is the stack top or the first parameter.
 230
 231 -- The format for live values for a particular continuation
 232 -- All on stack for now.
 233 -- Head element is the top of the stack (or just under the header).
 234 -- Nothing means an empty slot.
 235 -- Future possibilities include callee save registers (i.e. passing slots in register)
 236 -- and heap memory (not sure if that's usefull at all though, but it may
 237 -- be worth exploring the design space).
 238
 239 continuationLabel (Continuation _ l _ _ _) = l
 240 data Continuation info =
 241   Continuation
 242      info              -- Left <=> Continuation created by the CPS
 243                        -- Right <=> Function or Proc point
 244      CLabel            -- Used to generate both info & entry labels
 245      CmmFormals        -- Argument locals live on entry (C-- procedure params)
 246      Bool              -- ^ True <=> GC block so ignore stack size
 247      [BrokenBlock]     -- Code, may be empty.  The first block is
 248                        -- the entry point.  The order is otherwise initially
 249                        -- unimportant, but at some point the code gen will
 250                        -- fix the order.
 251
 252                        -- the BlockId of the first block does not give rise
 253                        -- to a label.  To jump to the first block in a Proc,
 254                        -- use the appropriate CLabel.
 255
 256 data ContinuationFormat
 257     = ContinuationFormat {
 258         continuation_formals :: CmmFormals,
 259         continuation_label :: Maybe CLabel,     -- The label occupying the top slot
 260         continuation_frame_size :: WordOff,     -- Total frame size in words (not including arguments)
 261         continuation_stack :: [Maybe LocalReg]  -- local reg offsets from stack top
 262       }
 263
 264 -- A block can be a continuation of a call
 265 -- A block can be a continuation of another block (w/ or w/o joins)
 266 -- A block can be an entry to a function
 267
 268 -----------------------------------------------------------------------------
 269
 270 collectNonProcPointTargets ::
 271     UniqSet BlockId -> BlockEnv BrokenBlock
 272     -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
 273 collectNonProcPointTargets proc_points blocks current_targets new_blocks =
 274     if sizeUniqSet current_targets == sizeUniqSet new_targets
 275        then current_targets
 276        else foldl
 277                 (collectNonProcPointTargets proc_points blocks)
 278                 new_targets
 279                 (map (:[]) targets)
 280     where
 281       blocks' = map (lookupWithDefaultUFM blocks (panic "TODO")) new_blocks
 282       targets =
 283         -- Note the subtlety that since the extra branch after a call
 284         -- will always be to a block that is a proc-point,
 285         -- this subtraction will always remove that case
 286         uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
 287                           `minusUniqSet` proc_points
 288         -- TODO: remove redundant uniqSetToList
 289       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 290
 291 -- TODO: insert proc point code here
 292 --  * Branches and switches to proc points may cause new blocks to be created
 293 --    (or proc points could leave behind phantom blocks that just jump to them)
 294 --  * Proc points might get some live variables passed as arguments
 295
 296 gatherBlocksIntoContinuation ::
 297     BlockEntryLiveness -> UniqSet BlockId -> BlockEnv BrokenBlock
 298     -> BlockId -> Maybe BlockId -> Continuation (Either C_SRT CmmInfo)
 299 gatherBlocksIntoContinuation live proc_points blocks start gc =
 300   Continuation info_table clabel params is_gc_cont body
 301     where
 302       --start_and_gc = [start] -- : maybeToList gc
 303       --children = (collectNonProcPointTargets proc_points blocks (mkUniqSet start_and_gc) start_and_gc) `minusUniqSet` (mkUniqSet start_and_gc)
 304       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
 305       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
 306       unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
 307       --gc_block = map (lookupWithDefaultUFM blocks (panic "TODO)"))
 308       --               (maybeToList gc)
 309       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
 310       body = start_block : {-gc_block ++ -} children_blocks
 311
 312       -- We can't properly annotate the continuation's stack parameters
 313       -- at this point because this is before stack selection
 314       -- but we want to keep the C_SRT around so we use 'Either'.
 315       info_table = case start_block_entry of
 316                      FunctionEntry info _ _ -> Right info
 317                      ContinuationEntry _ srt _ -> Left srt
 318                      ControlEntry -> Right (CmmNonInfo Nothing)
 319
 320       is_gc_cont = case start_block_entry of
 321                      FunctionEntry _ _ _ -> False
 322                      ContinuationEntry _ _ gc_cont -> gc_cont
 323                      ControlEntry -> False
 324
 325       start_block_entry = brokenBlockEntry start_block
 326       clabel = case start_block_entry of
 327                  FunctionEntry _ label _ -> label
 328                  _ -> mkReturnPtLabel $ getUnique start
 329       params = case start_block_entry of
 330                  FunctionEntry _ _ args -> args
 331                  ContinuationEntry args _ _ -> args
 332                  ControlEntry ->
 333                      uniqSetToList $
 334                      lookupWithDefaultUFM live unknown_block start
 335                      -- it's a proc-point, pass lives in parameter registers
 336
 337 --------------------------------------------------------------------------------
 338 -- For now just select the continuation orders in the order they are in the set with no gaps
 339
 340 selectContinuationFormat :: BlockEnv CmmLive
 341                   -> [Continuation (Either C_SRT CmmInfo)]
 342                   -> [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
 343 selectContinuationFormat live continuations =
 344     map (\c -> (continuationLabel c, selectContinuationFormat' c)) continuations
 345     where
 346       -- User written continuations
 347       selectContinuationFormat' (Continuation
 348                           (Right (CmmInfo _ _ _ (ContInfo format srt)))
 349                           label formals _ _) =
 350           (formals, Just label, format)
 351       -- Either user written non-continuation code
 352       -- or CPS generated proc-points
 353       selectContinuationFormat' (Continuation (Right _) _ formals _ _) =
 354           (formals, Nothing, [])
 355       -- CPS generated continuations
 356       selectContinuationFormat' (Continuation (Left srt) label formals _ blocks) =
 357           -- TODO: assumes the first block is the entry block
 358           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 359           in (formals,
 360               Just label,
 361               map Just $ uniqSetToList $
 362               lookupWithDefaultUFM live unknown_block ident)
 363
 364       unknown_block = panic "unknown BlockId in selectContinuationFormat"
 365
 366 processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
 367                -> [Continuation (Either C_SRT CmmInfo)]
 368                -> (WordOff, [(CLabel, ContinuationFormat)])
 369 processFormats formats continuations = (max_size, formats')
 370     where
 371       max_size = maximum $
 372                  0 : map (continuationMaxStack formats') continuations
 373       formats' = map make_format formats
 374       make_format (label, (formals, top, stack)) =
 375           (label,
 376            ContinuationFormat {
 377              continuation_formals = formals,
 378              continuation_label = top,
 379              continuation_frame_size = stack_size stack +
 380                                 if isJust top
 381                                 then label_size
 382                                 else 0,
 383              continuation_stack = stack })
 384
 385       -- TODO: get rid of "+ 1" etc.
 386       label_size = 1 :: WordOff
 387
 388       stack_size [] = 0
 389       stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
 390       stack_size (Just reg:formats) = width + stack_size formats
 391           where
 392             width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 393             -- TODO: it would be better if we had a machRepWordWidth
 394
 395 continuationMaxStack :: [(CLabel, ContinuationFormat)]
 396                      -> Continuation a
 397                      -> WordOff
 398 continuationMaxStack _ (Continuation _ _ _ True _) = 0
 399 continuationMaxStack formats (Continuation _ label _ False blocks) =
 400     max_arg_size + continuation_frame_size stack_format
 401     where
 402       stack_format = maybe unknown_format id $ lookup label formats
 403       unknown_format = panic "Unknown format in continuationMaxStack"
 404
 405       max_arg_size = maximum $ 0 : map block_max_arg_size blocks
 406
 407       block_max_arg_size block =
 408           maximum (final_arg_size (brokenBlockExit block) :
 409                    map stmt_arg_size (brokenBlockStmts block))
 410
 411       final_arg_size (FinalReturn args) =
 412           argumentsSize (cmmExprRep . fst) args
 413       final_arg_size (FinalJump _ args) =
 414           argumentsSize (cmmExprRep . fst) args
 415       final_arg_size (FinalCall next _ _ args _ True) = 0
 416       final_arg_size (FinalCall next _ _ args _ False) =
 417           -- We have to account for the stack used when we build a frame
 418           -- for the *next* continuation from *this* continuation
 419           argumentsSize (cmmExprRep . fst) args +
 420           continuation_frame_size next_format
 421           where
 422             next_format = maybe unknown_format id $ lookup next' formats
 423             next' = mkReturnPtLabel $ getUnique next
 424
 425       final_arg_size _ = 0
 426
 427       stmt_arg_size (CmmJump _ args) =
 428           argumentsSize (cmmExprRep . fst) args
 429       stmt_arg_size (CmmCall _ _ _ (CmmSafe _)) =
 430           panic "Safe call in processFormats"
 431       stmt_arg_size (CmmReturn _) =
 432           panic "CmmReturn in processFormats"
 433       stmt_arg_size _ = 0
 434
 435 -----------------------------------------------------------------------------
 436 applyContinuationFormat :: [(CLabel, ContinuationFormat)]
 437                  -> Continuation (Either C_SRT CmmInfo)
 438                  -> Continuation CmmInfo
 439
 440 -- User written continuations
 441 applyContinuationFormat formats (Continuation
 442                           (Right (CmmInfo prof gc tag (ContInfo _ srt)))
 443                           label formals is_gc blocks) =
 444     Continuation (CmmInfo prof gc tag (ContInfo format srt))
 445                  label formals is_gc blocks
 446     where
 447       format = continuation_stack $ maybe unknown_block id $ lookup label formats
 448       unknown_block = panic "unknown BlockId in applyContinuationFormat"
 449
 450 -- Either user written non-continuation code or CPS generated proc-point
 451 applyContinuationFormat formats (Continuation
 452                           (Right info) label formals is_gc blocks) =
 453     Continuation info label formals is_gc blocks
 454
 455 -- CPS generated continuations
 456 applyContinuationFormat formats (Continuation
 457                           (Left srt) label formals is_gc blocks) =
 458     Continuation (CmmInfo prof gc tag (ContInfo (continuation_stack $ format) srt))
 459                  label formals is_gc blocks
 460     where
 461       gc = Nothing -- Generated continuations never need a stack check
 462       -- TODO prof: this is the same as the current implementation
 463       -- but I think it could be improved
 464       prof = ProfilingInfo zeroCLit zeroCLit
 465       tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
 466       format = maybe unknown_block id $ lookup label formats
 467       unknown_block = panic "unknown BlockId in applyContinuationFormat"
 468
 469 -----------------------------------------------------------------------------
 470 continuationToProc :: (WordOff, [(CLabel, ContinuationFormat)])
 471                    -> CmmReg
 472                    -> [[Unique]]
 473                    -> Continuation CmmInfo
 474                    -> CmmTop
 475 continuationToProc (max_stack, formats) stack_use uniques
 476                    (Continuation info label formals _ blocks) =
 477     CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False))
 478     where
 479       curr_format = maybe unknown_block id $ lookup label formats
 480       unknown_block = panic "unknown BlockId in continuationToProc"
 481       curr_stack = continuation_frame_size curr_format
 482       arg_stack = argumentsSize localRegRep formals
 483
 484       param_stmts :: [CmmStmt]
 485       param_stmts = function_entry curr_format
 486
 487       gc_stmts :: [CmmStmt]
 488       gc_stmts =
 489           case info of
 490             CmmInfo _ (Just gc_block) _ _ ->
 491                 gc_stack_check' stack_use arg_stack (max_stack - curr_stack)
 492             CmmInfo _ Nothing _ _ ->
 493                 panic "continuationToProc: missing GC block"
 494             CmmNonInfo (Just gc_block) ->
 495                 gc_stack_check' stack_use arg_stack (max_stack - curr_stack)
 496             CmmNonInfo Nothing ->
 497                 panic "continuationToProc: missing non-info GC block"
 498
 499 -- At present neither the Cmm parser nor the code generator
 500 -- produce code that will allow the target of a CmmCondBranch
 501 -- or a CmmSwitch to become a continuation or a proc-point.
 502 -- If future revisions, might allow these to happen
 503 -- then special care will have to be take to allow for that case.
 504       continuationToProc' :: [Unique]
 505                           -> BrokenBlock
 506                           -> Bool
 507                           -> [CmmBasicBlock]
 508       continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
 509           prefix_blocks ++ [main_block]
 510           where
 511             prefix_blocks =
 512                 case gc_prefix ++ param_prefix of
 513                   [] -> []
 514                   entry_stmts -> [BasicBlock prefix_id
 515                                   (entry_stmts ++ [CmmBranch ident])]
 516
 517             prefix_unique : call_uniques = uniques
 518             toCLabel = mkReturnPtLabel . getUnique
 519
 520             block_for_branch unique next
 521                 | (Just cont_format) <- lookup (toCLabel next) formats
 522                 = let
 523                     new_next = BlockId unique
 524                     cont_stack = continuation_frame_size cont_format
 525                     arguments = map formal_to_actual (continuation_formals cont_format)
 526                   in (new_next,
 527                      [BasicBlock new_next $
 528                       pack_continuation False curr_format cont_format ++
 529                       tail_call (curr_stack - cont_stack)
 530                               (CmmLit $ CmmLabel $ toCLabel next)
 531                               arguments])
 532                 | otherwise
 533                 = (next, [])
 534
 535             block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
 536             block_for_branch' _ Nothing = (Nothing, [])
 537             block_for_branch' unique (Just next) = (Just new_next, new_blocks)
 538               where (new_next, new_blocks) = block_for_branch unique next
 539
 540             main_block = BasicBlock ident (stmts ++ postfix_stmts)
 541             prefix_id = BlockId prefix_unique
 542             gc_prefix = case entry of
 543                        FunctionEntry _ _ _ -> gc_stmts
 544                        ControlEntry -> []
 545                        ContinuationEntry _ _ _ -> []
 546             param_prefix = if is_entry
 547                            then param_stmts
 548                            else []
 549             postfix_stmts = case exit of
 550                         FinalBranch next ->
 551                             if (mkReturnPtLabel $ getUnique next) == label
 552                             then [CmmBranch next]
 553                             else case lookup (mkReturnPtLabel $ getUnique next) formats of
 554                               Nothing -> [CmmBranch next]
 555                               Just cont_format ->
 556                                 pack_continuation False curr_format cont_format ++
 557                                 tail_call (curr_stack - cont_stack)
 558                                           (CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next)
 559                                           arguments
 560                                 where
 561                                   cont_stack = continuation_frame_size cont_format
 562                                   arguments = map formal_to_actual (continuation_formals cont_format)
 563                         FinalSwitch expr targets -> [CmmSwitch expr targets]
 564                         FinalReturn arguments ->
 565                             tail_call curr_stack
 566                                 (CmmLoad (CmmReg spReg) wordRep)
 567                                 arguments
 568                         FinalJump target arguments ->
 569                             tail_call curr_stack target arguments
 570
 571                         -- A regular Cmm function call
 572                         FinalCall next (CmmForeignCall target CmmCallConv)
 573                             results arguments _ _ ->
 574                                 pack_continuation True curr_format cont_format ++
 575                                 tail_call (curr_stack - cont_stack)
 576                                               target arguments
 577                             where
 578                               cont_format = maybe unknown_block id $
 579                                             lookup (mkReturnPtLabel $ getUnique next) formats
 580                               cont_stack = continuation_frame_size cont_format
 581
 582                         -- A safe foreign call
 583                         FinalCall next (CmmForeignCall target conv)
 584                             results arguments _ _ ->
 585                                 target_stmts ++
 586                                 foreignCall call_uniques' (CmmForeignCall new_target conv)
 587                                             results arguments
 588                             where
 589                               (call_uniques', target_stmts, new_target) =
 590                                   maybeAssignTemp call_uniques target
 591
 592                         -- A safe prim call
 593                         FinalCall next (CmmPrim target)
 594                             results arguments _ _ ->
 595                                 foreignCall call_uniques (CmmPrim target)
 596                                             results arguments
 597
 598 formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint)
 599
 600 foreignCall :: [Unique] -> CmmCallTarget -> CmmHintFormals -> CmmActuals -> [CmmStmt]
 601 foreignCall uniques call results arguments =
 602     arg_stmts ++
 603     saveThreadState ++
 604     caller_save ++
 605     [CmmCall (CmmForeignCall suspendThread CCallConv)
 606                  [ (id,PtrHint) ]
 607                  [ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
 608                  CmmUnsafe,
 609      CmmCall call results new_args CmmUnsafe,
 610      CmmCall (CmmForeignCall resumeThread CCallConv)
 611                  [ (new_base, PtrHint) ]
 612                  [ (CmmReg (CmmLocal id), PtrHint) ]
 613                  CmmUnsafe,
 614      -- Assign the result to BaseReg: we
 615      -- might now have a different Capability!
 616      CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
 617     caller_load ++
 618     loadThreadState tso_unique ++
 619     [CmmJump (CmmReg spReg) (map (formal_to_actual . fst) results)]
 620     where
 621       (_, arg_stmts, new_args) =
 622           loadArgsIntoTemps argument_uniques arguments
 623       (caller_save, caller_load) =
 624           callerSaveVolatileRegs (Just [{-only system regs-}])
 625       new_base = LocalReg base_unique (cmmRegRep (CmmGlobal BaseReg)) KindNonPtr
 626       id = LocalReg id_unique wordRep KindNonPtr
 627       tso_unique : base_unique : id_unique : argument_uniques = uniques
 628
 629 -- -----------------------------------------------------------------------------
 630 -- Save/restore the thread state in the TSO
 631
 632 suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
 633 resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
 634
 635 -- This stuff can't be done in suspendThread/resumeThread, because it
 636 -- refers to global registers which aren't available in the C world.
 637
 638 saveThreadState =
 639   -- CurrentTSO->sp = Sp;
 640   [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
 641   closeNursery] ++
 642   -- and save the current cost centre stack in the TSO when profiling:
 643   if opt_SccProfilingOn
 644   then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
 645   else []
 646
 647    -- CurrentNursery->free = Hp+1;
 648 closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 649
 650 loadThreadState tso_unique =
 651   [
 652         -- tso = CurrentTSO;
 653         CmmAssign (CmmLocal tso) stgCurrentTSO,
 654         -- Sp = tso->sp;
 655         CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 656                               wordRep),
 657         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 658         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 659                                     rESERVED_STACK_WORDS)
 660   ] ++
 661   openNursery ++
 662   -- and load the current cost centre stack from the TSO when profiling:
 663   if opt_SccProfilingOn
 664   then [CmmStore curCCSAddr
 665         (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep)]
 666   else []
 667   where tso = LocalReg tso_unique wordRep KindNonPtr -- TODO FIXME NOW
 668
 669
 670 openNursery = [
 671         -- Hp = CurrentNursery->free - 1;
 672         CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free wordRep) (-1)),
 673
 674         -- HpLim = CurrentNursery->start +
 675         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 676         CmmAssign hpLim
 677             (cmmOffsetExpr
 678                 (CmmLoad nursery_bdescr_start wordRep)
 679                 (cmmOffset
 680                   (CmmMachOp mo_wordMul [
 681                     CmmMachOp (MO_S_Conv I32 wordRep)
 682                       [CmmLoad nursery_bdescr_blocks I32],
 683                     CmmLit (mkIntCLit bLOCK_SIZE)
 684                    ])
 685                   (-1)
 686                 )
 687             )
 688    ]
 689
 690
 691 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 692 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 693 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 694
 695 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 696 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 697 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 698
 699 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 700 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 701 tsoFieldB :: ByteOff -> ByteOff
 702 tsoFieldB off
 703   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 704   | otherwise          = off + fixedHdrSize * wORD_SIZE
 705
 706 tsoProfFieldB :: ByteOff -> ByteOff
 707 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 708
 709 stgSp             = CmmReg sp
 710 stgHp             = CmmReg hp
 711 stgCurrentTSO     = CmmReg currentTSO
 712 stgCurrentNursery = CmmReg currentNursery
 713
 714 sp                = CmmGlobal Sp
 715 spLim             = CmmGlobal SpLim
 716 hp                = CmmGlobal Hp
 717 hpLim             = CmmGlobal HpLim
 718 currentTSO        = CmmGlobal CurrentTSO
 719 currentNursery    = CmmGlobal CurrentNursery
 720
 721 -----------------------------------------------------------------------------
 722 -- Functions that generate CmmStmt sequences
 723 -- for packing/unpacking continuations
 724 -- and entering/exiting functions
 725
 726 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
 727 tail_call spRel target arguments
 728   = store_arguments ++ adjust_spReg ++ jump where
 729     store_arguments =
 730         [stack_put spRel expr offset
 731          | ((expr, _), StackParam offset) <- argument_formats] ++
 732         [global_put expr global
 733          | ((expr, _), RegisterParam global) <- argument_formats]
 734     adjust_spReg =
 735         if spRel == 0
 736         then []
 737         else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
 738     jump = [CmmJump target arguments]
 739
 740     argument_formats = assignArguments (cmmExprRep . fst) arguments
 741
 742 gc_stack_check' stack_use arg_stack max_frame_size =
 743     if max_frame_size > arg_stack
 744     then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
 745     else [CmmAssign stack_use (CmmReg spLimReg)]
 746          -- Trick the optimizer into eliminating the branch for us
 747
 748 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
 749 gc_stack_check gc_block max_frame_size
 750   = check_stack_limit where
 751     check_stack_limit = [
 752      CmmCondBranch
 753      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 754                     [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
 755                      CmmReg spLimReg])
 756      gc_block]
 757
 758
 759 -- TODO: fix branches to proc point
 760 -- (we have to insert a new block to marshel the continuation)
 761
 762
 763 pack_continuation :: Bool               -- ^ Whether to set the top/header
 764                                         -- of the stack.  We only need to
 765                                         -- set it if we are calling down
 766                                         -- as opposed to continuation
 767                                         -- adaptors.
 768                   -> ContinuationFormat -- ^ The current format
 769                   -> ContinuationFormat -- ^ The return point format
 770                   -> [CmmStmt]
 771 pack_continuation allow_header_set
 772                       (ContinuationFormat _ curr_id curr_frame_size _)
 773                       (ContinuationFormat _ cont_id cont_frame_size live_regs)
 774   = store_live_values ++ set_stack_header where
 775     -- TODO: only save variables when actually needed
 776     -- (may be handled by latter pass)
 777     store_live_values =
 778         [stack_put spRel (CmmReg (CmmLocal reg)) offset
 779          | (reg, offset) <- cont_offsets]
 780     set_stack_header =
 781         if needs_header_set && allow_header_set
 782         then [stack_put spRel continuation_function 0]
 783         else []
 784
 785     -- TODO: factor with function_entry and CmmInfo.hs(?)
 786     cont_offsets = mkOffsets label_size live_regs
 787
 788     label_size = 1 :: WordOff
 789
 790     mkOffsets size [] = []
 791     mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
 792     mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
 793         where
 794           width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 795           -- TODO: it would be better if we had a machRepWordWidth
 796
 797     spRel = curr_frame_size - cont_frame_size
 798     continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
 799     needs_header_set =
 800         case (curr_id, cont_id) of
 801           (Just x, Just y) -> x /= y
 802           _ -> isJust cont_id
 803
 804 -- Lazy adjustment of stack headers assumes all blocks
 805 -- that could branch to eachother (i.e. control blocks)
 806 -- have the same stack format (this causes a problem
 807 -- only for proc-point).
 808 function_entry :: ContinuationFormat -> [CmmStmt]
 809 function_entry (ContinuationFormat formals _ _ live_regs)
 810   = load_live_values ++ load_args where
 811     -- TODO: only save variables when actually needed
 812     -- (may be handled by latter pass)
 813     load_live_values =
 814         [stack_get 0 reg offset
 815          | (reg, offset) <- curr_offsets]
 816     load_args =
 817         [stack_get 0 reg offset
 818          | (reg, StackParam offset) <- argument_formats] ++
 819         [global_get reg global
 820          | (reg, RegisterParam global) <- argument_formats]
 821
 822     argument_formats = assignArguments (localRegRep) formals
 823
 824     -- TODO: eliminate copy/paste with pack_continuation
 825     curr_offsets = mkOffsets label_size live_regs
 826
 827     label_size = 1 :: WordOff
 828
 829     mkOffsets size [] = []
 830     mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
 831     mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
 832         where
 833           width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 834           -- TODO: it would be better if we had a machRepWordWidth
 835
 836 -----------------------------------------------------------------------------
 837 -- Section: Stack and argument register puts and gets
 838 -----------------------------------------------------------------------------
 839 -- TODO: document
 840
 841 -- |Construct a 'CmmStmt' that will save a value on the stack
 842 stack_put :: WordOff            -- ^ Offset from the real 'Sp' that 'offset'
 843                                 -- is relative to (added to offset)
 844           -> CmmExpr            -- ^ What to store onto the stack
 845           -> WordOff            -- ^ Where on the stack to store it
 846                                 -- (positive <=> higher addresses)
 847           -> CmmStmt
 848 stack_put spRel expr offset =
 849     CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
 850
 851 --------------------------------
 852 -- |Construct a
 853 stack_get :: WordOff
 854           -> LocalReg
 855           -> WordOff
 856           -> CmmStmt
 857 stack_get spRel reg offset =
 858     CmmAssign (CmmLocal reg)
 859               (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
 860                        (localRegRep reg))
 861 global_put :: CmmExpr -> GlobalReg -> CmmStmt
 862 global_put expr global = CmmAssign (CmmGlobal global) expr
 863 global_get :: LocalReg -> GlobalReg -> CmmStmt
 864 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))
 865