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

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

import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs, newTemp  ) -- 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.Platform
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Utils.Outputable hiding ( isEmpty )
import qualified Data.Set as Set
import Control.Monad.Fix
import Data.Array as Array
import Data.Bits
import Data.List (nub)

{- Note [Stack Layout]

The job of this pass is to

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

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

 - save any variables that are live across a call, and reload them as
   necessary.

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

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

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

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

Pass 1:

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

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

 - We maintain a data structure

     Map Label StackMap

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

 - For each block we visit:

    - Look up the StackMap for this block.

    - If this block is a proc point (or a call continuation, if we aren't
      splitting proc points), we need to reload all the live variables from the
      stack - but this is done in Pass 2, which calculates more precise liveness
      information (see description of Pass 2).

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

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

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

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

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

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

Pass 2:

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

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


Note [Two pass approach]

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

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

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

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

-}


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

{-
 A StackMap describes the stack at any given point.  At a continuation
 it has a particular layout, like this:

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

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

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

data StackMap = StackMap
 {  StackMap -> ByteOff
sm_sp   :: StackLoc
       -- ^ the offset of Sp relative to the base on entry
       -- to this block.
 ,  StackMap -> ByteOff
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 -> ByteOff
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, ByteOff)
sm_regs :: UniqFM LocalReg (LocalReg,StackLoc)
       -- ^ regs on the stack
 }

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


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

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

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

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

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

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

       -> [CmmBlock]                    -- [in] blocks

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

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

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

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

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

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

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

       -- (b) Look at the last node and if we are making a call or
       --     jumping to a proc point, we must save the live
       --     variables, adjust Sp, and construct the StackMaps for
       --     each of the successor blocks.  See handleLastNode for
       --     details.
       ([CmmNode O O]
middle1, ByteOff
sp_off, CmmNode O C
last1, [CmmBlock]
fixup_blocks, LabelMap StackMap
out)
           <- DynFlags
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> LabelMap ByteOff
-> LabelMap StackMap
-> StackMap
-> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqSM
     ([CmmNode O O], ByteOff, CmmNode O C, [CmmBlock],
      LabelMap StackMap)
handleLastNode DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness LabelMap ByteOff
cont_info
                             LabelMap StackMap
acc_stackmaps IndexedCO O StackMap StackMap
StackMap
stack1 CmmTickScope
tscope Block CmmNode O O
middle0 CmmNode O C
last0

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

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

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

           -- If this block jumps to the GC, then we do not take its
           -- stack usage into account for the high-water mark.
           -- Otherwise, if the only stack usage is in the stack-check
           -- failure block itself, we will do a redundant stack
           -- check.  The stack has a buffer designed to accommodate
           -- the largest amount of stack needed for calling the GC.
           --
           this_sp_hwm :: ByteOff
this_sp_hwm | CmmNode O C -> Bool
isGcJump CmmNode O C
last0 = ByteOff
0
                       | Bool
otherwise      = ByteOff
sp0 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
sp_off

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

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


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

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

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

-- This doesn't seem right somehow.  We need to find out whether this
-- proc will push some update frame material at some point, so that we
-- can avoid using that area of the stack for spilling. 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] -> (ByteOff, LabelMap ByteOff)
collectContInfo [CmmBlock]
blocks
  = ([ByteOff] -> ByteOff
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ByteOff]
ret_offs, [(KeyOf LabelMap, ByteOff)] -> LabelMap ByteOff
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([Maybe (BlockId, ByteOff)] -> [(BlockId, ByteOff)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (BlockId, ByteOff)]
mb_argss))
 where
  ([Maybe (BlockId, ByteOff)]
mb_argss, [ByteOff]
ret_offs) = (CmmBlock -> (Maybe (BlockId, ByteOff), ByteOff))
-> [CmmBlock] -> ([Maybe (BlockId, ByteOff)], [ByteOff])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip CmmBlock -> (Maybe (BlockId, ByteOff), ByteOff)
forall (x :: Extensibility).
Block CmmNode x C -> (Maybe (BlockId, ByteOff), ByteOff)
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, ByteOff), ByteOff)
get_cont Block CmmNode x C
b =
     case Block CmmNode x C -> CmmNode O C
forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
Block n x C -> n O C
lastNode Block CmmNode x C
b of
        CmmCall { cml_cont :: CmmNode O C -> Maybe BlockId
cml_cont = Just BlockId
l, ByteOff
[GlobalReg]
CmmExpr
cml_ret_off :: CmmNode O C -> ByteOff
cml_ret_args :: CmmNode O C -> ByteOff
cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_args :: CmmNode O C -> ByteOff
cml_ret_off :: ByteOff
cml_ret_args :: ByteOff
cml_args :: ByteOff
cml_args_regs :: [GlobalReg]
cml_target :: CmmExpr
cml_target :: CmmNode O C -> CmmExpr
.. }
           -> ((BlockId, ByteOff) -> Maybe (BlockId, ByteOff)
forall a. a -> Maybe a
Just (BlockId
l, ByteOff
cml_ret_args), ByteOff
cml_ret_off)
        CmmForeignCall { Bool
ByteOff
[CmmExpr]
[LocalReg]
BlockId
ForeignTarget
tgt :: CmmNode O C -> ForeignTarget
succ :: CmmNode O C -> BlockId
ret_off :: CmmNode O C -> ByteOff
ret_args :: CmmNode O C -> ByteOff
res :: CmmNode O C -> [LocalReg]
intrbl :: CmmNode O C -> Bool
args :: CmmNode O C -> [CmmExpr]
intrbl :: Bool
ret_off :: ByteOff
ret_args :: ByteOff
succ :: BlockId
args :: [CmmExpr]
res :: [LocalReg]
tgt :: ForeignTarget
.. }
           -> ((BlockId, ByteOff) -> Maybe (BlockId, ByteOff)
forall a. a -> Maybe a
Just (BlockId
succ, ByteOff
ret_args), ByteOff
ret_off)
        CmmNode O C
_other -> (Maybe (BlockId, ByteOff)
forall a. Maybe a
Nothing, ByteOff
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 ByteOff
off) CmmType
_)
       -> StackMap
sm { sm_regs :: UniqFM LocalReg (LocalReg, ByteOff)
sm_regs = UniqFM LocalReg (LocalReg, ByteOff)
-> LocalReg
-> (LocalReg, ByteOff)
-> UniqFM LocalReg (LocalReg, ByteOff)
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM (StackMap -> UniqFM LocalReg (LocalReg, ByteOff)
sm_regs StackMap
sm) LocalReg
r (LocalReg
r,ByteOff
loc) }
        where loc :: ByteOff
loc = Area -> ByteOff -> LabelMap StackMap -> ByteOff
getStackLoc Area
area ByteOff
off LabelMap StackMap
stackmaps
     CmmAssign (CmmLocal LocalReg
r) CmmExpr
_other
       -> StackMap
sm { sm_regs :: UniqFM LocalReg (LocalReg, ByteOff)
sm_regs = UniqFM LocalReg (LocalReg, ByteOff)
-> LocalReg -> UniqFM LocalReg (LocalReg, ByteOff)
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> UniqFM key elt
delFromUFM (StackMap -> UniqFM LocalReg (LocalReg, ByteOff)
sm_regs StackMap
sm) LocalReg
r }
     CmmNode e x
_other
       -> StackMap
sm

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

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

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

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


     prepareStack :: BlockId -> ByteOff -> ByteOff -> ([CmmNode O O], StackMap)
prepareStack BlockId
lbl ByteOff
cml_ret_args ByteOff
cml_ret_off
       | Just StackMap
cont_stack <- KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
lbl LabelMap StackMap
stackmaps
             -- If we have already seen this continuation before, then
             -- we just have to make the stack look the same:
       = (StackMap -> StackMap -> [CmmNode O O]
fixupStack StackMap
stack0 StackMap
cont_stack, StackMap
cont_stack)
             -- Otherwise, we have to allocate the stack frame
       | Bool
otherwise
       = ([CmmNode O O]
save_assignments, StackMap
new_cont_stack)
       where
        (StackMap
new_cont_stack, [CmmNode O O]
save_assignments)
           = Platform
-> BlockId
-> BlockEntryLiveness LocalReg
-> ByteOff
-> ByteOff
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame Platform
platform BlockId
lbl BlockEntryLiveness LocalReg
liveness ByteOff
cml_ret_off ByteOff
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], ByteOff, CmmNode O C, [CmmBlock],
   LabelMap StackMap)
handleBranches
         -- Note [diamond proc point]
       | Just BlockId
l <- Block CmmNode O O -> Maybe BlockId
futureContinuation Block CmmNode O O
middle
       , ([BlockId] -> [BlockId]
forall a. Eq a => [a] -> [a]
nub ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ (BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (ElemOf ProcPointSet -> ProcPointSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints) ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ CmmNode O C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last) [BlockId] -> [BlockId] -> Bool
forall a. Eq a => a -> a -> Bool
== [BlockId
l]
       = do
         let cont_args :: ByteOff
cont_args = ByteOff -> KeyOf LabelMap -> LabelMap ByteOff -> ByteOff
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault ByteOff
0 KeyOf LabelMap
BlockId
l LabelMap ByteOff
cont_info
             ([CmmNode O O]
assigs, StackMap
cont_stack) = BlockId -> ByteOff -> ByteOff -> ([CmmNode O O], StackMap)
prepareStack BlockId
l ByteOff
cont_args (StackMap -> ByteOff
sm_ret_off StackMap
stack0)
             out :: LabelMap StackMap
out = [(KeyOf LabelMap, StackMap)] -> LabelMap StackMap
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (KeyOf LabelMap
BlockId
l', StackMap
cont_stack)
                               | BlockId
l' <- CmmNode O C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last ]
         ([CmmNode O O], ByteOff, CmmNode O C, [CmmBlock],
 LabelMap StackMap)
-> UniqSM
     ([CmmNode O O], ByteOff, CmmNode O C, [CmmBlock],
      LabelMap StackMap)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [CmmNode O O]
assigs
                , ByteOff -> StackMap -> ByteOff -> ByteOff
spOffsetForCall ByteOff
sp0 StackMap
cont_stack (Platform -> ByteOff
platformWordSizeInBytes Platform
platform)
                , CmmNode O C
last
                , []
                , LabelMap StackMap
out)

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

     -- For each successor of this block
     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
handleBranch BlockId
l
        --   (a) if the successor already has a stackmap, we need to
        --       shuffle the current stack to make it look the same.
        --       We have to insert a new block to make this happen.
        | Just StackMap
stack2 <- KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
l LabelMap StackMap
stackmaps
        = do
             let assigs :: [CmmNode O O]
assigs = StackMap -> StackMap -> [CmmNode O O]
fixupStack StackMap
stack0 StackMap
stack2
             (BlockId
tmp_lbl, [CmmBlock]
block) <- DynFlags
-> ByteOff
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags ByteOff
sp0 BlockId
l StackMap
stack2 CmmTickScope
tscp [CmmNode O O]
assigs
             (BlockId, BlockId, StackMap, [CmmBlock])
-> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
tmp_lbl, StackMap
stack2, [CmmBlock]
block)

        --   (b) if the successor is a proc point, save everything
        --       on the stack.
        | ElemOf ProcPointSet
BlockId
l ElemOf ProcPointSet -> ProcPointSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints
        = do
             let cont_args :: ByteOff
cont_args = ByteOff -> KeyOf LabelMap -> LabelMap ByteOff -> ByteOff
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault ByteOff
0 KeyOf LabelMap
BlockId
l LabelMap ByteOff
cont_info
                 (StackMap
stack2, [CmmNode O O]
assigs) =
                      Platform
-> BlockId
-> BlockEntryLiveness LocalReg
-> ByteOff
-> ByteOff
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame Platform
platform BlockId
l BlockEntryLiveness LocalReg
liveness (StackMap -> ByteOff
sm_ret_off StackMap
stack0)
                                                        ByteOff
cont_args StackMap
stack0
             (BlockId
tmp_lbl, [CmmBlock]
block) <- DynFlags
-> ByteOff
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags ByteOff
sp0 BlockId
l StackMap
stack2 CmmTickScope
tscp [CmmNode O O]
assigs
             (BlockId, BlockId, StackMap, [CmmBlock])
-> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
tmp_lbl, StackMap
stack2, [CmmBlock]
block)

        --   (c) otherwise, the current StackMap is the StackMap for
        --       the continuation.  But we must remember to remove any
        --       variables from the StackMap that are *not* live at
        --       the destination, because this StackMap might be used
        --       by fixupStack if this is a join point.
        | Bool
otherwise = (BlockId, BlockId, StackMap, [CmmBlock])
-> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
l, StackMap
stack1, [])
        where live :: CmmLocalLive
live = CmmLocalLive
-> KeyOf LabelMap -> BlockEntryLiveness LocalReg -> CmmLocalLive
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault (String -> CmmLocalLive
forall a. String -> a
panic String
"handleBranch") KeyOf LabelMap
BlockId
l BlockEntryLiveness LocalReg
liveness
              stack1 :: StackMap
stack1 = StackMap
stack0 { sm_regs :: UniqFM LocalReg (LocalReg, ByteOff)
sm_regs = ((LocalReg, ByteOff) -> Bool)
-> UniqFM LocalReg (LocalReg, ByteOff)
-> UniqFM LocalReg (LocalReg, ByteOff)
forall elt key. (elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM (LocalReg, ByteOff) -> Bool
is_live (StackMap -> UniqFM LocalReg (LocalReg, ByteOff)
sm_regs StackMap
stack0) }
              is_live :: (LocalReg, ByteOff) -> Bool
is_live (LocalReg
r,ByteOff
_) = LocalReg
r LocalReg -> CmmLocalLive -> Bool
forall r. Ord r => r -> RegSet r -> Bool
`elemRegSet` CmmLocalLive
live


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


-- Sp is currently pointing to current_sp,
-- we want it to point to
--    (sm_sp cont_stack - sm_args cont_stack + args)
-- so the difference is
--    sp0 - (sm_sp cont_stack - sm_args cont_stack + args)
spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff
spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff
spOffsetForCall ByteOff
current_sp StackMap
cont_stack ByteOff
args
  = ByteOff
current_sp ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- (StackMap -> ByteOff
sm_sp StackMap
cont_stack ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- StackMap -> ByteOff
sm_args StackMap
cont_stack ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
args)


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

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



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

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

      -- everything up to updfr_off is off-limits
      -- stack1 contains updfr_off, plus everything we need to save
      (StackMap
stack1, [CmmNode O O]
assignments) = Platform
-> ByteOff -> CmmLocalLive -> StackMap -> (StackMap, [CmmNode O O])
allocate Platform
platform ByteOff
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 :: ByteOff
sm_sp = StackMap -> ByteOff
sm_sp StackMap
stack1 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
ret_args
                         , sm_args :: ByteOff
sm_args = ByteOff
ret_args
                         , sm_ret_off :: ByteOff
sm_ret_off = ByteOff
updfr_off
                         }


-- -----------------------------------------------------------------------------
-- Note [diamond proc point]
--
-- This special case looks for the pattern we get from a typical
-- tagged case expression:
--
--    Sp[young(L1)] = L1
--    if (R1 & 7) != 0 goto L1 else goto L2
--  L2:
--    call [R1] returns to L1
--  L1: live: {y}
--    x = R1
--
-- If we let the generic case handle this, we get
--
--    Sp[-16] = L1
--    if (R1 & 7) != 0 goto L1a else goto L2
--  L2:
--    Sp[-8] = y
--    Sp = Sp - 16
--    call [R1] returns to L1
--  L1a:
--    Sp[-8] = y
--    Sp = Sp - 16
--    goto L1
--  L1:
--    x = R1
--
-- The code for saving the live vars is duplicated in each branch, and
-- furthermore there is an extra jump in the fast path (assuming L1 is
-- a proc point, which it probably is if there is a heap check).
--
-- So to fix this we want to set up the stack frame before the
-- conditional jump.  How do we know when to do this, and when it is
-- safe?  The basic idea is, when we see the assignment
--
--   Sp[young(L)] = L
--
-- we know that
--   * we are definitely heading for L
--   * there can be no more reads from another stack area, because young(L)
--     overlaps with it.
--
-- We don't necessarily know that everything live at L is live now
-- (some might be assigned between here and the jump to L).  So we
-- simplify and only do the optimisation when we see
--
--   (1) a block containing an assignment of a return address L
--   (2) ending in a branch where one (and only) continuation goes to L,
--       and no other continuations go to proc points.
--
-- then we allocate the stack frame for L at the end of the block,
-- before the branch.
--
-- We could generalise (2), but that would make it a bit more
-- complicated to handle, and this currently catches the common case.

futureContinuation :: Block CmmNode O O -> Maybe BlockId
futureContinuation :: Block CmmNode O O -> Maybe BlockId
futureContinuation Block CmmNode O O
middle = (forall (e :: Extensibility) (x :: Extensibility).
 CmmNode e x -> Maybe BlockId -> Maybe BlockId)
-> forall (e :: Extensibility) (x :: Extensibility).
   Block CmmNode e x
   -> IndexedCO x (Maybe BlockId) (Maybe BlockId)
   -> IndexedCO e (Maybe BlockId) (Maybe BlockId)
forall (n :: Extensibility -> Extensibility -> *) a.
(forall (e :: Extensibility) (x :: Extensibility). n e x -> a -> a)
-> forall (e :: Extensibility) (x :: Extensibility).
   Block n e x -> IndexedCO x a a -> IndexedCO e a a
foldBlockNodesB forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Maybe BlockId -> Maybe BlockId
f Block CmmNode O O
middle IndexedCO O (Maybe BlockId) (Maybe BlockId)
forall a. Maybe a
Nothing
   where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
         f :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Maybe BlockId -> Maybe BlockId
f (CmmStore (CmmStackSlot (Young BlockId
l) ByteOff
_) (CmmLit (CmmBlock BlockId
_))) Maybe BlockId
_
               = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
l
         f CmmNode a b
_ Maybe BlockId
r = Maybe BlockId
r

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

-- | Given a set of live registers and a StackMap, save all the registers
-- on the stack and return the new StackMap and the assignments to do
-- the saving.
--
allocate :: Platform -> ByteOff -> LocalRegSet -> StackMap
         -> (StackMap, [CmmNode O O])
allocate :: Platform
-> ByteOff -> CmmLocalLive -> StackMap -> (StackMap, [CmmNode O O])
allocate Platform
platform ByteOff
ret_off CmmLocalLive
live stackmap :: StackMap
stackmap@StackMap{ sm_sp :: StackMap -> ByteOff
sm_sp = ByteOff
sp0
                                              , sm_regs :: StackMap -> UniqFM LocalReg (LocalReg, ByteOff)
sm_regs = UniqFM LocalReg (LocalReg, ByteOff)
regs0 }
 =
   -- we only have to save regs that are not already in a slot
   let to_save :: [LocalReg]
to_save = (LocalReg -> Bool) -> [LocalReg] -> [LocalReg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (LocalReg -> Bool) -> LocalReg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalReg -> UniqFM LocalReg (LocalReg, ByteOff) -> Bool
forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
`elemUFM` UniqFM LocalReg (LocalReg, ByteOff)
regs0)) (CmmLocalLive -> [LocalReg]
forall a. Set a -> [a]
Set.elems CmmLocalLive
live)
       regs1 :: UniqFM LocalReg (LocalReg, ByteOff)
regs1   = ((LocalReg, ByteOff) -> Bool)
-> UniqFM LocalReg (LocalReg, ByteOff)
-> UniqFM LocalReg (LocalReg, ByteOff)
forall elt key. (elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM (\(LocalReg
r,ByteOff
_) -> LocalReg -> CmmLocalLive -> Bool
forall r. Ord r => r -> RegSet r -> Bool
elemRegSet LocalReg
r CmmLocalLive
live) UniqFM LocalReg (LocalReg, ByteOff)
regs0
   in

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

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

       -- we should do better here: right now we'll fit the smallest first,
       -- but it would make more sense to fit the biggest first.
       select_save :: [LocalReg] -> [StackSlot]
                   -> Maybe ([StackSlot], LocalReg, [LocalReg])
       select_save :: [LocalReg]
-> [StackSlot] -> Maybe ([StackSlot], LocalReg, [LocalReg])
select_save [LocalReg]
regs [StackSlot]
stack = [LocalReg]
-> [LocalReg] -> Maybe ([StackSlot], LocalReg, [LocalReg])
go [LocalReg]
regs []
         where go :: [LocalReg]
-> [LocalReg] -> Maybe ([StackSlot], LocalReg, [LocalReg])
go []     [LocalReg]
_no_fit = Maybe ([StackSlot], LocalReg, [LocalReg])
forall a. Maybe a
Nothing
               go (LocalReg
r:[LocalReg]
rs) [LocalReg]
no_fit
                 | Just [StackSlot]
rest <- ByteOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty ByteOff
words [StackSlot]
stack
                 = ([StackSlot], LocalReg, [LocalReg])
-> Maybe ([StackSlot], LocalReg, [LocalReg])
forall a. a -> Maybe a
Just (ByteOff -> StackSlot -> [StackSlot]
forall a. ByteOff -> a -> [a]
replicate ByteOff
words StackSlot
Occupied [StackSlot] -> [StackSlot] -> [StackSlot]
forall a. [a] -> [a] -> [a]
++ [StackSlot]
rest, LocalReg
r, [LocalReg]
rs[LocalReg] -> [LocalReg] -> [LocalReg]
forall a. [a] -> [a] -> [a]
++[LocalReg]
no_fit)
                 | Bool
otherwise
                 = [LocalReg]
-> [LocalReg] -> Maybe ([StackSlot], LocalReg, [LocalReg])
go [LocalReg]
rs (LocalReg
rLocalReg -> [LocalReg] -> [LocalReg]
forall a. a -> [a] -> [a]
:[LocalReg]
no_fit)
                 where words :: ByteOff
words = Platform -> LocalReg -> ByteOff
localRegWords Platform
platform LocalReg
r

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

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

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

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

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

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

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


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

-- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp.  The
-- block looks like this:
--
--    middle_pre       -- the middle nodes
--    Sp = Sp + sp_off -- Sp adjustment goes here
--    last             -- the last node
--
-- And we have some extra blocks too (that don't contain Sp adjustments)
--
-- The adjustment for middle_pre will be different from that for
-- middle_post, because the Sp adjustment intervenes.
--
manifestSp
   :: DynFlags
   -> LabelMap StackMap  -- StackMaps for other blocks
   -> StackMap           -- StackMap for this block
   -> ByteOff            -- Sp on entry to the block
   -> ByteOff            -- SpHigh
   -> CmmNode C O        -- first node
   -> [CmmNode O O]      -- middle
   -> ByteOff            -- sp_off
   -> CmmNode O C        -- last node
   -> [CmmBlock]         -- new blocks
   -> [CmmBlock]         -- final blocks with Sp manifest

manifestSp :: DynFlags
-> LabelMap StackMap
-> StackMap
-> ByteOff
-> ByteOff
-> CmmNode C O
-> [CmmNode O O]
-> ByteOff
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp DynFlags
dflags LabelMap StackMap
stackmaps StackMap
stack0 ByteOff
sp0 ByteOff
sp_high
           CmmNode C O
first [CmmNode O O]
middle_pre ByteOff
sp_off CmmNode O C
last [CmmBlock]
fixup_blocks
  = CmmBlock
final_block CmmBlock -> [CmmBlock] -> [CmmBlock]
forall a. a -> [a] -> [a]
: [CmmBlock]
fixup_blocks'
  where
    area_off :: Area -> ByteOff
area_off = LabelMap StackMap -> Area -> ByteOff
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  = (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep (Platform
-> ByteOff -> ByteOff -> (Area -> ByteOff) -> CmmExpr -> CmmExpr
areaToSp Platform
platform ByteOff
sp0            ByteOff
sp_high Area -> ByteOff
area_off)
    adj_post_sp :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_post_sp = (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep (Platform
-> ByteOff -> ByteOff -> (Area -> ByteOff) -> CmmExpr -> CmmExpr
areaToSp Platform
platform (ByteOff
sp0 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
sp_off) ByteOff
sp_high Area -> ByteOff
area_off)

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

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

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

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


maybeAddSpAdj
  :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj :: DynFlags
-> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj DynFlags
dflags ByteOff
sp0 ByteOff
sp_off Block CmmNode O O
block =
  Block CmmNode O O -> Block CmmNode O O
add_initial_unwind (Block CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> Block CmmNode O O
forall a b. (a -> b) -> a -> b
$ Block CmmNode O O -> Block CmmNode O O
add_adj_unwind (Block CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> Block CmmNode O O
forall a b. (a -> b) -> a -> b
$ Block CmmNode O O -> Block CmmNode O O
adj Block CmmNode O O
block
  where
    platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    adj :: Block CmmNode O O -> Block CmmNode O O
adj Block CmmNode O O
block
      | ByteOff
sp_off ByteOff -> ByteOff -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteOff
0
      = Block CmmNode O O
block Block CmmNode O O -> CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O O -> Block n e O
`blockSnoc` CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
spReg (Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset Platform
platform CmmExpr
spExpr ByteOff
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 -> ByteOff
debugLevel DynFlags
dflags ByteOff -> ByteOff -> Bool
forall a. Ord a => a -> a -> Bool
> ByteOff
0
      = [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
CmmUnwind [(GlobalReg
Sp, CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just CmmExpr
sp_unwind)] CmmNode O O -> Block CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
n O O -> Block n O x -> Block n O x
`blockCons` Block CmmNode O O
block
      | Bool
otherwise
      = Block CmmNode O O
block
      where sp_unwind :: CmmExpr
sp_unwind = CmmReg -> ByteOff -> CmmExpr
CmmRegOff CmmReg
spReg (ByteOff
sp0 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- Platform -> ByteOff
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 -> ByteOff
debugLevel DynFlags
dflags ByteOff -> ByteOff -> Bool
forall a. Ord a => a -> a -> Bool
> ByteOff
0
      , ByteOff
sp_off ByteOff -> ByteOff -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteOff
0
      = Block CmmNode O O
block Block CmmNode O O -> CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O O -> Block n e O
`blockSnoc` [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
CmmUnwind [(GlobalReg
Sp, CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just CmmExpr
sp_unwind)]
      | Bool
otherwise
      = Block CmmNode O O
block
      where sp_unwind :: CmmExpr
sp_unwind = CmmReg -> ByteOff -> CmmExpr
CmmRegOff CmmReg
spReg (ByteOff
sp0 ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- Platform -> ByteOff
platformWordSizeInBytes Platform
platform ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
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
-> ByteOff -> ByteOff -> (Area -> ByteOff) -> CmmExpr -> CmmExpr
areaToSp Platform
platform ByteOff
sp_old ByteOff
_sp_hwm Area -> ByteOff
area_off (CmmStackSlot Area
area ByteOff
n)
  = Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset Platform
platform CmmExpr
spExpr (ByteOff
sp_old ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- Area -> ByteOff
area_off Area
area ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
n)
    -- Replace (CmmStackSlot area n) with an offset from Sp

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

areaToSp Platform
_ ByteOff
_ ByteOff
_ Area -> ByteOff
_ 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) ByteOff
x_off
                      , CmmLit (CmmInt Integer
y_lit Width
_)]
                , CmmReg (CmmGlobal GlobalReg
SpLim)]
  = ByteOff -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteOff
x_off Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
y_lit
falseStackCheck [CmmExpr]
_ = Bool
False

-- Note [Always false stack check]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- We can optimise stack checks of the form
--
--   if ((Sp + x) - y < SpLim) then .. else ..
--
-- where are non-negative integer byte offsets.  Since we know that
-- SpLim <= Sp (remember the stack grows downwards), this test must
-- yield False if (x >= y), so we can rewrite the comparison to False.
-- A subsequent sinking pass will later drop the dead code.
-- Optimising this away depends on knowing that SpLim <= Sp, so it is
-- really the job of the stack layout algorithm, hence we do it now.
--
-- The control flow optimiser may negate a conditional to increase
-- the likelihood of a fallthrough if the branch is not taken.  But
-- not every conditional is inverted as the control flow optimiser
-- places some requirements on the predecessors of both branch targets.
-- So we better look for the inverted comparison too.

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


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

-- | Eliminate stores of the form
--
--    Sp[area+n] = r
--
-- when we know that r is already in the same slot as Sp[area+n].  We
-- could do this in a later optimisation pass, but that would involve
-- a separate analysis and we already have the information to hand
-- here.  It helps clean up some extra stack stores in common cases.
--
-- Note that we may have to modify the StackMap as we walk through the
-- code using procMiddle, since an assignment to a variable in the
-- StackMap will invalidate its mapping there.
--
elimStackStores :: StackMap
                -> LabelMap StackMap
                -> (Area -> ByteOff)
                -> [CmmNode O O]
                -> [CmmNode O O]
elimStackStores :: StackMap
-> LabelMap StackMap
-> (Area -> ByteOff)
-> [CmmNode O O]
-> [CmmNode O O]
elimStackStores StackMap
stackmap LabelMap StackMap
stackmaps Area -> ByteOff
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 ByteOff
m) (CmmReg (CmmLocal LocalReg
r))
            | Just (LocalReg
_,ByteOff
off) <- UniqFM LocalReg (LocalReg, ByteOff)
-> LocalReg -> Maybe (LocalReg, ByteOff)
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (StackMap -> UniqFM LocalReg (LocalReg, ByteOff)
sm_regs StackMap
stackmap) LocalReg
r
            , Area -> ByteOff
area_off Area
area ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
m ByteOff -> ByteOff -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOff
off
            -> StackMap -> [CmmNode O O] -> [CmmNode O O]
go StackMap
stackmap [CmmNode O O]
ns
         CmmNode O O
_otherwise
            -> CmmNode O O
n CmmNode O O -> [CmmNode O O] -> [CmmNode O O]
forall a. a -> [a] -> [a]
: StackMap -> [CmmNode O O] -> [CmmNode O O]
go (LabelMap StackMap -> CmmNode O O -> StackMap -> StackMap
forall (e :: Extensibility) (x :: Extensibility).
LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle LabelMap StackMap
stackmaps CmmNode O O
n StackMap
stackmap) [CmmNode O O]
ns


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


setInfoTableStackMap :: 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)
  = CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
top_info{ info_tbls :: LabelMap CmmInfoTable
info_tbls = (KeyOf LabelMap -> CmmInfoTable -> CmmInfoTable)
-> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
forall (map :: * -> *) a b.
IsMap map =>
(KeyOf map -> a -> b) -> map a -> map b
mapMapWithKey KeyOf LabelMap -> CmmInfoTable -> CmmInfoTable
BlockId -> CmmInfoTable -> CmmInfoTable
fix_info LabelMap CmmInfoTable
info_tbls } CLabel
l [GlobalReg]
v CmmGraph
g
  where
    fix_info :: BlockId -> CmmInfoTable -> CmmInfoTable
fix_info BlockId
lbl info_tbl :: CmmInfoTable
info_tbl@CmmInfoTable{ cit_rep :: CmmInfoTable -> SMRep
cit_rep = StackRep Liveness
_ } =
       CmmInfoTable
info_tbl { cit_rep :: SMRep
cit_rep = Liveness -> SMRep
StackRep (BlockId -> Liveness
get_liveness BlockId
lbl) }
    fix_info BlockId
_ CmmInfoTable
other = CmmInfoTable
other

    get_liveness :: BlockId -> Liveness
    get_liveness :: BlockId -> Liveness
get_liveness BlockId
lbl
      = case KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
lbl LabelMap StackMap
stackmaps of
          Maybe StackMap
Nothing -> String -> SDoc -> Liveness
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"setInfoTableStackMap" (BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
lbl SDoc -> SDoc -> SDoc
<+> LabelMap CmmInfoTable -> SDoc
forall a. Outputable a => a -> SDoc
ppr LabelMap CmmInfoTable
info_tbls)
          Just StackMap
sm -> 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{ByteOff
UniqFM LocalReg (LocalReg, ByteOff)
sm_regs :: UniqFM LocalReg (LocalReg, ByteOff)
sm_ret_off :: ByteOff
sm_args :: ByteOff
sm_sp :: ByteOff
sm_regs :: StackMap -> UniqFM LocalReg (LocalReg, ByteOff)
sm_ret_off :: StackMap -> ByteOff
sm_args :: StackMap -> ByteOff
sm_sp :: StackMap -> ByteOff
..} =
   Liveness -> Liveness
forall a. [a] -> [a]
reverse (Liveness -> Liveness) -> Liveness -> Liveness
forall a b. (a -> b) -> a -> b
$ Array ByteOff Bool -> Liveness
forall i e. Array i e -> [e]
Array.elems (Array ByteOff Bool -> Liveness) -> Array ByteOff Bool -> Liveness
forall a b. (a -> b) -> a -> b
$
        (Bool -> Bool -> Bool)
-> Bool
-> (ByteOff, ByteOff)
-> [(ByteOff, Bool)]
-> Array ByteOff Bool
forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray (\Bool
_ Bool
x -> Bool
x) Bool
True (Platform -> ByteOff -> ByteOff
toWords Platform
platform ByteOff
sm_ret_off ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
1,
                                     Platform -> ByteOff -> ByteOff
toWords Platform
platform (ByteOff
sm_sp ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
sm_args)) [(ByteOff, Bool)]
live_words
   where
     live_words :: [(ByteOff, Bool)]
live_words =  [ (Platform -> ByteOff -> ByteOff
toWords Platform
platform ByteOff
off, Bool
False)
                   | (LocalReg
r,ByteOff
off) <- UniqFM LocalReg (LocalReg, ByteOff) -> [(LocalReg, ByteOff)]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM LocalReg (LocalReg, ByteOff)
sm_regs
                   , CmmType -> Bool
isGcPtrType (LocalReg -> CmmType
localRegType LocalReg
r) ]
                   -- See Note [Unique Determinism and code generation]

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

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

            -- Merge the liveness from successor blocks and analyse the last
            -- node.
            joined :: CmmLocalLive
joined = DynFlags -> CmmNode O C -> CmmLocalLive -> CmmLocalLive
forall r n.
(DefinerOfRegs r n, UserOfRegs r n) =>
DynFlags -> n -> CmmLive r -> CmmLive r
gen_kill DynFlags
dflags CmmNode O C
x_node (CmmLocalLive -> CmmLocalLive) -> CmmLocalLive -> CmmLocalLive
forall a b. (a -> b) -> a -> b
$!
                         DataflowLattice CmmLocalLive
-> CmmNode O C -> BlockEntryLiveness LocalReg -> CmmLocalLive
forall (n :: Extensibility -> Extensibility -> *) f
       (e :: Extensibility).
NonLocal n =>
DataflowLattice f -> n e C -> FactBase f -> f
joinOutFacts DataflowLattice CmmLocalLive
forall r. Ord r => DataflowLattice (CmmLive r)
liveLattice CmmNode O C
x_node BlockEntryLiveness LocalReg
fact_base0
            -- What is live at the start of middle0.
            live_at_middle0 :: CmmLocalLive
live_at_middle0 = (CmmNode O O -> CmmLocalLive -> CmmLocalLive)
-> Block CmmNode O O -> CmmLocalLive -> CmmLocalLive
forall f. (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
foldNodesBwdOO (DynFlags -> CmmNode O O -> CmmLocalLive -> CmmLocalLive
forall r n.
(DefinerOfRegs r n, UserOfRegs r n) =>
DynFlags -> n -> CmmLive r -> CmmLive r
gen_kill DynFlags
dflags) Block CmmNode O O
middle0 CmmLocalLive
joined

            -- If this is a procpoint we need to add the reloads, but only if
            -- they're actually live. Furthermore, nothing is live at the entry
            -- to a proc point.
            (Block CmmNode O O
middle1, CmmLocalLive
live_with_reloads)
                | ElemOf ProcPointSet
BlockId
entry_label ElemOf ProcPointSet -> ProcPointSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints
                = let reloads :: [CmmNode O O]
reloads = Platform -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads Platform
platform StackMap
stackmap CmmLocalLive
live_at_middle0
                  in ((CmmNode O O -> Block CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> [CmmNode O O] -> Block CmmNode O O
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmNode O O -> Block CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
n O O -> Block n O x -> Block n O x
blockCons Block CmmNode O O
middle0 [CmmNode O O]
reloads, CmmLocalLive
forall a. Set a
emptyRegSet)
                | Bool
otherwise
                = (Block CmmNode O O
middle0, CmmLocalLive
live_at_middle0)

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

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

insertReloads :: 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 -> CmmExpr
CmmLoad (Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset Platform
platform CmmExpr
spExpr (ByteOff
sp_off ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
reg_off))
                          (LocalReg -> CmmType
localRegType LocalReg
reg))
     | (LocalReg
reg, ByteOff
reg_off) <- StackMap -> [(LocalReg, ByteOff)]
stackSlotRegs StackMap
stackmap
     , LocalReg
reg LocalReg -> CmmLocalLive -> Bool
forall r. Ord r => r -> RegSet r -> Bool
`elemRegSet` CmmLocalLive
live
     ]
   where
     sp_off :: ByteOff
sp_off = StackMap -> ByteOff
sm_sp StackMap
stackmap

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

{-
Note [Lower safe foreign calls]

We start with

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

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

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

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

lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall DynFlags
dflags CmmBlock
block
  | (entry :: CmmNode C O
entry@(CmmEntry BlockId
_ CmmTickScope
tscp), Block CmmNode O O
middle, CmmForeignCall { Bool
ByteOff
[CmmExpr]
[LocalReg]
BlockId
ForeignTarget
intrbl :: Bool
ret_off :: ByteOff
ret_args :: ByteOff
succ :: BlockId
args :: [CmmExpr]
res :: [LocalReg]
tgt :: ForeignTarget
tgt :: CmmNode O C -> ForeignTarget
succ :: CmmNode O C -> BlockId
ret_off :: CmmNode O C -> ByteOff
ret_args :: CmmNode O C -> ByteOff
res :: CmmNode O C -> [LocalReg]
intrbl :: CmmNode O C -> Bool
args :: CmmNode O C -> [CmmExpr]
.. }) <- CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
  = do
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    -- Both 'id' and 'new_base' are KindNonPtr because they're
    -- RTS-only objects and are not subject to garbage collection
    LocalReg
id <- CmmType -> UniqSM LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
bWord Platform
platform)
    LocalReg
new_base <- CmmType -> UniqSM LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
baseReg)
    let (CmmAGraph
caller_save, CmmAGraph
caller_load) = DynFlags -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs DynFlags
dflags
    CmmAGraph
save_state_code <- DynFlags -> UniqSM CmmAGraph
forall (m :: * -> *). MonadUnique m => DynFlags -> m CmmAGraph
saveThreadState DynFlags
dflags
    CmmAGraph
load_state_code <- DynFlags -> UniqSM CmmAGraph
forall (m :: * -> *). MonadUnique m => DynFlags -> m CmmAGraph
loadThreadState DynFlags
dflags
    let suspend :: CmmAGraph
suspend = CmmAGraph
save_state_code  CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
                  CmmAGraph
caller_save CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
                  CmmNode O O -> CmmAGraph
mkMiddle (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

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

        -- NB. after resumeThread returns, the top-of-stack probably contains
        -- the stack frame for succ, but it might not: if the current thread
        -- received an exception during the call, then the stack might be
        -- different.  Hence we continue by jumping to the top stack frame,
        -- not by jumping to succ.
        jump :: CmmNode O C
jump = CmmCall :: CmmExpr
-> Maybe BlockId
-> [GlobalReg]
-> ByteOff
-> ByteOff
-> ByteOff
-> CmmNode O C
CmmCall { cml_target :: CmmExpr
cml_target    = Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
forall a b. (a -> b) -> a -> b
$
                                         CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
spExpr (Platform -> CmmType
bWord Platform
platform)
                       , cml_cont :: Maybe BlockId
cml_cont      = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
succ
                       , cml_args_regs :: [GlobalReg]
cml_args_regs = [GlobalReg]
regs
                       , cml_args :: ByteOff
cml_args      = Width -> ByteOff
widthInBytes (Platform -> Width
wordWidth Platform
platform)
                       , cml_ret_args :: ByteOff
cml_ret_args  = ByteOff
ret_args
                       , cml_ret_off :: ByteOff
cml_ret_off   = ByteOff
ret_off }

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

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

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


foreignLbl :: FastString -> CmmExpr
foreignLbl :: FastString -> CmmExpr
foreignLbl FastString
name = CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (FastString
-> Maybe ByteOff -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
name Maybe ByteOff
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 -> ByteOff -> CmmExpr
mkIntExpr Platform
platform (Bool -> ByteOff
forall a. Enum a => a -> ByteOff
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 -> ByteOff -> ByteOff -> ByteOff
plusW Platform
platform ByteOff
b ByteOff
w = ByteOff
b ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
w ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
* Platform -> ByteOff
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 :: ByteOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty ByteOff
0 [StackSlot]
ss           = [StackSlot] -> Maybe [StackSlot]
forall a. a -> Maybe a
Just [StackSlot]
ss
dropEmpty ByteOff
n (StackSlot
Empty : [StackSlot]
ss) = ByteOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty (ByteOff
nByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
-ByteOff
1) [StackSlot]
ss
dropEmpty ByteOff
_ [StackSlot]
_            = Maybe [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 -> ByteOff
localRegBytes Platform
platform LocalReg
r
    = Platform -> ByteOff -> ByteOff
roundUpToWords Platform
platform (Width -> ByteOff
widthInBytes (CmmType -> Width
typeWidth (LocalReg -> CmmType
localRegType LocalReg
r)))

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

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


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