module RegAlloc.Graph.Main (
regAlloc
)
where
import qualified GraphColor as Color
import RegAlloc.Liveness
import RegAlloc.Graph.Spill
import RegAlloc.Graph.SpillClean
import RegAlloc.Graph.SpillCost
import RegAlloc.Graph.Stats
import RegAlloc.Graph.TrivColorable
import Instruction
import TargetReg
import RegClass
import Reg
import UniqSupply
import UniqSet
import UniqFM
import Bag
import Outputable
import DynFlags
import Data.List
import Data.Maybe
import Control.Monad
maxSpinCount :: Int
maxSpinCount = 10
regAlloc
:: (Outputable instr, Instruction instr)
=> DynFlags
-> UniqFM (UniqSet RealReg)
-> UniqSet Int
-> [LiveCmmTop instr]
-> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] )
regAlloc dflags regsFree slotsFree code
= do
let triv = trivColorable
targetVirtualRegSqueeze
targetRealRegSqueeze
(code_final, debug_codeGraphs, _)
<- regAlloc_spin dflags 0
triv
regsFree slotsFree [] code
return ( code_final
, reverse debug_codeGraphs )
regAlloc_spin
dflags
spinCount
(triv :: Color.Triv VirtualReg RegClass RealReg)
(regsFree :: UniqFM (UniqSet RealReg))
slotsFree
debug_codeGraphs
code
= do
let dump = or
[ dopt Opt_D_dump_asm_regalloc_stages dflags
, dopt Opt_D_dump_asm_stats dflags
, dopt Opt_D_dump_asm_conflicts dflags ]
when (spinCount > maxSpinCount)
$ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
( text "It looks like the register allocator is stuck in an infinite loop."
$$ text "max cycles = " <> int maxSpinCount
$$ text "regsFree = " <> (hcat $ punctuate space $ map ppr
$ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree)
$$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree))
(graph :: Color.Graph VirtualReg RegClass RealReg)
<- buildGraph code
seqGraph graph `seq` return ()
let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo
$ map slurpSpillCostInfo code
let spill = chooseSpill spillCosts
let stat1 =
if spinCount == 0
then Just $ RegAllocStatsStart
{ raLiveCmm = code
, raGraph = graph
, raSpillCosts = spillCosts }
else Nothing
let (graph_colored, rsSpill, rmCoalesce)
=
Color.colorGraph
(dopt Opt_RegsIterative dflags)
spinCount
regsFree triv spill graph
let patchF reg
| RegVirtual vr <- reg
= case lookupUFM rmCoalesce vr of
Just vr' -> patchF (RegVirtual vr')
Nothing -> reg
| otherwise
= reg
let code_coalesced
= map (patchEraseLive patchF) code
if isEmptyUniqSet rsSpill
then do
let graph_colored_lint =
if dopt Opt_DoAsmLinting dflags
then Color.validateGraph (text "")
True
graph_colored
else graph_colored
let code_patched = map (patchRegsFromGraph graph_colored_lint) code_coalesced
let code_spillclean = map cleanSpills code_patched
let code_final = map stripLive code_spillclean
let stat =
RegAllocStatsColored
{ raCode = code
, raGraph = graph
, raGraphColored = graph_colored_lint
, raCoalesced = rmCoalesce
, raCodeCoalesced = code_coalesced
, raPatched = code_patched
, raSpillClean = code_spillclean
, raFinal = code_final
, raSRMs = foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean }
let statList =
if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
else []
seqList statList `seq` return ()
return ( code_final
, statList
, graph_colored_lint)
else do
let graph_colored_lint =
if dopt Opt_DoAsmLinting dflags
then Color.validateGraph (text "")
False
graph_colored
else graph_colored
(code_spilled, slotsFree', spillStats)
<- regSpill code_coalesced slotsFree rsSpill
code_relive <- mapM (regLiveness . reverseBlocksInTops) code_spilled
let stat =
RegAllocStatsSpill
{ raCode = code
, raGraph = graph_colored_lint
, raCoalesced = rmCoalesce
, raSpillStats = spillStats
, raSpillCosts = spillCosts
, raSpilled = code_spilled }
let statList =
if dump
then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
else []
seqList statList `seq` return ()
regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
statList
code_relive
buildGraph
:: Instruction instr
=> [LiveCmmTop instr]
-> UniqSM (Color.Graph VirtualReg RegClass RealReg)
buildGraph code
= do
let (conflictList, moveList) =
unzip $ map slurpConflicts code
let moveList2 = map slurpReloadCoalesce code
let conflictBag = unionManyBags conflictList
let graph_conflict = foldrBag graphAddConflictSet Color.initGraph conflictBag
let moveBag = unionBags (unionManyBags moveList2) (unionManyBags moveList)
let graph_coalesce = foldrBag graphAddCoalesce graph_conflict moveBag
return graph_coalesce
graphAddConflictSet
:: UniqSet Reg
-> Color.Graph VirtualReg RegClass RealReg
-> Color.Graph VirtualReg RegClass RealReg
graphAddConflictSet set graph
= let virtuals = mkUniqSet
[ vr | RegVirtual vr <- uniqSetToList set ]
graph1 = Color.addConflicts virtuals classOfVirtualReg graph
graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2)
graph1
[ (vr, rr)
| RegVirtual vr <- uniqSetToList set
, RegReal rr <- uniqSetToList set]
in graph2
graphAddCoalesce
:: (Reg, Reg)
-> Color.Graph VirtualReg RegClass RealReg
-> Color.Graph VirtualReg RegClass RealReg
graphAddCoalesce (r1, r2) graph
| RegReal rr <- r1
, RegVirtual vr <- r2
= Color.addPreference (vr, classOfVirtualReg vr) rr graph
| RegReal rr <- r2
, RegVirtual vr <- r1
= Color.addPreference (vr, classOfVirtualReg vr) rr graph
| RegVirtual vr1 <- r1
, RegVirtual vr2 <- r2
= Color.addCoalesce
(vr1, classOfVirtualReg vr1)
(vr2, classOfVirtualReg vr2)
graph
| RegReal _ <- r1
, RegReal _ <- r2
= graph
graphAddCoalesce _ _
= panic "graphAddCoalesce: bogus"
patchRegsFromGraph
:: (Outputable instr, Instruction instr)
=> Color.Graph VirtualReg RegClass RealReg
-> LiveCmmTop instr -> LiveCmmTop instr
patchRegsFromGraph graph code
= let
patchF reg
| RegReal{} <- reg
= reg
| RegVirtual vr <- reg
, Just node <- Color.lookupNode graph vr
= case Color.nodeColor node of
Just color -> RegReal color
Nothing -> RegVirtual vr
| otherwise
= pprPanic "patchRegsFromGraph: register mapping failed."
( text "There is no node in the graph for register " <> ppr reg
$$ ppr code
$$ Color.dotGraph
(\_ -> text "white")
(trivColorable
targetVirtualRegSqueeze
targetRealRegSqueeze)
graph)
in patchEraseLive patchF code
seqGraph :: Color.Graph VirtualReg RegClass RealReg -> ()
seqGraph graph = seqNodes (eltsUFM (Color.graphMap graph))
seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> ()
seqNodes ns
= case ns of
[] -> ()
(n : ns) -> seqNode n `seq` seqNodes ns
seqNode :: Color.Node VirtualReg RegClass RealReg -> ()
seqNode node
= seqVirtualReg (Color.nodeId node)
`seq` seqRegClass (Color.nodeClass node)
`seq` seqMaybeRealReg (Color.nodeColor node)
`seq` (seqVirtualRegList (uniqSetToList (Color.nodeConflicts node)))
`seq` (seqRealRegList (uniqSetToList (Color.nodeExclusions node)))
`seq` (seqRealRegList (Color.nodePreference node))
`seq` (seqVirtualRegList (uniqSetToList (Color.nodeCoalesce node)))
seqVirtualReg :: VirtualReg -> ()
seqVirtualReg reg = reg `seq` ()
seqRealReg :: RealReg -> ()
seqRealReg reg = reg `seq` ()
seqRegClass :: RegClass -> ()
seqRegClass c = c `seq` ()
seqMaybeRealReg :: Maybe RealReg -> ()
seqMaybeRealReg mr
= case mr of
Nothing -> ()
Just r -> seqRealReg r
seqVirtualRegList :: [VirtualReg] -> ()
seqVirtualRegList rs
= case rs of
[] -> ()
(r : rs) -> seqVirtualReg r `seq` seqVirtualRegList rs
seqRealRegList :: [RealReg] -> ()
seqRealRegList rs
= case rs of
[] -> ()
(r : rs) -> seqRealReg r `seq` seqRealRegList rs
seqList :: [a] -> ()
seqList ls
= case ls of
[] -> ()
(r : rs) -> r `seq` seqList rs