{-# 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 = MaybeO C (Block CmmNode O C)
-> Body' Block CmmNode
-> MaybeO C (Block CmmNode C O)
-> Graph CmmNode C C
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 MaybeO C (Block CmmNode O C)
forall t. MaybeO C t
NothingO Body' Block CmmNode
body MaybeO C (Block CmmNode C O)
forall t. MaybeO C t
NothingO }
  where
  body :: Body' Block CmmNode
body = (Block CmmNode C C -> Body' Block CmmNode -> Body' Block CmmNode)
-> Body' Block CmmNode
-> [Block CmmNode C C]
-> Body' Block CmmNode
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Block CmmNode C C -> Body' Block CmmNode -> Body' Block CmmNode
forall (block :: Extensibility -> Extensibility -> *).
(NonLocal block, HasDebugCallStack) =>
block C C -> LabelMap (block C C) -> LabelMap (block C C)
addBlock Body' Block CmmNode
forall (block :: (Extensibility -> Extensibility -> *)
                 -> Extensibility -> Extensibility -> *)
       (n :: Extensibility -> Extensibility -> *).
Body' block n
emptyBody ([Block CmmNode C C] -> Body' Block CmmNode)
-> [Block CmmNode C C] -> Body' Block CmmNode
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 (CmmAGraph -> [CgStmt]
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' = CmmNode C O -> Block CmmNode O O -> Block CmmNode C O
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) Block CmmNode O O
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 = CmmNode C O -> Block CmmNode O O -> Block CmmNode C O
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) Block CmmNode O O
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 ([Block CmmNode C C] -> [Block CmmNode C C])
-> [Block CmmNode C C] -> [Block CmmNode C C]
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
    = Block CmmNode C O -> CmmNode O C -> Block CmmNode C C
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 (Block CmmNode C O -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel Block CmmNode C O
block)) Block CmmNode C C -> [Block CmmNode C C] -> [Block CmmNode C C]
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' Block CmmNode C C -> [Block CmmNode C C] -> [Block CmmNode C C]
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' = Block CmmNode C O -> CmmNode O C -> Block CmmNode C C
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' = Block CmmNode C O -> CmmNode O O -> Block CmmNode C O
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 ([Block CmmNode C C] -> [Block CmmNode C C])
-> [Block CmmNode C C] -> [Block CmmNode C C]
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
    = Block CmmNode C O -> CmmNode O C -> Block CmmNode C C
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) Block CmmNode C C -> [Block CmmNode C C] -> [Block CmmNode C C]
forall a. a -> [a] -> [a]
:
      [CgStmt]
-> Block CmmNode C O -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 [CgStmt]
stmts (CmmNode C O -> Block CmmNode O O -> Block CmmNode C O
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) Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *). Block n O O
emptyBlock) [Block CmmNode C C]
blocks



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

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

catAGraphs     :: [CmmAGraph] -> CmmAGraph
catAGraphs :: [CmmAGraph] -> CmmAGraph
catAGraphs      = [CmmAGraph] -> CmmAGraph
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 = CgStmt -> CmmAGraph
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 = CgStmt -> CmmAGraph
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     = CgStmt -> CmmAGraph
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) = CgStmt -> CmmAGraph
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 <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
  CmmGraph -> UniqSM CmmGraph
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         = CmmAGraph
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 (CmmNode O O -> CmmAGraph) -> CmmNode O O -> CmmAGraph
forall a b. (a -> b) -> a -> b
$ FastString -> CmmNode O O
CmmComment FastString
fs
  | Bool
otherwise = CmmAGraph
forall a. OrdList a
nilOL

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

mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore  CmmExpr
l CmmExpr
r  = CmmNode O O -> CmmAGraph
mkMiddle (CmmNode O O -> CmmAGraph) -> CmmNode O O -> CmmAGraph
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmExpr -> CmmNode O O
CmmStore  CmmExpr
l CmmExpr
r

---------- 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 ((ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph)
-> (ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph
forall a b. (a -> b) -> a -> b
$
    CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e Maybe BlockId
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 ((ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph)
-> (ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph
forall a b. (a -> b) -> a -> b
$
    \ByteOff
arg_space [GlobalReg]
_  -> CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e Maybe BlockId
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 ((ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph)
-> (ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph
forall a b. (a -> b) -> a -> b
$
    CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e Maybe BlockId
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 (CmmNode O C -> CmmAGraph) -> CmmNode O C -> CmmAGraph
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 ((ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph)
-> (ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph
forall a b. (a -> b) -> a -> b
$
    CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e Maybe BlockId
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 ((ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph)
-> (ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph
forall a b. (a -> b) -> a -> b
$
    CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
f Maybe BlockId
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 ((ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph)
-> (ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph
forall a b. (a -> b) -> a -> b
$
      CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
f (BlockId -> Maybe BlockId
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 ((ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph)
-> (ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph
forall a b. (a -> b) -> a -> b
$
    CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
f (BlockId -> Maybe BlockId
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 (CmmNode O O -> CmmAGraph) -> CmmNode O O -> CmmAGraph
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 (CmmNode O O -> CmmAGraph) -> CmmNode O O -> CmmAGraph
forall a b. (a -> b) -> a -> b
$ [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
CmmUnwind [(GlobalReg
r, CmmExpr -> Maybe CmmExpr
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 ([CmmAGraph] -> CmmAGraph) -> [CmmAGraph] -> CmmAGraph
forall a b. (a -> b) -> a -> b
$ (CmmNode O O -> CmmAGraph) -> [CmmNode O O] -> [CmmAGraph]
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], ((CmmFormal, ParamLocation) -> CmmNode O O)
-> [(CmmFormal, ParamLocation)] -> [CmmNode O O]
forall a b. (a -> b) -> [a] -> [b]
map (CmmFormal, ParamLocation) -> CmmNode O O
ci ([(CmmFormal, ParamLocation)]
stk_args [(CmmFormal, ParamLocation)]
-> [(CmmFormal, ParamLocation)] -> [(CmmFormal, ParamLocation)]
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 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform = CmmExpr
global
                | Width
width Width -> Width -> Bool
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 = String -> CmmExpr
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 (CmmType -> Bool) -> CmmType -> Bool
forall a b. (a -> b) -> a -> b
$ CmmFormal -> CmmType
localRegType CmmFormal
reg
      , CmmType -> Width
typeWidth (CmmFormal -> CmmType
localRegType CmmFormal
reg) Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Platform -> Width
wordWidth Platform
platform =
        let
          stack_slot :: CmmExpr
stack_slot = (CmmExpr -> CmmType -> CmmExpr
CmmLoad (Area -> ByteOff -> CmmExpr
CmmStackSlot Area
area ByteOff
off) (Width -> CmmType
cmmBits (Width -> CmmType) -> Width -> CmmType
forall a b. (a -> b) -> a -> b
$ Platform -> Width
wordWidth Platform
platform))
          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 -> CmmExpr
CmmLoad (Area -> ByteOff -> CmmExpr
CmmStackSlot Area
area ByteOff
off) CmmType
ty)
         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) = Platform
-> ByteOff
-> (CmmFormal -> CmmType)
-> [CmmFormal]
-> (ByteOff, [(CmmFormal, ParamLocation)])
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) = Profile
-> ByteOff
-> Convention
-> (CmmFormal -> CmmType)
-> [CmmFormal]
-> (ByteOff, [(CmmFormal, ParamLocation)])
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
(Transfer -> Transfer -> Bool)
-> (Transfer -> Transfer -> Bool) -> Eq Transfer
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) = ((CmmExpr, ParamLocation)
 -> ([GlobalReg], CmmAGraph) -> ([GlobalReg], CmmAGraph))
-> ([GlobalReg], CmmAGraph)
-> [(CmmExpr, ParamLocation)]
-> ([GlobalReg], CmmAGraph)
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 [(CmmExpr, ParamLocation)]
-> [(CmmExpr, ParamLocation)] -> [(CmmExpr, ParamLocation)]
forall a. [a] -> [a] -> [a]
++ [(CmmExpr, ParamLocation)]
args [(CmmExpr, ParamLocation)]
-> [(CmmExpr, ParamLocation)] -> [(CmmExpr, ParamLocation)]
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 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform = CmmExpr
v
                | Width
width Width -> Width -> Bool
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 = String -> CmmExpr
forall a. String -> a
panic String
"Parameter width greater than word width"

        in (GlobalReg
rGlobalReg -> [GlobalReg] -> [GlobalReg]
forall 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
rGlobalReg -> [GlobalReg] -> [GlobalReg]
forall 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 (CmmType -> Bool) -> CmmType -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
v
      , CmmExpr -> Width
width CmmExpr
v Width -> Width -> Bool
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) =
       Platform
-> ByteOff
-> (CmmExpr -> CmmType)
-> [CmmExpr]
-> (ByteOff, [(CmmExpr, ParamLocation)])
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) = Profile
-> ByteOff
-> Convention
-> (CmmExpr -> CmmType)
-> [CmmExpr]
-> (ByteOff, [(CmmExpr, ParamLocation)])
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 (CmmNode O C -> CmmAGraph) -> CmmNode O C -> CmmAGraph
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