{-# LANGUAGE BangPatterns, GADTs #-}

module MkGraph
  ( 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 GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>)

import BlockId
import Cmm
import CmmCallConv
import CmmSwitch (SwitchTargets)

import Hoopl.Block
import Hoopl.Graph
import Hoopl.Label
import DynFlags
import FastString
import ForeignCall
import OrdList
import SMRep (ByteOff)
import UniqSupply
import Util
import 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 :: forall (n :: Extensibility -> Extensibility -> *).
BlockId -> Graph n C C -> GenCmmGraph n
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          :: DynFlags -> Convention -> CmmExpr
                -> [CmmExpr]
                -> UpdFrameOffset
                -> CmmAGraph
mkJump :: DynFlags
-> Convention
-> CmmExpr
-> [CmmExpr]
-> UpdFrameOffset
-> CmmAGraph
mkJump DynFlags
dflags Convention
conv CmmExpr
e [CmmExpr]
actuals UpdFrameOffset
updfr_off =
  DynFlags
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> UpdFrameOffset
-> (UpdFrameOffset -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs DynFlags
dflags Transfer
Jump Area
Old Convention
conv [CmmExpr]
actuals UpdFrameOffset
updfr_off ((UpdFrameOffset -> [GlobalReg] -> CmmAGraph) -> CmmAGraph)
-> (UpdFrameOffset -> [GlobalReg] -> CmmAGraph) -> CmmAGraph
forall a b. (a -> b) -> a -> b
$
    CmmExpr
-> Maybe BlockId
-> UpdFrameOffset
-> UpdFrameOffset
-> UpdFrameOffset
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e Maybe BlockId
forall a. Maybe a
Nothing UpdFrameOffset
updfr_off UpdFrameOffset
0

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


mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]
                -> UpdFrameOffset -> [CmmExpr]
                -> CmmAGraph
mkJumpExtra :: DynFlags
-> Convention
-> CmmExpr
-> [CmmExpr]
-> UpdFrameOffset
-> [CmmExpr]
-> CmmAGraph
mkJumpExtra DynFlags
dflags Convention
conv CmmExpr
e [CmmExpr]
actuals UpdFrameOffset
updfr_off [CmmExpr]
extra_stack =
  DynFlags
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> UpdFrameOffset
-> [CmmExpr]
-> (UpdFrameOffset -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgsAndExtraStack DynFlags
dflags Transfer
Jump Area
Old Convention
conv [CmmExpr]
actuals UpdFrameOffset
updfr_off [CmmExpr]
extra_stack ((UpdFrameOffset -> [GlobalReg] -> CmmAGraph) -> CmmAGraph)
-> (UpdFrameOffset -> [GlobalReg] -> CmmAGraph) -> CmmAGraph
forall a b. (a -> b) -> a -> b
$
    CmmExpr
-> Maybe BlockId
-> UpdFrameOffset
-> UpdFrameOffset
-> UpdFrameOffset
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e Maybe BlockId
forall a. Maybe a
Nothing UpdFrameOffset
updfr_off UpdFrameOffset
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        :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
                -> CmmAGraph
mkReturn :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset -> CmmAGraph
mkReturn DynFlags
dflags CmmExpr
e [CmmExpr]
actuals UpdFrameOffset
updfr_off =
  DynFlags
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> UpdFrameOffset
-> (UpdFrameOffset -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs DynFlags
dflags Transfer
Ret  Area
Old Convention
NativeReturn [CmmExpr]
actuals UpdFrameOffset
updfr_off ((UpdFrameOffset -> [GlobalReg] -> CmmAGraph) -> CmmAGraph)
-> (UpdFrameOffset -> [GlobalReg] -> CmmAGraph) -> CmmAGraph
forall a b. (a -> b) -> a -> b
$
    CmmExpr
-> Maybe BlockId
-> UpdFrameOffset
-> UpdFrameOffset
-> UpdFrameOffset
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e Maybe BlockId
forall a. Maybe a
Nothing UpdFrameOffset
updfr_off UpdFrameOffset
0

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

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

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

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

copyInOflow :: DynFlags
-> Convention
-> Area
-> [CmmFormal]
-> [CmmFormal]
-> (UpdFrameOffset, [GlobalReg], CmmAGraph)
copyInOflow DynFlags
dflags Convention
conv Area
area [CmmFormal]
formals [CmmFormal]
extra_stk
  = (UpdFrameOffset
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 (UpdFrameOffset
offset, [GlobalReg]
gregs, [CmmNode O O]
nodes) = DynFlags
-> Convention
-> Area
-> [CmmFormal]
-> [CmmFormal]
-> (UpdFrameOffset, [GlobalReg], [CmmNode O O])
copyIn DynFlags
dflags 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 :: DynFlags -> Convention -> Area
       -> [CmmFormal]
       -> [CmmFormal]
       -> (ByteOff, [GlobalReg], [CmmNode O O])
copyIn :: DynFlags
-> Convention
-> Area
-> [CmmFormal]
-> [CmmFormal]
-> (UpdFrameOffset, [GlobalReg], [CmmNode O O])
copyIn DynFlags
dflags Convention
conv Area
area [CmmFormal]
formals [CmmFormal]
extra_stk
  = (UpdFrameOffset
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
    -- 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 = DynFlags -> CmmReg -> Width
cmmRegWidth DynFlags
dflags CmmReg
local
            expr :: CmmExpr
expr
                | Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Width
wordWidth DynFlags
dflags = CmmExpr
global
                | Width
width Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< DynFlags -> Width
wordWidth DynFlags
dflags =
                    MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_XX_Conv (DynFlags -> Width
wordWidth DynFlags
dflags) 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 UpdFrameOffset
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
< DynFlags -> Width
wordWidth DynFlags
dflags =
        let
          stack_slot :: CmmExpr
stack_slot = (CmmExpr -> CmmType -> CmmExpr
CmmLoad (Area -> UpdFrameOffset -> CmmExpr
CmmStackSlot Area
area UpdFrameOffset
off) (Width -> CmmType
cmmBits (Width -> CmmType) -> Width -> CmmType
forall a b. (a -> b) -> a -> b
$ DynFlags -> Width
wordWidth DynFlags
dflags))
          local :: CmmReg
local = CmmFormal -> CmmReg
CmmLocal CmmFormal
reg
          width :: Width
width = DynFlags -> CmmReg -> Width
cmmRegWidth DynFlags
dflags CmmReg
local
          expr :: CmmExpr
expr  = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_XX_Conv (DynFlags -> Width
wordWidth DynFlags
dflags) 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 -> UpdFrameOffset -> CmmExpr
CmmStackSlot Area
area UpdFrameOffset
off) CmmType
ty)
         where ty :: CmmType
ty = CmmFormal -> CmmType
localRegType CmmFormal
reg

    init_offset :: UpdFrameOffset
init_offset = Width -> UpdFrameOffset
widthInBytes (DynFlags -> Width
wordWidth DynFlags
dflags) -- infotable

    (UpdFrameOffset
stk_off, [(CmmFormal, ParamLocation)]
stk_args) = DynFlags
-> UpdFrameOffset
-> (CmmFormal -> CmmType)
-> [CmmFormal]
-> (UpdFrameOffset, [(CmmFormal, ParamLocation)])
forall a.
DynFlags
-> UpdFrameOffset
-> (a -> CmmType)
-> [a]
-> (UpdFrameOffset, [(a, ParamLocation)])
assignStack DynFlags
dflags UpdFrameOffset
init_offset CmmFormal -> CmmType
localRegType [CmmFormal]
extra_stk

    (UpdFrameOffset
stk_size, [(CmmFormal, ParamLocation)]
args) = DynFlags
-> UpdFrameOffset
-> Convention
-> (CmmFormal -> CmmType)
-> [CmmFormal]
-> (UpdFrameOffset, [(CmmFormal, ParamLocation)])
forall a.
DynFlags
-> UpdFrameOffset
-> Convention
-> (a -> CmmType)
-> [a]
-> (UpdFrameOffset, [(a, ParamLocation)])
assignArgumentsPos DynFlags
dflags UpdFrameOffset
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 :: DynFlags -> 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 :: DynFlags
-> Convention
-> Transfer
-> Area
-> [CmmExpr]
-> UpdFrameOffset
-> [CmmExpr]
-> (UpdFrameOffset, [GlobalReg], CmmAGraph)
copyOutOflow DynFlags
dflags Convention
conv Transfer
transfer Area
area [CmmExpr]
actuals UpdFrameOffset
updfr_off [CmmExpr]
extra_stack_stuff
  = (UpdFrameOffset
stk_size, [GlobalReg]
regs, CmmAGraph
graph)
  where
    ([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 = DynFlags -> CmmExpr -> Width
cmmExprWidth DynFlags
dflags CmmExpr
v
            value :: CmmExpr
value
                | Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Width
wordWidth DynFlags
dflags = CmmExpr
v
                | Width
width Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< DynFlags -> Width
wordWidth DynFlags
dflags =
                    MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_XX_Conv Width
width (DynFlags -> Width
wordWidth DynFlags
dflags)) [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 UpdFrameOffset
off)  ([GlobalReg]
rs, CmmAGraph
ms)
      = ([GlobalReg]
rs, CmmExpr -> CmmExpr -> CmmAGraph
mkStore (Area -> UpdFrameOffset -> CmmExpr
CmmStackSlot Area
area UpdFrameOffset
off) (CmmExpr -> CmmExpr
value CmmExpr
v) CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
ms)

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

    ([(CmmExpr, ParamLocation)]
setRA, UpdFrameOffset
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), UpdFrameOffset -> ParamLocation
StackParam UpdFrameOffset
init_offset)],
                       Width -> UpdFrameOffset
widthInBytes (DynFlags -> Width
wordWidth DynFlags
dflags))
                     Transfer
JumpRet ->
                       ([],
                       Width -> UpdFrameOffset
widthInBytes (DynFlags -> Width
wordWidth DynFlags
dflags))
                     Transfer
_other ->
                       ([], UpdFrameOffset
0)
            Area
Old -> ([], UpdFrameOffset
updfr_off)

    (UpdFrameOffset
extra_stack_off, [(CmmExpr, ParamLocation)]
stack_params) =
       DynFlags
-> UpdFrameOffset
-> (CmmExpr -> CmmType)
-> [CmmExpr]
-> (UpdFrameOffset, [(CmmExpr, ParamLocation)])
forall a.
DynFlags
-> UpdFrameOffset
-> (a -> CmmType)
-> [a]
-> (UpdFrameOffset, [(a, ParamLocation)])
assignStack DynFlags
dflags UpdFrameOffset
init_offset (DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags) [CmmExpr]
extra_stack_stuff

    args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it
    (UpdFrameOffset
stk_size, [(CmmExpr, ParamLocation)]
args) = DynFlags
-> UpdFrameOffset
-> Convention
-> (CmmExpr -> CmmType)
-> [CmmExpr]
-> (UpdFrameOffset, [(CmmExpr, ParamLocation)])
forall a.
DynFlags
-> UpdFrameOffset
-> Convention
-> (a -> CmmType)
-> [a]
-> (UpdFrameOffset, [(a, ParamLocation)])
assignArgumentsPos DynFlags
dflags UpdFrameOffset
extra_stack_off Convention
conv
                                          (DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags) [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 :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
            -> (Int, [GlobalReg], CmmAGraph)
mkCallEntry :: DynFlags
-> Convention
-> [CmmFormal]
-> [CmmFormal]
-> (UpdFrameOffset, [GlobalReg], CmmAGraph)
mkCallEntry DynFlags
dflags Convention
conv [CmmFormal]
formals [CmmFormal]
extra_stk
  = DynFlags
-> Convention
-> Area
-> [CmmFormal]
-> [CmmFormal]
-> (UpdFrameOffset, [GlobalReg], CmmAGraph)
copyInOflow DynFlags
dflags Convention
conv Area
Old [CmmFormal]
formals [CmmFormal]
extra_stk

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

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


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

toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
       -> ByteOff -> [GlobalReg]
       -> CmmAGraph
toCall :: CmmExpr
-> Maybe BlockId
-> UpdFrameOffset
-> UpdFrameOffset
-> UpdFrameOffset
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e Maybe BlockId
cont UpdFrameOffset
updfr_off UpdFrameOffset
res_space UpdFrameOffset
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]
-> UpdFrameOffset
-> UpdFrameOffset
-> UpdFrameOffset
-> CmmNode O C
CmmCall CmmExpr
e Maybe BlockId
cont [GlobalReg]
regs UpdFrameOffset
arg_space UpdFrameOffset
res_space UpdFrameOffset
updfr_off