{-# 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 id :: BlockId
id (stmts_t :: CmmAGraph
stmts_t, tscope :: CmmTickScope
tscope) =
    CmmGraph :: forall (n :: * -> * -> *). 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 (block :: (* -> * -> *) -> * -> * -> *) (n :: * -> * -> *)
       x.
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 :: * -> * -> *).
(NonLocal block, HasDebugCallStack) =>
block C C -> LabelMap (block C C) -> LabelMap (block C C)
addBlock Body' Block CmmNode
forall (block :: (* -> * -> *) -> * -> * -> *) (n :: * -> * -> *).
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 id :: BlockId
id g :: CmmAGraph
g tscope :: CmmTickScope
tscope blocks :: [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 :: * -> * -> *) x. 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 :: * -> * -> *). 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 [] blocks :: [Block CmmNode C C]
blocks = [Block CmmNode C C]
blocks

  flatten0 (CgLabel id :: BlockId
id tscope :: CmmTickScope
tscope : stmts :: [CgStmt]
stmts) blocks :: [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 :: * -> * -> *) x. 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 :: * -> * -> *). Block n O O
emptyBlock

  flatten0 (CgFork fork_id :: BlockId
fork_id stmts_t :: CmmAGraph
stmts_t tscope :: CmmTickScope
tscope : rest :: [CgStmt]
rest) blocks :: [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 _ : stmts :: [CgStmt]
stmts) blocks :: [Block CmmNode C C]
blocks = [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [CgStmt]
stmts [Block CmmNode C C]
blocks
  flatten0 (CgStmt _ : stmts :: [CgStmt]
stmts) blocks :: [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 :: Block CmmNode C O
block blocks :: [Block CmmNode C C]
blocks
    = Block CmmNode C O -> CmmNode O C -> Block CmmNode C C
forall (n :: * -> * -> *) e. 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 :: * -> * -> *) x.
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 stmt :: CmmNode O C
stmt : stmts :: [CgStmt]
stmts) block :: Block CmmNode C O
block blocks :: [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 :: * -> * -> *) e. Block n e O -> n O C -> Block n e C
blockJoinTail Block CmmNode C O
block CmmNode O C
stmt

  flatten1 (CgStmt stmt :: CmmNode O O
stmt : stmts :: [CgStmt]
stmts) block :: Block CmmNode C O
block blocks :: [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 :: * -> * -> *) e. Block n e O -> n O O -> Block n e O
blockSnoc Block CmmNode C O
block CmmNode O O
stmt

  flatten1 (CgFork fork_id :: BlockId
fork_id stmts_t :: CmmAGraph
stmts_t tscope :: CmmTickScope
tscope : rest :: [CgStmt]
rest) block :: Block CmmNode C O
block blocks :: [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 id :: BlockId
id tscp :: CmmTickScope
tscp : stmts :: [CgStmt]
stmts) block :: Block CmmNode C O
block blocks :: [Block CmmNode C C]
blocks
    = Block CmmNode C O -> CmmNode O C -> Block CmmNode C C
forall (n :: * -> * -> *) e. 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 :: * -> * -> *) x. 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 :: * -> * -> *). 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 bid :: BlockId
bid scp :: 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 middle :: 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 last :: 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 l :: BlockId
l (c :: CmmAGraph
c,s :: 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 g :: 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 lbl :: BlockId
lbl ag :: 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 fs :: 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 l :: CmmReg
l (CmmReg r :: CmmReg
r) | CmmReg
l CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
== CmmReg
r  = CmmAGraph
mkNop
mkAssign l :: CmmReg
l r :: 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  l :: CmmExpr
l r :: 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 dflags :: DynFlags
dflags conv :: Convention
conv e :: CmmExpr
e actuals :: [CmmExpr]
actuals updfr_off :: 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 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 dflags :: DynFlags
dflags e :: CmmExpr
e updfr_off :: UpdFrameOffset
updfr_off vols :: [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
$
    \arg_space :: UpdFrameOffset
arg_space _  -> CmmExpr
-> Maybe BlockId
-> UpdFrameOffset
-> UpdFrameOffset
-> UpdFrameOffset
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e Maybe BlockId
forall a. Maybe a
Nothing UpdFrameOffset
updfr_off 0 UpdFrameOffset
arg_space [GlobalReg]
vols


mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]
                -> UpdFrameOffset -> [CmmExpr]
                -> CmmAGraph
mkJumpExtra :: DynFlags
-> Convention
-> CmmExpr
-> [CmmExpr]
-> UpdFrameOffset
-> [CmmExpr]
-> CmmAGraph
mkJumpExtra dflags :: DynFlags
dflags conv :: Convention
conv e :: CmmExpr
e actuals :: [CmmExpr]
actuals updfr_off :: UpdFrameOffset
updfr_off extra_stack :: [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 0

mkCbranch       :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch pred :: CmmExpr
pred ifso :: BlockId
ifso ifnot :: BlockId
ifnot likely :: 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 e :: CmmExpr
e tbl :: 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 dflags :: DynFlags
dflags e :: CmmExpr
e actuals :: [CmmExpr]
actuals updfr_off :: 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 0

mkBranch        :: BlockId -> CmmAGraph
mkBranch :: BlockId -> CmmAGraph
mkBranch bid :: 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 dflags :: DynFlags
dflags f :: CmmExpr
f _ actuals :: [CmmExpr]
actuals updfr_off :: 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 0

mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
                -> BlockId
                -> ByteOff
                -> UpdFrameOffset
                -> [CmmExpr]
                -> CmmAGraph
mkCallReturnsTo :: DynFlags
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> UpdFrameOffset
-> UpdFrameOffset
-> [CmmExpr]
-> CmmAGraph
mkCallReturnsTo dflags :: DynFlags
dflags f :: CmmExpr
f callConv :: Convention
callConv actuals :: [CmmExpr]
actuals ret_lbl :: BlockId
ret_lbl ret_off :: UpdFrameOffset
ret_off updfr_off :: UpdFrameOffset
updfr_off extra_stack :: [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 dflags :: DynFlags
dflags f :: CmmExpr
f callConv :: Convention
callConv actuals :: [CmmExpr]
actuals ret_lbl :: BlockId
ret_lbl ret_off :: UpdFrameOffset
ret_off updfr_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 t :: ForeignTarget
t fs :: [CmmFormal]
fs as :: [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 r :: GlobalReg
r e :: 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 w :: Width
w = CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt 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 dflags :: DynFlags
dflags conv :: Convention
conv area :: Area
area formals :: [CmmFormal]
formals extra_stk :: [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 (offset :: UpdFrameOffset
offset, gregs :: [GlobalReg]
gregs, nodes :: [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 dflags :: DynFlags
dflags conv :: Convention
conv area :: Area
area formals :: [CmmFormal]
formals extra_stk :: [CmmFormal]
extra_stk
  = (UpdFrameOffset
stk_size, [GlobalReg
r | (_, RegisterParam r :: 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 (reg :: 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 "Parameter width greater than word width"

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

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

    ci (reg :: CmmFormal
reg, StackParam off :: 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

    (stk_off :: UpdFrameOffset
stk_off, stk_args :: [(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

    (stk_size :: UpdFrameOffset
stk_size, args :: [(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 dflags :: DynFlags
dflags conv :: Convention
conv transfer :: Transfer
transfer area :: Area
area actuals :: [CmmExpr]
actuals updfr_off :: UpdFrameOffset
updfr_off extra_stack_stuff :: [CmmExpr]
extra_stack_stuff
  = (UpdFrameOffset
stk_size, [GlobalReg]
regs, CmmAGraph
graph)
  where
    (regs :: [GlobalReg]
regs, graph :: 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 (v :: CmmExpr
v, RegisterParam r :: GlobalReg
r@(VanillaReg {})) (rs :: [GlobalReg]
rs, ms :: 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 "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 (v :: CmmExpr
v, RegisterParam r :: GlobalReg
r) (rs :: [GlobalReg]
rs, ms :: 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 (v :: CmmExpr
v, StackParam off :: UpdFrameOffset
off)  (rs :: [GlobalReg]
rs, ms :: 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 v :: CmmExpr
v = DynFlags -> CmmExpr -> Width
cmmExprWidth DynFlags
dflags CmmExpr
v
    value :: CmmExpr -> CmmExpr
value v :: 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

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

    (extra_stack_off :: UpdFrameOffset
extra_stack_off, stack_params :: [(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
    (stk_size :: UpdFrameOffset
stk_size, args :: [(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 dflags :: DynFlags
dflags conv :: Convention
conv formals :: [CmmFormal]
formals extra_stk :: [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 dflags :: DynFlags
dflags transfer :: Transfer
transfer area :: Area
area conv :: Convention
conv actuals :: [CmmExpr]
actuals updfr_off :: UpdFrameOffset
updfr_off last :: 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 dflags :: DynFlags
dflags transfer :: Transfer
transfer area :: Area
area conv :: Convention
conv actuals :: [CmmExpr]
actuals updfr_off :: UpdFrameOffset
updfr_off
                          extra_stack :: [CmmExpr]
extra_stack last :: UpdFrameOffset -> [GlobalReg] -> CmmAGraph
last =
  CmmAGraph
copies CmmAGraph -> CmmAGraph -> CmmAGraph
<*> UpdFrameOffset -> [GlobalReg] -> CmmAGraph
last UpdFrameOffset
outArgs [GlobalReg]
regs
 where
  (outArgs :: UpdFrameOffset
outArgs, regs :: [GlobalReg]
regs, copies :: 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 e :: CmmExpr
e cont :: Maybe BlockId
cont updfr_off :: UpdFrameOffset
updfr_off res_space :: UpdFrameOffset
res_space arg_space :: UpdFrameOffset
arg_space regs :: [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