{-# LANGUAGE RecordWildCards, GADTs #-}
module GHC.Cmm.LayoutStack (
cmmLayoutStack, setInfoTableStackMap
) where
import GHC.Prelude hiding ((<*>))
import GHC.Platform
import GHC.Platform.Profile
import GHC.StgToCmm.Monad ( newTemp )
import GHC.StgToCmm.Utils ( callerSaveVolatileRegs )
import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState )
import GHC.Cmm
import GHC.Cmm.Info
import GHC.Cmm.BlockId
import GHC.Cmm.Config
import GHC.Cmm.Utils
import GHC.Cmm.Graph
import GHC.Cmm.Liveness
import GHC.Cmm.ProcPoint
import GHC.Runtime.Heap.Layout
import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Data.Maybe
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSM
import GHC.Utils.Misc
import GHC.Utils.Outputable hiding ( isEmpty )
import GHC.Utils.Panic
import qualified Data.Set as Set
import Control.Monad.Fix
import Data.Array as Array
import Data.List (nub)
type StackLoc = ByteOff
data StackMap = StackMap
{ StackMap -> WordOff
sm_sp :: StackLoc
, StackMap -> WordOff
sm_args :: ByteOff
, StackMap -> WordOff
sm_ret_off :: ByteOff
, StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs :: UniqFM LocalReg (LocalReg,StackLoc)
}
instance Outputable StackMap where
ppr :: StackMap -> SDoc
ppr StackMap{WordOff
UniqFM LocalReg (LocalReg, WordOff)
sm_sp :: StackMap -> WordOff
sm_args :: StackMap -> WordOff
sm_ret_off :: StackMap -> WordOff
sm_regs :: StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_sp :: WordOff
sm_args :: WordOff
sm_ret_off :: WordOff
sm_regs :: UniqFM LocalReg (LocalReg, WordOff)
..} =
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Sp = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> WordOff -> SDoc
forall doc. IsLine doc => WordOff -> doc
int WordOff
sm_sp SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sm_args = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> WordOff -> SDoc
forall doc. IsLine doc => WordOff -> doc
int WordOff
sm_args SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sm_ret_off = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> WordOff -> SDoc
forall doc. IsLine doc => WordOff -> doc
int WordOff
sm_ret_off SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sm_regs = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> UniqFM LocalReg (LocalReg, WordOff)
-> ([(LocalReg, WordOff)] -> SDoc) -> SDoc
forall {k} (key :: k) a. UniqFM key a -> ([a] -> SDoc) -> SDoc
pprUFM UniqFM LocalReg (LocalReg, WordOff)
sm_regs [(LocalReg, WordOff)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr
cmmLayoutStack :: CmmConfig -> ProcPointSet -> ByteOff -> CmmGraph
-> UniqDSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack :: CmmConfig
-> ProcPointSet
-> WordOff
-> CmmGraph
-> UniqDSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack CmmConfig
cfg ProcPointSet
procpoints WordOff
entry_args
graph :: CmmGraph
graph@(CmmGraph { g_entry :: forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> BlockId
g_entry = BlockId
entry })
= do
let liveness :: BlockEntryLiveness LocalReg
liveness = Platform -> CmmGraph -> BlockEntryLiveness LocalReg
cmmLocalLiveness Platform
platform CmmGraph
graph
blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
revPostorder CmmGraph
graph
profile :: Profile
profile = CmmConfig -> Profile
cmmProfile CmmConfig
cfg
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
(final_stackmaps, _final_high_sp, new_blocks) <-
((LabelMap StackMap, WordOff, [CmmBlock])
-> UniqDSM (LabelMap StackMap, WordOff, [CmmBlock]))
-> UniqDSM (LabelMap StackMap, WordOff, [CmmBlock])
forall a. (a -> UniqDSM a) -> UniqDSM a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (((LabelMap StackMap, WordOff, [CmmBlock])
-> UniqDSM (LabelMap StackMap, WordOff, [CmmBlock]))
-> UniqDSM (LabelMap StackMap, WordOff, [CmmBlock]))
-> ((LabelMap StackMap, WordOff, [CmmBlock])
-> UniqDSM (LabelMap StackMap, WordOff, [CmmBlock]))
-> UniqDSM (LabelMap StackMap, WordOff, [CmmBlock])
forall a b. (a -> b) -> a -> b
$ \ ~(LabelMap StackMap
rec_stackmaps, WordOff
rec_high_sp, [CmmBlock]
_new_blocks) ->
CmmConfig
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> BlockId
-> WordOff
-> LabelMap StackMap
-> WordOff
-> [CmmBlock]
-> UniqDSM (LabelMap StackMap, WordOff, [CmmBlock])
layout CmmConfig
cfg ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness BlockId
entry WordOff
entry_args
LabelMap StackMap
rec_stackmaps WordOff
rec_high_sp [CmmBlock]
blocks
blocks_with_reloads <-
insertReloadsAsNeeded platform procpoints final_stackmaps entry new_blocks
new_blocks' <- mapM (lowerSafeForeignCall profile) blocks_with_reloads
return (ofBlockList entry new_blocks', final_stackmaps)
layout :: CmmConfig
-> LabelSet
-> LabelMap CmmLocalLive
-> BlockId
-> ByteOff
-> LabelMap StackMap
-> ByteOff
-> [CmmBlock]
-> UniqDSM
( LabelMap StackMap
, ByteOff
, [CmmBlock]
)
layout :: CmmConfig
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> BlockId
-> WordOff
-> LabelMap StackMap
-> WordOff
-> [CmmBlock]
-> UniqDSM (LabelMap StackMap, WordOff, [CmmBlock])
layout CmmConfig
cfg ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness BlockId
entry WordOff
entry_args LabelMap StackMap
final_stackmaps WordOff
final_sp_high [CmmBlock]
blocks
= [CmmBlock]
-> LabelMap StackMap
-> WordOff
-> [CmmBlock]
-> UniqDSM (LabelMap StackMap, WordOff, [CmmBlock])
go [CmmBlock]
blocks LabelMap StackMap
init_stackmap WordOff
entry_args []
where
(WordOff
updfr, LabelMap WordOff
cont_info) = [CmmBlock] -> (WordOff, LabelMap WordOff)
collectContInfo [CmmBlock]
blocks
init_stackmap :: LabelMap StackMap
init_stackmap = BlockId -> StackMap -> LabelMap StackMap
forall v. BlockId -> v -> LabelMap v
mapSingleton BlockId
entry
StackMap{ sm_sp :: WordOff
sm_sp = WordOff
entry_args
, sm_args :: WordOff
sm_args = WordOff
entry_args
, sm_ret_off :: WordOff
sm_ret_off = WordOff
updfr
, sm_regs :: UniqFM LocalReg (LocalReg, WordOff)
sm_regs = UniqFM LocalReg (LocalReg, WordOff)
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM
}
go :: [Block CmmNode C C]
-> LabelMap StackMap
-> StackLoc
-> [CmmBlock]
-> UniqDSM (LabelMap StackMap, StackLoc, [CmmBlock])
go :: [CmmBlock]
-> LabelMap StackMap
-> WordOff
-> [CmmBlock]
-> UniqDSM (LabelMap StackMap, WordOff, [CmmBlock])
go [] LabelMap StackMap
acc_stackmaps WordOff
acc_hwm [CmmBlock]
acc_blocks
= (LabelMap StackMap, WordOff, [CmmBlock])
-> UniqDSM (LabelMap StackMap, WordOff, [CmmBlock])
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelMap StackMap
acc_stackmaps, WordOff
acc_hwm, [CmmBlock]
acc_blocks)
go (CmmBlock
b0 : [CmmBlock]
bs) LabelMap StackMap
acc_stackmaps WordOff
acc_hwm [CmmBlock]
acc_blocks
= do
let (entry0 :: CmmNode C O
entry0@(CmmEntry BlockId
entry_lbl CmmTickScope
tscope), Block CmmNode O O
middle0, CmmNode O C
last0) = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
b0
let stack0 :: StackMap
stack0@StackMap { sm_sp :: StackMap -> WordOff
sm_sp = WordOff
sp0 }
= StackMap -> BlockId -> LabelMap StackMap -> StackMap
forall a. a -> BlockId -> LabelMap a -> a
mapFindWithDefault
(String -> SDoc -> StackMap
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"no stack map for" (BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
entry_lbl))
BlockId
entry_lbl LabelMap StackMap
acc_stackmaps
let stack1 :: IndexedCO O StackMap StackMap
stack1 = (forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> StackMap -> StackMap)
-> forall (e :: Extensibility) (x :: Extensibility).
Block CmmNode e x
-> IndexedCO e StackMap StackMap -> IndexedCO x StackMap StackMap
forall (n :: Extensibility -> Extensibility -> *) a.
(forall (e :: Extensibility) (x :: Extensibility). n e x -> a -> a)
-> forall (e :: Extensibility) (x :: Extensibility).
Block n e x -> IndexedCO e a a -> IndexedCO x a a
foldBlockNodesF (LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
forall (e :: Extensibility) (x :: Extensibility).
LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle LabelMap StackMap
acc_stackmaps) Block CmmNode O O
middle0 IndexedCO O StackMap StackMap
StackMap
stack0
(middle1, sp_off, last1, fixup_blocks, out)
<- CmmConfig
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> LabelMap WordOff
-> LabelMap StackMap
-> StackMap
-> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleLastNode CmmConfig
cfg ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness LabelMap WordOff
cont_info
LabelMap StackMap
acc_stackmaps IndexedCO O StackMap StackMap
StackMap
stack1 CmmTickScope
tscope Block CmmNode O O
middle0 CmmNode O C
last0
let middle_pre = Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList (Block CmmNode O O -> [CmmNode O O])
-> Block CmmNode O O -> [CmmNode O O]
forall a b. (a -> b) -> a -> b
$ (Block CmmNode O O -> CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> [CmmNode O O] -> Block CmmNode O O
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Block CmmNode O O -> CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e O -> n O O -> Block n e O
blockSnoc Block CmmNode O O
middle0 [CmmNode O O]
middle1
let final_blocks =
CmmConfig
-> LabelMap StackMap
-> StackMap
-> WordOff
-> WordOff
-> CmmNode C O
-> [CmmNode O O]
-> WordOff
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp CmmConfig
cfg LabelMap StackMap
final_stackmaps StackMap
stack0 WordOff
sp0 WordOff
final_sp_high
CmmNode C O
entry0 [CmmNode O O]
middle_pre WordOff
sp_off CmmNode O C
last1 [CmmBlock]
fixup_blocks
let acc_stackmaps' = LabelMap StackMap -> LabelMap StackMap -> LabelMap StackMap
forall v. LabelMap v -> LabelMap v -> LabelMap v
mapUnion LabelMap StackMap
acc_stackmaps LabelMap StackMap
out
this_sp_hwm | CmmNode O C -> Bool
isGcJump CmmNode O C
last0 = WordOff
0
| Bool
otherwise = WordOff
sp0 WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
sp_off
hwm' = [WordOff] -> WordOff
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (WordOff
acc_hwm WordOff -> [WordOff] -> [WordOff]
forall a. a -> [a] -> [a]
: WordOff
this_sp_hwm WordOff -> [WordOff] -> [WordOff]
forall a. a -> [a] -> [a]
: (StackMap -> WordOff) -> [StackMap] -> [WordOff]
forall a b. (a -> b) -> [a] -> [b]
map StackMap -> WordOff
sm_sp (LabelMap StackMap -> [StackMap]
forall a. LabelMap a -> [a]
mapElems LabelMap StackMap
out))
go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)
isGcJump :: CmmNode O C -> Bool
isGcJump :: CmmNode O C -> Bool
isGcJump (CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmReg (CmmGlobal (GlobalRegUse GlobalReg
l CmmType
_)) })
= GlobalReg
l GlobalReg -> GlobalReg -> Bool
forall a. Eq a => a -> a -> Bool
== GlobalReg
GCFun Bool -> Bool -> Bool
|| GlobalReg
l GlobalReg -> GlobalReg -> Bool
forall a. Eq a => a -> a -> Bool
== GlobalReg
GCEnter1
isGcJump CmmNode O C
_something_else = Bool
False
collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff)
collectContInfo :: [CmmBlock] -> (WordOff, LabelMap WordOff)
collectContInfo [CmmBlock]
blocks
= ([WordOff] -> WordOff
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [WordOff]
ret_offs, [(BlockId, WordOff)] -> LabelMap WordOff
forall v. [(BlockId, v)] -> LabelMap v
mapFromList ([Maybe (BlockId, WordOff)] -> [(BlockId, WordOff)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (BlockId, WordOff)]
mb_argss))
where
([Maybe (BlockId, WordOff)]
mb_argss, [WordOff]
ret_offs) = (CmmBlock -> (Maybe (BlockId, WordOff), WordOff))
-> [CmmBlock] -> ([Maybe (BlockId, WordOff)], [WordOff])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip CmmBlock -> (Maybe (BlockId, WordOff), WordOff)
forall (x :: Extensibility).
Block CmmNode x C -> (Maybe (BlockId, WordOff), WordOff)
get_cont [CmmBlock]
blocks
get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)
get_cont :: forall (x :: Extensibility).
Block CmmNode x C -> (Maybe (BlockId, WordOff), WordOff)
get_cont Block CmmNode x C
b =
case Block CmmNode x C -> CmmNode O C
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n x C -> n O C
lastNode Block CmmNode x C
b of
CmmCall { cml_cont :: CmmNode O C -> Maybe BlockId
cml_cont = Just BlockId
l, WordOff
[GlobalRegUse]
CmmExpr
cml_target :: CmmNode O C -> CmmExpr
cml_target :: CmmExpr
cml_args_regs :: [GlobalRegUse]
cml_args :: WordOff
cml_ret_args :: WordOff
cml_ret_off :: WordOff
cml_ret_off :: CmmNode O C -> WordOff
cml_ret_args :: CmmNode O C -> WordOff
cml_args :: CmmNode O C -> WordOff
cml_args_regs :: CmmNode O C -> [GlobalRegUse]
.. }
-> ((BlockId, WordOff) -> Maybe (BlockId, WordOff)
forall a. a -> Maybe a
Just (BlockId
l, WordOff
cml_ret_args), WordOff
cml_ret_off)
CmmForeignCall { Bool
WordOff
[LocalReg]
[CmmExpr]
BlockId
ForeignTarget
tgt :: ForeignTarget
res :: [LocalReg]
args :: [CmmExpr]
succ :: BlockId
ret_args :: WordOff
ret_off :: WordOff
intrbl :: Bool
intrbl :: CmmNode O C -> Bool
ret_off :: CmmNode O C -> WordOff
ret_args :: CmmNode O C -> WordOff
succ :: CmmNode O C -> BlockId
args :: CmmNode O C -> [CmmExpr]
res :: CmmNode O C -> [LocalReg]
tgt :: CmmNode O C -> ForeignTarget
.. }
-> ((BlockId, WordOff) -> Maybe (BlockId, WordOff)
forall a. a -> Maybe a
Just (BlockId
succ, WordOff
ret_args), WordOff
ret_off)
CmmNode O C
_other -> (Maybe (BlockId, WordOff)
forall a. Maybe a
Nothing, WordOff
0)
procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle :: forall (e :: Extensibility) (x :: Extensibility).
LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle LabelMap StackMap
stackmaps CmmNode e x
node StackMap
sm
= case CmmNode e x
node of
CmmAssign (CmmLocal LocalReg
r) (CmmLoad (CmmStackSlot Area
area WordOff
off) CmmType
_ AlignmentSpec
_)
-> StackMap
sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) }
where loc :: WordOff
loc = Area -> WordOff -> LabelMap StackMap -> WordOff
getStackLoc Area
area WordOff
off LabelMap StackMap
stackmaps
CmmAssign (CmmLocal LocalReg
r) CmmExpr
_other
-> StackMap
sm { sm_regs = delFromUFM (sm_regs sm) r }
CmmNode e x
_other
-> StackMap
sm
getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc
getStackLoc :: Area -> WordOff -> LabelMap StackMap -> WordOff
getStackLoc Area
Old WordOff
n LabelMap StackMap
_ = WordOff
n
getStackLoc (Young BlockId
l) WordOff
n LabelMap StackMap
stackmaps =
case BlockId -> LabelMap StackMap -> Maybe StackMap
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
l LabelMap StackMap
stackmaps of
Maybe StackMap
Nothing -> String -> SDoc -> WordOff
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getStackLoc" (BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
l)
Just StackMap
sm -> StackMap -> WordOff
sm_sp StackMap
sm WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- StackMap -> WordOff
sm_args StackMap
sm WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
n
handleLastNode
:: CmmConfig -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff
-> LabelMap StackMap -> StackMap -> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqDSM
( [CmmNode O O]
, ByteOff
, CmmNode O C
, [CmmBlock]
, LabelMap StackMap
)
handleLastNode :: CmmConfig
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> LabelMap WordOff
-> LabelMap StackMap
-> StackMap
-> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleLastNode CmmConfig
cfg ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness LabelMap WordOff
cont_info LabelMap StackMap
stackmaps
stack0 :: StackMap
stack0@StackMap { sm_sp :: StackMap -> WordOff
sm_sp = WordOff
sp0 } CmmTickScope
tscp Block CmmNode O O
middle CmmNode O C
last
= case CmmNode O C
last of
CmmCall{ cml_cont :: CmmNode O C -> Maybe BlockId
cml_cont = Maybe BlockId
Nothing, WordOff
[GlobalRegUse]
CmmExpr
cml_target :: CmmNode O C -> CmmExpr
cml_ret_off :: CmmNode O C -> WordOff
cml_ret_args :: CmmNode O C -> WordOff
cml_args :: CmmNode O C -> WordOff
cml_args_regs :: CmmNode O C -> [GlobalRegUse]
cml_target :: CmmExpr
cml_args_regs :: [GlobalRegUse]
cml_args :: WordOff
cml_ret_args :: WordOff
cml_ret_off :: WordOff
.. } -> do
let sp_off :: WordOff
sp_off = WordOff
sp0 WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
cml_args
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], WordOff
sp_off, CmmNode O C
last, [], LabelMap StackMap
forall v. LabelMap v
mapEmpty)
CmmCall{ cml_cont :: CmmNode O C -> Maybe BlockId
cml_cont = Just BlockId
cont_lbl, WordOff
[GlobalRegUse]
CmmExpr
cml_target :: CmmNode O C -> CmmExpr
cml_ret_off :: CmmNode O C -> WordOff
cml_ret_args :: CmmNode O C -> WordOff
cml_args :: CmmNode O C -> WordOff
cml_args_regs :: CmmNode O C -> [GlobalRegUse]
cml_target :: CmmExpr
cml_args_regs :: [GlobalRegUse]
cml_args :: WordOff
cml_ret_args :: WordOff
cml_ret_off :: WordOff
.. } ->
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap))
-> ([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
forall a b. (a -> b) -> a -> b
$ BlockId
-> WordOff
-> WordOff
-> WordOff
-> ([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
lastCall BlockId
cont_lbl WordOff
cml_args WordOff
cml_ret_args WordOff
cml_ret_off
CmmForeignCall{ succ :: CmmNode O C -> BlockId
succ = BlockId
cont_lbl, Bool
WordOff
[LocalReg]
[CmmExpr]
ForeignTarget
intrbl :: CmmNode O C -> Bool
ret_off :: CmmNode O C -> WordOff
ret_args :: CmmNode O C -> WordOff
args :: CmmNode O C -> [CmmExpr]
res :: CmmNode O C -> [LocalReg]
tgt :: CmmNode O C -> ForeignTarget
tgt :: ForeignTarget
res :: [LocalReg]
args :: [CmmExpr]
ret_args :: WordOff
ret_off :: WordOff
intrbl :: Bool
.. } ->
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap))
-> ([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
forall a b. (a -> b) -> a -> b
$ BlockId
-> WordOff
-> WordOff
-> WordOff
-> ([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
lastCall BlockId
cont_lbl (Platform -> WordOff
platformWordSizeInBytes Platform
platform) WordOff
ret_args WordOff
ret_off
CmmBranch {} -> UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleBranches
CmmCondBranch {} -> UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleBranches
CmmSwitch {} -> UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleBranches
where
platform :: Platform
platform = CmmConfig -> Platform
cmmPlatform CmmConfig
cfg
lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff
-> ( [CmmNode O O]
, ByteOff
, CmmNode O C
, [CmmBlock]
, LabelMap StackMap
)
lastCall :: BlockId
-> WordOff
-> WordOff
-> WordOff
-> ([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
lastCall BlockId
lbl WordOff
cml_args WordOff
cml_ret_args WordOff
cml_ret_off
= ( [CmmNode O O]
assignments
, WordOff -> StackMap -> WordOff -> WordOff
spOffsetForCall WordOff
sp0 StackMap
cont_stack WordOff
cml_args
, CmmNode O C
last
, []
, BlockId -> StackMap -> LabelMap StackMap
forall v. BlockId -> v -> LabelMap v
mapSingleton BlockId
lbl StackMap
cont_stack )
where
([CmmNode O O]
assignments, StackMap
cont_stack) = BlockId -> WordOff -> WordOff -> ([CmmNode O O], StackMap)
prepareStack BlockId
lbl WordOff
cml_ret_args WordOff
cml_ret_off
prepareStack :: BlockId -> WordOff -> WordOff -> ([CmmNode O O], StackMap)
prepareStack BlockId
lbl WordOff
cml_ret_args WordOff
cml_ret_off
| Just StackMap
cont_stack <- BlockId -> LabelMap StackMap -> Maybe StackMap
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
lbl LabelMap StackMap
stackmaps
= (StackMap -> StackMap -> [CmmNode O O]
fixupStack StackMap
stack0 StackMap
cont_stack, StackMap
cont_stack)
| Bool
otherwise
= ([CmmNode O O]
save_assignments, StackMap
new_cont_stack)
where
(StackMap
new_cont_stack, [CmmNode O O]
save_assignments)
= Platform
-> BlockId
-> BlockEntryLiveness LocalReg
-> WordOff
-> WordOff
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame Platform
platform BlockId
lbl BlockEntryLiveness LocalReg
liveness WordOff
cml_ret_off WordOff
cml_ret_args StackMap
stack0
handleBranches :: UniqDSM ( [CmmNode O O]
, ByteOff
, CmmNode O C
, [CmmBlock]
, LabelMap StackMap )
handleBranches :: UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleBranches
| Just BlockId
l <- Block CmmNode O O -> Maybe BlockId
futureContinuation Block CmmNode O O
middle
, ([BlockId] -> [BlockId]
forall a. Eq a => [a] -> [a]
nub ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ (BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (BlockId -> ProcPointSet -> Bool
`setMember` ProcPointSet
procpoints) ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ CmmNode O C -> [BlockId]
forall (e :: Extensibility). CmmNode e C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last) [BlockId] -> [BlockId] -> Bool
forall a. Eq a => a -> a -> Bool
== [BlockId
l]
= do
let cont_args :: WordOff
cont_args = WordOff -> BlockId -> LabelMap WordOff -> WordOff
forall a. a -> BlockId -> LabelMap a -> a
mapFindWithDefault WordOff
0 BlockId
l LabelMap WordOff
cont_info
([CmmNode O O]
assigs, StackMap
cont_stack) = BlockId -> WordOff -> WordOff -> ([CmmNode O O], StackMap)
prepareStack BlockId
l WordOff
cont_args (StackMap -> WordOff
sm_ret_off StackMap
stack0)
out :: LabelMap StackMap
out = [(BlockId, StackMap)] -> LabelMap StackMap
forall v. [(BlockId, v)] -> LabelMap v
mapFromList [ (BlockId
l', StackMap
cont_stack)
| BlockId
l' <- CmmNode O C -> [BlockId]
forall (e :: Extensibility). CmmNode e C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last ]
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqDSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [CmmNode O O]
assigs
, WordOff -> StackMap -> WordOff -> WordOff
spOffsetForCall WordOff
sp0 StackMap
cont_stack (Platform -> WordOff
platformWordSizeInBytes Platform
platform)
, CmmNode O C
last
, []
, LabelMap StackMap
out)
| Bool
otherwise = do
pps <- (BlockId -> UniqDSM (BlockId, BlockId, StackMap, [CmmBlock]))
-> [BlockId] -> UniqDSM [(BlockId, BlockId, StackMap, [CmmBlock])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM BlockId -> UniqDSM (BlockId, BlockId, StackMap, [CmmBlock])
handleBranch (CmmNode O C -> [BlockId]
forall (e :: Extensibility). CmmNode e C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last)
let lbl_map :: LabelMap Label
lbl_map = [(BlockId, BlockId)] -> LabelMap BlockId
forall v. [(BlockId, v)] -> LabelMap v
mapFromList [ (BlockId
l,BlockId
tmp) | (BlockId
l,BlockId
tmp,StackMap
_,[CmmBlock]
_) <- [(BlockId, BlockId, StackMap, [CmmBlock])]
pps ]
fix_lbl BlockId
l = BlockId -> BlockId -> LabelMap BlockId -> BlockId
forall a. a -> BlockId -> LabelMap a -> a
mapFindWithDefault BlockId
l BlockId
l LabelMap BlockId
lbl_map
return ( []
, 0
, mapSuccessors fix_lbl last
, concat [ blk | (_,_,_,blk) <- pps ]
, mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )
handleBranch :: BlockId -> UniqDSM (BlockId, BlockId, StackMap, [CmmBlock])
handleBranch :: BlockId -> UniqDSM (BlockId, BlockId, StackMap, [CmmBlock])
handleBranch BlockId
l
| Just StackMap
stack2 <- BlockId -> LabelMap StackMap -> Maybe StackMap
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
l LabelMap StackMap
stackmaps
= do
let assigs :: [CmmNode O O]
assigs = StackMap -> StackMap -> [CmmNode O O]
fixupStack StackMap
stack0 StackMap
stack2
(tmp_lbl, block) <- CmmConfig
-> WordOff
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqDSM (BlockId, [CmmBlock])
makeFixupBlock CmmConfig
cfg WordOff
sp0 BlockId
l StackMap
stack2 CmmTickScope
tscp [CmmNode O O]
assigs
return (l, tmp_lbl, stack2, block)
| BlockId
l BlockId -> ProcPointSet -> Bool
`setMember` ProcPointSet
procpoints
= do
let cont_args :: WordOff
cont_args = WordOff -> BlockId -> LabelMap WordOff -> WordOff
forall a. a -> BlockId -> LabelMap a -> a
mapFindWithDefault WordOff
0 BlockId
l LabelMap WordOff
cont_info
(StackMap
stack2, [CmmNode O O]
assigs) =
Platform
-> BlockId
-> BlockEntryLiveness LocalReg
-> WordOff
-> WordOff
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame Platform
platform BlockId
l BlockEntryLiveness LocalReg
liveness (StackMap -> WordOff
sm_ret_off StackMap
stack0)
WordOff
cont_args StackMap
stack0
(tmp_lbl, block) <- CmmConfig
-> WordOff
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqDSM (BlockId, [CmmBlock])
makeFixupBlock CmmConfig
cfg WordOff
sp0 BlockId
l StackMap
stack2 CmmTickScope
tscp [CmmNode O O]
assigs
return (l, tmp_lbl, stack2, block)
| Bool
otherwise = (BlockId, BlockId, StackMap, [CmmBlock])
-> UniqDSM (BlockId, BlockId, StackMap, [CmmBlock])
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
l, StackMap
stack1, [])
where live :: CmmLocalLive
live = CmmLocalLive
-> BlockId -> BlockEntryLiveness LocalReg -> CmmLocalLive
forall a. a -> BlockId -> LabelMap a -> a
mapFindWithDefault (String -> CmmLocalLive
forall a. HasCallStack => String -> a
panic String
"handleBranch") BlockId
l BlockEntryLiveness LocalReg
liveness
stack1 :: StackMap
stack1 = StackMap
stack0 { sm_regs = filterUFM is_live (sm_regs stack0) }
is_live :: (LocalReg, WordOff) -> Bool
is_live (LocalReg
r,WordOff
_) = LocalReg
r LocalReg -> CmmLocalLive -> Bool
forall r. Ord r => r -> RegSet r -> Bool
`elemRegSet` CmmLocalLive
live
makeFixupBlock :: CmmConfig -> ByteOff -> Label -> StackMap
-> CmmTickScope -> [CmmNode O O]
-> UniqDSM (Label, [CmmBlock])
makeFixupBlock :: CmmConfig
-> WordOff
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqDSM (BlockId, [CmmBlock])
makeFixupBlock CmmConfig
cfg WordOff
sp0 BlockId
l StackMap
stack CmmTickScope
tscope [CmmNode O O]
assigs
| [CmmNode O O] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CmmNode O O]
assigs Bool -> Bool -> Bool
&& WordOff
sp0 WordOff -> WordOff -> Bool
forall a. Eq a => a -> a -> Bool
== StackMap -> WordOff
sm_sp StackMap
stack = (BlockId, [CmmBlock]) -> UniqDSM (BlockId, [CmmBlock])
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, [])
| Bool
otherwise = do
tmp_lbl <- UniqDSM BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
let sp_off = WordOff
sp0 WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- StackMap -> WordOff
sm_sp StackMap
stack
block = CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *).
n C O -> Block n O O -> n O C -> Block n C C
blockJoin (BlockId -> CmmTickScope -> CmmNode C O
CmmEntry BlockId
tmp_lbl CmmTickScope
tscope)
( CmmConfig
-> WordOff -> WordOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj CmmConfig
cfg WordOff
sp0 WordOff
sp_off
(Block CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> Block CmmNode O O
forall a b. (a -> b) -> a -> b
$ [CmmNode O O] -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *).
[n O O] -> Block n O O
blockFromList [CmmNode O O]
assigs )
(BlockId -> CmmNode O C
CmmBranch BlockId
l)
return (tmp_lbl, [block])
spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff
spOffsetForCall :: WordOff -> StackMap -> WordOff -> WordOff
spOffsetForCall WordOff
current_sp StackMap
cont_stack WordOff
args
= WordOff
current_sp WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- (StackMap -> WordOff
sm_sp StackMap
cont_stack WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- StackMap -> WordOff
sm_args StackMap
cont_stack WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
args)
fixupStack :: StackMap -> StackMap -> [CmmNode O O]
fixupStack :: StackMap -> StackMap -> [CmmNode O O]
fixupStack StackMap
old_stack StackMap
new_stack = ((LocalReg, WordOff) -> [CmmNode O O])
-> [(LocalReg, WordOff)] -> [CmmNode O O]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LocalReg, WordOff) -> [CmmNode O O]
move [(LocalReg, WordOff)]
new_locs
where
old_map :: UniqFM LocalReg (LocalReg, WordOff)
old_map = StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs StackMap
old_stack
new_locs :: [(LocalReg, WordOff)]
new_locs = StackMap -> [(LocalReg, WordOff)]
stackSlotRegs StackMap
new_stack
move :: (LocalReg, WordOff) -> [CmmNode O O]
move (LocalReg
r,WordOff
n)
| Just (LocalReg
_,WordOff
m) <- UniqFM LocalReg (LocalReg, WordOff)
-> LocalReg -> Maybe (LocalReg, WordOff)
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM LocalReg (LocalReg, WordOff)
old_map LocalReg
r, WordOff
n WordOff -> WordOff -> Bool
forall a. Eq a => a -> a -> Bool
== WordOff
m = []
| Bool
otherwise = [CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode O O
CmmStore (Area -> WordOff -> CmmExpr
CmmStackSlot Area
Old WordOff
n)
(CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
r))
AlignmentSpec
NaturallyAligned]
setupStackFrame
:: Platform
-> BlockId
-> LabelMap CmmLocalLive
-> ByteOff
-> ByteOff
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame :: Platform
-> BlockId
-> BlockEntryLiveness LocalReg
-> WordOff
-> WordOff
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame Platform
platform BlockId
lbl BlockEntryLiveness LocalReg
liveness WordOff
updfr_off WordOff
ret_args StackMap
stack0
= (StackMap
cont_stack, [CmmNode O O]
assignments)
where
live :: CmmLocalLive
live = CmmLocalLive
-> BlockId -> BlockEntryLiveness LocalReg -> CmmLocalLive
forall a. a -> BlockId -> LabelMap a -> a
mapFindWithDefault CmmLocalLive
forall a. Set a
Set.empty BlockId
lbl BlockEntryLiveness LocalReg
liveness
(StackMap
stack1, [CmmNode O O]
assignments) = Platform
-> WordOff -> CmmLocalLive -> StackMap -> (StackMap, [CmmNode O O])
allocate Platform
platform WordOff
updfr_off CmmLocalLive
live StackMap
stack0
cont_stack :: StackMap
cont_stack = StackMap
stack1{ sm_sp = sm_sp stack1 + ret_args
, sm_args = ret_args
, sm_ret_off = updfr_off
}
futureContinuation :: Block CmmNode O O -> Maybe BlockId
futureContinuation :: Block CmmNode O O -> Maybe BlockId
futureContinuation Block CmmNode O O
middle = (forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Maybe BlockId -> Maybe BlockId)
-> forall (e :: Extensibility) (x :: Extensibility).
Block CmmNode e x
-> IndexedCO x (Maybe BlockId) (Maybe BlockId)
-> IndexedCO e (Maybe BlockId) (Maybe BlockId)
forall (n :: Extensibility -> Extensibility -> *) a.
(forall (e :: Extensibility) (x :: Extensibility). n e x -> a -> a)
-> forall (e :: Extensibility) (x :: Extensibility).
Block n e x -> IndexedCO x a a -> IndexedCO e a a
foldBlockNodesB CmmNode e x -> Maybe BlockId -> Maybe BlockId
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Maybe BlockId -> Maybe BlockId
f Block CmmNode O O
middle Maybe BlockId
IndexedCO O (Maybe BlockId) (Maybe BlockId)
forall a. Maybe a
Nothing
where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
f :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Maybe BlockId -> Maybe BlockId
f (CmmStore (CmmStackSlot (Young BlockId
l) WordOff
_) (CmmLit (CmmBlock BlockId
_)) AlignmentSpec
_) Maybe BlockId
_
= BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
l
f CmmNode a b
_ Maybe BlockId
r = Maybe BlockId
r
allocate :: Platform -> ByteOff -> LocalRegSet -> StackMap
-> (StackMap, [CmmNode O O])
allocate :: Platform
-> WordOff -> CmmLocalLive -> StackMap -> (StackMap, [CmmNode O O])
allocate Platform
platform WordOff
ret_off CmmLocalLive
live stackmap :: StackMap
stackmap@StackMap{ sm_sp :: StackMap -> WordOff
sm_sp = WordOff
sp0
, sm_regs :: StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs = UniqFM LocalReg (LocalReg, WordOff)
regs0 }
=
let to_save :: [LocalReg]
to_save = (LocalReg -> Bool) -> [LocalReg] -> [LocalReg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (LocalReg -> Bool) -> LocalReg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalReg -> UniqFM LocalReg (LocalReg, WordOff) -> Bool
forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
`elemUFM` UniqFM LocalReg (LocalReg, WordOff)
regs0)) (CmmLocalLive -> [LocalReg]
forall a. Set a -> [a]
Set.elems CmmLocalLive
live)
regs1 :: UniqFM LocalReg (LocalReg, WordOff)
regs1 = ((LocalReg, WordOff) -> Bool)
-> UniqFM LocalReg (LocalReg, WordOff)
-> UniqFM LocalReg (LocalReg, WordOff)
forall {k} elt (key :: k).
(elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM (\(LocalReg
r,WordOff
_) -> LocalReg -> CmmLocalLive -> Bool
forall r. Ord r => r -> RegSet r -> Bool
elemRegSet LocalReg
r CmmLocalLive
live) UniqFM LocalReg (LocalReg, WordOff)
regs0
in
let stack :: [StackSlot]
stack = [StackSlot] -> [StackSlot]
forall a. [a] -> [a]
reverse ([StackSlot] -> [StackSlot]) -> [StackSlot] -> [StackSlot]
forall a b. (a -> b) -> a -> b
$ Array WordOff StackSlot -> [StackSlot]
forall i e. Array i e -> [e]
Array.elems (Array WordOff StackSlot -> [StackSlot])
-> Array WordOff StackSlot -> [StackSlot]
forall a b. (a -> b) -> a -> b
$
(StackSlot -> StackSlot -> StackSlot)
-> StackSlot
-> (WordOff, WordOff)
-> [(WordOff, StackSlot)]
-> Array WordOff StackSlot
forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray (\StackSlot
_ StackSlot
x -> StackSlot
x) StackSlot
Empty (WordOff
1, Platform -> WordOff -> WordOff
toWords Platform
platform (WordOff -> WordOff -> WordOff
forall a. Ord a => a -> a -> a
max WordOff
sp0 WordOff
ret_off)) ([(WordOff, StackSlot)] -> Array WordOff StackSlot)
-> [(WordOff, StackSlot)] -> Array WordOff StackSlot
forall a b. (a -> b) -> a -> b
$
[(WordOff, StackSlot)]
ret_words [(WordOff, StackSlot)]
-> [(WordOff, StackSlot)] -> [(WordOff, StackSlot)]
forall a. [a] -> [a] -> [a]
++ [(WordOff, StackSlot)]
live_words
where ret_words :: [(WordOff, StackSlot)]
ret_words =
[ (WordOff
x, StackSlot
Occupied)
| WordOff
x <- [ WordOff
1 .. Platform -> WordOff -> WordOff
toWords Platform
platform WordOff
ret_off] ]
live_words :: [(WordOff, StackSlot)]
live_words =
[ (Platform -> WordOff -> WordOff
toWords Platform
platform WordOff
x, StackSlot
Occupied)
| (LocalReg
r,WordOff
off) <- UniqFM LocalReg (LocalReg, WordOff) -> [(LocalReg, WordOff)]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM LocalReg (LocalReg, WordOff)
regs1,
let w :: WordOff
w = Platform -> LocalReg -> WordOff
localRegBytes Platform
platform LocalReg
r,
WordOff
x <- [ WordOff
off, WordOff
off WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- Platform -> WordOff
platformWordSizeInBytes Platform
platform .. WordOff
off WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
w WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
1] ]
in
let
save :: StackSlot
-> ([LocalReg], [StackSlot], WordOff, [CmmNode O O],
[(LocalReg, (LocalReg, WordOff))])
-> ([LocalReg], [StackSlot], WordOff, [CmmNode O O],
[(LocalReg, (LocalReg, WordOff))])
save StackSlot
slot ([], [StackSlot]
stack, WordOff
n, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, WordOff))]
regs)
= ([], StackSlot
slotStackSlot -> [StackSlot] -> [StackSlot]
forall a. a -> [a] -> [a]
:[StackSlot]
stack, Platform -> WordOff -> WordOff -> WordOff
plusW Platform
platform WordOff
n WordOff
1, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, WordOff))]
regs)
save StackSlot
slot ([LocalReg]
to_save, [StackSlot]
stack, WordOff
n, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, WordOff))]
regs)
= case StackSlot
slot of
StackSlot
Occupied -> ([LocalReg]
to_save, StackSlot
OccupiedStackSlot -> [StackSlot] -> [StackSlot]
forall a. a -> [a] -> [a]
:[StackSlot]
stack, Platform -> WordOff -> WordOff -> WordOff
plusW Platform
platform WordOff
n WordOff
1, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, WordOff))]
regs)
StackSlot
Empty
| Just ([StackSlot]
stack', LocalReg
r, [LocalReg]
to_save') <-
[LocalReg]
-> [StackSlot] -> Maybe ([StackSlot], LocalReg, [LocalReg])
select_save [LocalReg]
to_save (StackSlot
slotStackSlot -> [StackSlot] -> [StackSlot]
forall a. a -> [a] -> [a]
:[StackSlot]
stack)
-> let assig :: CmmNode O O
assig = CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode O O
CmmStore (Area -> WordOff -> CmmExpr
CmmStackSlot Area
Old WordOff
n')
(CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
r))
AlignmentSpec
NaturallyAligned
n' :: WordOff
n' = Platform -> WordOff -> WordOff -> WordOff
plusW Platform
platform WordOff
n WordOff
1
in
([LocalReg]
to_save', [StackSlot]
stack', WordOff
n', CmmNode O O
assig CmmNode O O -> [CmmNode O O] -> [CmmNode O O]
forall a. a -> [a] -> [a]
: [CmmNode O O]
assigs, (LocalReg
r,(LocalReg
r,WordOff
n'))(LocalReg, (LocalReg, WordOff))
-> [(LocalReg, (LocalReg, WordOff))]
-> [(LocalReg, (LocalReg, WordOff))]
forall a. a -> [a] -> [a]
:[(LocalReg, (LocalReg, WordOff))]
regs)
| Bool
otherwise
-> ([LocalReg]
to_save, StackSlot
slotStackSlot -> [StackSlot] -> [StackSlot]
forall a. a -> [a] -> [a]
:[StackSlot]
stack, Platform -> WordOff -> WordOff -> WordOff
plusW Platform
platform WordOff
n WordOff
1, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, WordOff))]
regs)
select_save :: [LocalReg] -> [StackSlot]
-> Maybe ([StackSlot], LocalReg, [LocalReg])
select_save :: [LocalReg]
-> [StackSlot] -> Maybe ([StackSlot], LocalReg, [LocalReg])
select_save [LocalReg]
regs [StackSlot]
stack = [LocalReg]
-> [LocalReg] -> Maybe ([StackSlot], LocalReg, [LocalReg])
go [LocalReg]
regs []
where go :: [LocalReg]
-> [LocalReg] -> Maybe ([StackSlot], LocalReg, [LocalReg])
go [] [LocalReg]
_no_fit = Maybe ([StackSlot], LocalReg, [LocalReg])
forall a. Maybe a
Nothing
go (LocalReg
r:[LocalReg]
rs) [LocalReg]
no_fit
| Just [StackSlot]
rest <- WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty WordOff
words [StackSlot]
stack
= ([StackSlot], LocalReg, [LocalReg])
-> Maybe ([StackSlot], LocalReg, [LocalReg])
forall a. a -> Maybe a
Just (WordOff -> StackSlot -> [StackSlot]
forall a. WordOff -> a -> [a]
replicate WordOff
words StackSlot
Occupied [StackSlot] -> [StackSlot] -> [StackSlot]
forall a. [a] -> [a] -> [a]
++ [StackSlot]
rest, LocalReg
r, [LocalReg]
rs[LocalReg] -> [LocalReg] -> [LocalReg]
forall a. [a] -> [a] -> [a]
++[LocalReg]
no_fit)
| Bool
otherwise
= [LocalReg]
-> [LocalReg] -> Maybe ([StackSlot], LocalReg, [LocalReg])
go [LocalReg]
rs (LocalReg
rLocalReg -> [LocalReg] -> [LocalReg]
forall a. a -> [a] -> [a]
:[LocalReg]
no_fit)
where words :: WordOff
words = Platform -> LocalReg -> WordOff
localRegWords Platform
platform LocalReg
r
([LocalReg]
still_to_save, [StackSlot]
save_stack, WordOff
n, [CmmNode O O]
save_assigs, [(LocalReg, (LocalReg, WordOff))]
save_regs)
= (StackSlot
-> ([LocalReg], [StackSlot], WordOff, [CmmNode O O],
[(LocalReg, (LocalReg, WordOff))])
-> ([LocalReg], [StackSlot], WordOff, [CmmNode O O],
[(LocalReg, (LocalReg, WordOff))]))
-> ([LocalReg], [StackSlot], WordOff, [CmmNode O O],
[(LocalReg, (LocalReg, WordOff))])
-> [StackSlot]
-> ([LocalReg], [StackSlot], WordOff, [CmmNode O O],
[(LocalReg, (LocalReg, WordOff))])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr StackSlot
-> ([LocalReg], [StackSlot], WordOff, [CmmNode O O],
[(LocalReg, (LocalReg, WordOff))])
-> ([LocalReg], [StackSlot], WordOff, [CmmNode O O],
[(LocalReg, (LocalReg, WordOff))])
save ([LocalReg]
to_save, [], WordOff
0, [], []) [StackSlot]
stack
(WordOff
push_sp, [CmmNode O O]
push_assigs, [(LocalReg, (LocalReg, WordOff))]
push_regs)
= (LocalReg
-> (WordOff, [CmmNode O O], [(LocalReg, (LocalReg, WordOff))])
-> (WordOff, [CmmNode O O], [(LocalReg, (LocalReg, WordOff))]))
-> (WordOff, [CmmNode O O], [(LocalReg, (LocalReg, WordOff))])
-> [LocalReg]
-> (WordOff, [CmmNode O O], [(LocalReg, (LocalReg, WordOff))])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LocalReg
-> (WordOff, [CmmNode O O], [(LocalReg, (LocalReg, WordOff))])
-> (WordOff, [CmmNode O O], [(LocalReg, (LocalReg, WordOff))])
push (WordOff
n, [], []) [LocalReg]
still_to_save
where
push :: LocalReg
-> (WordOff, [CmmNode O O], [(LocalReg, (LocalReg, WordOff))])
-> (WordOff, [CmmNode O O], [(LocalReg, (LocalReg, WordOff))])
push LocalReg
r (WordOff
n, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, WordOff))]
regs)
= (WordOff
n', CmmNode O O
assig CmmNode O O -> [CmmNode O O] -> [CmmNode O O]
forall a. a -> [a] -> [a]
: [CmmNode O O]
assigs, (LocalReg
r,(LocalReg
r,WordOff
n')) (LocalReg, (LocalReg, WordOff))
-> [(LocalReg, (LocalReg, WordOff))]
-> [(LocalReg, (LocalReg, WordOff))]
forall a. a -> [a] -> [a]
: [(LocalReg, (LocalReg, WordOff))]
regs)
where
n' :: WordOff
n' = WordOff
n WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ Platform -> LocalReg -> WordOff
localRegBytes Platform
platform LocalReg
r
assig :: CmmNode O O
assig = CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode O O
CmmStore (Area -> WordOff -> CmmExpr
CmmStackSlot Area
Old WordOff
n')
(CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
r))
AlignmentSpec
NaturallyAligned
trim_sp :: WordOff
trim_sp
| Bool -> Bool
not ([(LocalReg, (LocalReg, WordOff))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LocalReg, (LocalReg, WordOff))]
push_regs) = WordOff
push_sp
| Bool
otherwise
= Platform -> WordOff -> WordOff -> WordOff
plusW Platform
platform WordOff
n (- [StackSlot] -> WordOff
forall a. [a] -> WordOff
forall (t :: * -> *) a. Foldable t => t a -> WordOff
length ((StackSlot -> Bool) -> [StackSlot] -> [StackSlot]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile StackSlot -> Bool
isEmpty [StackSlot]
save_stack))
final_regs :: UniqFM LocalReg (LocalReg, WordOff)
final_regs = UniqFM LocalReg (LocalReg, WordOff)
regs1 UniqFM LocalReg (LocalReg, WordOff)
-> [(LocalReg, (LocalReg, WordOff))]
-> UniqFM LocalReg (LocalReg, WordOff)
forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
`addListToUFM` [(LocalReg, (LocalReg, WordOff))]
push_regs
UniqFM LocalReg (LocalReg, WordOff)
-> [(LocalReg, (LocalReg, WordOff))]
-> UniqFM LocalReg (LocalReg, WordOff)
forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
`addListToUFM` [(LocalReg, (LocalReg, WordOff))]
save_regs
in
if ( WordOff
n WordOff -> WordOff -> Bool
forall a. Eq a => a -> a -> Bool
/= WordOff -> WordOff -> WordOff
forall a. Ord a => a -> a -> a
max WordOff
sp0 WordOff
ret_off ) then String -> SDoc -> (StackMap, [CmmNode O O])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocate" (WordOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr WordOff
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> WordOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr WordOff
sp0 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> WordOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr WordOff
ret_off) else
if (WordOff
trim_sp WordOff -> WordOff -> WordOff
forall a. Bits a => a -> a -> a
.&. (Platform -> WordOff
platformWordSizeInBytes Platform
platform WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
1)) WordOff -> WordOff -> Bool
forall a. Eq a => a -> a -> Bool
/= WordOff
0 then String -> SDoc -> (StackMap, [CmmNode O O])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocate2" (WordOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr WordOff
trim_sp SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UniqFM LocalReg (LocalReg, WordOff) -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqFM LocalReg (LocalReg, WordOff)
final_regs SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> WordOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr WordOff
push_sp) else
( StackMap
stackmap { sm_regs = final_regs , sm_sp = trim_sp }
, [CmmNode O O]
push_assigs [CmmNode O O] -> [CmmNode O O] -> [CmmNode O O]
forall a. [a] -> [a] -> [a]
++ [CmmNode O O]
save_assigs )
manifestSp
:: CmmConfig
-> LabelMap StackMap
-> StackMap
-> ByteOff
-> ByteOff
-> CmmNode C O
-> [CmmNode O O]
-> ByteOff
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp :: CmmConfig
-> LabelMap StackMap
-> StackMap
-> WordOff
-> WordOff
-> CmmNode C O
-> [CmmNode O O]
-> WordOff
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp CmmConfig
cfg LabelMap StackMap
stackmaps StackMap
stack0 WordOff
sp0 WordOff
sp_high
CmmNode C O
first [CmmNode O O]
middle_pre WordOff
sp_off CmmNode O C
last [CmmBlock]
fixup_blocks
= CmmBlock
final_block CmmBlock -> [CmmBlock] -> [CmmBlock]
forall a. a -> [a] -> [a]
: [CmmBlock]
fixup_blocks'
where
area_off :: Area -> WordOff
area_off = LabelMap StackMap -> Area -> WordOff
getAreaOff LabelMap StackMap
stackmaps
platform :: Platform
platform = CmmConfig -> Platform
cmmPlatform CmmConfig
cfg
adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
adj_pre_sp :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_pre_sp = (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep (Platform
-> WordOff -> WordOff -> (Area -> WordOff) -> CmmExpr -> CmmExpr
areaToSp Platform
platform WordOff
sp0 WordOff
sp_high Area -> WordOff
area_off)
adj_post_sp :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_post_sp = (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep (Platform
-> WordOff -> WordOff -> (Area -> WordOff) -> CmmExpr -> CmmExpr
areaToSp Platform
platform (WordOff
sp0 WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
sp_off) WordOff
sp_high Area -> WordOff
area_off)
final_middle :: Block CmmNode O O
final_middle = CmmConfig
-> WordOff -> WordOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj CmmConfig
cfg WordOff
sp0 WordOff
sp_off
(Block CmmNode O O -> Block CmmNode O O)
-> ([CmmNode O O] -> Block CmmNode O O)
-> [CmmNode O O]
-> Block CmmNode O O
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CmmNode O O] -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *).
[n O O] -> Block n O O
blockFromList
([CmmNode O O] -> Block CmmNode O O)
-> ([CmmNode O O] -> [CmmNode O O])
-> [CmmNode O O]
-> Block CmmNode O O
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CmmNode O O -> CmmNode O O) -> [CmmNode O O] -> [CmmNode O O]
forall a b. (a -> b) -> [a] -> [b]
map CmmNode O O -> CmmNode O O
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_pre_sp
([CmmNode O O] -> [CmmNode O O])
-> ([CmmNode O O] -> [CmmNode O O])
-> [CmmNode O O]
-> [CmmNode O O]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackMap
-> LabelMap StackMap
-> (Area -> WordOff)
-> [CmmNode O O]
-> [CmmNode O O]
elimStackStores StackMap
stack0 LabelMap StackMap
stackmaps Area -> WordOff
area_off
([CmmNode O O] -> Block CmmNode O O)
-> [CmmNode O O] -> Block CmmNode O O
forall a b. (a -> b) -> a -> b
$ [CmmNode O O]
middle_pre
final_last :: CmmNode O C
final_last = CmmNode O C -> CmmNode O C
optStackCheck (CmmNode O C -> CmmNode O C
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_post_sp CmmNode O C
last)
final_block :: CmmBlock
final_block = CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *).
n C O -> Block n O O -> n O C -> Block n C C
blockJoin CmmNode C O
first Block CmmNode O O
final_middle CmmNode O C
final_last
fixup_blocks' :: [CmmBlock]
fixup_blocks' = (CmmBlock -> CmmBlock) -> [CmmBlock] -> [CmmBlock]
forall a b. (a -> b) -> [a] -> [b]
map ((CmmNode C O -> CmmNode C O, CmmNode O O -> CmmNode O O,
CmmNode O C -> CmmNode O C)
-> CmmBlock -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *)
(n' :: Extensibility -> Extensibility -> *) (e :: Extensibility)
(x :: Extensibility).
(n C O -> n' C O, n O O -> n' O O, n O C -> n' O C)
-> Block n e x -> Block n' e x
mapBlock3' (CmmNode C O -> CmmNode C O
forall a. a -> a
id, CmmNode O O -> CmmNode O O
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_post_sp, CmmNode O C -> CmmNode O C
forall a. a -> a
id)) [CmmBlock]
fixup_blocks
getAreaOff :: LabelMap StackMap -> (Area -> StackLoc)
getAreaOff :: LabelMap StackMap -> Area -> WordOff
getAreaOff LabelMap StackMap
_ Area
Old = WordOff
0
getAreaOff LabelMap StackMap
stackmaps (Young BlockId
l) =
case BlockId -> LabelMap StackMap -> Maybe StackMap
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
l LabelMap StackMap
stackmaps of
Just StackMap
sm -> StackMap -> WordOff
sm_sp StackMap
sm WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- StackMap -> WordOff
sm_args StackMap
sm
Maybe StackMap
Nothing -> String -> SDoc -> WordOff
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getAreaOff" (BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
l)
maybeAddSpAdj
:: CmmConfig -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj :: CmmConfig
-> WordOff -> WordOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj CmmConfig
cfg WordOff
sp0 WordOff
sp_off Block CmmNode O O
block =
Block CmmNode O O -> Block CmmNode O O
add_initial_unwind (Block CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> Block CmmNode O O
forall a b. (a -> b) -> a -> b
$ Block CmmNode O O -> Block CmmNode O O
add_adj_unwind (Block CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> Block CmmNode O O
forall a b. (a -> b) -> a -> b
$ Block CmmNode O O -> Block CmmNode O O
adj Block CmmNode O O
block
where
platform :: Platform
platform = CmmConfig -> Platform
cmmPlatform CmmConfig
cfg
do_stk_unwinding_gen :: Bool
do_stk_unwinding_gen = CmmConfig -> Bool
cmmGenStackUnwindInstr CmmConfig
cfg
adj :: Block CmmNode O O -> Block CmmNode O O
adj Block CmmNode O O
block
| WordOff
sp_off WordOff -> WordOff -> Bool
forall a. Eq a => a -> a -> Bool
/= WordOff
0
= Block CmmNode O O
block Block CmmNode O O -> CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e O -> n O O -> Block n e O
`blockSnoc` CmmReg -> CmmExpr -> CmmNode O O
CmmAssign (Platform -> CmmReg
spReg Platform
platform) (Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffset Platform
platform (Platform -> CmmExpr
spExpr Platform
platform) WordOff
sp_off)
| Bool
otherwise = Block CmmNode O O
block
add_initial_unwind :: Block CmmNode O O -> Block CmmNode O O
add_initial_unwind Block CmmNode O O
block
| Bool
do_stk_unwinding_gen
= [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
CmmUnwind [(GlobalReg
Sp, CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just CmmExpr
sp_unwind)] CmmNode O O -> Block CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
n O O -> Block n O x -> Block n O x
`blockCons` Block CmmNode O O
block
| Bool
otherwise
= Block CmmNode O O
block
where sp_unwind :: CmmExpr
sp_unwind = CmmReg -> WordOff -> CmmExpr
CmmRegOff (Platform -> CmmReg
spReg Platform
platform) (WordOff
sp0 WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- Platform -> WordOff
platformWordSizeInBytes Platform
platform)
add_adj_unwind :: Block CmmNode O O -> Block CmmNode O O
add_adj_unwind Block CmmNode O O
block
| Bool
do_stk_unwinding_gen
, WordOff
sp_off WordOff -> WordOff -> Bool
forall a. Eq a => a -> a -> Bool
/= WordOff
0
= Block CmmNode O O
block Block CmmNode O O -> CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e O -> n O O -> Block n e O
`blockSnoc` [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
CmmUnwind [(GlobalReg
Sp, CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just CmmExpr
sp_unwind)]
| Bool
otherwise
= Block CmmNode O O
block
where sp_unwind :: CmmExpr
sp_unwind = CmmReg -> WordOff -> CmmExpr
CmmRegOff (Platform -> CmmReg
spReg Platform
platform) (WordOff
sp0 WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- Platform -> WordOff
platformWordSizeInBytes Platform
platform WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
sp_off)
areaToSp :: Platform -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
areaToSp :: Platform
-> WordOff -> WordOff -> (Area -> WordOff) -> CmmExpr -> CmmExpr
areaToSp Platform
platform WordOff
sp_old WordOff
_sp_hwm Area -> WordOff
area_off (CmmStackSlot Area
area WordOff
n)
= Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffset Platform
platform (Platform -> CmmExpr
spExpr Platform
platform) (WordOff
sp_old WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- Area -> WordOff
area_off Area
area WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
n)
areaToSp Platform
platform WordOff
_ WordOff
sp_hwm Area -> WordOff
_ (CmmLit CmmLit
CmmHighStackMark)
= Platform -> WordOff -> CmmExpr
mkIntExpr Platform
platform WordOff
sp_hwm
areaToSp Platform
platform WordOff
_ WordOff
_ Area -> WordOff
_ (CmmMachOp (MO_U_Lt Width
_) [CmmExpr]
args)
| [CmmExpr] -> Bool
falseStackCheck [CmmExpr]
args
= Platform -> CmmExpr
zeroExpr Platform
platform
areaToSp Platform
platform WordOff
_ WordOff
_ Area -> WordOff
_ (CmmMachOp (MO_U_Ge Width
_) [CmmExpr]
args)
| [CmmExpr] -> Bool
falseStackCheck [CmmExpr]
args
= Platform -> WordOff -> CmmExpr
mkIntExpr Platform
platform WordOff
1
areaToSp Platform
_ WordOff
_ WordOff
_ Area -> WordOff
_ CmmExpr
other = CmmExpr
other
falseStackCheck :: [CmmExpr] -> Bool
falseStackCheck :: [CmmExpr] -> Bool
falseStackCheck [ CmmMachOp (MO_Sub Width
_)
[ CmmRegOff (CmmGlobal (GlobalRegUse GlobalReg
Sp CmmType
_)) WordOff
x_off
, CmmLit (CmmInt Integer
y_lit Width
_)]
, CmmReg (CmmGlobal (GlobalRegUse GlobalReg
SpLim CmmType
_))]
= WordOff -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
x_off Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
y_lit
falseStackCheck [CmmExpr]
_ = Bool
False
optStackCheck :: CmmNode O C -> CmmNode O C
optStackCheck :: CmmNode O C -> CmmNode O C
optStackCheck CmmNode O C
n =
case CmmNode O C
n of
CmmCondBranch (CmmLit (CmmInt Integer
0 Width
_)) BlockId
_true BlockId
false Maybe Bool
_ -> BlockId -> CmmNode O C
CmmBranch BlockId
false
CmmCondBranch (CmmLit (CmmInt Integer
_ Width
_)) BlockId
true BlockId
_false Maybe Bool
_ -> BlockId -> CmmNode O C
CmmBranch BlockId
true
CmmNode O C
other -> CmmNode O C
other
elimStackStores :: StackMap
-> LabelMap StackMap
-> (Area -> ByteOff)
-> [CmmNode O O]
-> [CmmNode O O]
elimStackStores :: StackMap
-> LabelMap StackMap
-> (Area -> WordOff)
-> [CmmNode O O]
-> [CmmNode O O]
elimStackStores StackMap
stackmap LabelMap StackMap
stackmaps Area -> WordOff
area_off [CmmNode O O]
nodes
= StackMap -> [CmmNode O O] -> [CmmNode O O]
go StackMap
stackmap [CmmNode O O]
nodes
where
go :: StackMap -> [CmmNode O O] -> [CmmNode O O]
go StackMap
_stackmap [] = []
go StackMap
stackmap (CmmNode O O
n:[CmmNode O O]
ns)
= case CmmNode O O
n of
CmmStore (CmmStackSlot Area
area WordOff
m) (CmmReg (CmmLocal LocalReg
r)) AlignmentSpec
_
| Just (LocalReg
_,WordOff
off) <- UniqFM LocalReg (LocalReg, WordOff)
-> LocalReg -> Maybe (LocalReg, WordOff)
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs StackMap
stackmap) LocalReg
r
, Area -> WordOff
area_off Area
area WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
m WordOff -> WordOff -> Bool
forall a. Eq a => a -> a -> Bool
== WordOff
off
-> StackMap -> [CmmNode O O] -> [CmmNode O O]
go StackMap
stackmap [CmmNode O O]
ns
CmmNode O O
_otherwise
-> CmmNode O O
n CmmNode O O -> [CmmNode O O] -> [CmmNode O O]
forall a. a -> [a] -> [a]
: StackMap -> [CmmNode O O] -> [CmmNode O O]
go (LabelMap StackMap -> CmmNode O O -> StackMap -> StackMap
forall (e :: Extensibility) (x :: Extensibility).
LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle LabelMap StackMap
stackmaps CmmNode O O
n StackMap
stackmap) [CmmNode O O]
ns
setInfoTableStackMap :: Platform -> LabelMap StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap :: Platform -> LabelMap StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap Platform
platform LabelMap StackMap
stackmaps (CmmProc top_info :: CmmTopInfo
top_info@TopInfo{LabelMap CmmInfoTable
CmmStackInfo
info_tbls :: LabelMap CmmInfoTable
stack_info :: CmmStackInfo
stack_info :: forall (f :: * -> *). GenCmmTopInfo f -> CmmStackInfo
info_tbls :: forall (f :: * -> *). GenCmmTopInfo f -> f CmmInfoTable
..} CLabel
l [GlobalRegUse]
v CmmGraph
g)
= CmmTopInfo -> CLabel -> [GlobalRegUse] -> CmmGraph -> CmmDecl
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
top_info{ info_tbls = mapMapWithKey fix_info info_tbls } CLabel
l [GlobalRegUse]
v CmmGraph
g
where
fix_info :: BlockId -> CmmInfoTable -> CmmInfoTable
fix_info BlockId
lbl info_tbl :: CmmInfoTable
info_tbl@CmmInfoTable{ cit_rep :: CmmInfoTable -> SMRep
cit_rep = StackRep Liveness
_ } =
CmmInfoTable
info_tbl { cit_rep = StackRep (get_liveness lbl) }
fix_info BlockId
_ CmmInfoTable
other = CmmInfoTable
other
get_liveness :: BlockId -> Liveness
get_liveness :: BlockId -> Liveness
get_liveness BlockId
lbl
= case BlockId -> LabelMap StackMap -> Maybe StackMap
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
lbl LabelMap StackMap
stackmaps of
Maybe StackMap
Nothing -> String -> SDoc -> Liveness
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"setInfoTableStackMap" (BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
lbl SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> LabelMap CmmInfoTable -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform LabelMap CmmInfoTable
info_tbls)
Just StackMap
sm -> Platform -> StackMap -> Liveness
stackMapToLiveness Platform
platform StackMap
sm
setInfoTableStackMap Platform
_ LabelMap StackMap
_ CmmDecl
d = CmmDecl
d
stackMapToLiveness :: Platform -> StackMap -> Liveness
stackMapToLiveness :: Platform -> StackMap -> Liveness
stackMapToLiveness Platform
platform StackMap{WordOff
UniqFM LocalReg (LocalReg, WordOff)
sm_sp :: StackMap -> WordOff
sm_args :: StackMap -> WordOff
sm_ret_off :: StackMap -> WordOff
sm_regs :: StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_sp :: WordOff
sm_args :: WordOff
sm_ret_off :: WordOff
sm_regs :: UniqFM LocalReg (LocalReg, WordOff)
..} =
Liveness -> Liveness
forall a. [a] -> [a]
reverse (Liveness -> Liveness) -> Liveness -> Liveness
forall a b. (a -> b) -> a -> b
$ Array WordOff Bool -> Liveness
forall i e. Array i e -> [e]
Array.elems (Array WordOff Bool -> Liveness) -> Array WordOff Bool -> Liveness
forall a b. (a -> b) -> a -> b
$
(Bool -> Bool -> Bool)
-> Bool
-> (WordOff, WordOff)
-> [(WordOff, Bool)]
-> Array WordOff Bool
forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray (\Bool
_ Bool
x -> Bool
x) Bool
True (Platform -> WordOff -> WordOff
toWords Platform
platform WordOff
sm_ret_off WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
1,
Platform -> WordOff -> WordOff
toWords Platform
platform (WordOff
sm_sp WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
sm_args)) [(WordOff, Bool)]
live_words
where
live_words :: [(WordOff, Bool)]
live_words = [ (Platform -> WordOff -> WordOff
toWords Platform
platform WordOff
off, Bool
False)
| (LocalReg
r,WordOff
off) <- UniqFM LocalReg (LocalReg, WordOff) -> [(LocalReg, WordOff)]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM LocalReg (LocalReg, WordOff)
sm_regs
, CmmType -> Bool
isGcPtrType (LocalReg -> CmmType
localRegType LocalReg
r) ]
insertReloadsAsNeeded
:: Platform
-> ProcPointSet
-> LabelMap StackMap
-> BlockId
-> [CmmBlock]
-> UniqDSM [CmmBlock]
insertReloadsAsNeeded :: Platform
-> ProcPointSet
-> LabelMap StackMap
-> BlockId
-> [CmmBlock]
-> UniqDSM [CmmBlock]
insertReloadsAsNeeded Platform
platform ProcPointSet
procpoints LabelMap StackMap
final_stackmaps BlockId
entry [CmmBlock]
blocks =
CmmGraph -> [CmmBlock]
toBlockList (CmmGraph -> [CmmBlock])
-> ((CmmGraph, BlockEntryLiveness LocalReg) -> CmmGraph)
-> (CmmGraph, BlockEntryLiveness LocalReg)
-> [CmmBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CmmGraph, BlockEntryLiveness LocalReg) -> CmmGraph
forall a b. (a, b) -> a
fst ((CmmGraph, BlockEntryLiveness LocalReg) -> [CmmBlock])
-> UniqDSM (CmmGraph, BlockEntryLiveness LocalReg)
-> UniqDSM [CmmBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
DataflowLattice CmmLocalLive
-> RewriteFun' CmmNode CmmLocalLive
-> CmmGraph
-> BlockEntryLiveness LocalReg
-> UniqDSM (CmmGraph, BlockEntryLiveness LocalReg)
forall (node :: Extensibility -> Extensibility -> *) f.
NonLocal node =>
DataflowLattice f
-> RewriteFun' node f
-> GenCmmGraph node
-> FactBase f
-> UniqDSM (GenCmmGraph node, FactBase f)
rewriteCmmBwd DataflowLattice CmmLocalLive
forall r. Ord r => DataflowLattice (CmmLive r)
liveLattice RewriteFun' CmmNode CmmLocalLive
rewriteCC (BlockId -> [CmmBlock] -> CmmGraph
ofBlockList BlockId
entry [CmmBlock]
blocks) BlockEntryLiveness LocalReg
forall v. LabelMap v
mapEmpty
where
rewriteCC :: RewriteFun CmmLocalLive
rewriteCC :: RewriteFun' CmmNode CmmLocalLive
rewriteCC (BlockCC CmmNode C O
e_node Block CmmNode O O
middle0 CmmNode O C
x_node) BlockEntryLiveness LocalReg
fact_base0 = do
let entry_label :: BlockId
entry_label = CmmNode C O -> BlockId
forall (x :: Extensibility). CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmNode C O
e_node
stackmap :: StackMap
stackmap = case BlockId -> LabelMap StackMap -> Maybe StackMap
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
entry_label LabelMap StackMap
final_stackmaps of
Just StackMap
sm -> StackMap
sm
Maybe StackMap
Nothing -> String -> StackMap
forall a. HasCallStack => String -> a
panic String
"insertReloadsAsNeeded: rewriteCC: stackmap"
joined :: CmmLocalLive
joined = Platform -> CmmNode O C -> CmmLocalLive -> CmmLocalLive
forall r n.
(DefinerOfRegs r n, UserOfRegs r n) =>
Platform -> n -> CmmLive r -> CmmLive r
gen_kill Platform
platform CmmNode O C
x_node (CmmLocalLive -> CmmLocalLive) -> CmmLocalLive -> CmmLocalLive
forall a b. (a -> b) -> a -> b
$!
DataflowLattice CmmLocalLive
-> CmmNode O C -> BlockEntryLiveness LocalReg -> CmmLocalLive
forall (n :: Extensibility -> Extensibility -> *) f
(e :: Extensibility).
NonLocal n =>
DataflowLattice f -> n e C -> FactBase f -> f
joinOutFacts DataflowLattice CmmLocalLive
forall r. Ord r => DataflowLattice (CmmLive r)
liveLattice CmmNode O C
x_node BlockEntryLiveness LocalReg
fact_base0
live_at_middle0 :: CmmLocalLive
live_at_middle0 = (CmmNode O O -> CmmLocalLive -> CmmLocalLive)
-> Block CmmNode O O -> CmmLocalLive -> CmmLocalLive
forall (node :: Extensibility -> Extensibility -> *) f.
(node O O -> f -> f) -> Block node O O -> f -> f
foldNodesBwdOO (Platform -> CmmNode O O -> CmmLocalLive -> CmmLocalLive
forall r n.
(DefinerOfRegs r n, UserOfRegs r n) =>
Platform -> n -> CmmLive r -> CmmLive r
gen_kill Platform
platform) Block CmmNode O O
middle0 CmmLocalLive
joined
(Block CmmNode O O
middle1, CmmLocalLive
live_with_reloads)
| BlockId
entry_label BlockId -> ProcPointSet -> Bool
`setMember` ProcPointSet
procpoints
= let reloads :: [CmmNode O O]
reloads = Platform -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads Platform
platform StackMap
stackmap CmmLocalLive
live_at_middle0
in ((CmmNode O O -> Block CmmNode O O -> Block CmmNode O O)
-> Block CmmNode O O -> [CmmNode O O] -> Block CmmNode O O
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmNode O O -> Block CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
n O O -> Block n O x -> Block n O x
blockCons Block CmmNode O O
middle0 [CmmNode O O]
reloads, CmmLocalLive
forall a. Set a
emptyRegSet)
| Bool
otherwise
= (Block CmmNode O O
middle0, CmmLocalLive
live_at_middle0)
!fact_base2 :: BlockEntryLiveness LocalReg
fact_base2 = BlockId -> CmmLocalLive -> BlockEntryLiveness LocalReg
forall v. BlockId -> v -> LabelMap v
mapSingleton BlockId
entry_label CmmLocalLive
live_with_reloads
(CmmBlock, BlockEntryLiveness LocalReg)
-> UniqDSM (CmmBlock, BlockEntryLiveness LocalReg)
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *).
n C O -> Block n O O -> n O C -> Block n C C
BlockCC CmmNode C O
e_node Block CmmNode O O
middle1 CmmNode O C
x_node, BlockEntryLiveness LocalReg
fact_base2)
insertReloads :: Platform -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads :: Platform -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads Platform
platform StackMap
stackmap CmmLocalLive
live =
[ CmmReg -> CmmExpr -> CmmNode O O
CmmAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg)
(CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffset Platform
platform (Platform -> CmmExpr
spExpr Platform
platform) (WordOff
sp_off WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
- WordOff
reg_off))
(LocalReg -> CmmType
localRegType LocalReg
reg)
AlignmentSpec
NaturallyAligned)
| (LocalReg
reg, WordOff
reg_off) <- StackMap -> [(LocalReg, WordOff)]
stackSlotRegs StackMap
stackmap
, LocalReg
reg LocalReg -> CmmLocalLive -> Bool
forall r. Ord r => r -> RegSet r -> Bool
`elemRegSet` CmmLocalLive
live
]
where
sp_off :: WordOff
sp_off = StackMap -> WordOff
sm_sp StackMap
stackmap
lowerSafeForeignCall :: Profile -> CmmBlock -> UniqDSM CmmBlock
lowerSafeForeignCall :: Profile -> CmmBlock -> UniqDSM CmmBlock
lowerSafeForeignCall Profile
profile CmmBlock
block
| (entry :: CmmNode C O
entry@(CmmEntry BlockId
_ CmmTickScope
tscp), Block CmmNode O O
middle, CmmForeignCall { Bool
WordOff
[LocalReg]
[CmmExpr]
BlockId
ForeignTarget
intrbl :: CmmNode O C -> Bool
ret_off :: CmmNode O C -> WordOff
ret_args :: CmmNode O C -> WordOff
succ :: CmmNode O C -> BlockId
args :: CmmNode O C -> [CmmExpr]
res :: CmmNode O C -> [LocalReg]
tgt :: CmmNode O C -> ForeignTarget
tgt :: ForeignTarget
res :: [LocalReg]
args :: [CmmExpr]
succ :: BlockId
ret_args :: WordOff
ret_off :: WordOff
intrbl :: Bool
.. }) <- CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
= do
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
id <- CmmType -> UniqDSM LocalReg
forall (m :: * -> *). MonadGetUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
bWord Platform
platform)
new_base <- newTemp (cmmRegType $ baseReg platform)
let (caller_save, caller_load) = callerSaveVolatileRegs platform
save_state_code <- saveThreadState profile
load_state_code <- loadThreadState profile
let suspend = CmmAGraph
save_state_code CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmAGraph
caller_save CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmNode O O -> CmmAGraph
mkMiddle (Platform -> LocalReg -> Bool -> CmmNode O O
callSuspendThread Platform
platform LocalReg
id Bool
intrbl)
midCall = ForeignTarget -> [LocalReg] -> [CmmExpr] -> CmmAGraph
mkUnsafeCall ForeignTarget
tgt [LocalReg]
res [CmmExpr]
args
resume = CmmNode O O -> CmmAGraph
mkMiddle (LocalReg -> LocalReg -> CmmNode O O
callResumeThread LocalReg
new_base LocalReg
id) CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmReg -> CmmExpr -> CmmAGraph
mkAssign (Platform -> CmmReg
baseReg Platform
platform) (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
new_base)) CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmAGraph
caller_load CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmAGraph
load_state_code
(_, regs, copyout) =
copyOutOflow profile NativeReturn Jump (Young succ)
(map (CmmReg . CmmLocal) res)
ret_off []
jump = CmmCall { cml_target :: CmmExpr
cml_target = Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
forall a b. (a -> b) -> a -> b
$
Platform -> CmmExpr -> CmmExpr
cmmLoadBWord Platform
platform (Platform -> CmmExpr
spExpr Platform
platform)
, cml_cont :: Maybe BlockId
cml_cont = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
succ
, cml_args_regs :: [GlobalRegUse]
cml_args_regs = [GlobalRegUse]
regs
, cml_args :: WordOff
cml_args = Width -> WordOff
widthInBytes (Platform -> Width
wordWidth Platform
platform)
, cml_ret_args :: WordOff
cml_ret_args = WordOff
ret_args
, cml_ret_off :: WordOff
cml_ret_off = WordOff
ret_off }
graph' <- lgraphOfAGraph ( suspend <*>
midCall <*>
resume <*>
copyout <*>
mkLast jump, tscp)
case toBlockList (removeDetermGraph graph') of
[CmmBlock
one] -> let (CmmNode C O
_, Block CmmNode O O
middle', CmmNode O C
last) = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
one
in CmmBlock -> UniqDSM CmmBlock
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmNode C O -> Block CmmNode O O -> CmmNode O C -> CmmBlock
forall (n :: Extensibility -> Extensibility -> *).
n C O -> Block n O O -> n O C -> Block n C C
blockJoin CmmNode C O
entry (Block CmmNode O O
middle Block CmmNode O O -> Block CmmNode O O -> Block CmmNode O O
forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility) (x :: Extensibility).
Block n e O -> Block n O x -> Block n e x
`blockAppend` Block CmmNode O O
middle') CmmNode O C
last)
[CmmBlock]
_ -> String -> UniqDSM CmmBlock
forall a. HasCallStack => String -> a
panic String
"lowerSafeForeignCall0"
| Bool
otherwise = CmmBlock -> UniqDSM CmmBlock
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return CmmBlock
block
callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O
callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O
callSuspendThread Platform
platform LocalReg
id Bool
intrbl =
ForeignTarget -> [LocalReg] -> [CmmExpr] -> CmmNode O O
CmmUnsafeForeignCall (CallishMachOp -> ForeignTarget
PrimTarget CallishMachOp
MO_SuspendThread)
[LocalReg
id] [Platform -> CmmExpr
baseExpr Platform
platform, Platform -> WordOff -> CmmExpr
mkIntExpr Platform
platform (Bool -> WordOff
forall a. Enum a => a -> WordOff
fromEnum Bool
intrbl)]
callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread LocalReg
new_base LocalReg
id =
ForeignTarget -> [LocalReg] -> [CmmExpr] -> CmmNode O O
CmmUnsafeForeignCall (CallishMachOp -> ForeignTarget
PrimTarget CallishMachOp
MO_ResumeThread)
[LocalReg
new_base] [CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
id)]
plusW :: Platform -> ByteOff -> WordOff -> ByteOff
plusW :: Platform -> WordOff -> WordOff -> WordOff
plusW Platform
platform WordOff
b WordOff
w = WordOff
b WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ WordOff
w WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
* Platform -> WordOff
platformWordSizeInBytes Platform
platform
data StackSlot = Occupied | Empty
instance Outputable StackSlot where
ppr :: StackSlot -> SDoc
ppr StackSlot
Occupied = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"XXX"
ppr StackSlot
Empty = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"---"
dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty WordOff
0 [StackSlot]
ss = [StackSlot] -> Maybe [StackSlot]
forall a. a -> Maybe a
Just [StackSlot]
ss
dropEmpty WordOff
n (StackSlot
Empty : [StackSlot]
ss) = WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty (WordOff
nWordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
-WordOff
1) [StackSlot]
ss
dropEmpty WordOff
_ [StackSlot]
_ = Maybe [StackSlot]
forall a. Maybe a
Nothing
isEmpty :: StackSlot -> Bool
isEmpty :: StackSlot -> Bool
isEmpty StackSlot
Empty = Bool
True
isEmpty StackSlot
_ = Bool
False
localRegBytes :: Platform -> LocalReg -> ByteOff
localRegBytes :: Platform -> LocalReg -> WordOff
localRegBytes Platform
platform LocalReg
r
= Platform -> WordOff -> WordOff
roundUpToWords Platform
platform (Width -> WordOff
widthInBytes (CmmType -> Width
typeWidth (LocalReg -> CmmType
localRegType LocalReg
r)))
localRegWords :: Platform -> LocalReg -> WordOff
localRegWords :: Platform -> LocalReg -> WordOff
localRegWords Platform
platform = Platform -> WordOff -> WordOff
toWords Platform
platform (WordOff -> WordOff)
-> (LocalReg -> WordOff) -> LocalReg -> WordOff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> LocalReg -> WordOff
localRegBytes Platform
platform
toWords :: Platform -> ByteOff -> WordOff
toWords :: Platform -> WordOff -> WordOff
toWords Platform
platform WordOff
x = WordOff
x WordOff -> WordOff -> WordOff
forall a. Integral a => a -> a -> a
`quot` Platform -> WordOff
platformWordSizeInBytes Platform
platform
stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
stackSlotRegs :: StackMap -> [(LocalReg, WordOff)]
stackSlotRegs StackMap
sm = UniqFM LocalReg (LocalReg, WordOff) -> [(LocalReg, WordOff)]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM (StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs StackMap
sm)