{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}
module GHC.Cmm.LayoutStack (
cmmLayoutStack, setInfoTableStackMap
) where
import GHC.Prelude hiding ((<*>))
import GHC.Platform
import GHC.Platform.Profile
import GHC.StgToCmm.Utils ( callerSaveVolatileRegs, newTemp )
import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState )
import GHC.Types.Basic
import GHC.Cmm
import GHC.Cmm.Info
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.Utils
import GHC.Cmm.Graph
import GHC.Types.ForeignCall
import GHC.Cmm.Liveness
import GHC.Cmm.ProcPoint
import GHC.Runtime.Heap.Layout
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Types.Unique.Supply
import GHC.Data.Maybe
import GHC.Types.Unique.FM
import GHC.Utils.Misc
import GHC.Driver.Session
import GHC.Data.FastString
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_regs :: UniqFM LocalReg (LocalReg, WordOff)
sm_ret_off :: WordOff
sm_args :: WordOff
sm_sp :: WordOff
sm_regs :: StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_ret_off :: StackMap -> WordOff
sm_args :: StackMap -> WordOff
sm_sp :: StackMap -> WordOff
..} =
String -> SDoc
text String
"Sp = " SDoc -> SDoc -> SDoc
<> WordOff -> SDoc
int WordOff
sm_sp SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"sm_args = " SDoc -> SDoc -> SDoc
<> WordOff -> SDoc
int WordOff
sm_args SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"sm_ret_off = " SDoc -> SDoc -> SDoc
<> WordOff -> SDoc
int WordOff
sm_ret_off SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"sm_regs = " SDoc -> SDoc -> SDoc
<> forall key a. UniqFM key a -> ([a] -> SDoc) -> SDoc
pprUFM UniqFM LocalReg (LocalReg, WordOff)
sm_regs forall a. Outputable a => a -> SDoc
ppr
cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
-> UniqSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack :: DynFlags
-> ProcPointSet
-> WordOff
-> CmmGraph
-> UniqSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack DynFlags
dflags ProcPointSet
procpoints WordOff
entry_args
graph :: CmmGraph
graph@(CmmGraph { g_entry :: forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph 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 = DynFlags -> Profile
targetProfile DynFlags
dflags
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
(LabelMap StackMap
final_stackmaps, WordOff
_final_high_sp, [CmmBlock]
new_blocks) <-
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix forall a b. (a -> b) -> a -> b
$ \ ~(LabelMap StackMap
rec_stackmaps, WordOff
rec_high_sp, [CmmBlock]
_new_blocks) ->
DynFlags
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> BlockId
-> WordOff
-> LabelMap StackMap
-> WordOff
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, WordOff, [CmmBlock])
layout DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness BlockId
entry WordOff
entry_args
LabelMap StackMap
rec_stackmaps WordOff
rec_high_sp [CmmBlock]
blocks
[CmmBlock]
blocks_with_reloads <-
Platform
-> ProcPointSet
-> LabelMap StackMap
-> BlockId
-> [CmmBlock]
-> UniqSM [CmmBlock]
insertReloadsAsNeeded Platform
platform ProcPointSet
procpoints LabelMap StackMap
final_stackmaps BlockId
entry [CmmBlock]
new_blocks
[CmmBlock]
new_blocks' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Profile -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall Profile
profile) [CmmBlock]
blocks_with_reloads
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> [CmmBlock] -> CmmGraph
ofBlockList BlockId
entry [CmmBlock]
new_blocks', LabelMap StackMap
final_stackmaps)
layout :: DynFlags
-> LabelSet
-> LabelMap CmmLocalLive
-> BlockId
-> ByteOff
-> LabelMap StackMap
-> ByteOff
-> [CmmBlock]
-> UniqSM
( LabelMap StackMap
, ByteOff
, [CmmBlock]
)
layout :: DynFlags
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> BlockId
-> WordOff
-> LabelMap StackMap
-> WordOff
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, WordOff, [CmmBlock])
layout DynFlags
dflags 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]
-> UniqSM (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 = forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
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 = forall key elt. UniqFM key elt
emptyUFM
}
go :: [CmmBlock]
-> LabelMap StackMap
-> WordOff
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, WordOff, [CmmBlock])
go [] LabelMap StackMap
acc_stackmaps WordOff
acc_hwm [CmmBlock]
acc_blocks
= 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) = 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 }
= forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault
(forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"no stack map for" (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 (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 (forall (e :: Extensibility) (x :: Extensibility).
LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle LabelMap StackMap
acc_stackmaps) Block CmmNode O O
middle0 StackMap
stack0
([CmmNode O O]
middle1, WordOff
sp_off, CmmNode O C
last1, [CmmBlock]
fixup_blocks, LabelMap StackMap
out)
<- DynFlags
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> LabelMap WordOff
-> LabelMap StackMap
-> StackMap
-> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleLastNode DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness LabelMap WordOff
cont_info
LabelMap StackMap
acc_stackmaps IndexedCO O StackMap StackMap
stack1 CmmTickScope
tscope Block CmmNode O O
middle0 CmmNode O C
last0
let middle_pre :: [CmmNode O O]
middle_pre = forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' 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 :: [CmmBlock]
final_blocks =
DynFlags
-> LabelMap StackMap
-> StackMap
-> WordOff
-> WordOff
-> CmmNode C O
-> [CmmNode O O]
-> WordOff
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp DynFlags
dflags 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
acc_stackmaps' = forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
mapUnion LabelMap StackMap
acc_stackmaps LabelMap StackMap
out
this_sp_hwm :: WordOff
this_sp_hwm | CmmNode O C -> Bool
isGcJump CmmNode O C
last0 = WordOff
0
| Bool
otherwise = WordOff
sp0 forall a. Num a => a -> a -> a
- WordOff
sp_off
hwm' :: WordOff
hwm' = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (WordOff
acc_hwm forall a. a -> [a] -> [a]
: WordOff
this_sp_hwm forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map StackMap -> WordOff
sm_sp (forall (map :: * -> *) a. IsMap map => map a -> [a]
mapElems LabelMap StackMap
out))
[CmmBlock]
-> LabelMap StackMap
-> WordOff
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, WordOff, [CmmBlock])
go [CmmBlock]
bs LabelMap StackMap
acc_stackmaps' WordOff
hwm' ([CmmBlock]
final_blocks forall a. [a] -> [a] -> [a]
++ [CmmBlock]
acc_blocks)
isGcJump :: CmmNode O C -> Bool
isGcJump :: CmmNode O C -> Bool
isGcJump (CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmReg (CmmGlobal GlobalReg
l) })
= GlobalReg
l forall a. Eq a => a -> a -> Bool
== GlobalReg
GCFun Bool -> Bool -> Bool
|| GlobalReg
l 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
= (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [WordOff]
ret_offs, forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList (forall a. [Maybe a] -> [a]
catMaybes [Maybe (BlockId, WordOff)]
mb_argss))
where
([Maybe (BlockId, WordOff)]
mb_argss, [WordOff]
ret_offs) = forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip 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 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
[GlobalReg]
CmmExpr
cml_ret_off :: CmmNode O C -> WordOff
cml_ret_args :: CmmNode O C -> WordOff
cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_args :: CmmNode O C -> WordOff
cml_ret_off :: WordOff
cml_ret_args :: WordOff
cml_args :: WordOff
cml_args_regs :: [GlobalReg]
cml_target :: CmmExpr
cml_target :: CmmNode O C -> CmmExpr
.. }
-> (forall a. a -> Maybe a
Just (BlockId
l, WordOff
cml_ret_args), WordOff
cml_ret_off)
CmmForeignCall { Bool
WordOff
[CmmExpr]
[LocalReg]
BlockId
ForeignTarget
tgt :: CmmNode O C -> ForeignTarget
succ :: CmmNode O C -> BlockId
ret_off :: CmmNode O C -> WordOff
ret_args :: CmmNode O C -> WordOff
res :: CmmNode O C -> [LocalReg]
intrbl :: CmmNode O C -> Bool
args :: CmmNode O C -> [CmmExpr]
intrbl :: Bool
ret_off :: WordOff
ret_args :: WordOff
succ :: BlockId
args :: [CmmExpr]
res :: [LocalReg]
tgt :: ForeignTarget
.. }
-> (forall a. a -> Maybe a
Just (BlockId
succ, WordOff
ret_args), WordOff
ret_off)
CmmNode O C
_other -> (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 :: UniqFM LocalReg (LocalReg, WordOff)
sm_regs = forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM (StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs StackMap
sm) LocalReg
r (LocalReg
r,WordOff
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 :: UniqFM LocalReg (LocalReg, WordOff)
sm_regs = forall key elt.
Uniquable key =>
UniqFM key elt -> key -> UniqFM key elt
delFromUFM (StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs StackMap
sm) LocalReg
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 forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
l LabelMap StackMap
stackmaps of
Maybe StackMap
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getStackLoc" (forall a. Outputable a => a -> SDoc
ppr BlockId
l)
Just StackMap
sm -> StackMap -> WordOff
sm_sp StackMap
sm forall a. Num a => a -> a -> a
- StackMap -> WordOff
sm_args StackMap
sm forall a. Num a => a -> a -> a
+ WordOff
n
handleLastNode
:: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff
-> LabelMap StackMap -> StackMap -> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqSM
( [CmmNode O O]
, ByteOff
, CmmNode O C
, [CmmBlock]
, LabelMap StackMap
)
handleLastNode :: DynFlags
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> LabelMap WordOff
-> LabelMap StackMap
-> StackMap
-> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleLastNode DynFlags
dflags 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
[GlobalReg]
CmmExpr
cml_ret_off :: WordOff
cml_ret_args :: WordOff
cml_args :: WordOff
cml_args_regs :: [GlobalReg]
cml_target :: CmmExpr
cml_ret_off :: CmmNode O C -> WordOff
cml_ret_args :: CmmNode O C -> WordOff
cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_args :: CmmNode O C -> WordOff
cml_target :: CmmNode O C -> CmmExpr
.. } -> do
let sp_off :: WordOff
sp_off = WordOff
sp0 forall a. Num a => a -> a -> a
- WordOff
cml_args
forall (m :: * -> *) a. Monad m => a -> m a
return ([], WordOff
sp_off, CmmNode O C
last, [], forall (map :: * -> *) a. IsMap map => map a
mapEmpty)
CmmCall{ cml_cont :: CmmNode O C -> Maybe BlockId
cml_cont = Just BlockId
cont_lbl, WordOff
[GlobalReg]
CmmExpr
cml_ret_off :: WordOff
cml_ret_args :: WordOff
cml_args :: WordOff
cml_args_regs :: [GlobalReg]
cml_target :: CmmExpr
cml_ret_off :: CmmNode O C -> WordOff
cml_ret_args :: CmmNode O C -> WordOff
cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_args :: CmmNode O C -> WordOff
cml_target :: CmmNode O C -> CmmExpr
.. } ->
forall (m :: * -> *) a. Monad m => a -> m a
return 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
[CmmExpr]
[LocalReg]
ForeignTarget
intrbl :: Bool
ret_off :: WordOff
ret_args :: WordOff
args :: [CmmExpr]
res :: [LocalReg]
tgt :: ForeignTarget
tgt :: CmmNode O C -> ForeignTarget
ret_off :: CmmNode O C -> WordOff
ret_args :: CmmNode O C -> WordOff
res :: CmmNode O C -> [LocalReg]
intrbl :: CmmNode O C -> Bool
args :: CmmNode O C -> [CmmExpr]
.. } ->
forall (m :: * -> *) a. Monad m => a -> m a
return 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 {} -> UniqSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleBranches
CmmCondBranch {} -> UniqSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleBranches
CmmSwitch {} -> UniqSM
([CmmNode O O], WordOff, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleBranches
where
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
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
, []
, forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
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 <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map 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 :: UniqSM ( [CmmNode O O]
, ByteOff
, CmmNode O C
, [CmmBlock]
, LabelMap StackMap )
handleBranches :: UniqSM
([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
, (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints) forall a b. (a -> b) -> a -> b
$ forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last) forall a. Eq a => a -> a -> Bool
== [BlockId
l]
= do
let cont_args :: WordOff
cont_args = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map 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 = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (BlockId
l', StackMap
cont_stack)
| BlockId
l' <- forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last ]
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
[(BlockId, BlockId, StackMap, [CmmBlock])]
pps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
handleBranch (forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last)
let lbl_map :: LabelMap Label
lbl_map :: LabelMap BlockId
lbl_map = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (BlockId
l,BlockId
tmp) | (BlockId
l,BlockId
tmp,StackMap
_,[CmmBlock]
_) <- [(BlockId, BlockId, StackMap, [CmmBlock])]
pps ]
fix_lbl :: BlockId -> BlockId
fix_lbl BlockId
l = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault BlockId
l BlockId
l LabelMap BlockId
lbl_map
forall (m :: * -> *) a. Monad m => a -> m a
return ( []
, WordOff
0
, (BlockId -> BlockId) -> CmmNode O C -> CmmNode O C
mapSuccessors BlockId -> BlockId
fix_lbl CmmNode O C
last
, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [CmmBlock]
blk | (BlockId
_,BlockId
_,StackMap
_,[CmmBlock]
blk) <- [(BlockId, BlockId, StackMap, [CmmBlock])]
pps ]
, forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (BlockId
l, StackMap
sm) | (BlockId
l,BlockId
_,StackMap
sm,[CmmBlock]
_) <- [(BlockId, BlockId, StackMap, [CmmBlock])]
pps ] )
handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
handleBranch BlockId
l
| Just StackMap
stack2 <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map 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
(BlockId
tmp_lbl, [CmmBlock]
block) <- DynFlags
-> WordOff
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags WordOff
sp0 BlockId
l StackMap
stack2 CmmTickScope
tscp [CmmNode O O]
assigs
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
tmp_lbl, StackMap
stack2, [CmmBlock]
block)
| BlockId
l forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints
= do
let cont_args :: WordOff
cont_args = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map 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
(BlockId
tmp_lbl, [CmmBlock]
block) <- DynFlags
-> WordOff
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags WordOff
sp0 BlockId
l StackMap
stack2 CmmTickScope
tscp [CmmNode O O]
assigs
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
tmp_lbl, StackMap
stack2, [CmmBlock]
block)
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
l, StackMap
stack1, [])
where live :: CmmLocalLive
live = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault (forall a. String -> a
panic String
"handleBranch") BlockId
l BlockEntryLiveness LocalReg
liveness
stack1 :: StackMap
stack1 = StackMap
stack0 { sm_regs :: UniqFM LocalReg (LocalReg, WordOff)
sm_regs = forall elt key. (elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM (LocalReg, WordOff) -> Bool
is_live (StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs StackMap
stack0) }
is_live :: (LocalReg, WordOff) -> Bool
is_live (LocalReg
r,WordOff
_) = LocalReg
r forall r. Ord r => r -> RegSet r -> Bool
`elemRegSet` CmmLocalLive
live
makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap
-> CmmTickScope -> [CmmNode O O]
-> UniqSM (Label, [CmmBlock])
makeFixupBlock :: DynFlags
-> WordOff
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags WordOff
sp0 BlockId
l StackMap
stack CmmTickScope
tscope [CmmNode O O]
assigs
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CmmNode O O]
assigs Bool -> Bool -> Bool
&& WordOff
sp0 forall a. Eq a => a -> a -> Bool
== StackMap -> WordOff
sm_sp StackMap
stack = forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, [])
| Bool
otherwise = do
BlockId
tmp_lbl <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
let sp_off :: WordOff
sp_off = WordOff
sp0 forall a. Num a => a -> a -> a
- StackMap -> WordOff
sm_sp StackMap
stack
block :: CmmBlock
block = 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)
( DynFlags
-> WordOff -> WordOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj DynFlags
dflags WordOff
sp0 WordOff
sp_off
forall a b. (a -> b) -> a -> b
$ forall (n :: Extensibility -> Extensibility -> *).
[n O O] -> Block n O O
blockFromList [CmmNode O O]
assigs )
(BlockId -> CmmNode O C
CmmBranch BlockId
l)
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
tmp_lbl, [CmmBlock
block])
spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff
spOffsetForCall :: WordOff -> StackMap -> WordOff -> WordOff
spOffsetForCall WordOff
current_sp StackMap
cont_stack WordOff
args
= WordOff
current_sp forall a. Num a => a -> a -> a
- (StackMap -> WordOff
sm_sp StackMap
cont_stack forall a. Num a => a -> a -> a
- StackMap -> WordOff
sm_args StackMap
cont_stack 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 = 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) <- forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM LocalReg (LocalReg, WordOff)
old_map LocalReg
r, WordOff
n 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 = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault 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 :: WordOff
sm_sp = StackMap -> WordOff
sm_sp StackMap
stack1 forall a. Num a => a -> a -> a
+ WordOff
ret_args
, sm_args :: WordOff
sm_args = WordOff
ret_args
, sm_ret_off :: WordOff
sm_ret_off = WordOff
updfr_off
}
futureContinuation :: Block CmmNode O O -> Maybe BlockId
futureContinuation :: Block CmmNode O O -> Maybe BlockId
futureContinuation Block CmmNode O O
middle = 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 forall (a :: Extensibility) (b :: Extensibility).
CmmNode a b -> Maybe BlockId -> Maybe BlockId
f Block CmmNode O O
middle forall a. Maybe a
Nothing
where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
f :: forall (a :: Extensibility) (b :: Extensibility).
CmmNode a b -> Maybe BlockId -> Maybe BlockId
f (CmmStore (CmmStackSlot (Young BlockId
l) WordOff
_) (CmmLit (CmmBlock BlockId
_)) AlignmentSpec
_) 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
`elemUFM` UniqFM LocalReg (LocalReg, WordOff)
regs0)) (forall a. Set a -> [a]
Set.elems CmmLocalLive
live)
regs1 :: UniqFM LocalReg (LocalReg, WordOff)
regs1 = forall elt key. (elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM (\(LocalReg
r,WordOff
_) -> forall r. Ord r => r -> RegSet r -> Bool
elemRegSet LocalReg
r CmmLocalLive
live) UniqFM LocalReg (LocalReg, WordOff)
regs0
in
let stack :: [StackSlot]
stack = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall i e. Array i e -> [e]
Array.elems forall a b. (a -> b) -> a -> b
$
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 (forall a. Ord a => a -> a -> a
max WordOff
sp0 WordOff
ret_off)) forall a b. (a -> b) -> a -> b
$
[(WordOff, StackSlot)]
ret_words 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) <- forall key 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 forall a. Num a => a -> a -> a
- Platform -> WordOff
platformWordSizeInBytes Platform
platform .. WordOff
off forall a. Num a => a -> a -> a
- WordOff
w 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
slotforall 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
Occupiedforall 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
slotforall 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 forall a. a -> [a] -> [a]
: [CmmNode O O]
assigs, (LocalReg
r,(LocalReg
r,WordOff
n'))forall a. a -> [a] -> [a]
:[(LocalReg, (LocalReg, WordOff))]
regs)
| Bool
otherwise
-> ([LocalReg]
to_save, StackSlot
slotforall 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 = 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
= forall a. a -> Maybe a
Just (forall a. WordOff -> a -> [a]
replicate WordOff
words StackSlot
Occupied forall a. [a] -> [a] -> [a]
++ [StackSlot]
rest, LocalReg
r, [LocalReg]
rsforall a. [a] -> [a] -> [a]
++[LocalReg]
no_fit)
| Bool
otherwise
= [LocalReg]
-> [LocalReg] -> Maybe ([StackSlot], LocalReg, [LocalReg])
go [LocalReg]
rs (LocalReg
rforall 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)
= 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)
= 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 forall a. a -> [a] -> [a]
: [CmmNode O O]
assigs, (LocalReg
r,(LocalReg
r,WordOff
n')) forall a. a -> [a] -> [a]
: [(LocalReg, (LocalReg, WordOff))]
regs)
where
n' :: WordOff
n' = WordOff
n 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 (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 (- forall (t :: * -> *) a. Foldable t => t a -> WordOff
length (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 forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
`addListToUFM` [(LocalReg, (LocalReg, WordOff))]
push_regs
forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
`addListToUFM` [(LocalReg, (LocalReg, WordOff))]
save_regs
in
if ( WordOff
n forall a. Eq a => a -> a -> Bool
/= forall a. Ord a => a -> a -> a
max WordOff
sp0 WordOff
ret_off ) then forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocate" (forall a. Outputable a => a -> SDoc
ppr WordOff
n SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr WordOff
sp0 SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr WordOff
ret_off) else
if (WordOff
trim_sp forall a. Bits a => a -> a -> a
.&. (Platform -> WordOff
platformWordSizeInBytes Platform
platform forall a. Num a => a -> a -> a
- WordOff
1)) forall a. Eq a => a -> a -> Bool
/= WordOff
0 then forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocate2" (forall a. Outputable a => a -> SDoc
ppr WordOff
trim_sp SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr UniqFM LocalReg (LocalReg, WordOff)
final_regs SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr WordOff
push_sp) else
( StackMap
stackmap { sm_regs :: UniqFM LocalReg (LocalReg, WordOff)
sm_regs = UniqFM LocalReg (LocalReg, WordOff)
final_regs , sm_sp :: WordOff
sm_sp = WordOff
trim_sp }
, [CmmNode O O]
push_assigs forall a. [a] -> [a] -> [a]
++ [CmmNode O O]
save_assigs )
manifestSp
:: DynFlags
-> LabelMap StackMap
-> StackMap
-> ByteOff
-> ByteOff
-> CmmNode C O
-> [CmmNode O O]
-> ByteOff
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp :: DynFlags
-> LabelMap StackMap
-> StackMap
-> WordOff
-> WordOff
-> CmmNode C O
-> [CmmNode O O]
-> WordOff
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp DynFlags
dflags 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 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 = DynFlags -> Platform
targetPlatform DynFlags
dflags
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 = 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 = 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 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 = DynFlags
-> WordOff -> WordOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj DynFlags
dflags WordOff
sp0 WordOff
sp_off
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Extensibility -> Extensibility -> *).
[n O O] -> Block n O O
blockFromList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_pre_sp
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
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 (forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_post_sp CmmNode O C
last)
final_block :: CmmBlock
final_block = 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' = forall a b. (a -> b) -> [a] -> [b]
map (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' (forall a. a -> a
id, forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> CmmNode e x
adj_post_sp, 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 forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
l LabelMap StackMap
stackmaps of
Just StackMap
sm -> StackMap -> WordOff
sm_sp StackMap
sm forall a. Num a => a -> a -> a
- StackMap -> WordOff
sm_args StackMap
sm
Maybe StackMap
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getAreaOff" (forall a. Outputable a => a -> SDoc
ppr BlockId
l)
maybeAddSpAdj
:: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj :: DynFlags
-> WordOff -> WordOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj DynFlags
dflags WordOff
sp0 WordOff
sp_off Block CmmNode O O
block =
Block CmmNode O O -> Block CmmNode O O
add_initial_unwind forall a b. (a -> b) -> a -> b
$ Block CmmNode O O -> Block CmmNode O O
add_adj_unwind 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 = DynFlags -> Platform
targetPlatform DynFlags
dflags
adj :: Block CmmNode O O -> Block CmmNode O O
adj Block CmmNode O O
block
| WordOff
sp_off forall a. Eq a => a -> a -> Bool
/= WordOff
0
= Block CmmNode O O
block forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e O -> n O O -> Block n e O
`blockSnoc` CmmReg -> CmmExpr -> CmmNode O O
CmmAssign CmmReg
spReg (Platform -> CmmExpr -> WordOff -> CmmExpr
cmmOffset Platform
platform CmmExpr
spExpr 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
| DynFlags -> WordOff
debugLevel DynFlags
dflags forall a. Ord a => a -> a -> Bool
> WordOff
0
= [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
CmmUnwind [(GlobalReg
Sp, forall a. a -> Maybe a
Just CmmExpr
sp_unwind)] 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 CmmReg
spReg (WordOff
sp0 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
| DynFlags -> WordOff
debugLevel DynFlags
dflags forall a. Ord a => a -> a -> Bool
> WordOff
0
, WordOff
sp_off forall a. Eq a => a -> a -> Bool
/= WordOff
0
= Block CmmNode O O
block 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, 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 CmmReg
spReg (WordOff
sp0 forall a. Num a => a -> a -> a
- Platform -> WordOff
platformWordSizeInBytes Platform
platform 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 CmmExpr
spExpr (WordOff
sp_old forall a. Num a => a -> a -> a
- Area -> WordOff
area_off Area
area 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 GlobalReg
Sp) WordOff
x_off
, CmmLit (CmmInt Integer
y_lit Width
_)]
, CmmReg (CmmGlobal GlobalReg
SpLim)]
= forall a b. (Integral a, Num b) => a -> b
fromIntegral WordOff
x_off 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) <- 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 forall a. Num a => a -> a -> a
+ WordOff
m 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 forall a. a -> [a] -> [a]
: StackMap -> [CmmNode O O] -> [CmmNode O O]
go (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
stack_info :: CmmTopInfo -> CmmStackInfo
info_tbls :: CmmTopInfo -> LabelMap CmmInfoTable
stack_info :: CmmStackInfo
info_tbls :: LabelMap CmmInfoTable
..} CLabel
l [GlobalReg]
v CmmGraph
g)
= forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
top_info{ info_tbls :: LabelMap CmmInfoTable
info_tbls = forall (map :: * -> *) a b.
IsMap map =>
(KeyOf map -> a -> b) -> map a -> map b
mapMapWithKey BlockId -> CmmInfoTable -> CmmInfoTable
fix_info LabelMap CmmInfoTable
info_tbls } CLabel
l [GlobalReg]
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 :: SMRep
cit_rep = Liveness -> SMRep
StackRep (BlockId -> Liveness
get_liveness BlockId
lbl) }
fix_info BlockId
_ CmmInfoTable
other = CmmInfoTable
other
get_liveness :: BlockId -> Liveness
get_liveness :: BlockId -> Liveness
get_liveness BlockId
lbl
= case forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
lbl LabelMap StackMap
stackmaps of
Maybe StackMap
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"setInfoTableStackMap" (forall a. Outputable a => a -> SDoc
ppr BlockId
lbl SDoc -> SDoc -> 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_regs :: UniqFM LocalReg (LocalReg, WordOff)
sm_ret_off :: WordOff
sm_args :: WordOff
sm_sp :: WordOff
sm_regs :: StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_ret_off :: StackMap -> WordOff
sm_args :: StackMap -> WordOff
sm_sp :: StackMap -> WordOff
..} =
forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall i e. Array i e -> [e]
Array.elems forall a b. (a -> b) -> a -> b
$
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 forall a. Num a => a -> a -> a
+ WordOff
1,
Platform -> WordOff -> WordOff
toWords Platform
platform (WordOff
sm_sp 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) <- forall key 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]
-> UniqSM [CmmBlock]
insertReloadsAsNeeded :: Platform
-> ProcPointSet
-> LabelMap StackMap
-> BlockId
-> [CmmBlock]
-> UniqSM [CmmBlock]
insertReloadsAsNeeded Platform
platform ProcPointSet
procpoints LabelMap StackMap
final_stackmaps BlockId
entry [CmmBlock]
blocks =
CmmGraph -> [CmmBlock]
toBlockList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall f.
DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmmBwd forall r. Ord r => DataflowLattice (CmmLive r)
liveLattice RewriteFun CmmLocalLive
rewriteCC (BlockId -> [CmmBlock] -> CmmGraph
ofBlockList BlockId
entry [CmmBlock]
blocks) forall (map :: * -> *) a. IsMap map => map a
mapEmpty
where
rewriteCC :: RewriteFun CmmLocalLive
rewriteCC :: RewriteFun 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 = forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmNode C O
e_node
stackmap :: StackMap
stackmap = case forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
entry_label LabelMap StackMap
final_stackmaps of
Just StackMap
sm -> StackMap
sm
Maybe StackMap
Nothing -> forall a. String -> a
panic String
"insertReloadsAsNeeded: rewriteCC: stackmap"
joined :: CmmLocalLive
joined = forall r n.
(DefinerOfRegs r n, UserOfRegs r n) =>
Platform -> n -> CmmLive r -> CmmLive r
gen_kill Platform
platform CmmNode O C
x_node forall a b. (a -> b) -> a -> b
$!
forall (n :: Extensibility -> Extensibility -> *) f
(e :: Extensibility).
NonLocal n =>
DataflowLattice f -> n e C -> FactBase f -> f
joinOutFacts forall r. Ord r => DataflowLattice (CmmLive r)
liveLattice CmmNode O C
x_node BlockEntryLiveness LocalReg
fact_base0
live_at_middle0 :: CmmLocalLive
live_at_middle0 = forall f. (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
foldNodesBwdOO (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 forall set. IsSet set => ElemOf set -> set -> 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 (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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, forall a. Set a
emptyRegSet)
| Bool
otherwise
= (Block CmmNode O O
middle0, CmmLocalLive
live_at_middle0)
!fact_base2 :: BlockEntryLiveness LocalReg
fact_base2 = forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton BlockId
entry_label CmmLocalLive
live_with_reloads
forall (m :: * -> *) a. Monad m => a -> m a
return (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 CmmExpr
spExpr (WordOff
sp_off 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 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 -> UniqSM CmmBlock
lowerSafeForeignCall :: Profile -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall Profile
profile CmmBlock
block
| (entry :: CmmNode C O
entry@(CmmEntry BlockId
_ CmmTickScope
tscp), Block CmmNode O O
middle, CmmForeignCall { Bool
WordOff
[CmmExpr]
[LocalReg]
BlockId
ForeignTarget
intrbl :: Bool
ret_off :: WordOff
ret_args :: WordOff
succ :: BlockId
args :: [CmmExpr]
res :: [LocalReg]
tgt :: ForeignTarget
tgt :: CmmNode O C -> ForeignTarget
succ :: CmmNode O C -> BlockId
ret_off :: CmmNode O C -> WordOff
ret_args :: CmmNode O C -> WordOff
res :: CmmNode O C -> [LocalReg]
intrbl :: CmmNode O C -> Bool
args :: CmmNode O C -> [CmmExpr]
.. }) <- 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
LocalReg
id <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
bWord Platform
platform)
LocalReg
new_base <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
baseReg)
let (CmmAGraph
caller_save, CmmAGraph
caller_load) = Platform -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs Platform
platform
CmmAGraph
save_state_code <- forall (m :: * -> *). MonadUnique m => Profile -> m CmmAGraph
saveThreadState Profile
profile
CmmAGraph
load_state_code <- forall (m :: * -> *). MonadUnique m => Profile -> m CmmAGraph
loadThreadState Profile
profile
let suspend :: CmmAGraph
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 :: CmmAGraph
midCall = ForeignTarget -> [LocalReg] -> [CmmExpr] -> CmmAGraph
mkUnsafeCall ForeignTarget
tgt [LocalReg]
res [CmmExpr]
args
resume :: CmmAGraph
resume = CmmNode O O -> CmmAGraph
mkMiddle (LocalReg -> LocalReg -> CmmNode O O
callResumeThread LocalReg
new_base LocalReg
id) CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
baseReg (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
new_base)) CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmAGraph
caller_load CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmAGraph
load_state_code
(WordOff
_, [GlobalReg]
regs, CmmAGraph
copyout) =
Profile
-> Convention
-> Transfer
-> Area
-> [CmmExpr]
-> WordOff
-> [CmmExpr]
-> (WordOff, [GlobalReg], CmmAGraph)
copyOutOflow Profile
profile Convention
NativeReturn Transfer
Jump (BlockId -> Area
Young BlockId
succ)
(forall a b. (a -> b) -> [a] -> [b]
map (CmmReg -> CmmExpr
CmmReg forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) [LocalReg]
res)
WordOff
ret_off []
jump :: CmmNode O C
jump = CmmCall { cml_target :: CmmExpr
cml_target = Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform forall a b. (a -> b) -> a -> b
$
Platform -> CmmExpr -> CmmExpr
cmmLoadBWord Platform
platform CmmExpr
spExpr
, cml_cont :: Maybe BlockId
cml_cont = forall a. a -> Maybe a
Just BlockId
succ
, cml_args_regs :: [GlobalReg]
cml_args_regs = [GlobalReg]
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 }
CmmGraph
graph' <- CmmAGraphScoped -> UniqSM CmmGraph
lgraphOfAGraph ( CmmAGraph
suspend CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmAGraph
midCall CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmAGraph
resume CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmAGraph
copyout CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmNode O C -> CmmAGraph
mkLast CmmNode O C
jump, CmmTickScope
tscp)
case CmmGraph -> [CmmBlock]
toBlockList CmmGraph
graph' of
[CmmBlock
one] -> let (CmmNode C O
_, Block CmmNode O O
middle', CmmNode O C
last) = forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
one
in forall (m :: * -> *) a. Monad m => a -> m a
return (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 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]
_ -> forall a. String -> a
panic String
"lowerSafeForeignCall0"
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return CmmBlock
block
foreignLbl :: FastString -> CmmExpr
foreignLbl :: FastString -> CmmExpr
foreignLbl FastString
name = CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (FastString
-> Maybe WordOff -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
name forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInExternalPackage FunctionOrData
IsFunction))
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
(CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget (FastString -> CmmExpr
foreignLbl (String -> FastString
fsLit String
"suspendThread"))
(CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [ForeignHint
AddrHint, ForeignHint
NoHint] [ForeignHint
AddrHint] CmmReturnInfo
CmmMayReturn))
[LocalReg
id] [CmmExpr
baseExpr, Platform -> WordOff -> CmmExpr
mkIntExpr Platform
platform (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
(CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget (FastString -> CmmExpr
foreignLbl (String -> FastString
fsLit String
"resumeThread"))
(CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [ForeignHint
AddrHint] [ForeignHint
AddrHint] CmmReturnInfo
CmmMayReturn))
[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 forall a. Num a => a -> a -> a
+ WordOff
w 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
text String
"XXX"
ppr StackSlot
Empty = String -> SDoc
text String
"---"
dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty WordOff
0 [StackSlot]
ss = forall a. a -> Maybe a
Just [StackSlot]
ss
dropEmpty WordOff
n (StackSlot
Empty : [StackSlot]
ss) = WordOff -> [StackSlot] -> Maybe [StackSlot]
dropEmpty (WordOff
nforall a. Num a => a -> a -> a
-WordOff
1) [StackSlot]
ss
dropEmpty WordOff
_ [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 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 forall a. Integral a => a -> a -> a
`quot` Platform -> WordOff
platformWordSizeInBytes Platform
platform
stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
stackSlotRegs :: StackMap -> [(LocalReg, WordOff)]
stackSlotRegs StackMap
sm = forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM (StackMap -> UniqFM LocalReg (LocalReg, WordOff)
sm_regs StackMap
sm)