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

6 7
import GhcPrelude hiding ((<*>))

8 9
import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs, newTemp  ) -- XXX layering violation
import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation
10

11
import BasicTypes
12 13 14 15 16 17
import GHC.Cmm
import GHC.Cmm.Info
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.Utils
import GHC.Cmm.Graph
18
import ForeignCall
19 20 21 22 23 24 25 26
import GHC.Cmm.Liveness
import GHC.Cmm.ProcPoint
import GHC.Runtime.Layout
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
Simon Marlow's avatar
Simon Marlow committed
27 28 29 30 31
import UniqSupply
import Maybes
import UniqFM
import Util

32
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
33
import FastString
34
import Outputable hiding ( isEmpty )
Simon Marlow's avatar
Simon Marlow committed
35 36 37
import qualified Data.Set as Set
import Control.Monad.Fix
import Data.Array as Array
38
import Data.Bits
David Eichmann's avatar
David Eichmann committed
39
import Data.List (nub)
Simon Marlow's avatar
Simon Marlow committed
40

41
{- Note [Stack Layout]
Simon Marlow's avatar
Simon Marlow committed
42

43 44 45 46 47 48 49
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
50
 - save any variables that are live across a call, and reload them as
51 52 53 54 55 56 57 58 59 60 61 62 63
   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.

64 65 66 67 68
We proceed in two passes, see Note [Two pass approach] for why they are not easy
to merge into one.

Pass 1:

69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
 - 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.

89 90 91 92
    - If this block is a proc point (or a call continuation, if we aren't
      splitting proc points), we need to reload all the live variables from the
      stack - but this is done in Pass 2, which calculates more precise liveness
      information (see description of Pass 2).
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 126 127 128

    - 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.)

129 130 131 132 133 134 135 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 164 165 166 167 168 169 170 171 172 173 174
  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.

Pass 2:

- Calculate live registers, but taking into account that nothing is live at the
  entry to a proc point.

- At each proc point and call continuation insert reloads of live registers from
  the stack (they were saved by Pass 1).


Note [Two pass approach]

The main reason for Pass 2 is being able to insert only the reloads that are
needed and the fact that the two passes need different liveness information.
Let's consider an example:

  .....
   \ /
    D   <- proc point
   / \
  E   F
   \ /
    G   <- proc point
    |
    X

Pass 1 needs liveness assuming that local variables are preserved across calls.
This is important because it needs to save any local registers to the stack
(e.g., if register a is used in block X, it must be saved before any native
call).
However, for Pass 2, where we want to reload registers from stack (in a proc
point), this is overly conservative and would lead us to generate reloads in D
for things used in X, even though we're going to generate reloads in G anyway
(since it's also a proc point).
So Pass 2 calculates liveness knowing that nothing is live at the entry to a
proc point. This means that in D we only need to reload things used in E or F.
This can be quite important, for an extreme example see testcase for #3294.

Merging the two passes is not trivial - Pass 2 is a backward rewrite and Pass 1
is a forward one. Furthermore, Pass 1 is creating code that uses local registers
(saving them before a call), which the liveness analysis for Pass 2 must see to
be correct.
175 176

-}
Simon Marlow's avatar
Simon Marlow committed
177 178 179 180 181 182 183 184 185 186


-- 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

187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214
{-
 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
215 216 217 218 219 220 221 222
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.
223 224 225
 ,  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
226 227 228 229 230 231 232 233 234
 ,  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 $$
235
     text "sm_regs = " <> pprUFM sm_regs ppr
Simon Marlow's avatar
Simon Marlow committed
236 237


238
cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
239
               -> UniqSM (CmmGraph, LabelMap StackMap)
240
cmmLayoutStack dflags procpoints entry_args
241
               graph@(CmmGraph { g_entry = entry })
Simon Marlow's avatar
Simon Marlow committed
242
  = do
Jan Stolarek's avatar
Jan Stolarek committed
243 244
    -- We need liveness info. Dead assignments are removed later
    -- by the sinking pass.
245
    let liveness = cmmLocalLiveness dflags graph
246
        blocks = revPostorder graph
Simon Marlow's avatar
Simon Marlow committed
247

248
    (final_stackmaps, _final_high_sp, new_blocks) <-
Simon Marlow's avatar
Simon Marlow committed
249
          mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
250
            layout dflags procpoints liveness entry entry_args
Simon Marlow's avatar
Simon Marlow committed
251 252
                   rec_stackmaps rec_high_sp blocks

253 254 255
    blocks_with_reloads <-
        insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks
    new_blocks' <- mapM (lowerSafeForeignCall dflags) blocks_with_reloads
256
    return (ofBlockList entry new_blocks', final_stackmaps)
Simon Marlow's avatar
Simon Marlow committed
257

258 259 260
-- -----------------------------------------------------------------------------
-- Pass 1
-- -----------------------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
261

262
layout :: DynFlags
263 264
       -> LabelSet                      -- proc points
       -> LabelMap CmmLocalLive         -- liveness
Simon Marlow's avatar
Simon Marlow committed
265 266 267
       -> BlockId                       -- entry
       -> ByteOff                       -- stack args on entry

268
       -> LabelMap StackMap             -- [final] stack maps
Simon Marlow's avatar
Simon Marlow committed
269 270 271 272 273
       -> ByteOff                       -- [final] Sp high water mark

       -> [CmmBlock]                    -- [in] blocks

       -> UniqSM
274
          ( LabelMap StackMap           -- [out] stack maps
Simon Marlow's avatar
Simon Marlow committed
275 276 277 278
          , ByteOff                     -- [out] Sp high water mark
          , [CmmBlock]                  -- [out] new blocks
          )

279
layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks
Simon Marlow's avatar
Simon Marlow committed
280 281 282 283 284 285 286 287 288 289 290 291 292 293 294
  = 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
Peter Wortmann's avatar
Peter Wortmann committed
295
       let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0
Jan Stolarek's avatar
Jan Stolarek committed
296

Simon Marlow's avatar
Simon Marlow committed
297 298 299 300
       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
301

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

306
       -- (b) Look at the last node and if we are making a call or
Simon Marlow's avatar
Simon Marlow committed
307 308 309 310
       --     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.
311
       (middle1, sp_off, last1, fixup_blocks, out)
312
           <- handleLastNode dflags procpoints liveness cont_info
Peter Wortmann's avatar
Peter Wortmann committed
313
                             acc_stackmaps stack1 tscope middle0 last0
Jan Stolarek's avatar
Jan Stolarek committed
314

315
       -- (c) Manifest Sp: run over the nodes in the block and replace
Simon Marlow's avatar
Simon Marlow committed
316 317
       --     CmmStackSlot with CmmLoad from Sp with a concrete offset.
       --
318
       -- our block:
319 320
       --    middle0          -- the original middle nodes
       --    middle1          -- live variable saves from handleLastNode
321 322 323
       --    Sp = Sp + sp_off -- Sp adjustment goes here
       --    last1            -- the last node
       --
324
       let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1
325

326 327 328
       let final_blocks =
               manifestSp dflags final_stackmaps stack0 sp0 final_sp_high
                          entry0 middle_pre sp_off last1 fixup_blocks
329

330
       let acc_stackmaps' = mapUnion acc_stackmaps out
331

332 333 334 335 336 337 338 339 340 341 342
           -- 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))
343

344
       go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)
345 346


347 348 349 350 351 352 353 354
-- -----------------------------------------------------------------------------

-- 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
355
-- -----------------------------------------------------------------------------
356

Simon Marlow's avatar
Simon Marlow committed
357 358 359 360 361 362 363 364 365 366 367
-- 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.

368
collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff)
Simon Marlow's avatar
Simon Marlow committed
369 370 371 372 373
collectContInfo blocks
  = (maximum ret_offs, mapFromList (catMaybes mb_argss))
 where
  (mb_argss, ret_offs) = mapAndUnzip get_cont blocks

374
  get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)
Simon Marlow's avatar
Simon Marlow committed
375 376 377 378 379
  get_cont b =
     case lastNode b of
        CmmCall { cml_cont = Just l, .. }
           -> (Just (l, cml_ret_args), cml_ret_off)
        CmmForeignCall { .. }
380
           -> (Just (succ, ret_args), ret_off)
Simon Marlow's avatar
Simon Marlow committed
381 382 383
        _other -> (Nothing, 0)


Simon Marlow's avatar
Simon Marlow committed
384 385
-- -----------------------------------------------------------------------------
-- Updating the StackMap from middle nodes
Simon Marlow's avatar
Simon Marlow committed
386

Simon Marlow's avatar
Simon Marlow committed
387
-- Look for loads from stack slots, and update the StackMap.  This is
388
-- purely for optimisation reasons, so that we can avoid saving a
Simon Marlow's avatar
Simon Marlow committed
389 390 391 392 393 394 395
-- 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.
--
396
procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
Simon Marlow's avatar
Simon Marlow committed
397 398
procMiddle stackmaps node sm
  = case node of
399
     CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)
Simon Marlow's avatar
Simon Marlow committed
400 401 402 403 404 405 406
       -> 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

407
getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc
Simon Marlow's avatar
Simon Marlow committed
408 409 410 411 412 413
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
414

Simon Marlow's avatar
Simon Marlow committed
415 416 417
-- -----------------------------------------------------------------------------
-- Handling stack allocation for a last node

418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433
-- 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
434
handleLastNode
435 436
   :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff
   -> LabelMap StackMap -> StackMap -> CmmTickScope
Simon Marlow's avatar
Simon Marlow committed
437
   -> Block CmmNode O O
Simon Marlow's avatar
Simon Marlow committed
438 439
   -> CmmNode O C
   -> UniqSM
440 441
      ( [CmmNode O O]      -- nodes to go *before* the Sp adjustment
      , ByteOff            -- amount to adjust Sp
Simon Marlow's avatar
Simon Marlow committed
442 443
      , CmmNode O C        -- new last node
      , [CmmBlock]         -- new blocks
444
      , LabelMap StackMap  -- stackmaps for the continuations
Simon Marlow's avatar
Simon Marlow committed
445 446
      )

447
handleLastNode dflags procpoints liveness cont_info stackmaps
Peter Wortmann's avatar
Peter Wortmann committed
448
               stack0@StackMap { sm_sp = sp0 } tscp middle last
Simon Marlow's avatar
Simon Marlow committed
449 450 451 452 453 454
 = 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
455
      return ([], sp_off, last, [], mapEmpty)
Simon Marlow's avatar
Simon Marlow committed
456 457

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

461
    CmmForeignCall{ succ = cont_lbl, .. } -> do
462 463
       return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off
            -- one word of args: the return address
464

Simon Peyton Jones's avatar
Simon Peyton Jones committed
465 466 467
    CmmBranch {}     ->  handleBranches
    CmmCondBranch {} ->  handleBranches
    CmmSwitch {}     ->  handleBranches
468 469

  where
Simon Marlow's avatar
Simon Marlow committed
470 471 472 473 474 475
     -- Calls and ForeignCalls are handled the same way:
     lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff
              -> ( [CmmNode O O]
                 , ByteOff
                 , CmmNode O C
                 , [CmmBlock]
476
                 , LabelMap StackMap
Simon Marlow's avatar
Simon Marlow committed
477 478 479 480 481 482
                 )
     lastCall lbl cml_args cml_ret_args cml_ret_off
      =  ( assignments
         , spOffsetForCall sp0 cont_stack cml_args
         , last
         , [] -- no new blocks
483
         , mapSingleton lbl cont_stack )
Simon Marlow's avatar
Simon Marlow committed
484
      where
485 486 487 488 489 490 491 492 493 494 495 496 497
         (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)
498
           = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0
499 500


501
     -- For other last nodes (branches), if any of the targets is a
Simon Marlow's avatar
Simon Marlow committed
502 503 504
     -- proc point, we have to set up the stack to match what the proc
     -- point is expecting.
     --
505
     handleBranches :: UniqSM ( [CmmNode O O]
Simon Marlow's avatar
Simon Marlow committed
506 507
                                , ByteOff
                                , CmmNode O C
508
                                , [CmmBlock]
509
                                , LabelMap StackMap )
Simon Marlow's avatar
Simon Marlow committed
510

511
     handleBranches
512 513
         -- Note [diamond proc point]
       | Just l <- futureContinuation middle
Simon Marlow's avatar
Simon Marlow committed
514
       , (nub $ filter (`setMember` procpoints) $ successors last) == [l]
515 516 517 518 519 520
       = 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
521
                , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)
522 523 524
                , last
                , []
                , out)
Simon Marlow's avatar
Simon Marlow committed
525

Simon Marlow's avatar
Simon Marlow committed
526
        | otherwise = do
527
          pps <- mapM handleBranch (successors last)
Simon Marlow's avatar
Simon Marlow committed
528 529
          let lbl_map :: LabelMap Label
              lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]
530
              fix_lbl l = mapFindWithDefault l l lbl_map
Simon Marlow's avatar
Simon Marlow committed
531 532 533
          return ( []
                 , 0
                 , mapSuccessors fix_lbl last
534 535
                 , concat [ blk | (_,_,_,blk) <- pps ]
                 , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )
Simon Marlow's avatar
Simon Marlow committed
536

537 538 539 540 541 542 543 544 545
     -- 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
Peter Wortmann's avatar
Peter Wortmann committed
546
             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
547 548 549 550 551 552 553 554
             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) =
555
                      setupStackFrame dflags l liveness (sm_ret_off stack0)
Jan Stolarek's avatar
Jan Stolarek committed
556
                                                        cont_args stack0
Peter Wortmann's avatar
Peter Wortmann committed
557
             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
558 559 560 561 562 563 564 565 566 567 568 569 570
             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


Peter Wortmann's avatar
Peter Wortmann committed
571 572
makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap
               -> CmmTickScope -> [CmmNode O O]
573
               -> UniqSM (Label, [CmmBlock])
Peter Wortmann's avatar
Peter Wortmann committed
574
makeFixupBlock dflags sp0 l stack tscope assigs
575 576
  | null assigs && sp0 == sm_sp stack = return (l, [])
  | otherwise = do
577
    tmp_lbl <- newBlockId
578
    let sp_off = sp0 - sm_sp stack
Peter Wortmann's avatar
Peter Wortmann committed
579
        block = blockJoin (CmmEntry tmp_lbl tscope)
580
                          ( maybeAddSpAdj dflags sp0 sp_off
581
                           $ blockFromList assigs )
582 583
                          (CmmBranch l)
    return (tmp_lbl, [block])
Simon Marlow's avatar
Simon Marlow committed
584 585 586 587 588 589 590 591 592 593


-- 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
594 595 596 597 598 599 600


-- | 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
601
     old_map  = sm_regs old_stack
Simon Marlow's avatar
Simon Marlow committed
602 603 604
     new_locs = stackSlotRegs new_stack

     move (r,n)
Simon Marlow's avatar
Simon Marlow committed
605
       | Just (_,m) <- lookupUFM old_map r, n == m = []
Simon Marlow's avatar
Simon Marlow committed
606 607 608
       | otherwise = [CmmStore (CmmStackSlot Old n)
                               (CmmReg (CmmLocal r))]

Simon Marlow's avatar
Simon Marlow committed
609 610 611


setupStackFrame
612 613
             :: DynFlags
             -> BlockId                 -- label of continuation
614
             -> LabelMap CmmLocalLive   -- liveness
Simon Marlow's avatar
Simon Marlow committed
615 616 617 618 619
             -> ByteOff      -- updfr
             -> ByteOff      -- bytes of return values on stack
             -> StackMap     -- current StackMap
             -> (StackMap, [CmmNode O O])

620
setupStackFrame dflags lbl liveness updfr_off ret_args stack0
Simon Marlow's avatar
Simon Marlow committed
621
  = (cont_stack, assignments)
Simon Marlow's avatar
Simon Marlow committed
622 623 624 625 626 627 628 629 630 631 632 633 634 635
  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
636
      (stack1, assignments) = allocate dflags updfr_off live stack0
Simon Marlow's avatar
Simon Marlow committed
637 638 639 640 641 642 643 644 645

      -- 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
                         }


646 647 648 649 650 651
-- -----------------------------------------------------------------------------
-- 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
652 653
--    Sp[young(L1)] = L1
--    if (R1 & 7) != 0 goto L1 else goto L2
654
--  L2:
Simon Marlow's avatar
Simon Marlow committed
655
--    call [R1] returns to L1
656
--  L1: live: {y}
Simon Marlow's avatar
Simon Marlow committed
657
--    x = R1
658 659 660
--
-- If we let the generic case handle this, we get
--
Simon Marlow's avatar
Simon Marlow committed
661 662
--    Sp[-16] = L1
--    if (R1 & 7) != 0 goto L1a else goto L2
663
--  L2:
Simon Marlow's avatar
Simon Marlow committed
664 665 666
--    Sp[-8] = y
--    Sp = Sp - 16
--    call [R1] returns to L1
667
--  L1a:
Simon Marlow's avatar
Simon Marlow committed
668 669 670
--    Sp[-8] = y
--    Sp = Sp - 16
--    goto L1
671
--  L1:
Simon Marlow's avatar
Simon Marlow committed
672
--    x = R1
673 674
--
-- The code for saving the live vars is duplicated in each branch, and
Simon Marlow's avatar
Simon Marlow committed
675 676 677 678 679 680
-- 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
681
--
Simon Marlow's avatar
Simon Marlow committed
682
--   Sp[young(L)] = L
Jan Stolarek's avatar
Jan Stolarek committed
683
--
Simon Marlow's avatar
Simon Marlow committed
684 685 686 687 688 689 690 691
-- 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
692 693 694 695 696
--
--   (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
697 698
-- then we allocate the stack frame for L at the end of the block,
-- before the branch.
699 700 701 702 703 704
--
-- 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
705 706
   where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
         f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _
707 708 709 710 711 712 713 714 715 716
               = 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.
--
717
allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
718 719 720
         -> (StackMap, [CmmNode O O])
allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
                                              , sm_regs = regs0 }
721 722 723 724 725 726 727 728
 =
   -- 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 $
729
               accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $
730 731 732
                 ret_words ++ live_words
            where ret_words =
                   [ (x, Occupied)
733
                   | x <- [ 1 .. toWords dflags ret_off] ]
734
                  live_words =
735
                   [ (toWords dflags x, Occupied)
736 737
                   | (r,off) <- nonDetEltsUFM regs1,
                   -- See Note [Unique Determinism and code generation]
738 739
                     let w = localRegBytes dflags r,
                     x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]
740 741 742 743 744 745
   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
746
          = ([], slot:stack, plusW dflags n 1, assigs, regs)
747 748
       save slot (to_save, stack, n, assigs, regs)
          = case slot of
749
               Occupied ->  (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)
750 751 752 753 754
               Empty
                 | Just (stack', r, to_save') <-
                       select_save to_save (slot:stack)
                 -> let assig = CmmStore (CmmStackSlot Old n')
                                         (CmmReg (CmmLocal r))
755
                        n' = plusW dflags n 1
756 757 758 759
                   in
                        (to_save', stack', n', assig : assigs, (r,(r,n')):regs)

                 | otherwise
760
                 -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)
761 762 763 764 765 766 767 768 769 770 771 772

       -- 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)
773
                 where words = localRegWords dflags r
774 775 776 777 778 779 780 781 782 783 784 785

       -- 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
786
                  n' = n + localRegBytes dflags r
787 788 789 790 791 792
                  assig = CmmStore (CmmStackSlot Old n')
                                   (CmmReg (CmmLocal r))

       trim_sp
          | not (null push_regs) = push_sp
          | otherwise
793
          = plusW dflags n (- length (takeWhile isEmpty save_stack))
794 795 796 797 798 799 800 801

       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

802
   if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
803 804 805 806 807

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


Simon Marlow's avatar
Simon Marlow committed
808
-- -----------------------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
809
-- Manifesting Sp
Simon Marlow's avatar
Simon Marlow committed
810

Simon Marlow's avatar
Simon Marlow committed
811 812 813 814 815 816 817 818 819 820 821 822 823
-- | 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
824
   :: DynFlags
825
   -> LabelMap StackMap  -- StackMaps for other blocks
Simon Marlow's avatar
Simon Marlow committed
826 827 828 829 830 831 832 833 834 835
   -> 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

836
manifestSp dflags stackmaps stack0 sp0 sp_high
Simon Marlow's avatar
Simon Marlow committed
837 838 839 840 841 842
           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
843 844
    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
845

846
    final_middle = maybeAddSpAdj dflags sp0 sp_off
847 848 849 850
                 . blockFromList
                 . map adj_pre_sp
                 . elimStackStores stack0 stackmaps area_off
                 $ middle_pre
Simon Marlow's avatar
Simon Marlow committed
851 852 853 854
    final_last    = optStackCheck (adj_post_sp last)

    final_block   = blockJoin first final_middle final_last

855
    fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks
Simon Marlow's avatar
Simon Marlow committed
856

857
getAreaOff :: LabelMap StackMap -> (Area -> StackLoc)
Simon Marlow's avatar
Simon Marlow committed
858 859 860 861 862 863 864
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)


865 866 867 868
maybeAddSpAdj
  :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj dflags sp0 sp_off block =
  add_initial_unwind $ add_adj_unwind $ adj block
869
  where
870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891
    adj block
      | sp_off /= 0
      = block `blockSnoc` CmmAssign spReg (cmmOffset dflags spExpr sp_off)
      | otherwise = block
    -- Add unwind pseudo-instruction at the beginning of each block to
    -- document Sp level for debugging
    add_initial_unwind block
      | debugLevel dflags > 0
      = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block
      | otherwise
      = block
      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags)

    -- Add unwind pseudo-instruction right after the Sp adjustment
    -- if there is one.
    add_adj_unwind block
      | debugLevel dflags > 0
      , sp_off /= 0
      = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]
      | otherwise
      = block
      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off)
Simon Marlow's avatar
Simon Marlow committed
892

893 894
{- Note [SP old/young offsets]

Simon Marlow's avatar
Simon Marlow committed
895 896 897 898 899 900
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.

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

904
 - in block L, each reference to [young(L') + N] turns into
Simon Marlow's avatar
Simon Marlow committed
905 906 907 908 909 910
   [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')
-}

911
areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
912 913

areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)
914
  = cmmOffset dflags spExpr (sp_old - area_off area - n)
915 916
    -- Replace (CmmStackSlot area n) with an offset from Sp

917
areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)
918
  = mkIntExpr dflags sp_hwm
919
    -- Replace CmmHighStackMark with the number of bytes of stack used,
920
    -- the sp_hwm.   See Note [Stack usage] in GHC.StgToCmm.Heap
921

922 923
areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)
  | falseStackCheck args
924
  = zeroExpr dflags
925 926 927
areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args)
  | falseStackCheck args
  = mkIntExpr dflags 1
928 929 930
    -- Replace a stack-overflow test that cannot fail with a no-op
    -- See Note [Always false stack check]

931
areaToSp _ _ _ _ other = other
Simon Marlow's avatar
Simon Marlow committed
932

933 934 935 936 937 938 939 940 941
-- | Determine whether a stack check cannot fail.
falseStackCheck :: [CmmExpr] -> Bool
falseStackCheck [ CmmMachOp (MO_Sub _)
                      [ CmmRegOff (CmmGlobal Sp) x_off
                      , CmmLit (CmmInt y_lit _)]
                , CmmReg (CmmGlobal SpLim)]
  = fromIntegral x_off >= y_lit
falseStackCheck _ = False

942 943 944
-- Note [Always false stack check]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- We can optimise stack checks of the form
945
--
946
--   if ((Sp + x) - y < SpLim) then .. else ..
947
--
948 949 950 951 952 953
-- 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.
954 955 956 957 958 959
--
-- The control flow optimiser may negate a conditional to increase
-- the likelihood of a fallthrough if the branch is not taken.  But
-- not every conditional is inverted as the control flow optimiser
-- places some requirements on the predecessors of both branch targets.
-- So we better look for the inverted comparison too.
960 961

optStackCheck :: CmmNode O C -> CmmNode O C
Simon Marlow's avatar
Simon Marlow committed
962
optStackCheck n = -- Note [Always false stack check]
963
 case n of
964
   CmmCondBranch (CmmLit (CmmInt 0 _)) _true false _ -> CmmBranch false
965
   CmmCondBranch (CmmLit (CmmInt _ _)) true _false _ -> CmmBranch true
966 967
   other -> other

Simon Marlow's avatar
Simon Marlow committed
968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984

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

-- | 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
985
                -> LabelMap StackMap
Simon Marlow's avatar
Simon Marlow committed
986 987 988 989 990 991 992 993 994 995 996 997
                -> (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
998
            -> go stackmap ns
Simon Marlow's avatar
Simon Marlow committed
999 1000 1001 1002
         _otherwise
            -> n : go (procMiddle stackmaps n stackmap) ns


1003 1004 1005 1006
-- -----------------------------------------------------------------------------
-- Update info tables to include stack liveness


1007
setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl
1008 1009
setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
  = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
1010
  where
1011 1012 1013
    fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
       info_tbl { cit_rep = StackRep (get_liveness lbl) }
    fix_info _ other = other
1014 1015 1016 1017

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

1021
setInfoTableStackMap _ _ d = d
1022 1023


1024 1025
stackMapToLiveness :: DynFlags -> StackMap -> Liveness
stackMapToLiveness dflags StackMap{..} =
1026
   reverse $ Array.elems $
1027 1028
        accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,
                                     toWords dflags (sm_sp - sm_args)) live_words
1029
   where
1030
     live_words =  [ (toWords dflags off, False)
1031 1032 1033
                   | (r,off) <- nonDetEltsUFM sm_regs
                   , isGcPtrType (localRegType r) ]
                   -- See Note [Unique Determinism and code generation]
1034

1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083
-- -----------------------------------------------------------------------------
-- Pass 2
-- -----------------------------------------------------------------------------

insertReloadsAsNeeded
    :: DynFlags
    -> ProcPointSet
    -> LabelMap StackMap
    -> BlockId
    -> [CmmBlock]
    -> UniqSM [CmmBlock]
insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do
    toBlockList . fst <$>
        rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty
  where
    rewriteCC :: RewriteFun CmmLocalLive
    rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do
        let entry_label = entryLabel e_node
            stackmap = case mapLookup entry_label final_stackmaps of
                Just sm -> sm
                Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap"

            -- Merge the liveness from successor blocks and analyse the last
            -- node.
            joined = gen_kill dflags x_node $!
                         joinOutFacts liveLattice x_node fact_base0
            -- What is live at the start of middle0.
            live_at_middle0 = foldNodesBwdOO (gen_kill dflags) middle0 joined

            -- If this is a procpoint we need to add the reloads, but only if
            -- they're actually live. Furthermore, nothing is live at the entry
            -- to a proc point.
            (middle1, live_with_reloads)
                | entry_label `setMember` procpoints
                = let reloads = insertReloads dflags stackmap live_at_middle0
                  in (foldr blockCons middle0 reloads, emptyRegSet)
                | otherwise
                = (middle0, live_at_middle0)

            -- Final liveness for this block.
            !fact_base2 = mapSingleton entry_label live_with_reloads

        return (BlockCC e_node middle1 x_node, fact_base2)

insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads dflags stackmap live =
     [ CmmAssign (CmmLocal reg)
                 -- This cmmOffset basically corresponds to manifesting
                 -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]
1084
                 (CmmLoad (cmmOffset dflags spExpr (sp_off - reg_off))
1085 1086 1087 1088 1089 1090
                          (localRegType reg))
     | (reg, reg_off) <- stackSlotRegs stackmap
     , reg `elemRegSet` live
     ]
   where
     sp_off = sm_sp stackmap
1091

1092 1093 1094 1095
-- -----------------------------------------------------------------------------
-- Lowering safe foreign calls

{-
Jan Stolarek's avatar
Jan Stolarek committed
1096
Note [Lower safe foreign calls]
1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118

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
1119
 | jump Sp[0]
1120 1121 1122 1123 1124 1125
 '-----------------------
 L1:
   r = R1 -- copyIn, inserted by mkSafeCall
   ...

Note the copyOut, which saves the results in the places that L1 is
Gabor Greif's avatar
Gabor Greif committed
1126
expecting them (see Note [safe foreign call convention]). Note also
Jan Stolarek's avatar
Jan Stolarek committed
1127
that safe foreign call is replace by an unsafe one in the Cmm graph.
1128 1129
-}

1130 1131
lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall dflags block
Peter Wortmann's avatar
Peter Wortmann committed
1132
  | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
1133
  = do
1134 1135
    -- Both 'id' and 'new_base' are KindNonPtr because they're
    -- RTS-only objects and are not subject to garbage collection
1136
    id <- newTemp (bWord dflags)
1137
    new_base <- newTemp (cmmRegType dflags baseReg)
1138
    let (caller_save, caller_load) = callerSaveVolatileRegs dflags
1139 1140 1141
    save_state_code <- saveThreadState dflags
    load_state_code <- loadThreadState dflags
    let suspend = save_state_code  <*>
1142
                  caller_save <*>
1143
                  mkMiddle (callSuspendThread dflags id intrbl)
1144 1145 1146 1147
        midCall = mkUnsafeCall tgt res args
        resume  = mkMiddle (callResumeThread new_base id) <*>
                  -- Assign the result to BaseReg: we
                  -- might now have a different Capability!
1148
                  mkAssign baseReg (CmmReg (CmmLocal new_base)) <*>
1149
                  caller_load <*>
1150
                  load_state_code
1151

1152 1153
        (_, regs, copyout) =
             copyOutOflow dflags NativeReturn Jump (Young succ)
1154
                            (map (CmmReg . CmmLocal) res)
1155
                            ret_off []
1156

1157 1158 1159 1160 1161
        -- 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
1162
        jump = CmmCall { cml_target    = entryCode dflags $
1163
                                         CmmLoad spExpr (bWord dflags)
1164 1165
                       , cml_cont      = Just succ
                       , cml_args_regs = regs
1166
                       , cml_args      = widthInBytes (wordWidth dflags)
1167
                       , cml_ret_args  = ret_args
1168
                       , cml_ret_off   = ret_off }
1169

Peter Wortmann's avatar
Peter Wortmann committed
1170
    graph' <- lgraphOfAGraph ( suspend <*>
1171 1172 1173
                               midCall <*>
                               resume  <*>
                               copyout <*>
Peter Wortmann's avatar
Peter Wortmann committed
1174
                               mkLast jump, tscp)
1175 1176

    case toBlockList graph' of
1177 1178
      [one] -> let (_, middle', last) = blockSplit one
               in return (blockJoin entry (middle `blockAppend` middle') last)
1179 1180
      _ -> panic "lowerSafeForeignCall0"

1181 1182
  -- Block doesn't end in a safe foreign call:
  | otherwise = return block
1183 1184 1185


foreignLbl :: FastString -> CmmExpr
1186
foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
1187

1188 1189
callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
callSuspendThread dflags id intrbl =
1190 1191
  CmmUnsafeForeignCall
       (ForeignTarget (foreignLbl (fsLit "suspendThread"))
1192
        (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
1193
       [id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)]
1194 1195 1196 1197 1198

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

Simon Marlow's avatar
Simon Marlow committed
1202 1203
-- -----------------------------------------------------------------------------

1204 1205
plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff
plusW dflags b w = b + w * wORD_SIZE dflags
Simon Marlow's avatar
Simon Marlow committed
1206

1207 1208 1209 1210
data StackSlot = Occupied | Empty
     -- Occupied: a return address or part of an update frame

instance Outputable StackSlot where
1211 1212
  ppr Occupied = text "XXX"
  ppr Empty    = text "---"
1213

Simon Marlow's avatar
Simon Marlow committed
1214 1215 1216
dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty 0 ss           = Just ss
dropEmpty n (Empty : ss) = dropEmpty (n-1) ss
1217
dropEmpty _ _            = Nothing
Simon Marlow's avatar
Simon Marlow committed
1218

1219 1220 1221
isEmpty :: StackSlot -> Bool
isEmpty Empty = True
isEmpty _ = False
Simon Marlow's avatar
Simon Marlow committed
1222

1223 1224 1225
localRegBytes :: DynFlags -> LocalReg -> ByteOff
localRegBytes dflags r
    = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))
Simon Marlow's avatar
Simon Marlow committed
1226

1227 1228
localRegWords :: DynFlags -> LocalReg -> WordOff
localRegWords dflags = toWords dflags . localRegBytes dflags
Simon Marlow's avatar
Simon Marlow committed
1229

1230 1231
toWords :: DynFlags -> ByteOff -> WordOff
toWords dflags x = x `quot` wORD_SIZE dflags
Simon Marlow's avatar
Simon Marlow committed
1232 1233 1234


stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
1235 1236
stackSlotRegs sm = nonDetEltsUFM (sm_regs sm)
  -- See Note [Unique Determinism and code generation]