CmmLayoutStack.hs 40.4 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1 2
{-# LANGUAGE RecordWildCards, GADTs #-}
module CmmLayoutStack (
3
       cmmLayoutStack, setInfoTableStackMap
Simon Marlow's avatar
Simon Marlow committed
4 5
  ) where

Simon Marlow's avatar
Simon Marlow committed
6 7
import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX layering violation
import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX layering violation
8

9
import BasicTypes
Simon Marlow's avatar
Simon Marlow committed
10
import Cmm
11
import CmmInfo
Simon Marlow's avatar
Simon Marlow committed
12
import BlockId
13
import CLabel
Simon Marlow's avatar
Simon Marlow committed
14
import CmmUtils
15 16
import MkGraph
import ForeignCall
Simon Marlow's avatar
Simon Marlow committed
17 18 19
import CmmLive
import CmmProcPoint
import SMRep
20
import Hoopl
Simon Marlow's avatar
Simon Marlow committed
21 22 23 24 25
import UniqSupply
import Maybes
import UniqFM
import Util

26
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
27 28 29 30 31
import FastString
import Outputable
import qualified Data.Set as Set
import Control.Monad.Fix
import Data.Array as Array
32
import Data.Bits
33
import Data.List (nub)
Simon Marlow's avatar
Simon Marlow committed
34
import Control.Monad (liftM)
Simon Marlow's avatar
Simon Marlow committed
35 36 37

#include "HsVersions.h"

38
{- Note [Stack Layout]
Simon Marlow's avatar
Simon Marlow committed
39

40 41 42 43 44 45 46
The job of this pass is to

 - replace references to abstract stack Areas with fixed offsets from Sp.

 - replace the CmmHighStackMark constant used in the stack check with
   the maximum stack usage of the proc.

Gabor Greif's avatar
Gabor Greif committed
47
 - save any variables that are live across a call, and reload them as
48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125
   necessary.

Before stack allocation, local variables remain live across native
calls (CmmCall{ cmm_cont = Just _ }), and after stack allocation local
variables are clobbered by native calls.

We want to do stack allocation so that as far as possible
 - stack use is minimized, and
 - unnecessary stack saves and loads are avoided.

The algorithm we use is a variant of linear-scan register allocation,
where the stack is our register file.

 - First, we do a liveness analysis, which annotates every block with
   the variables live on entry to the block.

 - We traverse blocks in reverse postorder DFS; that is, we visit at
   least one predecessor of a block before the block itself.  The
   stack layout flowing from the predecessor of the block will
   determine the stack layout on entry to the block.

 - We maintain a data structure

     Map Label StackMap

   which describes the contents of the stack and the stack pointer on
   entry to each block that is a successor of a block that we have
   visited.

 - For each block we visit:

    - Look up the StackMap for this block.

    - If this block is a proc point (or a call continuation, if we
      aren't splitting proc points), emit instructions to reload all
      the live variables from the stack, according to the StackMap.

    - Walk forwards through the instructions:
      - At an assignment  x = Sp[loc]
        - Record the fact that Sp[loc] contains x, so that we won't
          need to save x if it ever needs to be spilled.
      - At an assignment  x = E
        - If x was previously on the stack, it isn't any more
      - At the last node, if it is a call or a jump to a proc point
        - Lay out the stack frame for the call (see setupStackFrame)
        - emit instructions to save all the live variables
        - Remember the StackMaps for all the successors
        - emit an instruction to adjust Sp
      - If the last node is a branch, then the current StackMap is the
        StackMap for the successors.

    - Manifest Sp: replace references to stack areas in this block
      with real Sp offsets. We cannot do this until we have laid out
      the stack area for the successors above.

      In this phase we also eliminate redundant stores to the stack;
      see elimStackStores.

  - There is one important gotcha: sometimes we'll encounter a control
    transfer to a block that we've already processed (a join point),
    and in that case we might need to rearrange the stack to match
    what the block is expecting. (exactly the same as in linear-scan
    register allocation, except here we have the luxury of an infinite
    supply of temporary variables).

  - Finally, we update the magic CmmHighStackMark constant with the
    stack usage of the function, and eliminate the whole stack check
    if there was no stack use. (in fact this is done as part of the
    main traversal, by feeding the high-water-mark output back in as
    an input. I hate cyclic programming, but it's just too convenient
    sometimes.)

There are plenty of tricky details: update frames, proc points, return
addresses, foreign calls, and some ad-hoc optimisations that are
convenient to do here and effective in common cases.  Comments in the
code below explain these.

-}
Simon Marlow's avatar
Simon Marlow committed
126 127 128 129 130 131 132 133 134 135


-- All stack locations are expressed as positive byte offsets from the
-- "base", which is defined to be the address above the return address
-- on the stack on entry to this CmmProc.
--
-- Lower addresses have higher StackLocs.
--
type StackLoc = ByteOff

136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
{-
 A StackMap describes the stack at any given point.  At a continuation
 it has a particular layout, like this:

         |             | <- base
         |-------------|
         |     ret0    | <- base + 8
         |-------------|
         .  upd frame  . <- base + sm_ret_off
         |-------------|
         |             |
         .    vars     .
         . (live/dead) .
         |             | <- base + sm_sp - sm_args
         |-------------|
         |    ret1     |
         .  ret vals   . <- base + sm_sp    (<--- Sp points here)
         |-------------|

Why do we include the final return address (ret0) in our stack map?  I
have absolutely no idea, but it seems to be done that way consistently
in the rest of the code generator, so I played along here. --SDM

Note that we will be constructing an info table for the continuation
(ret1), which needs to describe the stack down to, but not including,
the update frame (or ret0, if there is no update frame).
-}

Simon Marlow's avatar
Simon Marlow committed
164 165 166 167 168 169 170 171
data StackMap = StackMap
 {  sm_sp   :: StackLoc
       -- ^ the offset of Sp relative to the base on entry
       -- to this block.
 ,  sm_args :: ByteOff
       -- ^ the number of bytes of arguments in the area for this block
       -- Defn: the offset of young(L) relative to the base is given by
       -- (sm_sp - sm_args) of the StackMap for block L.
172 173 174
 ,  sm_ret_off :: ByteOff
       -- ^ Number of words of stack that we do not describe with an info
       -- table, because it contains an update frame.
Simon Marlow's avatar
Simon Marlow committed
175 176 177 178 179 180 181 182 183 184 185 186
 ,  sm_regs :: UniqFM (LocalReg,StackLoc)
       -- ^ regs on the stack
 }

instance Outputable StackMap where
  ppr StackMap{..} =
     text "Sp = " <> int sm_sp $$
     text "sm_args = " <> int sm_args $$
     text "sm_ret_off = " <> int sm_ret_off $$
     text "sm_regs = " <> ppr (eltsUFM sm_regs)


187
cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
188
               -> UniqSM (CmmGraph, BlockEnv StackMap)
189
cmmLayoutStack dflags procpoints entry_args
190
               graph0@(CmmGraph { g_entry = entry })
Simon Marlow's avatar
Simon Marlow committed
191
  = do
Jan Stolarek's avatar
Jan Stolarek committed
192 193
    -- We need liveness info. Dead assignments are removed later
    -- by the sinking pass.
194
    let (graph, liveness) = (graph0, cmmLocalLiveness dflags graph0)
Jan Stolarek's avatar
Jan Stolarek committed
195
        blocks = postorderDfs graph
Simon Marlow's avatar
Simon Marlow committed
196

197
    (final_stackmaps, _final_high_sp, new_blocks) <-
Simon Marlow's avatar
Simon Marlow committed
198
          mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
199
            layout dflags procpoints liveness entry entry_args
Simon Marlow's avatar
Simon Marlow committed
200 201
                   rec_stackmaps rec_high_sp blocks

202
    new_blocks' <- mapM (lowerSafeForeignCall dflags) new_blocks
203
    return (ofBlockList entry new_blocks', final_stackmaps)
Simon Marlow's avatar
Simon Marlow committed
204 205


206 207
layout :: DynFlags
       -> BlockSet                      -- proc points
208
       -> BlockEnv CmmLocalLive         -- liveness
Simon Marlow's avatar
Simon Marlow committed
209 210 211 212 213 214 215 216 217 218 219 220 221 222
       -> BlockId                       -- entry
       -> ByteOff                       -- stack args on entry

       -> BlockEnv StackMap             -- [final] stack maps
       -> ByteOff                       -- [final] Sp high water mark

       -> [CmmBlock]                    -- [in] blocks

       -> UniqSM
          ( BlockEnv StackMap           -- [out] stack maps
          , ByteOff                     -- [out] Sp high water mark
          , [CmmBlock]                  -- [out] new blocks
          )

223
layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks
Simon Marlow's avatar
Simon Marlow committed
224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
  = go blocks init_stackmap entry_args []
  where
    (updfr, cont_info)  = collectContInfo blocks

    init_stackmap = mapSingleton entry StackMap{ sm_sp   = entry_args
                                               , sm_args = entry_args
                                               , sm_ret_off = updfr
                                               , sm_regs = emptyUFM
                                               }

    go [] acc_stackmaps acc_hwm acc_blocks
      = return (acc_stackmaps, acc_hwm, acc_blocks)

    go (b0 : bs) acc_stackmaps acc_hwm acc_blocks
      = do
       let (entry0@(CmmEntry entry_lbl), middle0, last0) = blockSplit b0
Jan Stolarek's avatar
Jan Stolarek committed
240

Simon Marlow's avatar
Simon Marlow committed
241 242 243 244
       let stack0@StackMap { sm_sp = sp0 }
               = mapFindWithDefault
                     (pprPanic "no stack map for" (ppr entry_lbl))
                     entry_lbl acc_stackmaps
Jan Stolarek's avatar
Jan Stolarek committed
245

Simon Marlow's avatar
Simon Marlow committed
246 247
       -- (a) Update the stack map to include the effects of
       --     assignments in this block
Simon Marlow's avatar
Simon Marlow committed
248
       let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0
Jan Stolarek's avatar
Jan Stolarek committed
249

Simon Marlow's avatar
Simon Marlow committed
250 251
       -- (b) Insert assignments to reload all the live variables if this
       --     block is a proc point
Simon Marlow's avatar
Simon Marlow committed
252 253 254
       let middle1 = if entry_lbl `setMember` procpoints
                        then foldr blockCons middle0 (insertReloads stack0)
                        else middle0
Jan Stolarek's avatar
Jan Stolarek committed
255

Simon Marlow's avatar
Simon Marlow committed
256 257 258 259 260
       -- (c) Look at the last node and if we are making a call or
       --     jumping to a proc point, we must save the live
       --     variables, adjust Sp, and construct the StackMaps for
       --     each of the successor blocks.  See handleLastNode for
       --     details.
261
       (middle2, sp_off, last1, fixup_blocks, out)
262
           <- handleLastNode dflags procpoints liveness cont_info
Simon Marlow's avatar
Simon Marlow committed
263
                             acc_stackmaps stack1 middle0 last0
Jan Stolarek's avatar
Jan Stolarek committed
264

Simon Marlow's avatar
Simon Marlow committed
265 266 267
       -- (d) Manifest Sp: run over the nodes in the block and replace
       --     CmmStackSlot with CmmLoad from Sp with a concrete offset.
       --
268 269 270 271 272 273
       -- our block:
       --    middle1          -- the original middle nodes
       --    middle2          -- live variable saves from handleLastNode
       --    Sp = Sp + sp_off -- Sp adjustment goes here
       --    last1            -- the last node
       --
Simon Marlow's avatar
Simon Marlow committed
274
       let middle_pre = blockToList $ foldl blockSnoc middle1 middle2
275

276
           final_blocks = manifestSp dflags final_stackmaps stack0 sp0 final_sp_high entry0
277
                              middle_pre sp_off last1 fixup_blocks
278

279
           acc_stackmaps' = mapUnion acc_stackmaps out
280

281 282 283 284 285 286 287 288 289 290 291
           -- If this block jumps to the GC, then we do not take its
           -- stack usage into account for the high-water mark.
           -- Otherwise, if the only stack usage is in the stack-check
           -- failure block itself, we will do a redundant stack
           -- check.  The stack has a buffer designed to accommodate
           -- the largest amount of stack needed for calling the GC.
           --
           this_sp_hwm | isGcJump last0 = 0
                       | otherwise      = sp0 - sp_off

           hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out))
292

293
       go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)
294 295


296 297 298 299 300 301 302 303
-- -----------------------------------------------------------------------------

-- Not foolproof, but GCFun is the culprit we most want to catch
isGcJump :: CmmNode O C -> Bool
isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) })
  = l == GCFun || l == GCEnter1
isGcJump _something_else = False

Simon Marlow's avatar
Simon Marlow committed
304
-- -----------------------------------------------------------------------------
305

Simon Marlow's avatar
Simon Marlow committed
306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322
-- This doesn't seem right somehow.  We need to find out whether this
-- proc will push some update frame material at some point, so that we
-- can avoid using that area of the stack for spilling.  The
-- updfr_space field of the CmmProc *should* tell us, but it doesn't
-- (I think maybe it gets filled in later when we do proc-point
-- splitting).
--
-- So we'll just take the max of all the cml_ret_offs.  This could be
-- unnecessarily pessimistic, but probably not in the code we
-- generate.

collectContInfo :: [CmmBlock] -> (ByteOff, BlockEnv ByteOff)
collectContInfo blocks
  = (maximum ret_offs, mapFromList (catMaybes mb_argss))
 where
  (mb_argss, ret_offs) = mapAndUnzip get_cont blocks

323
  get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)
Simon Marlow's avatar
Simon Marlow committed
324 325 326 327 328
  get_cont b =
     case lastNode b of
        CmmCall { cml_cont = Just l, .. }
           -> (Just (l, cml_ret_args), cml_ret_off)
        CmmForeignCall { .. }
329
           -> (Just (succ, ret_args), ret_off)
Simon Marlow's avatar
Simon Marlow committed
330 331 332
        _other -> (Nothing, 0)


Simon Marlow's avatar
Simon Marlow committed
333 334
-- -----------------------------------------------------------------------------
-- Updating the StackMap from middle nodes
Simon Marlow's avatar
Simon Marlow committed
335

Simon Marlow's avatar
Simon Marlow committed
336
-- Look for loads from stack slots, and update the StackMap.  This is
337
-- purely for optimisation reasons, so that we can avoid saving a
Simon Marlow's avatar
Simon Marlow committed
338 339 340 341 342 343 344
-- variable back to a different stack slot if it is already on the
-- stack.
--
-- This happens a lot: for example when function arguments are passed
-- on the stack and need to be immediately saved across a call, we
-- want to just leave them where they are on the stack.
--
Simon Marlow's avatar
Simon Marlow committed
345 346 347
procMiddle :: BlockEnv StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle stackmaps node sm
  = case node of
348
     CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)
Simon Marlow's avatar
Simon Marlow committed
349 350 351 352 353 354 355 356 357 358 359 360 361 362
       -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) }
        where loc = getStackLoc area off stackmaps
     CmmAssign (CmmLocal r) _other
       -> sm { sm_regs = delFromUFM (sm_regs sm) r }
     _other
       -> sm

getStackLoc :: Area -> ByteOff -> BlockEnv StackMap -> StackLoc
getStackLoc Old       n _         = n
getStackLoc (Young l) n stackmaps =
  case mapLookup l stackmaps of
    Nothing -> pprPanic "getStackLoc" (ppr l)
    Just sm -> sm_sp sm - sm_args sm + n

Simon Marlow's avatar
Simon Marlow committed
363

Simon Marlow's avatar
Simon Marlow committed
364 365 366
-- -----------------------------------------------------------------------------
-- Handling stack allocation for a last node

367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382
-- We take a single last node and turn it into:
--
--    C1 (some statements)
--    Sp = Sp + N
--    C2 (some more statements)
--    call f()          -- the actual last node
--
-- plus possibly some more blocks (we may have to add some fixup code
-- between the last node and the continuation).
--
-- C1: is the code for saving the variables across this last node onto
-- the stack, if the continuation is a call or jumps to a proc point.
--
-- C2: if the last node is a safe foreign call, we have to inject some
-- extra code that goes *after* the Sp adjustment.

Simon Marlow's avatar
Simon Marlow committed
383
handleLastNode
384
   :: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff
Simon Marlow's avatar
Simon Marlow committed
385
   -> BlockEnv StackMap -> StackMap
Simon Marlow's avatar
Simon Marlow committed
386
   -> Block CmmNode O O
Simon Marlow's avatar
Simon Marlow committed
387 388
   -> CmmNode O C
   -> UniqSM
389 390
      ( [CmmNode O O]      -- nodes to go *before* the Sp adjustment
      , ByteOff            -- amount to adjust Sp
Simon Marlow's avatar
Simon Marlow committed
391 392
      , CmmNode O C        -- new last node
      , [CmmBlock]         -- new blocks
393
      , BlockEnv StackMap  -- stackmaps for the continuations
Simon Marlow's avatar
Simon Marlow committed
394 395
      )

396
handleLastNode dflags procpoints liveness cont_info stackmaps
Simon Marlow's avatar
Simon Marlow committed
397
               stack0@StackMap { sm_sp = sp0 } middle last
Simon Marlow's avatar
Simon Marlow committed
398 399 400 401 402 403
 = case last of
    --  At each return / tail call,
    --  adjust Sp to point to the last argument pushed, which
    --  is cml_args, after popping any other junk from the stack.
    CmmCall{ cml_cont = Nothing, .. } -> do
      let sp_off = sp0 - cml_args
404
      return ([], sp_off, last, [], mapEmpty)
Simon Marlow's avatar
Simon Marlow committed
405 406

    --  At each CmmCall with a continuation:
407
    CmmCall{ cml_cont = Just cont_lbl, .. } ->
Simon Marlow's avatar
Simon Marlow committed
408
       return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
409

410
    CmmForeignCall{ succ = cont_lbl, .. } -> do
411 412
       return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off
            -- one word of args: the return address
413

414 415 416
    CmmBranch{..}     ->  handleBranches
    CmmCondBranch{..} ->  handleBranches
    CmmSwitch{..}     ->  handleBranches
417 418

  where
Simon Marlow's avatar
Simon Marlow committed
419 420 421 422 423 424 425 426 427 428 429 430 431
     -- Calls and ForeignCalls are handled the same way:
     lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff
              -> ( [CmmNode O O]
                 , ByteOff
                 , CmmNode O C
                 , [CmmBlock]
                 , BlockEnv StackMap
                 )
     lastCall lbl cml_args cml_ret_args cml_ret_off
      =  ( assignments
         , spOffsetForCall sp0 cont_stack cml_args
         , last
         , [] -- no new blocks
432
         , mapSingleton lbl cont_stack )
Simon Marlow's avatar
Simon Marlow committed
433
      where
434 435 436 437 438 439 440 441 442 443 444 445 446
         (assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off


     prepareStack lbl cml_ret_args cml_ret_off
       | Just cont_stack <- mapLookup lbl stackmaps
             -- If we have already seen this continuation before, then
             -- we just have to make the stack look the same:
       = (fixupStack stack0 cont_stack, cont_stack)
             -- Otherwise, we have to allocate the stack frame
       | otherwise
       = (save_assignments, new_cont_stack)
       where
        (new_cont_stack, save_assignments)
447
           = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0
448 449


450
     -- For other last nodes (branches), if any of the targets is a
Simon Marlow's avatar
Simon Marlow committed
451 452 453
     -- proc point, we have to set up the stack to match what the proc
     -- point is expecting.
     --
454
     handleBranches :: UniqSM ( [CmmNode O O]
Simon Marlow's avatar
Simon Marlow committed
455 456
                                , ByteOff
                                , CmmNode O C
457 458
                                , [CmmBlock]
                                , BlockEnv StackMap )
Simon Marlow's avatar
Simon Marlow committed
459

460
     handleBranches
461 462
         -- Note [diamond proc point]
       | Just l <- futureContinuation middle
Simon Marlow's avatar
Simon Marlow committed
463
       , (nub $ filter (`setMember` procpoints) $ successors last) == [l]
464 465 466 467 468 469
       = do
         let cont_args = mapFindWithDefault 0 l cont_info
             (assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0)
             out = mapFromList [ (l', cont_stack)
                               | l' <- successors last ]
         return ( assigs
470
                , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)
471 472 473
                , last
                , []
                , out)
Simon Marlow's avatar
Simon Marlow committed
474

Simon Marlow's avatar
Simon Marlow committed
475
        | otherwise = do
476
          pps <- mapM handleBranch (successors last)
Simon Marlow's avatar
Simon Marlow committed
477 478
          let lbl_map :: LabelMap Label
              lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]
479
              fix_lbl l = mapFindWithDefault l l lbl_map
Simon Marlow's avatar
Simon Marlow committed
480 481 482
          return ( []
                 , 0
                 , mapSuccessors fix_lbl last
483 484
                 , concat [ blk | (_,_,_,blk) <- pps ]
                 , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )
Simon Marlow's avatar
Simon Marlow committed
485

486 487 488 489 490 491 492 493 494
     -- For each successor of this block
     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
     handleBranch l
        --   (a) if the successor already has a stackmap, we need to
        --       shuffle the current stack to make it look the same.
        --       We have to insert a new block to make this happen.
        | Just stack2 <- mapLookup l stackmaps
        = do
             let assigs = fixupStack stack0 stack2
495
             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs
496 497 498 499 500 501 502 503
             return (l, tmp_lbl, stack2, block)

        --   (b) if the successor is a proc point, save everything
        --       on the stack.
        | l `setMember` procpoints
        = do
             let cont_args = mapFindWithDefault 0 l cont_info
                 (stack2, assigs) =
504
                      setupStackFrame dflags l liveness (sm_ret_off stack0)
Jan Stolarek's avatar
Jan Stolarek committed
505
                                                        cont_args stack0
506
             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs
507 508 509 510 511 512 513 514 515 516 517 518 519
             return (l, tmp_lbl, stack2, block)

        --   (c) otherwise, the current StackMap is the StackMap for
        --       the continuation.  But we must remember to remove any
        --       variables from the StackMap that are *not* live at
        --       the destination, because this StackMap might be used
        --       by fixupStack if this is a join point.
        | otherwise = return (l, l, stack1, [])
        where live = mapFindWithDefault (panic "handleBranch") l liveness
              stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) }
              is_live (r,_) = r `elemRegSet` live


520 521 522
makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap -> [CmmNode O O]
               -> UniqSM (Label, [CmmBlock])
makeFixupBlock dflags sp0 l stack assigs
523 524 525 526 527
  | null assigs && sp0 == sm_sp stack = return (l, [])
  | otherwise = do
    tmp_lbl <- liftM mkBlockId $ getUniqueM
    let sp_off = sp0 - sm_sp stack
        block = blockJoin (CmmEntry tmp_lbl)
528
                          (maybeAddSpAdj dflags sp_off (blockFromList assigs))
529 530
                          (CmmBranch l)
    return (tmp_lbl, [block])
Simon Marlow's avatar
Simon Marlow committed
531 532 533 534 535 536 537 538 539 540


-- Sp is currently pointing to current_sp,
-- we want it to point to
--    (sm_sp cont_stack - sm_args cont_stack + args)
-- so the difference is
--    sp0 - (sm_sp cont_stack - sm_args cont_stack + args)
spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff
spOffsetForCall current_sp cont_stack args
  = current_sp - (sm_sp cont_stack - sm_args cont_stack + args)
Simon Marlow's avatar
Simon Marlow committed
541 542 543 544 545 546 547


-- | create a sequence of assignments to establish the new StackMap,
-- given the old StackMap.
fixupStack :: StackMap -> StackMap -> [CmmNode O O]
fixupStack old_stack new_stack = concatMap move new_locs
 where
Simon Marlow's avatar
Simon Marlow committed
548
     old_map  = sm_regs old_stack
Simon Marlow's avatar
Simon Marlow committed
549 550 551
     new_locs = stackSlotRegs new_stack

     move (r,n)
Simon Marlow's avatar
Simon Marlow committed
552
       | Just (_,m) <- lookupUFM old_map r, n == m = []
Simon Marlow's avatar
Simon Marlow committed
553 554 555
       | otherwise = [CmmStore (CmmStackSlot Old n)
                               (CmmReg (CmmLocal r))]

Simon Marlow's avatar
Simon Marlow committed
556 557 558


setupStackFrame
559 560
             :: DynFlags
             -> BlockId                 -- label of continuation
561
             -> BlockEnv CmmLocalLive   -- liveness
Simon Marlow's avatar
Simon Marlow committed
562 563 564 565 566
             -> ByteOff      -- updfr
             -> ByteOff      -- bytes of return values on stack
             -> StackMap     -- current StackMap
             -> (StackMap, [CmmNode O O])

567
setupStackFrame dflags lbl liveness updfr_off ret_args stack0
Simon Marlow's avatar
Simon Marlow committed
568
  = (cont_stack, assignments)
Simon Marlow's avatar
Simon Marlow committed
569 570 571 572 573 574 575 576 577 578 579 580 581 582
  where
      -- get the set of LocalRegs live in the continuation
      live = mapFindWithDefault Set.empty lbl liveness

      -- the stack from the base to updfr_off is off-limits.
      -- our new stack frame contains:
      --   * saved live variables
      --   * the return address [young(C) + 8]
      --   * the args for the call,
      --     which are replaced by the return values at the return
      --     point.

      -- everything up to updfr_off is off-limits
      -- stack1 contains updfr_off, plus everything we need to save
583
      (stack1, assignments) = allocate dflags updfr_off live stack0
Simon Marlow's avatar
Simon Marlow committed
584 585 586 587 588 589 590 591 592

      -- And the Sp at the continuation is:
      --   sm_sp stack1 + ret_args
      cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args
                         , sm_args = ret_args
                         , sm_ret_off = updfr_off
                         }


593 594 595 596 597 598
-- -----------------------------------------------------------------------------
-- Note [diamond proc point]
--
-- This special case looks for the pattern we get from a typical
-- tagged case expression:
--
Simon Marlow's avatar
Simon Marlow committed
599 600
--    Sp[young(L1)] = L1
--    if (R1 & 7) != 0 goto L1 else goto L2
601
--  L2:
Simon Marlow's avatar
Simon Marlow committed
602
--    call [R1] returns to L1
603
--  L1: live: {y}
Simon Marlow's avatar
Simon Marlow committed
604
--    x = R1
605 606 607
--
-- If we let the generic case handle this, we get
--
Simon Marlow's avatar
Simon Marlow committed
608 609
--    Sp[-16] = L1
--    if (R1 & 7) != 0 goto L1a else goto L2
610
--  L2:
Simon Marlow's avatar
Simon Marlow committed
611 612 613
--    Sp[-8] = y
--    Sp = Sp - 16
--    call [R1] returns to L1
614
--  L1a:
Simon Marlow's avatar
Simon Marlow committed
615 616 617
--    Sp[-8] = y
--    Sp = Sp - 16
--    goto L1
618
--  L1:
Simon Marlow's avatar
Simon Marlow committed
619
--    x = R1
620 621
--
-- The code for saving the live vars is duplicated in each branch, and
Simon Marlow's avatar
Simon Marlow committed
622 623 624 625 626 627
-- furthermore there is an extra jump in the fast path (assuming L1 is
-- a proc point, which it probably is if there is a heap check).
--
-- So to fix this we want to set up the stack frame before the
-- conditional jump.  How do we know when to do this, and when it is
-- safe?  The basic idea is, when we see the assignment
Jan Stolarek's avatar
Jan Stolarek committed
628
--
Simon Marlow's avatar
Simon Marlow committed
629
--   Sp[young(L)] = L
Jan Stolarek's avatar
Jan Stolarek committed
630
--
Simon Marlow's avatar
Simon Marlow committed
631 632 633 634 635 636 637 638
-- we know that
--   * we are definitely heading for L
--   * there can be no more reads from another stack area, because young(L)
--     overlaps with it.
--
-- We don't necessarily know that everything live at L is live now
-- (some might be assigned between here and the jump to L).  So we
-- simplify and only do the optimisation when we see
639 640 641 642 643
--
--   (1) a block containing an assignment of a return address L
--   (2) ending in a branch where one (and only) continuation goes to L,
--       and no other continuations go to proc points.
--
Simon Marlow's avatar
Simon Marlow committed
644 645
-- then we allocate the stack frame for L at the end of the block,
-- before the branch.
646 647 648 649 650 651
--
-- We could generalise (2), but that would make it a bit more
-- complicated to handle, and this currently catches the common case.

futureContinuation :: Block CmmNode O O -> Maybe BlockId
futureContinuation middle = foldBlockNodesB f middle Nothing
652 653
   where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
         f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _
654 655 656 657 658 659 660 661 662 663
               = Just l
         f _ r = r

-- -----------------------------------------------------------------------------
-- Saving live registers

-- | Given a set of live registers and a StackMap, save all the registers
-- on the stack and return the new StackMap and the assignments to do
-- the saving.
--
664
allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
665 666 667
         -> (StackMap, [CmmNode O O])
allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
                                              , sm_regs = regs0 }
668 669 670 671 672 673 674 675
 =
   -- we only have to save regs that are not already in a slot
   let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live)
       regs1   = filterUFM (\(r,_) -> elemRegSet r live) regs0
   in

   -- make a map of the stack
   let stack = reverse $ Array.elems $
676
               accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $
677 678 679
                 ret_words ++ live_words
            where ret_words =
                   [ (x, Occupied)
680
                   | x <- [ 1 .. toWords dflags ret_off] ]
681
                  live_words =
682
                   [ (toWords dflags x, Occupied)
683
                   | (r,off) <- eltsUFM regs1,
684 685
                     let w = localRegBytes dflags r,
                     x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]
686 687 688 689 690 691
   in

   -- Pass over the stack: find slots to save all the new live variables,
   -- choosing the oldest slots first (hence a foldr).
   let
       save slot ([], stack, n, assigs, regs) -- no more regs to save
692
          = ([], slot:stack, plusW dflags n 1, assigs, regs)
693 694
       save slot (to_save, stack, n, assigs, regs)
          = case slot of
695
               Occupied ->  (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)
696 697 698 699 700
               Empty
                 | Just (stack', r, to_save') <-
                       select_save to_save (slot:stack)
                 -> let assig = CmmStore (CmmStackSlot Old n')
                                         (CmmReg (CmmLocal r))
701
                        n' = plusW dflags n 1
702 703 704 705
                   in
                        (to_save', stack', n', assig : assigs, (r,(r,n')):regs)

                 | otherwise
706
                 -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)
707 708 709 710 711 712 713 714 715 716 717 718

       -- we should do better here: right now we'll fit the smallest first,
       -- but it would make more sense to fit the biggest first.
       select_save :: [LocalReg] -> [StackSlot]
                   -> Maybe ([StackSlot], LocalReg, [LocalReg])
       select_save regs stack = go regs []
         where go []     _no_fit = Nothing
               go (r:rs) no_fit
                 | Just rest <- dropEmpty words stack
                 = Just (replicate words Occupied ++ rest, r, rs++no_fit)
                 | otherwise
                 = go rs (r:no_fit)
719
                 where words = localRegWords dflags r
720 721 722 723 724 725 726 727 728 729 730 731

       -- fill in empty slots as much as possible
       (still_to_save, save_stack, n, save_assigs, save_regs)
          = foldr save (to_save, [], 0, [], []) stack

       -- push any remaining live vars on the stack
       (push_sp, push_assigs, push_regs)
          = foldr push (n, [], []) still_to_save
          where
              push r (n, assigs, regs)
                = (n', assig : assigs, (r,(r,n')) : regs)
                where
732
                  n' = n + localRegBytes dflags r
733 734 735 736 737 738
                  assig = CmmStore (CmmStackSlot Old n')
                                   (CmmReg (CmmLocal r))

       trim_sp
          | not (null push_regs) = push_sp
          | otherwise
739
          = plusW dflags n (- length (takeWhile isEmpty save_stack))
740 741 742 743 744 745 746 747

       final_regs = regs1 `addListToUFM` push_regs
                          `addListToUFM` save_regs

   in
  -- XXX should be an assert
   if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else

748
   if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
749 750 751 752 753

   ( stackmap { sm_regs = final_regs , sm_sp = trim_sp }
   , push_assigs ++ save_assigs )


Simon Marlow's avatar
Simon Marlow committed
754
-- -----------------------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
755
-- Manifesting Sp
Simon Marlow's avatar
Simon Marlow committed
756

Simon Marlow's avatar
Simon Marlow committed
757 758 759 760 761 762 763 764 765 766 767 768 769
-- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp.  The
-- block looks like this:
--
--    middle_pre       -- the middle nodes
--    Sp = Sp + sp_off -- Sp adjustment goes here
--    last             -- the last node
--
-- And we have some extra blocks too (that don't contain Sp adjustments)
--
-- The adjustment for middle_pre will be different from that for
-- middle_post, because the Sp adjustment intervenes.
--
manifestSp
770 771
   :: DynFlags
   -> BlockEnv StackMap  -- StackMaps for other blocks
Simon Marlow's avatar
Simon Marlow committed
772 773 774 775 776 777 778 779 780 781
   -> StackMap           -- StackMap for this block
   -> ByteOff            -- Sp on entry to the block
   -> ByteOff            -- SpHigh
   -> CmmNode C O        -- first node
   -> [CmmNode O O]      -- middle
   -> ByteOff            -- sp_off
   -> CmmNode O C        -- last node
   -> [CmmBlock]         -- new blocks
   -> [CmmBlock]         -- final blocks with Sp manifest

782
manifestSp dflags stackmaps stack0 sp0 sp_high
Simon Marlow's avatar
Simon Marlow committed
783 784 785 786 787 788
           first middle_pre sp_off last fixup_blocks
  = final_block : fixup_blocks'
  where
    area_off = getAreaOff stackmaps

    adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
789 790
    adj_pre_sp  = mapExpDeep (areaToSp dflags sp0            sp_high area_off)
    adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)
Simon Marlow's avatar
Simon Marlow committed
791

792
    final_middle = maybeAddSpAdj dflags sp_off $
Simon Marlow's avatar
Simon Marlow committed
793 794 795 796 797 798 799 800 801
                   blockFromList $
                   map adj_pre_sp $
                   elimStackStores stack0 stackmaps area_off $
                   middle_pre

    final_last    = optStackCheck (adj_post_sp last)

    final_block   = blockJoin first final_middle final_last

802
    fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks
Simon Marlow's avatar
Simon Marlow committed
803 804 805 806 807 808 809 810 811 812


getAreaOff :: BlockEnv StackMap -> (Area -> StackLoc)
getAreaOff _ Old = 0
getAreaOff stackmaps (Young l) =
  case mapLookup l stackmaps of
    Just sm -> sm_sp sm - sm_args sm
    Nothing -> pprPanic "getAreaOff" (ppr l)


813 814 815 816
maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj _      0      block = block
maybeAddSpAdj dflags sp_off block
   = block `blockSnoc` CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off)
Simon Marlow's avatar
Simon Marlow committed
817 818 819


{-
Simon Marlow's avatar
Simon Marlow committed
820 821 822 823 824 825
Sp(L) is the Sp offset on entry to block L relative to the base of the
OLD area.

SpArgs(L) is the size of the young area for L, i.e. the number of
arguments.

826
 - in block L, each reference to [old + N] turns into
Simon Marlow's avatar
Simon Marlow committed
827 828
   [Sp + Sp(L) - N]

829
 - in block L, each reference to [young(L') + N] turns into
Simon Marlow's avatar
Simon Marlow committed
830 831 832 833 834 835
   [Sp + Sp(L) - Sp(L') + SpArgs(L') - N]

 - be careful with the last node of each block: Sp has already been adjusted
   to be Sp + Sp(L) - Sp(L')
-}

836
areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
837 838 839 840 841 842 843 844 845 846 847

areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)
  = cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n)
    -- Replace (CmmStackSlot area n) with an offset from Sp

areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark) 
  = mkIntExpr dflags sp_hwm
    -- Replace CmmHighStackMark with the number of bytes of stack used, 
    -- the sp_hwm.   See Note [Stack usage] in StgCmmHeap

areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _)  
848
                          [CmmMachOp (MO_Sub _)
849 850
                                  [ CmmRegOff (CmmGlobal Sp) x_off
                                  , CmmLit (CmmInt y_lit _)],
851
                           CmmReg (CmmGlobal SpLim)])
852 853 854 855 856
  | fromIntegral x_off >= y_lit 
  = zeroExpr dflags
    -- Replace a stack-overflow test that cannot fail with a no-op
    -- See Note [Always false stack check]

857
areaToSp _ _ _ _ other = other
Simon Marlow's avatar
Simon Marlow committed
858

859 860 861
-- Note [Always false stack check]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- We can optimise stack checks of the form
862
--
863
--   if ((Sp + x) - y < SpLim) then .. else ..
864
--
865 866 867 868 869 870
-- where are non-negative integer byte offsets.  Since we know that
-- SpLim <= Sp (remember the stack grows downwards), this test must
-- yield False if (x >= y), so we can rewrite the comparison to False.
-- A subsequent sinking pass will later drop the dead code.
-- Optimising this away depends on knowing that SpLim <= Sp, so it is
-- really the job of the stack layout algorithm, hence we do it now.
871 872 873 874 875 876 877

optStackCheck :: CmmNode O C -> CmmNode O C
optStackCheck n = -- Note [null stack check]
 case n of
   CmmCondBranch (CmmLit (CmmInt 0 _)) _true false -> CmmBranch false
   other -> other

Simon Marlow's avatar
Simon Marlow committed
878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907

-- -----------------------------------------------------------------------------

-- | Eliminate stores of the form
--
--    Sp[area+n] = r
--
-- when we know that r is already in the same slot as Sp[area+n].  We
-- could do this in a later optimisation pass, but that would involve
-- a separate analysis and we already have the information to hand
-- here.  It helps clean up some extra stack stores in common cases.
--
-- Note that we may have to modify the StackMap as we walk through the
-- code using procMiddle, since an assignment to a variable in the
-- StackMap will invalidate its mapping there.
--
elimStackStores :: StackMap
                -> BlockEnv StackMap
                -> (Area -> ByteOff)
                -> [CmmNode O O]
                -> [CmmNode O O]
elimStackStores stackmap stackmaps area_off nodes
  = go stackmap nodes
  where
    go _stackmap [] = []
    go stackmap (n:ns)
     = case n of
         CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))
            | Just (_,off) <- lookupUFM (sm_regs stackmap) r
            , area_off area + m == off
Jan Stolarek's avatar
Jan Stolarek committed
908
            -> go stackmap ns
Simon Marlow's avatar
Simon Marlow committed
909 910 911 912
         _otherwise
            -> n : go (procMiddle stackmaps n stackmap) ns


913 914 915 916
-- -----------------------------------------------------------------------------
-- Update info tables to include stack liveness


917
setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl
918 919
setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
  = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
920
  where
921 922 923
    fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
       info_tbl { cit_rep = StackRep (get_liveness lbl) }
    fix_info _ other = other
924 925 926 927

    get_liveness :: BlockId -> Liveness
    get_liveness lbl
      = case mapLookup lbl stackmaps of
928
          Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)
929
          Just sm -> stackMapToLiveness dflags sm
930

931
setInfoTableStackMap _ _ d = d
932 933


934 935
stackMapToLiveness :: DynFlags -> StackMap -> Liveness
stackMapToLiveness dflags StackMap{..} =
936
   reverse $ Array.elems $
937 938
        accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,
                                     toWords dflags (sm_sp - sm_args)) live_words
939
   where
940
     live_words =  [ (toWords dflags off, False)
941 942 943
                   | (r,off) <- eltsUFM sm_regs, isGcPtrType (localRegType r) ]


944 945 946 947
-- -----------------------------------------------------------------------------
-- Lowering safe foreign calls

{-
Jan Stolarek's avatar
Jan Stolarek committed
948
Note [Lower safe foreign calls]
949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970

We start with

   Sp[young(L1)] = L1
 ,-----------------------
 | r1 = foo(x,y,z) returns to L1
 '-----------------------
 L1:
   R1 = r1 -- copyIn, inserted by mkSafeCall
   ...

the stack layout algorithm will arrange to save and reload everything
live across the call.  Our job now is to expand the call so we get

   Sp[young(L1)] = L1
 ,-----------------------
 | SAVE_THREAD_STATE()
 | token = suspendThread(BaseReg, interruptible)
 | r = foo(x,y,z)
 | BaseReg = resumeThread(token)
 | LOAD_THREAD_STATE()
 | R1 = r  -- copyOut
971
 | jump Sp[0]
972 973 974 975 976 977
 '-----------------------
 L1:
   r = R1 -- copyIn, inserted by mkSafeCall
   ...

Note the copyOut, which saves the results in the places that L1 is
Jan Stolarek's avatar
Jan Stolarek committed
978 979
expecting them (see Note {safe foreign call convention]). Note also
that safe foreign call is replace by an unsafe one in the Cmm graph.
980 981
-}

982 983
lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall dflags block
984 985
  | (entry, middle, CmmForeignCall { .. }) <- blockSplit block
  = do
986 987
    -- Both 'id' and 'new_base' are KindNonPtr because they're
    -- RTS-only objects and are not subject to garbage collection
988 989
    id <- newTemp (bWord dflags)
    new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))
990
    let (caller_save, caller_load) = callerSaveVolatileRegs dflags
991
    load_tso <- newTemp (gcWord dflags)
992
    load_stack <- newTemp (gcWord dflags)
993
    let suspend = saveThreadState dflags <*>
994
                  caller_save <*>
995
                  mkMiddle (callSuspendThread dflags id intrbl)
996 997 998 999 1000 1001
        midCall = mkUnsafeCall tgt res args
        resume  = mkMiddle (callResumeThread new_base id) <*>
                  -- Assign the result to BaseReg: we
                  -- might now have a different Capability!
                  mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
                  caller_load <*>
1002
                  loadThreadState dflags load_tso load_stack
1003

1004 1005 1006 1007
        (_, regs, copyout) =
             copyOutOflow dflags NativeReturn Jump (Young succ)
                            (map (CmmReg . CmmLocal) res)
                            ret_off []
1008

1009 1010 1011 1012 1013
        -- NB. after resumeThread returns, the top-of-stack probably contains
        -- the stack frame for succ, but it might not: if the current thread
        -- received an exception during the call, then the stack might be
        -- different.  Hence we continue by jumping to the top stack frame,
        -- not by jumping to succ.
Simon Marlow's avatar
Simon Marlow committed
1014 1015
        jump = CmmCall { cml_target    = entryCode dflags $
                                         CmmLoad (CmmReg spReg) (bWord dflags)
1016 1017
                       , cml_cont      = Just succ
                       , cml_args_regs = regs
1018
                       , cml_args      = widthInBytes (wordWidth dflags)
1019
                       , cml_ret_args  = ret_args
1020
                       , cml_ret_off   = ret_off }
1021 1022 1023 1024 1025 1026 1027 1028

    graph' <- lgraphOfAGraph $ suspend <*>
                               midCall <*>
                               resume  <*>
                               copyout <*>
                               mkLast jump

    case toBlockList graph' of
1029 1030
      [one] -> let (_, middle', last) = blockSplit one
               in return (blockJoin entry (middle `blockAppend` middle') last)
1031 1032
      _ -> panic "lowerSafeForeignCall0"

1033 1034
  -- Block doesn't end in a safe foreign call:
  | otherwise = return block
1035 1036 1037


foreignLbl :: FastString -> CmmExpr
1038
foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
1039 1040 1041 1042

newTemp :: CmmType -> UniqSM LocalReg
newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)

1043 1044
callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
callSuspendThread dflags id intrbl =
1045 1046
  CmmUnsafeForeignCall
       (ForeignTarget (foreignLbl (fsLit "suspendThread"))
1047
        (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
1048
       [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)]
1049 1050 1051 1052 1053

callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread new_base id =
  CmmUnsafeForeignCall
       (ForeignTarget (foreignLbl (fsLit "resumeThread"))
1054
            (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))
1055 1056
       [new_base] [CmmReg (CmmLocal id)]

Simon Marlow's avatar
Simon Marlow committed
1057 1058
-- -----------------------------------------------------------------------------

1059 1060
plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff
plusW dflags b w = b + w * wORD_SIZE dflags
Simon Marlow's avatar
Simon Marlow committed
1061

1062 1063 1064 1065 1066 1067 1068
data StackSlot = Occupied | Empty
     -- Occupied: a return address or part of an update frame

instance Outputable StackSlot where
  ppr Occupied = ptext (sLit "XXX")
  ppr Empty    = ptext (sLit "---")

Simon Marlow's avatar
Simon Marlow committed
1069 1070 1071
dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty 0 ss           = Just ss
dropEmpty n (Empty : ss) = dropEmpty (n-1) ss