{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}
module CmmLayoutStack (
cmmLayoutStack, setInfoTableStackMap
) where
import GhcPrelude hiding ((<*>))
import GHC.StgToCmm.Utils ( callerSaveVolatileRegs, newTemp )
import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState )
import BasicTypes
import Cmm
import CmmInfo
import BlockId
import CLabel
import CmmUtils
import MkGraph
import ForeignCall
import CmmLive
import CmmProcPoint
import SMRep
import Hoopl.Block
import Hoopl.Collections
import Hoopl.Dataflow
import Hoopl.Graph
import Hoopl.Label
import UniqSupply
import Maybes
import UniqFM
import Util
import DynFlags
import FastString
import Outputable hiding ( isEmpty )
import qualified Data.Set as Set
import Control.Monad.Fix
import Data.Array as Array
import Data.Bits
import Data.List (nub)
type StackLoc = ByteOff
data StackMap = StackMap
{ StackMap -> StackLoc
sm_sp :: StackLoc
, StackMap -> StackLoc
sm_args :: ByteOff
, StackMap -> StackLoc
sm_ret_off :: ByteOff
, StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs :: UniqFM (LocalReg,StackLoc)
}
instance Outputable StackMap where
ppr :: StackMap -> SDoc
ppr StackMap{StackLoc
UniqFM (LocalReg, StackLoc)
sm_regs :: UniqFM (LocalReg, StackLoc)
sm_ret_off :: StackLoc
sm_args :: StackLoc
sm_sp :: StackLoc
sm_regs :: StackMap -> UniqFM (LocalReg, StackLoc)
sm_ret_off :: StackMap -> StackLoc
sm_args :: StackMap -> StackLoc
sm_sp :: StackMap -> StackLoc
..} =
String -> SDoc
text String
"Sp = " SDoc -> SDoc -> SDoc
<> StackLoc -> SDoc
int StackLoc
sm_sp SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"sm_args = " SDoc -> SDoc -> SDoc
<> StackLoc -> SDoc
int StackLoc
sm_args SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"sm_ret_off = " SDoc -> SDoc -> SDoc
<> StackLoc -> SDoc
int StackLoc
sm_ret_off SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"sm_regs = " SDoc -> SDoc -> SDoc
<> UniqFM (LocalReg, StackLoc)
-> ([(LocalReg, StackLoc)] -> SDoc) -> SDoc
forall a. UniqFM a -> ([a] -> SDoc) -> SDoc
pprUFM UniqFM (LocalReg, StackLoc)
sm_regs [(LocalReg, StackLoc)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr
cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
-> UniqSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack :: DynFlags
-> ProcPointSet
-> StackLoc
-> CmmGraph
-> UniqSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack DynFlags
dflags ProcPointSet
procpoints StackLoc
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 = DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg
cmmLocalLiveness DynFlags
dflags CmmGraph
graph
blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
revPostorder CmmGraph
graph
(LabelMap StackMap
final_stackmaps, StackLoc
_final_high_sp, [CmmBlock]
new_blocks) <-
((LabelMap StackMap, StackLoc, [CmmBlock])
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock]))
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (((LabelMap StackMap, StackLoc, [CmmBlock])
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock]))
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock]))
-> ((LabelMap StackMap, StackLoc, [CmmBlock])
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock]))
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
forall a b. (a -> b) -> a -> b
$ \ ~(LabelMap StackMap
rec_stackmaps, StackLoc
rec_high_sp, [CmmBlock]
_new_blocks) ->
DynFlags
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> BlockId
-> StackLoc
-> LabelMap StackMap
-> StackLoc
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
layout DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness BlockId
entry StackLoc
entry_args
LabelMap StackMap
rec_stackmaps StackLoc
rec_high_sp [CmmBlock]
blocks
[CmmBlock]
blocks_with_reloads <-
DynFlags
-> ProcPointSet
-> LabelMap StackMap
-> BlockId
-> [CmmBlock]
-> UniqSM [CmmBlock]
insertReloadsAsNeeded DynFlags
dflags ProcPointSet
procpoints LabelMap StackMap
final_stackmaps BlockId
entry [CmmBlock]
new_blocks
[CmmBlock]
new_blocks' <- (CmmBlock -> UniqSM CmmBlock) -> [CmmBlock] -> UniqSM [CmmBlock]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall DynFlags
dflags) [CmmBlock]
blocks_with_reloads
(CmmGraph, LabelMap StackMap)
-> UniqSM (CmmGraph, LabelMap StackMap)
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
-> StackLoc
-> LabelMap StackMap
-> StackLoc
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
layout DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness BlockId
entry StackLoc
entry_args LabelMap StackMap
final_stackmaps StackLoc
final_sp_high [CmmBlock]
blocks
= [CmmBlock]
-> LabelMap StackMap
-> StackLoc
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
go [CmmBlock]
blocks LabelMap StackMap
init_stackmap StackLoc
entry_args []
where
(StackLoc
updfr, LabelMap StackLoc
cont_info) = [CmmBlock] -> (StackLoc, LabelMap StackLoc)
collectContInfo [CmmBlock]
blocks
init_stackmap :: LabelMap StackMap
init_stackmap = KeyOf LabelMap -> StackMap -> LabelMap StackMap
forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton KeyOf LabelMap
BlockId
entry StackMap :: StackLoc
-> StackLoc -> StackLoc -> UniqFM (LocalReg, StackLoc) -> StackMap
StackMap{ sm_sp :: StackLoc
sm_sp = StackLoc
entry_args
, sm_args :: StackLoc
sm_args = StackLoc
entry_args
, sm_ret_off :: StackLoc
sm_ret_off = StackLoc
updfr
, sm_regs :: UniqFM (LocalReg, StackLoc)
sm_regs = UniqFM (LocalReg, StackLoc)
forall elt. UniqFM elt
emptyUFM
}
go :: [CmmBlock]
-> LabelMap StackMap
-> StackLoc
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
go [] LabelMap StackMap
acc_stackmaps StackLoc
acc_hwm [CmmBlock]
acc_blocks
= (LabelMap StackMap, StackLoc, [CmmBlock])
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelMap StackMap
acc_stackmaps, StackLoc
acc_hwm, [CmmBlock]
acc_blocks)
go (CmmBlock
b0 : [CmmBlock]
bs) LabelMap StackMap
acc_stackmaps StackLoc
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 -> StackLoc
sm_sp = StackLoc
sp0 }
= StackMap -> KeyOf LabelMap -> LabelMap StackMap -> StackMap
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map 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))
KeyOf LabelMap
BlockId
entry_lbl LabelMap StackMap
acc_stackmaps
let stack1 :: IndexedCO O StackMap StackMap
stack1 = (forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> StackMap -> StackMap)
-> Block CmmNode O O
-> IndexedCO O StackMap StackMap
-> IndexedCO O 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
([CmmNode O O]
middle1, StackLoc
sp_off, CmmNode O C
last1, [CmmBlock]
fixup_blocks, LabelMap StackMap
out)
<- DynFlags
-> ProcPointSet
-> BlockEntryLiveness LocalReg
-> LabelMap StackLoc
-> LabelMap StackMap
-> StackMap
-> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleLastNode DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness LabelMap StackLoc
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 :: [CmmNode O O]
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 (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 :: [CmmBlock]
final_blocks =
DynFlags
-> LabelMap StackMap
-> StackMap
-> StackLoc
-> StackLoc
-> CmmNode C O
-> [CmmNode O O]
-> StackLoc
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp DynFlags
dflags LabelMap StackMap
final_stackmaps StackMap
stack0 StackLoc
sp0 StackLoc
final_sp_high
CmmNode C O
entry0 [CmmNode O O]
middle_pre StackLoc
sp_off CmmNode O C
last1 [CmmBlock]
fixup_blocks
let acc_stackmaps' :: LabelMap StackMap
acc_stackmaps' = LabelMap StackMap -> LabelMap StackMap -> LabelMap StackMap
forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
mapUnion LabelMap StackMap
acc_stackmaps LabelMap StackMap
out
this_sp_hwm :: StackLoc
this_sp_hwm | CmmNode O C -> Bool
isGcJump CmmNode O C
last0 = StackLoc
0
| Bool
otherwise = StackLoc
sp0 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
sp_off
hwm' :: StackLoc
hwm' = [StackLoc] -> StackLoc
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (StackLoc
acc_hwm StackLoc -> [StackLoc] -> [StackLoc]
forall a. a -> [a] -> [a]
: StackLoc
this_sp_hwm StackLoc -> [StackLoc] -> [StackLoc]
forall a. a -> [a] -> [a]
: (StackMap -> StackLoc) -> [StackMap] -> [StackLoc]
forall a b. (a -> b) -> [a] -> [b]
map StackMap -> StackLoc
sm_sp (LabelMap StackMap -> [StackMap]
forall (map :: * -> *) a. IsMap map => map a -> [a]
mapElems LabelMap StackMap
out))
[CmmBlock]
-> LabelMap StackMap
-> StackLoc
-> [CmmBlock]
-> UniqSM (LabelMap StackMap, StackLoc, [CmmBlock])
go [CmmBlock]
bs LabelMap StackMap
acc_stackmaps' StackLoc
hwm' ([CmmBlock]
final_blocks [CmmBlock] -> [CmmBlock] -> [CmmBlock]
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 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] -> (StackLoc, LabelMap StackLoc)
collectContInfo [CmmBlock]
blocks
= ([StackLoc] -> StackLoc
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [StackLoc]
ret_offs, [(KeyOf LabelMap, StackLoc)] -> LabelMap StackLoc
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([Maybe (BlockId, StackLoc)] -> [(BlockId, StackLoc)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (BlockId, StackLoc)]
mb_argss))
where
([Maybe (BlockId, StackLoc)]
mb_argss, [StackLoc]
ret_offs) = (CmmBlock -> (Maybe (BlockId, StackLoc), StackLoc))
-> [CmmBlock] -> ([Maybe (BlockId, StackLoc)], [StackLoc])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip CmmBlock -> (Maybe (BlockId, StackLoc), StackLoc)
forall (x :: Extensibility).
Block CmmNode x C -> (Maybe (BlockId, StackLoc), StackLoc)
get_cont [CmmBlock]
blocks
get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)
get_cont :: Block CmmNode x C -> (Maybe (BlockId, StackLoc), StackLoc)
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, StackLoc
[GlobalReg]
CmmExpr
cml_ret_off :: CmmNode O C -> StackLoc
cml_ret_args :: CmmNode O C -> StackLoc
cml_args :: CmmNode O C -> StackLoc
cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_ret_off :: StackLoc
cml_ret_args :: StackLoc
cml_args :: StackLoc
cml_args_regs :: [GlobalReg]
cml_target :: CmmExpr
cml_target :: CmmNode O C -> CmmExpr
.. }
-> ((BlockId, StackLoc) -> Maybe (BlockId, StackLoc)
forall a. a -> Maybe a
Just (BlockId
l, StackLoc
cml_ret_args), StackLoc
cml_ret_off)
CmmForeignCall { Bool
StackLoc
[LocalReg]
[CmmExpr]
BlockId
ForeignTarget
intrbl :: CmmNode O C -> Bool
ret_off :: CmmNode O C -> StackLoc
ret_args :: CmmNode O C -> StackLoc
succ :: CmmNode O C -> BlockId
args :: CmmNode O C -> [CmmExpr]
res :: CmmNode O C -> [LocalReg]
tgt :: CmmNode O C -> ForeignTarget
intrbl :: Bool
ret_off :: StackLoc
ret_args :: StackLoc
succ :: BlockId
args :: [CmmExpr]
res :: [LocalReg]
tgt :: ForeignTarget
.. }
-> ((BlockId, StackLoc) -> Maybe (BlockId, StackLoc)
forall a. a -> Maybe a
Just (BlockId
succ, StackLoc
ret_args), StackLoc
ret_off)
CmmNode O C
_other -> (Maybe (BlockId, StackLoc)
forall a. Maybe a
Nothing, StackLoc
0)
procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
procMiddle :: 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 StackLoc
off) CmmType
_)
-> StackMap
sm { sm_regs :: UniqFM (LocalReg, StackLoc)
sm_regs = UniqFM (LocalReg, StackLoc)
-> LocalReg -> (LocalReg, StackLoc) -> UniqFM (LocalReg, StackLoc)
forall key elt.
Uniquable key =>
UniqFM elt -> key -> elt -> UniqFM elt
addToUFM (StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs StackMap
sm) LocalReg
r (LocalReg
r,StackLoc
loc) }
where loc :: StackLoc
loc = Area -> StackLoc -> LabelMap StackMap -> StackLoc
getStackLoc Area
area StackLoc
off LabelMap StackMap
stackmaps
CmmAssign (CmmLocal LocalReg
r) CmmExpr
_other
-> StackMap
sm { sm_regs :: UniqFM (LocalReg, StackLoc)
sm_regs = UniqFM (LocalReg, StackLoc)
-> LocalReg -> UniqFM (LocalReg, StackLoc)
forall key elt. Uniquable key => UniqFM elt -> key -> UniqFM elt
delFromUFM (StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs StackMap
sm) LocalReg
r }
CmmNode e x
_other
-> StackMap
sm
getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc
getStackLoc :: Area -> StackLoc -> LabelMap StackMap -> StackLoc
getStackLoc Area
Old StackLoc
n LabelMap StackMap
_ = StackLoc
n
getStackLoc (Young BlockId
l) StackLoc
n LabelMap StackMap
stackmaps =
case KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
l LabelMap StackMap
stackmaps of
Maybe StackMap
Nothing -> String -> SDoc -> StackLoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getStackLoc" (BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
l)
Just StackMap
sm -> StackMap -> StackLoc
sm_sp StackMap
sm StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackMap -> StackLoc
sm_args StackMap
sm StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
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 StackLoc
-> LabelMap StackMap
-> StackMap
-> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
-> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleLastNode DynFlags
dflags ProcPointSet
procpoints BlockEntryLiveness LocalReg
liveness LabelMap StackLoc
cont_info LabelMap StackMap
stackmaps
stack0 :: StackMap
stack0@StackMap { sm_sp :: StackMap -> StackLoc
sm_sp = StackLoc
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, StackLoc
[GlobalReg]
CmmExpr
cml_ret_off :: StackLoc
cml_ret_args :: StackLoc
cml_args :: StackLoc
cml_args_regs :: [GlobalReg]
cml_target :: CmmExpr
cml_ret_off :: CmmNode O C -> StackLoc
cml_ret_args :: CmmNode O C -> StackLoc
cml_args :: CmmNode O C -> StackLoc
cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_target :: CmmNode O C -> CmmExpr
.. } -> do
let sp_off :: StackLoc
sp_off = StackLoc
sp0 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
cml_args
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], StackLoc
sp_off, CmmNode O C
last, [], LabelMap StackMap
forall (map :: * -> *) a. IsMap map => map a
mapEmpty)
CmmCall{ cml_cont :: CmmNode O C -> Maybe BlockId
cml_cont = Just BlockId
cont_lbl, StackLoc
[GlobalReg]
CmmExpr
cml_ret_off :: StackLoc
cml_ret_args :: StackLoc
cml_args :: StackLoc
cml_args_regs :: [GlobalReg]
cml_target :: CmmExpr
cml_ret_off :: CmmNode O C -> StackLoc
cml_ret_args :: CmmNode O C -> StackLoc
cml_args :: CmmNode O C -> StackLoc
cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_target :: CmmNode O C -> CmmExpr
.. } ->
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap))
-> ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
forall a b. (a -> b) -> a -> b
$ BlockId
-> StackLoc
-> StackLoc
-> StackLoc
-> ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
lastCall BlockId
cont_lbl StackLoc
cml_args StackLoc
cml_ret_args StackLoc
cml_ret_off
CmmForeignCall{ succ :: CmmNode O C -> BlockId
succ = BlockId
cont_lbl, Bool
StackLoc
[LocalReg]
[CmmExpr]
ForeignTarget
intrbl :: Bool
ret_off :: StackLoc
ret_args :: StackLoc
args :: [CmmExpr]
res :: [LocalReg]
tgt :: ForeignTarget
intrbl :: CmmNode O C -> Bool
ret_off :: CmmNode O C -> StackLoc
ret_args :: CmmNode O C -> StackLoc
args :: CmmNode O C -> [CmmExpr]
res :: CmmNode O C -> [LocalReg]
tgt :: CmmNode O C -> ForeignTarget
.. } -> do
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap))
-> ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
forall a b. (a -> b) -> a -> b
$ BlockId
-> StackLoc
-> StackLoc
-> StackLoc
-> ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
lastCall BlockId
cont_lbl (DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags) StackLoc
ret_args StackLoc
ret_off
CmmBranch {} -> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleBranches
CmmCondBranch {} -> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleBranches
CmmSwitch {} -> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
handleBranches
where
lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff
-> ( [CmmNode O O]
, ByteOff
, CmmNode O C
, [CmmBlock]
, LabelMap StackMap
)
lastCall :: BlockId
-> StackLoc
-> StackLoc
-> StackLoc
-> ([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
lastCall BlockId
lbl StackLoc
cml_args StackLoc
cml_ret_args StackLoc
cml_ret_off
= ( [CmmNode O O]
assignments
, StackLoc -> StackMap -> StackLoc -> StackLoc
spOffsetForCall StackLoc
sp0 StackMap
cont_stack StackLoc
cml_args
, CmmNode O C
last
, []
, KeyOf LabelMap -> StackMap -> LabelMap StackMap
forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton KeyOf LabelMap
BlockId
lbl StackMap
cont_stack )
where
([CmmNode O O]
assignments, StackMap
cont_stack) = BlockId -> StackLoc -> StackLoc -> ([CmmNode O O], StackMap)
prepareStack BlockId
lbl StackLoc
cml_ret_args StackLoc
cml_ret_off
prepareStack :: BlockId -> StackLoc -> StackLoc -> ([CmmNode O O], StackMap)
prepareStack BlockId
lbl StackLoc
cml_ret_args StackLoc
cml_ret_off
| Just StackMap
cont_stack <- KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
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)
= DynFlags
-> BlockId
-> BlockEntryLiveness LocalReg
-> StackLoc
-> StackLoc
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame DynFlags
dflags BlockId
lbl BlockEntryLiveness LocalReg
liveness StackLoc
cml_ret_off StackLoc
cml_ret_args StackMap
stack0
handleBranches :: UniqSM ( [CmmNode O O]
, ByteOff
, CmmNode O C
, [CmmBlock]
, LabelMap StackMap )
handleBranches :: UniqSM
([CmmNode O O], StackLoc, 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 (ElemOf ProcPointSet -> ProcPointSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints) ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ CmmNode O 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 :: StackLoc
cont_args = StackLoc -> KeyOf LabelMap -> LabelMap StackLoc -> StackLoc
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault StackLoc
0 KeyOf LabelMap
BlockId
l LabelMap StackLoc
cont_info
([CmmNode O O]
assigs, StackMap
cont_stack) = BlockId -> StackLoc -> StackLoc -> ([CmmNode O O], StackMap)
prepareStack BlockId
l StackLoc
cont_args (StackMap -> StackLoc
sm_ret_off StackMap
stack0)
out :: LabelMap StackMap
out = [(KeyOf LabelMap, StackMap)] -> LabelMap StackMap
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (KeyOf LabelMap
BlockId
l', StackMap
cont_stack)
| BlockId
l' <- CmmNode O C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last ]
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [CmmNode O O]
assigs
, StackLoc -> StackMap -> StackLoc -> StackLoc
spOffsetForCall StackLoc
sp0 StackMap
cont_stack (DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags)
, CmmNode O C
last
, []
, LabelMap StackMap
out)
| Bool
otherwise = do
[(BlockId, BlockId, StackMap, [CmmBlock])]
pps <- (BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock]))
-> [BlockId] -> UniqSM [(BlockId, BlockId, StackMap, [CmmBlock])]
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 (CmmNode O 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 :: LabelMap BlockId
lbl_map = [(KeyOf LabelMap, BlockId)] -> LabelMap BlockId
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (KeyOf LabelMap
BlockId
l,BlockId
tmp) | (BlockId
l,BlockId
tmp,StackMap
_,[CmmBlock]
_) <- [(BlockId, BlockId, StackMap, [CmmBlock])]
pps ]
fix_lbl :: BlockId -> BlockId
fix_lbl BlockId
l = BlockId -> KeyOf LabelMap -> LabelMap BlockId -> BlockId
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault BlockId
l KeyOf LabelMap
BlockId
l LabelMap BlockId
lbl_map
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
-> UniqSM
([CmmNode O O], StackLoc, CmmNode O C, [CmmBlock],
LabelMap StackMap)
forall (m :: * -> *) a. Monad m => a -> m a
return ( []
, StackLoc
0
, (BlockId -> BlockId) -> CmmNode O C -> CmmNode O C
mapSuccessors BlockId -> BlockId
fix_lbl CmmNode O C
last
, [[CmmBlock]] -> [CmmBlock]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [CmmBlock]
blk | (BlockId
_,BlockId
_,StackMap
_,[CmmBlock]
blk) <- [(BlockId, BlockId, StackMap, [CmmBlock])]
pps ]
, [(KeyOf LabelMap, StackMap)] -> LabelMap StackMap
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (KeyOf LabelMap
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 <- KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
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
-> StackLoc
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags StackLoc
sp0 BlockId
l StackMap
stack2 CmmTickScope
tscp [CmmNode O O]
assigs
(BlockId, BlockId, StackMap, [CmmBlock])
-> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
tmp_lbl, StackMap
stack2, [CmmBlock]
block)
| ElemOf ProcPointSet
BlockId
l ElemOf ProcPointSet -> ProcPointSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints
= do
let cont_args :: StackLoc
cont_args = StackLoc -> KeyOf LabelMap -> LabelMap StackLoc -> StackLoc
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault StackLoc
0 KeyOf LabelMap
BlockId
l LabelMap StackLoc
cont_info
(StackMap
stack2, [CmmNode O O]
assigs) =
DynFlags
-> BlockId
-> BlockEntryLiveness LocalReg
-> StackLoc
-> StackLoc
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame DynFlags
dflags BlockId
l BlockEntryLiveness LocalReg
liveness (StackMap -> StackLoc
sm_ret_off StackMap
stack0)
StackLoc
cont_args StackMap
stack0
(BlockId
tmp_lbl, [CmmBlock]
block) <- DynFlags
-> StackLoc
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags StackLoc
sp0 BlockId
l StackMap
stack2 CmmTickScope
tscp [CmmNode O O]
assigs
(BlockId, BlockId, StackMap, [CmmBlock])
-> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
tmp_lbl, StackMap
stack2, [CmmBlock]
block)
| Bool
otherwise = (BlockId, BlockId, StackMap, [CmmBlock])
-> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, BlockId
l, StackMap
stack1, [])
where live :: CmmLocalLive
live = CmmLocalLive
-> KeyOf LabelMap -> BlockEntryLiveness LocalReg -> CmmLocalLive
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault (String -> CmmLocalLive
forall a. String -> a
panic String
"handleBranch") KeyOf LabelMap
BlockId
l BlockEntryLiveness LocalReg
liveness
stack1 :: StackMap
stack1 = StackMap
stack0 { sm_regs :: UniqFM (LocalReg, StackLoc)
sm_regs = ((LocalReg, StackLoc) -> Bool)
-> UniqFM (LocalReg, StackLoc) -> UniqFM (LocalReg, StackLoc)
forall elt. (elt -> Bool) -> UniqFM elt -> UniqFM elt
filterUFM (LocalReg, StackLoc) -> Bool
is_live (StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs StackMap
stack0) }
is_live :: (LocalReg, StackLoc) -> Bool
is_live (LocalReg
r,StackLoc
_) = LocalReg
r LocalReg -> CmmLocalLive -> Bool
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
-> StackLoc
-> BlockId
-> StackMap
-> CmmTickScope
-> [CmmNode O O]
-> UniqSM (BlockId, [CmmBlock])
makeFixupBlock DynFlags
dflags StackLoc
sp0 BlockId
l StackMap
stack CmmTickScope
tscope [CmmNode O O]
assigs
| [CmmNode O O] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CmmNode O O]
assigs Bool -> Bool -> Bool
&& StackLoc
sp0 StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
== StackMap -> StackLoc
sm_sp StackMap
stack = (BlockId, [CmmBlock]) -> UniqSM (BlockId, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
l, [])
| Bool
otherwise = do
BlockId
tmp_lbl <- UniqSM BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
let sp_off :: StackLoc
sp_off = StackLoc
sp0 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackMap -> StackLoc
sm_sp StackMap
stack
block :: CmmBlock
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)
( DynFlags
-> StackLoc -> StackLoc -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj DynFlags
dflags StackLoc
sp0 StackLoc
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)
(BlockId, [CmmBlock]) -> UniqSM (BlockId, [CmmBlock])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId
tmp_lbl, [CmmBlock
block])
spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff
spOffsetForCall :: StackLoc -> StackMap -> StackLoc -> StackLoc
spOffsetForCall StackLoc
current_sp StackMap
cont_stack StackLoc
args
= StackLoc
current_sp StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- (StackMap -> StackLoc
sm_sp StackMap
cont_stack StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackMap -> StackLoc
sm_args StackMap
cont_stack StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
args)
fixupStack :: StackMap -> StackMap -> [CmmNode O O]
fixupStack :: StackMap -> StackMap -> [CmmNode O O]
fixupStack StackMap
old_stack StackMap
new_stack = ((LocalReg, StackLoc) -> [CmmNode O O])
-> [(LocalReg, StackLoc)] -> [CmmNode O O]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LocalReg, StackLoc) -> [CmmNode O O]
move [(LocalReg, StackLoc)]
new_locs
where
old_map :: UniqFM (LocalReg, StackLoc)
old_map = StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs StackMap
old_stack
new_locs :: [(LocalReg, StackLoc)]
new_locs = StackMap -> [(LocalReg, StackLoc)]
stackSlotRegs StackMap
new_stack
move :: (LocalReg, StackLoc) -> [CmmNode O O]
move (LocalReg
r,StackLoc
n)
| Just (LocalReg
_,StackLoc
m) <- UniqFM (LocalReg, StackLoc)
-> LocalReg -> Maybe (LocalReg, StackLoc)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM (LocalReg, StackLoc)
old_map LocalReg
r, StackLoc
n StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
== StackLoc
m = []
| Bool
otherwise = [CmmExpr -> CmmExpr -> CmmNode O O
CmmStore (Area -> StackLoc -> CmmExpr
CmmStackSlot Area
Old StackLoc
n)
(CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
r))]
setupStackFrame
:: DynFlags
-> BlockId
-> LabelMap CmmLocalLive
-> ByteOff
-> ByteOff
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame :: DynFlags
-> BlockId
-> BlockEntryLiveness LocalReg
-> StackLoc
-> StackLoc
-> StackMap
-> (StackMap, [CmmNode O O])
setupStackFrame DynFlags
dflags BlockId
lbl BlockEntryLiveness LocalReg
liveness StackLoc
updfr_off StackLoc
ret_args StackMap
stack0
= (StackMap
cont_stack, [CmmNode O O]
assignments)
where
live :: CmmLocalLive
live = CmmLocalLive
-> KeyOf LabelMap -> BlockEntryLiveness LocalReg -> CmmLocalLive
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault CmmLocalLive
forall a. Set a
Set.empty KeyOf LabelMap
BlockId
lbl BlockEntryLiveness LocalReg
liveness
(StackMap
stack1, [CmmNode O O]
assignments) = DynFlags
-> StackLoc
-> CmmLocalLive
-> StackMap
-> (StackMap, [CmmNode O O])
allocate DynFlags
dflags StackLoc
updfr_off CmmLocalLive
live StackMap
stack0
cont_stack :: StackMap
cont_stack = StackMap
stack1{ sm_sp :: StackLoc
sm_sp = StackMap -> StackLoc
sm_sp StackMap
stack1 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
ret_args
, sm_args :: StackLoc
sm_args = StackLoc
ret_args
, sm_ret_off :: StackLoc
sm_ret_off = StackLoc
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)
-> Block CmmNode O O
-> IndexedCO O (Maybe BlockId) (Maybe BlockId)
-> IndexedCO O (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 forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Maybe BlockId -> Maybe BlockId
f Block CmmNode O O
middle IndexedCO O (Maybe BlockId) (Maybe BlockId)
forall a. Maybe a
Nothing
where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
f (CmmStore (CmmStackSlot (Young BlockId
l) StackLoc
_) (CmmLit (CmmBlock BlockId
_))) Maybe BlockId
_
= BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
l
f CmmNode a b
_ Maybe BlockId
r = Maybe BlockId
r
allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
-> (StackMap, [CmmNode O O])
allocate :: DynFlags
-> StackLoc
-> CmmLocalLive
-> StackMap
-> (StackMap, [CmmNode O O])
allocate DynFlags
dflags StackLoc
ret_off CmmLocalLive
live stackmap :: StackMap
stackmap@StackMap{ sm_sp :: StackMap -> StackLoc
sm_sp = StackLoc
sp0
, sm_regs :: StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs = UniqFM (LocalReg, StackLoc)
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, StackLoc) -> Bool
forall key elt. Uniquable key => key -> UniqFM elt -> Bool
`elemUFM` UniqFM (LocalReg, StackLoc)
regs0)) (CmmLocalLive -> [LocalReg]
forall a. Set a -> [a]
Set.elems CmmLocalLive
live)
regs1 :: UniqFM (LocalReg, StackLoc)
regs1 = ((LocalReg, StackLoc) -> Bool)
-> UniqFM (LocalReg, StackLoc) -> UniqFM (LocalReg, StackLoc)
forall elt. (elt -> Bool) -> UniqFM elt -> UniqFM elt
filterUFM (\(LocalReg
r,StackLoc
_) -> LocalReg -> CmmLocalLive -> Bool
forall r. Ord r => r -> RegSet r -> Bool
elemRegSet LocalReg
r CmmLocalLive
live) UniqFM (LocalReg, StackLoc)
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 StackLoc StackSlot -> [StackSlot]
forall i e. Array i e -> [e]
Array.elems (Array StackLoc StackSlot -> [StackSlot])
-> Array StackLoc StackSlot -> [StackSlot]
forall a b. (a -> b) -> a -> b
$
(StackSlot -> StackSlot -> StackSlot)
-> StackSlot
-> (StackLoc, StackLoc)
-> [(StackLoc, StackSlot)]
-> Array StackLoc 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 (StackLoc
1, DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags (StackLoc -> StackLoc -> StackLoc
forall a. Ord a => a -> a -> a
max StackLoc
sp0 StackLoc
ret_off)) ([(StackLoc, StackSlot)] -> Array StackLoc StackSlot)
-> [(StackLoc, StackSlot)] -> Array StackLoc StackSlot
forall a b. (a -> b) -> a -> b
$
[(StackLoc, StackSlot)]
ret_words [(StackLoc, StackSlot)]
-> [(StackLoc, StackSlot)] -> [(StackLoc, StackSlot)]
forall a. [a] -> [a] -> [a]
++ [(StackLoc, StackSlot)]
live_words
where ret_words :: [(StackLoc, StackSlot)]
ret_words =
[ (StackLoc
x, StackSlot
Occupied)
| StackLoc
x <- [ StackLoc
1 .. DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags StackLoc
ret_off] ]
live_words :: [(StackLoc, StackSlot)]
live_words =
[ (DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags StackLoc
x, StackSlot
Occupied)
| (LocalReg
r,StackLoc
off) <- UniqFM (LocalReg, StackLoc) -> [(LocalReg, StackLoc)]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM UniqFM (LocalReg, StackLoc)
regs1,
let w :: StackLoc
w = DynFlags -> LocalReg -> StackLoc
localRegBytes DynFlags
dflags LocalReg
r,
StackLoc
x <- [ StackLoc
off, StackLoc
off StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags .. StackLoc
off StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
w StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
1] ]
in
let
save :: StackSlot
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
[(LocalReg, (LocalReg, StackLoc))])
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
[(LocalReg, (LocalReg, StackLoc))])
save StackSlot
slot ([], [StackSlot]
stack, StackLoc
n, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, StackLoc))]
regs)
= ([], StackSlot
slotStackSlot -> [StackSlot] -> [StackSlot]
forall a. a -> [a] -> [a]
:[StackSlot]
stack, DynFlags -> StackLoc -> StackLoc -> StackLoc
plusW DynFlags
dflags StackLoc
n StackLoc
1, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, StackLoc))]
regs)
save StackSlot
slot ([LocalReg]
to_save, [StackSlot]
stack, StackLoc
n, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, StackLoc))]
regs)
= case StackSlot
slot of
StackSlot
Occupied -> ([LocalReg]
to_save, StackSlot
OccupiedStackSlot -> [StackSlot] -> [StackSlot]
forall a. a -> [a] -> [a]
:[StackSlot]
stack, DynFlags -> StackLoc -> StackLoc -> StackLoc
plusW DynFlags
dflags StackLoc
n StackLoc
1, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, StackLoc))]
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 -> CmmNode O O
CmmStore (Area -> StackLoc -> CmmExpr
CmmStackSlot Area
Old StackLoc
n')
(CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
r))
n' :: StackLoc
n' = DynFlags -> StackLoc -> StackLoc -> StackLoc
plusW DynFlags
dflags StackLoc
n StackLoc
1
in
([LocalReg]
to_save', [StackSlot]
stack', StackLoc
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,StackLoc
n'))(LocalReg, (LocalReg, StackLoc))
-> [(LocalReg, (LocalReg, StackLoc))]
-> [(LocalReg, (LocalReg, StackLoc))]
forall a. a -> [a] -> [a]
:[(LocalReg, (LocalReg, StackLoc))]
regs)
| Bool
otherwise
-> ([LocalReg]
to_save, StackSlot
slotStackSlot -> [StackSlot] -> [StackSlot]
forall a. a -> [a] -> [a]
:[StackSlot]
stack, DynFlags -> StackLoc -> StackLoc -> StackLoc
plusW DynFlags
dflags StackLoc
n StackLoc
1, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, StackLoc))]
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 <- StackLoc -> [StackSlot] -> Maybe [StackSlot]
dropEmpty StackLoc
words [StackSlot]
stack
= ([StackSlot], LocalReg, [LocalReg])
-> Maybe ([StackSlot], LocalReg, [LocalReg])
forall a. a -> Maybe a
Just (StackLoc -> StackSlot -> [StackSlot]
forall a. StackLoc -> a -> [a]
replicate StackLoc
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 :: StackLoc
words = DynFlags -> LocalReg -> StackLoc
localRegWords DynFlags
dflags LocalReg
r
([LocalReg]
still_to_save, [StackSlot]
save_stack, StackLoc
n, [CmmNode O O]
save_assigs, [(LocalReg, (LocalReg, StackLoc))]
save_regs)
= (StackSlot
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
[(LocalReg, (LocalReg, StackLoc))])
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
[(LocalReg, (LocalReg, StackLoc))]))
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
[(LocalReg, (LocalReg, StackLoc))])
-> [StackSlot]
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
[(LocalReg, (LocalReg, StackLoc))])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr StackSlot
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
[(LocalReg, (LocalReg, StackLoc))])
-> ([LocalReg], [StackSlot], StackLoc, [CmmNode O O],
[(LocalReg, (LocalReg, StackLoc))])
save ([LocalReg]
to_save, [], StackLoc
0, [], []) [StackSlot]
stack
(StackLoc
push_sp, [CmmNode O O]
push_assigs, [(LocalReg, (LocalReg, StackLoc))]
push_regs)
= (LocalReg
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))]))
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
-> [LocalReg]
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LocalReg
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
push (StackLoc
n, [], []) [LocalReg]
still_to_save
where
push :: LocalReg
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
-> (StackLoc, [CmmNode O O], [(LocalReg, (LocalReg, StackLoc))])
push LocalReg
r (StackLoc
n, [CmmNode O O]
assigs, [(LocalReg, (LocalReg, StackLoc))]
regs)
= (StackLoc
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,StackLoc
n')) (LocalReg, (LocalReg, StackLoc))
-> [(LocalReg, (LocalReg, StackLoc))]
-> [(LocalReg, (LocalReg, StackLoc))]
forall a. a -> [a] -> [a]
: [(LocalReg, (LocalReg, StackLoc))]
regs)
where
n' :: StackLoc
n' = StackLoc
n StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ DynFlags -> LocalReg -> StackLoc
localRegBytes DynFlags
dflags LocalReg
r
assig :: CmmNode O O
assig = CmmExpr -> CmmExpr -> CmmNode O O
CmmStore (Area -> StackLoc -> CmmExpr
CmmStackSlot Area
Old StackLoc
n')
(CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
r))
trim_sp :: StackLoc
trim_sp
| Bool -> Bool
not ([(LocalReg, (LocalReg, StackLoc))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LocalReg, (LocalReg, StackLoc))]
push_regs) = StackLoc
push_sp
| Bool
otherwise
= DynFlags -> StackLoc -> StackLoc -> StackLoc
plusW DynFlags
dflags StackLoc
n (- [StackSlot] -> StackLoc
forall (t :: * -> *) a. Foldable t => t a -> StackLoc
length ((StackSlot -> Bool) -> [StackSlot] -> [StackSlot]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile StackSlot -> Bool
isEmpty [StackSlot]
save_stack))
final_regs :: UniqFM (LocalReg, StackLoc)
final_regs = UniqFM (LocalReg, StackLoc)
regs1 UniqFM (LocalReg, StackLoc)
-> [(LocalReg, (LocalReg, StackLoc))]
-> UniqFM (LocalReg, StackLoc)
forall key elt.
Uniquable key =>
UniqFM elt -> [(key, elt)] -> UniqFM elt
`addListToUFM` [(LocalReg, (LocalReg, StackLoc))]
push_regs
UniqFM (LocalReg, StackLoc)
-> [(LocalReg, (LocalReg, StackLoc))]
-> UniqFM (LocalReg, StackLoc)
forall key elt.
Uniquable key =>
UniqFM elt -> [(key, elt)] -> UniqFM elt
`addListToUFM` [(LocalReg, (LocalReg, StackLoc))]
save_regs
in
if ( StackLoc
n StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
/= StackLoc -> StackLoc -> StackLoc
forall a. Ord a => a -> a -> a
max StackLoc
sp0 StackLoc
ret_off ) then String -> SDoc -> (StackMap, [CmmNode O O])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocate" (StackLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr StackLoc
n SDoc -> SDoc -> SDoc
<+> StackLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr StackLoc
sp0 SDoc -> SDoc -> SDoc
<+> StackLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr StackLoc
ret_off) else
if (StackLoc
trim_sp StackLoc -> StackLoc -> StackLoc
forall a. Bits a => a -> a -> a
.&. (DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
1)) StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
/= StackLoc
0 then String -> SDoc -> (StackMap, [CmmNode O O])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"allocate2" (StackLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr StackLoc
trim_sp SDoc -> SDoc -> SDoc
<+> UniqFM (LocalReg, StackLoc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqFM (LocalReg, StackLoc)
final_regs SDoc -> SDoc -> SDoc
<+> StackLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr StackLoc
push_sp) else
( StackMap
stackmap { sm_regs :: UniqFM (LocalReg, StackLoc)
sm_regs = UniqFM (LocalReg, StackLoc)
final_regs , sm_sp :: StackLoc
sm_sp = StackLoc
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
:: DynFlags
-> LabelMap StackMap
-> StackMap
-> ByteOff
-> ByteOff
-> CmmNode C O
-> [CmmNode O O]
-> ByteOff
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp :: DynFlags
-> LabelMap StackMap
-> StackMap
-> StackLoc
-> StackLoc
-> CmmNode C O
-> [CmmNode O O]
-> StackLoc
-> CmmNode O C
-> [CmmBlock]
-> [CmmBlock]
manifestSp DynFlags
dflags LabelMap StackMap
stackmaps StackMap
stack0 StackLoc
sp0 StackLoc
sp_high
CmmNode C O
first [CmmNode O O]
middle_pre StackLoc
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 -> StackLoc
area_off = LabelMap StackMap -> Area -> StackLoc
getAreaOff LabelMap StackMap
stackmaps
adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
adj_pre_sp :: 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 (DynFlags
-> StackLoc -> StackLoc -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
areaToSp DynFlags
dflags StackLoc
sp0 StackLoc
sp_high Area -> StackLoc
area_off)
adj_post_sp :: 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 (DynFlags
-> StackLoc -> StackLoc -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
areaToSp DynFlags
dflags (StackLoc
sp0 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
sp_off) StackLoc
sp_high Area -> StackLoc
area_off)
final_middle :: Block CmmNode O O
final_middle = DynFlags
-> StackLoc -> StackLoc -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj DynFlags
dflags StackLoc
sp0 StackLoc
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 -> StackLoc)
-> [CmmNode O O]
-> [CmmNode O O]
elimStackStores StackMap
stack0 LabelMap StackMap
stackmaps Area -> StackLoc
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 -> StackLoc
getAreaOff LabelMap StackMap
_ Area
Old = StackLoc
0
getAreaOff LabelMap StackMap
stackmaps (Young BlockId
l) =
case KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
l LabelMap StackMap
stackmaps of
Just StackMap
sm -> StackMap -> StackLoc
sm_sp StackMap
sm StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackMap -> StackLoc
sm_args StackMap
sm
Maybe StackMap
Nothing -> String -> SDoc -> StackLoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getAreaOff" (BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
l)
maybeAddSpAdj
:: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj :: DynFlags
-> StackLoc -> StackLoc -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj DynFlags
dflags StackLoc
sp0 StackLoc
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
adj :: Block CmmNode O O -> Block CmmNode O O
adj Block CmmNode O O
block
| StackLoc
sp_off StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
/= StackLoc
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 CmmReg
spReg (DynFlags -> CmmExpr -> StackLoc -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
spExpr StackLoc
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 -> StackLoc
debugLevel DynFlags
dflags StackLoc -> StackLoc -> Bool
forall a. Ord a => a -> a -> Bool
> StackLoc
0
= [(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 -> StackLoc -> CmmExpr
CmmRegOff CmmReg
spReg (StackLoc
sp0 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags)
add_adj_unwind :: Block CmmNode O O -> Block CmmNode O O
add_adj_unwind Block CmmNode O O
block
| DynFlags -> StackLoc
debugLevel DynFlags
dflags StackLoc -> StackLoc -> Bool
forall a. Ord a => a -> a -> Bool
> StackLoc
0
, StackLoc
sp_off StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
/= StackLoc
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 -> StackLoc -> CmmExpr
CmmRegOff CmmReg
spReg (StackLoc
sp0 StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
sp_off)
areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
areaToSp :: DynFlags
-> StackLoc -> StackLoc -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
areaToSp DynFlags
dflags StackLoc
sp_old StackLoc
_sp_hwm Area -> StackLoc
area_off (CmmStackSlot Area
area StackLoc
n)
= DynFlags -> CmmExpr -> StackLoc -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
spExpr (StackLoc
sp_old StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- Area -> StackLoc
area_off Area
area StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
n)
areaToSp DynFlags
dflags StackLoc
_ StackLoc
sp_hwm Area -> StackLoc
_ (CmmLit CmmLit
CmmHighStackMark)
= DynFlags -> StackLoc -> CmmExpr
mkIntExpr DynFlags
dflags StackLoc
sp_hwm
areaToSp DynFlags
dflags StackLoc
_ StackLoc
_ Area -> StackLoc
_ (CmmMachOp (MO_U_Lt Width
_) [CmmExpr]
args)
| [CmmExpr] -> Bool
falseStackCheck [CmmExpr]
args
= DynFlags -> CmmExpr
zeroExpr DynFlags
dflags
areaToSp DynFlags
dflags StackLoc
_ StackLoc
_ Area -> StackLoc
_ (CmmMachOp (MO_U_Ge Width
_) [CmmExpr]
args)
| [CmmExpr] -> Bool
falseStackCheck [CmmExpr]
args
= DynFlags -> StackLoc -> CmmExpr
mkIntExpr DynFlags
dflags StackLoc
1
areaToSp DynFlags
_ StackLoc
_ StackLoc
_ Area -> StackLoc
_ CmmExpr
other = CmmExpr
other
falseStackCheck :: [CmmExpr] -> Bool
falseStackCheck :: [CmmExpr] -> Bool
falseStackCheck [ CmmMachOp (MO_Sub Width
_)
[ CmmRegOff (CmmGlobal GlobalReg
Sp) StackLoc
x_off
, CmmLit (CmmInt Integer
y_lit Width
_)]
, CmmReg (CmmGlobal GlobalReg
SpLim)]
= StackLoc -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral StackLoc
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 -> StackLoc)
-> [CmmNode O O]
-> [CmmNode O O]
elimStackStores StackMap
stackmap LabelMap StackMap
stackmaps Area -> StackLoc
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 StackLoc
m) (CmmReg (CmmLocal LocalReg
r))
| Just (LocalReg
_,StackLoc
off) <- UniqFM (LocalReg, StackLoc)
-> LocalReg -> Maybe (LocalReg, StackLoc)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM (StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs StackMap
stackmap) LocalReg
r
, Area -> StackLoc
area_off Area
area StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
m StackLoc -> StackLoc -> Bool
forall a. Eq a => a -> a -> Bool
== StackLoc
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 :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl
setInfoTableStackMap DynFlags
dflags 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)
= CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
top_info{ info_tbls :: LabelMap CmmInfoTable
info_tbls = (KeyOf LabelMap -> CmmInfoTable -> CmmInfoTable)
-> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
forall (map :: * -> *) a b.
IsMap map =>
(KeyOf map -> a -> b) -> map a -> map b
mapMapWithKey KeyOf LabelMap -> CmmInfoTable -> CmmInfoTable
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 KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
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
<+> LabelMap CmmInfoTable -> SDoc
forall a. Outputable a => a -> SDoc
ppr LabelMap CmmInfoTable
info_tbls)
Just StackMap
sm -> DynFlags -> StackMap -> Liveness
stackMapToLiveness DynFlags
dflags StackMap
sm
setInfoTableStackMap DynFlags
_ LabelMap StackMap
_ CmmDecl
d = CmmDecl
d
stackMapToLiveness :: DynFlags -> StackMap -> Liveness
stackMapToLiveness :: DynFlags -> StackMap -> Liveness
stackMapToLiveness DynFlags
dflags StackMap{StackLoc
UniqFM (LocalReg, StackLoc)
sm_regs :: UniqFM (LocalReg, StackLoc)
sm_ret_off :: StackLoc
sm_args :: StackLoc
sm_sp :: StackLoc
sm_regs :: StackMap -> UniqFM (LocalReg, StackLoc)
sm_ret_off :: StackMap -> StackLoc
sm_args :: StackMap -> StackLoc
sm_sp :: StackMap -> StackLoc
..} =
Liveness -> Liveness
forall a. [a] -> [a]
reverse (Liveness -> Liveness) -> Liveness -> Liveness
forall a b. (a -> b) -> a -> b
$ Array StackLoc Bool -> Liveness
forall i e. Array i e -> [e]
Array.elems (Array StackLoc Bool -> Liveness)
-> Array StackLoc Bool -> Liveness
forall a b. (a -> b) -> a -> b
$
(Bool -> Bool -> Bool)
-> Bool
-> (StackLoc, StackLoc)
-> [(StackLoc, Bool)]
-> Array StackLoc 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 (DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags StackLoc
sm_ret_off StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
1,
DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags (StackLoc
sm_sp StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
sm_args)) [(StackLoc, Bool)]
live_words
where
live_words :: [(StackLoc, Bool)]
live_words = [ (DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags StackLoc
off, Bool
False)
| (LocalReg
r,StackLoc
off) <- UniqFM (LocalReg, StackLoc) -> [(LocalReg, StackLoc)]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM UniqFM (LocalReg, StackLoc)
sm_regs
, CmmType -> Bool
isGcPtrType (LocalReg -> CmmType
localRegType LocalReg
r) ]
insertReloadsAsNeeded
:: DynFlags
-> ProcPointSet
-> LabelMap StackMap
-> BlockId
-> [CmmBlock]
-> UniqSM [CmmBlock]
insertReloadsAsNeeded :: DynFlags
-> ProcPointSet
-> LabelMap StackMap
-> BlockId
-> [CmmBlock]
-> UniqSM [CmmBlock]
insertReloadsAsNeeded DynFlags
dflags ProcPointSet
procpoints LabelMap StackMap
final_stackmaps BlockId
entry [CmmBlock]
blocks = do
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])
-> UniqSM (CmmGraph, BlockEntryLiveness LocalReg)
-> UniqSM [CmmBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
DataflowLattice CmmLocalLive
-> RewriteFun CmmLocalLive
-> CmmGraph
-> BlockEntryLiveness LocalReg
-> UniqSM (CmmGraph, BlockEntryLiveness LocalReg)
forall f.
DataflowLattice f
-> RewriteFun f
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmmBwd DataflowLattice CmmLocalLive
forall r. Ord r => DataflowLattice (CmmLive r)
liveLattice RewriteFun CmmLocalLive
rewriteCC (BlockId -> [CmmBlock] -> CmmGraph
ofBlockList BlockId
entry [CmmBlock]
blocks) BlockEntryLiveness LocalReg
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 = CmmNode C O -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmNode C O
e_node
stackmap :: StackMap
stackmap = case KeyOf LabelMap -> LabelMap StackMap -> Maybe StackMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
entry_label LabelMap StackMap
final_stackmaps of
Just StackMap
sm -> StackMap
sm
Maybe StackMap
Nothing -> String -> StackMap
forall a. String -> a
panic String
"insertReloadsAsNeeded: rewriteCC: stackmap"
joined :: CmmLocalLive
joined = DynFlags -> CmmNode O C -> CmmLocalLive -> CmmLocalLive
forall r n.
(DefinerOfRegs r n, UserOfRegs r n) =>
DynFlags -> n -> CmmLive r -> CmmLive r
gen_kill DynFlags
dflags 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 f. (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
foldNodesBwdOO (DynFlags -> CmmNode O O -> CmmLocalLive -> CmmLocalLive
forall r n.
(DefinerOfRegs r n, UserOfRegs r n) =>
DynFlags -> n -> CmmLive r -> CmmLive r
gen_kill DynFlags
dflags) Block CmmNode O O
middle0 CmmLocalLive
joined
(Block CmmNode O O
middle1, CmmLocalLive
live_with_reloads)
| ElemOf ProcPointSet
BlockId
entry_label ElemOf ProcPointSet -> ProcPointSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` ProcPointSet
procpoints
= let reloads :: [CmmNode O O]
reloads = DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads DynFlags
dflags 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 (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 = KeyOf LabelMap -> CmmLocalLive -> BlockEntryLiveness LocalReg
forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton KeyOf LabelMap
BlockId
entry_label CmmLocalLive
live_with_reloads
(CmmBlock, BlockEntryLiveness LocalReg)
-> UniqSM (CmmBlock, BlockEntryLiveness LocalReg)
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 :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]
insertReloads DynFlags
dflags StackMap
stackmap CmmLocalLive
live =
[ CmmReg -> CmmExpr -> CmmNode O O
CmmAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg)
(CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> StackLoc -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
spExpr (StackLoc
sp_off StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
- StackLoc
reg_off))
(LocalReg -> CmmType
localRegType LocalReg
reg))
| (LocalReg
reg, StackLoc
reg_off) <- StackMap -> [(LocalReg, StackLoc)]
stackSlotRegs StackMap
stackmap
, LocalReg
reg LocalReg -> CmmLocalLive -> Bool
forall r. Ord r => r -> RegSet r -> Bool
`elemRegSet` CmmLocalLive
live
]
where
sp_off :: StackLoc
sp_off = StackMap -> StackLoc
sm_sp StackMap
stackmap
lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
lowerSafeForeignCall DynFlags
dflags CmmBlock
block
| (entry :: CmmNode C O
entry@(CmmEntry BlockId
_ CmmTickScope
tscp), Block CmmNode O O
middle, CmmForeignCall { Bool
StackLoc
[LocalReg]
[CmmExpr]
BlockId
ForeignTarget
intrbl :: Bool
ret_off :: StackLoc
ret_args :: StackLoc
succ :: BlockId
args :: [CmmExpr]
res :: [LocalReg]
tgt :: ForeignTarget
intrbl :: CmmNode O C -> Bool
ret_off :: CmmNode O C -> StackLoc
ret_args :: CmmNode O C -> StackLoc
succ :: CmmNode O C -> BlockId
args :: CmmNode O C -> [CmmExpr]
res :: CmmNode O C -> [LocalReg]
tgt :: CmmNode O C -> ForeignTarget
.. }) <- 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
LocalReg
id <- CmmType -> UniqSM LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
dflags)
LocalReg
new_base <- CmmType -> UniqSM LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
baseReg)
let (CmmAGraph
caller_save, CmmAGraph
caller_load) = DynFlags -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs DynFlags
dflags
CmmAGraph
save_state_code <- DynFlags -> UniqSM CmmAGraph
forall (m :: * -> *). MonadUnique m => DynFlags -> m CmmAGraph
saveThreadState DynFlags
dflags
CmmAGraph
load_state_code <- DynFlags -> UniqSM CmmAGraph
forall (m :: * -> *). MonadUnique m => DynFlags -> m CmmAGraph
loadThreadState DynFlags
dflags
let suspend :: CmmAGraph
suspend = CmmAGraph
save_state_code CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmAGraph
caller_save CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmNode O O -> CmmAGraph
mkMiddle (DynFlags -> LocalReg -> Bool -> CmmNode O O
callSuspendThread DynFlags
dflags 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
(StackLoc
_, [GlobalReg]
regs, CmmAGraph
copyout) =
DynFlags
-> Convention
-> Transfer
-> Area
-> [CmmExpr]
-> StackLoc
-> [CmmExpr]
-> (StackLoc, [GlobalReg], CmmAGraph)
copyOutOflow DynFlags
dflags Convention
NativeReturn Transfer
Jump (BlockId -> Area
Young BlockId
succ)
((LocalReg -> CmmExpr) -> [LocalReg] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> (LocalReg -> CmmReg) -> LocalReg -> CmmExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) [LocalReg]
res)
StackLoc
ret_off []
jump :: CmmNode O C
jump = CmmCall :: CmmExpr
-> Maybe BlockId
-> [GlobalReg]
-> StackLoc
-> StackLoc
-> StackLoc
-> CmmNode O C
CmmCall { cml_target :: CmmExpr
cml_target = DynFlags -> CmmExpr -> CmmExpr
entryCode DynFlags
dflags (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
forall a b. (a -> b) -> a -> b
$
CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
spExpr (DynFlags -> CmmType
bWord DynFlags
dflags)
, cml_cont :: Maybe BlockId
cml_cont = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
succ
, cml_args_regs :: [GlobalReg]
cml_args_regs = [GlobalReg]
regs
, cml_args :: StackLoc
cml_args = Width -> StackLoc
widthInBytes (DynFlags -> Width
wordWidth DynFlags
dflags)
, cml_ret_args :: StackLoc
cml_ret_args = StackLoc
ret_args
, cml_ret_off :: StackLoc
cml_ret_off = StackLoc
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) = 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 -> UniqSM CmmBlock
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 -> UniqSM CmmBlock
forall a. String -> a
panic String
"lowerSafeForeignCall0"
| Bool
otherwise = CmmBlock -> UniqSM CmmBlock
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 StackLoc -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
name Maybe StackLoc
forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInExternalPackage FunctionOrData
IsFunction))
callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
callSuspendThread DynFlags
dflags 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, DynFlags -> StackLoc -> CmmExpr
mkIntExpr DynFlags
dflags (Bool -> StackLoc
forall a. Enum a => a -> StackLoc
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 :: DynFlags -> ByteOff -> WordOff -> ByteOff
plusW :: DynFlags -> StackLoc -> StackLoc -> StackLoc
plusW DynFlags
dflags StackLoc
b StackLoc
w = StackLoc
b StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
+ StackLoc
w StackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
* DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags
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 :: StackLoc -> [StackSlot] -> Maybe [StackSlot]
dropEmpty StackLoc
0 [StackSlot]
ss = [StackSlot] -> Maybe [StackSlot]
forall a. a -> Maybe a
Just [StackSlot]
ss
dropEmpty StackLoc
n (StackSlot
Empty : [StackSlot]
ss) = StackLoc -> [StackSlot] -> Maybe [StackSlot]
dropEmpty (StackLoc
nStackLoc -> StackLoc -> StackLoc
forall a. Num a => a -> a -> a
-StackLoc
1) [StackSlot]
ss
dropEmpty StackLoc
_ [StackSlot]
_ = Maybe [StackSlot]
forall a. Maybe a
Nothing
isEmpty :: StackSlot -> Bool
isEmpty :: StackSlot -> Bool
isEmpty StackSlot
Empty = Bool
True
isEmpty StackSlot
_ = Bool
False
localRegBytes :: DynFlags -> LocalReg -> ByteOff
localRegBytes :: DynFlags -> LocalReg -> StackLoc
localRegBytes DynFlags
dflags LocalReg
r
= DynFlags -> StackLoc -> StackLoc
roundUpToWords DynFlags
dflags (Width -> StackLoc
widthInBytes (CmmType -> Width
typeWidth (LocalReg -> CmmType
localRegType LocalReg
r)))
localRegWords :: DynFlags -> LocalReg -> WordOff
localRegWords :: DynFlags -> LocalReg -> StackLoc
localRegWords DynFlags
dflags = DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags (StackLoc -> StackLoc)
-> (LocalReg -> StackLoc) -> LocalReg -> StackLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> LocalReg -> StackLoc
localRegBytes DynFlags
dflags
toWords :: DynFlags -> ByteOff -> WordOff
toWords :: DynFlags -> StackLoc -> StackLoc
toWords DynFlags
dflags StackLoc
x = StackLoc
x StackLoc -> StackLoc -> StackLoc
forall a. Integral a => a -> a -> a
`quot` DynFlags -> StackLoc
wORD_SIZE DynFlags
dflags
stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
stackSlotRegs StackMap
sm = UniqFM (LocalReg, StackLoc) -> [(LocalReg, StackLoc)]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM (StackMap -> UniqFM (LocalReg, StackLoc)
sm_regs StackMap
sm)