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