--
module RegAlloc.Graph.Main (
- regAlloc,
- regDotColor
+ regAlloc
)
where
import qualified GraphColor as Color
-import RegLiveness
+import qualified GraphBase as Color
+import RegAlloc.Liveness
import RegAlloc.Graph.Spill
import RegAlloc.Graph.SpillClean
import RegAlloc.Graph.SpillCost
import RegAlloc.Graph.Stats
-import Regs
-import Instrs
-import PprMach
+import RegAlloc.Graph.TrivColorable
+import Instruction
+import TargetReg
+import RegClass
+import Reg
+
import UniqSupply
import UniqSet
-- | The top level of the graph coloring register allocator.
--
regAlloc
- :: DynFlags
- -> UniqFM (UniqSet Reg) -- ^ the registers we can use for allocation
+ :: (Outputable instr, Instruction instr)
+ => DynFlags
+ -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation
-> UniqSet Int -- ^ the set of available spill slots.
- -> [LiveCmmTop] -- ^ code annotated with liveness information.
- -> UniqSM ( [NatCmmTop], [RegAllocStats] )
+ -> [LiveCmmTop instr] -- ^ code annotated with liveness information.
+ -> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] )
-- ^ code with registers allocated and stats for each stage of
-- allocation
regAlloc dflags regsFree slotsFree code
= do
+ -- TODO: the regClass function is currently hard coded to the default target
+ -- architecture. Would prefer to determine this from dflags.
+ -- There are other uses of targetRegClass later in this module.
+ let triv = trivColorable
+ targetVirtualRegSqueeze
+ targetRealRegSqueeze
+
(code_final, debug_codeGraphs, _)
- <- regAlloc_spin dflags 0 trivColorable regsFree slotsFree [] code
+ <- regAlloc_spin dflags 0
+ triv
+ regsFree slotsFree [] code
return ( code_final
, reverse debug_codeGraphs )
-regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
+regAlloc_spin
+ dflags
+ spinCount
+ (triv :: Color.Triv VirtualReg RegClass RealReg)
+ (regsFree :: UniqFM (UniqSet RealReg))
+ slotsFree
+ debug_codeGraphs
+ code
= do
-- if any of these dump flags are turned on we want to hang on to
-- intermediate structures in the allocator - otherwise tell the
$ 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 (docToSDoc . pprUserReg)
+ $$ text "regsFree = " <> (hcat $ punctuate space $ map ppr
$ uniqSetToList $ unionManyUniqSets $ eltsUFM regsFree)
$$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree))
-- build a conflict graph from the code.
- graph <- {-# SCC "BuildGraph" #-} buildGraph code
+ (graph :: Color.Graph VirtualReg RegClass RealReg)
+ <- {-# SCC "BuildGraph" #-} buildGraph code
-- VERY IMPORTANT:
-- We really do want the graph to be fully evaluated _before_ we start coloring.
regsFree triv spill graph
-- rewrite regs in the code that have been coalesced
- let patchF reg = case lookupUFM rmCoalesce reg of
- Just reg' -> patchF reg'
- Nothing -> reg
+ 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
-- clean out unneeded SPILL/RELOADs
let code_spillclean = map cleanSpills code_patched
- -- strip off liveness information
- let code_nat = map stripLive code_spillclean
+ -- strip off liveness information,
+ -- and rewrite SPILL/RELOAD pseudos into real instructions along the way
+ let code_final = map stripLive code_spillclean
- -- rewrite SPILL/RELOAD pseudos into real instructions
- let spillNatTop = mapGenBlockTop spillNatBlock
- let code_final = map spillNatTop code_nat
+-- let spillNatTop = mapGenBlockTop spillNatBlock
+-- let code_final = map spillNatTop code_nat
-- record what happened in this stage for debugging
let stat =
-- | Build a graph from the liveness and coalesce information in this code.
buildGraph
- :: [LiveCmmTop]
- -> UniqSM (Color.Graph Reg RegClass Reg)
+ :: Instruction instr
+ => [LiveCmmTop instr]
+ -> UniqSM (Color.Graph VirtualReg RegClass RealReg)
buildGraph code
= do
--
graphAddConflictSet
:: UniqSet Reg
- -> Color.Graph Reg RegClass Reg
- -> Color.Graph Reg RegClass Reg
+ -> Color.Graph VirtualReg RegClass RealReg
+ -> Color.Graph VirtualReg RegClass RealReg
graphAddConflictSet set graph
- = let reals = filterUFM isRealReg set
- virtuals = filterUFM (not . isRealReg) set
+ = let virtuals = mkUniqSet
+ [ vr | RegVirtual vr <- uniqSetToList set ]
- graph1 = Color.addConflicts virtuals regClass graph
- graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 regClass r2)
+ graph1 = Color.addConflicts virtuals classOfVirtualReg graph
+
+ graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2)
graph1
- [ (a, b)
- | a <- uniqSetToList virtuals
- , b <- uniqSetToList reals]
+ [ (vr, rr)
+ | RegVirtual vr <- uniqSetToList set
+ , RegReal rr <- uniqSetToList set]
in graph2
--
graphAddCoalesce
:: (Reg, Reg)
- -> Color.Graph Reg RegClass Reg
- -> Color.Graph Reg RegClass Reg
+ -> Color.Graph VirtualReg RegClass RealReg
+ -> Color.Graph VirtualReg RegClass RealReg
graphAddCoalesce (r1, r2) graph
- | RealReg _ <- r1
- = Color.addPreference (regWithClass r2) r1 graph
+ | RegReal rr <- r1
+ , RegVirtual vr <- r2
+ = Color.addPreference (vr, classOfVirtualReg vr) rr graph
- | RealReg _ <- r2
- = Color.addPreference (regWithClass r1) r2 graph
+ | RegReal rr <- r2
+ , RegVirtual vr <- r1
+ = Color.addPreference (vr, classOfVirtualReg vr) rr graph
- | otherwise
- = Color.addCoalesce (regWithClass r1) (regWithClass r2) graph
+ | RegVirtual vr1 <- r1
+ , RegVirtual vr2 <- r2
+ = Color.addCoalesce
+ (vr1, classOfVirtualReg vr1)
+ (vr2, classOfVirtualReg vr2)
+ graph
- where regWithClass r = (r, regClass r)
+ | otherwise
+ = panic "RegAlloc.Graph.Main.graphAddCoalesce: can't coalesce two real regs"
-- | Patch registers in code using the reg -> reg mapping in this graph.
patchRegsFromGraph
- :: Color.Graph Reg RegClass Reg
- -> LiveCmmTop -> LiveCmmTop
+ :: (Outputable instr, Instruction instr)
+ => Color.Graph VirtualReg RegClass RealReg
+ -> LiveCmmTop instr -> LiveCmmTop instr
patchRegsFromGraph graph code
= let
-- a function to lookup the hardreg for a virtual reg from the graph.
patchF reg
-- leave real regs alone.
- | isRealReg reg
+ | RegReal{} <- reg
= reg
-- this virtual has a regular node in the graph.
- | Just node <- Color.lookupNode graph reg
+ | RegVirtual vr <- reg
+ , Just node <- Color.lookupNode graph vr
= case Color.nodeColor node of
- Just color -> color
- Nothing -> reg
+ Just color -> RegReal color
+ Nothing -> RegVirtual vr
-- no node in the graph for this virtual, bad news.
| 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 graph)
+ $$ Color.dotGraph
+ (\_ -> text "white")
+ (trivColorable
+ targetVirtualRegSqueeze
+ targetRealRegSqueeze)
+ graph)
in patchEraseLive patchF code
-----
-- for when laziness just isn't what you wanted...
--
-seqGraph :: Color.Graph Reg RegClass Reg -> ()
+seqGraph :: Color.Graph VirtualReg RegClass RealReg -> ()
seqGraph graph = seqNodes (eltsUFM (Color.graphMap graph))
-seqNodes :: [Color.Node Reg RegClass Reg] -> ()
+seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> ()
seqNodes ns
= case ns of
[] -> ()
(n : ns) -> seqNode n `seq` seqNodes ns
-seqNode :: Color.Node Reg RegClass Reg -> ()
+seqNode :: Color.Node VirtualReg RegClass RealReg -> ()
seqNode node
- = seqReg (Color.nodeId node)
- `seq` seqRegClass (Color.nodeClass node)
- `seq` seqMaybeReg (Color.nodeColor node)
- `seq` (seqRegList (uniqSetToList (Color.nodeConflicts node)))
- `seq` (seqRegList (uniqSetToList (Color.nodeExclusions node)))
- `seq` (seqRegList (Color.nodePreference node))
- `seq` (seqRegList (uniqSetToList (Color.nodeCoalesce node)))
-
-seqReg :: Reg -> ()
-seqReg reg
+ = 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
= case reg of
- RealReg _ -> ()
VirtualRegI _ -> ()
VirtualRegHi _ -> ()
VirtualRegF _ -> ()
VirtualRegD _ -> ()
+seqRealReg :: RealReg -> ()
+seqRealReg reg
+ = case reg of
+ RealRegSingle _ -> ()
+ RealRegPair _ _ -> ()
+
seqRegClass :: RegClass -> ()
seqRegClass c
= case c of
RcFloat -> ()
RcDouble -> ()
-seqMaybeReg :: Maybe Reg -> ()
-seqMaybeReg mr
+seqMaybeRealReg :: Maybe RealReg -> ()
+seqMaybeRealReg mr
= case mr of
Nothing -> ()
- Just r -> seqReg r
+ Just r -> seqRealReg r
+
+seqVirtualRegList :: [VirtualReg] -> ()
+seqVirtualRegList rs
+ = case rs of
+ [] -> ()
+ (r : rs) -> seqVirtualReg r `seq` seqVirtualRegList rs
-seqRegList :: [Reg] -> ()
-seqRegList rs
+seqRealRegList :: [RealReg] -> ()
+seqRealRegList rs
= case rs of
[] -> ()
- (r : rs) -> seqReg r `seq` seqRegList rs
+ (r : rs) -> seqRealReg r `seq` seqRealRegList rs
seqList :: [a] -> ()
seqList ls
projects / ghc-hetmet.git / blobdiff