{-# LANGUAGE BangPatterns, GADTs #-}

module GHC.Cmm.Graph
  ( CmmAGraph, CmmAGraphScoped, CgStmt(..)
  , (<*>), catAGraphs
  , mkLabel, mkMiddle, mkLast, outOfLine
  , lgraphOfAGraph, labelAGraph

  , stackStubExpr
  , mkNop, mkAssign, mkStore
  , mkUnsafeCall, mkFinalCall, mkCallReturnsTo
  , mkJumpReturnsTo
  , mkJump, mkJumpExtra
  , mkRawJump
  , mkCbranch, mkSwitch
  , mkReturn, mkComment, mkCallEntry, mkBranch
  , mkUnwind
  , copyInOflow, copyOutOflow
  , noExtraStack
  , toCall, Transfer(..)
  )
where

import GHC.Prelude hiding ( (<*>) ) -- avoid importing (<*>)

import GHC.Platform.Profile

import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.CallConv
import GHC.Cmm.Switch (SwitchTargets)

import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Data.FastString
import GHC.Types.ForeignCall
import GHC.Data.OrdList
import GHC.Runtime.Heap.Layout (ByteOff)
import GHC.Types.Unique.Supply
import GHC.Utils.Misc
import GHC.Utils.Panic


-----------------------------------------------------------------------------
-- Building Graphs


-- | CmmAGraph is a chunk of code consisting of:
--
--   * ordinary statements (assignments, stores etc.)
--   * jumps
--   * labels
--   * out-of-line labelled blocks
--
-- The semantics is that control falls through labels and out-of-line
-- blocks.  Everything after a jump up to the next label is by
-- definition unreachable code, and will be discarded.
--
-- Two CmmAGraphs can be stuck together with <*>, with the meaning that
-- control flows from the first to the second.
--
-- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)
-- by providing a label for the entry point and a tick scope; see
-- 'labelAGraph'.
type CmmAGraph = OrdList CgStmt
-- | Unlabeled graph with tick scope
type CmmAGraphScoped = (CmmAGraph, CmmTickScope)

data CgStmt
  = CgLabel BlockId CmmTickScope
  | CgStmt  (CmmNode O O)
  | CgLast  (CmmNode O C)
  | CgFork  BlockId CmmAGraph CmmTickScope

flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
flattenCmmAGraph BlockId
id (CmmAGraph
stmts_t, CmmTickScope
tscope) =
    CmmGraph { g_entry :: BlockId
g_entry = BlockId
id,
               g_graph :: Graph CmmNode C C
g_graph = forall (e :: Extensibility)
       (block :: (Extensibility -> Extensibility -> *)
                 -> Extensibility -> Extensibility -> *)
       (n :: Extensibility -> Extensibility -> *) (x :: Extensibility).
MaybeO e (block n O C)
-> Body' block n -> MaybeO x (block n C O) -> Graph' block n e x
GMany forall t. MaybeO C t
NothingO LabelMap (Block CmmNode C C)
body forall t. MaybeO C t
NothingO }
  where
  body :: LabelMap (Block CmmNode C C)
body = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (block :: Extensibility -> Extensibility -> *).
(NonLocal block, HasDebugCallStack) =>
block C C -> LabelMap (block C C) -> LabelMap (block C C)
addBlock forall (block :: (Extensibility -> Extensibility -> *)
                 -> Extensibility -> Extensibility -> *)
       (n :: Extensibility -> Extensibility -> *).
Body' block n
emptyBody forall a b. (a -> b) -> a -> b
$ BlockId
-> CmmAGraph
-> CmmTickScope
-> [Block CmmNode C C]
-> [Block CmmNode C C]
flatten BlockId
id CmmAGraph
stmts_t CmmTickScope
tscope []

  --
  -- flatten: given an entry label and a CmmAGraph, make a list of blocks.
  --
  -- NB. avoid the quadratic-append trap by passing in the tail of the
  -- list.  This is important for Very Long Functions (e.g. in T783).
  --
  flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]
          -> [Block CmmNode C C]
  flatten :: BlockId
-> CmmAGraph
-> CmmTickScope
-> [Block CmmNode C C]
-> [Block CmmNode C C]
flatten BlockId
id CmmAGraph
g CmmTickScope
tscope [Block CmmNode C C]
blocks
      = [CgStmt]
-> Block CmmNode C O -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 (forall a. OrdList a -> [a]
fromOL CmmAGraph
g) Block CmmNode C O
block' [Block CmmNode C C]
blocks
      where !block' :: Block CmmNode C O
block' = forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
n C O -> Block n O x -> Block n C x
blockJoinHead (BlockId -> CmmTickScope -> CmmNode C O
CmmEntry BlockId
id CmmTickScope
tscope) forall (n :: Extensibility -> Extensibility -> *). Block n O O
emptyBlock
  --
  -- flatten0: we are outside a block at this point: any code before
  -- the first label is unreachable, so just drop it.
  --
  flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
  flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [] [Block CmmNode C C]
blocks = [Block CmmNode C C]
blocks

  flatten0 (CgLabel BlockId
id CmmTickScope
tscope : [CgStmt]
stmts) [Block CmmNode C C]
blocks
    = [CgStmt]
-> Block CmmNode C O -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 [CgStmt]
stmts Block CmmNode C O
block [Block CmmNode C C]
blocks
    where !block :: Block CmmNode C O
block = forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
n C O -> Block n O x -> Block n C x
blockJoinHead (BlockId -> CmmTickScope -> CmmNode C O
CmmEntry BlockId
id CmmTickScope
tscope) forall (n :: Extensibility -> Extensibility -> *). Block n O O
emptyBlock

  flatten0 (CgFork BlockId
fork_id CmmAGraph
stmts_t CmmTickScope
tscope : [CgStmt]
rest) [Block CmmNode C C]
blocks
    = BlockId
-> CmmAGraph
-> CmmTickScope
-> [Block CmmNode C C]
-> [Block CmmNode C C]
flatten BlockId
fork_id CmmAGraph
stmts_t CmmTickScope
tscope forall a b. (a -> b) -> a -> b
$ [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [CgStmt]
rest [Block CmmNode C C]
blocks

  flatten0 (CgLast CmmNode O C
_ : [CgStmt]
stmts) [Block CmmNode C C]
blocks = [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [CgStmt]
stmts [Block CmmNode C C]
blocks
  flatten0 (CgStmt CmmNode O O
_ : [CgStmt]
stmts) [Block CmmNode C C]
blocks = [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [CgStmt]
stmts [Block CmmNode C C]
blocks

  --
  -- flatten1: we have a partial block, collect statements until the
  -- next last node to make a block, then call flatten0 to get the rest
  -- of the blocks
  --
  flatten1 :: [CgStmt] -> Block CmmNode C O
           -> [Block CmmNode C C] -> [Block CmmNode C C]

  -- The current block falls through to the end of a function or fork:
  -- this code should not be reachable, but it may be referenced by
  -- other code that is not reachable.  We'll remove it later with
  -- dead-code analysis, but for now we have to keep the graph
  -- well-formed, so we terminate the block with a branch to the
  -- beginning of the current block.
  flatten1 :: [CgStmt]
-> Block CmmNode C O -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 [] Block CmmNode C O
block [Block CmmNode C C]
blocks
    = forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O C -> Block n e C
blockJoinTail Block CmmNode C O
block (BlockId -> CmmNode O C
CmmBranch (forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel Block CmmNode C O
block)) forall a. a -> [a] -> [a]
: [Block CmmNode C C]
blocks

  flatten1 (CgLast CmmNode O C
stmt : [CgStmt]
stmts) Block CmmNode C O
block [Block CmmNode C C]
blocks
    = Block CmmNode C C
block' forall a. a -> [a] -> [a]
: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [CgStmt]
stmts [Block CmmNode C C]
blocks
    where !block' :: Block CmmNode C C
block' = forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O C -> Block n e C
blockJoinTail Block CmmNode C O
block CmmNode O C
stmt

  flatten1 (CgStmt CmmNode O O
stmt : [CgStmt]
stmts) Block CmmNode C O
block [Block CmmNode C C]
blocks
    = [CgStmt]
-> Block CmmNode C O -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 [CgStmt]
stmts Block CmmNode C O
block' [Block CmmNode C C]
blocks
    where !block' :: Block CmmNode C O
block' = forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O O -> Block n e O
blockSnoc Block CmmNode C O
block CmmNode O O
stmt

  flatten1 (CgFork BlockId
fork_id CmmAGraph
stmts_t CmmTickScope
tscope : [CgStmt]
rest) Block CmmNode C O
block [Block CmmNode C C]
blocks
    = BlockId
-> CmmAGraph
-> CmmTickScope
-> [Block CmmNode C C]
-> [Block CmmNode C C]
flatten BlockId
fork_id CmmAGraph
stmts_t CmmTickScope
tscope forall a b. (a -> b) -> a -> b
$ [CgStmt]
-> Block CmmNode C O -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 [CgStmt]
rest Block CmmNode C O
block [Block CmmNode C C]
blocks

  -- a label here means that we should start a new block, and the
  -- current block should fall through to the new block.
  flatten1 (CgLabel BlockId
id CmmTickScope
tscp : [CgStmt]
stmts) Block CmmNode C O
block [Block CmmNode C C]
blocks
    = forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e O -> n O C -> Block n e C
blockJoinTail Block CmmNode C O
block (BlockId -> CmmNode O C
CmmBranch BlockId
id) forall a. a -> [a] -> [a]
:
      [CgStmt]
-> Block CmmNode C O -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 [CgStmt]
stmts (forall (n :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
n C O -> Block n O x -> Block n C x
blockJoinHead (BlockId -> CmmTickScope -> CmmNode C O
CmmEntry BlockId
id CmmTickScope
tscp) forall (n :: Extensibility -> Extensibility -> *). Block n O O
emptyBlock) [Block CmmNode C C]
blocks



---------- AGraph manipulation

(<*>)          :: CmmAGraph -> CmmAGraph -> CmmAGraph
<*> :: CmmAGraph -> CmmAGraph -> CmmAGraph
(<*>)           = forall a. OrdList a -> OrdList a -> OrdList a
appOL

catAGraphs     :: [CmmAGraph] -> CmmAGraph
catAGraphs :: [CmmAGraph] -> CmmAGraph
catAGraphs      = forall a. [OrdList a] -> OrdList a
concatOL

-- | creates a sequence "goto id; id:" as an AGraph
mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph
mkLabel :: BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
bid CmmTickScope
scp = forall a. a -> OrdList a
unitOL (BlockId -> CmmTickScope -> CgStmt
CgLabel BlockId
bid CmmTickScope
scp)

-- | creates an open AGraph from a given node
mkMiddle        :: CmmNode O O -> CmmAGraph
mkMiddle :: CmmNode O O -> CmmAGraph
mkMiddle CmmNode O O
middle = forall a. a -> OrdList a
unitOL (CmmNode O O -> CgStmt
CgStmt CmmNode O O
middle)

-- | creates a closed AGraph from a given node
mkLast         :: CmmNode O C -> CmmAGraph
mkLast :: CmmNode O C -> CmmAGraph
mkLast CmmNode O C
last     = forall a. a -> OrdList a
unitOL (CmmNode O C -> CgStmt
CgLast CmmNode O C
last)

-- | A labelled code block; should end in a last node
outOfLine      :: BlockId -> CmmAGraphScoped -> CmmAGraph
outOfLine :: BlockId -> CmmAGraphScoped -> CmmAGraph
outOfLine BlockId
l (CmmAGraph
c,CmmTickScope
s) = forall a. a -> OrdList a
unitOL (BlockId -> CmmAGraph -> CmmTickScope -> CgStmt
CgFork BlockId
l CmmAGraph
c CmmTickScope
s)

-- | allocate a fresh label for the entry point
lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph
lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph
lgraphOfAGraph CmmAGraphScoped
g = do
  Unique
u <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
  forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> CmmAGraphScoped -> CmmGraph
labelAGraph (Unique -> BlockId
mkBlockId Unique
u) CmmAGraphScoped
g)

-- | use the given BlockId as the label of the entry point
labelAGraph    :: BlockId -> CmmAGraphScoped -> CmmGraph
labelAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
labelAGraph BlockId
lbl CmmAGraphScoped
ag = BlockId -> CmmAGraphScoped -> CmmGraph
flattenCmmAGraph BlockId
lbl CmmAGraphScoped
ag

---------- No-ops
mkNop        :: CmmAGraph
mkNop :: CmmAGraph
mkNop         = forall a. OrdList a
nilOL

mkComment    :: FastString -> CmmAGraph
mkComment :: FastString -> CmmAGraph
mkComment FastString
fs
  -- SDM: generating all those comments takes time, this saved about 4% for me
  | Bool
debugIsOn = CmmNode O O -> CmmAGraph
mkMiddle forall a b. (a -> b) -> a -> b
$ FastString -> CmmNode O O
CmmComment FastString
fs
  | Bool
otherwise = forall a. OrdList a
nilOL

---------- Assignment and store
mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
l (CmmReg CmmReg
r) | CmmReg
l forall a. Eq a => a -> a -> Bool
== CmmReg
r  = CmmAGraph
mkNop
mkAssign CmmReg
l CmmExpr
r  = CmmNode O O -> CmmAGraph
mkMiddle forall a b. (a -> b) -> a -> b
$ CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
l CmmExpr
r

-- | Assumes natural alignment
mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore  CmmExpr
l CmmExpr
r  = CmmNode O O -> CmmAGraph
mkMiddle forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode O O
CmmStore  CmmExpr
l CmmExpr
r AlignmentSpec
NaturallyAligned

---------- Control transfer
mkJump          :: Profile -> Convention -> CmmExpr
                -> [CmmExpr]
                -> UpdFrameOffset
                -> CmmAGraph
mkJump :: Profile
-> Convention -> CmmExpr -> [CmmExpr] -> ByteOff -> CmmAGraph
mkJump Profile
profile Convention
conv CmmExpr
e [CmmExpr]
actuals ByteOff
updfr_off =
  Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs Profile
profile Transfer
Jump Area
Old Convention
conv [CmmExpr]
actuals ByteOff
updfr_off forall a b. (a -> b) -> a -> b
$
    CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e forall a. Maybe a
Nothing ByteOff
updfr_off ByteOff
0

-- | A jump where the caller says what the live GlobalRegs are.  Used
-- for low-level hand-written Cmm.
mkRawJump       :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
                -> CmmAGraph
mkRawJump :: Profile -> CmmExpr -> ByteOff -> [GlobalReg] -> CmmAGraph
mkRawJump Profile
profile CmmExpr
e ByteOff
updfr_off [GlobalReg]
vols =
  Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs Profile
profile Transfer
Jump Area
Old Convention
NativeNodeCall [] ByteOff
updfr_off forall a b. (a -> b) -> a -> b
$
    \ByteOff
arg_space [GlobalReg]
_  -> CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e forall a. Maybe a
Nothing ByteOff
updfr_off ByteOff
0 ByteOff
arg_space [GlobalReg]
vols


mkJumpExtra :: Profile -> Convention -> CmmExpr -> [CmmExpr]
                -> UpdFrameOffset -> [CmmExpr]
                -> CmmAGraph
mkJumpExtra :: Profile
-> Convention
-> CmmExpr
-> [CmmExpr]
-> ByteOff
-> [CmmExpr]
-> CmmAGraph
mkJumpExtra Profile
profile Convention
conv CmmExpr
e [CmmExpr]
actuals ByteOff
updfr_off [CmmExpr]
extra_stack =
  Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> [CmmExpr]
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgsAndExtraStack Profile
profile Transfer
Jump Area
Old Convention
conv [CmmExpr]
actuals ByteOff
updfr_off [CmmExpr]
extra_stack forall a b. (a -> b) -> a -> b
$
    CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e forall a. Maybe a
Nothing ByteOff
updfr_off ByteOff
0

mkCbranch       :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch CmmExpr
pred BlockId
ifso BlockId
ifnot Maybe Bool
likely =
  CmmNode O C -> CmmAGraph
mkLast (CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
CmmCondBranch CmmExpr
pred BlockId
ifso BlockId
ifnot Maybe Bool
likely)

mkSwitch        :: CmmExpr -> SwitchTargets -> CmmAGraph
mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph
mkSwitch CmmExpr
e SwitchTargets
tbl   = CmmNode O C -> CmmAGraph
mkLast forall a b. (a -> b) -> a -> b
$ CmmExpr -> SwitchTargets -> CmmNode O C
CmmSwitch CmmExpr
e SwitchTargets
tbl

mkReturn        :: Profile -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
                -> CmmAGraph
mkReturn :: Profile -> CmmExpr -> [CmmExpr] -> ByteOff -> CmmAGraph
mkReturn Profile
profile CmmExpr
e [CmmExpr]
actuals ByteOff
updfr_off =
  Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs Profile
profile Transfer
Ret  Area
Old Convention
NativeReturn [CmmExpr]
actuals ByteOff
updfr_off forall a b. (a -> b) -> a -> b
$
    CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e forall a. Maybe a
Nothing ByteOff
updfr_off ByteOff
0

mkBranch        :: BlockId -> CmmAGraph
mkBranch :: BlockId -> CmmAGraph
mkBranch BlockId
bid     = CmmNode O C -> CmmAGraph
mkLast (BlockId -> CmmNode O C
CmmBranch BlockId
bid)

mkFinalCall   :: Profile
              -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset
              -> CmmAGraph
mkFinalCall :: Profile
-> CmmExpr -> CCallConv -> [CmmExpr] -> ByteOff -> CmmAGraph
mkFinalCall Profile
profile CmmExpr
f CCallConv
_ [CmmExpr]
actuals ByteOff
updfr_off =
  Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs Profile
profile Transfer
Call Area
Old Convention
NativeDirectCall [CmmExpr]
actuals ByteOff
updfr_off forall a b. (a -> b) -> a -> b
$
    CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
f forall a. Maybe a
Nothing ByteOff
updfr_off ByteOff
0

mkCallReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
                -> BlockId
                -> ByteOff
                -> UpdFrameOffset
                -> [CmmExpr]
                -> CmmAGraph
mkCallReturnsTo :: Profile
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> ByteOff
-> ByteOff
-> [CmmExpr]
-> CmmAGraph
mkCallReturnsTo Profile
profile CmmExpr
f Convention
callConv [CmmExpr]
actuals BlockId
ret_lbl ByteOff
ret_off ByteOff
updfr_off [CmmExpr]
extra_stack =
  Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> [CmmExpr]
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgsAndExtraStack Profile
profile Transfer
Call (BlockId -> Area
Young BlockId
ret_lbl) Convention
callConv [CmmExpr]
actuals
    ByteOff
updfr_off [CmmExpr]
extra_stack forall a b. (a -> b) -> a -> b
$
      CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
f (forall a. a -> Maybe a
Just BlockId
ret_lbl) ByteOff
updfr_off ByteOff
ret_off

-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
-- already on the stack).
mkJumpReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
                -> BlockId
                -> ByteOff
                -> UpdFrameOffset
                -> CmmAGraph
mkJumpReturnsTo :: Profile
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> ByteOff
-> ByteOff
-> CmmAGraph
mkJumpReturnsTo Profile
profile CmmExpr
f Convention
callConv [CmmExpr]
actuals BlockId
ret_lbl ByteOff
ret_off ByteOff
updfr_off =
  Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs Profile
profile Transfer
JumpRet (BlockId -> Area
Young BlockId
ret_lbl) Convention
callConv [CmmExpr]
actuals ByteOff
updfr_off forall a b. (a -> b) -> a -> b
$
    CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
f (forall a. a -> Maybe a
Just BlockId
ret_lbl) ByteOff
updfr_off ByteOff
ret_off

mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmAGraph
mkUnsafeCall ForeignTarget
t [CmmFormal]
fs [CmmExpr]
as = CmmNode O O -> CmmAGraph
mkMiddle forall a b. (a -> b) -> a -> b
$ ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode O O
CmmUnsafeForeignCall ForeignTarget
t [CmmFormal]
fs [CmmExpr]
as

-- | Construct a 'CmmUnwind' node for the given register and unwinding
-- expression.
mkUnwind     :: GlobalReg -> CmmExpr -> CmmAGraph
mkUnwind :: GlobalReg -> CmmExpr -> CmmAGraph
mkUnwind GlobalReg
r CmmExpr
e  = CmmNode O O -> CmmAGraph
mkMiddle forall a b. (a -> b) -> a -> b
$ [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
CmmUnwind [(GlobalReg
r, forall a. a -> Maybe a
Just CmmExpr
e)]

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




-- Why are we inserting extra blocks that simply branch to the successors?
-- Because in addition to the branch instruction, @mkBranch@ will insert
-- a necessary adjustment to the stack pointer.


-- For debugging purposes, we can stub out dead stack slots:
stackStubExpr :: Width -> CmmExpr
stackStubExpr :: Width -> CmmExpr
stackStubExpr Width
w = CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
0 Width
w)

-- When we copy in parameters, we usually want to put overflow
-- parameters on the stack, but sometimes we want to pass the
-- variables in their spill slots.  Therefore, for copying arguments
-- and results, we provide different functions to pass the arguments
-- in an overflow area and to pass them in spill slots.
copyInOflow  :: Profile -> Convention -> Area
             -> [CmmFormal]
             -> [CmmFormal]
             -> (Int, [GlobalReg], CmmAGraph)

copyInOflow :: Profile
-> Convention
-> Area
-> [CmmFormal]
-> [CmmFormal]
-> (ByteOff, [GlobalReg], CmmAGraph)
copyInOflow Profile
profile Convention
conv Area
area [CmmFormal]
formals [CmmFormal]
extra_stk
  = (ByteOff
offset, [GlobalReg]
gregs, [CmmAGraph] -> CmmAGraph
catAGraphs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map CmmNode O O -> CmmAGraph
mkMiddle [CmmNode O O]
nodes)
  where (ByteOff
offset, [GlobalReg]
gregs, [CmmNode O O]
nodes) = Profile
-> Convention
-> Area
-> [CmmFormal]
-> [CmmFormal]
-> (ByteOff, [GlobalReg], [CmmNode O O])
copyIn Profile
profile Convention
conv Area
area [CmmFormal]
formals [CmmFormal]
extra_stk

-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
copyIn :: Profile -> Convention -> Area
       -> [CmmFormal]
       -> [CmmFormal]
       -> (ByteOff, [GlobalReg], [CmmNode O O])
copyIn :: Profile
-> Convention
-> Area
-> [CmmFormal]
-> [CmmFormal]
-> (ByteOff, [GlobalReg], [CmmNode O O])
copyIn Profile
profile Convention
conv Area
area [CmmFormal]
formals [CmmFormal]
extra_stk
  = (ByteOff
stk_size, [GlobalReg
r | (CmmFormal
_, RegisterParam GlobalReg
r) <- [(CmmFormal, ParamLocation)]
args], forall a b. (a -> b) -> [a] -> [b]
map (CmmFormal, ParamLocation) -> CmmNode O O
ci ([(CmmFormal, ParamLocation)]
stk_args forall a. [a] -> [a] -> [a]
++ [(CmmFormal, ParamLocation)]
args))
  where
    platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
    -- See Note [Width of parameters]
    ci :: (CmmFormal, ParamLocation) -> CmmNode O O
ci (CmmFormal
reg, RegisterParam r :: GlobalReg
r@(VanillaReg {})) =
        let local :: CmmReg
local = CmmFormal -> CmmReg
CmmLocal CmmFormal
reg
            global :: CmmExpr
global = CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r)
            width :: Width
width = Platform -> CmmReg -> Width
cmmRegWidth Platform
platform CmmReg
local
            expr :: CmmExpr
expr
                | Width
width forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform = CmmExpr
global
                | Width
width forall a. Ord a => a -> a -> Bool
< Platform -> Width
wordWidth Platform
platform =
                    MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_XX_Conv (Platform -> Width
wordWidth Platform
platform) Width
width) [CmmExpr
global]
                | Bool
otherwise = forall a. String -> a
panic String
"Parameter width greater than word width"

        in CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
local CmmExpr
expr

    -- Non VanillaRegs
    ci (CmmFormal
reg, RegisterParam GlobalReg
r) =
        CmmReg -> CmmExpr -> CmmNode O O
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
reg) (CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r))

    ci (CmmFormal
reg, StackParam ByteOff
off)
      | CmmType -> Bool
isBitsType forall a b. (a -> b) -> a -> b
$ CmmFormal -> CmmType
localRegType CmmFormal
reg
      , CmmType -> Width
typeWidth (CmmFormal -> CmmType
localRegType CmmFormal
reg) forall a. Ord a => a -> a -> Bool
< Platform -> Width
wordWidth Platform
platform =
        let
          stack_slot :: CmmExpr
stack_slot = CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Area -> ByteOff -> CmmExpr
CmmStackSlot Area
area ByteOff
off) (Width -> CmmType
cmmBits forall a b. (a -> b) -> a -> b
$ Platform -> Width
wordWidth Platform
platform) AlignmentSpec
NaturallyAligned
          local :: CmmReg
local = CmmFormal -> CmmReg
CmmLocal CmmFormal
reg
          width :: Width
width = Platform -> CmmReg -> Width
cmmRegWidth Platform
platform CmmReg
local
          expr :: CmmExpr
expr  = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_XX_Conv (Platform -> Width
wordWidth Platform
platform) Width
width) [CmmExpr
stack_slot]
        in CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
local CmmExpr
expr

      | Bool
otherwise =
         CmmReg -> CmmExpr -> CmmNode O O
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
reg) (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Area -> ByteOff -> CmmExpr
CmmStackSlot Area
area ByteOff
off) CmmType
ty AlignmentSpec
NaturallyAligned)
         where ty :: CmmType
ty = CmmFormal -> CmmType
localRegType CmmFormal
reg

    init_offset :: ByteOff
init_offset = Width -> ByteOff
widthInBytes (Platform -> Width
wordWidth Platform
platform) -- infotable

    (ByteOff
stk_off, [(CmmFormal, ParamLocation)]
stk_args) = forall a.
Platform
-> ByteOff
-> (a -> CmmType)
-> [a]
-> (ByteOff, [(a, ParamLocation)])
assignStack Platform
platform ByteOff
init_offset CmmFormal -> CmmType
localRegType [CmmFormal]
extra_stk

    (ByteOff
stk_size, [(CmmFormal, ParamLocation)]
args) = forall a.
Profile
-> ByteOff
-> Convention
-> (a -> CmmType)
-> [a]
-> (ByteOff, [(a, ParamLocation)])
assignArgumentsPos Profile
profile ByteOff
stk_off Convention
conv
                                          CmmFormal -> CmmType
localRegType [CmmFormal]
formals

-- Factoring out the common parts of the copyout functions yielded something
-- more complicated:

data Transfer = Call | JumpRet | Jump | Ret deriving Transfer -> Transfer -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Transfer -> Transfer -> Bool
$c/= :: Transfer -> Transfer -> Bool
== :: Transfer -> Transfer -> Bool
$c== :: Transfer -> Transfer -> Bool
Eq

copyOutOflow :: Profile -> Convention -> Transfer -> Area -> [CmmExpr]
             -> UpdFrameOffset
             -> [CmmExpr] -- extra stack args
             -> (Int, [GlobalReg], CmmAGraph)

-- Generate code to move the actual parameters into the locations
-- required by the calling convention.  This includes a store for the
-- return address.
--
-- The argument layout function ignores the pointer to the info table,
-- so we slot that in here. When copying-out to a young area, we set
-- the info table for return and adjust the offsets of the other
-- parameters.  If this is a call instruction, we adjust the offsets
-- of the other parameters.
copyOutOflow :: Profile
-> Convention
-> Transfer
-> Area
-> [CmmExpr]
-> ByteOff
-> [CmmExpr]
-> (ByteOff, [GlobalReg], CmmAGraph)
copyOutOflow Profile
profile Convention
conv Transfer
transfer Area
area [CmmExpr]
actuals ByteOff
updfr_off [CmmExpr]
extra_stack_stuff
  = (ByteOff
stk_size, [GlobalReg]
regs, CmmAGraph
graph)
  where
    platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
    ([GlobalReg]
regs, CmmAGraph
graph) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CmmExpr, ParamLocation)
-> ([GlobalReg], CmmAGraph) -> ([GlobalReg], CmmAGraph)
co ([], CmmAGraph
mkNop) ([(CmmExpr, ParamLocation)]
setRA forall a. [a] -> [a] -> [a]
++ [(CmmExpr, ParamLocation)]
args forall a. [a] -> [a] -> [a]
++ [(CmmExpr, ParamLocation)]
stack_params)

    -- See Note [Width of parameters]
    co :: (CmmExpr, ParamLocation)
-> ([GlobalReg], CmmAGraph) -> ([GlobalReg], CmmAGraph)
co (CmmExpr
v, RegisterParam r :: GlobalReg
r@(VanillaReg {})) ([GlobalReg]
rs, CmmAGraph
ms) =
        let width :: Width
width = Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
v
            value :: CmmExpr
value
                | Width
width forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform = CmmExpr
v
                | Width
width forall a. Ord a => a -> a -> Bool
< Platform -> Width
wordWidth Platform
platform =
                    MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_XX_Conv Width
width (Platform -> Width
wordWidth Platform
platform)) [CmmExpr
v]
                | Bool
otherwise = forall a. String -> a
panic String
"Parameter width greater than word width"

        in (GlobalReg
rforall a. a -> [a] -> [a]
:[GlobalReg]
rs, CmmReg -> CmmExpr -> CmmAGraph
mkAssign (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r) CmmExpr
value CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
ms)

    -- Non VanillaRegs
    co (CmmExpr
v, RegisterParam GlobalReg
r) ([GlobalReg]
rs, CmmAGraph
ms) =
        (GlobalReg
rforall a. a -> [a] -> [a]
:[GlobalReg]
rs, CmmReg -> CmmExpr -> CmmAGraph
mkAssign (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r) CmmExpr
v CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
ms)

    -- See Note [Width of parameters]
    co (CmmExpr
v, StackParam ByteOff
off)  ([GlobalReg]
rs, CmmAGraph
ms)
      = ([GlobalReg]
rs, CmmExpr -> CmmExpr -> CmmAGraph
mkStore (Area -> ByteOff -> CmmExpr
CmmStackSlot Area
area ByteOff
off) (CmmExpr -> CmmExpr
value CmmExpr
v) CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
ms)

    width :: CmmExpr -> Width
width CmmExpr
v = Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
v
    value :: CmmExpr -> CmmExpr
value CmmExpr
v
      | CmmType -> Bool
isBitsType forall a b. (a -> b) -> a -> b
$ Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
v
      , CmmExpr -> Width
width CmmExpr
v forall a. Ord a => a -> a -> Bool
< Platform -> Width
wordWidth Platform
platform =
        MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_XX_Conv (CmmExpr -> Width
width CmmExpr
v) (Platform -> Width
wordWidth Platform
platform)) [CmmExpr
v]
      | Bool
otherwise = CmmExpr
v

    ([(CmmExpr, ParamLocation)]
setRA, ByteOff
init_offset) =
      case Area
area of
            Young BlockId
id ->  -- Generate a store instruction for
                         -- the return address if making a call
                  case Transfer
transfer of
                     Transfer
Call ->
                       ([(CmmLit -> CmmExpr
CmmLit (BlockId -> CmmLit
CmmBlock BlockId
id), ByteOff -> ParamLocation
StackParam ByteOff
init_offset)],
                       Width -> ByteOff
widthInBytes (Platform -> Width
wordWidth Platform
platform))
                     Transfer
JumpRet ->
                       ([],
                       Width -> ByteOff
widthInBytes (Platform -> Width
wordWidth Platform
platform))
                     Transfer
_other ->
                       ([], ByteOff
0)
            Area
Old -> ([], ByteOff
updfr_off)

    (ByteOff
extra_stack_off, [(CmmExpr, ParamLocation)]
stack_params) =
       forall a.
Platform
-> ByteOff
-> (a -> CmmType)
-> [a]
-> (ByteOff, [(a, ParamLocation)])
assignStack Platform
platform ByteOff
init_offset (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform) [CmmExpr]
extra_stack_stuff

    args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it
    (ByteOff
stk_size, [(CmmExpr, ParamLocation)]
args) = forall a.
Profile
-> ByteOff
-> Convention
-> (a -> CmmType)
-> [a]
-> (ByteOff, [(a, ParamLocation)])
assignArgumentsPos Profile
profile ByteOff
extra_stack_off Convention
conv
                                          (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform) [CmmExpr]
actuals


-- Note [Width of parameters]
--
-- Consider passing a small (< word width) primitive like Int8# to a function.
-- It's actually non-trivial to do this without extending/narrowing:
-- * Global registers are considered to have native word width (i.e., 64-bits on
--   x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a
--   global register.
-- * Same problem exists with LLVM IR.
-- * Lowering gets harder since on x86-32 not every register exposes its lower
--   8 bits (e.g., for %eax we can use %al, but there isn't a corresponding
--   8-bit register for %edi). So we would either need to extend/narrow anyway,
--   or complicate the calling convention.
-- * Passing a small integer in a stack slot, which has native word width,
--   requires extending to word width when writing to the stack and narrowing
--   when reading off the stack (see #16258).
-- So instead, we always extend every parameter smaller than native word width
-- in copyOutOflow and then truncate it back to the expected width in copyIn.
-- Note that we do this in cmm using MO_XX_Conv to avoid requiring
-- zero-/sign-extending - it's up to a backend to handle this in a most
-- efficient way (e.g., a simple register move or a smaller size store).
-- This convention (of ignoring the upper bits) is different from some C ABIs,
-- e.g. all PowerPC ELF ABIs, that require sign or zero extending parameters.
--
-- There was some discussion about this on this PR:
-- https://github.com/ghc-proposals/ghc-proposals/pull/74


mkCallEntry :: Profile -> Convention -> [CmmFormal] -> [CmmFormal]
            -> (Int, [GlobalReg], CmmAGraph)
mkCallEntry :: Profile
-> Convention
-> [CmmFormal]
-> [CmmFormal]
-> (ByteOff, [GlobalReg], CmmAGraph)
mkCallEntry Profile
profile Convention
conv [CmmFormal]
formals [CmmFormal]
extra_stk
  = Profile
-> Convention
-> Area
-> [CmmFormal]
-> [CmmFormal]
-> (ByteOff, [GlobalReg], CmmAGraph)
copyInOflow Profile
profile Convention
conv Area
Old [CmmFormal]
formals [CmmFormal]
extra_stk

lastWithArgs :: Profile -> Transfer -> Area -> Convention -> [CmmExpr]
             -> UpdFrameOffset
             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
             -> CmmAGraph
lastWithArgs :: Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs Profile
profile Transfer
transfer Area
area Convention
conv [CmmExpr]
actuals ByteOff
updfr_off ByteOff -> [GlobalReg] -> CmmAGraph
last =
  Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> [CmmExpr]
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgsAndExtraStack Profile
profile Transfer
transfer Area
area Convention
conv [CmmExpr]
actuals
                            ByteOff
updfr_off [CmmExpr]
noExtraStack ByteOff -> [GlobalReg] -> CmmAGraph
last

lastWithArgsAndExtraStack :: Profile
             -> Transfer -> Area -> Convention -> [CmmExpr]
             -> UpdFrameOffset -> [CmmExpr]
             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
             -> CmmAGraph
lastWithArgsAndExtraStack :: Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> [CmmExpr]
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgsAndExtraStack Profile
profile Transfer
transfer Area
area Convention
conv [CmmExpr]
actuals ByteOff
updfr_off
                          [CmmExpr]
extra_stack ByteOff -> [GlobalReg] -> CmmAGraph
last =
  CmmAGraph
copies CmmAGraph -> CmmAGraph -> CmmAGraph
<*> ByteOff -> [GlobalReg] -> CmmAGraph
last ByteOff
outArgs [GlobalReg]
regs
 where
  (ByteOff
outArgs, [GlobalReg]
regs, CmmAGraph
copies) = Profile
-> Convention
-> Transfer
-> Area
-> [CmmExpr]
-> ByteOff
-> [CmmExpr]
-> (ByteOff, [GlobalReg], CmmAGraph)
copyOutOflow Profile
profile Convention
conv Transfer
transfer Area
area [CmmExpr]
actuals
                               ByteOff
updfr_off [CmmExpr]
extra_stack


noExtraStack :: [CmmExpr]
noExtraStack :: [CmmExpr]
noExtraStack = []

toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
       -> ByteOff -> [GlobalReg]
       -> CmmAGraph
toCall :: CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e Maybe BlockId
cont ByteOff
updfr_off ByteOff
res_space ByteOff
arg_space [GlobalReg]
regs =
  CmmNode O C -> CmmAGraph
mkLast forall a b. (a -> b) -> a -> b
$ CmmExpr
-> Maybe BlockId
-> [GlobalReg]
-> ByteOff
-> ByteOff
-> ByteOff
-> CmmNode O C
CmmCall CmmExpr
e Maybe BlockId
cont [GlobalReg]
regs ByteOff
arg_space ByteOff
res_space ByteOff
updfr_off