{-# 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 ( (<*>) )
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
type CmmAGraph = OrdList CgStmt
type CmmAGraphScoped = (CmmAGraph, CmmTickScope)
data CgStmt
= CgLabel BlockId CmmTickScope
| CgStmt (CmmNode O O)
| CgLast (CmmNode O C)
| CgFork BlockId CmmAGraph CmmTickScope
flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
flattenCmmAGraph BlockId
id (CmmAGraph
stmts_t, CmmTickScope
tscope) =
CmmGraph { g_entry :: BlockId
g_entry = BlockId
id,
g_graph :: Graph CmmNode C C
g_graph = forall (e :: Extensibility)
(block :: (Extensibility -> Extensibility -> *)
-> Extensibility -> Extensibility -> *)
(n :: Extensibility -> Extensibility -> *) (x :: Extensibility).
MaybeO e (block n O C)
-> Body' block n -> MaybeO x (block n C O) -> Graph' block n e x
GMany forall t. MaybeO C t
NothingO LabelMap (Block CmmNode C C)
body forall t. MaybeO C t
NothingO }
where
body :: LabelMap (Block CmmNode C C)
body = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (block :: Extensibility -> Extensibility -> *).
(NonLocal block, HasDebugCallStack) =>
block C C -> LabelMap (block C C) -> LabelMap (block C C)
addBlock forall (block :: (Extensibility -> Extensibility -> *)
-> Extensibility -> Extensibility -> *)
(n :: Extensibility -> Extensibility -> *).
Body' block n
emptyBody forall a b. (a -> b) -> a -> b
$ BlockId
-> CmmAGraph
-> CmmTickScope
-> [Block CmmNode C C]
-> [Block CmmNode C C]
flatten BlockId
id CmmAGraph
stmts_t CmmTickScope
tscope []
flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]
-> [Block CmmNode C C]
flatten :: BlockId
-> CmmAGraph
-> CmmTickScope
-> [Block CmmNode C C]
-> [Block CmmNode C C]
flatten BlockId
id CmmAGraph
g CmmTickScope
tscope [Block CmmNode C C]
blocks
= [CgStmt]
-> Block CmmNode C O -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 (forall a. OrdList a -> [a]
fromOL CmmAGraph
g) Block CmmNode C O
block' [Block CmmNode C C]
blocks
where !block' :: Block CmmNode C O
block' = forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
n C O -> Block n O x -> Block n C x
blockJoinHead (BlockId -> CmmTickScope -> CmmNode C O
CmmEntry BlockId
id CmmTickScope
tscope) forall (n :: Extensibility -> Extensibility -> *). Block n O O
emptyBlock
flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [] [Block CmmNode C C]
blocks = [Block CmmNode C C]
blocks
flatten0 (CgLabel BlockId
id CmmTickScope
tscope : [CgStmt]
stmts) [Block CmmNode C C]
blocks
= [CgStmt]
-> Block CmmNode C O -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 [CgStmt]
stmts Block CmmNode C O
block [Block CmmNode C C]
blocks
where !block :: Block CmmNode C O
block = forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
n C O -> Block n O x -> Block n C x
blockJoinHead (BlockId -> CmmTickScope -> CmmNode C O
CmmEntry BlockId
id CmmTickScope
tscope) forall (n :: Extensibility -> Extensibility -> *). Block n O O
emptyBlock
flatten0 (CgFork BlockId
fork_id CmmAGraph
stmts_t CmmTickScope
tscope : [CgStmt]
rest) [Block CmmNode C C]
blocks
= BlockId
-> CmmAGraph
-> CmmTickScope
-> [Block CmmNode C C]
-> [Block CmmNode C C]
flatten BlockId
fork_id CmmAGraph
stmts_t CmmTickScope
tscope forall a b. (a -> b) -> a -> b
$ [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [CgStmt]
rest [Block CmmNode C C]
blocks
flatten0 (CgLast CmmNode O C
_ : [CgStmt]
stmts) [Block CmmNode C C]
blocks = [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [CgStmt]
stmts [Block CmmNode C C]
blocks
flatten0 (CgStmt CmmNode O O
_ : [CgStmt]
stmts) [Block CmmNode C C]
blocks = [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [CgStmt]
stmts [Block CmmNode C C]
blocks
flatten1 :: [CgStmt] -> Block CmmNode C O
-> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 :: [CgStmt]
-> Block CmmNode C O -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 [] Block CmmNode C O
block [Block CmmNode C C]
blocks
= forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e O -> n O C -> Block n e C
blockJoinTail Block CmmNode C O
block (BlockId -> CmmNode O C
CmmBranch (forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel Block CmmNode C O
block)) forall a. a -> [a] -> [a]
: [Block CmmNode C C]
blocks
flatten1 (CgLast CmmNode O C
stmt : [CgStmt]
stmts) Block CmmNode C O
block [Block CmmNode C C]
blocks
= Block CmmNode C C
block' forall a. a -> [a] -> [a]
: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [CgStmt]
stmts [Block CmmNode C C]
blocks
where !block' :: Block CmmNode C C
block' = forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e O -> n O C -> Block n e C
blockJoinTail Block CmmNode C O
block CmmNode O C
stmt
flatten1 (CgStmt CmmNode O O
stmt : [CgStmt]
stmts) Block CmmNode C O
block [Block CmmNode C C]
blocks
= [CgStmt]
-> Block CmmNode C O -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 [CgStmt]
stmts Block CmmNode C O
block' [Block CmmNode C C]
blocks
where !block' :: Block CmmNode C O
block' = forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e O -> n O O -> Block n e O
blockSnoc Block CmmNode C O
block CmmNode O O
stmt
flatten1 (CgFork BlockId
fork_id CmmAGraph
stmts_t CmmTickScope
tscope : [CgStmt]
rest) Block CmmNode C O
block [Block CmmNode C C]
blocks
= BlockId
-> CmmAGraph
-> CmmTickScope
-> [Block CmmNode C C]
-> [Block CmmNode C C]
flatten BlockId
fork_id CmmAGraph
stmts_t CmmTickScope
tscope forall a b. (a -> b) -> a -> b
$ [CgStmt]
-> Block CmmNode C O -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 [CgStmt]
rest Block CmmNode C O
block [Block CmmNode C C]
blocks
flatten1 (CgLabel BlockId
id CmmTickScope
tscp : [CgStmt]
stmts) Block CmmNode C O
block [Block CmmNode C C]
blocks
= forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e O -> n O C -> Block n e C
blockJoinTail Block CmmNode C O
block (BlockId -> CmmNode O C
CmmBranch BlockId
id) forall a. a -> [a] -> [a]
:
[CgStmt]
-> Block CmmNode C O -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten1 [CgStmt]
stmts (forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
n C O -> Block n O x -> Block n C x
blockJoinHead (BlockId -> CmmTickScope -> CmmNode C O
CmmEntry BlockId
id CmmTickScope
tscp) forall (n :: Extensibility -> Extensibility -> *). Block n O O
emptyBlock) [Block CmmNode C C]
blocks
(<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph
<*> :: CmmAGraph -> CmmAGraph -> CmmAGraph
(<*>) = forall a. OrdList a -> OrdList a -> OrdList a
appOL
catAGraphs :: [CmmAGraph] -> CmmAGraph
catAGraphs :: [CmmAGraph] -> CmmAGraph
catAGraphs = forall a. [OrdList a] -> OrdList a
concatOL
mkLabel :: BlockId -> CmmTickScope -> CmmAGraph
mkLabel :: BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
bid CmmTickScope
scp = forall a. a -> OrdList a
unitOL (BlockId -> CmmTickScope -> CgStmt
CgLabel BlockId
bid CmmTickScope
scp)
mkMiddle :: CmmNode O O -> CmmAGraph
mkMiddle :: CmmNode O O -> CmmAGraph
mkMiddle CmmNode O O
middle = forall a. a -> OrdList a
unitOL (CmmNode O O -> CgStmt
CgStmt CmmNode O O
middle)
mkLast :: CmmNode O C -> CmmAGraph
mkLast :: CmmNode O C -> CmmAGraph
mkLast CmmNode O C
last = forall a. a -> OrdList a
unitOL (CmmNode O C -> CgStmt
CgLast CmmNode O C
last)
outOfLine :: BlockId -> CmmAGraphScoped -> CmmAGraph
outOfLine :: BlockId -> CmmAGraphScoped -> CmmAGraph
outOfLine BlockId
l (CmmAGraph
c,CmmTickScope
s) = forall a. a -> OrdList a
unitOL (BlockId -> CmmAGraph -> CmmTickScope -> CgStmt
CgFork BlockId
l CmmAGraph
c CmmTickScope
s)
lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph
lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph
lgraphOfAGraph CmmAGraphScoped
g = do
Unique
u <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> CmmAGraphScoped -> CmmGraph
labelAGraph (Unique -> BlockId
mkBlockId Unique
u) CmmAGraphScoped
g)
labelAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
labelAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
labelAGraph BlockId
lbl CmmAGraphScoped
ag = BlockId -> CmmAGraphScoped -> CmmGraph
flattenCmmAGraph BlockId
lbl CmmAGraphScoped
ag
mkNop :: CmmAGraph
mkNop :: CmmAGraph
mkNop = forall a. OrdList a
nilOL
mkComment :: FastString -> CmmAGraph
FastString
fs
| Bool
debugIsOn = CmmNode O O -> CmmAGraph
mkMiddle forall a b. (a -> b) -> a -> b
$ FastString -> CmmNode O O
CmmComment FastString
fs
| Bool
otherwise = forall a. OrdList a
nilOL
mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
l (CmmReg CmmReg
r) | CmmReg
l forall a. Eq a => a -> a -> Bool
== CmmReg
r = CmmAGraph
mkNop
mkAssign CmmReg
l CmmExpr
r = CmmNode O O -> CmmAGraph
mkMiddle forall a b. (a -> b) -> a -> b
$ CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
l CmmExpr
r
mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore CmmExpr
l CmmExpr
r = CmmNode O O -> CmmAGraph
mkMiddle forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode O O
CmmStore CmmExpr
l CmmExpr
r AlignmentSpec
NaturallyAligned
mkJump :: Profile -> Convention -> CmmExpr
-> [CmmExpr]
-> UpdFrameOffset
-> CmmAGraph
mkJump :: Profile
-> Convention -> CmmExpr -> [CmmExpr] -> ByteOff -> CmmAGraph
mkJump Profile
profile Convention
conv CmmExpr
e [CmmExpr]
actuals ByteOff
updfr_off =
Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs Profile
profile Transfer
Jump Area
Old Convention
conv [CmmExpr]
actuals ByteOff
updfr_off forall a b. (a -> b) -> a -> b
$
CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e forall a. Maybe a
Nothing ByteOff
updfr_off ByteOff
0
mkRawJump :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
-> CmmAGraph
mkRawJump :: Profile -> CmmExpr -> ByteOff -> [GlobalReg] -> CmmAGraph
mkRawJump Profile
profile CmmExpr
e ByteOff
updfr_off [GlobalReg]
vols =
Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs Profile
profile Transfer
Jump Area
Old Convention
NativeNodeCall [] ByteOff
updfr_off forall a b. (a -> b) -> a -> b
$
\ByteOff
arg_space [GlobalReg]
_ -> CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e forall a. Maybe a
Nothing ByteOff
updfr_off ByteOff
0 ByteOff
arg_space [GlobalReg]
vols
mkJumpExtra :: Profile -> Convention -> CmmExpr -> [CmmExpr]
-> UpdFrameOffset -> [CmmExpr]
-> CmmAGraph
Profile
profile Convention
conv CmmExpr
e [CmmExpr]
actuals ByteOff
updfr_off [CmmExpr]
extra_stack =
Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> [CmmExpr]
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgsAndExtraStack Profile
profile Transfer
Jump Area
Old Convention
conv [CmmExpr]
actuals ByteOff
updfr_off [CmmExpr]
extra_stack forall a b. (a -> b) -> a -> b
$
CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e forall a. Maybe a
Nothing ByteOff
updfr_off ByteOff
0
mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch CmmExpr
pred BlockId
ifso BlockId
ifnot Maybe Bool
likely =
CmmNode O C -> CmmAGraph
mkLast (CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
CmmCondBranch CmmExpr
pred BlockId
ifso BlockId
ifnot Maybe Bool
likely)
mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph
mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph
mkSwitch CmmExpr
e SwitchTargets
tbl = CmmNode O C -> CmmAGraph
mkLast forall a b. (a -> b) -> a -> b
$ CmmExpr -> SwitchTargets -> CmmNode O C
CmmSwitch CmmExpr
e SwitchTargets
tbl
mkReturn :: Profile -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
-> CmmAGraph
mkReturn :: Profile -> CmmExpr -> [CmmExpr] -> ByteOff -> CmmAGraph
mkReturn Profile
profile CmmExpr
e [CmmExpr]
actuals ByteOff
updfr_off =
Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs Profile
profile Transfer
Ret Area
Old Convention
NativeReturn [CmmExpr]
actuals ByteOff
updfr_off forall a b. (a -> b) -> a -> b
$
CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e forall a. Maybe a
Nothing ByteOff
updfr_off ByteOff
0
mkBranch :: BlockId -> CmmAGraph
mkBranch :: BlockId -> CmmAGraph
mkBranch BlockId
bid = CmmNode O C -> CmmAGraph
mkLast (BlockId -> CmmNode O C
CmmBranch BlockId
bid)
mkFinalCall :: Profile
-> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset
-> CmmAGraph
mkFinalCall :: Profile
-> CmmExpr -> CCallConv -> [CmmExpr] -> ByteOff -> CmmAGraph
mkFinalCall Profile
profile CmmExpr
f CCallConv
_ [CmmExpr]
actuals ByteOff
updfr_off =
Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs Profile
profile Transfer
Call Area
Old Convention
NativeDirectCall [CmmExpr]
actuals ByteOff
updfr_off forall a b. (a -> b) -> a -> b
$
CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
f forall a. Maybe a
Nothing ByteOff
updfr_off ByteOff
0
mkCallReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
-> BlockId
-> ByteOff
-> UpdFrameOffset
-> [CmmExpr]
-> CmmAGraph
mkCallReturnsTo :: Profile
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> ByteOff
-> ByteOff
-> [CmmExpr]
-> CmmAGraph
mkCallReturnsTo Profile
profile CmmExpr
f Convention
callConv [CmmExpr]
actuals BlockId
ret_lbl ByteOff
ret_off ByteOff
updfr_off [CmmExpr]
extra_stack =
Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> [CmmExpr]
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgsAndExtraStack Profile
profile Transfer
Call (BlockId -> Area
Young BlockId
ret_lbl) Convention
callConv [CmmExpr]
actuals
ByteOff
updfr_off [CmmExpr]
extra_stack forall a b. (a -> b) -> a -> b
$
CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
f (forall a. a -> Maybe a
Just BlockId
ret_lbl) ByteOff
updfr_off ByteOff
ret_off
mkJumpReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
-> BlockId
-> ByteOff
-> UpdFrameOffset
-> CmmAGraph
mkJumpReturnsTo :: Profile
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> ByteOff
-> ByteOff
-> CmmAGraph
mkJumpReturnsTo Profile
profile CmmExpr
f Convention
callConv [CmmExpr]
actuals BlockId
ret_lbl ByteOff
ret_off ByteOff
updfr_off =
Profile
-> Transfer
-> Area
-> Convention
-> [CmmExpr]
-> ByteOff
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs Profile
profile Transfer
JumpRet (BlockId -> Area
Young BlockId
ret_lbl) Convention
callConv [CmmExpr]
actuals ByteOff
updfr_off forall a b. (a -> b) -> a -> b
$
CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
f (forall a. a -> Maybe a
Just BlockId
ret_lbl) ByteOff
updfr_off ByteOff
ret_off
mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmAGraph
mkUnsafeCall ForeignTarget
t [CmmFormal]
fs [CmmExpr]
as = CmmNode O O -> CmmAGraph
mkMiddle forall a b. (a -> b) -> a -> b
$ ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode O O
CmmUnsafeForeignCall ForeignTarget
t [CmmFormal]
fs [CmmExpr]
as
mkUnwind :: GlobalReg -> CmmExpr -> CmmAGraph
mkUnwind :: GlobalReg -> CmmExpr -> CmmAGraph
mkUnwind GlobalReg
r CmmExpr
e = CmmNode O O -> CmmAGraph
mkMiddle forall a b. (a -> b) -> a -> b
$ [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
CmmUnwind [(GlobalReg
r, forall a. a -> Maybe a
Just CmmExpr
e)]
stackStubExpr :: Width -> CmmExpr
stackStubExpr :: Width -> CmmExpr
stackStubExpr Width
w = CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
0 Width
w)
copyInOflow :: Profile -> Convention -> Area
-> [CmmFormal]
-> [CmmFormal]
-> (Int, [GlobalReg], CmmAGraph)
copyInOflow :: Profile
-> Convention
-> Area
-> [CmmFormal]
-> [CmmFormal]
-> (ByteOff, [GlobalReg], CmmAGraph)
copyInOflow Profile
profile Convention
conv Area
area [CmmFormal]
formals [CmmFormal]
extra_stk
= (ByteOff
offset, [GlobalReg]
gregs, [CmmAGraph] -> CmmAGraph
catAGraphs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map CmmNode O O -> CmmAGraph
mkMiddle [CmmNode O O]
nodes)
where (ByteOff
offset, [GlobalReg]
gregs, [CmmNode O O]
nodes) = Profile
-> Convention
-> Area
-> [CmmFormal]
-> [CmmFormal]
-> (ByteOff, [GlobalReg], [CmmNode O O])
copyIn Profile
profile Convention
conv Area
area [CmmFormal]
formals [CmmFormal]
extra_stk
copyIn :: Profile -> Convention -> Area
-> [CmmFormal]
-> [CmmFormal]
-> (ByteOff, [GlobalReg], [CmmNode O O])
copyIn :: Profile
-> Convention
-> Area
-> [CmmFormal]
-> [CmmFormal]
-> (ByteOff, [GlobalReg], [CmmNode O O])
copyIn Profile
profile Convention
conv Area
area [CmmFormal]
formals [CmmFormal]
extra_stk
= (ByteOff
stk_size, [GlobalReg
r | (CmmFormal
_, RegisterParam GlobalReg
r) <- [(CmmFormal, ParamLocation)]
args], forall a b. (a -> b) -> [a] -> [b]
map (CmmFormal, ParamLocation) -> CmmNode O O
ci ([(CmmFormal, ParamLocation)]
stk_args forall a. [a] -> [a] -> [a]
++ [(CmmFormal, ParamLocation)]
args))
where
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
ci :: (CmmFormal, ParamLocation) -> CmmNode O O
ci (CmmFormal
reg, RegisterParam r :: GlobalReg
r@(VanillaReg {})) =
let local :: CmmReg
local = CmmFormal -> CmmReg
CmmLocal CmmFormal
reg
global :: CmmExpr
global = CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r)
width :: Width
width = Platform -> CmmReg -> Width
cmmRegWidth Platform
platform CmmReg
local
expr :: CmmExpr
expr
| Width
width forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform = CmmExpr
global
| Width
width forall a. Ord a => a -> a -> Bool
< Platform -> Width
wordWidth Platform
platform =
MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_XX_Conv (Platform -> Width
wordWidth Platform
platform) Width
width) [CmmExpr
global]
| Bool
otherwise = forall a. String -> a
panic String
"Parameter width greater than word width"
in CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
local CmmExpr
expr
ci (CmmFormal
reg, RegisterParam GlobalReg
r) =
CmmReg -> CmmExpr -> CmmNode O O
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
reg) (CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r))
ci (CmmFormal
reg, StackParam ByteOff
off)
| CmmType -> Bool
isBitsType forall a b. (a -> b) -> a -> b
$ CmmFormal -> CmmType
localRegType CmmFormal
reg
, CmmType -> Width
typeWidth (CmmFormal -> CmmType
localRegType CmmFormal
reg) forall a. Ord a => a -> a -> Bool
< Platform -> Width
wordWidth Platform
platform =
let
stack_slot :: CmmExpr
stack_slot = CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Area -> ByteOff -> CmmExpr
CmmStackSlot Area
area ByteOff
off) (Width -> CmmType
cmmBits forall a b. (a -> b) -> a -> b
$ Platform -> Width
wordWidth Platform
platform) AlignmentSpec
NaturallyAligned
local :: CmmReg
local = CmmFormal -> CmmReg
CmmLocal CmmFormal
reg
width :: Width
width = Platform -> CmmReg -> Width
cmmRegWidth Platform
platform CmmReg
local
expr :: CmmExpr
expr = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_XX_Conv (Platform -> Width
wordWidth Platform
platform) Width
width) [CmmExpr
stack_slot]
in CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
local CmmExpr
expr
| Bool
otherwise =
CmmReg -> CmmExpr -> CmmNode O O
CmmAssign (CmmFormal -> CmmReg
CmmLocal CmmFormal
reg) (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Area -> ByteOff -> CmmExpr
CmmStackSlot Area
area ByteOff
off) CmmType
ty AlignmentSpec
NaturallyAligned)
where ty :: CmmType
ty = CmmFormal -> CmmType
localRegType CmmFormal
reg
init_offset :: ByteOff
init_offset = Width -> ByteOff
widthInBytes (Platform -> Width
wordWidth Platform
platform)
(ByteOff
stk_off, [(CmmFormal, ParamLocation)]
stk_args) = forall a.
Platform
-> ByteOff
-> (a -> CmmType)
-> [a]
-> (ByteOff, [(a, ParamLocation)])
assignStack Platform
platform ByteOff
init_offset CmmFormal -> CmmType
localRegType [CmmFormal]
extra_stk
(ByteOff
stk_size, [(CmmFormal, ParamLocation)]
args) = forall a.
Profile
-> ByteOff
-> Convention
-> (a -> CmmType)
-> [a]
-> (ByteOff, [(a, ParamLocation)])
assignArgumentsPos Profile
profile ByteOff
stk_off Convention
conv
CmmFormal -> CmmType
localRegType [CmmFormal]
formals
data Transfer = Call | JumpRet | Jump | Ret deriving Transfer -> Transfer -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Transfer -> Transfer -> Bool
$c/= :: Transfer -> Transfer -> Bool
== :: Transfer -> Transfer -> Bool
$c== :: Transfer -> Transfer -> Bool
Eq
copyOutOflow :: Profile -> Convention -> Transfer -> Area -> [CmmExpr]
-> UpdFrameOffset
-> [CmmExpr]
-> (Int, [GlobalReg], CmmAGraph)
copyOutOflow :: Profile
-> Convention
-> Transfer
-> Area
-> [CmmExpr]
-> ByteOff
-> [CmmExpr]
-> (ByteOff, [GlobalReg], CmmAGraph)
copyOutOflow Profile
profile Convention
conv Transfer
transfer Area
area [CmmExpr]
actuals ByteOff
updfr_off [CmmExpr]
extra_stack_stuff
= (ByteOff
stk_size, [GlobalReg]
regs, CmmAGraph
graph)
where
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
([GlobalReg]
regs, CmmAGraph
graph) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CmmExpr, ParamLocation)
-> ([GlobalReg], CmmAGraph) -> ([GlobalReg], CmmAGraph)
co ([], CmmAGraph
mkNop) ([(CmmExpr, ParamLocation)]
setRA forall a. [a] -> [a] -> [a]
++ [(CmmExpr, ParamLocation)]
args forall a. [a] -> [a] -> [a]
++ [(CmmExpr, ParamLocation)]
stack_params)
co :: (CmmExpr, ParamLocation)
-> ([GlobalReg], CmmAGraph) -> ([GlobalReg], CmmAGraph)
co (CmmExpr
v, RegisterParam r :: GlobalReg
r@(VanillaReg {})) ([GlobalReg]
rs, CmmAGraph
ms) =
let width :: Width
width = Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
v
value :: CmmExpr
value
| Width
width forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform = CmmExpr
v
| Width
width forall a. Ord a => a -> a -> Bool
< Platform -> Width
wordWidth Platform
platform =
MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_XX_Conv Width
width (Platform -> Width
wordWidth Platform
platform)) [CmmExpr
v]
| Bool
otherwise = forall a. String -> a
panic String
"Parameter width greater than word width"
in (GlobalReg
rforall a. a -> [a] -> [a]
:[GlobalReg]
rs, CmmReg -> CmmExpr -> CmmAGraph
mkAssign (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r) CmmExpr
value CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
ms)
co (CmmExpr
v, RegisterParam GlobalReg
r) ([GlobalReg]
rs, CmmAGraph
ms) =
(GlobalReg
rforall a. a -> [a] -> [a]
:[GlobalReg]
rs, CmmReg -> CmmExpr -> CmmAGraph
mkAssign (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r) CmmExpr
v CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
ms)
co (CmmExpr
v, StackParam ByteOff
off) ([GlobalReg]
rs, CmmAGraph
ms)
= ([GlobalReg]
rs, CmmExpr -> CmmExpr -> CmmAGraph
mkStore (Area -> ByteOff -> CmmExpr
CmmStackSlot Area
area ByteOff
off) (CmmExpr -> CmmExpr
value CmmExpr
v) CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
ms)
width :: CmmExpr -> Width
width CmmExpr
v = Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
v
value :: CmmExpr -> CmmExpr
value CmmExpr
v
| CmmType -> Bool
isBitsType forall a b. (a -> b) -> a -> b
$ Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
v
, CmmExpr -> Width
width CmmExpr
v forall a. Ord a => a -> a -> Bool
< Platform -> Width
wordWidth Platform
platform =
MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_XX_Conv (CmmExpr -> Width
width CmmExpr
v) (Platform -> Width
wordWidth Platform
platform)) [CmmExpr
v]
| Bool
otherwise = CmmExpr
v
([(CmmExpr, ParamLocation)]
setRA, ByteOff
init_offset) =
case Area
area of
Young BlockId
id ->
case Transfer
transfer of
Transfer
Call ->
([(CmmLit -> CmmExpr
CmmLit (BlockId -> CmmLit
CmmBlock BlockId
id), ByteOff -> ParamLocation
StackParam ByteOff
init_offset)],
Width -> ByteOff
widthInBytes (Platform -> Width
wordWidth Platform
platform))
Transfer
JumpRet ->
([],
Width -> ByteOff
widthInBytes (Platform -> Width
wordWidth Platform
platform))
Transfer
_other ->
([], ByteOff
0)
Area
Old -> ([], ByteOff
updfr_off)
(ByteOff
extra_stack_off, [(CmmExpr, ParamLocation)]
stack_params) =
forall a.
Platform
-> ByteOff
-> (a -> CmmType)
-> [a]
-> (ByteOff, [(a, ParamLocation)])
assignStack Platform
platform ByteOff
init_offset (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform) [CmmExpr]
extra_stack_stuff
args :: [(CmmExpr, ParamLocation)]
(ByteOff
stk_size, [(CmmExpr, ParamLocation)]
args) = forall a.
Profile
-> ByteOff
-> Convention
-> (a -> CmmType)
-> [a]
-> (ByteOff, [(a, ParamLocation)])
assignArgumentsPos Profile
profile ByteOff
extra_stack_off Convention
conv
(Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform) [CmmExpr]
actuals
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]
= []
toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
-> ByteOff -> [GlobalReg]
-> CmmAGraph
toCall :: CmmExpr
-> Maybe BlockId
-> ByteOff
-> ByteOff
-> ByteOff
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
e Maybe BlockId
cont ByteOff
updfr_off ByteOff
res_space ByteOff
arg_space [GlobalReg]
regs =
CmmNode O C -> CmmAGraph
mkLast forall a b. (a -> b) -> a -> b
$ CmmExpr
-> Maybe BlockId
-> [GlobalReg]
-> ByteOff
-> ByteOff
-> ByteOff
-> CmmNode O C
CmmCall CmmExpr
e Maybe BlockId
cont [GlobalReg]
regs ByteOff
arg_space ByteOff
res_space ByteOff
updfr_off