{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.CmmToAsm.Reg.Liveness (
RegMap, emptyRegMap,
BlockMap,
LiveCmmDecl,
InstrSR (..),
LiveInstr (..),
Liveness (..),
LiveInfo (..),
LiveBasicBlock,
mapBlockTop, mapBlockTopM, mapSCCM,
mapGenBlockTop, mapGenBlockTopM,
mapLiveCmmDecl, pprLiveCmmDecl,
stripLive,
stripLiveBlock,
slurpConflicts,
slurpReloadCoalesce,
eraseDeltasLive,
patchEraseLive,
patchRegsLiveInstr,
reverseBlocksInTops,
regLiveness,
cmmTopLiveness
) where
import GHC.Prelude
import GHC.Platform.Reg
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Types
import GHC.CmmToAsm.Utils
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Label
import GHC.Cmm
import GHC.CmmToAsm.Reg.Target
import GHC.Data.Graph.Directed
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
import GHC.Types.Unique (Uniquable(..))
import GHC.Types.Unique.Set
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSM
import GHC.Data.Bag
import GHC.Utils.Monad.State.Strict
import Data.List (mapAccumL, partition)
import Data.Maybe
import Data.IntSet (IntSet)
import GHC.Utils.Misc
type RegMap a = UniqFM Reg a
emptyRegMap :: RegMap a
emptyRegMap :: forall a. RegMap a
emptyRegMap = UniqFM Reg a
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM
type BlockMap a = LabelMap a
type SlotMap a = UniqFM Slot a
type Slot = Int
type LiveCmmDecl statics instr
= GenCmmDecl
statics
LiveInfo
[SCC (LiveBasicBlock instr)]
data InstrSR instr
= Instr !instr
| SPILL !RegWithFormat !Int
| RELOAD !Int !RegWithFormat
deriving ((forall a b. (a -> b) -> InstrSR a -> InstrSR b)
-> (forall a b. a -> InstrSR b -> InstrSR a) -> Functor InstrSR
forall a b. a -> InstrSR b -> InstrSR a
forall a b. (a -> b) -> InstrSR a -> InstrSR b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> InstrSR a -> InstrSR b
fmap :: forall a b. (a -> b) -> InstrSR a -> InstrSR b
$c<$ :: forall a b. a -> InstrSR b -> InstrSR a
<$ :: forall a b. a -> InstrSR b -> InstrSR a
Functor)
instance Instruction instr => Instruction (InstrSR instr) where
regUsageOfInstr :: Platform -> InstrSR instr -> RegUsage
regUsageOfInstr Platform
platform InstrSR instr
i
= case InstrSR instr
i of
Instr instr
instr -> Platform -> instr -> RegUsage
forall instr. Instruction instr => Platform -> instr -> RegUsage
regUsageOfInstr Platform
platform instr
instr
SPILL RegWithFormat
reg Int
_ -> [RegWithFormat] -> [RegWithFormat] -> RegUsage
RU [RegWithFormat
reg] []
RELOAD Int
_ RegWithFormat
reg -> [RegWithFormat] -> [RegWithFormat] -> RegUsage
RU [] [RegWithFormat
reg]
patchRegsOfInstr :: HasDebugCallStack =>
Platform -> InstrSR instr -> (Reg -> Reg) -> InstrSR instr
patchRegsOfInstr Platform
platform InstrSR instr
i Reg -> Reg
f
= case InstrSR instr
i of
Instr instr
instr -> instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr (Platform -> instr -> (Reg -> Reg) -> instr
forall instr.
(Instruction instr, HasDebugCallStack) =>
Platform -> instr -> (Reg -> Reg) -> instr
patchRegsOfInstr Platform
platform instr
instr Reg -> Reg
f)
SPILL RegWithFormat
reg Int
slot -> RegWithFormat -> Int -> InstrSR instr
forall instr. RegWithFormat -> Int -> InstrSR instr
SPILL ((Reg -> Reg) -> RegWithFormat -> RegWithFormat
updReg Reg -> Reg
f RegWithFormat
reg) Int
slot
RELOAD Int
slot RegWithFormat
reg -> Int -> RegWithFormat -> InstrSR instr
forall instr. Int -> RegWithFormat -> InstrSR instr
RELOAD Int
slot ((Reg -> Reg) -> RegWithFormat -> RegWithFormat
updReg Reg -> Reg
f RegWithFormat
reg)
where
updReg :: (Reg -> Reg) -> RegWithFormat -> RegWithFormat
updReg Reg -> Reg
g (RegWithFormat Reg
reg Format
fmt) = Reg -> Format -> RegWithFormat
RegWithFormat (Reg -> Reg
g Reg
reg) Format
fmt
isJumpishInstr :: Instruction instr => InstrSR instr -> Bool
isJumpishInstr :: Instruction instr => InstrSR instr -> Bool
isJumpishInstr InstrSR instr
i
= case InstrSR instr
i of
Instr instr
instr -> instr -> Bool
forall instr. Instruction instr => instr -> Bool
isJumpishInstr instr
instr
InstrSR instr
_ -> Bool
False
canFallthroughTo :: InstrSR instr -> BlockId -> Bool
canFallthroughTo InstrSR instr
i BlockId
bid
= case InstrSR instr
i of
Instr instr
instr -> instr -> BlockId -> Bool
forall instr. Instruction instr => instr -> BlockId -> Bool
canFallthroughTo instr
instr BlockId
bid
InstrSR instr
_ -> Bool
False
jumpDestsOfInstr :: InstrSR instr -> [BlockId]
jumpDestsOfInstr InstrSR instr
i
= case InstrSR instr
i of
Instr instr
instr -> instr -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr instr
instr
InstrSR instr
_ -> []
patchJumpInstr :: InstrSR instr -> (BlockId -> BlockId) -> InstrSR instr
patchJumpInstr InstrSR instr
i BlockId -> BlockId
f
= case InstrSR instr
i of
Instr instr
instr -> instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr (instr -> (BlockId -> BlockId) -> instr
forall instr.
Instruction instr =>
instr -> (BlockId -> BlockId) -> instr
patchJumpInstr instr
instr BlockId -> BlockId
f)
InstrSR instr
_ -> InstrSR instr
i
mkSpillInstr :: HasDebugCallStack =>
NCGConfig -> RegWithFormat -> Int -> Int -> [InstrSR instr]
mkSpillInstr = [Char]
-> NCGConfig -> RegWithFormat -> Int -> Int -> [InstrSR instr]
forall a. HasCallStack => [Char] -> a
error [Char]
"mkSpillInstr[InstrSR]: Not making SPILL meta-instr"
mkLoadInstr :: HasDebugCallStack =>
NCGConfig -> RegWithFormat -> Int -> Int -> [InstrSR instr]
mkLoadInstr = [Char]
-> NCGConfig -> RegWithFormat -> Int -> Int -> [InstrSR instr]
forall a. HasCallStack => [Char] -> a
error [Char]
"mkLoadInstr[InstrSR]: Not making LOAD meta-instr"
takeDeltaInstr :: InstrSR instr -> Maybe Int
takeDeltaInstr InstrSR instr
i
= case InstrSR instr
i of
Instr instr
instr -> instr -> Maybe Int
forall instr. Instruction instr => instr -> Maybe Int
takeDeltaInstr instr
instr
InstrSR instr
_ -> Maybe Int
forall a. Maybe a
Nothing
isMetaInstr :: InstrSR instr -> Bool
isMetaInstr InstrSR instr
i
= case InstrSR instr
i of
Instr instr
instr -> instr -> Bool
forall instr. Instruction instr => instr -> Bool
isMetaInstr instr
instr
InstrSR instr
_ -> Bool
False
mkRegRegMoveInstr :: HasDebugCallStack =>
NCGConfig -> Format -> Reg -> Reg -> InstrSR instr
mkRegRegMoveInstr NCGConfig
platform Format
fmt Reg
r1 Reg
r2
= instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr (NCGConfig -> Format -> Reg -> Reg -> instr
forall instr.
(Instruction instr, HasDebugCallStack) =>
NCGConfig -> Format -> Reg -> Reg -> instr
mkRegRegMoveInstr NCGConfig
platform Format
fmt Reg
r1 Reg
r2)
takeRegRegMoveInstr :: Platform -> InstrSR instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr Platform
platform InstrSR instr
i
= case InstrSR instr
i of
Instr instr
instr -> Platform -> instr -> Maybe (Reg, Reg)
forall instr.
Instruction instr =>
Platform -> instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr Platform
platform instr
instr
InstrSR instr
_ -> Maybe (Reg, Reg)
forall a. Maybe a
Nothing
mkJumpInstr :: BlockId -> [InstrSR instr]
mkJumpInstr BlockId
target = (instr -> InstrSR instr) -> [instr] -> [InstrSR instr]
forall a b. (a -> b) -> [a] -> [b]
map instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr (BlockId -> [instr]
forall instr. Instruction instr => BlockId -> [instr]
mkJumpInstr BlockId
target)
mkStackAllocInstr :: Platform -> Int -> [InstrSR instr]
mkStackAllocInstr Platform
platform Int
amount =
instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr (instr -> InstrSR instr) -> [instr] -> [InstrSR instr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Platform -> Int -> [instr]
forall instr. Instruction instr => Platform -> Int -> [instr]
mkStackAllocInstr Platform
platform Int
amount
mkStackDeallocInstr :: Platform -> Int -> [InstrSR instr]
mkStackDeallocInstr Platform
platform Int
amount =
instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr (instr -> InstrSR instr) -> [instr] -> [InstrSR instr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Platform -> Int -> [instr]
forall instr. Instruction instr => Platform -> Int -> [instr]
mkStackDeallocInstr Platform
platform Int
amount
pprInstr :: Platform -> InstrSR instr -> SDoc
pprInstr Platform
platform InstrSR instr
i = InstrSR SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((instr -> SDoc) -> InstrSR instr -> InstrSR SDoc
forall a b. (a -> b) -> InstrSR a -> InstrSR b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Platform -> instr -> SDoc
forall instr. Instruction instr => Platform -> instr -> SDoc
pprInstr Platform
platform) InstrSR instr
i)
mkComment :: FastString -> [InstrSR instr]
mkComment = (instr -> InstrSR instr) -> [instr] -> [InstrSR instr]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr ([instr] -> [InstrSR instr])
-> (FastString -> [instr]) -> FastString -> [InstrSR instr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> [instr]
forall instr. Instruction instr => FastString -> [instr]
mkComment
data LiveInstr instr
= LiveInstr (InstrSR instr) (Maybe Liveness)
deriving ((forall a b. (a -> b) -> LiveInstr a -> LiveInstr b)
-> (forall a b. a -> LiveInstr b -> LiveInstr a)
-> Functor LiveInstr
forall a b. a -> LiveInstr b -> LiveInstr a
forall a b. (a -> b) -> LiveInstr a -> LiveInstr b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> LiveInstr a -> LiveInstr b
fmap :: forall a b. (a -> b) -> LiveInstr a -> LiveInstr b
$c<$ :: forall a b. a -> LiveInstr b -> LiveInstr a
<$ :: forall a b. a -> LiveInstr b -> LiveInstr a
Functor)
data Liveness
= Liveness
{ Liveness -> UniqSet RegWithFormat
liveBorn :: UniqSet RegWithFormat
, Liveness -> UniqSet RegWithFormat
liveDieRead :: UniqSet RegWithFormat
, Liveness -> UniqSet RegWithFormat
liveDieWrite :: UniqSet RegWithFormat}
data LiveInfo
= LiveInfo
(LabelMap RawCmmStatics)
[BlockId]
(BlockMap (UniqSet RegWithFormat))
(BlockMap IntSet)
type LiveBasicBlock instr
= GenBasicBlock (LiveInstr instr)
instance Outputable instr
=> Outputable (InstrSR instr) where
ppr :: InstrSR instr -> SDoc
ppr (Instr instr
realInstr)
= instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr instr
realInstr
ppr (SPILL (RegWithFormat Reg
reg Format
_fmt) Int
slot)
= [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"\tSPILL",
Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
' ',
Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
reg,
SDoc
forall doc. IsLine doc => doc
comma,
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"SLOT" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
slot)]
ppr (RELOAD Int
slot (RegWithFormat Reg
reg Format
_fmt))
= [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"\tRELOAD",
Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
' ',
[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"SLOT" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
slot),
SDoc
forall doc. IsLine doc => doc
comma,
Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
reg]
instance Outputable instr
=> Outputable (LiveInstr instr) where
ppr :: LiveInstr instr -> SDoc
ppr (LiveInstr InstrSR instr
instr Maybe Liveness
Nothing)
= InstrSR instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstrSR instr
instr
ppr (LiveInstr InstrSR instr
instr (Just Liveness
live))
= InstrSR instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstrSR instr
instr
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ (Int -> SDoc -> SDoc
nest Int
8
(SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ SDoc -> UniqSet RegWithFormat -> SDoc
pprRegs ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"# born: ") (Liveness -> UniqSet RegWithFormat
liveBorn Liveness
live)
, SDoc -> UniqSet RegWithFormat -> SDoc
pprRegs ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"# r_dying: ") (Liveness -> UniqSet RegWithFormat
liveDieRead Liveness
live)
, SDoc -> UniqSet RegWithFormat -> SDoc
pprRegs ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"# w_dying: ") (Liveness -> UniqSet RegWithFormat
liveDieWrite Liveness
live) ]
SDoc -> SDoc -> SDoc
$+$ SDoc
forall doc. IsLine doc => doc
space)
where pprRegs :: SDoc -> UniqSet RegWithFormat -> SDoc
pprRegs :: SDoc -> UniqSet RegWithFormat -> SDoc
pprRegs SDoc
name UniqSet RegWithFormat
regs
| UniqSet RegWithFormat -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet RegWithFormat
regs = SDoc
forall doc. IsOutput doc => doc
empty
| Bool
otherwise = SDoc
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
(UniqFM RegWithFormat RegWithFormat
-> ([RegWithFormat] -> SDoc) -> SDoc
forall {k} (key :: k) a. UniqFM key a -> ([a] -> SDoc) -> SDoc
pprUFM (UniqSet RegWithFormat -> UniqFM RegWithFormat RegWithFormat
forall a. UniqSet a -> UniqFM a a
getUniqSet UniqSet RegWithFormat
regs) ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc)
-> ([RegWithFormat] -> [SDoc]) -> [RegWithFormat] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
space ([SDoc] -> [SDoc])
-> ([RegWithFormat] -> [SDoc]) -> [RegWithFormat] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RegWithFormat -> SDoc) -> [RegWithFormat] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map RegWithFormat -> SDoc
forall a. Outputable a => a -> SDoc
ppr))
instance OutputableP env instr => OutputableP env (LiveInstr instr) where
pdoc :: env -> LiveInstr instr -> SDoc
pdoc env
env LiveInstr instr
i = LiveInstr SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((instr -> SDoc) -> LiveInstr instr -> LiveInstr SDoc
forall a b. (a -> b) -> LiveInstr a -> LiveInstr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (env -> instr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env) LiveInstr instr
i)
instance OutputableP Platform LiveInfo where
pdoc :: Platform -> LiveInfo -> SDoc
pdoc Platform
env (LiveInfo LabelMap RawCmmStatics
mb_static [BlockId]
entryIds BlockMap (UniqSet RegWithFormat)
liveVRegsOnEntry BlockMap IntSet
liveSlotsOnEntry)
= (Platform -> LabelMap RawCmmStatics -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
env LabelMap RawCmmStatics
mb_static)
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"# entryIds = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [BlockId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [BlockId]
entryIds
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"# liveVRegsOnEntry = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> BlockMap (UniqSet RegWithFormat) -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockMap (UniqSet RegWithFormat)
liveVRegsOnEntry
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"# liveSlotsOnEntry = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> BlockMap IntSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockMap IntSet
liveSlotsOnEntry
mapBlockTop
:: (LiveBasicBlock instr -> LiveBasicBlock instr)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
mapBlockTop :: forall instr statics.
(LiveBasicBlock instr -> LiveBasicBlock instr)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
mapBlockTop LiveBasicBlock instr -> LiveBasicBlock instr
f LiveCmmDecl statics instr
cmm
= State () (LiveCmmDecl statics instr)
-> () -> LiveCmmDecl statics instr
forall s a. State s a -> s -> a
evalState ((LiveBasicBlock instr -> State () (LiveBasicBlock instr))
-> LiveCmmDecl statics instr
-> State () (LiveCmmDecl statics instr)
forall (m :: * -> *) instr statics.
Monad m =>
(LiveBasicBlock instr -> m (LiveBasicBlock instr))
-> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
mapBlockTopM (\LiveBasicBlock instr
x -> LiveBasicBlock instr -> State () (LiveBasicBlock instr)
forall a. a -> State () a
forall (m :: * -> *) a. Monad m => a -> m a
return (LiveBasicBlock instr -> State () (LiveBasicBlock instr))
-> LiveBasicBlock instr -> State () (LiveBasicBlock instr)
forall a b. (a -> b) -> a -> b
$ LiveBasicBlock instr -> LiveBasicBlock instr
f LiveBasicBlock instr
x) LiveCmmDecl statics instr
cmm) ()
mapBlockTopM
:: Monad m
=> (LiveBasicBlock instr -> m (LiveBasicBlock instr))
-> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
mapBlockTopM :: forall (m :: * -> *) instr statics.
Monad m =>
(LiveBasicBlock instr -> m (LiveBasicBlock instr))
-> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
mapBlockTopM LiveBasicBlock instr -> m (LiveBasicBlock instr)
_ cmm :: LiveCmmDecl statics instr
cmm@(CmmData{})
= LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return LiveCmmDecl statics instr
cmm
mapBlockTopM LiveBasicBlock instr -> m (LiveBasicBlock instr)
f (CmmProc LiveInfo
header CLabel
label [GlobalRegUse]
live [SCC (LiveBasicBlock instr)]
sccs)
= do sccs' <- (SCC (LiveBasicBlock instr) -> m (SCC (LiveBasicBlock instr)))
-> [SCC (LiveBasicBlock instr)] -> m [SCC (LiveBasicBlock instr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((LiveBasicBlock instr -> m (LiveBasicBlock instr))
-> SCC (LiveBasicBlock instr) -> m (SCC (LiveBasicBlock instr))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SCC a -> m (SCC b)
mapSCCM LiveBasicBlock instr -> m (LiveBasicBlock instr)
f) [SCC (LiveBasicBlock instr)]
sccs
return $ CmmProc header label live sccs'
mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
mapSCCM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SCC a -> m (SCC b)
mapSCCM a -> m b
f (AcyclicSCC a
x)
= do x' <- a -> m b
f a
x
return $ AcyclicSCC x'
mapSCCM a -> m b
f (CyclicSCC [a]
xs)
= do xs' <- (a -> m b) -> [a] -> m [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> m b
f [a]
xs
return $ CyclicSCC xs'
mapGenBlockTop
:: (GenBasicBlock i -> GenBasicBlock i)
-> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i))
mapGenBlockTop :: forall i d h.
(GenBasicBlock i -> GenBasicBlock i)
-> GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i)
mapGenBlockTop GenBasicBlock i -> GenBasicBlock i
f GenCmmDecl d h (ListGraph i)
cmm
= State () (GenCmmDecl d h (ListGraph i))
-> () -> GenCmmDecl d h (ListGraph i)
forall s a. State s a -> s -> a
evalState ((GenBasicBlock i -> State () (GenBasicBlock i))
-> GenCmmDecl d h (ListGraph i)
-> State () (GenCmmDecl d h (ListGraph i))
forall (m :: * -> *) i d h.
Monad m =>
(GenBasicBlock i -> m (GenBasicBlock i))
-> GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))
mapGenBlockTopM (\GenBasicBlock i
x -> GenBasicBlock i -> State () (GenBasicBlock i)
forall a. a -> State () a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenBasicBlock i -> State () (GenBasicBlock i))
-> GenBasicBlock i -> State () (GenBasicBlock i)
forall a b. (a -> b) -> a -> b
$ GenBasicBlock i -> GenBasicBlock i
f GenBasicBlock i
x) GenCmmDecl d h (ListGraph i)
cmm) ()
mapGenBlockTopM
:: Monad m
=> (GenBasicBlock i -> m (GenBasicBlock i))
-> (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i)))
mapGenBlockTopM :: forall (m :: * -> *) i d h.
Monad m =>
(GenBasicBlock i -> m (GenBasicBlock i))
-> GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))
mapGenBlockTopM GenBasicBlock i -> m (GenBasicBlock i)
_ cmm :: GenCmmDecl d h (ListGraph i)
cmm@(CmmData{})
= GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return GenCmmDecl d h (ListGraph i)
cmm
mapGenBlockTopM GenBasicBlock i -> m (GenBasicBlock i)
f (CmmProc h
header CLabel
label [GlobalRegUse]
live (ListGraph [GenBasicBlock i]
blocks))
= do blocks' <- (GenBasicBlock i -> m (GenBasicBlock i))
-> [GenBasicBlock i] -> m [GenBasicBlock i]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenBasicBlock i -> m (GenBasicBlock i)
f [GenBasicBlock i]
blocks
return $ CmmProc header label live (ListGraph blocks')
slurpConflicts
:: Instruction instr
=> Platform
-> LiveCmmDecl statics instr
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpConflicts :: forall instr statics.
Instruction instr =>
Platform
-> LiveCmmDecl statics instr
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpConflicts Platform
platform LiveCmmDecl statics instr
live
= (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> LiveCmmDecl statics instr
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpCmm (Bag (UniqSet RegWithFormat)
forall a. Bag a
emptyBag, Bag (Reg, Reg)
forall a. Bag a
emptyBag) LiveCmmDecl statics instr
live
where slurpCmm :: (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> LiveCmmDecl statics instr
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpCmm (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
rs CmmData{} = (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
rs
slurpCmm (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
rs (CmmProc LiveInfo
info CLabel
_ [GlobalRegUse]
_ [SCC (GenBasicBlock (LiveInstr instr))]
sccs)
= ((Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> SCC (GenBasicBlock (LiveInstr instr))
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg)))
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> [SCC (GenBasicBlock (LiveInstr instr))]
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (LiveInfo
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> SCC (GenBasicBlock (LiveInstr instr))
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpSCC LiveInfo
info) (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
rs [SCC (GenBasicBlock (LiveInstr instr))]
sccs
slurpSCC :: LiveInfo
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> SCC (GenBasicBlock (LiveInstr instr))
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpSCC LiveInfo
info (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
rs (AcyclicSCC GenBasicBlock (LiveInstr instr)
b)
= LiveInfo
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> GenBasicBlock (LiveInstr instr)
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpBlock LiveInfo
info (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
rs GenBasicBlock (LiveInstr instr)
b
slurpSCC LiveInfo
info (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
rs (CyclicSCC [GenBasicBlock (LiveInstr instr)]
bs)
= ((Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> GenBasicBlock (LiveInstr instr)
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg)))
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> [GenBasicBlock (LiveInstr instr)]
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (LiveInfo
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> GenBasicBlock (LiveInstr instr)
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpBlock LiveInfo
info) (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
rs [GenBasicBlock (LiveInstr instr)]
bs
slurpBlock :: LiveInfo
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> GenBasicBlock (LiveInstr instr)
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpBlock LiveInfo
info (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
rs (BasicBlock BlockId
blockId [LiveInstr instr]
instrs)
| LiveInfo LabelMap RawCmmStatics
_ [BlockId]
_ BlockMap (UniqSet RegWithFormat)
blockLive BlockMap IntSet
_ <- LiveInfo
info
, Just UniqSet RegWithFormat
rsLiveEntry <- BlockId
-> BlockMap (UniqSet RegWithFormat)
-> Maybe (UniqSet RegWithFormat)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
blockId BlockMap (UniqSet RegWithFormat)
blockLive
, (Bag (UniqSet RegWithFormat)
conflicts, Bag (Reg, Reg)
moves) <- UniqSet RegWithFormat
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> [LiveInstr instr]
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpLIs UniqSet RegWithFormat
rsLiveEntry (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
rs [LiveInstr instr]
instrs
= (UniqSet RegWithFormat
-> Bag (UniqSet RegWithFormat) -> Bag (UniqSet RegWithFormat)
forall a. a -> Bag a -> Bag a
consBag UniqSet RegWithFormat
rsLiveEntry Bag (UniqSet RegWithFormat)
conflicts, Bag (Reg, Reg)
moves)
| Bool
otherwise
= [Char] -> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
forall a. HasCallStack => [Char] -> a
panic [Char]
"Liveness.slurpConflicts: bad block"
slurpLIs :: UniqSet RegWithFormat
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> [LiveInstr instr]
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpLIs UniqSet RegWithFormat
rsLive (Bag (UniqSet RegWithFormat)
conflicts, Bag (Reg, Reg)
moves) []
= (UniqSet RegWithFormat
-> Bag (UniqSet RegWithFormat) -> Bag (UniqSet RegWithFormat)
forall a. a -> Bag a -> Bag a
consBag UniqSet RegWithFormat
rsLive Bag (UniqSet RegWithFormat)
conflicts, Bag (Reg, Reg)
moves)
slurpLIs UniqSet RegWithFormat
rsLive (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
rs (LiveInstr InstrSR instr
_ Maybe Liveness
Nothing : [LiveInstr instr]
lis)
= UniqSet RegWithFormat
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> [LiveInstr instr]
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpLIs UniqSet RegWithFormat
rsLive (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
rs [LiveInstr instr]
lis
slurpLIs UniqSet RegWithFormat
rsLiveEntry (Bag (UniqSet RegWithFormat)
conflicts, Bag (Reg, Reg)
moves) (LiveInstr InstrSR instr
instr (Just Liveness
live) : [LiveInstr instr]
lis)
= let
rsLiveAcross :: UniqSet RegWithFormat
rsLiveAcross = UniqSet RegWithFormat
rsLiveEntry UniqSet RegWithFormat
-> UniqSet RegWithFormat -> UniqSet RegWithFormat
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` (Liveness -> UniqSet RegWithFormat
liveDieRead Liveness
live)
rsLiveNext :: UniqSet RegWithFormat
rsLiveNext = (UniqSet RegWithFormat
rsLiveAcross UniqSet RegWithFormat
-> UniqSet RegWithFormat -> UniqSet RegWithFormat
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` (Liveness -> UniqSet RegWithFormat
liveBorn Liveness
live))
UniqSet RegWithFormat
-> UniqSet RegWithFormat -> UniqSet RegWithFormat
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` (Liveness -> UniqSet RegWithFormat
liveDieWrite Liveness
live)
rsOrphans :: UniqSet RegWithFormat
rsOrphans = UniqSet RegWithFormat
-> UniqSet RegWithFormat -> UniqSet RegWithFormat
forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets
(Liveness -> UniqSet RegWithFormat
liveBorn Liveness
live)
(UniqSet RegWithFormat
-> UniqSet RegWithFormat -> UniqSet RegWithFormat
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets (Liveness -> UniqSet RegWithFormat
liveDieWrite Liveness
live) (Liveness -> UniqSet RegWithFormat
liveDieRead Liveness
live))
rsConflicts :: UniqSet RegWithFormat
rsConflicts = UniqSet RegWithFormat
-> UniqSet RegWithFormat -> UniqSet RegWithFormat
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets UniqSet RegWithFormat
rsLiveNext UniqSet RegWithFormat
rsOrphans
in case Platform -> InstrSR instr -> Maybe (Reg, Reg)
forall instr.
Instruction instr =>
Platform -> instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr Platform
platform InstrSR instr
instr of
Just (Reg, Reg)
rr -> UniqSet RegWithFormat
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> [LiveInstr instr]
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpLIs UniqSet RegWithFormat
rsLiveNext
( UniqSet RegWithFormat
-> Bag (UniqSet RegWithFormat) -> Bag (UniqSet RegWithFormat)
forall a. a -> Bag a -> Bag a
consBag UniqSet RegWithFormat
rsConflicts Bag (UniqSet RegWithFormat)
conflicts
, (Reg, Reg) -> Bag (Reg, Reg) -> Bag (Reg, Reg)
forall a. a -> Bag a -> Bag a
consBag (Reg, Reg)
rr Bag (Reg, Reg)
moves) [LiveInstr instr]
lis
Maybe (Reg, Reg)
Nothing -> UniqSet RegWithFormat
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
-> [LiveInstr instr]
-> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))
slurpLIs UniqSet RegWithFormat
rsLiveNext
( UniqSet RegWithFormat
-> Bag (UniqSet RegWithFormat) -> Bag (UniqSet RegWithFormat)
forall a. a -> Bag a -> Bag a
consBag UniqSet RegWithFormat
rsConflicts Bag (UniqSet RegWithFormat)
conflicts
, Bag (Reg, Reg)
moves) [LiveInstr instr]
lis
slurpReloadCoalesce
:: forall statics instr. Instruction instr
=> LiveCmmDecl statics instr
-> Bag (Reg, Reg)
slurpReloadCoalesce :: forall statics instr.
Instruction instr =>
LiveCmmDecl statics instr -> Bag (Reg, Reg)
slurpReloadCoalesce LiveCmmDecl statics instr
live
= Bag (Reg, Reg) -> LiveCmmDecl statics instr -> Bag (Reg, Reg)
forall t t1.
Bag (Reg, Reg)
-> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)] -> Bag (Reg, Reg)
slurpCmm Bag (Reg, Reg)
forall a. Bag a
emptyBag LiveCmmDecl statics instr
live
where
slurpCmm :: Bag (Reg, Reg)
-> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)]
-> Bag (Reg, Reg)
slurpCmm :: forall t t1.
Bag (Reg, Reg)
-> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)] -> Bag (Reg, Reg)
slurpCmm Bag (Reg, Reg)
cs CmmData{} = Bag (Reg, Reg)
cs
slurpCmm Bag (Reg, Reg)
cs (CmmProc t1
_ CLabel
_ [GlobalRegUse]
_ [SCC (LiveBasicBlock instr)]
sccs)
= Bag (Reg, Reg) -> [LiveBasicBlock instr] -> Bag (Reg, Reg)
slurpComp Bag (Reg, Reg)
cs ([SCC (LiveBasicBlock instr)] -> [LiveBasicBlock instr]
forall a. [SCC a] -> [a]
flattenSCCs [SCC (LiveBasicBlock instr)]
sccs)
slurpComp :: Bag (Reg, Reg)
-> [LiveBasicBlock instr]
-> Bag (Reg, Reg)
slurpComp :: Bag (Reg, Reg) -> [LiveBasicBlock instr] -> Bag (Reg, Reg)
slurpComp Bag (Reg, Reg)
cs [LiveBasicBlock instr]
blocks
= let ([Bag (Reg, Reg)]
moveBags, UniqFM BlockId [SlotMap Reg]
_) = State (UniqFM BlockId [SlotMap Reg]) [Bag (Reg, Reg)]
-> UniqFM BlockId [SlotMap Reg]
-> ([Bag (Reg, Reg)], UniqFM BlockId [SlotMap Reg])
forall s a. State s a -> s -> (a, s)
runState ([LiveBasicBlock instr]
-> State (UniqFM BlockId [SlotMap Reg]) [Bag (Reg, Reg)]
slurpCompM [LiveBasicBlock instr]
blocks) UniqFM BlockId [SlotMap Reg]
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM
in [Bag (Reg, Reg)] -> Bag (Reg, Reg)
forall a. [Bag a] -> Bag a
unionManyBags (Bag (Reg, Reg)
cs Bag (Reg, Reg) -> [Bag (Reg, Reg)] -> [Bag (Reg, Reg)]
forall a. a -> [a] -> [a]
: [Bag (Reg, Reg)]
moveBags)
slurpCompM :: [LiveBasicBlock instr]
-> State (UniqFM BlockId [UniqFM Slot Reg]) [Bag (Reg, Reg)]
slurpCompM :: [LiveBasicBlock instr]
-> State (UniqFM BlockId [SlotMap Reg]) [Bag (Reg, Reg)]
slurpCompM [LiveBasicBlock instr]
blocks
= do
(LiveBasicBlock instr
-> State (UniqFM BlockId [SlotMap Reg]) (Bag (Reg, Reg)))
-> [LiveBasicBlock instr]
-> State (UniqFM BlockId [SlotMap Reg]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool
-> LiveBasicBlock instr
-> State (UniqFM BlockId [SlotMap Reg]) (Bag (Reg, Reg))
slurpBlock Bool
False) [LiveBasicBlock instr]
blocks
(LiveBasicBlock instr
-> State (UniqFM BlockId [SlotMap Reg]) (Bag (Reg, Reg)))
-> [LiveBasicBlock instr]
-> State (UniqFM BlockId [SlotMap Reg]) [Bag (Reg, Reg)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Bool
-> LiveBasicBlock instr
-> State (UniqFM BlockId [SlotMap Reg]) (Bag (Reg, Reg))
slurpBlock Bool
True) [LiveBasicBlock instr]
blocks
slurpBlock :: Bool -> LiveBasicBlock instr
-> State (UniqFM BlockId [UniqFM Slot Reg]) (Bag (Reg, Reg))
slurpBlock :: Bool
-> LiveBasicBlock instr
-> State (UniqFM BlockId [SlotMap Reg]) (Bag (Reg, Reg))
slurpBlock Bool
propagate (BasicBlock BlockId
blockId [LiveInstr instr]
instrs)
= do
slotMap <- if Bool
propagate
then BlockId -> State (UniqFM BlockId [SlotMap Reg]) (SlotMap Reg)
forall {key}.
Uniquable key =>
key -> State (UniqFM key [SlotMap Reg]) (SlotMap Reg)
getSlotMap BlockId
blockId
else SlotMap Reg -> State (UniqFM BlockId [SlotMap Reg]) (SlotMap Reg)
forall a. a -> State (UniqFM BlockId [SlotMap Reg]) a
forall (m :: * -> *) a. Monad m => a -> m a
return SlotMap Reg
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM
(_, mMoves) <- mapAccumLM slurpLI slotMap instrs
return $ listToBag $ catMaybes mMoves
slurpLI :: SlotMap Reg
-> LiveInstr instr
-> State (UniqFM BlockId [SlotMap Reg])
( SlotMap Reg
, Maybe (Reg, Reg))
slurpLI :: SlotMap Reg
-> LiveInstr instr
-> State
(UniqFM BlockId [SlotMap Reg]) (SlotMap Reg, Maybe (Reg, Reg))
slurpLI SlotMap Reg
slotMap LiveInstr instr
li
| LiveInstr (SPILL (RegWithFormat Reg
reg Format
_fmt) Int
slot) Maybe Liveness
_ <- LiveInstr instr
li
, SlotMap Reg
slotMap' <- SlotMap Reg -> Int -> Reg -> SlotMap Reg
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM SlotMap Reg
slotMap Int
slot Reg
reg
= (SlotMap Reg, Maybe (Reg, Reg))
-> State
(UniqFM BlockId [SlotMap Reg]) (SlotMap Reg, Maybe (Reg, Reg))
forall a. a -> State (UniqFM BlockId [SlotMap Reg]) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotMap Reg
slotMap', Maybe (Reg, Reg)
forall a. Maybe a
Nothing)
| LiveInstr (RELOAD Int
slot (RegWithFormat Reg
reg Format
_fmt)) Maybe Liveness
_ <- LiveInstr instr
li
= case SlotMap Reg -> Int -> Maybe Reg
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM SlotMap Reg
slotMap Int
slot of
Just Reg
reg2
| Reg
reg Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
/= Reg
reg2 -> (SlotMap Reg, Maybe (Reg, Reg))
-> State
(UniqFM BlockId [SlotMap Reg]) (SlotMap Reg, Maybe (Reg, Reg))
forall a. a -> State (UniqFM BlockId [SlotMap Reg]) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotMap Reg
slotMap, (Reg, Reg) -> Maybe (Reg, Reg)
forall a. a -> Maybe a
Just (Reg
reg, Reg
reg2))
| Bool
otherwise -> (SlotMap Reg, Maybe (Reg, Reg))
-> State
(UniqFM BlockId [SlotMap Reg]) (SlotMap Reg, Maybe (Reg, Reg))
forall a. a -> State (UniqFM BlockId [SlotMap Reg]) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotMap Reg
slotMap, Maybe (Reg, Reg)
forall a. Maybe a
Nothing)
Maybe Reg
Nothing -> (SlotMap Reg, Maybe (Reg, Reg))
-> State
(UniqFM BlockId [SlotMap Reg]) (SlotMap Reg, Maybe (Reg, Reg))
forall a. a -> State (UniqFM BlockId [SlotMap Reg]) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotMap Reg
slotMap, Maybe (Reg, Reg)
forall a. Maybe a
Nothing)
| LiveInstr (Instr instr
instr) Maybe Liveness
_ <- LiveInstr instr
li
, [BlockId]
targets <- instr -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr instr
instr
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [BlockId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
targets
= do (BlockId -> State (UniqFM BlockId [SlotMap Reg]) ())
-> [BlockId] -> State (UniqFM BlockId [SlotMap Reg]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SlotMap Reg -> BlockId -> State (UniqFM BlockId [SlotMap Reg]) ()
forall {key} {a}.
Uniquable key =>
a -> key -> State (UniqFM key [a]) ()
accSlotMap SlotMap Reg
slotMap) [BlockId]
targets
(SlotMap Reg, Maybe (Reg, Reg))
-> State
(UniqFM BlockId [SlotMap Reg]) (SlotMap Reg, Maybe (Reg, Reg))
forall a. a -> State (UniqFM BlockId [SlotMap Reg]) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotMap Reg
slotMap, Maybe (Reg, Reg)
forall a. Maybe a
Nothing)
| Bool
otherwise
= (SlotMap Reg, Maybe (Reg, Reg))
-> State
(UniqFM BlockId [SlotMap Reg]) (SlotMap Reg, Maybe (Reg, Reg))
forall a. a -> State (UniqFM BlockId [SlotMap Reg]) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotMap Reg
slotMap, Maybe (Reg, Reg)
forall a. Maybe a
Nothing)
accSlotMap :: a -> key -> State (UniqFM key [a]) ()
accSlotMap a
slotMap key
blockId
= (UniqFM key [a] -> UniqFM key [a]) -> State (UniqFM key [a]) ()
forall s. (s -> s) -> State s ()
modify (\UniqFM key [a]
s -> ([a] -> [a] -> [a])
-> UniqFM key [a] -> key -> [a] -> UniqFM key [a]
forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) UniqFM key [a]
s key
blockId [a
slotMap])
getSlotMap :: key -> State (UniqFM key [SlotMap Reg]) (SlotMap Reg)
getSlotMap key
blockId
= do map <- State (UniqFM key [SlotMap Reg]) (UniqFM key [SlotMap Reg])
forall s. State s s
get
let slotMaps = [SlotMap Reg] -> Maybe [SlotMap Reg] -> [SlotMap Reg]
forall a. a -> Maybe a -> a
fromMaybe [] (UniqFM key [SlotMap Reg] -> key -> Maybe [SlotMap Reg]
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM key [SlotMap Reg]
map key
blockId)
return $ foldr mergeSlotMaps emptyUFM slotMaps
mergeSlotMaps :: SlotMap Reg -> SlotMap Reg -> SlotMap Reg
mergeSlotMaps :: SlotMap Reg -> SlotMap Reg -> SlotMap Reg
mergeSlotMaps SlotMap Reg
map1 SlotMap Reg
map2
= [(Unique, Reg)] -> SlotMap Reg
forall {k} elt (key :: k). [(Unique, elt)] -> UniqFM key elt
listToUFM_Directly
([(Unique, Reg)] -> SlotMap Reg) -> [(Unique, Reg)] -> SlotMap Reg
forall a b. (a -> b) -> a -> b
$ [ (Unique
k, Reg
r1)
| (Unique
k, Reg
r1) <- SlotMap Reg -> [(Unique, Reg)]
forall {k} (key :: k) elt. UniqFM key elt -> [(Unique, elt)]
nonDetUFMToList SlotMap Reg
map1
, case SlotMap Reg -> Unique -> Maybe Reg
forall {k} (key :: k) elt. UniqFM key elt -> Unique -> Maybe elt
lookupUFM_Directly SlotMap Reg
map2 Unique
k of
Maybe Reg
Nothing -> Bool
False
Just Reg
r2 -> Reg
r1 Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
r2 ]
stripLive
:: (OutputableP Platform statics, Instruction instr)
=> NCGConfig
-> LiveCmmDecl statics instr
-> NatCmmDecl statics instr
stripLive :: forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
NCGConfig -> LiveCmmDecl statics instr -> NatCmmDecl statics instr
stripLive NCGConfig
config LiveCmmDecl statics instr
live
= LiveCmmDecl statics instr -> NatCmmDecl statics instr
forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
LiveCmmDecl statics instr -> NatCmmDecl statics instr
stripCmm LiveCmmDecl statics instr
live
where stripCmm :: (OutputableP Platform statics, Instruction instr)
=> LiveCmmDecl statics instr -> NatCmmDecl statics instr
stripCmm :: forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
LiveCmmDecl statics instr -> NatCmmDecl statics instr
stripCmm (CmmData Section
sec statics
ds) = Section
-> statics
-> GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr)
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec statics
ds
stripCmm (CmmProc (LiveInfo LabelMap RawCmmStatics
info (BlockId
first_id:[BlockId]
_) BlockMap (UniqSet RegWithFormat)
_ BlockMap IntSet
_) CLabel
label [GlobalRegUse]
live [SCC (LiveBasicBlock instr)]
sccs)
= let final_blocks :: [LiveBasicBlock instr]
final_blocks = [SCC (LiveBasicBlock instr)] -> [LiveBasicBlock instr]
forall a. [SCC a] -> [a]
flattenSCCs [SCC (LiveBasicBlock instr)]
sccs
((LiveBasicBlock instr
first':[LiveBasicBlock instr]
_), [LiveBasicBlock instr]
rest')
= (LiveBasicBlock instr -> Bool)
-> [LiveBasicBlock instr]
-> ([LiveBasicBlock instr], [LiveBasicBlock instr])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
first_id) (BlockId -> Bool)
-> (LiveBasicBlock instr -> BlockId)
-> LiveBasicBlock instr
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LiveBasicBlock instr -> BlockId
forall i. GenBasicBlock i -> BlockId
blockId) [LiveBasicBlock instr]
final_blocks
in LabelMap RawCmmStatics
-> CLabel
-> [GlobalRegUse]
-> ListGraph instr
-> GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr)
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
info CLabel
label [GlobalRegUse]
live
([GenBasicBlock instr] -> ListGraph instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph ([GenBasicBlock instr] -> ListGraph instr)
-> [GenBasicBlock instr] -> ListGraph instr
forall a b. (a -> b) -> a -> b
$ (LiveBasicBlock instr -> GenBasicBlock instr)
-> [LiveBasicBlock instr] -> [GenBasicBlock instr]
forall a b. (a -> b) -> [a] -> [b]
map (NCGConfig -> LiveBasicBlock instr -> GenBasicBlock instr
forall instr.
Instruction instr =>
NCGConfig -> LiveBasicBlock instr -> NatBasicBlock instr
stripLiveBlock NCGConfig
config) ([LiveBasicBlock instr] -> [GenBasicBlock instr])
-> [LiveBasicBlock instr] -> [GenBasicBlock instr]
forall a b. (a -> b) -> a -> b
$ LiveBasicBlock instr
first' LiveBasicBlock instr
-> [LiveBasicBlock instr] -> [LiveBasicBlock instr]
forall a. a -> [a] -> [a]
: [LiveBasicBlock instr]
rest')
stripCmm GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
proc
= [Char]
-> SDoc
-> GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr)
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"RegAlloc.Liveness.stripLive: no first_id on proc" (Platform
-> GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)] -> SDoc
forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
Platform -> LiveCmmDecl statics instr -> SDoc
pprLiveCmmDecl (NCGConfig -> Platform
ncgPlatform NCGConfig
config) GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
proc)
pprLiveCmmDecl :: (OutputableP Platform statics, Instruction instr) => Platform -> LiveCmmDecl statics instr -> SDoc
pprLiveCmmDecl :: forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
Platform -> LiveCmmDecl statics instr -> SDoc
pprLiveCmmDecl Platform
platform LiveCmmDecl statics instr
d = Platform -> LiveCmmDecl statics SDoc -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform ((instr -> SDoc)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics SDoc
forall instr b statics.
(instr -> b) -> LiveCmmDecl statics instr -> LiveCmmDecl statics b
mapLiveCmmDecl (Platform -> instr -> SDoc
forall instr. Instruction instr => Platform -> instr -> SDoc
pprInstr Platform
platform) LiveCmmDecl statics instr
d)
mapLiveCmmDecl
:: (instr -> b)
-> LiveCmmDecl statics instr
-> LiveCmmDecl statics b
mapLiveCmmDecl :: forall instr b statics.
(instr -> b) -> LiveCmmDecl statics instr -> LiveCmmDecl statics b
mapLiveCmmDecl instr -> b
f LiveCmmDecl statics instr
proc = ([SCC (GenBasicBlock (LiveInstr instr))]
-> [SCC (LiveBasicBlock b)])
-> LiveCmmDecl statics instr
-> GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock b)]
forall a b.
(a -> b)
-> GenCmmDecl statics LiveInfo a -> GenCmmDecl statics LiveInfo b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SCC (GenBasicBlock (LiveInstr instr)) -> SCC (LiveBasicBlock b))
-> [SCC (GenBasicBlock (LiveInstr instr))]
-> [SCC (LiveBasicBlock b)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GenBasicBlock (LiveInstr instr) -> LiveBasicBlock b)
-> SCC (GenBasicBlock (LiveInstr instr)) -> SCC (LiveBasicBlock b)
forall a b. (a -> b) -> SCC a -> SCC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LiveInstr instr -> LiveInstr b)
-> GenBasicBlock (LiveInstr instr) -> LiveBasicBlock b
forall a b. (a -> b) -> GenBasicBlock a -> GenBasicBlock b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((instr -> b) -> LiveInstr instr -> LiveInstr b
forall a b. (a -> b) -> LiveInstr a -> LiveInstr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap instr -> b
f)))) LiveCmmDecl statics instr
proc
stripLiveBlock
:: Instruction instr
=> NCGConfig
-> LiveBasicBlock instr
-> NatBasicBlock instr
stripLiveBlock :: forall instr.
Instruction instr =>
NCGConfig -> LiveBasicBlock instr -> NatBasicBlock instr
stripLiveBlock NCGConfig
config (BasicBlock BlockId
i [LiveInstr instr]
lis)
= BlockId -> [instr] -> GenBasicBlock instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
i [instr]
instrs'
where ([instr]
instrs', Int
_)
= State Int [instr] -> Int -> ([instr], Int)
forall s a. State s a -> s -> (a, s)
runState ([instr] -> [LiveInstr instr] -> State Int [instr]
forall instr.
Instruction instr =>
[instr] -> [LiveInstr instr] -> State Int [instr]
spillNat [] [LiveInstr instr]
lis) Int
0
spillNat :: Instruction instr => [instr] -> [LiveInstr instr] -> State Int [instr]
spillNat :: forall instr.
Instruction instr =>
[instr] -> [LiveInstr instr] -> State Int [instr]
spillNat [instr]
acc []
= [instr] -> State Int [instr]
forall a. a -> State Int a
forall (m :: * -> *) a. Monad m => a -> m a
return ([instr] -> [instr]
forall a. [a] -> [a]
reverse [instr]
acc)
spillNat [instr]
acc (LiveInstr (SPILL RegWithFormat
reg Int
slot) Maybe Liveness
_ : [LiveInstr instr]
instrs)
= do delta <- State Int Int
forall s. State s s
get
spillNat (mkSpillInstr config reg delta slot ++ acc) instrs
spillNat [instr]
acc (LiveInstr (RELOAD Int
slot RegWithFormat
reg) Maybe Liveness
_ : [LiveInstr instr]
instrs)
= do delta <- State Int Int
forall s. State s s
get
spillNat (mkLoadInstr config reg delta slot ++ acc) instrs
spillNat [instr]
acc (LiveInstr (Instr instr
instr) Maybe Liveness
_ : [LiveInstr instr]
instrs)
| Just Int
i <- instr -> Maybe Int
forall instr. Instruction instr => instr -> Maybe Int
takeDeltaInstr instr
instr
= do Int -> State Int ()
forall s. s -> State s ()
put Int
i
[instr] -> [LiveInstr instr] -> State Int [instr]
forall instr.
Instruction instr =>
[instr] -> [LiveInstr instr] -> State Int [instr]
spillNat [instr]
acc [LiveInstr instr]
instrs
spillNat [instr]
acc (LiveInstr (Instr instr
instr) Maybe Liveness
_ : [LiveInstr instr]
instrs)
= [instr] -> [LiveInstr instr] -> State Int [instr]
forall instr.
Instruction instr =>
[instr] -> [LiveInstr instr] -> State Int [instr]
spillNat (instr
instr instr -> [instr] -> [instr]
forall a. a -> [a] -> [a]
: [instr]
acc) [LiveInstr instr]
instrs
eraseDeltasLive
:: Instruction instr
=> LiveCmmDecl statics instr
-> LiveCmmDecl statics instr
eraseDeltasLive :: forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> LiveCmmDecl statics instr
eraseDeltasLive LiveCmmDecl statics instr
cmm
= (LiveBasicBlock instr -> LiveBasicBlock instr)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
forall instr statics.
(LiveBasicBlock instr -> LiveBasicBlock instr)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
mapBlockTop LiveBasicBlock instr -> LiveBasicBlock instr
forall {instr}.
Instruction instr =>
GenBasicBlock (LiveInstr instr) -> GenBasicBlock (LiveInstr instr)
eraseBlock LiveCmmDecl statics instr
cmm
where
eraseBlock :: GenBasicBlock (LiveInstr instr) -> GenBasicBlock (LiveInstr instr)
eraseBlock (BasicBlock BlockId
id [LiveInstr instr]
lis)
= BlockId -> [LiveInstr instr] -> GenBasicBlock (LiveInstr instr)
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id
([LiveInstr instr] -> GenBasicBlock (LiveInstr instr))
-> [LiveInstr instr] -> GenBasicBlock (LiveInstr instr)
forall a b. (a -> b) -> a -> b
$ (LiveInstr instr -> Bool) -> [LiveInstr instr] -> [LiveInstr instr]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(LiveInstr InstrSR instr
i Maybe Liveness
_) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ InstrSR instr -> Maybe Int
forall instr. Instruction instr => instr -> Maybe Int
takeDeltaInstr InstrSR instr
i)
([LiveInstr instr] -> [LiveInstr instr])
-> [LiveInstr instr] -> [LiveInstr instr]
forall a b. (a -> b) -> a -> b
$ [LiveInstr instr]
lis
patchEraseLive
:: (Instruction instr, HasDebugCallStack)
=> Platform
-> (Reg -> Reg)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
patchEraseLive :: forall instr statics.
(Instruction instr, HasDebugCallStack) =>
Platform
-> (Reg -> Reg)
-> LiveCmmDecl statics instr
-> LiveCmmDecl statics instr
patchEraseLive Platform
platform Reg -> Reg
patchF LiveCmmDecl statics instr
cmm
= LiveCmmDecl statics instr -> LiveCmmDecl statics instr
patchCmm LiveCmmDecl statics instr
cmm
where
patchCmm :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr
patchCmm cmm :: LiveCmmDecl statics instr
cmm@CmmData{} = LiveCmmDecl statics instr
cmm
patchCmm (CmmProc LiveInfo
info CLabel
label [GlobalRegUse]
live [SCC (GenBasicBlock (LiveInstr instr))]
sccs)
| LiveInfo LabelMap RawCmmStatics
static [BlockId]
id BlockMap (UniqSet RegWithFormat)
blockMap BlockMap IntSet
mLiveSlots <- LiveInfo
info
= let
blockMap' :: BlockMap (UniqSet RegWithFormat)
blockMap' = (UniqSet RegWithFormat -> UniqSet RegWithFormat)
-> BlockMap (UniqSet RegWithFormat)
-> BlockMap (UniqSet RegWithFormat)
forall a v. (a -> v) -> LabelMap a -> LabelMap v
mapMap (HasDebugCallStack =>
(Reg -> Reg) -> UniqSet RegWithFormat -> UniqSet RegWithFormat
(Reg -> Reg) -> UniqSet RegWithFormat -> UniqSet RegWithFormat
mapRegFormatSet Reg -> Reg
patchF) BlockMap (UniqSet RegWithFormat)
blockMap
info' :: LiveInfo
info' = LabelMap RawCmmStatics
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> BlockMap IntSet
-> LiveInfo
LiveInfo LabelMap RawCmmStatics
static [BlockId]
id BlockMap (UniqSet RegWithFormat)
blockMap' BlockMap IntSet
mLiveSlots
in LiveInfo
-> CLabel
-> [GlobalRegUse]
-> [SCC (GenBasicBlock (LiveInstr instr))]
-> LiveCmmDecl statics instr
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc LiveInfo
info' CLabel
label [GlobalRegUse]
live ([SCC (GenBasicBlock (LiveInstr instr))]
-> LiveCmmDecl statics instr)
-> [SCC (GenBasicBlock (LiveInstr instr))]
-> LiveCmmDecl statics instr
forall a b. (a -> b) -> a -> b
$ (SCC (GenBasicBlock (LiveInstr instr))
-> SCC (GenBasicBlock (LiveInstr instr)))
-> [SCC (GenBasicBlock (LiveInstr instr))]
-> [SCC (GenBasicBlock (LiveInstr instr))]
forall a b. (a -> b) -> [a] -> [b]
map SCC (GenBasicBlock (LiveInstr instr))
-> SCC (GenBasicBlock (LiveInstr instr))
patchSCC [SCC (GenBasicBlock (LiveInstr instr))]
sccs
patchSCC :: SCC (GenBasicBlock (LiveInstr instr))
-> SCC (GenBasicBlock (LiveInstr instr))
patchSCC (AcyclicSCC GenBasicBlock (LiveInstr instr)
b) = GenBasicBlock (LiveInstr instr)
-> SCC (GenBasicBlock (LiveInstr instr))
forall vertex. vertex -> SCC vertex
AcyclicSCC (GenBasicBlock (LiveInstr instr) -> GenBasicBlock (LiveInstr instr)
patchBlock GenBasicBlock (LiveInstr instr)
b)
patchSCC (CyclicSCC [GenBasicBlock (LiveInstr instr)]
bs) = [GenBasicBlock (LiveInstr instr)]
-> SCC (GenBasicBlock (LiveInstr instr))
forall vertex. [vertex] -> SCC vertex
CyclicSCC ((GenBasicBlock (LiveInstr instr)
-> GenBasicBlock (LiveInstr instr))
-> [GenBasicBlock (LiveInstr instr)]
-> [GenBasicBlock (LiveInstr instr)]
forall a b. (a -> b) -> [a] -> [b]
map GenBasicBlock (LiveInstr instr) -> GenBasicBlock (LiveInstr instr)
patchBlock [GenBasicBlock (LiveInstr instr)]
bs)
patchBlock :: GenBasicBlock (LiveInstr instr) -> GenBasicBlock (LiveInstr instr)
patchBlock (BasicBlock BlockId
id [LiveInstr instr]
lis)
= BlockId -> [LiveInstr instr] -> GenBasicBlock (LiveInstr instr)
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id ([LiveInstr instr] -> GenBasicBlock (LiveInstr instr))
-> [LiveInstr instr] -> GenBasicBlock (LiveInstr instr)
forall a b. (a -> b) -> a -> b
$ [LiveInstr instr] -> [LiveInstr instr]
patchInstrs [LiveInstr instr]
lis
patchInstrs :: [LiveInstr instr] -> [LiveInstr instr]
patchInstrs [] = []
patchInstrs (LiveInstr instr
li : [LiveInstr instr]
lis)
| LiveInstr InstrSR instr
i (Just Liveness
live) <- LiveInstr instr
li'
, Just (Reg
r1, Reg
r2) <- Platform -> InstrSR instr -> Maybe (Reg, Reg)
forall instr.
Instruction instr =>
Platform -> instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr Platform
platform InstrSR instr
i
, Reg -> Reg -> Liveness -> Bool
forall {a}. (Eq a, Uniquable a) => a -> a -> Liveness -> Bool
eatMe Reg
r1 Reg
r2 Liveness
live
= [LiveInstr instr] -> [LiveInstr instr]
patchInstrs [LiveInstr instr]
lis
| Bool
otherwise
= LiveInstr instr
li' LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: [LiveInstr instr] -> [LiveInstr instr]
patchInstrs [LiveInstr instr]
lis
where li' :: LiveInstr instr
li' = Platform -> (Reg -> Reg) -> LiveInstr instr -> LiveInstr instr
forall instr.
(Instruction instr, HasDebugCallStack) =>
Platform -> (Reg -> Reg) -> LiveInstr instr -> LiveInstr instr
patchRegsLiveInstr Platform
platform Reg -> Reg
patchF LiveInstr instr
li
eatMe :: a -> a -> Liveness -> Bool
eatMe a
r1 a
r2 Liveness
live
| a
r1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
r2 = Bool
True
| Unique -> UniqSet RegWithFormat -> Bool
forall a. Unique -> UniqSet a -> Bool
elemUniqSet_Directly (a -> Unique
forall a. Uniquable a => a -> Unique
getUnique a
r2) (Liveness -> UniqSet RegWithFormat
liveBorn Liveness
live)
, Unique -> UniqSet RegWithFormat -> Bool
forall a. Unique -> UniqSet a -> Bool
elemUniqSet_Directly (a -> Unique
forall a. Uniquable a => a -> Unique
getUnique a
r2) (Liveness -> UniqSet RegWithFormat
liveDieRead Liveness
live) Bool -> Bool -> Bool
|| Unique -> UniqSet RegWithFormat -> Bool
forall a. Unique -> UniqSet a -> Bool
elemUniqSet_Directly (a -> Unique
forall a. Uniquable a => a -> Unique
getUnique a
r2) (Liveness -> UniqSet RegWithFormat
liveDieWrite Liveness
live)
= Bool
True
| Bool
otherwise = Bool
False
patchRegsLiveInstr
:: (Instruction instr, HasDebugCallStack)
=> Platform
-> (Reg -> Reg)
-> LiveInstr instr -> LiveInstr instr
patchRegsLiveInstr :: forall instr.
(Instruction instr, HasDebugCallStack) =>
Platform -> (Reg -> Reg) -> LiveInstr instr -> LiveInstr instr
patchRegsLiveInstr Platform
platform Reg -> Reg
patchF LiveInstr instr
li
= case LiveInstr instr
li of
LiveInstr InstrSR instr
instr Maybe Liveness
Nothing
-> InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr (Platform -> InstrSR instr -> (Reg -> Reg) -> InstrSR instr
forall instr.
(Instruction instr, HasDebugCallStack) =>
Platform -> instr -> (Reg -> Reg) -> instr
patchRegsOfInstr Platform
platform InstrSR instr
instr Reg -> Reg
patchF) Maybe Liveness
forall a. Maybe a
Nothing
LiveInstr InstrSR instr
instr (Just Liveness
live)
-> InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr
(Platform -> InstrSR instr -> (Reg -> Reg) -> InstrSR instr
forall instr.
(Instruction instr, HasDebugCallStack) =>
Platform -> instr -> (Reg -> Reg) -> instr
patchRegsOfInstr Platform
platform InstrSR instr
instr Reg -> Reg
patchF)
(Liveness -> Maybe Liveness
forall a. a -> Maybe a
Just Liveness
live
{
liveBorn = mapRegFormatSet patchF $ liveBorn live
, liveDieRead = mapRegFormatSet patchF $ liveDieRead live
, liveDieWrite = mapRegFormatSet patchF $ liveDieWrite live })
cmmTopLiveness
:: Instruction instr
=> Maybe CFG
-> Platform
-> NatCmmDecl statics instr
-> UniqDSM (LiveCmmDecl statics instr)
cmmTopLiveness :: forall instr statics.
Instruction instr =>
Maybe CFG
-> Platform
-> NatCmmDecl statics instr
-> UniqDSM (LiveCmmDecl statics instr)
cmmTopLiveness Maybe CFG
cfg Platform
platform NatCmmDecl statics instr
cmm
= Platform
-> LiveCmmDecl statics instr -> UniqDSM (LiveCmmDecl statics instr)
forall instr statics.
Instruction instr =>
Platform
-> LiveCmmDecl statics instr -> UniqDSM (LiveCmmDecl statics instr)
regLiveness Platform
platform (LiveCmmDecl statics instr -> UniqDSM (LiveCmmDecl statics instr))
-> LiveCmmDecl statics instr -> UniqDSM (LiveCmmDecl statics instr)
forall a b. (a -> b) -> a -> b
$ Maybe CFG -> NatCmmDecl statics instr -> LiveCmmDecl statics instr
forall instr statics.
Instruction instr =>
Maybe CFG -> NatCmmDecl statics instr -> LiveCmmDecl statics instr
natCmmTopToLive Maybe CFG
cfg NatCmmDecl statics instr
cmm
natCmmTopToLive
:: Instruction instr
=> Maybe CFG -> NatCmmDecl statics instr
-> LiveCmmDecl statics instr
natCmmTopToLive :: forall instr statics.
Instruction instr =>
Maybe CFG -> NatCmmDecl statics instr -> LiveCmmDecl statics instr
natCmmTopToLive Maybe CFG
_ (CmmData Section
i statics
d)
= Section
-> statics
-> GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
i statics
d
natCmmTopToLive Maybe CFG
_ (CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalRegUse]
live (ListGraph []))
= LiveInfo
-> CLabel
-> [GlobalRegUse]
-> [SCC (LiveBasicBlock instr)]
-> GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc (LabelMap RawCmmStatics
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> BlockMap IntSet
-> LiveInfo
LiveInfo LabelMap RawCmmStatics
info [] BlockMap (UniqSet RegWithFormat)
forall v. LabelMap v
mapEmpty BlockMap IntSet
forall v. LabelMap v
mapEmpty) CLabel
lbl [GlobalRegUse]
live []
natCmmTopToLive Maybe CFG
mCfg proc :: GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr)
proc@(CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalRegUse]
live (ListGraph blocks :: [GenBasicBlock instr]
blocks@(GenBasicBlock instr
first : [GenBasicBlock instr]
_)))
= LiveInfo
-> CLabel
-> [GlobalRegUse]
-> [SCC (LiveBasicBlock instr)]
-> GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc (LabelMap RawCmmStatics
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> BlockMap IntSet
-> LiveInfo
LiveInfo LabelMap RawCmmStatics
info' (BlockId
first_id BlockId -> [BlockId] -> [BlockId]
forall a. a -> [a] -> [a]
: [BlockId]
entry_ids) BlockMap (UniqSet RegWithFormat)
forall v. LabelMap v
mapEmpty BlockMap IntSet
forall v. LabelMap v
mapEmpty)
CLabel
lbl [GlobalRegUse]
live [SCC (LiveBasicBlock instr)]
sccsLive
where
first_id :: BlockId
first_id = GenBasicBlock instr -> BlockId
forall i. GenBasicBlock i -> BlockId
blockId GenBasicBlock instr
first
all_entry_ids :: [BlockId]
all_entry_ids = GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr)
-> [BlockId]
forall a i b. GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]
entryBlocks GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr)
proc
sccs :: [SCC (GenBasicBlock instr)]
sccs = [GenBasicBlock instr]
-> [BlockId] -> Maybe CFG -> [SCC (GenBasicBlock instr)]
forall instr.
Instruction instr =>
[NatBasicBlock instr]
-> [BlockId] -> Maybe CFG -> [SCC (NatBasicBlock instr)]
sccBlocks [GenBasicBlock instr]
blocks [BlockId]
all_entry_ids Maybe CFG
mCfg
sccsLive :: [SCC (LiveBasicBlock instr)]
sccsLive = (SCC (GenBasicBlock instr) -> SCC (LiveBasicBlock instr))
-> [SCC (GenBasicBlock instr)] -> [SCC (LiveBasicBlock instr)]
forall a b. (a -> b) -> [a] -> [b]
map ((GenBasicBlock instr -> LiveBasicBlock instr)
-> SCC (GenBasicBlock instr) -> SCC (LiveBasicBlock instr)
forall a b. (a -> b) -> SCC a -> SCC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(BasicBlock BlockId
l [instr]
instrs) ->
BlockId -> [LiveInstr instr] -> LiveBasicBlock instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
l ((instr -> LiveInstr instr) -> [instr] -> [LiveInstr instr]
forall a b. (a -> b) -> [a] -> [b]
map (\instr
i -> InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr (instr -> InstrSR instr
forall instr. instr -> InstrSR instr
Instr instr
i) Maybe Liveness
forall a. Maybe a
Nothing) [instr]
instrs)))
([SCC (GenBasicBlock instr)] -> [SCC (LiveBasicBlock instr)])
-> [SCC (GenBasicBlock instr)] -> [SCC (LiveBasicBlock instr)]
forall a b. (a -> b) -> a -> b
$ [SCC (GenBasicBlock instr)]
sccs
entry_ids :: [BlockId]
entry_ids = (BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (BlockId -> Bool
reachable_node) ([BlockId] -> [BlockId])
-> ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockId
first_id) ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ [BlockId]
all_entry_ids
info' :: LabelMap RawCmmStatics
info' = (BlockId -> RawCmmStatics -> Bool)
-> LabelMap RawCmmStatics -> LabelMap RawCmmStatics
forall v. (BlockId -> v -> Bool) -> LabelMap v -> LabelMap v
mapFilterWithKey (\BlockId
node RawCmmStatics
_ -> BlockId -> Bool
reachable_node BlockId
node) LabelMap RawCmmStatics
info
reachable_node :: BlockId -> Bool
reachable_node
| Just CFG
cfg <- Maybe CFG
mCfg
= CFG -> BlockId -> Bool
hasNode CFG
cfg
| Bool
otherwise
= Bool -> BlockId -> Bool
forall a b. a -> b -> a
const Bool
True
sccBlocks
:: forall instr . Instruction instr
=> [NatBasicBlock instr]
-> [BlockId]
-> Maybe CFG
-> [SCC (NatBasicBlock instr)]
sccBlocks :: forall instr.
Instruction instr =>
[NatBasicBlock instr]
-> [BlockId] -> Maybe CFG -> [SCC (NatBasicBlock instr)]
sccBlocks [NatBasicBlock instr]
blocks [BlockId]
entries Maybe CFG
mcfg = (SCC (Node BlockId (NatBasicBlock instr))
-> SCC (NatBasicBlock instr))
-> [SCC (Node BlockId (NatBasicBlock instr))]
-> [SCC (NatBasicBlock instr)]
forall a b. (a -> b) -> [a] -> [b]
map ((Node BlockId (NatBasicBlock instr) -> NatBasicBlock instr)
-> SCC (Node BlockId (NatBasicBlock instr))
-> SCC (NatBasicBlock instr)
forall a b. (a -> b) -> SCC a -> SCC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node BlockId (NatBasicBlock instr) -> NatBasicBlock instr
forall key payload. Node key payload -> payload
node_payload) [SCC (Node BlockId (NatBasicBlock instr))]
sccs
where
nodes :: [ Node BlockId (NatBasicBlock instr) ]
nodes :: [Node BlockId (NatBasicBlock instr)]
nodes = [ NatBasicBlock instr
-> BlockId -> [BlockId] -> Node BlockId (NatBasicBlock instr)
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode NatBasicBlock instr
block BlockId
id ([instr] -> [BlockId]
Instruction instr => [instr] -> [BlockId]
getOutEdges [instr]
instrs)
| block :: NatBasicBlock instr
block@(BasicBlock BlockId
id [instr]
instrs) <- [NatBasicBlock instr]
blocks ]
g1 :: Graph (Node BlockId (NatBasicBlock instr))
g1 = [Node BlockId (NatBasicBlock instr)]
-> Graph (Node BlockId (NatBasicBlock instr))
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [Node BlockId (NatBasicBlock instr)]
nodes
reachable :: LabelSet
reachable :: LabelSet
reachable
| Just CFG
cfg <- Maybe CFG
mcfg
= [BlockId] -> LabelSet
setFromList ([BlockId] -> LabelSet) -> [BlockId] -> LabelSet
forall a b. (a -> b) -> a -> b
$ CFG -> [BlockId]
getCfgNodes CFG
cfg
| Bool
otherwise
= [BlockId] -> LabelSet
setFromList ([BlockId] -> LabelSet) -> [BlockId] -> LabelSet
forall a b. (a -> b) -> a -> b
$ [ Node BlockId (NatBasicBlock instr) -> BlockId
forall key payload. Node key payload -> key
node_key Node BlockId (NatBasicBlock instr)
node | Node BlockId (NatBasicBlock instr)
node <- Graph (Node BlockId (NatBasicBlock instr))
-> [Node BlockId (NatBasicBlock instr)]
-> [Node BlockId (NatBasicBlock instr)]
forall node. Graph node -> [node] -> [node]
reachablesG Graph (Node BlockId (NatBasicBlock instr))
g1 [Node BlockId (NatBasicBlock instr)]
roots ]
g2 :: Graph (Node BlockId (NatBasicBlock instr))
g2 = [Node BlockId (NatBasicBlock instr)]
-> Graph (Node BlockId (NatBasicBlock instr))
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [ Node BlockId (NatBasicBlock instr)
node | Node BlockId (NatBasicBlock instr)
node <- [Node BlockId (NatBasicBlock instr)]
nodes
, Node BlockId (NatBasicBlock instr) -> BlockId
forall key payload. Node key payload -> key
node_key Node BlockId (NatBasicBlock instr)
node
BlockId -> LabelSet -> Bool
`setMember` LabelSet
reachable ]
sccs :: [SCC (Node BlockId (NatBasicBlock instr))]
sccs = Graph (Node BlockId (NatBasicBlock instr))
-> [SCC (Node BlockId (NatBasicBlock instr))]
forall node. Graph node -> [SCC node]
stronglyConnCompG Graph (Node BlockId (NatBasicBlock instr))
g2
getOutEdges :: Instruction instr => [instr] -> [BlockId]
getOutEdges :: Instruction instr => [instr] -> [BlockId]
getOutEdges [instr]
instrs = (instr -> [BlockId]) -> [instr] -> [BlockId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap instr -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr [instr]
instrs
roots :: [Node BlockId (NatBasicBlock instr)]
roots = [NatBasicBlock instr
-> BlockId -> [BlockId] -> Node BlockId (NatBasicBlock instr)
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode ([Char] -> NatBasicBlock instr
forall a. HasCallStack => [Char] -> a
panic [Char]
"sccBlocks") BlockId
b ([Char] -> [BlockId]
forall a. HasCallStack => [Char] -> a
panic [Char]
"sccBlocks")
| BlockId
b <- [BlockId]
entries ]
regLiveness
:: Instruction instr
=> Platform
-> LiveCmmDecl statics instr
-> UniqDSM (LiveCmmDecl statics instr)
regLiveness :: forall instr statics.
Instruction instr =>
Platform
-> LiveCmmDecl statics instr -> UniqDSM (LiveCmmDecl statics instr)
regLiveness Platform
_ (CmmData Section
i statics
d)
= GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
-> UniqDSM
(GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)])
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
-> UniqDSM
(GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]))
-> GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
-> UniqDSM
(GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)])
forall a b. (a -> b) -> a -> b
$ Section
-> statics
-> GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
i statics
d
regLiveness Platform
_ (CmmProc LiveInfo
info CLabel
lbl [GlobalRegUse]
live [])
| LiveInfo LabelMap RawCmmStatics
static [BlockId]
mFirst BlockMap (UniqSet RegWithFormat)
_ BlockMap IntSet
_ <- LiveInfo
info
= GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
-> UniqDSM
(GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)])
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
-> UniqDSM
(GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]))
-> GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
-> UniqDSM
(GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)])
forall a b. (a -> b) -> a -> b
$ LiveInfo
-> CLabel
-> [GlobalRegUse]
-> [SCC (LiveBasicBlock instr)]
-> GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc
(LabelMap RawCmmStatics
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> BlockMap IntSet
-> LiveInfo
LiveInfo LabelMap RawCmmStatics
static [BlockId]
mFirst BlockMap (UniqSet RegWithFormat)
forall v. LabelMap v
mapEmpty BlockMap IntSet
forall v. LabelMap v
mapEmpty)
CLabel
lbl [GlobalRegUse]
live []
regLiveness Platform
platform (CmmProc LiveInfo
info CLabel
lbl [GlobalRegUse]
live [SCC (LiveBasicBlock instr)]
sccs)
| LiveInfo LabelMap RawCmmStatics
static [BlockId]
mFirst BlockMap (UniqSet RegWithFormat)
_ BlockMap IntSet
liveSlotsOnEntry <- LiveInfo
info
= let ([SCC (LiveBasicBlock instr)]
ann_sccs, BlockMap (UniqSet RegWithFormat)
block_live) = Platform
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap (UniqSet RegWithFormat))
forall instr.
Instruction instr =>
Platform
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap (UniqSet RegWithFormat))
computeLiveness Platform
platform [SCC (LiveBasicBlock instr)]
sccs
in GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
-> UniqDSM
(GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)])
forall a. a -> UniqDSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
-> UniqDSM
(GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]))
-> GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
-> UniqDSM
(GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)])
forall a b. (a -> b) -> a -> b
$ LiveInfo
-> CLabel
-> [GlobalRegUse]
-> [SCC (LiveBasicBlock instr)]
-> GenCmmDecl statics LiveInfo [SCC (LiveBasicBlock instr)]
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc (LabelMap RawCmmStatics
-> [BlockId]
-> BlockMap (UniqSet RegWithFormat)
-> BlockMap IntSet
-> LiveInfo
LiveInfo LabelMap RawCmmStatics
static [BlockId]
mFirst BlockMap (UniqSet RegWithFormat)
block_live BlockMap IntSet
liveSlotsOnEntry)
CLabel
lbl [GlobalRegUse]
live [SCC (LiveBasicBlock instr)]
ann_sccs
checkIsReverseDependent
:: Instruction instr
=> [SCC (LiveBasicBlock instr)]
-> Maybe BlockId
checkIsReverseDependent :: forall instr.
Instruction instr =>
[SCC (LiveBasicBlock instr)] -> Maybe BlockId
checkIsReverseDependent [SCC (LiveBasicBlock instr)]
sccs'
= UniqSet BlockId -> [SCC (LiveBasicBlock instr)] -> Maybe BlockId
forall {instr}.
Instruction instr =>
UniqSet BlockId
-> [SCC (GenBasicBlock (LiveInstr instr))] -> Maybe BlockId
go UniqSet BlockId
forall a. UniqSet a
emptyUniqSet [SCC (LiveBasicBlock instr)]
sccs'
where go :: UniqSet BlockId
-> [SCC (GenBasicBlock (LiveInstr instr))] -> Maybe BlockId
go UniqSet BlockId
_ []
= Maybe BlockId
forall a. Maybe a
Nothing
go UniqSet BlockId
blocksSeen (AcyclicSCC GenBasicBlock (LiveInstr instr)
block : [SCC (GenBasicBlock (LiveInstr instr))]
sccs)
= let dests :: UniqSet BlockId
dests = GenBasicBlock (LiveInstr instr) -> UniqSet BlockId
forall {instr}.
Instruction instr =>
GenBasicBlock (LiveInstr instr) -> UniqSet BlockId
slurpJumpDestsOfBlock GenBasicBlock (LiveInstr instr)
block
blocksSeen' :: UniqSet BlockId
blocksSeen' = UniqSet BlockId -> UniqSet BlockId -> UniqSet BlockId
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets UniqSet BlockId
blocksSeen (UniqSet BlockId -> UniqSet BlockId)
-> UniqSet BlockId -> UniqSet BlockId
forall a b. (a -> b) -> a -> b
$ [BlockId] -> UniqSet BlockId
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [GenBasicBlock (LiveInstr instr) -> BlockId
forall i. GenBasicBlock i -> BlockId
blockId GenBasicBlock (LiveInstr instr)
block]
badDests :: UniqSet BlockId
badDests = UniqSet BlockId
dests UniqSet BlockId -> UniqSet BlockId -> UniqSet BlockId
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` UniqSet BlockId
blocksSeen'
in case UniqSet BlockId -> [BlockId]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet BlockId
badDests of
[] -> UniqSet BlockId
-> [SCC (GenBasicBlock (LiveInstr instr))] -> Maybe BlockId
go UniqSet BlockId
blocksSeen' [SCC (GenBasicBlock (LiveInstr instr))]
sccs
BlockId
bad : [BlockId]
_ -> BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
bad
go UniqSet BlockId
blocksSeen (CyclicSCC [GenBasicBlock (LiveInstr instr)]
blocks : [SCC (GenBasicBlock (LiveInstr instr))]
sccs)
= let dests :: UniqSet BlockId
dests = [UniqSet BlockId] -> UniqSet BlockId
forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets ([UniqSet BlockId] -> UniqSet BlockId)
-> [UniqSet BlockId] -> UniqSet BlockId
forall a b. (a -> b) -> a -> b
$ (GenBasicBlock (LiveInstr instr) -> UniqSet BlockId)
-> [GenBasicBlock (LiveInstr instr)] -> [UniqSet BlockId]
forall a b. (a -> b) -> [a] -> [b]
map GenBasicBlock (LiveInstr instr) -> UniqSet BlockId
forall {instr}.
Instruction instr =>
GenBasicBlock (LiveInstr instr) -> UniqSet BlockId
slurpJumpDestsOfBlock [GenBasicBlock (LiveInstr instr)]
blocks
blocksSeen' :: UniqSet BlockId
blocksSeen' = UniqSet BlockId -> UniqSet BlockId -> UniqSet BlockId
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets UniqSet BlockId
blocksSeen (UniqSet BlockId -> UniqSet BlockId)
-> UniqSet BlockId -> UniqSet BlockId
forall a b. (a -> b) -> a -> b
$ [BlockId] -> UniqSet BlockId
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([BlockId] -> UniqSet BlockId) -> [BlockId] -> UniqSet BlockId
forall a b. (a -> b) -> a -> b
$ (GenBasicBlock (LiveInstr instr) -> BlockId)
-> [GenBasicBlock (LiveInstr instr)] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map GenBasicBlock (LiveInstr instr) -> BlockId
forall i. GenBasicBlock i -> BlockId
blockId [GenBasicBlock (LiveInstr instr)]
blocks
badDests :: UniqSet BlockId
badDests = UniqSet BlockId
dests UniqSet BlockId -> UniqSet BlockId -> UniqSet BlockId
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` UniqSet BlockId
blocksSeen'
in case UniqSet BlockId -> [BlockId]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet BlockId
badDests of
[] -> UniqSet BlockId
-> [SCC (GenBasicBlock (LiveInstr instr))] -> Maybe BlockId
go UniqSet BlockId
blocksSeen' [SCC (GenBasicBlock (LiveInstr instr))]
sccs
BlockId
bad : [BlockId]
_ -> BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
bad
slurpJumpDestsOfBlock :: GenBasicBlock (LiveInstr instr) -> UniqSet BlockId
slurpJumpDestsOfBlock (BasicBlock BlockId
_ [LiveInstr instr]
instrs)
= [UniqSet BlockId] -> UniqSet BlockId
forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets
([UniqSet BlockId] -> UniqSet BlockId)
-> [UniqSet BlockId] -> UniqSet BlockId
forall a b. (a -> b) -> a -> b
$ (InstrSR instr -> UniqSet BlockId)
-> [InstrSR instr] -> [UniqSet BlockId]
forall a b. (a -> b) -> [a] -> [b]
map ([BlockId] -> UniqSet BlockId
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([BlockId] -> UniqSet BlockId)
-> (InstrSR instr -> [BlockId]) -> InstrSR instr -> UniqSet BlockId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstrSR instr -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr)
[ InstrSR instr
i | LiveInstr InstrSR instr
i Maybe Liveness
_ <- [LiveInstr instr]
instrs]
reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr
reverseBlocksInTops :: forall statics instr.
LiveCmmDecl statics instr -> LiveCmmDecl statics instr
reverseBlocksInTops LiveCmmDecl statics instr
top
= case LiveCmmDecl statics instr
top of
CmmData{} -> LiveCmmDecl statics instr
top
CmmProc LiveInfo
info CLabel
lbl [GlobalRegUse]
live [SCC (LiveBasicBlock instr)]
sccs -> LiveInfo
-> CLabel
-> [GlobalRegUse]
-> [SCC (LiveBasicBlock instr)]
-> LiveCmmDecl statics instr
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc LiveInfo
info CLabel
lbl [GlobalRegUse]
live ([SCC (LiveBasicBlock instr)] -> [SCC (LiveBasicBlock instr)]
forall a. [a] -> [a]
reverse [SCC (LiveBasicBlock instr)]
sccs)
computeLiveness
:: Instruction instr
=> Platform
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)],
BlockMap (UniqSet RegWithFormat))
computeLiveness :: forall instr.
Instruction instr =>
Platform
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap (UniqSet RegWithFormat))
computeLiveness Platform
platform [SCC (LiveBasicBlock instr)]
sccs
= case [SCC (LiveBasicBlock instr)] -> Maybe BlockId
forall instr.
Instruction instr =>
[SCC (LiveBasicBlock instr)] -> Maybe BlockId
checkIsReverseDependent [SCC (LiveBasicBlock instr)]
sccs of
Maybe BlockId
Nothing -> Platform
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap (UniqSet RegWithFormat))
forall instr.
Instruction instr =>
Platform
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap (UniqSet RegWithFormat))
livenessSCCs Platform
platform BlockMap (UniqSet RegWithFormat)
forall v. LabelMap v
mapEmpty [] [SCC (LiveBasicBlock instr)]
sccs
Just BlockId
bad -> let sccs' :: [SCC (LiveBasicBlock SDoc)]
sccs' = (SCC (LiveBasicBlock instr) -> SCC (LiveBasicBlock SDoc))
-> [SCC (LiveBasicBlock instr)] -> [SCC (LiveBasicBlock SDoc)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LiveBasicBlock instr -> LiveBasicBlock SDoc)
-> SCC (LiveBasicBlock instr) -> SCC (LiveBasicBlock SDoc)
forall a b. (a -> b) -> SCC a -> SCC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LiveInstr instr -> LiveInstr SDoc)
-> LiveBasicBlock instr -> LiveBasicBlock SDoc
forall a b. (a -> b) -> GenBasicBlock a -> GenBasicBlock b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((instr -> SDoc) -> LiveInstr instr -> LiveInstr SDoc
forall a b. (a -> b) -> LiveInstr a -> LiveInstr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Platform -> instr -> SDoc
forall instr. Instruction instr => Platform -> instr -> SDoc
pprInstr Platform
platform)))) [SCC (LiveBasicBlock instr)]
sccs
in [Char]
-> SDoc
-> ([SCC (LiveBasicBlock instr)], BlockMap (UniqSet RegWithFormat))
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"RegAlloc.Liveness.computeLiveness"
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"SCCs aren't in reverse dependent order"
, [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"bad blockId" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
bad
, [SCC (LiveBasicBlock SDoc)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SCC (LiveBasicBlock SDoc)]
sccs'])
livenessSCCs
:: Instruction instr
=> Platform
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ( [SCC (LiveBasicBlock instr)]
, BlockMap (UniqSet RegWithFormat))
livenessSCCs :: forall instr.
Instruction instr =>
Platform
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap (UniqSet RegWithFormat))
livenessSCCs Platform
_ BlockMap (UniqSet RegWithFormat)
blockmap [SCC (LiveBasicBlock instr)]
done []
= ([SCC (LiveBasicBlock instr)]
done, BlockMap (UniqSet RegWithFormat)
blockmap)
livenessSCCs Platform
platform BlockMap (UniqSet RegWithFormat)
blockmap [SCC (LiveBasicBlock instr)]
done (AcyclicSCC LiveBasicBlock instr
block : [SCC (LiveBasicBlock instr)]
sccs)
= let (BlockMap (UniqSet RegWithFormat)
blockmap', LiveBasicBlock instr
block') = Platform
-> BlockMap (UniqSet RegWithFormat)
-> LiveBasicBlock instr
-> (BlockMap (UniqSet RegWithFormat), LiveBasicBlock instr)
forall instr.
Instruction instr =>
Platform
-> BlockMap (UniqSet RegWithFormat)
-> LiveBasicBlock instr
-> (BlockMap (UniqSet RegWithFormat), LiveBasicBlock instr)
livenessBlock Platform
platform BlockMap (UniqSet RegWithFormat)
blockmap LiveBasicBlock instr
block
in Platform
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap (UniqSet RegWithFormat))
forall instr.
Instruction instr =>
Platform
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap (UniqSet RegWithFormat))
livenessSCCs Platform
platform BlockMap (UniqSet RegWithFormat)
blockmap' (LiveBasicBlock instr -> SCC (LiveBasicBlock instr)
forall vertex. vertex -> SCC vertex
AcyclicSCC LiveBasicBlock instr
block' SCC (LiveBasicBlock instr)
-> [SCC (LiveBasicBlock instr)] -> [SCC (LiveBasicBlock instr)]
forall a. a -> [a] -> [a]
: [SCC (LiveBasicBlock instr)]
done) [SCC (LiveBasicBlock instr)]
sccs
livenessSCCs Platform
platform BlockMap (UniqSet RegWithFormat)
blockmap [SCC (LiveBasicBlock instr)]
done
(CyclicSCC [LiveBasicBlock instr]
blocks : [SCC (LiveBasicBlock instr)]
sccs) =
Platform
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap (UniqSet RegWithFormat))
forall instr.
Instruction instr =>
Platform
-> BlockMap (UniqSet RegWithFormat)
-> [SCC (LiveBasicBlock instr)]
-> [SCC (LiveBasicBlock instr)]
-> ([SCC (LiveBasicBlock instr)], BlockMap (UniqSet RegWithFormat))
livenessSCCs Platform
platform BlockMap (UniqSet RegWithFormat)
blockmap' ([LiveBasicBlock instr] -> SCC (LiveBasicBlock instr)
forall vertex. [vertex] -> SCC vertex
CyclicSCC [LiveBasicBlock instr]
blocks'SCC (LiveBasicBlock instr)
-> [SCC (LiveBasicBlock instr)] -> [SCC (LiveBasicBlock instr)]
forall a. a -> [a] -> [a]
:[SCC (LiveBasicBlock instr)]
done) [SCC (LiveBasicBlock instr)]
sccs
where (BlockMap (UniqSet RegWithFormat)
blockmap', [LiveBasicBlock instr]
blocks')
= (BlockMap (UniqSet RegWithFormat)
-> [LiveBasicBlock instr]
-> (BlockMap (UniqSet RegWithFormat), [LiveBasicBlock instr]))
-> (BlockMap (UniqSet RegWithFormat)
-> BlockMap (UniqSet RegWithFormat) -> Bool)
-> BlockMap (UniqSet RegWithFormat)
-> [LiveBasicBlock instr]
-> (BlockMap (UniqSet RegWithFormat), [LiveBasicBlock instr])
forall a b c.
(a -> b -> (a, c)) -> (a -> a -> Bool) -> a -> b -> (a, c)
iterateUntilUnchanged BlockMap (UniqSet RegWithFormat)
-> [LiveBasicBlock instr]
-> (BlockMap (UniqSet RegWithFormat), [LiveBasicBlock instr])
forall instr.
Instruction instr =>
BlockMap (UniqSet RegWithFormat)
-> [LiveBasicBlock instr]
-> (BlockMap (UniqSet RegWithFormat), [LiveBasicBlock instr])
linearLiveness BlockMap (UniqSet RegWithFormat)
-> BlockMap (UniqSet RegWithFormat) -> Bool
forall {b}. Eq b => LabelMap b -> LabelMap b -> Bool
equalBlockMaps
BlockMap (UniqSet RegWithFormat)
blockmap [LiveBasicBlock instr]
blocks
iterateUntilUnchanged
:: (a -> b -> (a,c)) -> (a -> a -> Bool)
-> a -> b
-> (a,c)
iterateUntilUnchanged :: forall a b c.
(a -> b -> (a, c)) -> (a -> a -> Bool) -> a -> b -> (a, c)
iterateUntilUnchanged a -> b -> (a, c)
f a -> a -> Bool
eq a
aa b
b = a -> (a, c)
go a
aa
where
go :: a -> (a, c)
go a
a = if a -> a -> Bool
eq a
a a
a' then (a, c)
ac else a -> (a, c)
go a
a'
where
ac :: (a, c)
ac@(a
a', c
_) = a -> b -> (a, c)
f a
a b
b
linearLiveness
:: Instruction instr
=> BlockMap (UniqSet RegWithFormat) -> [LiveBasicBlock instr]
-> (BlockMap (UniqSet RegWithFormat), [LiveBasicBlock instr])
linearLiveness :: forall instr.
Instruction instr =>
BlockMap (UniqSet RegWithFormat)
-> [LiveBasicBlock instr]
-> (BlockMap (UniqSet RegWithFormat), [LiveBasicBlock instr])
linearLiveness = (BlockMap (UniqSet RegWithFormat)
-> LiveBasicBlock instr
-> (BlockMap (UniqSet RegWithFormat), LiveBasicBlock instr))
-> BlockMap (UniqSet RegWithFormat)
-> [LiveBasicBlock instr]
-> (BlockMap (UniqSet RegWithFormat), [LiveBasicBlock instr])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (Platform
-> BlockMap (UniqSet RegWithFormat)
-> LiveBasicBlock instr
-> (BlockMap (UniqSet RegWithFormat), LiveBasicBlock instr)
forall instr.
Instruction instr =>
Platform
-> BlockMap (UniqSet RegWithFormat)
-> LiveBasicBlock instr
-> (BlockMap (UniqSet RegWithFormat), LiveBasicBlock instr)
livenessBlock Platform
platform)
equalBlockMaps :: LabelMap b -> LabelMap b -> Bool
equalBlockMaps LabelMap b
a LabelMap b
b
= [(BlockId, b)]
a' [(BlockId, b)] -> [(BlockId, b)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(BlockId, b)]
b'
where a' :: [(BlockId, b)]
a' = LabelMap b -> [(BlockId, b)]
forall b. LabelMap b -> [(BlockId, b)]
mapToList LabelMap b
a
b' :: [(BlockId, b)]
b' = LabelMap b -> [(BlockId, b)]
forall b. LabelMap b -> [(BlockId, b)]
mapToList LabelMap b
b
livenessBlock
:: Instruction instr
=> Platform
-> BlockMap (UniqSet RegWithFormat)
-> LiveBasicBlock instr
-> (BlockMap (UniqSet RegWithFormat), LiveBasicBlock instr)
livenessBlock :: forall instr.
Instruction instr =>
Platform
-> BlockMap (UniqSet RegWithFormat)
-> LiveBasicBlock instr
-> (BlockMap (UniqSet RegWithFormat), LiveBasicBlock instr)
livenessBlock Platform
platform BlockMap (UniqSet RegWithFormat)
blockmap (BasicBlock BlockId
block_id [LiveInstr instr]
instrs)
= let
(UniqSet RegWithFormat
regsLiveOnEntry, [LiveInstr instr]
instrs1)
= Platform
-> UniqSet RegWithFormat
-> BlockMap (UniqSet RegWithFormat)
-> [LiveInstr instr]
-> [LiveInstr instr]
-> (UniqSet RegWithFormat, [LiveInstr instr])
forall instr.
Instruction instr =>
Platform
-> UniqSet RegWithFormat
-> BlockMap (UniqSet RegWithFormat)
-> [LiveInstr instr]
-> [LiveInstr instr]
-> (UniqSet RegWithFormat, [LiveInstr instr])
livenessBack Platform
platform UniqSet RegWithFormat
forall a. UniqSet a
emptyUniqSet BlockMap (UniqSet RegWithFormat)
blockmap [] ([LiveInstr instr] -> [LiveInstr instr]
forall a. [a] -> [a]
reverse [LiveInstr instr]
instrs)
blockmap' :: BlockMap (UniqSet RegWithFormat)
blockmap' = BlockId
-> UniqSet RegWithFormat
-> BlockMap (UniqSet RegWithFormat)
-> BlockMap (UniqSet RegWithFormat)
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
block_id UniqSet RegWithFormat
regsLiveOnEntry BlockMap (UniqSet RegWithFormat)
blockmap
instrs2 :: [LiveInstr instr]
instrs2 = Platform
-> UniqSet RegWithFormat -> [LiveInstr instr] -> [LiveInstr instr]
forall instr.
Instruction instr =>
Platform
-> UniqSet RegWithFormat -> [LiveInstr instr] -> [LiveInstr instr]
livenessForward Platform
platform UniqSet RegWithFormat
regsLiveOnEntry [LiveInstr instr]
instrs1
output :: GenBasicBlock (LiveInstr instr)
output = BlockId -> [LiveInstr instr] -> GenBasicBlock (LiveInstr instr)
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
block_id [LiveInstr instr]
instrs2
in ( BlockMap (UniqSet RegWithFormat)
blockmap', GenBasicBlock (LiveInstr instr)
output)
livenessForward
:: Instruction instr
=> Platform
-> UniqSet RegWithFormat
-> [LiveInstr instr] -> [LiveInstr instr]
livenessForward :: forall instr.
Instruction instr =>
Platform
-> UniqSet RegWithFormat -> [LiveInstr instr] -> [LiveInstr instr]
livenessForward Platform
_ UniqSet RegWithFormat
_ [] = []
livenessForward Platform
platform UniqSet RegWithFormat
rsLiveEntry (li :: LiveInstr instr
li@(LiveInstr InstrSR instr
instr Maybe Liveness
mLive) : [LiveInstr instr]
lis)
| Just Liveness
live <- Maybe Liveness
mLive
= let
RU [RegWithFormat]
_ [RegWithFormat]
written = Platform -> InstrSR instr -> RegUsage
forall instr. Instruction instr => Platform -> instr -> RegUsage
regUsageOfInstr Platform
platform InstrSR instr
instr
rsBorn :: UniqSet RegWithFormat
rsBorn = [RegWithFormat] -> UniqSet RegWithFormat
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet
([RegWithFormat] -> UniqSet RegWithFormat)
-> [RegWithFormat] -> UniqSet RegWithFormat
forall a b. (a -> b) -> a -> b
$ (RegWithFormat -> Bool) -> [RegWithFormat] -> [RegWithFormat]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ RegWithFormat
r -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Unique -> UniqSet RegWithFormat -> Bool
forall a. Unique -> UniqSet a -> Bool
elemUniqSet_Directly (RegWithFormat -> Unique
forall a. Uniquable a => a -> Unique
getUnique RegWithFormat
r) UniqSet RegWithFormat
rsLiveEntry)
([RegWithFormat] -> [RegWithFormat])
-> [RegWithFormat] -> [RegWithFormat]
forall a b. (a -> b) -> a -> b
$ [RegWithFormat]
written
rsLiveNext :: UniqSet RegWithFormat
rsLiveNext = (UniqSet RegWithFormat
rsLiveEntry UniqSet RegWithFormat
-> UniqSet RegWithFormat -> UniqSet RegWithFormat
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` UniqSet RegWithFormat
rsBorn)
UniqSet RegWithFormat
-> UniqSet RegWithFormat -> UniqSet RegWithFormat
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` (Liveness -> UniqSet RegWithFormat
liveDieRead Liveness
live)
UniqSet RegWithFormat
-> UniqSet RegWithFormat -> UniqSet RegWithFormat
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` (Liveness -> UniqSet RegWithFormat
liveDieWrite Liveness
live)
in InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr InstrSR instr
instr (Liveness -> Maybe Liveness
forall a. a -> Maybe a
Just Liveness
live { liveBorn = rsBorn })
LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: Platform
-> UniqSet RegWithFormat -> [LiveInstr instr] -> [LiveInstr instr]
forall instr.
Instruction instr =>
Platform
-> UniqSet RegWithFormat -> [LiveInstr instr] -> [LiveInstr instr]
livenessForward Platform
platform UniqSet RegWithFormat
rsLiveNext [LiveInstr instr]
lis
| Bool
otherwise
= LiveInstr instr
li LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: Platform
-> UniqSet RegWithFormat -> [LiveInstr instr] -> [LiveInstr instr]
forall instr.
Instruction instr =>
Platform
-> UniqSet RegWithFormat -> [LiveInstr instr] -> [LiveInstr instr]
livenessForward Platform
platform UniqSet RegWithFormat
rsLiveEntry [LiveInstr instr]
lis
livenessBack
:: Instruction instr
=> Platform
-> UniqSet RegWithFormat
-> BlockMap (UniqSet RegWithFormat)
-> [LiveInstr instr]
-> [LiveInstr instr]
-> (UniqSet RegWithFormat, [LiveInstr instr])
livenessBack :: forall instr.
Instruction instr =>
Platform
-> UniqSet RegWithFormat
-> BlockMap (UniqSet RegWithFormat)
-> [LiveInstr instr]
-> [LiveInstr instr]
-> (UniqSet RegWithFormat, [LiveInstr instr])
livenessBack Platform
_ UniqSet RegWithFormat
liveregs BlockMap (UniqSet RegWithFormat)
_ [LiveInstr instr]
done [] = (UniqSet RegWithFormat
liveregs, [LiveInstr instr]
done)
livenessBack Platform
platform UniqSet RegWithFormat
liveregs BlockMap (UniqSet RegWithFormat)
blockmap [LiveInstr instr]
acc (LiveInstr instr
instr : [LiveInstr instr]
instrs)
= let !(!UniqSet RegWithFormat
liveregs', LiveInstr instr
instr') = Platform
-> UniqSet RegWithFormat
-> BlockMap (UniqSet RegWithFormat)
-> LiveInstr instr
-> (UniqSet RegWithFormat, LiveInstr instr)
forall instr.
Instruction instr =>
Platform
-> UniqSet RegWithFormat
-> BlockMap (UniqSet RegWithFormat)
-> LiveInstr instr
-> (UniqSet RegWithFormat, LiveInstr instr)
liveness1 Platform
platform UniqSet RegWithFormat
liveregs BlockMap (UniqSet RegWithFormat)
blockmap LiveInstr instr
instr
in Platform
-> UniqSet RegWithFormat
-> BlockMap (UniqSet RegWithFormat)
-> [LiveInstr instr]
-> [LiveInstr instr]
-> (UniqSet RegWithFormat, [LiveInstr instr])
forall instr.
Instruction instr =>
Platform
-> UniqSet RegWithFormat
-> BlockMap (UniqSet RegWithFormat)
-> [LiveInstr instr]
-> [LiveInstr instr]
-> (UniqSet RegWithFormat, [LiveInstr instr])
livenessBack Platform
platform UniqSet RegWithFormat
liveregs' BlockMap (UniqSet RegWithFormat)
blockmap (LiveInstr instr
instr' LiveInstr instr -> [LiveInstr instr] -> [LiveInstr instr]
forall a. a -> [a] -> [a]
: [LiveInstr instr]
acc) [LiveInstr instr]
instrs
liveness1
:: Instruction instr
=> Platform
-> UniqSet RegWithFormat
-> BlockMap (UniqSet RegWithFormat)
-> LiveInstr instr
-> (UniqSet RegWithFormat, LiveInstr instr)
liveness1 :: forall instr.
Instruction instr =>
Platform
-> UniqSet RegWithFormat
-> BlockMap (UniqSet RegWithFormat)
-> LiveInstr instr
-> (UniqSet RegWithFormat, LiveInstr instr)
liveness1 Platform
_ UniqSet RegWithFormat
liveregs BlockMap (UniqSet RegWithFormat)
_ (LiveInstr InstrSR instr
instr Maybe Liveness
_)
| InstrSR instr -> Bool
forall instr. Instruction instr => instr -> Bool
isMetaInstr InstrSR instr
instr
= (UniqSet RegWithFormat
liveregs, InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr InstrSR instr
instr Maybe Liveness
forall a. Maybe a
Nothing)
liveness1 Platform
platform UniqSet RegWithFormat
liveregs BlockMap (UniqSet RegWithFormat)
blockmap (LiveInstr InstrSR instr
instr Maybe Liveness
_)
| Bool
not_a_branch
= (UniqSet RegWithFormat
liveregs1, InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr InstrSR instr
instr
(Liveness -> Maybe Liveness
forall a. a -> Maybe a
Just (Liveness -> Maybe Liveness) -> Liveness -> Maybe Liveness
forall a b. (a -> b) -> a -> b
$ Liveness
{ liveBorn :: UniqSet RegWithFormat
liveBorn = UniqSet RegWithFormat
forall a. UniqSet a
emptyUniqSet
, liveDieRead :: UniqSet RegWithFormat
liveDieRead = UniqSet RegWithFormat
r_dying
, liveDieWrite :: UniqSet RegWithFormat
liveDieWrite = UniqSet RegWithFormat
w_dying }))
| Bool
otherwise
= (UniqSet RegWithFormat
liveregs_br, InstrSR instr -> Maybe Liveness -> LiveInstr instr
forall instr. InstrSR instr -> Maybe Liveness -> LiveInstr instr
LiveInstr InstrSR instr
instr
(Liveness -> Maybe Liveness
forall a. a -> Maybe a
Just (Liveness -> Maybe Liveness) -> Liveness -> Maybe Liveness
forall a b. (a -> b) -> a -> b
$ Liveness
{ liveBorn :: UniqSet RegWithFormat
liveBorn = UniqSet RegWithFormat
forall a. UniqSet a
emptyUniqSet
, liveDieRead :: UniqSet RegWithFormat
liveDieRead = UniqSet RegWithFormat
r_dying_br
, liveDieWrite :: UniqSet RegWithFormat
liveDieWrite = UniqSet RegWithFormat
w_dying }))
where
!(RU [RegWithFormat]
read [RegWithFormat]
written) = Platform -> InstrSR instr -> RegUsage
forall instr. Instruction instr => Platform -> instr -> RegUsage
regUsageOfInstr Platform
platform InstrSR instr
instr
liveregs1 :: UniqSet RegWithFormat
liveregs1 = (UniqSet RegWithFormat
liveregs UniqSet RegWithFormat -> [RegWithFormat] -> UniqSet RegWithFormat
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
`delListFromUniqSet` [RegWithFormat]
written)
UniqSet RegWithFormat -> [RegWithFormat] -> UniqSet RegWithFormat
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
`addListToUniqSet` [RegWithFormat]
read
r_dying :: UniqSet RegWithFormat
r_dying = [RegWithFormat] -> UniqSet RegWithFormat
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet
[ RegWithFormat
reg
| reg :: RegWithFormat
reg@(RegWithFormat Reg
r Format
_) <- [RegWithFormat]
read
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (RegWithFormat -> Bool) -> [RegWithFormat] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ RegWithFormat
w -> RegWithFormat -> Unique
forall a. Uniquable a => a -> Unique
getUnique RegWithFormat
w Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Reg -> Unique
forall a. Uniquable a => a -> Unique
getUnique Reg
r) [RegWithFormat]
written
, Bool -> Bool
not (RegWithFormat -> UniqSet RegWithFormat -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet RegWithFormat
reg UniqSet RegWithFormat
liveregs) ]
w_dying :: UniqSet RegWithFormat
w_dying = [RegWithFormat] -> UniqSet RegWithFormat
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet
[ RegWithFormat
reg
| RegWithFormat
reg <- [RegWithFormat]
written
, Bool -> Bool
not (RegWithFormat -> UniqSet RegWithFormat -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet RegWithFormat
reg UniqSet RegWithFormat
liveregs) ]
targets :: [BlockId]
targets = InstrSR instr -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr InstrSR instr
instr
not_a_branch :: Bool
not_a_branch = [BlockId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
targets
targetLiveRegs :: BlockId -> UniqSet RegWithFormat
targetLiveRegs BlockId
target
= case BlockId
-> BlockMap (UniqSet RegWithFormat)
-> Maybe (UniqSet RegWithFormat)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
target BlockMap (UniqSet RegWithFormat)
blockmap of
Just UniqSet RegWithFormat
ra -> UniqSet RegWithFormat
ra
Maybe (UniqSet RegWithFormat)
Nothing -> UniqSet RegWithFormat
forall a. UniqSet a
emptyUniqSet
live_from_branch :: UniqSet RegWithFormat
live_from_branch = [UniqSet RegWithFormat] -> UniqSet RegWithFormat
forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets ((BlockId -> UniqSet RegWithFormat)
-> [BlockId] -> [UniqSet RegWithFormat]
forall a b. (a -> b) -> [a] -> [b]
map BlockId -> UniqSet RegWithFormat
targetLiveRegs [BlockId]
targets)
liveregs_br :: UniqSet RegWithFormat
liveregs_br = UniqSet RegWithFormat
liveregs1 UniqSet RegWithFormat
-> UniqSet RegWithFormat -> UniqSet RegWithFormat
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` UniqSet RegWithFormat
live_from_branch
live_branch_only :: UniqSet RegWithFormat
live_branch_only = UniqSet RegWithFormat
live_from_branch UniqSet RegWithFormat
-> UniqSet RegWithFormat -> UniqSet RegWithFormat
forall a. UniqSet a -> UniqSet a -> UniqSet a
`minusUniqSet` UniqSet RegWithFormat
liveregs
r_dying_br :: UniqSet RegWithFormat
r_dying_br = (UniqSet RegWithFormat
r_dying UniqSet RegWithFormat
-> UniqSet RegWithFormat -> UniqSet RegWithFormat
forall a. UniqSet a -> UniqSet a -> UniqSet a
`unionUniqSets` UniqSet RegWithFormat
live_branch_only)