{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}
module CmmLayoutStack (
       cmmLayoutStack, setInfoTableStackMap
  ) where

import GhcPrelude hiding ((<*>))

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

import BasicTypes
import Cmm
import CmmInfo
import BlockId
import CLabel
import CmmUtils
import MkGraph
import ForeignCall
import CmmLive
import CmmProcPoint
import SMRep
import Hoopl.Block
import Hoopl.Collections
import Hoopl.Dataflow
import Hoopl.Graph
import Hoopl.Label
import UniqSupply
import Maybes
import UniqFM
import Util

import DynFlags
import FastString
import Outputable hiding ( isEmpty )
import qualified Data.Set as Set
import Control.Monad.Fix
import Data.Array as Array
import Data.Bits
import Data.List (nub)

{- Note [Stack Layout]

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.

 - save any variables that are live across a call, and reload them as
   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.

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

Pass 1:

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

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

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.

-}


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

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

data StackMap = StackMap
 {  StackMap -> StackLoc
sm_sp   :: StackLoc
       -- ^ the offset of Sp relative to the base on entry
       -- to this block.
 ,  StackMap -> StackLoc
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.
 ,  StackMap -> StackLoc
sm_ret_off :: ByteOff
       -- ^ Number of words of stack that we do not describe with an info
       -- table, because it contains an update frame.
 ,  StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs :: UniqFM (LocalReg,StackLoc)
       -- ^ regs on the stack
 }

instance Outputable StackMap where
  ppr :: StackMap -> SDoc
ppr StackMap{StackLoc
UniqFM (LocalReg, StackLoc)
sm_regs :: UniqFM (LocalReg, StackLoc)
sm_ret_off :: StackLoc
sm_args :: StackLoc
sm_sp :: StackLoc
sm_regs :: StackMap -> UniqFM (LocalReg, StackLoc)
sm_ret_off :: StackMap -> StackLoc
sm_args :: StackMap -> StackLoc
sm_sp :: StackMap -> StackLoc
..} =
     String -> SDoc
text String
"Sp = " SDoc -> SDoc -> SDoc
<> StackLoc -> SDoc
int StackLoc
sm_sp SDoc -> SDoc -> SDoc
$$
     String -> SDoc
text String
"sm_args = " SDoc -> SDoc -> SDoc
<> StackLoc -> SDoc
int StackLoc
sm_args SDoc -> SDoc -> SDoc
$$
     String -> SDoc
text String
"sm_ret_off = " SDoc -> SDoc -> SDoc
<> StackLoc -> SDoc
int StackLoc
sm_ret_off SDoc -> SDoc -> SDoc
$$
     String -> SDoc
text String
"sm_regs = " SDoc -> SDoc -> SDoc
<> UniqFM (LocalReg, StackLoc)
-> ([(LocalReg, StackLoc)] -> SDoc) -> SDoc
forall a. UniqFM a -> ([a] -> SDoc) -> SDoc
pprUFM UniqFM (LocalReg, StackLoc)
sm_regs [(LocalReg, StackLoc)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr


cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
               -> UniqSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack :: DynFlags
-> ProcPointSet
-> StackLoc
-> CmmGraph
-> UniqSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack DynFlags
dflags ProcPointSet
procpoints StackLoc
entry_args
               graph :: CmmGraph
graph@(CmmGraph { g_entry :: forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry = BlockId
entry })
  = do
    -- We need liveness info. Dead assignments are removed later
    -- by the sinking pass.
    let liveness :: BlockEntryLiveness LocalReg
liveness = DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg
cmmLocalLiveness DynFlags
dflags CmmGraph
graph
        blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
revPostorder CmmGraph
graph

    (LabelMap StackMap
final_stackmaps, StackLoc
_final_high_sp, [CmmBlock]
new_blocks) <-
          ((LabelMap StackMap, StackLoc, [CmmBlock])
 -> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock]))
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (((LabelMap StackMap, StackLoc, [CmmBlock])
  -> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock]))
 -> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock]))
-> ((LabelMap StackMap, StackLoc, [CmmBlock])
    -> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock]))
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
forall a b. (a -> b) -> a -> b
$ \ ~(LabelMap StackMap
rec_stackmaps, StackLoc
rec_high_sp, [CmmBlock]
_new_blocks) ->
            DynFlags
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> BlockId
-> StackLoc
-> LabelMap StackMap
-> StackLoc
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
layout DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness BlockId
entry StackLoc
entry_args
                   LabelMap StackMap
rec_stackmaps StackLoc
rec_high_sp [CmmBlock]
blocks

    [CmmBlock]
blocks_with_reloads <-
        DynFlags
-> ProcPointSet
-> LabelMap StackMap
-> BlockId
-> [CmmBlock]
-> UniqSM [CmmBlock]
insertReloadsAsNeeded DynFlags
dflags ProcPointSet
procpoints LabelMap StackMap
final_stackmaps BlockId
entry [CmmBlock]
new_blocks
    [CmmBlock]
new_blocks' <- (CmmBlock -> UniqSM CmmBlock) -> [CmmBlock] -> UniqSM [CmmBlock]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall DynFlags
dflags) [CmmBlock]
blocks_with_reloads
    (CmmGraph, LabelMap StackMap)
-> UniqSM (CmmGraph, LabelMap StackMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> [CmmBlock] -> CmmGraph
ofBlockList BlockId
entry [CmmBlock]
new_blocks', LabelMap StackMap
final_stackmaps)

-- -----------------------------------------------------------------------------
-- Pass 1
-- -----------------------------------------------------------------------------

layout :: DynFlags
       -> LabelSet                      -- proc points
       -> LabelMap CmmLocalLive         -- liveness
       -> BlockId                       -- entry
       -> ByteOff                       -- stack args on entry

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

       -> [CmmBlock]                    -- [in] blocks

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

layout :: DynFlags
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> BlockId
-> StackLoc
-> LabelMap StackMap
-> StackLoc
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
layout DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness BlockId
entry StackLoc
entry_args LabelMap StackMap
final_stackmaps StackLoc
final_sp_high [CmmBlock]
blocks
  = [CmmBlock]
-> LabelMap StackMap
-> StackLoc
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
go [CmmBlock]
blocks LabelMap StackMap
init_stackmap StackLoc
entry_args []
  where
    (StackLoc
updfr, LabelMap StackLoc
cont_info)  = [CmmBlock] -> (StackLoc, LabelMap StackLoc)
collectContInfo [CmmBlock]
blocks

    init_stackmap :: LabelMap StackMap
init_stackmap = KeyOf LabelMap -> StackMap -> LabelMap StackMap
forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton KeyOf LabelMap
BlockId
entry StackMap :: StackLoc
-> StackLoc -> StackLoc -> UniqFM (LocalReg, StackLoc) -> StackMap
StackMap{ sm_sp :: StackLoc
sm_sp   = StackLoc
entry_args
                                               , sm_args :: StackLoc
sm_args = StackLoc
entry_args
                                               , sm_ret_off :: StackLoc
sm_ret_off = StackLoc
updfr
                                               , sm_regs :: UniqFM (LocalReg, StackLoc)
sm_regs = UniqFM (LocalReg, StackLoc)
forall elt. UniqFM elt
emptyUFM
                                               }

    go :: [CmmBlock]
-> LabelMap StackMap
-> StackLoc
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
go [] LabelMap StackMap
acc_stackmaps StackLoc
acc_hwm [CmmBlock]
acc_blocks
      = (LabelMap StackMap, StackLoc, [CmmBlock])
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelMap StackMap
acc_stackmaps, StackLoc
acc_hwm, [CmmBlock]
acc_blocks)

    go (CmmBlock
b0 : [CmmBlock]
bs) LabelMap StackMap
acc_stackmaps StackLoc
acc_hwm [CmmBlock]
acc_blocks
      = do
       let (entry0 :: CmmNode C O
entry0@(CmmEntry BlockId
entry_lbl CmmTickScope
tscope), Block CmmNode O O
middle0, CmmNode O C
last0) = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
b0

       let stack0 :: StackMap
stack0@StackMap { sm_sp :: StackMap -> StackLoc
sm_sp = StackLoc
sp0 }
               = StackMap -> KeyOf LabelMap -> LabelMap StackMap -> StackMap
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault
                     (String -> SDoc -> StackMap
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"no stack map for" (BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
entry_lbl))
                     KeyOf LabelMap
BlockId
entry_lbl LabelMap StackMap
acc_stackmaps

       -- (a) Update the stack map to include the effects of
       --     assignments in this block
       let stack1 :: IndexedCO O StackMap StackMap
stack1 = (forall (e :: Extensibility) (x :: Extensibility).
 CmmNode e x -> StackMap -> StackMap)
-> Block CmmNode O O
-> IndexedCO O StackMap StackMap
-> IndexedCO O StackMap StackMap
forall (n :: Extensibility -> Extensibility -> *) a.
(forall (e :: Extensibility) (x :: Extensibility). n e x -> a -> a)
-> forall (e :: Extensibility) (x :: Extensibility).
   Block n e x -> IndexedCO e a a -> IndexedCO x a a
foldBlockNodesF (LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
forall (e :: Extensibility) (x :: Extensibility).
LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle LabelMap StackMap
acc_stackmaps) Block CmmNode O O
middle0 IndexedCO O StackMap StackMap
StackMap
stack0

       -- (b) 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.
       ([CmmNode O O]
middle1, StackLoc
sp_off, CmmNode O C
last1, [CmmBlock]
fixup_blocks, LabelMap StackMap
out)
           <- DynFlags
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> LabelMap StackLoc
-> LabelMap StackMap
-> StackMap
-> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqSM
     ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
      LabelMap StackMap)
handleLastNode DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness LabelMap StackLoc
cont_info
                             LabelMap StackMap
acc_stackmaps IndexedCO O StackMap StackMap
StackMap
stack1 CmmTickScope
tscope Block CmmNode O O
middle0 CmmNode O C
last0

       -- (c) Manifest Sp: run over the nodes in the block and replace
       --     CmmStackSlot with CmmLoad from Sp with a concrete offset.
       --
       -- our block:
       --    middle0          -- the original middle nodes
       --    middle1          -- live variable saves from handleLastNode
       --    Sp = Sp + sp_off -- Sp adjustment goes here
       --    last1            -- the last node
       --
       let middle_pre :: [CmmNode O O]
middle_pre = Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList (Block CmmNode O O -> [CmmNode O O])
-> Block CmmNode O O -> [CmmNode O O]
forall a b. (a -> b) -> a -> b
$ (Block CmmNode O O -> CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> [CmmNode O O] -> Block CmmNode O O
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Block CmmNode O O -> CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O O -> Block n e O
blockSnoc Block CmmNode O O
middle0 [CmmNode O O]
middle1

       let final_blocks :: [CmmBlock]
final_blocks =
               DynFlags
-> LabelMap StackMap
-> StackMap
-> StackLoc
-> StackLoc
-> CmmNode C O
-> [CmmNode O O]
-> StackLoc
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp DynFlags
dflags LabelMap StackMap
final_stackmaps StackMap
stack0 StackLoc
sp0 StackLoc
final_sp_high
                          CmmNode C O
entry0 [CmmNode O O]
middle_pre StackLoc
sp_off CmmNode O C
last1 [CmmBlock]
fixup_blocks

       let acc_stackmaps' :: LabelMap StackMap
acc_stackmaps' = LabelMap StackMap -> LabelMap StackMap -> LabelMap StackMap
forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
mapUnion LabelMap StackMap
acc_stackmaps LabelMap StackMap
out

           -- 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 :: StackLoc
this_sp_hwm | CmmNode O C -> Bool
isGcJump CmmNode O C
last0 = StackLoc
0
                       | Bool
otherwise      = StackLoc
sp0 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
sp_off

           hwm' :: StackLoc
hwm' = [StackLoc] -> StackLoc
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (StackLoc
acc_hwm StackLoc -> [StackLoc] -> [StackLoc]
forall a. a -> [a] -> [a]
: StackLoc
this_sp_hwm StackLoc -> [StackLoc] -> [StackLoc]
forall a. a -> [a] -> [a]
: (StackMap -> StackLoc) -> [StackMap] -> [StackLoc]
forall a b. (a -> b) -> [a] -> [b]
map StackMap -> StackLoc
sm_sp (LabelMap StackMap -> [StackMap]
forall (map :: * -> *) a. IsMap map => map a -> [a]
mapElems LabelMap StackMap
out))

       [CmmBlock]
-> LabelMap StackMap
-> StackLoc
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
go [CmmBlock]
bs LabelMap StackMap
acc_stackmaps' StackLoc
hwm' ([CmmBlock]
final_blocks [CmmBlock] -> [CmmBlock] -> [CmmBlock]
forall a. [a] -> [a] -> [a]
++ [CmmBlock]
acc_blocks)


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

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

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

-- 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, LabelMap ByteOff)
collectContInfo :: [CmmBlock] -> (StackLoc, LabelMap StackLoc)
collectContInfo [CmmBlock]
blocks
  = ([StackLoc] -> StackLoc
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [StackLoc]
ret_offs, [(KeyOf LabelMap, StackLoc)] -> LabelMap StackLoc
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([Maybe (BlockId, StackLoc)] -> [(BlockId, StackLoc)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (BlockId, StackLoc)]
mb_argss))
 where
  ([Maybe (BlockId, StackLoc)]
mb_argss, [StackLoc]
ret_offs) = (CmmBlock -> (Maybe (BlockId, StackLoc), StackLoc))
-> [CmmBlock] -> ([Maybe (BlockId, StackLoc)], [StackLoc])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip CmmBlock -> (Maybe (BlockId, StackLoc), StackLoc)
forall (x :: Extensibility).
Block CmmNode x C -> (Maybe (BlockId, StackLoc), StackLoc)
get_cont [CmmBlock]
blocks

  get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)
  get_cont :: Block CmmNode x C -> (Maybe (BlockId, StackLoc), StackLoc)
get_cont Block CmmNode x C
b =
     case Block CmmNode x C -> CmmNode O C
forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
Block n x C -> n O C
lastNode Block CmmNode x C
b of
        CmmCall { cml_cont :: CmmNode O C -> Maybe BlockId
cml_cont = Just BlockId
l, StackLoc
[GlobalReg]
CmmExpr
cml_ret_off :: CmmNode O C -> StackLoc
cml_ret_args :: CmmNode O C -> StackLoc
cml_args :: CmmNode O C -> StackLoc
cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_ret_off :: StackLoc
cml_ret_args :: StackLoc
cml_args :: StackLoc
cml_args_regs :: [GlobalReg]
cml_target :: CmmExpr
cml_target :: CmmNode O C -> CmmExpr
.. }
           -> ((BlockId, StackLoc) -> Maybe (BlockId, StackLoc)
forall a. a -> Maybe a
Just (BlockId
l, StackLoc
cml_ret_args), StackLoc
cml_ret_off)
        CmmForeignCall { Bool
StackLoc
[LocalReg]
[CmmExpr]
BlockId
ForeignTarget
intrbl :: CmmNode O C -> Bool
ret_off :: CmmNode O C -> StackLoc
ret_args :: CmmNode O C -> StackLoc
succ :: CmmNode O C -> BlockId
args :: CmmNode O C -> [CmmExpr]
res :: CmmNode O C -> [LocalReg]
tgt :: CmmNode O C -> ForeignTarget
intrbl :: Bool
ret_off :: StackLoc
ret_args :: StackLoc
succ :: BlockId
args :: [CmmExpr]
res :: [LocalReg]
tgt :: ForeignTarget
.. }
           -> ((BlockId, StackLoc) -> Maybe (BlockId, StackLoc)
forall a. a -> Maybe a
Just (BlockId
succ, StackLoc
ret_args), StackLoc
ret_off)
        CmmNode O C
_other -> (Maybe (BlockId, StackLoc)
forall a. Maybe a
Nothing, StackLoc
0)


-- -----------------------------------------------------------------------------
-- Updating the StackMap from middle nodes

-- Look for loads from stack slots, and update the StackMap.  This is
-- purely for optimisation reasons, so that we can avoid saving a
-- 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.
--
procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle LabelMap StackMap
stackmaps CmmNode e x
node StackMap
sm
  = case CmmNode e x
node of
     CmmAssign (CmmLocal LocalReg
r) (CmmLoad (CmmStackSlot Area
area StackLoc
off) CmmType
_)
       -> StackMap
sm { sm_regs :: UniqFM (LocalReg, StackLoc)
sm_regs = UniqFM (LocalReg, StackLoc)
-> LocalReg -> (LocalReg, StackLoc) -> UniqFM (LocalReg, StackLoc)
forall key elt.
Uniquable key =>
UniqFM elt -> key -> elt -> UniqFM elt
addToUFM (StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs StackMap
sm) LocalReg
r (LocalReg
r,StackLoc
loc) }
        where loc :: StackLoc
loc = Area -> StackLoc -> LabelMap StackMap -> StackLoc
getStackLoc Area
area StackLoc
off LabelMap StackMap
stackmaps
     CmmAssign (CmmLocal LocalReg
r) CmmExpr
_other
       -> StackMap
sm { sm_regs :: UniqFM (LocalReg, StackLoc)
sm_regs = UniqFM (LocalReg, StackLoc)
-> LocalReg -> UniqFM (LocalReg, StackLoc)
forall key elt. Uniquable key => UniqFM elt -> key -> UniqFM elt
delFromUFM (StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs StackMap
sm) LocalReg
r }
     CmmNode e x
_other
       -> StackMap
sm

getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc
getStackLoc :: Area -> StackLoc -> LabelMap StackMap -> StackLoc
getStackLoc Area
Old       StackLoc
n LabelMap StackMap
_         = StackLoc
n
getStackLoc (Young BlockId
l) StackLoc
n LabelMap StackMap
stackmaps =
  case KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
l LabelMap StackMap
stackmaps of
    Maybe StackMap
Nothing -> String -> SDoc -> StackLoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getStackLoc" (BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
l)
    Just StackMap
sm -> StackMap -> StackLoc
sm_sp StackMap
sm StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackMap -> StackLoc
sm_args StackMap
sm StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
n


-- -----------------------------------------------------------------------------
-- Handling stack allocation for a last node

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

handleLastNode
   :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff
   -> LabelMap StackMap -> StackMap -> CmmTickScope
   -> Block CmmNode O O
   -> CmmNode O C
   -> UniqSM
      ( [CmmNode O O]      -- nodes to go *before* the Sp adjustment
      , ByteOff            -- amount to adjust Sp
      , CmmNode O C        -- new last node
      , [CmmBlock]         -- new blocks
      , LabelMap StackMap  -- stackmaps for the continuations
      )

handleLastNode :: DynFlags
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> LabelMap StackLoc
-> LabelMap StackMap
-> StackMap
-> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqSM
     ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
      LabelMap StackMap)
handleLastNode DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness LabelMap StackLoc
cont_info LabelMap StackMap
stackmaps
               stack0 :: StackMap
stack0@StackMap { sm_sp :: StackMap -> StackLoc
sm_sp = StackLoc
sp0 } CmmTickScope
tscp Block CmmNode O O
middle CmmNode O C
last
 = case CmmNode O C
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 :: CmmNode O C -> Maybe BlockId
cml_cont = Maybe BlockId
Nothing, StackLoc
[GlobalReg]
CmmExpr
cml_ret_off :: StackLoc
cml_ret_args :: StackLoc
cml_args :: StackLoc
cml_args_regs :: [GlobalReg]
cml_target :: CmmExpr
cml_ret_off :: CmmNode O C -> StackLoc
cml_ret_args :: CmmNode O C -> StackLoc
cml_args :: CmmNode O C -> StackLoc
cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_target :: CmmNode O C -> CmmExpr
.. } -> do
      let sp_off :: StackLoc
sp_off = StackLoc
sp0 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
cml_args
      ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
 LabelMap StackMap)
-> UniqSM
     ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
      LabelMap StackMap)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], StackLoc
sp_off, CmmNode O C
last, [], LabelMap StackMap
forall (map :: * -> *) a. IsMap map => map a
mapEmpty)

    --  At each CmmCall with a continuation:
    CmmCall{ cml_cont :: CmmNode O C -> Maybe BlockId
cml_cont = Just BlockId
cont_lbl, StackLoc
[GlobalReg]
CmmExpr
cml_ret_off :: StackLoc
cml_ret_args :: StackLoc
cml_args :: StackLoc
cml_args_regs :: [GlobalReg]
cml_target :: CmmExpr
cml_ret_off :: CmmNode O C -> StackLoc
cml_ret_args :: CmmNode O C -> StackLoc
cml_args :: CmmNode O C -> StackLoc
cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_target :: CmmNode O C -> CmmExpr
.. } ->
       ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
 LabelMap StackMap)
-> UniqSM
     ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
      LabelMap StackMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
  LabelMap StackMap)
 -> UniqSM
      ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
       LabelMap StackMap))
-> ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
    LabelMap StackMap)
-> UniqSM
     ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
      LabelMap StackMap)
forall a b. (a -> b) -> a -> b
$ BlockId
-> StackLoc
-> StackLoc
-> StackLoc
-> ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
    LabelMap StackMap)
lastCall BlockId
cont_lbl StackLoc
cml_args StackLoc
cml_ret_args StackLoc
cml_ret_off

    CmmForeignCall{ succ :: CmmNode O C -> BlockId
succ = BlockId
cont_lbl, Bool
StackLoc
[LocalReg]
[CmmExpr]
ForeignTarget
intrbl :: Bool
ret_off :: StackLoc
ret_args :: StackLoc
args :: [CmmExpr]
res :: [LocalReg]
tgt :: ForeignTarget
intrbl :: CmmNode O C -> Bool
ret_off :: CmmNode O C -> StackLoc
ret_args :: CmmNode O C -> StackLoc
args :: CmmNode O C -> [CmmExpr]
res :: CmmNode O C -> [LocalReg]
tgt :: CmmNode O C -> ForeignTarget
.. } -> do
       ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
 LabelMap StackMap)
-> UniqSM
     ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
      LabelMap StackMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
  LabelMap StackMap)
 -> UniqSM
      ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
       LabelMap StackMap))
-> ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
    LabelMap StackMap)
-> UniqSM
     ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
      LabelMap StackMap)
forall a b. (a -> b) -> a -> b
$ BlockId
-> StackLoc
-> StackLoc
-> StackLoc
-> ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
    LabelMap StackMap)
lastCall BlockId
cont_lbl (DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags) StackLoc
ret_args StackLoc
ret_off
            -- one word of args: the return address

    CmmBranch {}     ->  UniqSM
  ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
   LabelMap StackMap)
handleBranches
    CmmCondBranch {} ->  UniqSM
  ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
   LabelMap StackMap)
handleBranches
    CmmSwitch {}     ->  UniqSM
  ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
   LabelMap StackMap)
handleBranches

  where
     -- Calls and ForeignCalls are handled the same way:
     lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff
              -> ( [CmmNode O O]
                 , ByteOff
                 , CmmNode O C
                 , [CmmBlock]
                 , LabelMap StackMap
                 )
     lastCall :: BlockId
-> StackLoc
-> StackLoc
-> StackLoc
-> ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
    LabelMap StackMap)
lastCall BlockId
lbl StackLoc
cml_args StackLoc
cml_ret_args StackLoc
cml_ret_off
      =  ( [CmmNode O O]
assignments
         , StackLoc -> StackMap -> StackLoc -> StackLoc
spOffsetForCall StackLoc
sp0 StackMap
cont_stack StackLoc
cml_args
         , CmmNode O C
last
         , [] -- no new blocks
         , KeyOf LabelMap -> StackMap -> LabelMap StackMap
forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton KeyOf LabelMap
BlockId
lbl StackMap
cont_stack )
      where
         ([CmmNode O O]
assignments, StackMap
cont_stack) = BlockId -> StackLoc -> StackLoc -> ([CmmNode O O], StackMap)
prepareStack BlockId
lbl StackLoc
cml_ret_args StackLoc
cml_ret_off


     prepareStack :: BlockId -> StackLoc -> StackLoc -> ([CmmNode O O], StackMap)
prepareStack BlockId
lbl StackLoc
cml_ret_args StackLoc
cml_ret_off
       | Just StackMap
cont_stack <- KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
lbl LabelMap StackMap
stackmaps
             -- If we have already seen this continuation before, then
             -- we just have to make the stack look the same:
       = (StackMap -> StackMap -> [CmmNode O O]
fixupStack StackMap
stack0 StackMap
cont_stack, StackMap
cont_stack)
             -- Otherwise, we have to allocate the stack frame
       | Bool
otherwise
       = ([CmmNode O O]
save_assignments, StackMap
new_cont_stack)
       where
        (StackMap
new_cont_stack, [CmmNode O O]
save_assignments)
           = DynFlags
-> BlockId
-> BlockEntryLiveness LocalReg
-> StackLoc
-> StackLoc
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame DynFlags
dflags BlockId
lbl BlockEntryLiveness LocalReg
liveness StackLoc
cml_ret_off StackLoc
cml_ret_args StackMap
stack0


     -- For other last nodes (branches), if any of the targets is a
     -- proc point, we have to set up the stack to match what the proc
     -- point is expecting.
     --
     handleBranches :: UniqSM ( [CmmNode O O]
                                , ByteOff
                                , CmmNode O C
                                , [CmmBlock]
                                , LabelMap StackMap )

     handleBranches :: UniqSM
  ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
   LabelMap StackMap)
handleBranches
         -- Note [diamond proc point]
       | Just BlockId
l <- Block CmmNode O O -> Maybe BlockId
futureContinuation Block CmmNode O O
middle
       , ([BlockId] -> [BlockId]
forall a. Eq a => [a] -> [a]
nub ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ (BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (ElemOf ProcPointSet -> ProcPointSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints) ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ CmmNode O C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last) [BlockId] -> [BlockId] -> Bool
forall a. Eq a => a -> a -> Bool
== [BlockId
l]
       = do
         let cont_args :: StackLoc
cont_args = StackLoc -> KeyOf LabelMap -> LabelMap StackLoc -> StackLoc
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault StackLoc
0 KeyOf LabelMap
BlockId
l LabelMap StackLoc
cont_info
             ([CmmNode O O]
assigs, StackMap
cont_stack) = BlockId -> StackLoc -> StackLoc -> ([CmmNode O O], StackMap)
prepareStack BlockId
l StackLoc
cont_args (StackMap -> StackLoc
sm_ret_off StackMap
stack0)
             out :: LabelMap StackMap
out = [(KeyOf LabelMap, StackMap)] -> LabelMap StackMap
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (KeyOf LabelMap
BlockId
l', StackMap
cont_stack)
                               | BlockId
l' <- CmmNode O C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last ]
         ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
 LabelMap StackMap)
-> UniqSM
     ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
      LabelMap StackMap)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [CmmNode O O]
assigs
                , StackLoc -> StackMap -> StackLoc -> StackLoc
spOffsetForCall StackLoc
sp0 StackMap
cont_stack (DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags)
                , CmmNode O C
last
                , []
                , LabelMap StackMap
out)

        | Bool
otherwise = do
          [(BlockId, BlockId, StackMap, [CmmBlock])]
pps <- (BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock]))
-> [BlockId] -> UniqSM [(BlockId, BlockId, StackMap, [CmmBlock])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
handleBranch (CmmNode O C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last)
          let lbl_map :: LabelMap Label
              lbl_map :: LabelMap BlockId
lbl_map = [(KeyOf LabelMap, BlockId)] -> LabelMap BlockId
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (KeyOf LabelMap
BlockId
l,BlockId
tmp) | (BlockId
l,BlockId
tmp,StackMap
_,[CmmBlock]
_) <- [(BlockId, BlockId, StackMap, [CmmBlock])]
pps ]
              fix_lbl :: BlockId -> BlockId
fix_lbl BlockId
l = BlockId -> KeyOf LabelMap -> LabelMap BlockId -> BlockId
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault BlockId
l KeyOf LabelMap
BlockId
l LabelMap BlockId
lbl_map
          ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
 LabelMap StackMap)
-> UniqSM
     ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
      LabelMap StackMap)
forall (m :: * -> *) a. Monad m => a -> m a
return ( []
                 , StackLoc
0
                 , (BlockId -> BlockId) -> CmmNode O C -> CmmNode O C
mapSuccessors BlockId -> BlockId
fix_lbl CmmNode O C
last
                 , [[CmmBlock]] -> [CmmBlock]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [CmmBlock]
blk | (BlockId
_,BlockId
_,StackMap
_,[CmmBlock]
blk) <- [(BlockId, BlockId, StackMap, [CmmBlock])]
pps ]
                 , [(KeyOf LabelMap, StackMap)] -> LabelMap StackMap
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (KeyOf LabelMap
BlockId
l, StackMap
sm) | (BlockId
l,BlockId
_,StackMap
sm,[CmmBlock]
_) <- [(BlockId, BlockId, StackMap, [CmmBlock])]
pps ] )

     -- For each successor of this block
     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
handleBranch BlockId
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 StackMap
stack2 <- KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
l LabelMap StackMap
stackmaps
        = do
             let assigs :: [CmmNode O O]
assigs = StackMap -> StackMap -> [CmmNode O O]
fixupStack StackMap
stack0 StackMap
stack2
             (BlockId
tmp_lbl, [CmmBlock]
block) <- DynFlags
-> StackLoc
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags StackLoc
sp0 BlockId
l StackMap
stack2 CmmTickScope
tscp [CmmNode O O]
assigs
             (BlockId, BlockId, StackMap, [CmmBlock])
-> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
tmp_lbl, StackMap
stack2, [CmmBlock]
block)

        --   (b) if the successor is a proc point, save everything
        --       on the stack.
        | ElemOf ProcPointSet
BlockId
l ElemOf ProcPointSet -> ProcPointSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints
        = do
             let cont_args :: StackLoc
cont_args = StackLoc -> KeyOf LabelMap -> LabelMap StackLoc -> StackLoc
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault StackLoc
0 KeyOf LabelMap
BlockId
l LabelMap StackLoc
cont_info
                 (StackMap
stack2, [CmmNode O O]
assigs) =
                      DynFlags
-> BlockId
-> BlockEntryLiveness LocalReg
-> StackLoc
-> StackLoc
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame DynFlags
dflags BlockId
l BlockEntryLiveness LocalReg
liveness (StackMap -> StackLoc
sm_ret_off StackMap
stack0)
                                                        StackLoc
cont_args StackMap
stack0
             (BlockId
tmp_lbl, [CmmBlock]
block) <- DynFlags
-> StackLoc
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags StackLoc
sp0 BlockId
l StackMap
stack2 CmmTickScope
tscp [CmmNode O O]
assigs
             (BlockId, BlockId, StackMap, [CmmBlock])
-> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
tmp_lbl, StackMap
stack2, [CmmBlock]
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.
        | Bool
otherwise = (BlockId, BlockId, StackMap, [CmmBlock])
-> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
l, StackMap
stack1, [])
        where live :: CmmLocalLive
live = CmmLocalLive
-> KeyOf LabelMap -> BlockEntryLiveness LocalReg -> CmmLocalLive
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault (String -> CmmLocalLive
forall a. String -> a
panic String
"handleBranch") KeyOf LabelMap
BlockId
l BlockEntryLiveness LocalReg
liveness
              stack1 :: StackMap
stack1 = StackMap
stack0 { sm_regs :: UniqFM (LocalReg, StackLoc)
sm_regs = ((LocalReg, StackLoc) -> Bool)
-> UniqFM (LocalReg, StackLoc) -> UniqFM (LocalReg, StackLoc)
forall elt. (elt -> Bool) -> UniqFM elt -> UniqFM elt
filterUFM (LocalReg, StackLoc) -> Bool
is_live (StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs StackMap
stack0) }
              is_live :: (LocalReg, StackLoc) -> Bool
is_live (LocalReg
r,StackLoc
_) = LocalReg
r LocalReg -> CmmLocalLive -> Bool
forall r. Ord r => r -> RegSet r -> Bool
`elemRegSet` CmmLocalLive
live


makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap
               -> CmmTickScope -> [CmmNode O O]
               -> UniqSM (Label, [CmmBlock])
makeFixupBlock :: DynFlags
-> StackLoc
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags StackLoc
sp0 BlockId
l StackMap
stack CmmTickScope
tscope [CmmNode O O]
assigs
  | [CmmNode O O] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CmmNode O O]
assigs Bool -> Bool -> Bool
&& StackLoc
sp0 StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
== StackMap -> StackLoc
sm_sp StackMap
stack = (BlockId, [CmmBlock]) -> UniqSM (BlockId, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, [])
  | Bool
otherwise = do
    BlockId
tmp_lbl <- UniqSM BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
    let sp_off :: StackLoc
sp_off = StackLoc
sp0 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackMap -> StackLoc
sm_sp StackMap
stack
        block :: CmmBlock
block = CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *).
n C O -> Block n O O -> n O C -> Block n C C
blockJoin (BlockId -> CmmTickScope -> CmmNode C O
CmmEntry BlockId
tmp_lbl CmmTickScope
tscope)
                          ( DynFlags
-> StackLoc -> StackLoc -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj DynFlags
dflags StackLoc
sp0 StackLoc
sp_off
                           (Block CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> Block CmmNode O O
forall a b. (a -> b) -> a -> b
$ [CmmNode O O] -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *).
[n O O] -> Block n O O
blockFromList [CmmNode O O]
assigs )
                          (BlockId -> CmmNode O C
CmmBranch BlockId
l)
    (BlockId, [CmmBlock]) -> UniqSM (BlockId, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
tmp_lbl, [CmmBlock
block])


-- 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 :: StackLoc -> StackMap -> StackLoc -> StackLoc
spOffsetForCall StackLoc
current_sp StackMap
cont_stack StackLoc
args
  = StackLoc
current_sp StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- (StackMap -> StackLoc
sm_sp StackMap
cont_stack StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackMap -> StackLoc
sm_args StackMap
cont_stack StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
args)


-- | create a sequence of assignments to establish the new StackMap,
-- given the old StackMap.
fixupStack :: StackMap -> StackMap -> [CmmNode O O]
fixupStack :: StackMap -> StackMap -> [CmmNode O O]
fixupStack StackMap
old_stack StackMap
new_stack = ((LocalReg, StackLoc) -> [CmmNode O O])
-> [(LocalReg, StackLoc)] -> [CmmNode O O]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LocalReg, StackLoc) -> [CmmNode O O]
move [(LocalReg, StackLoc)]
new_locs
 where
     old_map :: UniqFM (LocalReg, StackLoc)
old_map  = StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs StackMap
old_stack
     new_locs :: [(LocalReg, StackLoc)]
new_locs = StackMap -> [(LocalReg, StackLoc)]
stackSlotRegs StackMap
new_stack

     move :: (LocalReg, StackLoc) -> [CmmNode O O]
move (LocalReg
r,StackLoc
n)
       | Just (LocalReg
_,StackLoc
m) <- UniqFM (LocalReg, StackLoc)
-> LocalReg -> Maybe (LocalReg, StackLoc)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM (LocalReg, StackLoc)
old_map LocalReg
r, StackLoc
n StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
== StackLoc
m = []
       | Bool
otherwise = [CmmExpr -> CmmExpr -> CmmNode O O
CmmStore (Area -> StackLoc -> CmmExpr
CmmStackSlot Area
Old StackLoc
n)
                               (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
r))]



setupStackFrame
             :: DynFlags
             -> BlockId                 -- label of continuation
             -> LabelMap CmmLocalLive   -- liveness
             -> ByteOff      -- updfr
             -> ByteOff      -- bytes of return values on stack
             -> StackMap     -- current StackMap
             -> (StackMap, [CmmNode O O])

setupStackFrame :: DynFlags
-> BlockId
-> BlockEntryLiveness LocalReg
-> StackLoc
-> StackLoc
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame DynFlags
dflags BlockId
lbl BlockEntryLiveness LocalReg
liveness StackLoc
updfr_off StackLoc
ret_args StackMap
stack0
  = (StackMap
cont_stack, [CmmNode O O]
assignments)
  where
      -- get the set of LocalRegs live in the continuation
      live :: CmmLocalLive
live = CmmLocalLive
-> KeyOf LabelMap -> BlockEntryLiveness LocalReg -> CmmLocalLive
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault CmmLocalLive
forall a. Set a
Set.empty KeyOf LabelMap
BlockId
lbl BlockEntryLiveness LocalReg
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
      (StackMap
stack1, [CmmNode O O]
assignments) = DynFlags
-> StackLoc
-> CmmLocalLive
-> StackMap
-> (StackMap, [CmmNode O O])
allocate DynFlags
dflags StackLoc
updfr_off CmmLocalLive
live StackMap
stack0

      -- And the Sp at the continuation is:
      --   sm_sp stack1 + ret_args
      cont_stack :: StackMap
cont_stack = StackMap
stack1{ sm_sp :: StackLoc
sm_sp = StackMap -> StackLoc
sm_sp StackMap
stack1 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
ret_args
                         , sm_args :: StackLoc
sm_args = StackLoc
ret_args
                         , sm_ret_off :: StackLoc
sm_ret_off = StackLoc
updfr_off
                         }


-- -----------------------------------------------------------------------------
-- Note [diamond proc point]
--
-- This special case looks for the pattern we get from a typical
-- tagged case expression:
--
--    Sp[young(L1)] = L1
--    if (R1 & 7) != 0 goto L1 else goto L2
--  L2:
--    call [R1] returns to L1
--  L1: live: {y}
--    x = R1
--
-- If we let the generic case handle this, we get
--
--    Sp[-16] = L1
--    if (R1 & 7) != 0 goto L1a else goto L2
--  L2:
--    Sp[-8] = y
--    Sp = Sp - 16
--    call [R1] returns to L1
--  L1a:
--    Sp[-8] = y
--    Sp = Sp - 16
--    goto L1
--  L1:
--    x = R1
--
-- The code for saving the live vars is duplicated in each branch, and
-- 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
--
--   Sp[young(L)] = L
--
-- 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
--
--   (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.
--
-- then we allocate the stack frame for L at the end of the block,
-- before the branch.
--
-- 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 :: Block CmmNode O O -> Maybe BlockId
futureContinuation Block CmmNode O O
middle = (forall (e :: Extensibility) (x :: Extensibility).
 CmmNode e x -> Maybe BlockId -> Maybe BlockId)
-> Block CmmNode O O
-> IndexedCO O (Maybe BlockId) (Maybe BlockId)
-> IndexedCO O (Maybe BlockId) (Maybe BlockId)
forall (n :: Extensibility -> Extensibility -> *) a.
(forall (e :: Extensibility) (x :: Extensibility). n e x -> a -> a)
-> forall (e :: Extensibility) (x :: Extensibility).
   Block n e x -> IndexedCO x a a -> IndexedCO e a a
foldBlockNodesB forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Maybe BlockId -> Maybe BlockId
f Block CmmNode O O
middle IndexedCO O (Maybe BlockId) (Maybe BlockId)
forall a. Maybe a
Nothing
   where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
         f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
f (CmmStore (CmmStackSlot (Young BlockId
l) StackLoc
_) (CmmLit (CmmBlock BlockId
_))) Maybe BlockId
_
               = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
l
         f CmmNode a b
_ Maybe BlockId
r = Maybe BlockId
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.
--
allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
         -> (StackMap, [CmmNode O O])
allocate :: DynFlags
-> StackLoc
-> CmmLocalLive
-> StackMap
-> (StackMap, [CmmNode O O])
allocate DynFlags
dflags StackLoc
ret_off CmmLocalLive
live stackmap :: StackMap
stackmap@StackMap{ sm_sp :: StackMap -> StackLoc
sm_sp = StackLoc
sp0
                                              , sm_regs :: StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs = UniqFM (LocalReg, StackLoc)
regs0 }
 =
   -- we only have to save regs that are not already in a slot
   let to_save :: [LocalReg]
to_save = (LocalReg -> Bool) -> [LocalReg] -> [LocalReg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (LocalReg -> Bool) -> LocalReg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalReg -> UniqFM (LocalReg, StackLoc) -> Bool
forall key elt. Uniquable key => key -> UniqFM elt -> Bool
`elemUFM` UniqFM (LocalReg, StackLoc)
regs0)) (CmmLocalLive -> [LocalReg]
forall a. Set a -> [a]
Set.elems CmmLocalLive
live)
       regs1 :: UniqFM (LocalReg, StackLoc)
regs1   = ((LocalReg, StackLoc) -> Bool)
-> UniqFM (LocalReg, StackLoc) -> UniqFM (LocalReg, StackLoc)
forall elt. (elt -> Bool) -> UniqFM elt -> UniqFM elt
filterUFM (\(LocalReg
r,StackLoc
_) -> LocalReg -> CmmLocalLive -> Bool
forall r. Ord r => r -> RegSet r -> Bool
elemRegSet LocalReg
r CmmLocalLive
live) UniqFM (LocalReg, StackLoc)
regs0
   in

   -- make a map of the stack
   let stack :: [StackSlot]
stack = [StackSlot] -> [StackSlot]
forall a. [a] -> [a]
reverse ([StackSlot] -> [StackSlot]) -> [StackSlot] -> [StackSlot]
forall a b. (a -> b) -> a -> b
$ Array StackLoc StackSlot -> [StackSlot]
forall i e. Array i e -> [e]
Array.elems (Array StackLoc StackSlot -> [StackSlot])
-> Array StackLoc StackSlot -> [StackSlot]
forall a b. (a -> b) -> a -> b
$
               (StackSlot -> StackSlot -> StackSlot)
-> StackSlot
-> (StackLoc, StackLoc)
-> [(StackLoc, StackSlot)]
-> Array StackLoc StackSlot
forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray (\StackSlot
_ StackSlot
x -> StackSlot
x) StackSlot
Empty (StackLoc
1, DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags (StackLoc -> StackLoc -> StackLoc
forall a. Ord a => a -> a -> a
max StackLoc
sp0 StackLoc
ret_off)) ([(StackLoc, StackSlot)] -> Array StackLoc StackSlot)
-> [(StackLoc, StackSlot)] -> Array StackLoc StackSlot
forall a b. (a -> b) -> a -> b
$
                 [(StackLoc, StackSlot)]
ret_words [(StackLoc, StackSlot)]
-> [(StackLoc, StackSlot)] -> [(StackLoc, StackSlot)]
forall a. [a] -> [a] -> [a]
++ [(StackLoc, StackSlot)]
live_words
            where ret_words :: [(StackLoc, StackSlot)]
ret_words =
                   [ (StackLoc
x, StackSlot
Occupied)
                   | StackLoc
x <- [ StackLoc
1 .. DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags StackLoc
ret_off] ]
                  live_words :: [(StackLoc, StackSlot)]
live_words =
                   [ (DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags StackLoc
x, StackSlot
Occupied)
                   | (LocalReg
r,StackLoc
off) <- UniqFM (LocalReg, StackLoc) -> [(LocalReg, StackLoc)]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM UniqFM (LocalReg, StackLoc)
regs1,
                   -- See Note [Unique Determinism and code generation]
                     let w :: StackLoc
w = DynFlags -> LocalReg -> StackLoc
localRegBytes DynFlags
dflags LocalReg
r,
                     StackLoc
x <- [ StackLoc
off, StackLoc
off StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags .. StackLoc
off StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
w StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
1] ]
   in

   -- Pass over the stack: find slots to save all the new live variables,
   -- choosing the oldest slots first (hence a foldr).
   let
       save :: StackSlot
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
    [(LocalReg, (LocalReg, StackLoc))])
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
    [(LocalReg, (LocalReg, StackLoc))])
save StackSlot
slot ([], [StackSlot]
stack, StackLoc
n, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, StackLoc))]
regs) -- no more regs to save
          = ([], StackSlot
slotStackSlot -> [StackSlot] -> [StackSlot]
forall a. a -> [a] -> [a]
:[StackSlot]
stack, DynFlags -> StackLoc -> StackLoc -> StackLoc
plusW DynFlags
dflags StackLoc
n StackLoc
1, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, StackLoc))]
regs)
       save StackSlot
slot ([LocalReg]
to_save, [StackSlot]
stack, StackLoc
n, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, StackLoc))]
regs)
          = case StackSlot
slot of
               StackSlot
Occupied ->  ([LocalReg]
to_save, StackSlot
OccupiedStackSlot -> [StackSlot] -> [StackSlot]
forall a. a -> [a] -> [a]
:[StackSlot]
stack, DynFlags -> StackLoc -> StackLoc -> StackLoc
plusW DynFlags
dflags StackLoc
n StackLoc
1, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, StackLoc))]
regs)
               StackSlot
Empty
                 | Just ([StackSlot]
stack', LocalReg
r, [LocalReg]
to_save') <-
                       [LocalReg]
-> [StackSlot] -> Maybe ([StackSlot], LocalReg, [LocalReg])
select_save [LocalReg]
to_save (StackSlot
slotStackSlot -> [StackSlot] -> [StackSlot]
forall a. a -> [a] -> [a]
:[StackSlot]
stack)
                 -> let assig :: CmmNode O O
assig = CmmExpr -> CmmExpr -> CmmNode O O
CmmStore (Area -> StackLoc -> CmmExpr
CmmStackSlot Area
Old StackLoc
n')
                                         (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
r))
                        n' :: StackLoc
n' = DynFlags -> StackLoc -> StackLoc -> StackLoc
plusW DynFlags
dflags StackLoc
n StackLoc
1
                   in
                        ([LocalReg]
to_save', [StackSlot]
stack', StackLoc
n', CmmNode O O
assig CmmNode O O -> [CmmNode O O] -> [CmmNode O O]
forall a. a -> [a] -> [a]
: [CmmNode O O]
assigs, (LocalReg
r,(LocalReg
r,StackLoc
n'))(LocalReg, (LocalReg, StackLoc))
-> [(LocalReg, (LocalReg, StackLoc))]
-> [(LocalReg, (LocalReg, StackLoc))]
forall a. a -> [a] -> [a]
:[(LocalReg, (LocalReg, StackLoc))]
regs)

                 | Bool
otherwise
                 -> ([LocalReg]
to_save, StackSlot
slotStackSlot -> [StackSlot] -> [StackSlot]
forall a. a -> [a] -> [a]
:[StackSlot]
stack, DynFlags -> StackLoc -> StackLoc -> StackLoc
plusW DynFlags
dflags StackLoc
n StackLoc
1, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, StackLoc))]
regs)

       -- 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 :: [LocalReg]
-> [StackSlot] -> Maybe ([StackSlot], LocalReg, [LocalReg])
select_save [LocalReg]
regs [StackSlot]
stack = [LocalReg]
-> [LocalReg] -> Maybe ([StackSlot], LocalReg, [LocalReg])
go [LocalReg]
regs []
         where go :: [LocalReg]
-> [LocalReg] -> Maybe ([StackSlot], LocalReg, [LocalReg])
go []     [LocalReg]
_no_fit = Maybe ([StackSlot], LocalReg, [LocalReg])
forall a. Maybe a
Nothing
               go (LocalReg
r:[LocalReg]
rs) [LocalReg]
no_fit
                 | Just [StackSlot]
rest <- StackLoc -> [StackSlot] -> Maybe [StackSlot]
dropEmpty StackLoc
words [StackSlot]
stack
                 = ([StackSlot], LocalReg, [LocalReg])
-> Maybe ([StackSlot], LocalReg, [LocalReg])
forall a. a -> Maybe a
Just (StackLoc -> StackSlot -> [StackSlot]
forall a. StackLoc -> a -> [a]
replicate StackLoc
words StackSlot
Occupied [StackSlot] -> [StackSlot] -> [StackSlot]
forall a. [a] -> [a] -> [a]
++ [StackSlot]
rest, LocalReg
r, [LocalReg]
rs[LocalReg] -> [LocalReg] -> [LocalReg]
forall a. [a] -> [a] -> [a]
++[LocalReg]
no_fit)
                 | Bool
otherwise
                 = [LocalReg]
-> [LocalReg] -> Maybe ([StackSlot], LocalReg, [LocalReg])
go [LocalReg]
rs (LocalReg
rLocalReg -> [LocalReg] -> [LocalReg]
forall a. a -> [a] -> [a]
:[LocalReg]
no_fit)
                 where words :: StackLoc
words = DynFlags -> LocalReg -> StackLoc
localRegWords DynFlags
dflags LocalReg
r

       -- fill in empty slots as much as possible
       ([LocalReg]
still_to_save, [StackSlot]
save_stack, StackLoc
n, [CmmNode O O]
save_assigs, [(LocalReg, (LocalReg, StackLoc))]
save_regs)
          = (StackSlot
 -> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
     [(LocalReg, (LocalReg, StackLoc))])
 -> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
     [(LocalReg, (LocalReg, StackLoc))]))
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
    [(LocalReg, (LocalReg, StackLoc))])
-> [StackSlot]
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
    [(LocalReg, (LocalReg, StackLoc))])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr StackSlot
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
    [(LocalReg, (LocalReg, StackLoc))])
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
    [(LocalReg, (LocalReg, StackLoc))])
save ([LocalReg]
to_save, [], StackLoc
0, [], []) [StackSlot]
stack

       -- push any remaining live vars on the stack
       (StackLoc
push_sp, [CmmNode O O]
push_assigs, [(LocalReg, (LocalReg, StackLoc))]
push_regs)
          = (LocalReg
 -> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
 -> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))]))
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
-> [LocalReg]
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LocalReg
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
push (StackLoc
n, [], []) [LocalReg]
still_to_save
          where
              push :: LocalReg
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
push LocalReg
r (StackLoc
n, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, StackLoc))]
regs)
                = (StackLoc
n', CmmNode O O
assig CmmNode O O -> [CmmNode O O] -> [CmmNode O O]
forall a. a -> [a] -> [a]
: [CmmNode O O]
assigs, (LocalReg
r,(LocalReg
r,StackLoc
n')) (LocalReg, (LocalReg, StackLoc))
-> [(LocalReg, (LocalReg, StackLoc))]
-> [(LocalReg, (LocalReg, StackLoc))]
forall a. a -> [a] -> [a]
: [(LocalReg, (LocalReg, StackLoc))]
regs)
                where
                  n' :: StackLoc
n' = StackLoc
n StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ DynFlags -> LocalReg -> StackLoc
localRegBytes DynFlags
dflags LocalReg
r
                  assig :: CmmNode O O
assig = CmmExpr -> CmmExpr -> CmmNode O O
CmmStore (Area -> StackLoc -> CmmExpr
CmmStackSlot Area
Old StackLoc
n')
                                   (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
r))

       trim_sp :: StackLoc
trim_sp
          | Bool -> Bool
not ([(LocalReg, (LocalReg, StackLoc))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LocalReg, (LocalReg, StackLoc))]
push_regs) = StackLoc
push_sp
          | Bool
otherwise
          = DynFlags -> StackLoc -> StackLoc -> StackLoc
plusW DynFlags
dflags StackLoc
n (- [StackSlot] -> StackLoc
forall (t :: * -> *) a. Foldable t => t a -> StackLoc
length ((StackSlot -> Bool) -> [StackSlot] -> [StackSlot]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile StackSlot -> Bool
isEmpty [StackSlot]
save_stack))

       final_regs :: UniqFM (LocalReg, StackLoc)
final_regs = UniqFM (LocalReg, StackLoc)
regs1 UniqFM (LocalReg, StackLoc)
-> [(LocalReg, (LocalReg, StackLoc))]
-> UniqFM (LocalReg, StackLoc)
forall key elt.
Uniquable key =>
UniqFM elt -> [(key, elt)] -> UniqFM elt
`addListToUFM` [(LocalReg, (LocalReg, StackLoc))]
push_regs
                          UniqFM (LocalReg, StackLoc)
-> [(LocalReg, (LocalReg, StackLoc))]
-> UniqFM (LocalReg, StackLoc)
forall key elt.
Uniquable key =>
UniqFM elt -> [(key, elt)] -> UniqFM elt
`addListToUFM` [(LocalReg, (LocalReg, StackLoc))]
save_regs

   in
  -- XXX should be an assert
   if ( StackLoc
n StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
/= StackLoc -> StackLoc -> StackLoc
forall a. Ord a => a -> a -> a
max StackLoc
sp0 StackLoc
ret_off ) then String -> SDoc -> (StackMap, [CmmNode O O])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocate" (StackLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr StackLoc
n SDoc -> SDoc -> SDoc
<+> StackLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr StackLoc
sp0 SDoc -> SDoc -> SDoc
<+> StackLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr StackLoc
ret_off) else

   if (StackLoc
trim_sp StackLoc -> StackLoc -> StackLoc
forall a. Bits a => a -> a -> a
.&. (DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
1)) StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
/= StackLoc
0  then String -> SDoc -> (StackMap, [CmmNode O O])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocate2" (StackLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr StackLoc
trim_sp SDoc -> SDoc -> SDoc
<+> UniqFM (LocalReg, StackLoc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqFM (LocalReg, StackLoc)
final_regs SDoc -> SDoc -> SDoc
<+> StackLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr StackLoc
push_sp) else

   ( StackMap
stackmap { sm_regs :: UniqFM (LocalReg, StackLoc)
sm_regs = UniqFM (LocalReg, StackLoc)
final_regs , sm_sp :: StackLoc
sm_sp = StackLoc
trim_sp }
   , [CmmNode O O]
push_assigs [CmmNode O O] -> [CmmNode O O] -> [CmmNode O O]
forall a. [a] -> [a] -> [a]
++ [CmmNode O O]
save_assigs )


-- -----------------------------------------------------------------------------
-- Manifesting Sp

-- | 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
   :: DynFlags
   -> LabelMap StackMap  -- StackMaps for other blocks
   -> 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

manifestSp :: DynFlags
-> LabelMap StackMap
-> StackMap
-> StackLoc
-> StackLoc
-> CmmNode C O
-> [CmmNode O O]
-> StackLoc
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp DynFlags
dflags LabelMap StackMap
stackmaps StackMap
stack0 StackLoc
sp0 StackLoc
sp_high
           CmmNode C O
first [CmmNode O O]
middle_pre StackLoc
sp_off CmmNode O C
last [CmmBlock]
fixup_blocks
  = CmmBlock
final_block CmmBlock -> [CmmBlock] -> [CmmBlock]
forall a. a -> [a] -> [a]
: [CmmBlock]
fixup_blocks'
  where
    area_off :: Area -> StackLoc
area_off = LabelMap StackMap -> Area -> StackLoc
getAreaOff LabelMap StackMap
stackmaps

    adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
    adj_pre_sp :: CmmNode e x -> CmmNode e x
adj_pre_sp  = (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep (DynFlags
-> StackLoc -> StackLoc -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
areaToSp DynFlags
dflags StackLoc
sp0            StackLoc
sp_high Area -> StackLoc
area_off)
    adj_post_sp :: CmmNode e x -> CmmNode e x
adj_post_sp = (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep (DynFlags
-> StackLoc -> StackLoc -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
areaToSp DynFlags
dflags (StackLoc
sp0 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
sp_off) StackLoc
sp_high Area -> StackLoc
area_off)

    final_middle :: Block CmmNode O O
final_middle = DynFlags
-> StackLoc -> StackLoc -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj DynFlags
dflags StackLoc
sp0 StackLoc
sp_off
                 (Block CmmNode O O -> Block CmmNode O O)
-> ([CmmNode O O] -> Block CmmNode O O)
-> [CmmNode O O]
-> Block CmmNode O O
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CmmNode O O] -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *).
[n O O] -> Block n O O
blockFromList
                 ([CmmNode O O] -> Block CmmNode O O)
-> ([CmmNode O O] -> [CmmNode O O])
-> [CmmNode O O]
-> Block CmmNode O O
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CmmNode O O -> CmmNode O O) -> [CmmNode O O] -> [CmmNode O O]
forall a b. (a -> b) -> [a] -> [b]
map CmmNode O O -> CmmNode O O
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_pre_sp
                 ([CmmNode O O] -> [CmmNode O O])
-> ([CmmNode O O] -> [CmmNode O O])
-> [CmmNode O O]
-> [CmmNode O O]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackMap
-> LabelMap StackMap
-> (Area -> StackLoc)
-> [CmmNode O O]
-> [CmmNode O O]
elimStackStores StackMap
stack0 LabelMap StackMap
stackmaps Area -> StackLoc
area_off
                 ([CmmNode O O] -> Block CmmNode O O)
-> [CmmNode O O] -> Block CmmNode O O
forall a b. (a -> b) -> a -> b
$ [CmmNode O O]
middle_pre
    final_last :: CmmNode O C
final_last    = CmmNode O C -> CmmNode O C
optStackCheck (CmmNode O C -> CmmNode O C
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_post_sp CmmNode O C
last)

    final_block :: CmmBlock
final_block   = CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *).
n C O -> Block n O O -> n O C -> Block n C C
blockJoin CmmNode C O
first Block CmmNode O O
final_middle CmmNode O C
final_last

    fixup_blocks' :: [CmmBlock]
fixup_blocks' = (CmmBlock -> CmmBlock) -> [CmmBlock] -> [CmmBlock]
forall a b. (a -> b) -> [a] -> [b]
map ((CmmNode C O -> CmmNode C O, CmmNode O O -> CmmNode O O,
 CmmNode O C -> CmmNode O C)
-> CmmBlock -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *)
       (n' :: Extensibility -> Extensibility -> *) (e :: Extensibility)
       (x :: Extensibility).
(n C O -> n' C O, n O O -> n' O O, n O C -> n' O C)
-> Block n e x -> Block n' e x
mapBlock3' (CmmNode C O -> CmmNode C O
forall a. a -> a
id, CmmNode O O -> CmmNode O O
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_post_sp, CmmNode O C -> CmmNode O C
forall a. a -> a
id)) [CmmBlock]
fixup_blocks

getAreaOff :: LabelMap StackMap -> (Area -> StackLoc)
getAreaOff :: LabelMap StackMap -> Area -> StackLoc
getAreaOff LabelMap StackMap
_ Area
Old = StackLoc
0
getAreaOff LabelMap StackMap
stackmaps (Young BlockId
l) =
  case KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
l LabelMap StackMap
stackmaps of
    Just StackMap
sm -> StackMap -> StackLoc
sm_sp StackMap
sm StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackMap -> StackLoc
sm_args StackMap
sm
    Maybe StackMap
Nothing -> String -> SDoc -> StackLoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getAreaOff" (BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
l)


maybeAddSpAdj
  :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj :: DynFlags
-> StackLoc -> StackLoc -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj DynFlags
dflags StackLoc
sp0 StackLoc
sp_off Block CmmNode O O
block =
  Block CmmNode O O -> Block CmmNode O O
add_initial_unwind (Block CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> Block CmmNode O O
forall a b. (a -> b) -> a -> b
$ Block CmmNode O O -> Block CmmNode O O
add_adj_unwind (Block CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> Block CmmNode O O
forall a b. (a -> b) -> a -> b
$ Block CmmNode O O -> Block CmmNode O O
adj Block CmmNode O O
block
  where
    adj :: Block CmmNode O O -> Block CmmNode O O
adj Block CmmNode O O
block
      | StackLoc
sp_off StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
/= StackLoc
0
      = Block CmmNode O O
block Block CmmNode O O -> CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O O -> Block n e O
`blockSnoc` CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
spReg (DynFlags -> CmmExpr -> StackLoc -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
spExpr StackLoc
sp_off)
      | Bool
otherwise = Block CmmNode O O
block
    -- Add unwind pseudo-instruction at the beginning of each block to
    -- document Sp level for debugging
    add_initial_unwind :: Block CmmNode O O -> Block CmmNode O O
add_initial_unwind Block CmmNode O O
block
      | DynFlags -> StackLoc
debugLevel DynFlags
dflags StackLoc -> StackLoc -> Bool
forall a. Ord a => a -> a -> Bool
> StackLoc
0
      = [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
CmmUnwind [(GlobalReg
Sp, CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just CmmExpr
sp_unwind)] CmmNode O O -> Block CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
n O O -> Block n O x -> Block n O x
`blockCons` Block CmmNode O O
block
      | Bool
otherwise
      = Block CmmNode O O
block
      where sp_unwind :: CmmExpr
sp_unwind = CmmReg -> StackLoc -> CmmExpr
CmmRegOff CmmReg
spReg (StackLoc
sp0 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags)

    -- Add unwind pseudo-instruction right after the Sp adjustment
    -- if there is one.
    add_adj_unwind :: Block CmmNode O O -> Block CmmNode O O
add_adj_unwind Block CmmNode O O
block
      | DynFlags -> StackLoc
debugLevel DynFlags
dflags StackLoc -> StackLoc -> Bool
forall a. Ord a => a -> a -> Bool
> StackLoc
0
      , StackLoc
sp_off StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
/= StackLoc
0
      = Block CmmNode O O
block Block CmmNode O O -> CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O O -> Block n e O
`blockSnoc` [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
CmmUnwind [(GlobalReg
Sp, CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just CmmExpr
sp_unwind)]
      | Bool
otherwise
      = Block CmmNode O O
block
      where sp_unwind :: CmmExpr
sp_unwind = CmmReg -> StackLoc -> CmmExpr
CmmRegOff CmmReg
spReg (StackLoc
sp0 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
sp_off)

{- Note [SP old/young offsets]

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.

 - in block L, each reference to [old + N] turns into
   [Sp + Sp(L) - N]

 - in block L, each reference to [young(L') + N] turns into
   [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')
-}

areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr

areaToSp :: DynFlags
-> StackLoc -> StackLoc -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
areaToSp DynFlags
dflags StackLoc
sp_old StackLoc
_sp_hwm Area -> StackLoc
area_off (CmmStackSlot Area
area StackLoc
n)
  = DynFlags -> CmmExpr -> StackLoc -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
spExpr (StackLoc
sp_old StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- Area -> StackLoc
area_off Area
area StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
n)
    -- Replace (CmmStackSlot area n) with an offset from Sp

areaToSp DynFlags
dflags StackLoc
_ StackLoc
sp_hwm Area -> StackLoc
_ (CmmLit CmmLit
CmmHighStackMark)
  = DynFlags -> StackLoc -> CmmExpr
mkIntExpr DynFlags
dflags StackLoc
sp_hwm
    -- Replace CmmHighStackMark with the number of bytes of stack used,
    -- the sp_hwm.   See Note [Stack usage] in GHC.StgToCmm.Heap

areaToSp DynFlags
dflags StackLoc
_ StackLoc
_ Area -> StackLoc
_ (CmmMachOp (MO_U_Lt Width
_) [CmmExpr]
args)
  | [CmmExpr] -> Bool
falseStackCheck [CmmExpr]
args
  = DynFlags -> CmmExpr
zeroExpr DynFlags
dflags
areaToSp DynFlags
dflags StackLoc
_ StackLoc
_ Area -> StackLoc
_ (CmmMachOp (MO_U_Ge Width
_) [CmmExpr]
args)
  | [CmmExpr] -> Bool
falseStackCheck [CmmExpr]
args
  = DynFlags -> StackLoc -> CmmExpr
mkIntExpr DynFlags
dflags StackLoc
1
    -- Replace a stack-overflow test that cannot fail with a no-op
    -- See Note [Always false stack check]

areaToSp DynFlags
_ StackLoc
_ StackLoc
_ Area -> StackLoc
_ CmmExpr
other = CmmExpr
other

-- | Determine whether a stack check cannot fail.
falseStackCheck :: [CmmExpr] -> Bool
falseStackCheck :: [CmmExpr] -> Bool
falseStackCheck [ CmmMachOp (MO_Sub Width
_)
                      [ CmmRegOff (CmmGlobal GlobalReg
Sp) StackLoc
x_off
                      , CmmLit (CmmInt Integer
y_lit Width
_)]
                , CmmReg (CmmGlobal GlobalReg
SpLim)]
  = StackLoc -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral StackLoc
x_off Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
y_lit
falseStackCheck [CmmExpr]
_ = Bool
False

-- Note [Always false stack check]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- We can optimise stack checks of the form
--
--   if ((Sp + x) - y < SpLim) then .. else ..
--
-- 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.
--
-- 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.

optStackCheck :: CmmNode O C -> CmmNode O C
optStackCheck :: CmmNode O C -> CmmNode O C
optStackCheck CmmNode O C
n = -- Note [Always false stack check]
 case CmmNode O C
n of
   CmmCondBranch (CmmLit (CmmInt Integer
0 Width
_)) BlockId
_true BlockId
false Maybe Bool
_ -> BlockId -> CmmNode O C
CmmBranch BlockId
false
   CmmCondBranch (CmmLit (CmmInt Integer
_ Width
_)) BlockId
true BlockId
_false Maybe Bool
_ -> BlockId -> CmmNode O C
CmmBranch BlockId
true
   CmmNode O C
other -> CmmNode O C
other


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

-- | 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
                -> LabelMap StackMap
                -> (Area -> ByteOff)
                -> [CmmNode O O]
                -> [CmmNode O O]
elimStackStores :: StackMap
-> LabelMap StackMap
-> (Area -> StackLoc)
-> [CmmNode O O]
-> [CmmNode O O]
elimStackStores StackMap
stackmap LabelMap StackMap
stackmaps Area -> StackLoc
area_off [CmmNode O O]
nodes
  = StackMap -> [CmmNode O O] -> [CmmNode O O]
go StackMap
stackmap [CmmNode O O]
nodes
  where
    go :: StackMap -> [CmmNode O O] -> [CmmNode O O]
go StackMap
_stackmap [] = []
    go StackMap
stackmap (CmmNode O O
n:[CmmNode O O]
ns)
     = case CmmNode O O
n of
         CmmStore (CmmStackSlot Area
area StackLoc
m) (CmmReg (CmmLocal LocalReg
r))
            | Just (LocalReg
_,StackLoc
off) <- UniqFM (LocalReg, StackLoc)
-> LocalReg -> Maybe (LocalReg, StackLoc)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM (StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs StackMap
stackmap) LocalReg
r
            , Area -> StackLoc
area_off Area
area StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
m StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
== StackLoc
off
            -> StackMap -> [CmmNode O O] -> [CmmNode O O]
go StackMap
stackmap [CmmNode O O]
ns
         CmmNode O O
_otherwise
            -> CmmNode O O
n CmmNode O O -> [CmmNode O O] -> [CmmNode O O]
forall a. a -> [a] -> [a]
: StackMap -> [CmmNode O O] -> [CmmNode O O]
go (LabelMap StackMap -> CmmNode O O -> StackMap -> StackMap
forall (e :: Extensibility) (x :: Extensibility).
LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle LabelMap StackMap
stackmaps CmmNode O O
n StackMap
stackmap) [CmmNode O O]
ns


-- -----------------------------------------------------------------------------
-- Update info tables to include stack liveness


setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap DynFlags
dflags LabelMap StackMap
stackmaps (CmmProc top_info :: CmmTopInfo
top_info@TopInfo{LabelMap CmmInfoTable
CmmStackInfo
stack_info :: CmmTopInfo -> CmmStackInfo
info_tbls :: CmmTopInfo -> LabelMap CmmInfoTable
stack_info :: CmmStackInfo
info_tbls :: LabelMap CmmInfoTable
..} CLabel
l [GlobalReg]
v CmmGraph
g)
  = CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
top_info{ info_tbls :: LabelMap CmmInfoTable
info_tbls = (KeyOf LabelMap -> CmmInfoTable -> CmmInfoTable)
-> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
forall (map :: * -> *) a b.
IsMap map =>
(KeyOf map -> a -> b) -> map a -> map b
mapMapWithKey KeyOf LabelMap -> CmmInfoTable -> CmmInfoTable
BlockId -> CmmInfoTable -> CmmInfoTable
fix_info LabelMap CmmInfoTable
info_tbls } CLabel
l [GlobalReg]
v CmmGraph
g
  where
    fix_info :: BlockId -> CmmInfoTable -> CmmInfoTable
fix_info BlockId
lbl info_tbl :: CmmInfoTable
info_tbl@CmmInfoTable{ cit_rep :: CmmInfoTable -> SMRep
cit_rep = StackRep Liveness
_ } =
       CmmInfoTable
info_tbl { cit_rep :: SMRep
cit_rep = Liveness -> SMRep
StackRep (BlockId -> Liveness
get_liveness BlockId
lbl) }
    fix_info BlockId
_ CmmInfoTable
other = CmmInfoTable
other

    get_liveness :: BlockId -> Liveness
    get_liveness :: BlockId -> Liveness
get_liveness BlockId
lbl
      = case KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
lbl LabelMap StackMap
stackmaps of
          Maybe StackMap
Nothing -> String -> SDoc -> Liveness
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"setInfoTableStackMap" (BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
lbl SDoc -> SDoc -> SDoc
<+> LabelMap CmmInfoTable -> SDoc
forall a. Outputable a => a -> SDoc
ppr LabelMap CmmInfoTable
info_tbls)
          Just StackMap
sm -> DynFlags -> StackMap -> Liveness
stackMapToLiveness DynFlags
dflags StackMap
sm

setInfoTableStackMap DynFlags
_ LabelMap StackMap
_ CmmDecl
d = CmmDecl
d


stackMapToLiveness :: DynFlags -> StackMap -> Liveness
stackMapToLiveness :: DynFlags -> StackMap -> Liveness
stackMapToLiveness DynFlags
dflags StackMap{StackLoc
UniqFM (LocalReg, StackLoc)
sm_regs :: UniqFM (LocalReg, StackLoc)
sm_ret_off :: StackLoc
sm_args :: StackLoc
sm_sp :: StackLoc
sm_regs :: StackMap -> UniqFM (LocalReg, StackLoc)
sm_ret_off :: StackMap -> StackLoc
sm_args :: StackMap -> StackLoc
sm_sp :: StackMap -> StackLoc
..} =
   Liveness -> Liveness
forall a. [a] -> [a]
reverse (Liveness -> Liveness) -> Liveness -> Liveness
forall a b. (a -> b) -> a -> b
$ Array StackLoc Bool -> Liveness
forall i e. Array i e -> [e]
Array.elems (Array StackLoc Bool -> Liveness)
-> Array StackLoc Bool -> Liveness
forall a b. (a -> b) -> a -> b
$
        (Bool -> Bool -> Bool)
-> Bool
-> (StackLoc, StackLoc)
-> [(StackLoc, Bool)]
-> Array StackLoc Bool
forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray (\Bool
_ Bool
x -> Bool
x) Bool
True (DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags StackLoc
sm_ret_off StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
1,
                                     DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags (StackLoc
sm_sp StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
sm_args)) [(StackLoc, Bool)]
live_words
   where
     live_words :: [(StackLoc, Bool)]
live_words =  [ (DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags StackLoc
off, Bool
False)
                   | (LocalReg
r,StackLoc
off) <- UniqFM (LocalReg, StackLoc) -> [(LocalReg, StackLoc)]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM UniqFM (LocalReg, StackLoc)
sm_regs
                   , CmmType -> Bool
isGcPtrType (LocalReg -> CmmType
localRegType LocalReg
r) ]
                   -- See Note [Unique Determinism and code generation]

-- -----------------------------------------------------------------------------
-- Pass 2
-- -----------------------------------------------------------------------------

insertReloadsAsNeeded
    :: DynFlags
    -> ProcPointSet
    -> LabelMap StackMap
    -> BlockId
    -> [CmmBlock]
    -> UniqSM [CmmBlock]
insertReloadsAsNeeded :: DynFlags
-> ProcPointSet
-> LabelMap StackMap
-> BlockId
-> [CmmBlock]
-> UniqSM [CmmBlock]
insertReloadsAsNeeded DynFlags
dflags ProcPointSet
procpoints LabelMap StackMap
final_stackmaps BlockId
entry [CmmBlock]
blocks = do
    CmmGraph -> [CmmBlock]
toBlockList (CmmGraph -> [CmmBlock])
-> ((CmmGraph, BlockEntryLiveness LocalReg) -> CmmGraph)
-> (CmmGraph, BlockEntryLiveness LocalReg)
-> [CmmBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CmmGraph, BlockEntryLiveness LocalReg) -> CmmGraph
forall a b. (a, b) -> a
fst ((CmmGraph, BlockEntryLiveness LocalReg) -> [CmmBlock])
-> UniqSM (CmmGraph, BlockEntryLiveness LocalReg)
-> UniqSM [CmmBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        DataflowLattice CmmLocalLive
-> RewriteFun CmmLocalLive
-> CmmGraph
-> BlockEntryLiveness LocalReg
-> UniqSM (CmmGraph, BlockEntryLiveness LocalReg)
forall f.
DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmmBwd DataflowLattice CmmLocalLive
forall r. Ord r => DataflowLattice (CmmLive r)
liveLattice RewriteFun CmmLocalLive
rewriteCC (BlockId -> [CmmBlock] -> CmmGraph
ofBlockList BlockId
entry [CmmBlock]
blocks) BlockEntryLiveness LocalReg
forall (map :: * -> *) a. IsMap map => map a
mapEmpty
  where
    rewriteCC :: RewriteFun CmmLocalLive
    rewriteCC :: RewriteFun CmmLocalLive
rewriteCC (BlockCC CmmNode C O
e_node Block CmmNode O O
middle0 CmmNode O C
x_node) BlockEntryLiveness LocalReg
fact_base0 = do
        let entry_label :: BlockId
entry_label = CmmNode C O -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmNode C O
e_node
            stackmap :: StackMap
stackmap = case KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
entry_label LabelMap StackMap
final_stackmaps of
                Just StackMap
sm -> StackMap
sm
                Maybe StackMap
Nothing -> String -> StackMap
forall a. String -> a
panic String
"insertReloadsAsNeeded: rewriteCC: stackmap"

            -- Merge the liveness from successor blocks and analyse the last
            -- node.
            joined :: CmmLocalLive
joined = DynFlags -> CmmNode O C -> CmmLocalLive -> CmmLocalLive
forall r n.
(DefinerOfRegs r n, UserOfRegs r n) =>
DynFlags -> n -> CmmLive r -> CmmLive r
gen_kill DynFlags
dflags CmmNode O C
x_node (CmmLocalLive -> CmmLocalLive) -> CmmLocalLive -> CmmLocalLive
forall a b. (a -> b) -> a -> b
$!
                         DataflowLattice CmmLocalLive
-> CmmNode O C -> BlockEntryLiveness LocalReg -> CmmLocalLive
forall (n :: Extensibility -> Extensibility -> *) f
       (e :: Extensibility).
NonLocal n =>
DataflowLattice f -> n e C -> FactBase f -> f
joinOutFacts DataflowLattice CmmLocalLive
forall r. Ord r => DataflowLattice (CmmLive r)
liveLattice CmmNode O C
x_node BlockEntryLiveness LocalReg
fact_base0
            -- What is live at the start of middle0.
            live_at_middle0 :: CmmLocalLive
live_at_middle0 = (CmmNode O O -> CmmLocalLive -> CmmLocalLive)
-> Block CmmNode O O -> CmmLocalLive -> CmmLocalLive
forall f. (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
foldNodesBwdOO (DynFlags -> CmmNode O O -> CmmLocalLive -> CmmLocalLive
forall r n.
(DefinerOfRegs r n, UserOfRegs r n) =>
DynFlags -> n -> CmmLive r -> CmmLive r
gen_kill DynFlags
dflags) Block CmmNode O O
middle0 CmmLocalLive
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.
            (Block CmmNode O O
middle1, CmmLocalLive
live_with_reloads)
                | ElemOf ProcPointSet
BlockId
entry_label ElemOf ProcPointSet -> ProcPointSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints
                = let reloads :: [CmmNode O O]
reloads = DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads DynFlags
dflags StackMap
stackmap CmmLocalLive
live_at_middle0
                  in ((CmmNode O O -> Block CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> [CmmNode O O] -> Block CmmNode O O
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmNode O O -> Block CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
n O O -> Block n O x -> Block n O x
blockCons Block CmmNode O O
middle0 [CmmNode O O]
reloads, CmmLocalLive
forall a. Set a
emptyRegSet)
                | Bool
otherwise
                = (Block CmmNode O O
middle0, CmmLocalLive
live_at_middle0)

            -- Final liveness for this block.
            !fact_base2 :: BlockEntryLiveness LocalReg
fact_base2 = KeyOf LabelMap -> CmmLocalLive -> BlockEntryLiveness LocalReg
forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton KeyOf LabelMap
BlockId
entry_label CmmLocalLive
live_with_reloads

        (CmmBlock, BlockEntryLiveness LocalReg)
-> UniqSM (CmmBlock, BlockEntryLiveness LocalReg)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *).
n C O -> Block n O O -> n O C -> Block n C C
BlockCC CmmNode C O
e_node Block CmmNode O O
middle1 CmmNode O C
x_node, BlockEntryLiveness LocalReg
fact_base2)

insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads DynFlags
dflags StackMap
stackmap CmmLocalLive
live =
     [ CmmReg -> CmmExpr -> CmmNode O O
CmmAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg)
                 -- This cmmOffset basically corresponds to manifesting
                 -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]
                 (CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> StackLoc -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
spExpr (StackLoc
sp_off StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
reg_off))
                          (LocalReg -> CmmType
localRegType LocalReg
reg))
     | (LocalReg
reg, StackLoc
reg_off) <- StackMap -> [(LocalReg, StackLoc)]
stackSlotRegs StackMap
stackmap
     , LocalReg
reg LocalReg -> CmmLocalLive -> Bool
forall r. Ord r => r -> RegSet r -> Bool
`elemRegSet` CmmLocalLive
live
     ]
   where
     sp_off :: StackLoc
sp_off = StackMap -> StackLoc
sm_sp StackMap
stackmap

-- -----------------------------------------------------------------------------
-- Lowering safe foreign calls

{-
Note [Lower safe foreign calls]

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
 | jump Sp[0]
 '-----------------------
 L1:
   r = R1 -- copyIn, inserted by mkSafeCall
   ...

Note the copyOut, which saves the results in the places that L1 is
expecting them (see Note [safe foreign call convention]). Note also
that safe foreign call is replace by an unsafe one in the Cmm graph.
-}

lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall DynFlags
dflags CmmBlock
block
  | (entry :: CmmNode C O
entry@(CmmEntry BlockId
_ CmmTickScope
tscp), Block CmmNode O O
middle, CmmForeignCall { Bool
StackLoc
[LocalReg]
[CmmExpr]
BlockId
ForeignTarget
intrbl :: Bool
ret_off :: StackLoc
ret_args :: StackLoc
succ :: BlockId
args :: [CmmExpr]
res :: [LocalReg]
tgt :: ForeignTarget
intrbl :: CmmNode O C -> Bool
ret_off :: CmmNode O C -> StackLoc
ret_args :: CmmNode O C -> StackLoc
succ :: CmmNode O C -> BlockId
args :: CmmNode O C -> [CmmExpr]
res :: CmmNode O C -> [LocalReg]
tgt :: CmmNode O C -> ForeignTarget
.. }) <- CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
  = do
    -- Both 'id' and 'new_base' are KindNonPtr because they're
    -- RTS-only objects and are not subject to garbage collection
    LocalReg
id <- CmmType -> UniqSM LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
dflags)
    LocalReg
new_base <- CmmType -> UniqSM LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
baseReg)
    let (CmmAGraph
caller_save, CmmAGraph
caller_load) = DynFlags -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs DynFlags
dflags
    CmmAGraph
save_state_code <- DynFlags -> UniqSM CmmAGraph
forall (m :: * -> *). MonadUnique m => DynFlags -> m CmmAGraph
saveThreadState DynFlags
dflags
    CmmAGraph
load_state_code <- DynFlags -> UniqSM CmmAGraph
forall (m :: * -> *). MonadUnique m => DynFlags -> m CmmAGraph
loadThreadState DynFlags
dflags
    let suspend :: CmmAGraph
suspend = CmmAGraph
save_state_code  CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
                  CmmAGraph
caller_save CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
                  CmmNode O O -> CmmAGraph
mkMiddle (DynFlags -> LocalReg -> Bool -> CmmNode O O
callSuspendThread DynFlags
dflags LocalReg
id Bool
intrbl)
        midCall :: CmmAGraph
midCall = ForeignTarget -> [LocalReg] -> [CmmExpr] -> CmmAGraph
mkUnsafeCall ForeignTarget
tgt [LocalReg]
res [CmmExpr]
args
        resume :: CmmAGraph
resume  = CmmNode O O -> CmmAGraph
mkMiddle (LocalReg -> LocalReg -> CmmNode O O
callResumeThread LocalReg
new_base LocalReg
id) CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
                  -- Assign the result to BaseReg: we
                  -- might now have a different Capability!
                  CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
baseReg (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
new_base)) CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
                  CmmAGraph
caller_load CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
                  CmmAGraph
load_state_code

        (StackLoc
_, [GlobalReg]
regs, CmmAGraph
copyout) =
             DynFlags
-> Convention
-> Transfer
-> Area
-> [CmmExpr]
-> StackLoc
-> [CmmExpr]
-> (StackLoc, [GlobalReg], CmmAGraph)
copyOutOflow DynFlags
dflags Convention
NativeReturn Transfer
Jump (BlockId -> Area
Young BlockId
succ)
                            ((LocalReg -> CmmExpr) -> [LocalReg] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> (LocalReg -> CmmReg) -> LocalReg -> CmmExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) [LocalReg]
res)
                            StackLoc
ret_off []

        -- 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.
        jump :: CmmNode O C
jump = CmmCall :: CmmExpr
-> Maybe BlockId
-> [GlobalReg]
-> StackLoc
-> StackLoc
-> StackLoc
-> CmmNode O C
CmmCall { cml_target :: CmmExpr
cml_target    = DynFlags -> CmmExpr -> CmmExpr
entryCode DynFlags
dflags (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
forall a b. (a -> b) -> a -> b
$
                                         CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
spExpr (DynFlags -> CmmType
bWord DynFlags
dflags)
                       , cml_cont :: Maybe BlockId
cml_cont      = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
succ
                       , cml_args_regs :: [GlobalReg]
cml_args_regs = [GlobalReg]
regs
                       , cml_args :: StackLoc
cml_args      = Width -> StackLoc
widthInBytes (DynFlags -> Width
wordWidth DynFlags
dflags)
                       , cml_ret_args :: StackLoc
cml_ret_args  = StackLoc
ret_args
                       , cml_ret_off :: StackLoc
cml_ret_off   = StackLoc
ret_off }

    CmmGraph
graph' <- CmmAGraphScoped -> UniqSM CmmGraph
lgraphOfAGraph ( CmmAGraph
suspend CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
                               CmmAGraph
midCall CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
                               CmmAGraph
resume  CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
                               CmmAGraph
copyout CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
                               CmmNode O C -> CmmAGraph
mkLast CmmNode O C
jump, CmmTickScope
tscp)

    case CmmGraph -> [CmmBlock]
toBlockList CmmGraph
graph' of
      [CmmBlock
one] -> let (CmmNode C O
_, Block CmmNode O O
middle', CmmNode O C
last) = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
one
               in CmmBlock -> UniqSM CmmBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *).
n C O -> Block n O O -> n O C -> Block n C C
blockJoin CmmNode C O
entry (Block CmmNode O O
middle Block CmmNode O O -> Block CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e O -> Block n O x -> Block n e x
`blockAppend` Block CmmNode O O
middle') CmmNode O C
last)
      [CmmBlock]
_ -> String -> UniqSM CmmBlock
forall a. String -> a
panic String
"lowerSafeForeignCall0"

  -- Block doesn't end in a safe foreign call:
  | Bool
otherwise = CmmBlock -> UniqSM CmmBlock
forall (m :: * -> *) a. Monad m => a -> m a
return CmmBlock
block


foreignLbl :: FastString -> CmmExpr
foreignLbl :: FastString -> CmmExpr
foreignLbl FastString
name = CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (FastString
-> Maybe StackLoc -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
name Maybe StackLoc
forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInExternalPackage FunctionOrData
IsFunction))

callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
callSuspendThread DynFlags
dflags LocalReg
id Bool
intrbl =
  ForeignTarget -> [LocalReg] -> [CmmExpr] -> CmmNode O O
CmmUnsafeForeignCall
       (CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget (FastString -> CmmExpr
foreignLbl (String -> FastString
fsLit String
"suspendThread"))
        (CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [ForeignHint
AddrHint, ForeignHint
NoHint] [ForeignHint
AddrHint] CmmReturnInfo
CmmMayReturn))
       [LocalReg
id] [CmmExpr
baseExpr, DynFlags -> StackLoc -> CmmExpr
mkIntExpr DynFlags
dflags (Bool -> StackLoc
forall a. Enum a => a -> StackLoc
fromEnum Bool
intrbl)]

callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread LocalReg
new_base LocalReg
id =
  ForeignTarget -> [LocalReg] -> [CmmExpr] -> CmmNode O O
CmmUnsafeForeignCall
       (CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget (FastString -> CmmExpr
foreignLbl (String -> FastString
fsLit String
"resumeThread"))
            (CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [ForeignHint
AddrHint] [ForeignHint
AddrHint] CmmReturnInfo
CmmMayReturn))
       [LocalReg
new_base] [CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
id)]

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

plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff
plusW :: DynFlags -> StackLoc -> StackLoc -> StackLoc
plusW DynFlags
dflags StackLoc
b StackLoc
w = StackLoc
b StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
w StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
* DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags

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

instance Outputable StackSlot where
  ppr :: StackSlot -> SDoc
ppr StackSlot
Occupied = String -> SDoc
text String
"XXX"
  ppr StackSlot
Empty    = String -> SDoc
text String
"---"

dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty :: StackLoc -> [StackSlot] -> Maybe [StackSlot]
dropEmpty StackLoc
0 [StackSlot]
ss           = [StackSlot] -> Maybe [StackSlot]
forall a. a -> Maybe a
Just [StackSlot]
ss
dropEmpty StackLoc
n (StackSlot
Empty : [StackSlot]
ss) = StackLoc -> [StackSlot] -> Maybe [StackSlot]
dropEmpty (StackLoc
nStackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
-StackLoc
1) [StackSlot]
ss
dropEmpty StackLoc
_ [StackSlot]
_            = Maybe [StackSlot]
forall a. Maybe a
Nothing

isEmpty :: StackSlot -> Bool
isEmpty :: StackSlot -> Bool
isEmpty StackSlot
Empty = Bool
True
isEmpty StackSlot
_ = Bool
False

localRegBytes :: DynFlags -> LocalReg -> ByteOff
localRegBytes :: DynFlags -> LocalReg -> StackLoc
localRegBytes DynFlags
dflags LocalReg
r
    = DynFlags -> StackLoc -> StackLoc
roundUpToWords DynFlags
dflags (Width -> StackLoc
widthInBytes (CmmType -> Width
typeWidth (LocalReg -> CmmType
localRegType LocalReg
r)))

localRegWords :: DynFlags -> LocalReg -> WordOff
localRegWords :: DynFlags -> LocalReg -> StackLoc
localRegWords DynFlags
dflags = DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags (StackLoc -> StackLoc)
-> (LocalReg -> StackLoc) -> LocalReg -> StackLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> LocalReg -> StackLoc
localRegBytes DynFlags
dflags

toWords :: DynFlags -> ByteOff -> WordOff
toWords :: DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags StackLoc
x = StackLoc
x StackLoc -> StackLoc -> StackLoc
forall a. Integral a => a -> a -> a
`quot` DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags


stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
stackSlotRegs StackMap
sm = UniqFM (LocalReg, StackLoc) -> [(LocalReg, StackLoc)]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM (StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs StackMap
sm)
  -- See Note [Unique Determinism and code generation]