{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module GHC.CmmToAsm.Reg.Graph (
regAlloc
) where
import GHC.Prelude
import qualified GHC.Data.Graph.Color as Color
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Reg.Graph.Spill
import GHC.CmmToAsm.Reg.Graph.SpillClean
import GHC.CmmToAsm.Reg.Graph.SpillCost
import GHC.CmmToAsm.Reg.Graph.Stats
import GHC.CmmToAsm.Reg.Graph.TrivColorable
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Reg.Target
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Types
import GHC.Platform.Reg.Class
import GHC.Platform.Reg
import GHC.Data.Bag
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Types.Unique.Supply
import GHC.Utils.Misc (seqList)
import GHC.CmmToAsm.CFG
import Data.Maybe
import Control.Monad
maxSpinCount :: Int
maxSpinCount :: Int
maxSpinCount = Int
10
regAlloc
:: (OutputableP Platform statics, Instruction instr)
=> NCGConfig
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM ( [NatCmmDecl statics instr]
, Maybe Int, [RegAllocStats statics instr] )
regAlloc :: forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
NCGConfig
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM
([NatCmmDecl statics instr], Maybe Int,
[RegAllocStats statics instr])
regAlloc NCGConfig
config UniqFM RegClass (UniqSet RealReg)
regsFree UniqSet Int
slotsFree Int
slotsCount [LiveCmmDecl statics instr]
code Maybe CFG
cfg
= do
let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
triv :: Triv VirtualReg RegClass RealReg
triv = Platform
-> (RegClass -> VirtualReg -> Int)
-> (RegClass -> RealReg -> Int)
-> Triv VirtualReg RegClass RealReg
trivColorable Platform
platform
(Platform -> RegClass -> VirtualReg -> Int
targetVirtualRegSqueeze Platform
platform)
(Platform -> RegClass -> RealReg -> Int
targetRealRegSqueeze Platform
platform)
([NatCmmDecl statics instr]
code_final, [RegAllocStats statics instr]
debug_codeGraphs, Int
slotsCount', Graph VirtualReg RegClass RealReg
_)
<- forall instr statics.
(Instruction instr, OutputableP Platform statics) =>
NCGConfig
-> Int
-> Triv VirtualReg RegClass RealReg
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [RegAllocStats statics instr]
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM
([NatCmmDecl statics instr], [RegAllocStats statics instr], Int,
Graph VirtualReg RegClass RealReg)
regAlloc_spin NCGConfig
config Int
0
Triv VirtualReg RegClass RealReg
triv
UniqFM RegClass (UniqSet RealReg)
regsFree UniqSet Int
slotsFree Int
slotsCount [] [LiveCmmDecl statics instr]
code Maybe CFG
cfg
let needStack :: Maybe Int
needStack
| Int
slotsCount forall a. Eq a => a -> a -> Bool
== Int
slotsCount'
= forall a. Maybe a
Nothing
| Bool
otherwise
= forall a. a -> Maybe a
Just Int
slotsCount'
forall (m :: * -> *) a. Monad m => a -> m a
return ( [NatCmmDecl statics instr]
code_final
, Maybe Int
needStack
, forall a. [a] -> [a]
reverse [RegAllocStats statics instr]
debug_codeGraphs )
regAlloc_spin
:: forall instr statics.
(Instruction instr,
OutputableP Platform statics)
=> NCGConfig
-> Int
-> Color.Triv VirtualReg RegClass RealReg
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [RegAllocStats statics instr]
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM ( [NatCmmDecl statics instr]
, [RegAllocStats statics instr]
, Int
, Color.Graph VirtualReg RegClass RealReg)
regAlloc_spin :: forall instr statics.
(Instruction instr, OutputableP Platform statics) =>
NCGConfig
-> Int
-> Triv VirtualReg RegClass RealReg
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [RegAllocStats statics instr]
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM
([NatCmmDecl statics instr], [RegAllocStats statics instr], Int,
Graph VirtualReg RegClass RealReg)
regAlloc_spin NCGConfig
config Int
spinCount Triv VirtualReg RegClass RealReg
triv UniqFM RegClass (UniqSet RealReg)
regsFree UniqSet Int
slotsFree Int
slotsCount [RegAllocStats statics instr]
debug_codeGraphs [LiveCmmDecl statics instr]
code Maybe CFG
cfg
= do
let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
let dump :: Bool
dump = forall (t :: * -> *). Foldable t => t Bool -> Bool
or
[ NCGConfig -> Bool
ncgDumpRegAllocStages NCGConfig
config
, NCGConfig -> Bool
ncgDumpAsmStats NCGConfig
config
, NCGConfig -> Bool
ncgDumpAsmConflicts NCGConfig
config
]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
spinCount forall a. Ord a => a -> a -> Bool
> Int
maxSpinCount)
forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"regAlloc_spin: max build/spill cycle count exceeded."
( String -> SDoc
text String
"It looks like the register allocator is stuck in an infinite loop."
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"max cycles = " SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
maxSpinCount
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"regsFree = " SDoc -> SDoc -> SDoc
<> ([SDoc] -> SDoc
hcat forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
space forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr
forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet forall a b. (a -> b) -> a -> b
$ forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets
forall a b. (a -> b) -> a -> b
$ forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM RegClass (UniqSet RealReg)
regsFree)
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"slotsFree = " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (forall a. UniqSet a -> Int
sizeUniqSet UniqSet Int
slotsFree))
(Graph VirtualReg RegClass RealReg
graph :: Color.Graph VirtualReg RegClass RealReg)
<- {-# SCC "BuildGraph" #-} forall instr statics.
Instruction instr =>
[LiveCmmDecl statics instr]
-> UniqSM (Graph VirtualReg RegClass RealReg)
buildGraph [LiveCmmDecl statics instr]
code
Graph VirtualReg RegClass RealReg -> ()
seqGraph Graph VirtualReg RegClass RealReg
graph seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return ()
let spillCosts :: SpillCostInfo
spillCosts = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SpillCostInfo -> SpillCostInfo -> SpillCostInfo
plusSpillCostInfo SpillCostInfo
zeroSpillCostInfo
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall instr statics.
Instruction instr =>
Platform -> Maybe CFG -> LiveCmmDecl statics instr -> SpillCostInfo
slurpSpillCostInfo Platform
platform Maybe CFG
cfg) [LiveCmmDecl statics instr]
code
let spill :: Graph VirtualReg RegClass RealReg -> VirtualReg
spill = SpillCostInfo -> Graph VirtualReg RegClass RealReg -> VirtualReg
chooseSpill SpillCostInfo
spillCosts
let stat1 :: Maybe (RegAllocStats statics instr)
stat1
= if Int
spinCount forall a. Eq a => a -> a -> Bool
== Int
0
then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RegAllocStatsStart
{ raLiveCmm :: [LiveCmmDecl statics instr]
raLiveCmm = [LiveCmmDecl statics instr]
code
, raGraph :: Graph VirtualReg RegClass RealReg
raGraph = Graph VirtualReg RegClass RealReg
graph
, raSpillCosts :: SpillCostInfo
raSpillCosts = SpillCostInfo
spillCosts
, raPlatform :: Platform
raPlatform = Platform
platform
}
else forall a. Maybe a
Nothing
let (Graph VirtualReg RegClass RealReg
graph_colored, UniqSet VirtualReg
rsSpill, UniqFM VirtualReg VirtualReg
rmCoalesce)
= {-# SCC "ColorGraph" #-}
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Eq cls, Ord k,
Outputable k, Outputable cls, Outputable color) =>
Bool
-> Int
-> UniqFM cls (UniqSet color)
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> (Graph k cls color, UniqSet k, UniqFM k k)
Color.colorGraph
(NCGConfig -> Bool
ncgRegsIterative NCGConfig
config)
Int
spinCount
UniqFM RegClass (UniqSet RealReg)
regsFree Triv VirtualReg RegClass RealReg
triv Graph VirtualReg RegClass RealReg -> VirtualReg
spill Graph VirtualReg RegClass RealReg
graph
let patchF :: Reg -> Reg
patchF Reg
reg
| RegVirtual VirtualReg
vr <- Reg
reg
= case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM VirtualReg VirtualReg
rmCoalesce VirtualReg
vr of
Just VirtualReg
vr' -> Reg -> Reg
patchF (VirtualReg -> Reg
RegVirtual VirtualReg
vr')
Maybe VirtualReg
Nothing -> Reg
reg
| Bool
otherwise
= Reg
reg
let ([LiveCmmDecl statics instr]
code_coalesced :: [LiveCmmDecl statics instr])
= forall a b. (a -> b) -> [a] -> [b]
map (forall instr statics.
Instruction instr =>
(Reg -> Reg)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
patchEraseLive Reg -> Reg
patchF) [LiveCmmDecl statics instr]
code
if forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet VirtualReg
rsSpill
then do
let graph_colored_lint :: Graph VirtualReg RegClass RealReg
graph_colored_lint =
if NCGConfig -> Bool
ncgAsmLinting NCGConfig
config
then forall k color cls.
(Uniquable k, Outputable k, Eq color) =>
SDoc -> Bool -> Graph k cls color -> Graph k cls color
Color.validateGraph (String -> SDoc
text String
"")
Bool
True
Graph VirtualReg RegClass RealReg
graph_colored
else Graph VirtualReg RegClass RealReg
graph_colored
let code_patched :: [LiveCmmDecl statics instr]
code_patched
= forall a b. (a -> b) -> [a] -> [b]
map (forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
Platform
-> Graph VirtualReg RegClass RealReg
-> LiveCmmDecl statics instr
-> LiveCmmDecl statics instr
patchRegsFromGraph Platform
platform Graph VirtualReg RegClass RealReg
graph_colored_lint)
[LiveCmmDecl statics instr]
code_coalesced
let code_spillclean :: [LiveCmmDecl statics instr]
code_spillclean
= forall a b. (a -> b) -> [a] -> [b]
map (forall instr statics.
Instruction instr =>
Platform -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
cleanSpills Platform
platform) [LiveCmmDecl statics instr]
code_patched
let code_final :: [NatCmmDecl statics instr]
code_final
= forall a b. (a -> b) -> [a] -> [b]
map (forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
NCGConfig -> LiveCmmDecl statics instr -> NatCmmDecl statics instr
stripLive NCGConfig
config) [LiveCmmDecl statics instr]
code_spillclean
let stat :: RegAllocStats statics instr
stat
= RegAllocStatsColored
{ raCode :: [LiveCmmDecl statics instr]
raCode = [LiveCmmDecl statics instr]
code
, raGraph :: Graph VirtualReg RegClass RealReg
raGraph = Graph VirtualReg RegClass RealReg
graph
, raGraphColored :: Graph VirtualReg RegClass RealReg
raGraphColored = Graph VirtualReg RegClass RealReg
graph_colored_lint
, raCoalesced :: UniqFM VirtualReg VirtualReg
raCoalesced = UniqFM VirtualReg VirtualReg
rmCoalesce
, raCodeCoalesced :: [LiveCmmDecl statics instr]
raCodeCoalesced = [LiveCmmDecl statics instr]
code_coalesced
, raPatched :: [LiveCmmDecl statics instr]
raPatched = [LiveCmmDecl statics instr]
code_patched
, raSpillClean :: [LiveCmmDecl statics instr]
raSpillClean = [LiveCmmDecl statics instr]
code_spillclean
, raFinal :: [NatCmmDecl statics instr]
raFinal = [NatCmmDecl statics instr]
code_final
, raSRMs :: (Int, Int, Int)
raSRMs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
addSRM (Int
0, Int
0, Int
0)
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> (Int, Int, Int)
countSRMs [LiveCmmDecl statics instr]
code_spillclean
, raPlatform :: Platform
raPlatform = Platform
platform
}
let statList :: [RegAllocStats statics instr]
statList =
if Bool
dump then [RegAllocStats statics instr
stat] forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList Maybe (RegAllocStats statics instr)
stat1 forall a. [a] -> [a] -> [a]
++ [RegAllocStats statics instr]
debug_codeGraphs
else []
forall a b. [a] -> b -> b
seqList [RegAllocStats statics instr]
statList (forall (m :: * -> *) a. Monad m => a -> m a
return ())
forall (m :: * -> *) a. Monad m => a -> m a
return ( [NatCmmDecl statics instr]
code_final
, [RegAllocStats statics instr]
statList
, Int
slotsCount
, Graph VirtualReg RegClass RealReg
graph_colored_lint)
else do
let graph_colored_lint :: Graph VirtualReg RegClass RealReg
graph_colored_lint =
if NCGConfig -> Bool
ncgAsmLinting NCGConfig
config
then forall k color cls.
(Uniquable k, Outputable k, Eq color) =>
SDoc -> Bool -> Graph k cls color -> Graph k cls color
Color.validateGraph (String -> SDoc
text String
"")
Bool
False
Graph VirtualReg RegClass RealReg
graph_colored
else Graph VirtualReg RegClass RealReg
graph_colored
([LiveCmmDecl statics instr]
code_spilled, UniqSet Int
slotsFree', Int
slotsCount', SpillStats
spillStats)
<- forall instr statics.
Instruction instr =>
Platform
-> [LiveCmmDecl statics instr]
-> UniqSet Int
-> Int
-> UniqSet VirtualReg
-> UniqSM
([LiveCmmDecl statics instr], UniqSet Int, Int, SpillStats)
regSpill Platform
platform [LiveCmmDecl statics instr]
code_coalesced UniqSet Int
slotsFree Int
slotsCount UniqSet VirtualReg
rsSpill
[LiveCmmDecl statics instr]
code_relive <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall instr statics.
Instruction instr =>
Platform
-> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)
regLiveness Platform
platform forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall statics instr.
LiveCmmDecl statics instr -> LiveCmmDecl statics instr
reverseBlocksInTops)
[LiveCmmDecl statics instr]
code_spilled
let stat :: RegAllocStats statics instr
stat =
RegAllocStatsSpill
{ raCode :: [LiveCmmDecl statics instr]
raCode = [LiveCmmDecl statics instr]
code
, raGraph :: Graph VirtualReg RegClass RealReg
raGraph = Graph VirtualReg RegClass RealReg
graph_colored_lint
, raCoalesced :: UniqFM VirtualReg VirtualReg
raCoalesced = UniqFM VirtualReg VirtualReg
rmCoalesce
, raSpillStats :: SpillStats
raSpillStats = SpillStats
spillStats
, raSpillCosts :: SpillCostInfo
raSpillCosts = SpillCostInfo
spillCosts
, raSpilled :: [LiveCmmDecl statics instr]
raSpilled = [LiveCmmDecl statics instr]
code_spilled
, raPlatform :: Platform
raPlatform = Platform
platform }
let statList :: [RegAllocStats statics instr]
statList =
if Bool
dump
then [RegAllocStats statics instr
stat] forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList Maybe (RegAllocStats statics instr)
stat1 forall a. [a] -> [a] -> [a]
++ [RegAllocStats statics instr]
debug_codeGraphs
else []
forall a b. [a] -> b -> b
seqList [RegAllocStats statics instr]
statList (forall (m :: * -> *) a. Monad m => a -> m a
return ())
forall instr statics.
(Instruction instr, OutputableP Platform statics) =>
NCGConfig
-> Int
-> Triv VirtualReg RegClass RealReg
-> UniqFM RegClass (UniqSet RealReg)
-> UniqSet Int
-> Int
-> [RegAllocStats statics instr]
-> [LiveCmmDecl statics instr]
-> Maybe CFG
-> UniqSM
([NatCmmDecl statics instr], [RegAllocStats statics instr], Int,
Graph VirtualReg RegClass RealReg)
regAlloc_spin NCGConfig
config (Int
spinCount forall a. Num a => a -> a -> a
+ Int
1) Triv VirtualReg RegClass RealReg
triv UniqFM RegClass (UniqSet RealReg)
regsFree UniqSet Int
slotsFree'
Int
slotsCount' [RegAllocStats statics instr]
statList [LiveCmmDecl statics instr]
code_relive Maybe CFG
cfg
buildGraph
:: Instruction instr
=> [LiveCmmDecl statics instr]
-> UniqSM (Color.Graph VirtualReg RegClass RealReg)
buildGraph :: forall instr statics.
Instruction instr =>
[LiveCmmDecl statics instr]
-> UniqSM (Graph VirtualReg RegClass RealReg)
buildGraph [LiveCmmDecl statics instr]
code
= do
let ([Bag (UniqSet Reg)]
conflictList, [Bag (Reg, Reg)]
moveList) =
forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall instr statics.
Instruction instr =>
LiveCmmDecl statics instr -> (Bag (UniqSet Reg), Bag (Reg, Reg))
slurpConflicts [LiveCmmDecl statics instr]
code
let moveList2 :: [Bag (Reg, Reg)]
moveList2 = forall a b. (a -> b) -> [a] -> [b]
map forall statics instr.
Instruction instr =>
LiveCmmDecl statics instr -> Bag (Reg, Reg)
slurpReloadCoalesce [LiveCmmDecl statics instr]
code
let conflictBag :: Bag (UniqSet Reg)
conflictBag = forall a. [Bag a] -> Bag a
unionManyBags [Bag (UniqSet Reg)]
conflictList
let graph_conflict :: Graph VirtualReg RegClass RealReg
graph_conflict
= forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr UniqSet Reg
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
graphAddConflictSet forall k cls color. Graph k cls color
Color.initGraph Bag (UniqSet Reg)
conflictBag
let moveBag :: Bag (Reg, Reg)
moveBag
= forall a. Bag a -> Bag a -> Bag a
unionBags (forall a. [Bag a] -> Bag a
unionManyBags [Bag (Reg, Reg)]
moveList2)
(forall a. [Bag a] -> Bag a
unionManyBags [Bag (Reg, Reg)]
moveList)
let graph_coalesce :: Graph VirtualReg RegClass RealReg
graph_coalesce
= forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Reg, Reg)
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
graphAddCoalesce Graph VirtualReg RegClass RealReg
graph_conflict Bag (Reg, Reg)
moveBag
forall (m :: * -> *) a. Monad m => a -> m a
return Graph VirtualReg RegClass RealReg
graph_coalesce
graphAddConflictSet
:: UniqSet Reg
-> Color.Graph VirtualReg RegClass RealReg
-> Color.Graph VirtualReg RegClass RealReg
graphAddConflictSet :: UniqSet Reg
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
graphAddConflictSet UniqSet Reg
set Graph VirtualReg RegClass RealReg
graph
= let virtuals :: UniqSet VirtualReg
virtuals = forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet
[ VirtualReg
vr | RegVirtual VirtualReg
vr <- forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Reg
set ]
graph1 :: Graph VirtualReg RegClass RealReg
graph1 = forall k cls color.
Uniquable k =>
UniqSet k -> (k -> cls) -> Graph k cls color -> Graph k cls color
Color.addConflicts UniqSet VirtualReg
virtuals VirtualReg -> RegClass
classOfVirtualReg Graph VirtualReg RegClass RealReg
graph
graph2 :: Graph VirtualReg RegClass RealReg
graph2 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(VirtualReg
r1, RealReg
r2) -> forall k color cls.
(Uniquable k, Uniquable color) =>
k -> (k -> cls) -> color -> Graph k cls color -> Graph k cls color
Color.addExclusion VirtualReg
r1 VirtualReg -> RegClass
classOfVirtualReg RealReg
r2)
Graph VirtualReg RegClass RealReg
graph1
[ (VirtualReg
vr, RealReg
rr)
| RegVirtual VirtualReg
vr <- forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Reg
set
, RegReal RealReg
rr <- forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Reg
set]
in Graph VirtualReg RegClass RealReg
graph2
graphAddCoalesce
:: (Reg, Reg)
-> Color.Graph VirtualReg RegClass RealReg
-> Color.Graph VirtualReg RegClass RealReg
graphAddCoalesce :: (Reg, Reg)
-> Graph VirtualReg RegClass RealReg
-> Graph VirtualReg RegClass RealReg
graphAddCoalesce (Reg
r1, Reg
r2) Graph VirtualReg RegClass RealReg
graph
| RegReal RealReg
rr <- Reg
r1
, RegVirtual VirtualReg
vr <- Reg
r2
= forall k cls color.
Uniquable k =>
(k, cls) -> color -> Graph k cls color -> Graph k cls color
Color.addPreference (VirtualReg
vr, VirtualReg -> RegClass
classOfVirtualReg VirtualReg
vr) RealReg
rr Graph VirtualReg RegClass RealReg
graph
| RegReal RealReg
rr <- Reg
r2
, RegVirtual VirtualReg
vr <- Reg
r1
= forall k cls color.
Uniquable k =>
(k, cls) -> color -> Graph k cls color -> Graph k cls color
Color.addPreference (VirtualReg
vr, VirtualReg -> RegClass
classOfVirtualReg VirtualReg
vr) RealReg
rr Graph VirtualReg RegClass RealReg
graph
| RegVirtual VirtualReg
vr1 <- Reg
r1
, RegVirtual VirtualReg
vr2 <- Reg
r2
= forall k cls color.
Uniquable k =>
(k, cls) -> (k, cls) -> Graph k cls color -> Graph k cls color
Color.addCoalesce
(VirtualReg
vr1, VirtualReg -> RegClass
classOfVirtualReg VirtualReg
vr1)
(VirtualReg
vr2, VirtualReg -> RegClass
classOfVirtualReg VirtualReg
vr2)
Graph VirtualReg RegClass RealReg
graph
| RegReal RealReg
_ <- Reg
r1
, RegReal RealReg
_ <- Reg
r2
= Graph VirtualReg RegClass RealReg
graph
#if __GLASGOW_HASKELL__ <= 810
| otherwise
= panic "graphAddCoalesce"
#endif
patchRegsFromGraph
:: (OutputableP Platform statics, Instruction instr)
=> Platform -> Color.Graph VirtualReg RegClass RealReg
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
patchRegsFromGraph :: forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
Platform
-> Graph VirtualReg RegClass RealReg
-> LiveCmmDecl statics instr
-> LiveCmmDecl statics instr
patchRegsFromGraph Platform
platform Graph VirtualReg RegClass RealReg
graph LiveCmmDecl statics instr
code
= forall instr statics.
Instruction instr =>
(Reg -> Reg)
-> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
patchEraseLive Reg -> Reg
patchF LiveCmmDecl statics instr
code
where
patchF :: Reg -> Reg
patchF Reg
reg
| RegReal{} <- Reg
reg
= Reg
reg
| RegVirtual VirtualReg
vr <- Reg
reg
, Just Node VirtualReg RegClass RealReg
node <- forall k cls color.
Uniquable k =>
Graph k cls color -> k -> Maybe (Node k cls color)
Color.lookupNode Graph VirtualReg RegClass RealReg
graph VirtualReg
vr
= case forall k cls color. Node k cls color -> Maybe color
Color.nodeColor Node VirtualReg RegClass RealReg
node of
Just RealReg
color -> RealReg -> Reg
RegReal RealReg
color
Maybe RealReg
Nothing -> VirtualReg -> Reg
RegVirtual VirtualReg
vr
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"patchRegsFromGraph: register mapping failed."
( String -> SDoc
text String
"There is no node in the graph for register "
SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Reg
reg
SDoc -> SDoc -> SDoc
$$ forall statics instr.
(OutputableP Platform statics, Instruction instr) =>
Platform -> LiveCmmDecl statics instr -> SDoc
pprLiveCmmDecl Platform
platform LiveCmmDecl statics instr
code
SDoc -> SDoc -> SDoc
$$ forall k cls color.
(Uniquable k, Outputable k, Outputable cls, Outputable color) =>
(color -> SDoc) -> Triv k cls color -> Graph k cls color -> SDoc
Color.dotGraph
(\RealReg
_ -> String -> SDoc
text String
"white")
(Platform
-> (RegClass -> VirtualReg -> Int)
-> (RegClass -> RealReg -> Int)
-> Triv VirtualReg RegClass RealReg
trivColorable Platform
platform
(Platform -> RegClass -> VirtualReg -> Int
targetVirtualRegSqueeze Platform
platform)
(Platform -> RegClass -> RealReg -> Int
targetRealRegSqueeze Platform
platform))
Graph VirtualReg RegClass RealReg
graph)
seqGraph :: Color.Graph VirtualReg RegClass RealReg -> ()
seqGraph :: Graph VirtualReg RegClass RealReg -> ()
seqGraph Graph VirtualReg RegClass RealReg
graph = [Node VirtualReg RegClass RealReg] -> ()
seqNodes (forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM (forall k cls color.
Graph k cls color -> UniqFM k (Node k cls color)
Color.graphMap Graph VirtualReg RegClass RealReg
graph))
seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> ()
seqNodes :: [Node VirtualReg RegClass RealReg] -> ()
seqNodes [Node VirtualReg RegClass RealReg]
ns
= case [Node VirtualReg RegClass RealReg]
ns of
[] -> ()
(Node VirtualReg RegClass RealReg
n : [Node VirtualReg RegClass RealReg]
ns) -> Node VirtualReg RegClass RealReg -> ()
seqNode Node VirtualReg RegClass RealReg
n seq :: forall a b. a -> b -> b
`seq` [Node VirtualReg RegClass RealReg] -> ()
seqNodes [Node VirtualReg RegClass RealReg]
ns
seqNode :: Color.Node VirtualReg RegClass RealReg -> ()
seqNode :: Node VirtualReg RegClass RealReg -> ()
seqNode Node VirtualReg RegClass RealReg
node
= VirtualReg -> ()
seqVirtualReg (forall k cls color. Node k cls color -> k
Color.nodeId Node VirtualReg RegClass RealReg
node)
seq :: forall a b. a -> b -> b
`seq` RegClass -> ()
seqRegClass (forall k cls color. Node k cls color -> cls
Color.nodeClass Node VirtualReg RegClass RealReg
node)
seq :: forall a b. a -> b -> b
`seq` Maybe RealReg -> ()
seqMaybeRealReg (forall k cls color. Node k cls color -> Maybe color
Color.nodeColor Node VirtualReg RegClass RealReg
node)
seq :: forall a b. a -> b -> b
`seq` ([VirtualReg] -> ()
seqVirtualRegList (forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (forall k cls color. Node k cls color -> UniqSet k
Color.nodeConflicts Node VirtualReg RegClass RealReg
node)))
seq :: forall a b. a -> b -> b
`seq` ([RealReg] -> ()
seqRealRegList (forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (forall k cls color. Node k cls color -> UniqSet color
Color.nodeExclusions Node VirtualReg RegClass RealReg
node)))
seq :: forall a b. a -> b -> b
`seq` ([RealReg] -> ()
seqRealRegList (forall k cls color. Node k cls color -> [color]
Color.nodePreference Node VirtualReg RegClass RealReg
node))
seq :: forall a b. a -> b -> b
`seq` ([VirtualReg] -> ()
seqVirtualRegList (forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (forall k cls color. Node k cls color -> UniqSet k
Color.nodeCoalesce Node VirtualReg RegClass RealReg
node)))
seqVirtualReg :: VirtualReg -> ()
seqVirtualReg :: VirtualReg -> ()
seqVirtualReg VirtualReg
reg = VirtualReg
reg seq :: forall a b. a -> b -> b
`seq` ()
seqRealReg :: RealReg -> ()
seqRealReg :: RealReg -> ()
seqRealReg RealReg
reg = RealReg
reg seq :: forall a b. a -> b -> b
`seq` ()
seqRegClass :: RegClass -> ()
seqRegClass :: RegClass -> ()
seqRegClass RegClass
c = RegClass
c seq :: forall a b. a -> b -> b
`seq` ()
seqMaybeRealReg :: Maybe RealReg -> ()
seqMaybeRealReg :: Maybe RealReg -> ()
seqMaybeRealReg Maybe RealReg
mr
= case Maybe RealReg
mr of
Maybe RealReg
Nothing -> ()
Just RealReg
r -> RealReg -> ()
seqRealReg RealReg
r
seqVirtualRegList :: [VirtualReg] -> ()
seqVirtualRegList :: [VirtualReg] -> ()
seqVirtualRegList [VirtualReg]
rs
= case [VirtualReg]
rs of
[] -> ()
(VirtualReg
r : [VirtualReg]
rs) -> VirtualReg -> ()
seqVirtualReg VirtualReg
r seq :: forall a b. a -> b -> b
`seq` [VirtualReg] -> ()
seqVirtualRegList [VirtualReg]
rs
seqRealRegList :: [RealReg] -> ()
seqRealRegList :: [RealReg] -> ()
seqRealRegList [RealReg]
rs
= case [RealReg]
rs of
[] -> ()
(RealReg
r : [RealReg]
rs) -> RealReg -> ()
seqRealReg RealReg
r seq :: forall a b. a -> b -> b
`seq` [RealReg] -> ()
seqRealRegList [RealReg]
rs