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 stg_gc_gen = mkRtsApFastLabel SLIT("gen_cg_TODO") --panic "Need the label for gc"
  73 make_gc_block block_id fun_label formals safety = BasicBlock block_id stmts
  74     where
  75       stmts = [CmmCall stg_gc_gen_target [] [] safety,
  76                CmmJump fun_expr actuals]
  77       stg_gc_gen_target =
  78           CmmForeignCall (CmmLit (CmmLabel stg_gc_gen)) CmmCallConv
  79       actuals = map (\x -> (CmmReg (CmmLocal x), NoHint)) formals
  80       fun_expr = CmmLit (CmmLabel fun_label)
  81
  82 make_gc_check stack_use gc_block =
  83     [CmmCondBranch
  84      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
  85                     [CmmReg stack_use, CmmReg spLimReg])
  86     gc_block]
  87
  88 force_gc_block old_info stack_use block_id fun_label formals =
  89     case old_info of
  90       CmmNonInfo (Just existing) -> (old_info, [], make_gc_check stack_use existing)
  91       CmmInfo _ (Just existing) _ _ -> (old_info, [], make_gc_check stack_use existing)
  92       CmmNonInfo Nothing
  93           -> (CmmNonInfo (Just block_id),
  94               [make_gc_block block_id fun_label formals (CmmSafe NoC_SRT)],
  95               make_gc_check stack_use block_id)
  96       CmmInfo prof Nothing type_tag type_info
  97           -> (CmmInfo prof (Just block_id) type_tag type_info,
  98               [make_gc_block block_id fun_label formals (CmmSafe srt)],
  99               make_gc_check stack_use block_id)
 100              where
 101                srt = case type_info of
 102                        ConstrInfo _ _ _ -> NoC_SRT
 103                        FunInfo _ srt' _ _ _ _ -> srt'
 104                        ThunkInfo _ srt' -> srt'
 105                        ThunkSelectorInfo _ srt' -> srt'
 106                        ContInfo _ srt' -> srt'
 107
 108 -----------------------------------------------------------------------------
 109 -- |CPS a single CmmTop (proceedure)
 110 -- Only 'CmmProc' are transformed 'CmmData' will be left alone.
 111 -----------------------------------------------------------------------------
 112
 113 cpsProc :: UniqSupply
 114         -> GenCmmTop CmmStatic CmmInfo CmmStmt     -- ^Input proceedure
 115         -> [GenCmmTop CmmStatic [CmmStatic] CmmStmt]   -- ^Output proceedure and continuations
 116 cpsProc uniqSupply (CmmData sec dat) = [CmmData sec dat]
 117 cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
 118     where
 119       (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
 120       uniques :: [[Unique]]
 121       uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
 122       (gc_unique:stack_use_unique:info_uniques):adaptor_uniques:block_uniques = uniques
 123       proc_uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply2
 124
 125       stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegRep spReg) KindPtr)
 126
 127       -- TODO: doc
 128       forced_gc :: (CmmInfo, [CmmBasicBlock], [CmmStmt])
 129       forced_gc = force_gc_block info stack_use (BlockId gc_unique) ident params
 130       (forced_info, gc_blocks, check_stmts) = forced_gc
 131
 132       forced_blocks =
 133           case blocks of
 134             (BasicBlock id stmts) : bs ->
 135                 (BasicBlock id (check_stmts ++ stmts)) : (bs ++ gc_blocks)
 136             [] -> [] -- If there is no code then we don't need a stack check
 137
 138       forced_gc_id = case forced_info of
 139                        CmmNonInfo (Just x) -> x
 140                        CmmInfo _ (Just x) _ _ -> x
 141
 142       -- Break the block at each function call.
 143       -- The part after the function call will have to become a continuation.
 144       broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
 145       broken_blocks =
 146           (\x -> (concatMap fst x, concatMap snd x)) $
 147           zipWith3 (breakBlock [forced_gc_id])
 148                      block_uniques
 149                      forced_blocks
 150                      (FunctionEntry forced_info ident params :
 151                       repeat ControlEntry)
 152
 153       f' = selectContinuations (fst broken_blocks)
 154       broken_blocks' = map (makeContinuationEntries f') $
 155                        concat $
 156                        zipWith (adaptBlockToFormat f')
 157                                adaptor_uniques
 158                                (snd broken_blocks)
 159
 160       -- Calculate live variables for each broken block.
 161       --
 162       -- Nothing can be live on entry to the first block
 163       -- so we could take the tail, but for now we wont
 164       -- to help future proof the code.
 165       live :: BlockEntryLiveness
 166       live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks'
 167
 168       -- Calculate which blocks must be made into full fledged procedures.
 169       proc_points :: UniqSet BlockId
 170       proc_points = calculateProcPoints broken_blocks'
 171
 172       -- Construct a map so we can lookup a broken block by its 'BlockId'.
 173       block_env :: BlockEnv BrokenBlock
 174       block_env = blocksToBlockEnv broken_blocks'
 175
 176       -- Group the blocks into continuations based on the set of proc-points.
 177       continuations :: [Continuation (Either C_SRT CmmInfo)]
 178       continuations = zipWith
 179                         (gatherBlocksIntoContinuation live proc_points block_env)
 180                         (uniqSetToList proc_points)
 181                         (Just forced_gc_id : repeat Nothing) {-dead-}
 182
 183       -- Select the stack format on entry to each continuation.
 184       -- Return the max stack offset and an association list
 185       --
 186       -- This is an association list instead of a UniqFM because
 187       -- CLabel's don't have a 'Uniqueable' instance.
 188       formats :: [(CLabel,              -- key
 189                    (CmmFormals,         -- arguments
 190                     Maybe CLabel,       -- label in top slot
 191                     [Maybe LocalReg]))] -- slots
 192       formats = selectContinuationFormat live continuations
 193
 194       -- Do a little meta-processing on the stack formats such as
 195       -- getting the individual frame sizes and the maximum frame size
 196       formats' :: (WordOff, [(CLabel, ContinuationFormat)])
 197       formats' = processFormats formats continuations
 198
 199       -- Update the info table data on the continuations with
 200       -- the selected stack formats.
 201       continuations' :: [Continuation CmmInfo]
 202       continuations' = map (applyContinuationFormat (snd formats')) continuations
 203
 204       -- Do the actual CPS transform.
 205       cps_procs :: [CmmTop]
 206       cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
 207
 208       -- Convert the info tables from CmmInfo to [CmmStatic]
 209       -- We might want to put this in another pass eventually
 210       info_procs :: [RawCmmTop]
 211       info_procs = concat (zipWith mkInfoTable info_uniques cps_procs)
 212
 213 --------------------------------------------------------------------------------
 214
 215 -- The format for the call to a continuation
 216 -- The fst is the arguments that must be passed to the continuation
 217 -- by the continuation's caller.
 218 -- The snd is the live values that must be saved on stack.
 219 -- A Nothing indicates an ignored slot.
 220 -- The head of each list is the stack top or the first parameter.
 221
 222 -- The format for live values for a particular continuation
 223 -- All on stack for now.
 224 -- Head element is the top of the stack (or just under the header).
 225 -- Nothing means an empty slot.
 226 -- Future possibilities include callee save registers (i.e. passing slots in register)
 227 -- and heap memory (not sure if that's usefull at all though, but it may
 228 -- be worth exploring the design space).
 229
 230 continuationLabel (Continuation _ l _ _ _) = l
 231 data Continuation info =
 232   Continuation
 233      info              -- Left <=> Continuation created by the CPS
 234                        -- Right <=> Function or Proc point
 235      CLabel            -- Used to generate both info & entry labels
 236      CmmFormals        -- Argument locals live on entry (C-- procedure params)
 237      Bool              -- ^ True <=> GC block so ignore stack size
 238      [BrokenBlock]     -- Code, may be empty.  The first block is
 239                        -- the entry point.  The order is otherwise initially
 240                        -- unimportant, but at some point the code gen will
 241                        -- fix the order.
 242
 243                        -- the BlockId of the first block does not give rise
 244                        -- to a label.  To jump to the first block in a Proc,
 245                        -- use the appropriate CLabel.
 246
 247 data ContinuationFormat
 248     = ContinuationFormat {
 249         continuation_formals :: CmmFormals,
 250         continuation_label :: Maybe CLabel,     -- The label occupying the top slot
 251         continuation_frame_size :: WordOff,     -- Total frame size in words (not including arguments)
 252         continuation_stack :: [Maybe LocalReg]  -- local reg offsets from stack top
 253       }
 254
 255 -- A block can be a continuation of a call
 256 -- A block can be a continuation of another block (w/ or w/o joins)
 257 -- A block can be an entry to a function
 258
 259 -----------------------------------------------------------------------------
 260
 261 collectNonProcPointTargets ::
 262     UniqSet BlockId -> BlockEnv BrokenBlock
 263     -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
 264 collectNonProcPointTargets proc_points blocks current_targets new_blocks =
 265     if sizeUniqSet current_targets == sizeUniqSet new_targets
 266        then current_targets
 267        else foldl
 268                 (collectNonProcPointTargets proc_points blocks)
 269                 new_targets
 270                 (map (:[]) targets)
 271     where
 272       blocks' = map (lookupWithDefaultUFM blocks (panic "TODO")) new_blocks
 273       targets =
 274         -- Note the subtlety that since the extra branch after a call
 275         -- will always be to a block that is a proc-point,
 276         -- this subtraction will always remove that case
 277         uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
 278                           `minusUniqSet` proc_points
 279         -- TODO: remove redundant uniqSetToList
 280       new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
 281
 282 -- TODO: insert proc point code here
 283 --  * Branches and switches to proc points may cause new blocks to be created
 284 --    (or proc points could leave behind phantom blocks that just jump to them)
 285 --  * Proc points might get some live variables passed as arguments
 286
 287 gatherBlocksIntoContinuation ::
 288     BlockEntryLiveness -> UniqSet BlockId -> BlockEnv BrokenBlock
 289     -> BlockId -> Maybe BlockId -> Continuation (Either C_SRT CmmInfo)
 290 gatherBlocksIntoContinuation live proc_points blocks start gc =
 291   Continuation info_table clabel params is_gc_cont body
 292     where
 293       --start_and_gc = [start] -- : maybeToList gc
 294       --children = (collectNonProcPointTargets proc_points blocks (mkUniqSet start_and_gc) start_and_gc) `minusUniqSet` (mkUniqSet start_and_gc)
 295       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
 296       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
 297       unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
 298       --gc_block = map (lookupWithDefaultUFM blocks (panic "TODO)"))
 299       --               (maybeToList gc)
 300       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
 301       body = start_block : {-gc_block ++ -} children_blocks
 302
 303       -- We can't properly annotate the continuation's stack parameters
 304       -- at this point because this is before stack selection
 305       -- but we want to keep the C_SRT around so we use 'Either'.
 306       info_table = case start_block_entry of
 307                      FunctionEntry info _ _ -> Right info
 308                      ContinuationEntry _ srt _ -> Left srt
 309                      ControlEntry -> Right (CmmNonInfo Nothing)
 310
 311       is_gc_cont = case start_block_entry of
 312                      FunctionEntry _ _ _ -> False
 313                      ContinuationEntry _ _ gc_cont -> gc_cont
 314                      ControlEntry -> False
 315
 316       start_block_entry = brokenBlockEntry start_block
 317       clabel = case start_block_entry of
 318                  FunctionEntry _ label _ -> label
 319                  _ -> mkReturnPtLabel $ getUnique start
 320       params = case start_block_entry of
 321                  FunctionEntry _ _ args -> args
 322                  ContinuationEntry args _ _ -> args
 323                  ControlEntry ->
 324                      uniqSetToList $
 325                      lookupWithDefaultUFM live unknown_block start
 326                      -- it's a proc-point, pass lives in parameter registers
 327
 328 --------------------------------------------------------------------------------
 329 -- For now just select the continuation orders in the order they are in the set with no gaps
 330
 331 selectContinuationFormat :: BlockEnv CmmLive
 332                   -> [Continuation (Either C_SRT CmmInfo)]
 333                   -> [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
 334 selectContinuationFormat live continuations =
 335     map (\c -> (continuationLabel c, selectContinuationFormat' c)) continuations
 336     where
 337       selectContinuationFormat' (Continuation
 338                           (Right (CmmInfo _ _ _ (ContInfo format srt)))
 339                           label formals _ _) =
 340           (formals, Just label, format)
 341       selectContinuationFormat' (Continuation (Right _) _ formals _ _) =
 342           (formals, Nothing, [])
 343       -- CPS generated continuations
 344       selectContinuationFormat' (Continuation (Left srt) label formals _ blocks) =
 345           -- TODO: assumes the first block is the entry block
 346           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
 347           in (formals,
 348               Just label,
 349               map Just $ uniqSetToList $
 350               lookupWithDefaultUFM live unknown_block ident)
 351
 352       unknown_block = panic "unknown BlockId in selectContinuationFormat"
 353
 354 processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
 355                -> [Continuation (Either C_SRT CmmInfo)]
 356                -> (WordOff, [(CLabel, ContinuationFormat)])
 357 processFormats formats continuations = (max_size, formats')
 358     where
 359       max_size = maximum $
 360                  0 : map (continuationMaxStack formats') continuations
 361       formats' = map make_format formats
 362       make_format (label, (formals, top, stack)) =
 363           (label,
 364            ContinuationFormat {
 365              continuation_formals = formals,
 366              continuation_label = top,
 367              continuation_frame_size = stack_size stack +
 368                                 if isJust top
 369                                 then label_size
 370                                 else 0,
 371              continuation_stack = stack })
 372
 373       -- TODO: get rid of "+ 1" etc.
 374       label_size = 1 :: WordOff
 375
 376       stack_size [] = 0
 377       stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
 378       stack_size (Just reg:formats) = width + stack_size formats
 379           where
 380             width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 381             -- TODO: it would be better if we had a machRepWordWidth
 382
 383 continuationMaxStack :: [(CLabel, ContinuationFormat)]
 384                      -> Continuation a
 385                      -> WordOff
 386 continuationMaxStack _ (Continuation _ _ _ True _) = 0
 387 continuationMaxStack formats (Continuation _ label _ False blocks) =
 388     max_arg_size + continuation_frame_size stack_format
 389     where
 390       stack_format = maybe unknown_format id $ lookup label formats
 391       unknown_format = panic "Unknown format in continuationMaxStack"
 392
 393       max_arg_size = maximum $ 0 : map block_max_arg_size blocks
 394
 395       block_max_arg_size block =
 396           maximum (final_arg_size (brokenBlockExit block) :
 397                    map stmt_arg_size (brokenBlockStmts block))
 398
 399       final_arg_size (FinalReturn args) =
 400           argumentsSize (cmmExprRep . fst) args
 401       final_arg_size (FinalJump _ args) =
 402           argumentsSize (cmmExprRep . fst) args
 403       final_arg_size (FinalCall next _ _ args _ True) = 0
 404       final_arg_size (FinalCall next _ _ args _ False) =
 405           -- We have to account for the stack used when we build a frame
 406           -- for the *next* continuation from *this* continuation
 407           argumentsSize (cmmExprRep . fst) args +
 408           continuation_frame_size next_format
 409           where
 410             next_format = maybe unknown_format id $ lookup next' formats
 411             next' = mkReturnPtLabel $ getUnique next
 412
 413       final_arg_size _ = 0
 414
 415       stmt_arg_size (CmmJump _ args) =
 416           argumentsSize (cmmExprRep . fst) args
 417       stmt_arg_size (CmmCall _ _ _ (CmmSafe _)) =
 418           panic "Safe call in processFormats"
 419       stmt_arg_size (CmmReturn _) =
 420           panic "CmmReturn in processFormats"
 421       stmt_arg_size _ = 0
 422
 423 -----------------------------------------------------------------------------
 424 applyContinuationFormat :: [(CLabel, ContinuationFormat)]
 425                  -> Continuation (Either C_SRT CmmInfo)
 426                  -> Continuation CmmInfo
 427
 428 -- User written continuations
 429 applyContinuationFormat formats (Continuation
 430                           (Right (CmmInfo prof gc tag (ContInfo _ srt)))
 431                           label formals is_gc blocks) =
 432     Continuation (CmmInfo prof gc tag (ContInfo format srt))
 433                  label formals is_gc blocks
 434     where
 435       format = continuation_stack $ maybe unknown_block id $ lookup label formats
 436       unknown_block = panic "unknown BlockId in applyContinuationFormat"
 437
 438 -- User written non-continuation code
 439 applyContinuationFormat formats (Continuation
 440                           (Right info) label formals is_gc blocks) =
 441     Continuation info label formals is_gc blocks
 442
 443 -- CPS generated continuations
 444 applyContinuationFormat formats (Continuation
 445                           (Left srt) label formals is_gc blocks) =
 446     Continuation (CmmInfo prof gc tag (ContInfo (continuation_stack $ format) srt))
 447                  label formals is_gc blocks
 448     where
 449       gc = Nothing -- Generated continuations never need a stack check
 450       -- TODO prof: this is the same as the current implementation
 451       -- but I think it could be improved
 452       prof = ProfilingInfo zeroCLit zeroCLit
 453       tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
 454       format = maybe unknown_block id $ lookup label formats
 455       unknown_block = panic "unknown BlockId in applyContinuationFormat"
 456
 457 -----------------------------------------------------------------------------
 458 continuationToProc :: (WordOff, [(CLabel, ContinuationFormat)])
 459                    -> CmmReg
 460                    -> [Unique]
 461                    -> Continuation CmmInfo
 462                    -> CmmTop
 463 continuationToProc (max_stack, formats) stack_use uniques
 464                    (Continuation info label formals _ blocks) =
 465     CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False))
 466     where
 467       curr_format = maybe unknown_block id $ lookup label formats
 468       unknown_block = panic "unknown BlockId in continuationToProc"
 469       curr_stack = continuation_frame_size curr_format
 470       arg_stack = argumentsSize localRegRep formals
 471
 472       param_stmts :: [CmmStmt]
 473       param_stmts = function_entry curr_format
 474
 475       gc_stmts :: [CmmStmt]
 476       gc_stmts =
 477           case info of
 478             CmmInfo _ (Just gc_block) _ _ ->
 479                 gc_stack_check' stack_use arg_stack (max_stack - curr_stack)
 480             CmmInfo _ Nothing _ _ ->
 481                 panic "continuationToProc: missing GC block"
 482             CmmNonInfo (Just gc_block) ->
 483                 gc_stack_check' stack_use arg_stack (max_stack - curr_stack)
 484             CmmNonInfo Nothing ->
 485                 panic "continuationToProc: missing non-info GC block"
 486
 487       continuationToProc' :: Unique -> BrokenBlock -> Bool -> [CmmBasicBlock]
 488       continuationToProc' unique (BrokenBlock ident entry stmts _ exit) is_entry =
 489           case gc_prefix ++ param_prefix of
 490             [] -> [main_block]
 491             stmts -> [BasicBlock prefix_id (gc_prefix ++ param_prefix ++ [CmmBranch ident]),
 492                       main_block]
 493           where
 494             main_block = BasicBlock ident (stmts ++ postfix)
 495             prefix_id = BlockId unique
 496             gc_prefix = case entry of
 497                        FunctionEntry _ _ _ -> gc_stmts
 498                        ControlEntry -> []
 499                        ContinuationEntry _ _ _ -> []
 500             param_prefix = if is_entry
 501                            then param_stmts
 502                            else []
 503             postfix = case exit of
 504                         FinalBranch next ->
 505                             if (mkReturnPtLabel $ getUnique next) == label
 506                             then [CmmBranch next]
 507                             else case lookup (mkReturnPtLabel $ getUnique next) formats of
 508                               Nothing -> [CmmBranch next]
 509                               Just cont_format ->
 510                                 pack_continuation False curr_format cont_format ++
 511                                 tail_call (curr_stack - cont_stack)
 512                                           (CmmLit $ CmmLabel $ mkReturnPtLabel $ getUnique next)
 513                                           arguments
 514                                 where
 515                                   cont_stack = continuation_frame_size cont_format
 516                                   arguments = map formal_to_actual (continuation_formals cont_format)
 517                                   formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint)
 518                         FinalSwitch expr targets -> [CmmSwitch expr targets]
 519                         FinalReturn arguments ->
 520                             tail_call curr_stack
 521                                 (CmmLoad (CmmReg spReg) wordRep)
 522                                 arguments
 523                         FinalJump target arguments ->
 524                             tail_call curr_stack target arguments
 525                         FinalCall next (CmmForeignCall target CmmCallConv)
 526                             results arguments _ _ ->
 527                                 pack_continuation True curr_format cont_format ++
 528                                 tail_call (curr_stack - cont_stack)
 529                                               target arguments
 530                             where
 531                               cont_format = maybe unknown_block id $
 532                                             lookup (mkReturnPtLabel $ getUnique next) formats
 533                               cont_stack = continuation_frame_size cont_format
 534                         FinalCall next _ results arguments _ _ -> panic "unimplemented CmmCall"
 535
 536 -----------------------------------------------------------------------------
 537 -- Functions that generate CmmStmt sequences
 538 -- for packing/unpacking continuations
 539 -- and entering/exiting functions
 540
 541 tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
 542 tail_call spRel target arguments
 543   = store_arguments ++ adjust_spReg ++ jump where
 544     store_arguments =
 545         [stack_put spRel expr offset
 546          | ((expr, _), StackParam offset) <- argument_formats] ++
 547         [global_put expr global
 548          | ((expr, _), RegisterParam global) <- argument_formats]
 549     adjust_spReg =
 550         if spRel == 0
 551         then []
 552         else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
 553     jump = [CmmJump target arguments]
 554
 555     argument_formats = assignArguments (cmmExprRep . fst) arguments
 556
 557 gc_stack_check' stack_use arg_stack max_frame_size =
 558     if max_frame_size > arg_stack
 559     then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
 560     else [CmmAssign stack_use (CmmReg spLimReg)]
 561          -- Trick the optimizer into eliminating the branch for us
 562
 563 gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
 564 gc_stack_check gc_block max_frame_size
 565   = check_stack_limit where
 566     check_stack_limit = [
 567      CmmCondBranch
 568      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
 569                     [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
 570                      CmmReg spLimReg])
 571      gc_block]
 572
 573
 574 -- TODO: fix branches to proc point
 575 -- (we have to insert a new block to marshel the continuation)
 576 pack_continuation :: Bool -> ContinuationFormat -> ContinuationFormat -> [CmmStmt]
 577 pack_continuation allow_header_set
 578                       (ContinuationFormat _ curr_id curr_frame_size _)
 579                       (ContinuationFormat _ cont_id cont_frame_size live_regs)
 580   = store_live_values ++ set_stack_header where
 581     -- TODO: only save variables when actually needed
 582     -- (may be handled by latter pass)
 583     store_live_values =
 584         [stack_put spRel (CmmReg (CmmLocal reg)) offset
 585          | (reg, offset) <- cont_offsets]
 586     set_stack_header =
 587         if needs_header_set && allow_header_set
 588         then [stack_put spRel continuation_function 0]
 589         else []
 590
 591     -- TODO: factor with function_entry and CmmInfo.hs(?)
 592     cont_offsets = mkOffsets label_size live_regs
 593
 594     label_size = 1 :: WordOff
 595
 596     mkOffsets size [] = []
 597     mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
 598     mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
 599         where
 600           width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 601           -- TODO: it would be better if we had a machRepWordWidth
 602
 603     spRel = curr_frame_size - cont_frame_size
 604     continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
 605     needs_header_set =
 606         case (curr_id, cont_id) of
 607           (Just x, Just y) -> x /= y
 608           _ -> isJust cont_id
 609
 610 -- Lazy adjustment of stack headers assumes all blocks
 611 -- that could branch to eachother (i.e. control blocks)
 612 -- have the same stack format (this causes a problem
 613 -- only for proc-point).
 614 function_entry :: ContinuationFormat -> [CmmStmt]
 615 function_entry (ContinuationFormat formals _ _ live_regs)
 616   = load_live_values ++ load_args where
 617     -- TODO: only save variables when actually needed
 618     -- (may be handled by latter pass)
 619     load_live_values =
 620         [stack_get 0 reg offset
 621          | (reg, offset) <- curr_offsets]
 622     load_args =
 623         [stack_get 0 reg offset
 624          | (reg, StackParam offset) <- argument_formats] ++
 625         [global_get reg global
 626          | (reg, RegisterParam global) <- argument_formats]
 627
 628     argument_formats = assignArguments (localRegRep) formals
 629
 630     -- TODO: eliminate copy/paste with pack_continuation
 631     curr_offsets = mkOffsets label_size live_regs
 632
 633     label_size = 1 :: WordOff
 634
 635     mkOffsets size [] = []
 636     mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
 637     mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
 638         where
 639           width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
 640           -- TODO: it would be better if we had a machRepWordWidth
 641
 642 -----------------------------------------------------------------------------
 643 -- Section: Stack and argument register puts and gets
 644 -----------------------------------------------------------------------------
 645 -- TODO: document
 646
 647 -- |Construct a 'CmmStmt' that will save a value on the stack
 648 stack_put :: WordOff            -- ^ Offset from the real 'Sp' that 'offset'
 649                                 -- is relative to (added to offset)
 650           -> CmmExpr            -- ^ What to store onto the stack
 651           -> WordOff            -- ^ Where on the stack to store it
 652                                 -- (positive <=> higher addresses)
 653           -> CmmStmt
 654 stack_put spRel expr offset =
 655     CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
 656
 657 --------------------------------
 658 -- |Construct a
 659 stack_get :: WordOff
 660           -> LocalReg
 661           -> WordOff
 662           -> CmmStmt
 663 stack_get spRel reg offset =
 664     CmmAssign (CmmLocal reg)
 665               (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
 666                        (localRegRep reg))
 667 global_put :: CmmExpr -> GlobalReg -> CmmStmt
 668 global_put expr global = CmmAssign (CmmGlobal global) expr
 669 global_get :: LocalReg -> GlobalReg -> CmmStmt
 670 global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))
 671