{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}
module GHC.Cmm.LayoutStack (
       cmmLayoutStack, setInfoTableStackMap
  ) where

import GHC.Prelude hiding ((<*>))

import GHC.Platform
import GHC.Platform.Profile

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

import GHC.Types.Basic
import GHC.Cmm
import GHC.Cmm.Info
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.Utils
import GHC.Cmm.Graph
import GHC.Types.ForeignCall
import GHC.Cmm.Liveness
import GHC.Cmm.ProcPoint
import GHC.Runtime.Heap.Layout
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Types.Unique.Supply
import GHC.Data.Maybe
import GHC.Types.Unique.FM
import GHC.Utils.Misc

import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Utils.Outputable hiding ( isEmpty )
import GHC.Utils.Panic
import qualified Data.Set as Set
import Control.Monad.Fix
import Data.Array as Array
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 -> WordOff
sm_sp   :: StackLoc
       -- ^ the offset of Sp relative to the base on entry
       -- to this block.
 ,  StackMap -> WordOff
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 -> WordOff
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 (LocalReg, WordOff)
sm_regs :: UniqFM LocalReg (LocalReg,StackLoc)
       -- ^ regs on the stack
 }

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


cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
               -> UniqSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack :: DynFlags
-> ProcPointSet
-> WordOff
-> CmmGraph
-> UniqSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack DynFlags
dflags ProcPointSet
procpoints WordOff
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 = Platform -> CmmGraph -> BlockEntryLiveness LocalReg
cmmLocalLiveness Platform
platform CmmGraph
graph
        blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
revPostorder CmmGraph
graph
        profile :: Profile
profile  = DynFlags -> Profile
targetProfile DynFlags
dflags
        platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile

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

    [CmmBlock]
blocks_with_reloads <-
        Platform
-> ProcPointSet
-> LabelMap StackMap
-> BlockId
-> [CmmBlock]
-> UniqSM [CmmBlock]
insertReloadsAsNeeded Platform
platform ProcPointSet
procpoints LabelMap StackMap
final_stackmaps BlockId
entry [CmmBlock]
new_blocks
    [CmmBlock]
new_blocks' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Profile -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall Profile
profile) [CmmBlock]
blocks_with_reloads
    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
-> WordOff
-> LabelMap StackMap
-> WordOff
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, WordOff, [CmmBlock])
layout DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness BlockId
entry WordOff
entry_args LabelMap StackMap
final_stackmaps WordOff
final_sp_high [CmmBlock]
blocks
  = [CmmBlock]
-> LabelMap StackMap
-> WordOff
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, WordOff, [CmmBlock])
go [CmmBlock]
blocks LabelMap StackMap
init_stackmap WordOff
entry_args []
  where
    (WordOff
updfr, LabelMap WordOff
cont_info)  = [CmmBlock] -> (WordOff, LabelMap WordOff)
collectContInfo [CmmBlock]
blocks

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

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

    go (CmmBlock
b0 : [CmmBlock]
bs) LabelMap StackMap
acc_stackmaps WordOff
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) = 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 -> WordOff
sm_sp = WordOff
sp0 }
               = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault
                     (forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"no stack map for" (forall a. Outputable a => a -> SDoc
ppr BlockId
entry_lbl))
                     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 (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 (forall (e :: Extensibility) (x :: Extensibility).
LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle LabelMap StackMap
acc_stackmaps) Block CmmNode O O
middle0 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, WordOff
sp_off, CmmNode O C
last1, [CmmBlock]
fixup_blocks, LabelMap StackMap
out)
           <- DynFlags
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> LabelMap WordOff
-> LabelMap StackMap
-> StackMap
-> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqSM
     ([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
      LabelMap StackMap)
handleLastNode DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness LabelMap WordOff
cont_info
                             LabelMap StackMap
acc_stackmaps IndexedCO O 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 = forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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
-> WordOff
-> WordOff
-> CmmNode C O
-> [CmmNode O O]
-> WordOff
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp DynFlags
dflags LabelMap StackMap
final_stackmaps StackMap
stack0 WordOff
sp0 WordOff
final_sp_high
                          CmmNode C O
entry0 [CmmNode O O]
middle_pre WordOff
sp_off CmmNode O C
last1 [CmmBlock]
fixup_blocks

       let acc_stackmaps' :: LabelMap StackMap
acc_stackmaps' = 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 :: WordOff
this_sp_hwm | CmmNode O C -> Bool
isGcJump CmmNode O C
last0 = WordOff
0
                       | Bool
otherwise      = WordOff
sp0 forall a. Num a => a -> a -> a
- WordOff
sp_off

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

       [CmmBlock]
-> LabelMap StackMap
-> WordOff
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, WordOff, [CmmBlock])
go [CmmBlock]
bs LabelMap StackMap
acc_stackmaps' WordOff
hwm' ([CmmBlock]
final_blocks 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 forall a. Eq a => a -> a -> Bool
== GlobalReg
GCFun Bool -> Bool -> Bool
|| GlobalReg
l 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. Ideally we would
-- capture this information in the CmmProc (e.g. in CmmStackInfo; see #18232
-- for details on one ill-fated attempt at this).
--
-- 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] -> (WordOff, LabelMap WordOff)
collectContInfo [CmmBlock]
blocks
  = (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [WordOff]
ret_offs, forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList (forall a. [Maybe a] -> [a]
catMaybes [Maybe (BlockId, WordOff)]
mb_argss))
 where
  ([Maybe (BlockId, WordOff)]
mb_argss, [WordOff]
ret_offs) = forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip forall (x :: Extensibility).
Block CmmNode x C -> (Maybe (BlockId, WordOff), WordOff)
get_cont [CmmBlock]
blocks

  get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)
  get_cont :: forall (x :: Extensibility).
Block CmmNode x C -> (Maybe (BlockId, WordOff), WordOff)
get_cont Block CmmNode x C
b =
     case 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, WordOff
[GlobalReg]
CmmExpr
cml_ret_off :: CmmNode O C -> WordOff
cml_ret_args :: CmmNode O C -> WordOff
cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_args :: CmmNode O C -> WordOff
cml_ret_off :: WordOff
cml_ret_args :: WordOff
cml_args :: WordOff
cml_args_regs :: [GlobalReg]
cml_target :: CmmExpr
cml_target :: CmmNode O C -> CmmExpr
.. }
           -> (forall a. a -> Maybe a
Just (BlockId
l, WordOff
cml_ret_args), WordOff
cml_ret_off)
        CmmForeignCall { Bool
WordOff
[CmmExpr]
[LocalReg]
BlockId
ForeignTarget
tgt :: CmmNode O C -> ForeignTarget
succ :: CmmNode O C -> BlockId
ret_off :: CmmNode O C -> WordOff
ret_args :: CmmNode O C -> WordOff
res :: CmmNode O C -> [LocalReg]
intrbl :: CmmNode O C -> Bool
args :: CmmNode O C -> [CmmExpr]
intrbl :: Bool
ret_off :: WordOff
ret_args :: WordOff
succ :: BlockId
args :: [CmmExpr]
res :: [LocalReg]
tgt :: ForeignTarget
.. }
           -> (forall a. a -> Maybe a
Just (BlockId
succ, WordOff
ret_args), WordOff
ret_off)
        CmmNode O C
_other -> (forall a. Maybe a
Nothing, WordOff
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 :: forall (e :: Extensibility) (x :: Extensibility).
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 WordOff
off) CmmType
_ AlignmentSpec
_)
       -> StackMap
sm { sm_regs :: UniqFM LocalReg (LocalReg, WordOff)
sm_regs = forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM (StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs StackMap
sm) LocalReg
r (LocalReg
r,WordOff
loc) }
        where loc :: WordOff
loc = Area -> WordOff -> LabelMap StackMap -> WordOff
getStackLoc Area
area WordOff
off LabelMap StackMap
stackmaps
     CmmAssign (CmmLocal LocalReg
r) CmmExpr
_other
       -> StackMap
sm { sm_regs :: UniqFM LocalReg (LocalReg, WordOff)
sm_regs = forall key elt.
Uniquable key =>
UniqFM key elt -> key -> UniqFM key elt
delFromUFM (StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs StackMap
sm) LocalReg
r }
     CmmNode e x
_other
       -> StackMap
sm

getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc
getStackLoc :: Area -> WordOff -> LabelMap StackMap -> WordOff
getStackLoc Area
Old       WordOff
n LabelMap StackMap
_         = WordOff
n
getStackLoc (Young BlockId
l) WordOff
n LabelMap StackMap
stackmaps =
  case forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
l LabelMap StackMap
stackmaps of
    Maybe StackMap
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getStackLoc" (forall a. Outputable a => a -> SDoc
ppr BlockId
l)
    Just StackMap
sm -> StackMap -> WordOff
sm_sp StackMap
sm forall a. Num a => a -> a -> a
- StackMap -> WordOff
sm_args StackMap
sm forall a. Num a => a -> a -> a
+ WordOff
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 WordOff
-> LabelMap StackMap
-> StackMap
-> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqSM
     ([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
      LabelMap StackMap)
handleLastNode DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness LabelMap WordOff
cont_info LabelMap StackMap
stackmaps
               stack0 :: StackMap
stack0@StackMap { sm_sp :: StackMap -> WordOff
sm_sp = WordOff
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, WordOff
[GlobalReg]
CmmExpr
cml_ret_off :: WordOff
cml_ret_args :: WordOff
cml_args :: WordOff
cml_args_regs :: [GlobalReg]
cml_target :: CmmExpr
cml_ret_off :: CmmNode O C -> WordOff
cml_ret_args :: CmmNode O C -> WordOff
cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_args :: CmmNode O C -> WordOff
cml_target :: CmmNode O C -> CmmExpr
.. } -> do
        let sp_off :: WordOff
sp_off = WordOff
sp0 forall a. Num a => a -> a -> a
- WordOff
cml_args
        forall (m :: * -> *) a. Monad m => a -> m a
return ([], WordOff
sp_off, CmmNode O C
last, [], 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, WordOff
[GlobalReg]
CmmExpr
cml_ret_off :: WordOff
cml_ret_args :: WordOff
cml_args :: WordOff
cml_args_regs :: [GlobalReg]
cml_target :: CmmExpr
cml_ret_off :: CmmNode O C -> WordOff
cml_ret_args :: CmmNode O C -> WordOff
cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_args :: CmmNode O C -> WordOff
cml_target :: CmmNode O C -> CmmExpr
.. } ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BlockId
-> WordOff
-> WordOff
-> WordOff
-> ([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
    LabelMap StackMap)
lastCall BlockId
cont_lbl WordOff
cml_args WordOff
cml_ret_args WordOff
cml_ret_off

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

      CmmBranch {}     ->  UniqSM
  ([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
   LabelMap StackMap)
handleBranches
      CmmCondBranch {} ->  UniqSM
  ([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
   LabelMap StackMap)
handleBranches
      CmmSwitch {}     ->  UniqSM
  ([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
   LabelMap StackMap)
handleBranches
  where
     platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
     -- 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
-> WordOff
-> WordOff
-> WordOff
-> ([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
    LabelMap StackMap)
lastCall BlockId
lbl WordOff
cml_args WordOff
cml_ret_args WordOff
cml_ret_off
      =  ( [CmmNode O O]
assignments
         , WordOff -> StackMap -> WordOff -> WordOff
spOffsetForCall WordOff
sp0 StackMap
cont_stack WordOff
cml_args
         , CmmNode O C
last
         , [] -- no new blocks
         , forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton BlockId
lbl StackMap
cont_stack )
      where
         ([CmmNode O O]
assignments, StackMap
cont_stack) = BlockId -> WordOff -> WordOff -> ([CmmNode O O], StackMap)
prepareStack BlockId
lbl WordOff
cml_ret_args WordOff
cml_ret_off


     prepareStack :: BlockId -> WordOff -> WordOff -> ([CmmNode O O], StackMap)
prepareStack BlockId
lbl WordOff
cml_ret_args WordOff
cml_ret_off
       | Just StackMap
cont_stack <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup 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)
           = Platform
-> BlockId
-> BlockEntryLiveness LocalReg
-> WordOff
-> WordOff
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame Platform
platform BlockId
lbl BlockEntryLiveness LocalReg
liveness WordOff
cml_ret_off WordOff
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], WordOff, 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
       , (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints) forall a b. (a -> b) -> a -> b
$ forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last) forall a. Eq a => a -> a -> Bool
== [BlockId
l]
       = do
         let cont_args :: WordOff
cont_args = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault WordOff
0 BlockId
l LabelMap WordOff
cont_info
             ([CmmNode O O]
assigs, StackMap
cont_stack) = BlockId -> WordOff -> WordOff -> ([CmmNode O O], StackMap)
prepareStack BlockId
l WordOff
cont_args (StackMap -> WordOff
sm_ret_off StackMap
stack0)
             out :: LabelMap StackMap
out = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (BlockId
l', StackMap
cont_stack)
                               | BlockId
l' <- forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last ]
         forall (m :: * -> *) a. Monad m => a -> m a
return ( [CmmNode O O]
assigs
                , WordOff -> StackMap -> WordOff -> WordOff
spOffsetForCall WordOff
sp0 StackMap
cont_stack (Platform -> WordOff
platformWordSizeInBytes Platform
platform)
                , CmmNode O C
last
                , []
                , LabelMap StackMap
out)

        | Bool
otherwise = do
          [(BlockId, BlockId, StackMap, [CmmBlock])]
pps <- 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 (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 = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (BlockId
l,BlockId
tmp) | (BlockId
l,BlockId
tmp,StackMap
_,[CmmBlock]
_) <- [(BlockId, BlockId, StackMap, [CmmBlock])]
pps ]
              fix_lbl :: BlockId -> BlockId
fix_lbl BlockId
l = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault BlockId
l BlockId
l LabelMap BlockId
lbl_map
          forall (m :: * -> *) a. Monad m => a -> m a
return ( []
                 , WordOff
0
                 , (BlockId -> BlockId) -> CmmNode O C -> CmmNode O C
mapSuccessors BlockId -> BlockId
fix_lbl CmmNode O C
last
                 , forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [CmmBlock]
blk | (BlockId
_,BlockId
_,StackMap
_,[CmmBlock]
blk) <- [(BlockId, BlockId, StackMap, [CmmBlock])]
pps ]
                 , forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (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 <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup 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
-> WordOff
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags WordOff
sp0 BlockId
l StackMap
stack2 CmmTickScope
tscp [CmmNode O O]
assigs
             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.
        | BlockId
l forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints
        = do
             let cont_args :: WordOff
cont_args = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault WordOff
0 BlockId
l LabelMap WordOff
cont_info
                 (StackMap
stack2, [CmmNode O O]
assigs) =
                      Platform
-> BlockId
-> BlockEntryLiveness LocalReg
-> WordOff
-> WordOff
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame Platform
platform BlockId
l BlockEntryLiveness LocalReg
liveness (StackMap -> WordOff
sm_ret_off StackMap
stack0)
                                                        WordOff
cont_args StackMap
stack0
             (BlockId
tmp_lbl, [CmmBlock]
block) <- DynFlags
-> WordOff
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags WordOff
sp0 BlockId
l StackMap
stack2 CmmTickScope
tscp [CmmNode O O]
assigs
             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 = forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
l, StackMap
stack1, [])
        where live :: CmmLocalLive
live = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault (forall a. String -> a
panic String
"handleBranch") BlockId
l BlockEntryLiveness LocalReg
liveness
              stack1 :: StackMap
stack1 = StackMap
stack0 { sm_regs :: UniqFM LocalReg (LocalReg, WordOff)
sm_regs = forall elt key. (elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM (LocalReg, WordOff) -> Bool
is_live (StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs StackMap
stack0) }
              is_live :: (LocalReg, WordOff) -> Bool
is_live (LocalReg
r,WordOff
_) = LocalReg
r 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
-> WordOff
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags WordOff
sp0 BlockId
l StackMap
stack CmmTickScope
tscope [CmmNode O O]
assigs
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CmmNode O O]
assigs Bool -> Bool -> Bool
&& WordOff
sp0 forall a. Eq a => a -> a -> Bool
== StackMap -> WordOff
sm_sp StackMap
stack = forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, [])
  | Bool
otherwise = do
    BlockId
tmp_lbl <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
    let sp_off :: WordOff
sp_off = WordOff
sp0 forall a. Num a => a -> a -> a
- StackMap -> WordOff
sm_sp StackMap
stack
        block :: CmmBlock
block = 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
-> WordOff -> WordOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj DynFlags
dflags WordOff
sp0 WordOff
sp_off
                           forall a b. (a -> b) -> a -> b
$ forall (n :: Extensibility -> Extensibility -> *).
[n O O] -> Block n O O
blockFromList [CmmNode O O]
assigs )
                          (BlockId -> CmmNode O C
CmmBranch BlockId
l)
    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 :: WordOff -> StackMap -> WordOff -> WordOff
spOffsetForCall WordOff
current_sp StackMap
cont_stack WordOff
args
  = WordOff
current_sp forall a. Num a => a -> a -> a
- (StackMap -> WordOff
sm_sp StackMap
cont_stack forall a. Num a => a -> a -> a
- StackMap -> WordOff
sm_args StackMap
cont_stack forall a. Num a => a -> a -> a
+ WordOff
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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LocalReg, WordOff) -> [CmmNode O O]
move [(LocalReg, WordOff)]
new_locs
 where
     old_map :: UniqFM LocalReg (LocalReg, WordOff)
old_map  = StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs StackMap
old_stack
     new_locs :: [(LocalReg, WordOff)]
new_locs = StackMap -> [(LocalReg, WordOff)]
stackSlotRegs StackMap
new_stack

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



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

setupStackFrame :: Platform
-> BlockId
-> BlockEntryLiveness LocalReg
-> WordOff
-> WordOff
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame Platform
platform BlockId
lbl BlockEntryLiveness LocalReg
liveness WordOff
updfr_off WordOff
ret_args StackMap
stack0
  = (StackMap
cont_stack, [CmmNode O O]
assignments)
  where
      -- get the set of LocalRegs live in the continuation
      live :: CmmLocalLive
live = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault forall a. Set a
Set.empty 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) = Platform
-> WordOff -> CmmLocalLive -> StackMap -> (StackMap, [CmmNode O O])
allocate Platform
platform WordOff
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 :: WordOff
sm_sp = StackMap -> WordOff
sm_sp StackMap
stack1 forall a. Num a => a -> a -> a
+ WordOff
ret_args
                         , sm_args :: WordOff
sm_args = WordOff
ret_args
                         , sm_ret_off :: WordOff
sm_ret_off = WordOff
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 (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 (a :: Extensibility) (b :: Extensibility).
CmmNode a b -> Maybe BlockId -> Maybe BlockId
f Block CmmNode O O
middle forall a. Maybe a
Nothing
   where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
         f :: forall (a :: Extensibility) (b :: Extensibility).
CmmNode a b -> Maybe BlockId -> Maybe BlockId
f (CmmStore (CmmStackSlot (Young BlockId
l) WordOff
_) (CmmLit (CmmBlock BlockId
_)) AlignmentSpec
_) 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 :: Platform -> ByteOff -> LocalRegSet -> StackMap
         -> (StackMap, [CmmNode O O])
allocate :: Platform
-> WordOff -> CmmLocalLive -> StackMap -> (StackMap, [CmmNode O O])
allocate Platform
platform WordOff
ret_off CmmLocalLive
live stackmap :: StackMap
stackmap@StackMap{ sm_sp :: StackMap -> WordOff
sm_sp = WordOff
sp0
                                              , sm_regs :: StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs = UniqFM LocalReg (LocalReg, WordOff)
regs0 }
 =
   -- we only have to save regs that are not already in a slot
   let to_save :: [LocalReg]
to_save = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
`elemUFM` UniqFM LocalReg (LocalReg, WordOff)
regs0)) (forall a. Set a -> [a]
Set.elems CmmLocalLive
live)
       regs1 :: UniqFM LocalReg (LocalReg, WordOff)
regs1   = forall elt key. (elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM (\(LocalReg
r,WordOff
_) -> forall r. Ord r => r -> RegSet r -> Bool
elemRegSet LocalReg
r CmmLocalLive
live) UniqFM LocalReg (LocalReg, WordOff)
regs0
   in

   -- make a map of the stack
   let stack :: [StackSlot]
stack = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall i e. Array i e -> [e]
Array.elems forall a b. (a -> b) -> a -> b
$
               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 (WordOff
1, Platform -> WordOff -> WordOff
toWords Platform
platform (forall a. Ord a => a -> a -> a
max WordOff
sp0 WordOff
ret_off)) forall a b. (a -> b) -> a -> b
$
                 [(WordOff, StackSlot)]
ret_words forall a. [a] -> [a] -> [a]
++ [(WordOff, StackSlot)]
live_words
            where ret_words :: [(WordOff, StackSlot)]
ret_words =
                   [ (WordOff
x, StackSlot
Occupied)
                   | WordOff
x <- [ WordOff
1 .. Platform -> WordOff -> WordOff
toWords Platform
platform WordOff
ret_off] ]
                  live_words :: [(WordOff, StackSlot)]
live_words =
                   [ (Platform -> WordOff -> WordOff
toWords Platform
platform WordOff
x, StackSlot
Occupied)
                   | (LocalReg
r,WordOff
off) <- forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM LocalReg (LocalReg, WordOff)
regs1,
                   -- See Note [Unique Determinism and code generation]
                     let w :: WordOff
w = Platform -> LocalReg -> WordOff
localRegBytes Platform
platform LocalReg
r,
                     WordOff
x <- [ WordOff
off, WordOff
off forall a. Num a => a -> a -> a
- Platform -> WordOff
platformWordSizeInBytes Platform
platform .. WordOff
off forall a. Num a => a -> a -> a
- WordOff
w forall a. Num a => a -> a -> a
+ WordOff
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], WordOff, [CmmNode O O],
    [(LocalReg, (LocalReg, WordOff))])
-> ([LocalReg], [StackSlot], WordOff, [CmmNode O O],
    [(LocalReg, (LocalReg, WordOff))])
save StackSlot
slot ([], [StackSlot]
stack, WordOff
n, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, WordOff))]
regs) -- no more regs to save
          = ([], StackSlot
slotforall a. a -> [a] -> [a]
:[StackSlot]
stack, Platform -> WordOff -> WordOff -> WordOff
plusW Platform
platform WordOff
n WordOff
1, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, WordOff))]
regs)
       save StackSlot
slot ([LocalReg]
to_save, [StackSlot]
stack, WordOff
n, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, WordOff))]
regs)
          = case StackSlot
slot of
               StackSlot
Occupied ->  ([LocalReg]
to_save, StackSlot
Occupiedforall a. a -> [a] -> [a]
:[StackSlot]
stack, Platform -> WordOff -> WordOff -> WordOff
plusW Platform
platform WordOff
n WordOff
1, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, WordOff))]
regs)
               StackSlot
Empty
                 | Just ([StackSlot]
stack', LocalReg
r, [LocalReg]
to_save') <-
                       [LocalReg]
-> [StackSlot] -> Maybe ([StackSlot], LocalReg, [LocalReg])
select_save [LocalReg]
to_save (StackSlot
slotforall a. a -> [a] -> [a]
:[StackSlot]
stack)
                 -> let assig :: CmmNode O O
assig = CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode O O
CmmStore (Area -> WordOff -> CmmExpr
CmmStackSlot Area
Old WordOff
n')
                                         (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
r))
                                         AlignmentSpec
NaturallyAligned
                        n' :: WordOff
n' = Platform -> WordOff -> WordOff -> WordOff
plusW Platform
platform WordOff
n WordOff
1
                   in
                        ([LocalReg]
to_save', [StackSlot]
stack', WordOff
n', CmmNode O O
assig forall a. a -> [a] -> [a]
: [CmmNode O O]
assigs, (LocalReg
r,(LocalReg
r,WordOff
n'))forall a. a -> [a] -> [a]
:[(LocalReg, (LocalReg, WordOff))]
regs)

                 | Bool
otherwise
                 -> ([LocalReg]
to_save, StackSlot
slotforall a. a -> [a] -> [a]
:[StackSlot]
stack, Platform -> WordOff -> WordOff -> WordOff
plusW Platform
platform WordOff
n WordOff
1, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, WordOff))]
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 = forall a. Maybe a
Nothing
               go (LocalReg
r:[LocalReg]
rs) [LocalReg]
no_fit
                 | Just [StackSlot]
rest <- WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty WordOff
words [StackSlot]
stack
                 = forall a. a -> Maybe a
Just (forall a. WordOff -> a -> [a]
replicate WordOff
words StackSlot
Occupied forall a. [a] -> [a] -> [a]
++ [StackSlot]
rest, LocalReg
r, [LocalReg]
rsforall a. [a] -> [a] -> [a]
++[LocalReg]
no_fit)
                 | Bool
otherwise
                 = [LocalReg]
-> [LocalReg] -> Maybe ([StackSlot], LocalReg, [LocalReg])
go [LocalReg]
rs (LocalReg
rforall a. a -> [a] -> [a]
:[LocalReg]
no_fit)
                 where words :: WordOff
words = Platform -> LocalReg -> WordOff
localRegWords Platform
platform LocalReg
r

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

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

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

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

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

   if (WordOff
trim_sp forall a. Bits a => a -> a -> a
.&. (Platform -> WordOff
platformWordSizeInBytes Platform
platform forall a. Num a => a -> a -> a
- WordOff
1)) forall a. Eq a => a -> a -> Bool
/= WordOff
0  then forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocate2" (forall a. Outputable a => a -> SDoc
ppr WordOff
trim_sp SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr UniqFM LocalReg (LocalReg, WordOff)
final_regs SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr WordOff
push_sp) else

   ( StackMap
stackmap { sm_regs :: UniqFM LocalReg (LocalReg, WordOff)
sm_regs = UniqFM LocalReg (LocalReg, WordOff)
final_regs , sm_sp :: WordOff
sm_sp = WordOff
trim_sp }
   , [CmmNode O O]
push_assigs 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
-> WordOff
-> WordOff
-> CmmNode C O
-> [CmmNode O O]
-> WordOff
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp DynFlags
dflags LabelMap StackMap
stackmaps StackMap
stack0 WordOff
sp0 WordOff
sp_high
           CmmNode C O
first [CmmNode O O]
middle_pre WordOff
sp_off CmmNode O C
last [CmmBlock]
fixup_blocks
  = CmmBlock
final_block forall a. a -> [a] -> [a]
: [CmmBlock]
fixup_blocks'
  where
    area_off :: Area -> WordOff
area_off = LabelMap StackMap -> Area -> WordOff
getAreaOff LabelMap StackMap
stackmaps
    platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

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

    final_middle :: Block CmmNode O O
final_middle = DynFlags
-> WordOff -> WordOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj DynFlags
dflags WordOff
sp0 WordOff
sp_off
                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Extensibility -> Extensibility -> *).
[n O O] -> Block n O O
blockFromList
                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_pre_sp
                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackMap
-> LabelMap StackMap
-> (Area -> WordOff)
-> [CmmNode O O]
-> [CmmNode O O]
elimStackStores StackMap
stack0 LabelMap StackMap
stackmaps Area -> WordOff
area_off
                 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 (forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_post_sp CmmNode O C
last)

    final_block :: CmmBlock
final_block   = 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' = forall a b. (a -> b) -> [a] -> [b]
map (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' (forall a. a -> a
id, forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_post_sp, forall a. a -> a
id)) [CmmBlock]
fixup_blocks

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


maybeAddSpAdj
  :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj :: DynFlags
-> WordOff -> WordOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj DynFlags
dflags WordOff
sp0 WordOff
sp_off Block CmmNode O O
block =
  Block CmmNode O O -> Block CmmNode O O
add_initial_unwind forall a b. (a -> b) -> a -> b
$ Block CmmNode O O -> Block CmmNode O O
add_adj_unwind forall a b. (a -> b) -> a -> b
$ Block CmmNode O O -> Block CmmNode O O
adj Block CmmNode O O
block
  where
    platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    adj :: Block CmmNode O O -> Block CmmNode O O
adj Block CmmNode O O
block
      | WordOff
sp_off forall a. Eq a => a -> a -> Bool
/= WordOff
0
      = Block CmmNode O O
block 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 (Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffset Platform
platform CmmExpr
spExpr WordOff
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 -> WordOff
debugLevel DynFlags
dflags forall a. Ord a => a -> a -> Bool
> WordOff
0
      = [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
CmmUnwind [(GlobalReg
Sp, forall a. a -> Maybe a
Just CmmExpr
sp_unwind)] 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 -> WordOff -> CmmExpr
CmmRegOff CmmReg
spReg (WordOff
sp0 forall a. Num a => a -> a -> a
- Platform -> WordOff
platformWordSizeInBytes Platform
platform)

    -- 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 -> WordOff
debugLevel DynFlags
dflags forall a. Ord a => a -> a -> Bool
> WordOff
0
      , WordOff
sp_off forall a. Eq a => a -> a -> Bool
/= WordOff
0
      = Block CmmNode O O
block 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, forall a. a -> Maybe a
Just CmmExpr
sp_unwind)]
      | Bool
otherwise
      = Block CmmNode O O
block
      where sp_unwind :: CmmExpr
sp_unwind = CmmReg -> WordOff -> CmmExpr
CmmRegOff CmmReg
spReg (WordOff
sp0 forall a. Num a => a -> a -> a
- Platform -> WordOff
platformWordSizeInBytes Platform
platform forall a. Num a => a -> a -> a
- WordOff
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 :: Platform -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr

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

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

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

areaToSp Platform
_ WordOff
_ WordOff
_ Area -> WordOff
_ 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) WordOff
x_off
                      , CmmLit (CmmInt Integer
y_lit Width
_)]
                , CmmReg (CmmGlobal GlobalReg
SpLim)]
  = forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
x_off 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 -> WordOff)
-> [CmmNode O O]
-> [CmmNode O O]
elimStackStores StackMap
stackmap LabelMap StackMap
stackmaps Area -> WordOff
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 WordOff
m) (CmmReg (CmmLocal LocalReg
r)) AlignmentSpec
_
            | Just (LocalReg
_,WordOff
off) <- forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs StackMap
stackmap) LocalReg
r
            , Area -> WordOff
area_off Area
area forall a. Num a => a -> a -> a
+ WordOff
m forall a. Eq a => a -> a -> Bool
== WordOff
off
            -> StackMap -> [CmmNode O O] -> [CmmNode O O]
go StackMap
stackmap [CmmNode O O]
ns
         CmmNode O O
_otherwise
            -> CmmNode O O
n forall a. a -> [a] -> [a]
: StackMap -> [CmmNode O O] -> [CmmNode O O]
go (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 :: Platform -> LabelMap StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap :: Platform -> LabelMap StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap Platform
platform 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)
  = forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
top_info{ info_tbls :: LabelMap CmmInfoTable
info_tbls = forall (map :: * -> *) a b.
IsMap map =>
(KeyOf map -> a -> b) -> map a -> map b
mapMapWithKey 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 forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
lbl LabelMap StackMap
stackmaps of
          Maybe StackMap
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"setInfoTableStackMap" (forall a. Outputable a => a -> SDoc
ppr BlockId
lbl SDoc -> SDoc -> SDoc
<+> forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform LabelMap CmmInfoTable
info_tbls)
          Just StackMap
sm -> Platform -> StackMap -> Liveness
stackMapToLiveness Platform
platform StackMap
sm

setInfoTableStackMap Platform
_ LabelMap StackMap
_ CmmDecl
d = CmmDecl
d


stackMapToLiveness :: Platform -> StackMap -> Liveness
stackMapToLiveness :: Platform -> StackMap -> Liveness
stackMapToLiveness Platform
platform StackMap{WordOff
UniqFM LocalReg (LocalReg, WordOff)
sm_regs :: UniqFM LocalReg (LocalReg, WordOff)
sm_ret_off :: WordOff
sm_args :: WordOff
sm_sp :: WordOff
sm_regs :: StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_ret_off :: StackMap -> WordOff
sm_args :: StackMap -> WordOff
sm_sp :: StackMap -> WordOff
..} =
   forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall i e. Array i e -> [e]
Array.elems forall a b. (a -> b) -> a -> b
$
        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 (Platform -> WordOff -> WordOff
toWords Platform
platform WordOff
sm_ret_off forall a. Num a => a -> a -> a
+ WordOff
1,
                                     Platform -> WordOff -> WordOff
toWords Platform
platform (WordOff
sm_sp forall a. Num a => a -> a -> a
- WordOff
sm_args)) [(WordOff, Bool)]
live_words
   where
     live_words :: [(WordOff, Bool)]
live_words =  [ (Platform -> WordOff -> WordOff
toWords Platform
platform WordOff
off, Bool
False)
                   | (LocalReg
r,WordOff
off) <- forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM LocalReg (LocalReg, WordOff)
sm_regs
                   , CmmType -> Bool
isGcPtrType (LocalReg -> CmmType
localRegType LocalReg
r) ]
                   -- See Note [Unique Determinism and code generation]

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

insertReloadsAsNeeded
    :: Platform
    -> ProcPointSet
    -> LabelMap StackMap
    -> BlockId
    -> [CmmBlock]
    -> UniqSM [CmmBlock]
insertReloadsAsNeeded :: Platform
-> ProcPointSet
-> LabelMap StackMap
-> BlockId
-> [CmmBlock]
-> UniqSM [CmmBlock]
insertReloadsAsNeeded Platform
platform ProcPointSet
procpoints LabelMap StackMap
final_stackmaps BlockId
entry [CmmBlock]
blocks =
    CmmGraph -> [CmmBlock]
toBlockList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall f.
DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmmBwd forall r. Ord r => DataflowLattice (CmmLive r)
liveLattice RewriteFun CmmLocalLive
rewriteCC (BlockId -> [CmmBlock] -> CmmGraph
ofBlockList BlockId
entry [CmmBlock]
blocks) 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 = forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmNode C O
e_node
            stackmap :: StackMap
stackmap = case forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
entry_label LabelMap StackMap
final_stackmaps of
                Just StackMap
sm -> StackMap
sm
                Maybe StackMap
Nothing -> forall a. String -> a
panic String
"insertReloadsAsNeeded: rewriteCC: stackmap"

            -- Merge the liveness from successor blocks and analyse the last
            -- node.
            joined :: CmmLocalLive
joined = forall r n.
(DefinerOfRegs r n, UserOfRegs r n) =>
Platform -> n -> CmmLive r -> CmmLive r
gen_kill Platform
platform CmmNode O C
x_node forall a b. (a -> b) -> a -> b
$!
                         forall (n :: Extensibility -> Extensibility -> *) f
       (e :: Extensibility).
NonLocal n =>
DataflowLattice f -> n e C -> FactBase f -> f
joinOutFacts 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 = forall f. (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
foldNodesBwdOO (forall r n.
(DefinerOfRegs r n, UserOfRegs r n) =>
Platform -> n -> CmmLive r -> CmmLive r
gen_kill Platform
platform) 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)
                | BlockId
entry_label forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints
                = let reloads :: [CmmNode O O]
reloads = Platform -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads Platform
platform StackMap
stackmap CmmLocalLive
live_at_middle0
                  in (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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, 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 = forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton BlockId
entry_label CmmLocalLive
live_with_reloads

        forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: Platform -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads :: Platform -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads Platform
platform 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 -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffset Platform
platform CmmExpr
spExpr (WordOff
sp_off forall a. Num a => a -> a -> a
- WordOff
reg_off))
                          (LocalReg -> CmmType
localRegType LocalReg
reg)
                          AlignmentSpec
NaturallyAligned)
     | (LocalReg
reg, WordOff
reg_off) <- StackMap -> [(LocalReg, WordOff)]
stackSlotRegs StackMap
stackmap
     , LocalReg
reg forall r. Ord r => r -> RegSet r -> Bool
`elemRegSet` CmmLocalLive
live
     ]
   where
     sp_off :: WordOff
sp_off = StackMap -> WordOff
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 :: Profile -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall :: Profile -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall Profile
profile CmmBlock
block
  | (entry :: CmmNode C O
entry@(CmmEntry BlockId
_ CmmTickScope
tscp), Block CmmNode O O
middle, CmmForeignCall { Bool
WordOff
[CmmExpr]
[LocalReg]
BlockId
ForeignTarget
intrbl :: Bool
ret_off :: WordOff
ret_args :: WordOff
succ :: BlockId
args :: [CmmExpr]
res :: [LocalReg]
tgt :: ForeignTarget
tgt :: CmmNode O C -> ForeignTarget
succ :: CmmNode O C -> BlockId
ret_off :: CmmNode O C -> WordOff
ret_args :: CmmNode O C -> WordOff
res :: CmmNode O C -> [LocalReg]
intrbl :: CmmNode O C -> Bool
args :: CmmNode O C -> [CmmExpr]
.. }) <- forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
  = do
    let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
    -- Both 'id' and 'new_base' are KindNonPtr because they're
    -- RTS-only objects and are not subject to garbage collection
    LocalReg
id <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
bWord Platform
platform)
    LocalReg
new_base <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
baseReg)
    let (CmmAGraph
caller_save, CmmAGraph
caller_load) = Platform -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs Platform
platform
    CmmAGraph
save_state_code <- forall (m :: * -> *). MonadUnique m => Profile -> m CmmAGraph
saveThreadState Profile
profile
    CmmAGraph
load_state_code <- forall (m :: * -> *). MonadUnique m => Profile -> m CmmAGraph
loadThreadState Profile
profile
    let suspend :: CmmAGraph
suspend = CmmAGraph
save_state_code  CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
                  CmmAGraph
caller_save CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
                  CmmNode O O -> CmmAGraph
mkMiddle (Platform -> LocalReg -> Bool -> CmmNode O O
callSuspendThread Platform
platform 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

        (WordOff
_, [GlobalReg]
regs, CmmAGraph
copyout) =
             Profile
-> Convention
-> Transfer
-> Area
-> [CmmExpr]
-> WordOff
-> [CmmExpr]
-> (WordOff, [GlobalReg], CmmAGraph)
copyOutOflow Profile
profile Convention
NativeReturn Transfer
Jump (BlockId -> Area
Young BlockId
succ)
                            (forall a b. (a -> b) -> [a] -> [b]
map (CmmReg -> CmmExpr
CmmReg forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) [LocalReg]
res)
                            WordOff
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 { cml_target :: CmmExpr
cml_target    = Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform forall a b. (a -> b) -> a -> b
$
                                         Platform -> CmmExpr -> CmmExpr
cmmLoadBWord Platform
platform CmmExpr
spExpr
                       , cml_cont :: Maybe BlockId
cml_cont      = forall a. a -> Maybe a
Just BlockId
succ
                       , cml_args_regs :: [GlobalReg]
cml_args_regs = [GlobalReg]
regs
                       , cml_args :: WordOff
cml_args      = Width -> WordOff
widthInBytes (Platform -> Width
wordWidth Platform
platform)
                       , cml_ret_args :: WordOff
cml_ret_args  = WordOff
ret_args
                       , cml_ret_off :: WordOff
cml_ret_off   = WordOff
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) = forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
one
               in forall (m :: * -> *) a. Monad m => a -> m a
return (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 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]
_ -> forall a. String -> a
panic String
"lowerSafeForeignCall0"

  -- Block doesn't end in a safe foreign call:
  | Bool
otherwise = 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 WordOff -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
name forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInExternalPackage FunctionOrData
IsFunction))

callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O
callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O
callSuspendThread Platform
platform 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, Platform -> WordOff -> CmmExpr
mkIntExpr Platform
platform (forall a. Enum a => a -> WordOff
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 :: Platform -> ByteOff -> WordOff -> ByteOff
plusW :: Platform -> WordOff -> WordOff -> WordOff
plusW Platform
platform WordOff
b WordOff
w = WordOff
b forall a. Num a => a -> a -> a
+ WordOff
w forall a. Num a => a -> a -> a
* Platform -> WordOff
platformWordSizeInBytes Platform
platform

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 :: WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty WordOff
0 [StackSlot]
ss           = forall a. a -> Maybe a
Just [StackSlot]
ss
dropEmpty WordOff
n (StackSlot
Empty : [StackSlot]
ss) = WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty (WordOff
nforall a. Num a => a -> a -> a
-WordOff
1) [StackSlot]
ss
dropEmpty WordOff
_ [StackSlot]
_            = forall a. Maybe a
Nothing

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

localRegBytes :: Platform -> LocalReg -> ByteOff
localRegBytes :: Platform -> LocalReg -> WordOff
localRegBytes Platform
platform LocalReg
r
    = Platform -> WordOff -> WordOff
roundUpToWords Platform
platform (Width -> WordOff
widthInBytes (CmmType -> Width
typeWidth (LocalReg -> CmmType
localRegType LocalReg
r)))

localRegWords :: Platform -> LocalReg -> WordOff
localRegWords :: Platform -> LocalReg -> WordOff
localRegWords Platform
platform = Platform -> WordOff -> WordOff
toWords Platform
platform forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> LocalReg -> WordOff
localRegBytes Platform
platform

toWords :: Platform -> ByteOff -> WordOff
toWords :: Platform -> WordOff -> WordOff
toWords Platform
platform WordOff
x = WordOff
x forall a. Integral a => a -> a -> a
`quot` Platform -> WordOff
platformWordSizeInBytes Platform
platform


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