{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GHC.Cmm.Sink (
cmmSink
) where
import GHC.Prelude
import GHC.Cmm
import GHC.Cmm.Opt
import GHC.Cmm.Liveness
import GHC.Cmm.LRegSet
import GHC.Cmm.Utils
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
import GHC.Platform.Regs
import GHC.Platform
import GHC.Types.Unique.FM
import qualified Data.IntSet as IntSet
import Data.List (partition)
import Data.Maybe
import GHC.Exts (inline)
type Assignment = (LocalReg, CmmExpr, AbsMem)
type Assignments = [Assignment]
cmmSink :: Platform -> CmmGraph -> CmmGraph
cmmSink :: Platform -> CmmGraph -> CmmGraph
cmmSink Platform
platform CmmGraph
graph = BlockId -> [CmmBlock] -> CmmGraph
ofBlockList (forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
graph) forall a b. (a -> b) -> a -> b
$ LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
sink forall (map :: * -> *) a. IsMap map => map a
mapEmpty forall a b. (a -> b) -> a -> b
$ [CmmBlock]
blocks
where
liveness :: BlockEntryLivenessL
liveness = Platform -> CmmGraph -> BlockEntryLivenessL
cmmLocalLivenessL Platform
platform CmmGraph
graph
getLive :: BlockId -> LRegSet
getLive BlockId
l = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault LRegSet
emptyLRegSet BlockId
l BlockEntryLivenessL
liveness
blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
revPostorder CmmGraph
graph
join_pts :: LabelMap Int
join_pts = [CmmBlock] -> LabelMap Int
findJoinPoints [CmmBlock]
blocks
sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
sink LabelMap Assignments
_ [] = []
sink LabelMap Assignments
sunk (CmmBlock
b:[CmmBlock]
bs) =
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 forall a. a -> [a] -> [a]
: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
sink LabelMap Assignments
sunk' [CmmBlock]
bs
where
lbl :: BlockId
lbl = forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
b
(CmmNode C O
first, 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
b
succs :: [BlockId]
succs = forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
last
live :: LRegSet
live = forall (f :: * -> *). Foldable f => f LRegSet -> LRegSet
IntSet.unions (forall a b. (a -> b) -> [a] -> [b]
map BlockId -> LRegSet
getLive [BlockId]
succs)
live_middle :: LRegSet
live_middle = forall n.
(DefinerOfRegs LocalReg n, UserOfRegs LocalReg n) =>
Platform -> n -> LRegSet -> LRegSet
gen_killL Platform
platform CmmNode O C
last LRegSet
live
ann_middles :: [(LRegSet, CmmNode O O)]
ann_middles = Platform -> LRegSet -> [CmmNode O O] -> [(LRegSet, CmmNode O O)]
annotate Platform
platform LRegSet
live_middle (forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
middle)
(Block CmmNode O O
middle', Assignments
assigs) = Platform
-> [(LRegSet, CmmNode O O)]
-> Assignments
-> (Block CmmNode O O, Assignments)
walk Platform
platform [(LRegSet, CmmNode O O)]
ann_middles (forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault [] BlockId
lbl LabelMap Assignments
sunk)
fold_last :: CmmNode O C
fold_last = forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> CmmNode e x
constantFoldNode Platform
platform CmmNode O C
last
(CmmNode O C
final_last, Assignments
assigs') = forall (x :: Extensibility).
Platform
-> LRegSet
-> CmmNode O x
-> Assignments
-> (CmmNode O x, Assignments)
tryToInline Platform
platform LRegSet
live CmmNode O C
fold_last Assignments
assigs
([BlockId]
joins, [BlockId]
nonjoins) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
`mapMember` LabelMap Int
join_pts) [BlockId]
succs
live_in_joins :: LRegSet
live_in_joins = forall (f :: * -> *). Foldable f => f LRegSet -> LRegSet
IntSet.unions (forall a b. (a -> b) -> [a] -> [b]
map BlockId -> LRegSet
getLive [BlockId]
joins)
init_live_sets :: [LRegSet]
init_live_sets = forall a b. (a -> b) -> [a] -> [b]
map BlockId -> LRegSet
getLive [BlockId]
nonjoins
live_in_multi :: [LRegSet] -> LocalReg -> Bool
live_in_multi [LRegSet]
live_sets LocalReg
r =
case forall a. (a -> Bool) -> [a] -> [a]
filter (LocalReg -> LRegSet -> Bool
elemLRegSet LocalReg
r) [LRegSet]
live_sets of
(LRegSet
_one:LRegSet
_two:[LRegSet]
_) -> Bool
True
[LRegSet]
_ -> Bool
False
([CmmNode O O]
dropped_last, Assignments
assigs'') = forall s.
Platform
-> (Assignment -> s -> (Bool, s))
-> s
-> Assignments
-> ([CmmNode O O], Assignments)
dropAssignments Platform
platform Assignment -> [LRegSet] -> (Bool, [LRegSet])
drop_if [LRegSet]
init_live_sets Assignments
assigs'
drop_if :: (LocalReg, CmmExpr, AbsMem)
-> [LRegSet] -> (Bool, [LRegSet])
drop_if :: Assignment -> [LRegSet] -> (Bool, [LRegSet])
drop_if a :: Assignment
a@(LocalReg
r,CmmExpr
rhs,AbsMem
_) [LRegSet]
live_sets = (Bool
should_drop, [LRegSet]
live_sets')
where
should_drop :: Bool
should_drop = forall (x :: Extensibility).
Platform -> Assignment -> CmmNode O x -> Bool
conflicts Platform
platform Assignment
a CmmNode O C
final_last
Bool -> Bool -> Bool
|| Bool -> Bool
not (Platform -> CmmExpr -> Bool
isTrivial Platform
platform CmmExpr
rhs) Bool -> Bool -> Bool
&& [LRegSet] -> LocalReg -> Bool
live_in_multi [LRegSet]
live_sets LocalReg
r
Bool -> Bool -> Bool
|| LocalReg
r LocalReg -> LRegSet -> Bool
`elemLRegSet` LRegSet
live_in_joins
live_sets' :: [LRegSet]
live_sets' | Bool
should_drop = [LRegSet]
live_sets
| Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map LRegSet -> LRegSet
upd [LRegSet]
live_sets
upd :: LRegSet -> LRegSet
upd LRegSet
set | LocalReg
r LocalReg -> LRegSet -> Bool
`elemLRegSet` LRegSet
set = LRegSet
set LRegSet -> LRegSet -> LRegSet
`IntSet.union` LRegSet
live_rhs
| Bool
otherwise = LRegSet
set
live_rhs :: LRegSet
live_rhs = forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform (forall a b c. (a -> b -> c) -> b -> a -> c
flip LocalReg -> LRegSet -> LRegSet
insertLRegSet) LRegSet
emptyLRegSet CmmExpr
rhs
final_middle :: Block CmmNode O O
final_middle = 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
middle' [CmmNode O O]
dropped_last
sunk' :: LabelMap Assignments
sunk' = forall (map :: * -> *) a. IsMap map => map a -> map a -> map a
mapUnion LabelMap Assignments
sunk forall a b. (a -> b) -> a -> b
$
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [ (BlockId
l, Platform -> LRegSet -> Assignments -> Assignments
filterAssignments Platform
platform (BlockId -> LRegSet
getLive BlockId
l) Assignments
assigs'')
| BlockId
l <- [BlockId]
succs ]
isTrivial :: Platform -> CmmExpr -> Bool
isTrivial :: Platform -> CmmExpr -> Bool
isTrivial Platform
_ (CmmReg (CmmLocal LocalReg
_)) = Bool
True
isTrivial Platform
platform (CmmReg (CmmGlobal GlobalReg
r)) =
if Arch -> Bool
isARM (Platform -> Arch
platformArch Platform
platform)
then Bool
True
else forall a. Maybe a -> Bool
isJust (Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform GlobalReg
r)
isTrivial Platform
_ (CmmLit CmmLit
_) = Bool
True
isTrivial Platform
_ CmmExpr
_ = Bool
False
annotate :: Platform -> LRegSet -> [CmmNode O O] -> [(LRegSet, CmmNode O O)]
annotate :: Platform -> LRegSet -> [CmmNode O O] -> [(LRegSet, CmmNode O O)]
annotate Platform
platform LRegSet
live [CmmNode O O]
nodes = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CmmNode O O
-> (LRegSet, [(LRegSet, CmmNode O O)])
-> (LRegSet, [(LRegSet, CmmNode O O)])
ann (LRegSet
live,[]) [CmmNode O O]
nodes
where ann :: CmmNode O O
-> (LRegSet, [(LRegSet, CmmNode O O)])
-> (LRegSet, [(LRegSet, CmmNode O O)])
ann CmmNode O O
n (LRegSet
live,[(LRegSet, CmmNode O O)]
nodes) = (forall n.
(DefinerOfRegs LocalReg n, UserOfRegs LocalReg n) =>
Platform -> n -> LRegSet -> LRegSet
gen_killL Platform
platform CmmNode O O
n LRegSet
live, (LRegSet
live,CmmNode O O
n) forall a. a -> [a] -> [a]
: [(LRegSet, CmmNode O O)]
nodes)
findJoinPoints :: [CmmBlock] -> LabelMap Int
findJoinPoints :: [CmmBlock] -> LabelMap Int
findJoinPoints [CmmBlock]
blocks = forall (map :: * -> *) a.
IsMap map =>
(a -> Bool) -> map a -> map a
mapFilter (forall a. Ord a => a -> a -> Bool
>Int
1) LabelMap Int
succ_counts
where
all_succs :: [BlockId]
all_succs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors [CmmBlock]
blocks
succ_counts :: LabelMap Int
succ_counts :: LabelMap Int
succ_counts = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\BlockId
l -> forall (map :: * -> *) a.
IsMap map =>
(a -> a -> a) -> KeyOf map -> a -> map a -> map a
mapInsertWith forall a. Num a => a -> a -> a
(+) BlockId
l Int
1) forall (map :: * -> *) a. IsMap map => map a
mapEmpty [BlockId]
all_succs
filterAssignments :: Platform -> LRegSet -> Assignments -> Assignments
filterAssignments :: Platform -> LRegSet -> Assignments -> Assignments
filterAssignments Platform
platform LRegSet
live Assignments
assigs = forall a. [a] -> [a]
reverse (Assignments -> Assignments -> Assignments
go Assignments
assigs [])
where go :: Assignments -> Assignments -> Assignments
go [] Assignments
kept = Assignments
kept
go (a :: Assignment
a@(LocalReg
r,CmmExpr
_,AbsMem
_):Assignments
as) Assignments
kept | Bool
needed = Assignments -> Assignments -> Assignments
go Assignments
as (Assignment
aforall a. a -> [a] -> [a]
:Assignments
kept)
| Bool
otherwise = Assignments -> Assignments -> Assignments
go Assignments
as Assignments
kept
where
needed :: Bool
needed = LocalReg
r LocalReg -> LRegSet -> Bool
`elemLRegSet` LRegSet
live
Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (x :: Extensibility).
Platform -> Assignment -> CmmNode O x -> Bool
conflicts Platform
platform Assignment
a) (forall a b. (a -> b) -> [a] -> [b]
map Assignment -> CmmNode O O
toNode Assignments
kept)
walk :: Platform
-> [(LRegSet, CmmNode O O)]
-> Assignments
-> ( Block CmmNode O O
, Assignments
)
walk :: Platform
-> [(LRegSet, CmmNode O O)]
-> Assignments
-> (Block CmmNode O O, Assignments)
walk Platform
platform [(LRegSet, CmmNode O O)]
nodes Assignments
assigs = [(LRegSet, CmmNode O O)]
-> Block CmmNode O O
-> Assignments
-> (Block CmmNode O O, Assignments)
go [(LRegSet, CmmNode O O)]
nodes forall (n :: Extensibility -> Extensibility -> *). Block n O O
emptyBlock Assignments
assigs
where
go :: [(LRegSet, CmmNode O O)]
-> Block CmmNode O O
-> Assignments
-> (Block CmmNode O O, Assignments)
go [] Block CmmNode O O
block Assignments
as = (Block CmmNode O O
block, Assignments
as)
go ((LRegSet
live,CmmNode O O
node):[(LRegSet, CmmNode O O)]
ns) Block CmmNode O O
block Assignments
as
| forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> LRegSet -> Bool
shouldDiscard CmmNode O O
node LRegSet
live = [(LRegSet, CmmNode O O)]
-> Block CmmNode O O
-> Assignments
-> (Block CmmNode O O, Assignments)
go [(LRegSet, CmmNode O O)]
ns Block CmmNode O O
block Assignments
as
| Just Assignment
a <- forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> Maybe Assignment
shouldSink Platform
platform CmmNode O O
node2 = [(LRegSet, CmmNode O O)]
-> Block CmmNode O O
-> Assignments
-> (Block CmmNode O O, Assignments)
go [(LRegSet, CmmNode O O)]
ns Block CmmNode O O
block (Assignment
a forall a. a -> [a] -> [a]
: Assignments
as1)
| Bool
otherwise = [(LRegSet, CmmNode O O)]
-> Block CmmNode O O
-> Assignments
-> (Block CmmNode O O, Assignments)
go [(LRegSet, CmmNode O O)]
ns Block CmmNode O O
block' Assignments
as'
where
node1 :: CmmNode O O
node1 = forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> CmmNode e x
constantFoldNode Platform
platform CmmNode O O
node
(CmmNode O O
node2, Assignments
as1) = forall (x :: Extensibility).
Platform
-> LRegSet
-> CmmNode O x
-> Assignments
-> (CmmNode O x, Assignments)
tryToInline Platform
platform LRegSet
live CmmNode O O
node1 Assignments
as
([CmmNode O O]
dropped, Assignments
as') = Platform
-> (Assignment -> Bool)
-> Assignments
-> ([CmmNode O O], Assignments)
dropAssignmentsSimple Platform
platform
(\Assignment
a -> forall (x :: Extensibility).
Platform -> Assignment -> CmmNode O x -> Bool
conflicts Platform
platform Assignment
a CmmNode O O
node2) Assignments
as1
block' :: Block CmmNode O O
block' = 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
block [CmmNode O O]
dropped forall (n :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
Block n e O -> n O O -> Block n e O
`blockSnoc` CmmNode O O
node2
shouldSink :: Platform -> CmmNode e x -> Maybe Assignment
shouldSink :: forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> Maybe Assignment
shouldSink Platform
platform (CmmAssign (CmmLocal LocalReg
r) CmmExpr
e) | Bool
no_local_regs = forall a. a -> Maybe a
Just (LocalReg
r, CmmExpr
e, Platform -> CmmExpr -> AbsMem
exprMem Platform
platform CmmExpr
e)
where no_local_regs :: Bool
no_local_regs = Bool
True
shouldSink Platform
_ CmmNode e x
_other = forall a. Maybe a
Nothing
shouldDiscard :: CmmNode e x -> LRegSet -> Bool
shouldDiscard :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> LRegSet -> Bool
shouldDiscard CmmNode e x
node LRegSet
live
= case CmmNode e x
node of
CmmAssign CmmReg
r (CmmReg CmmReg
r') | CmmReg
r forall a. Eq a => a -> a -> Bool
== CmmReg
r' -> Bool
True
CmmAssign (CmmLocal LocalReg
r) CmmExpr
_ -> Bool -> Bool
not (LocalReg
r LocalReg -> LRegSet -> Bool
`elemLRegSet` LRegSet
live)
CmmNode e x
_otherwise -> Bool
False
toNode :: Assignment -> CmmNode O O
toNode :: Assignment -> CmmNode O O
toNode (LocalReg
r,CmmExpr
rhs,AbsMem
_) = CmmReg -> CmmExpr -> CmmNode O O
CmmAssign (LocalReg -> CmmReg
CmmLocal LocalReg
r) CmmExpr
rhs
dropAssignmentsSimple :: Platform -> (Assignment -> Bool) -> Assignments
-> ([CmmNode O O], Assignments)
dropAssignmentsSimple :: Platform
-> (Assignment -> Bool)
-> Assignments
-> ([CmmNode O O], Assignments)
dropAssignmentsSimple Platform
platform Assignment -> Bool
f = forall s.
Platform
-> (Assignment -> s -> (Bool, s))
-> s
-> Assignments
-> ([CmmNode O O], Assignments)
dropAssignments Platform
platform (\Assignment
a ()
_ -> (Assignment -> Bool
f Assignment
a, ())) ()
dropAssignments :: Platform -> (Assignment -> s -> (Bool, s)) -> s -> Assignments
-> ([CmmNode O O], Assignments)
dropAssignments :: forall s.
Platform
-> (Assignment -> s -> (Bool, s))
-> s
-> Assignments
-> ([CmmNode O O], Assignments)
dropAssignments Platform
platform Assignment -> s -> (Bool, s)
should_drop s
state Assignments
assigs
= ([CmmNode O O]
dropped, forall a. [a] -> [a]
reverse Assignments
kept)
where
([CmmNode O O]
dropped,Assignments
kept) = s
-> Assignments
-> [CmmNode O O]
-> Assignments
-> ([CmmNode O O], Assignments)
go s
state Assignments
assigs [] []
go :: s
-> Assignments
-> [CmmNode O O]
-> Assignments
-> ([CmmNode O O], Assignments)
go s
_ [] [CmmNode O O]
dropped Assignments
kept = ([CmmNode O O]
dropped, Assignments
kept)
go s
state (Assignment
assig : Assignments
rest) [CmmNode O O]
dropped Assignments
kept
| Bool
conflict = s
-> Assignments
-> [CmmNode O O]
-> Assignments
-> ([CmmNode O O], Assignments)
go s
state' Assignments
rest (Assignment -> CmmNode O O
toNode Assignment
assig forall a. a -> [a] -> [a]
: [CmmNode O O]
dropped) Assignments
kept
| Bool
otherwise = s
-> Assignments
-> [CmmNode O O]
-> Assignments
-> ([CmmNode O O], Assignments)
go s
state' Assignments
rest [CmmNode O O]
dropped (Assignment
assigforall a. a -> [a] -> [a]
:Assignments
kept)
where
(Bool
dropit, s
state') = Assignment -> s -> (Bool, s)
should_drop Assignment
assig s
state
conflict :: Bool
conflict = Bool
dropit Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (x :: Extensibility).
Platform -> Assignment -> CmmNode O x -> Bool
conflicts Platform
platform Assignment
assig) [CmmNode O O]
dropped
tryToInline
:: forall x. Platform
-> LRegSet
-> CmmNode O x
-> Assignments
-> (
CmmNode O x
, Assignments
)
tryToInline :: forall (x :: Extensibility).
Platform
-> LRegSet
-> CmmNode O x
-> Assignments
-> (CmmNode O x, Assignments)
tryToInline Platform
platform LRegSet
liveAfter CmmNode O x
node Assignments
assigs =
UniqFM LocalReg Int
-> LRegSet
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM LocalReg Int
usages LRegSet
liveAfter CmmNode O x
node LRegSet
emptyLRegSet Assignments
assigs
where
usages :: UniqFM LocalReg Int
usages :: UniqFM LocalReg Int
usages = forall a b.
UserOfRegs LocalReg a =>
Platform -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed Platform
platform UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int
addUsage forall key elt. UniqFM key elt
emptyUFM CmmNode O x
node
go :: UniqFM LocalReg Int -> LRegSet -> CmmNode O x -> LRegSet -> Assignments
-> (CmmNode O x, Assignments)
go :: UniqFM LocalReg Int
-> LRegSet
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM LocalReg Int
_usages LRegSet
_live CmmNode O x
node LRegSet
_skipped [] = (CmmNode O x
node, [])
go UniqFM LocalReg Int
usages LRegSet
live CmmNode O x
node LRegSet
skipped (a :: Assignment
a@(LocalReg
l,CmmExpr
rhs,AbsMem
_) : Assignments
rest)
| Bool
cannot_inline = (CmmNode O x, Assignments)
dont_inline
| Bool
occurs_none = (CmmNode O x, Assignments)
discard
| Bool
occurs_once = (CmmNode O x, Assignments)
inline_and_discard
| Platform -> CmmExpr -> Bool
isTrivial Platform
platform CmmExpr
rhs = (CmmNode O x, Assignments)
inline_and_keep
| Bool
otherwise = (CmmNode O x, Assignments)
dont_inline
where
inline_and_discard :: (CmmNode O x, Assignments)
inline_and_discard = UniqFM LocalReg Int
-> LRegSet
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM LocalReg Int
usages' LRegSet
live CmmNode O x
inl_node LRegSet
skipped Assignments
rest
where usages' :: UniqFM LocalReg Int
usages' = forall a b.
UserOfRegs LocalReg a =>
Platform -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed Platform
platform UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int
addUsage UniqFM LocalReg Int
usages CmmExpr
rhs
discard :: (CmmNode O x, Assignments)
discard = UniqFM LocalReg Int
-> LRegSet
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM LocalReg Int
usages LRegSet
live CmmNode O x
node LRegSet
skipped Assignments
rest
dont_inline :: (CmmNode O x, Assignments)
dont_inline = CmmNode O x -> (CmmNode O x, Assignments)
keep CmmNode O x
node
inline_and_keep :: (CmmNode O x, Assignments)
inline_and_keep = CmmNode O x -> (CmmNode O x, Assignments)
keep CmmNode O x
inl_node
keep :: CmmNode O x -> (CmmNode O x, Assignments)
keep :: CmmNode O x -> (CmmNode O x, Assignments)
keep CmmNode O x
node' = (CmmNode O x
final_node, Assignment
a forall a. a -> [a] -> [a]
: Assignments
rest')
where (CmmNode O x
final_node, Assignments
rest') = UniqFM LocalReg Int
-> LRegSet
-> CmmNode O x
-> LRegSet
-> Assignments
-> (CmmNode O x, Assignments)
go UniqFM LocalReg Int
usages LRegSet
live' CmmNode O x
node' (LocalReg -> LRegSet -> LRegSet
insertLRegSet LocalReg
l LRegSet
skipped) Assignments
rest
live' :: LRegSet
live' = forall a. a -> a
inline forall a b.
UserOfRegs LocalReg a =>
Platform -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed Platform
platform (\LRegSet
m LocalReg
r -> LocalReg -> LRegSet -> LRegSet
insertLRegSet LocalReg
r LRegSet
m)
LRegSet
live CmmExpr
rhs
cannot_inline :: Bool
cannot_inline = LRegSet
skipped LRegSet -> CmmExpr -> Bool
`regsUsedIn` CmmExpr
rhs
Bool -> Bool -> Bool
|| LocalReg
l LocalReg -> LRegSet -> Bool
`elemLRegSet` LRegSet
skipped
Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmExpr -> CmmNode e x -> Bool
okToInline Platform
platform CmmExpr
rhs CmmNode O x
node)
l_usages :: Maybe Int
l_usages = forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM LocalReg Int
usages LocalReg
l
l_live :: Bool
l_live = LocalReg
l LocalReg -> LRegSet -> Bool
`elemLRegSet` LRegSet
live
occurs_once :: Bool
occurs_once = Bool -> Bool
not Bool
l_live Bool -> Bool -> Bool
&& Maybe Int
l_usages forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Int
1
occurs_none :: Bool
occurs_none = Bool -> Bool
not Bool
l_live Bool -> Bool -> Bool
&& Maybe Int
l_usages forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing
inl_node :: CmmNode O x
inl_node = forall (x :: Extensibility). CmmNode O x -> CmmNode O x
improveConditional (forall (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep CmmExpr -> CmmExpr
inl_exp CmmNode O x
node)
inl_exp :: CmmExpr -> CmmExpr
inl_exp :: CmmExpr -> CmmExpr
inl_exp (CmmReg (CmmLocal LocalReg
l')) | LocalReg
l forall a. Eq a => a -> a -> Bool
== LocalReg
l' = CmmExpr
rhs
inl_exp (CmmRegOff (CmmLocal LocalReg
l') Int
off) | LocalReg
l forall a. Eq a => a -> a -> Bool
== LocalReg
l'
= Platform -> CmmExpr -> Int -> CmmExpr
cmmOffset Platform
platform CmmExpr
rhs Int
off
inl_exp (CmmMachOp MachOp
op [CmmExpr]
args) = Platform -> MachOp -> [CmmExpr] -> CmmExpr
cmmMachOpFold Platform
platform MachOp
op [CmmExpr]
args
inl_exp CmmExpr
other = CmmExpr
other
improveConditional :: CmmNode O x -> CmmNode O x
improveConditional :: forall (x :: Extensibility). CmmNode O x -> CmmNode O x
improveConditional
(CmmCondBranch (CmmMachOp MachOp
mop [CmmExpr
x, CmmLit (CmmInt Integer
1 Width
_)]) BlockId
t BlockId
f Maybe Bool
l)
| MachOp -> Bool
neLike MachOp
mop, CmmExpr -> Bool
isComparisonExpr CmmExpr
x
= CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmNode O C
CmmCondBranch CmmExpr
x BlockId
f BlockId
t (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not Maybe Bool
l)
where
neLike :: MachOp -> Bool
neLike (MO_Ne Width
_) = Bool
True
neLike (MO_U_Lt Width
_) = Bool
True
neLike (MO_S_Lt Width
_) = Bool
True
neLike MachOp
_ = Bool
False
improveConditional CmmNode O x
other = CmmNode O x
other
addUsage :: UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int
addUsage :: UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int
addUsage UniqFM LocalReg Int
m LocalReg
r = forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C forall a. Num a => a -> a -> a
(+) UniqFM LocalReg Int
m LocalReg
r Int
1
regsUsedIn :: LRegSet -> CmmExpr -> Bool
regsUsedIn :: LRegSet -> CmmExpr -> Bool
regsUsedIn LRegSet
ls CmmExpr
_ | LRegSet -> Bool
nullLRegSet LRegSet
ls = Bool
False
regsUsedIn LRegSet
ls CmmExpr
e = LRegSet -> CmmExpr -> Bool -> Bool
go LRegSet
ls CmmExpr
e Bool
False
where use :: LRegSet -> CmmExpr -> Bool -> Bool
use :: LRegSet -> CmmExpr -> Bool -> Bool
use LRegSet
ls (CmmReg (CmmLocal LocalReg
l)) Bool
_ | LocalReg
l LocalReg -> LRegSet -> Bool
`elemLRegSet` LRegSet
ls = Bool
True
use LRegSet
ls (CmmRegOff (CmmLocal LocalReg
l) Int
_) Bool
_ | LocalReg
l LocalReg -> LRegSet -> Bool
`elemLRegSet` LRegSet
ls = Bool
True
use LRegSet
_ls CmmExpr
_ Bool
z = Bool
z
go :: LRegSet -> CmmExpr -> Bool -> Bool
go :: LRegSet -> CmmExpr -> Bool -> Bool
go LRegSet
ls (CmmMachOp MachOp
_ [CmmExpr]
es) Bool
z = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (LRegSet -> CmmExpr -> Bool -> Bool
go LRegSet
ls) Bool
z [CmmExpr]
es
go LRegSet
ls (CmmLoad CmmExpr
addr CmmType
_ AlignmentSpec
_) Bool
z = LRegSet -> CmmExpr -> Bool -> Bool
go LRegSet
ls CmmExpr
addr Bool
z
go LRegSet
ls CmmExpr
e Bool
z = LRegSet -> CmmExpr -> Bool -> Bool
use LRegSet
ls CmmExpr
e Bool
z
okToInline :: Platform -> CmmExpr -> CmmNode e x -> Bool
okToInline :: forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmExpr -> CmmNode e x -> Bool
okToInline Platform
platform CmmExpr
expr node :: CmmNode e x
node@(CmmUnsafeForeignCall{}) =
Bool -> Bool
not (forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict Platform
platform CmmExpr
expr CmmNode e x
node)
okToInline Platform
_ CmmExpr
_ CmmNode e x
_ = Bool
True
conflicts :: Platform -> Assignment -> CmmNode O x -> Bool
conflicts :: forall (x :: Extensibility).
Platform -> Assignment -> CmmNode O x -> Bool
conflicts Platform
platform (LocalReg
r, CmmExpr
rhs, AbsMem
addr) CmmNode O x
node
| forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict Platform
platform CmmExpr
rhs CmmNode O x
node = Bool
True
| forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmExpr -> CmmNode e x -> Bool
localRegistersConflict Platform
platform CmmExpr
rhs CmmNode O x
node = Bool
True
| forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform (\Bool
b LocalReg
r' -> LocalReg
r forall a. Eq a => a -> a -> Bool
== LocalReg
r' Bool -> Bool -> Bool
|| Bool
b) Bool
False CmmNode O x
node = Bool
True
| CmmStore CmmExpr
addr' CmmExpr
e AlignmentSpec
_ <- CmmNode O x
node
, AbsMem -> AbsMem -> Bool
memConflicts AbsMem
addr (Platform -> CmmExpr -> Width -> AbsMem
loadAddr Platform
platform CmmExpr
addr' (Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
e)) = Bool
True
| AbsMem
HeapMem <- AbsMem
addr, CmmAssign (CmmGlobal GlobalReg
Hp) CmmExpr
_ <- CmmNode O x
node = Bool
True
| AbsMem
StackMem <- AbsMem
addr, CmmAssign (CmmGlobal GlobalReg
Sp) CmmExpr
_ <- CmmNode O x
node = Bool
True
| SpMem{} <- AbsMem
addr, CmmAssign (CmmGlobal GlobalReg
Sp) CmmExpr
_ <- CmmNode O x
node = Bool
True
| CmmUnsafeForeignCall{} <- CmmNode O x
node, AbsMem -> AbsMem -> Bool
memConflicts AbsMem
addr AbsMem
AnyMem = Bool
True
| CmmCall{} <- CmmNode O x
node, AbsMem -> AbsMem -> Bool
memConflicts AbsMem
addr AbsMem
AnyMem = Bool
True
| Bool
otherwise = Bool
False
globalRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict :: forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict Platform
platform CmmExpr
expr CmmNode e x
node =
forall a. a -> a
inline forall r a b.
DefinerOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsDefd Platform
platform (\Bool
b GlobalReg
r -> Bool
b Bool -> Bool -> Bool
|| Platform -> CmmReg -> CmmExpr -> Bool
regUsedIn Platform
platform (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r) CmmExpr
expr)
Bool
False CmmNode e x
node
localRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool
localRegistersConflict :: forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmExpr -> CmmNode e x -> Bool
localRegistersConflict Platform
platform CmmExpr
expr CmmNode e x
node =
forall a. a -> a
inline forall r a b.
DefinerOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsDefd Platform
platform (\Bool
b LocalReg
r -> Bool
b Bool -> Bool -> Bool
|| Platform -> CmmReg -> CmmExpr -> Bool
regUsedIn Platform
platform (LocalReg -> CmmReg
CmmLocal LocalReg
r) CmmExpr
expr)
Bool
False CmmNode e x
node
data AbsMem
= NoMem
| AnyMem
| HeapMem
| StackMem
| SpMem
{-# UNPACK #-} !Int
{-# UNPACK #-} !Int
bothMems :: AbsMem -> AbsMem -> AbsMem
bothMems :: AbsMem -> AbsMem -> AbsMem
bothMems AbsMem
NoMem AbsMem
x = AbsMem
x
bothMems AbsMem
x AbsMem
NoMem = AbsMem
x
bothMems AbsMem
HeapMem AbsMem
HeapMem = AbsMem
HeapMem
bothMems AbsMem
StackMem AbsMem
StackMem = AbsMem
StackMem
bothMems (SpMem Int
o1 Int
w1) (SpMem Int
o2 Int
w2)
| Int
o1 forall a. Eq a => a -> a -> Bool
== Int
o2 = Int -> Int -> AbsMem
SpMem Int
o1 (forall a. Ord a => a -> a -> a
max Int
w1 Int
w2)
| Bool
otherwise = AbsMem
StackMem
bothMems SpMem{} AbsMem
StackMem = AbsMem
StackMem
bothMems AbsMem
StackMem SpMem{} = AbsMem
StackMem
bothMems AbsMem
_ AbsMem
_ = AbsMem
AnyMem
memConflicts :: AbsMem -> AbsMem -> Bool
memConflicts :: AbsMem -> AbsMem -> Bool
memConflicts AbsMem
NoMem AbsMem
_ = Bool
False
memConflicts AbsMem
_ AbsMem
NoMem = Bool
False
memConflicts AbsMem
HeapMem AbsMem
StackMem = Bool
False
memConflicts AbsMem
StackMem AbsMem
HeapMem = Bool
False
memConflicts SpMem{} AbsMem
HeapMem = Bool
False
memConflicts AbsMem
HeapMem SpMem{} = Bool
False
memConflicts (SpMem Int
o1 Int
w1) (SpMem Int
o2 Int
w2)
| Int
o1 forall a. Ord a => a -> a -> Bool
< Int
o2 = Int
o1 forall a. Num a => a -> a -> a
+ Int
w1 forall a. Ord a => a -> a -> Bool
> Int
o2
| Bool
otherwise = Int
o2 forall a. Num a => a -> a -> a
+ Int
w2 forall a. Ord a => a -> a -> Bool
> Int
o1
memConflicts AbsMem
_ AbsMem
_ = Bool
True
exprMem :: Platform -> CmmExpr -> AbsMem
exprMem :: Platform -> CmmExpr -> AbsMem
exprMem Platform
platform (CmmLoad CmmExpr
addr CmmType
w AlignmentSpec
_) = AbsMem -> AbsMem -> AbsMem
bothMems (Platform -> CmmExpr -> Width -> AbsMem
loadAddr Platform
platform CmmExpr
addr (CmmType -> Width
typeWidth CmmType
w)) (Platform -> CmmExpr -> AbsMem
exprMem Platform
platform CmmExpr
addr)
exprMem Platform
platform (CmmMachOp MachOp
_ [CmmExpr]
es) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AbsMem -> AbsMem -> AbsMem
bothMems AbsMem
NoMem (forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmExpr -> AbsMem
exprMem Platform
platform) [CmmExpr]
es)
exprMem Platform
_ CmmExpr
_ = AbsMem
NoMem
loadAddr :: Platform -> CmmExpr -> Width -> AbsMem
loadAddr :: Platform -> CmmExpr -> Width -> AbsMem
loadAddr Platform
platform CmmExpr
e Width
w =
case CmmExpr
e of
CmmReg CmmReg
r -> Platform -> CmmReg -> Int -> Width -> AbsMem
regAddr Platform
platform CmmReg
r Int
0 Width
w
CmmRegOff CmmReg
r Int
i -> Platform -> CmmReg -> Int -> Width -> AbsMem
regAddr Platform
platform CmmReg
r Int
i Width
w
CmmExpr
_other | Platform -> CmmReg -> CmmExpr -> Bool
regUsedIn Platform
platform CmmReg
spReg CmmExpr
e -> AbsMem
StackMem
| Bool
otherwise -> AbsMem
AnyMem
regAddr :: Platform -> CmmReg -> Int -> Width -> AbsMem
regAddr :: Platform -> CmmReg -> Int -> Width -> AbsMem
regAddr Platform
_ (CmmGlobal GlobalReg
Sp) Int
i Width
w = Int -> Int -> AbsMem
SpMem Int
i (Width -> Int
widthInBytes Width
w)
regAddr Platform
_ (CmmGlobal GlobalReg
Hp) Int
_ Width
_ = AbsMem
HeapMem
regAddr Platform
_ (CmmGlobal GlobalReg
CurrentTSO) Int
_ Width
_ = AbsMem
HeapMem
regAddr Platform
platform CmmReg
r Int
_ Width
_ | CmmType -> Bool
isGcPtrType (Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
r) = AbsMem
HeapMem
regAddr Platform
_ CmmReg
_ Int
_ Width
_ = AbsMem
AnyMem