summaryrefslogtreecommitdiff
path: root/compiler/nativeGen/RegAlloc/Graph
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/nativeGen/RegAlloc/Graph')
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/Main.hs146
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/Spill.hs6
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/SpillClean.hs5
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/SpillCost.hs71
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/Stats.hs40
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs253
6 files changed, 317 insertions, 204 deletions
diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs
index 2e584617e9..94b18aeb0a 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs
@@ -11,6 +11,7 @@ module RegAlloc.Graph.Main (
where
import qualified GraphColor as Color
+import qualified GraphBase as Color
import RegAlloc.Liveness
import RegAlloc.Graph.Spill
import RegAlloc.Graph.SpillClean
@@ -47,7 +48,7 @@ maxSpinCount = 10
regAlloc
:: (Outputable instr, Instruction instr)
=> DynFlags
- -> UniqFM (UniqSet Reg) -- ^ the registers we can use for allocation
+ -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation
-> UniqSet Int -- ^ the set of available spill slots.
-> [LiveCmmTop instr] -- ^ code annotated with liveness information.
-> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] )
@@ -59,7 +60,9 @@ regAlloc dflags regsFree slotsFree code
-- 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 targetRegClass
+ let triv = trivColorable
+ targetVirtualRegSqueeze
+ targetRealRegSqueeze
(code_final, debug_codeGraphs, _)
<- regAlloc_spin dflags 0
@@ -69,7 +72,14 @@ regAlloc dflags 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
@@ -89,7 +99,8 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
$$ 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.
@@ -125,9 +136,15 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
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
@@ -225,7 +242,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
buildGraph
:: Instruction instr
=> [LiveCmmTop instr]
- -> UniqSM (Color.Graph Reg RegClass Reg)
+ -> UniqSM (Color.Graph VirtualReg RegClass RealReg)
buildGraph code
= do
@@ -252,19 +269,20 @@ buildGraph code
--
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 targetRegClass graph
- graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 targetRegClass 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
@@ -274,26 +292,33 @@ graphAddConflictSet set graph
--
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, targetRegClass 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
:: (Outputable instr, Instruction instr)
- => Color.Graph Reg RegClass Reg
+ => Color.Graph VirtualReg RegClass RealReg
-> LiveCmmTop instr -> LiveCmmTop instr
patchRegsFromGraph graph code
@@ -301,21 +326,27 @@ patchRegsFromGraph graph code
-- 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 targetRegClass) graph)
+ $$ Color.dotGraph
+ (\_ -> text "white")
+ (trivColorable
+ targetVirtualRegSqueeze
+ targetRealRegSqueeze)
+ graph)
in patchEraseLive patchF code
@@ -323,34 +354,39 @@ patchRegsFromGraph graph 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
@@ -358,17 +394,23 @@ seqRegClass c
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
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
index e6e5622a02..ce34b513a1 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -37,7 +37,7 @@ regSpill
:: Instruction instr
=> [LiveCmmTop instr] -- ^ the code
-> UniqSet Int -- ^ available stack slots
- -> UniqSet Reg -- ^ the regs to spill
+ -> UniqSet VirtualReg -- ^ the regs to spill
-> UniqSM
([LiveCmmTop instr] -- code will spill instructions
, UniqSet Int -- left over slots
@@ -190,7 +190,9 @@ patchInstr
patchInstr reg instr
= do nUnique <- newUnique
- let nReg = renameVirtualReg nUnique reg
+ let nReg = case reg of
+ RegVirtual vr -> RegVirtual (renameVirtualReg nUnique vr)
+ RegReal{} -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg"
let instr' = patchReg1 reg nReg instr
return (instr', nReg)
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
index 4f129c468a..9d0dcf9236 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -436,9 +436,12 @@ isStoreReg ss
--
instance Uniquable Store where
getUnique (SReg r)
- | RealReg i <- r
+ | RegReal (RealRegSingle i) <- r
= mkUnique 'R' i
+ | RegReal (RealRegPair r1 r2) <- r
+ = mkUnique 'P' (r1 * 65535 + r2)
+
| otherwise
= error "RegSpillClean.getUnique: found virtual reg during spill clean, only real regs expected."
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
index d4dd75a4b7..ff3f76a545 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -36,10 +36,10 @@ import Data.Maybe
import Control.Monad
type SpillCostRecord
- = ( Reg -- register name
- , Int -- number of writes to this reg
- , Int -- number of reads from this reg
- , Int) -- number of instrs this reg was live on entry to
+ = ( VirtualReg -- register name
+ , Int -- number of writes to this reg
+ , Int -- number of reads from this reg
+ , Int) -- number of instrs this reg was live on entry to
type SpillCostInfo
= UniqFM SpillCostRecord
@@ -83,7 +83,11 @@ slurpSpillCostInfo cmm
countBlock info (BasicBlock blockId instrs)
| LiveInfo _ _ blockLive <- info
, Just rsLiveEntry <- lookupBlockEnv blockLive blockId
- = countLIs rsLiveEntry instrs
+
+ , rsLiveEntry_virt <- mapUniqSet (\(RegVirtual vr) -> vr)
+ $ filterUniqSet isVirtualReg rsLiveEntry
+
+ = countLIs rsLiveEntry_virt instrs
| otherwise
= error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block"
@@ -113,16 +117,24 @@ slurpSpillCostInfo cmm
-- increment counts for what regs were read/written from
let (RU read written) = regUsageOfInstr instr
- mapM_ incUses $ filter (not . isRealReg) $ nub read
- mapM_ incDefs $ filter (not . isRealReg) $ nub written
+ mapM_ incUses $ catMaybes $ map takeVirtualReg $ nub read
+ mapM_ incDefs $ catMaybes $ map takeVirtualReg $ nub written
-- compute liveness for entry to next instruction.
+ let takeVirtuals set
+ = mapUniqSet (\(RegVirtual vr) -> vr)
+ $ filterUniqSet isVirtualReg set
+
+ let liveDieRead_virt = takeVirtuals (liveDieRead live)
+ let liveDieWrite_virt = takeVirtuals (liveDieWrite live)
+ let liveBorn_virt = takeVirtuals (liveBorn live)
+
let rsLiveAcross
- = rsLiveEntry `minusUniqSet` (liveDieRead live)
+ = rsLiveEntry `minusUniqSet` liveDieRead_virt
let rsLiveNext
- = (rsLiveAcross `unionUniqSets` (liveBorn live))
- `minusUniqSet` (liveDieWrite live)
+ = (rsLiveAcross `unionUniqSets` liveBorn_virt)
+ `minusUniqSet` liveDieWrite_virt
countLIs rsLiveNext lis
@@ -135,8 +147,8 @@ slurpSpillCostInfo cmm
chooseSpill
:: SpillCostInfo
- -> Graph Reg RegClass Reg
- -> Reg
+ -> Graph VirtualReg RegClass RealReg
+ -> VirtualReg
chooseSpill info graph
= let cost = spillCost_length info graph
@@ -212,19 +224,20 @@ spillCost_chaitin info graph reg
-- Just spill the longest live range.
spillCost_length
:: SpillCostInfo
- -> Graph Reg RegClass Reg
- -> Reg
+ -> Graph VirtualReg RegClass RealReg
+ -> VirtualReg
-> Float
spillCost_length info _ reg
| lifetime <= 1 = 1/0
| otherwise = 1 / fromIntegral lifetime
where (_, _, _, lifetime)
- = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg
+ = fromMaybe (reg, 0, 0, 0)
+ $ lookupUFM info reg
-lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (Reg, Int)
+lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int)
lifeMapFromSpillCostInfo info
= listToUFM
$ map (\(r, _, _, life) -> (r, (r, life)))
@@ -233,13 +246,19 @@ lifeMapFromSpillCostInfo info
-- | Work out the degree (number of neighbors) of this node which have the same class.
nodeDegree
- :: (Reg -> RegClass)
- -> Graph Reg RegClass Reg -> Reg -> Int
+ :: (VirtualReg -> RegClass)
+ -> Graph VirtualReg RegClass RealReg
+ -> VirtualReg
+ -> Int
-nodeDegree regClass graph reg
+nodeDegree classOfVirtualReg graph reg
| Just node <- lookupUFM (graphMap graph) reg
- , virtConflicts <- length $ filter (\r -> regClass r == regClass reg)
- $ uniqSetToList $ nodeConflicts node
+
+ , virtConflicts <- length
+ $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg)
+ $ uniqSetToList
+ $ nodeConflicts node
+
= virtConflicts + sizeUniqSet (nodeExclusions node)
| otherwise
@@ -248,16 +267,20 @@ nodeDegree regClass graph reg
-- | Show a spill cost record, including the degree from the graph and final calulated spill cos
pprSpillCostRecord
- :: (Reg -> RegClass)
+ :: (VirtualReg -> RegClass)
-> (Reg -> SDoc)
- -> Graph Reg RegClass Reg -> SpillCostRecord -> SDoc
+ -> Graph VirtualReg RegClass RealReg
+ -> SpillCostRecord
+ -> SDoc
pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life)
= hsep
- [ pprReg reg
+ [ pprReg (RegVirtual reg)
, ppr uses
, ppr defs
, ppr life
, ppr $ nodeDegree regClass graph reg
, text $ show $ (fromIntegral (uses + defs)
/ fromIntegral (nodeDegree regClass graph reg) :: Float) ]
+
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
index 5e3dd3265b..10ab0cbcfb 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
@@ -39,27 +39,27 @@ data RegAllocStats instr
-- initial graph
= RegAllocStatsStart
- { raLiveCmm :: [LiveCmmTop instr] -- ^ initial code, with liveness
- , raGraph :: Color.Graph Reg RegClass Reg -- ^ the initial, uncolored graph
- , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill
+ { raLiveCmm :: [LiveCmmTop instr] -- ^ initial code, with liveness
+ , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the initial, uncolored graph
+ , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill
-- a spill stage
| RegAllocStatsSpill
- { raGraph :: Color.Graph Reg RegClass Reg -- ^ the partially colored graph
- , raCoalesced :: UniqFM Reg -- ^ the regs that were coaleced
- , raSpillStats :: SpillStats -- ^ spiller stats
- , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for
- , raSpilled :: [LiveCmmTop instr] } -- ^ code with spill instructions added
+ { raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the partially colored graph
+ , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced
+ , raSpillStats :: SpillStats -- ^ spiller stats
+ , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for
+ , raSpilled :: [LiveCmmTop instr] } -- ^ code with spill instructions added
-- a successful coloring
| RegAllocStatsColored
- { raGraph :: Color.Graph Reg RegClass Reg -- ^ the uncolored graph
- , raGraphColored :: Color.Graph Reg RegClass Reg -- ^ the coalesced and colored graph
- , raCoalesced :: UniqFM Reg -- ^ the regs that were coaleced
- , raPatched :: [LiveCmmTop instr] -- ^ code with vregs replaced by hregs
- , raSpillClean :: [LiveCmmTop instr] -- ^ code with unneeded spill\/reloads cleaned out
- , raFinal :: [NatCmmTop instr] -- ^ final code
- , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code
+ { raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the uncolored graph
+ , raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- ^ the coalesced and colored graph
+ , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced
+ , raPatched :: [LiveCmmTop instr] -- ^ code with vregs replaced by hregs
+ , raSpillClean :: [LiveCmmTop instr] -- ^ code with unneeded spill\/reloads cleaned out
+ , raFinal :: [NatCmmTop instr] -- ^ final code
+ , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code
instance Outputable instr => Outputable (RegAllocStats instr) where
@@ -132,7 +132,11 @@ instance Outputable instr => Outputable (RegAllocStats instr) where
$$ text ""
-- | Do all the different analysis on this list of RegAllocStats
-pprStats :: [RegAllocStats instr] -> Color.Graph Reg RegClass Reg -> SDoc
+pprStats
+ :: [RegAllocStats instr]
+ -> Color.Graph VirtualReg RegClass RealReg
+ -> SDoc
+
pprStats stats graph
= let outSpills = pprStatsSpills stats
outLife = pprStatsLifetimes stats
@@ -176,7 +180,7 @@ pprStatsLifetimes stats
$$ (vcat $ map ppr $ eltsUFM lifeBins)
$$ text "\n")
-binLifetimeCount :: UniqFM (Reg, Int) -> UniqFM (Int, Int)
+binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int)
binLifetimeCount fm
= let lifes = map (\l -> (l, (l, 1)))
$ map snd
@@ -208,7 +212,7 @@ pprStatsConflict stats
-- good for making a scatter plot.
pprStatsLifeConflict
:: [RegAllocStats instr]
- -> Color.Graph Reg RegClass Reg -- ^ global register conflict graph
+ -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph
-> SDoc
pprStatsLifeConflict stats graph
diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
index df04606313..5f3f0ac495 100644
--- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS -fno-warn-unused-binds #-}
module RegAlloc.Graph.TrivColorable (
trivColorable,
@@ -15,51 +16,136 @@ import GraphBase
import UniqFM
import FastTypes
-{-
--- allocatableRegs is allMachRegNos with the fixed-use regs removed.
--- i.e., these are the regs for which we are prepared to allow the
--- register allocator to attempt to map VRegs to.
-allocatableRegs :: [RegNo]
-allocatableRegs
- = let isFree i = isFastTrue (freeReg i)
- in filter isFree allMachRegNos
-
-
--- | The number of regs in each class.
--- We go via top level CAFs to ensure that we're not recomputing
--- the length of these lists each time the fn is called.
-allocatableRegsInClass :: RegClass -> Int
-allocatableRegsInClass cls
- = case cls of
- RcInteger -> allocatableRegsInteger
- RcDouble -> allocatableRegsDouble
- RcFloat -> panic "Regs.allocatableRegsInClass: no match\n"
-
-allocatableRegsInteger :: Int
-allocatableRegsInteger
- = length $ filter (\r -> regClass r == RcInteger)
- $ map RealReg allocatableRegs
-
-allocatableRegsDouble :: Int
-allocatableRegsDouble
- = length $ filter (\r -> regClass r == RcDouble)
- $ map RealReg allocatableRegs
--}
-
-- trivColorable ---------------------------------------------------------------
-- trivColorable function for the graph coloring allocator
+--
-- This gets hammered by scanGraph during register allocation,
-- so needs to be fairly efficient.
--
-- NOTE: This only works for arcitectures with just RcInteger and RcDouble
-- (which are disjoint) ie. x86, x86_64 and ppc
--
-
-- BL 2007/09
-- Doing a nice fold over the UniqSet makes trivColorable use
-- 32% of total compile time and 42% of total alloc when compiling SHA1.lhs from darcs.
+--
+-- The number of allocatable regs is hard coded here so we can do a fast
+-- comparision in trivColorable.
+--
+-- It's ok if these numbers are _less_ than the actual number of free regs,
+-- but they can't be more or the register conflict graph won't color.
+--
+-- If the graph doesn't color then the allocator will panic, but it won't
+-- generate bad object code or anything nasty like that.
+--
+-- There is an allocatableRegsInClass :: RegClass -> Int, but doing the unboxing
+-- is too slow for us here.
+--
+-- Look at includes/MachRegs.h to get these numbers.
+--
+
+#if i386_TARGET_ARCH
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(3))
+#define ALLOCATABLE_REGS_DOUBLE (_ILIT(6))
+#define ALLOCATABLE_REGS_FLOAT (_ILIT(0))
+
+
+#elif x86_64_TARGET_ARCH
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(5))
+#define ALLOCATABLE_REGS_DOUBLE (_ILIT(2))
+#define ALLOCATABLE_REGS_FLOAT (_ILIT(0))
+
+
+#elif powerpc_TARGET_ARCH
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(16))
+#define ALLOCATABLE_REGS_DOUBLE (_ILIT(26))
+#define ALLOCATABLE_REGS_FLOAT (_ILIT(0))
+
+
+#elif sparc_TARGET_ARCH
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(14))
+#define ALLOCATABLE_REGS_DOUBLE (_ILIT(11))
+#define ALLOCATABLE_REGS_FLOAT (_ILIT(22))
+
+
+#else
+#error ToDo: choose which trivColorable function to use for this architecture.
+#endif
+
+
+
+-- Disjoint registers ----------------------------------------------------------
+--
+-- The definition has been unfolded into individual cases for speed.
+-- Each architecture has a different register setup, so we use a
+-- different regSqueeze function for each.
+--
+accSqueeze
+ :: FastInt
+ -> FastInt
+ -> (reg -> FastInt)
+ -> UniqFM reg
+ -> FastInt
+
+accSqueeze count maxCount squeeze ufm
+ = case ufm of
+ NodeUFM _ _ left right
+ -> case accSqueeze count maxCount squeeze right of
+ count' -> case count' >=# maxCount of
+ False -> accSqueeze count' maxCount squeeze left
+ True -> count'
+
+ LeafUFM _ reg -> count +# squeeze reg
+ EmptyUFM -> count
+
+
+trivColorable
+ :: (RegClass -> VirtualReg -> FastInt)
+ -> (RegClass -> RealReg -> FastInt)
+ -> Triv VirtualReg RegClass RealReg
+
+trivColorable virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions
+ | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_INTEGER
+ (virtualRegSqueeze RcInteger)
+ conflicts
+
+ , count3 <- accSqueeze count2 ALLOCATABLE_REGS_INTEGER
+ (realRegSqueeze RcInteger)
+ exclusions
+
+ = count3 <# ALLOCATABLE_REGS_INTEGER
+
+trivColorable virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions
+ | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_FLOAT
+ (virtualRegSqueeze RcFloat)
+ conflicts
+
+ , count3 <- accSqueeze count2 ALLOCATABLE_REGS_FLOAT
+ (realRegSqueeze RcFloat)
+ exclusions
+
+ = count3 <# ALLOCATABLE_REGS_FLOAT
+
+trivColorable virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions
+ | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_DOUBLE
+ (virtualRegSqueeze RcDouble)
+ conflicts
+
+ , count3 <- accSqueeze count2 ALLOCATABLE_REGS_DOUBLE
+ (realRegSqueeze RcDouble)
+ exclusions
+
+ = count3 <# ALLOCATABLE_REGS_DOUBLE
+
+
+-- Specification Code ----------------------------------------------------------
+--
+-- The trivColorable function for each particular architecture should
+-- implement the following function, but faster.
+--
+
{-
trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool
trivColorable classN conflicts exclusions
@@ -69,14 +155,14 @@ trivColorable classN conflicts exclusions
acc r (cd, cf)
= case regClass r of
RcInteger -> (cd+1, cf)
- RcDouble -> (cd, cf+1)
+ RcFloat -> (cd, cf+1)
_ -> panic "Regs.trivColorable: reg class not handled"
tmp = foldUniqSet acc (0, 0) conflicts
(countInt, countFloat) = foldUniqSet acc tmp exclusions
squeese = worst countInt classN RcInteger
- + worst countFloat classN RcDouble
+ + worst countFloat classN RcFloat
in squeese < allocatableRegsInClass classN
@@ -92,85 +178,38 @@ worst n classN classC
RcInteger
-> case classC of
RcInteger -> min n (allocatableRegsInClass RcInteger)
- RcDouble -> 0
+ RcFloat -> 0
RcDouble
-> case classC of
- RcDouble -> min n (allocatableRegsInClass RcDouble)
+ RcFloat -> min n (allocatableRegsInClass RcFloat)
RcInteger -> 0
--}
-
--- The number of allocatable regs is hard coded here so we can do a fast comparision
--- in trivColorable. It's ok if these numbers are _less_ than the actual number of
--- free regs, but they can't be more or the register conflict graph won't color.
---
--- There is an allocatableRegsInClass :: RegClass -> Int, but doing the unboxing
--- is too slow for us here.
---
--- Compare Regs.freeRegs and MachRegs.h to get these numbers.
---
-#if i386_TARGET_ARCH
-#define ALLOCATABLE_REGS_INTEGER (_ILIT(3))
-#define ALLOCATABLE_REGS_DOUBLE (_ILIT(6))
-#define ALLOCATABLE_REGS_FLOAT (_ILIT(0))
-
-#elif x86_64_TARGET_ARCH
-#define ALLOCATABLE_REGS_INTEGER (_ILIT(5))
-#define ALLOCATABLE_REGS_DOUBLE (_ILIT(2))
-#define ALLOCATABLE_REGS_FLOAT (_ILIT(0))
+-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
+-- i.e., these are the regs for which we are prepared to allow the
+-- register allocator to attempt to map VRegs to.
+allocatableRegs :: [RegNo]
+allocatableRegs
+ = let isFree i = isFastTrue (freeReg i)
+ in filter isFree allMachRegNos
-#elif powerpc_TARGET_ARCH
-#define ALLOCATABLE_REGS_INTEGER (_ILIT(16))
-#define ALLOCATABLE_REGS_DOUBLE (_ILIT(26))
-#define ALLOCATABLE_REGS_FLOAT (_ILIT(0))
-#elif sparc_TARGET_ARCH
-#define ALLOCATABLE_REGS_INTEGER (_ILIT(14))
-#define ALLOCATABLE_REGS_DOUBLE (_ILIT(8))
-#define ALLOCATABLE_REGS_FLOAT (_ILIT(6))
+-- | The number of regs in each class.
+-- We go via top level CAFs to ensure that we're not recomputing
+-- the length of these lists each time the fn is called.
+allocatableRegsInClass :: RegClass -> Int
+allocatableRegsInClass cls
+ = case cls of
+ RcInteger -> allocatableRegsInteger
+ RcFloat -> allocatableRegsDouble
-#else
-#error ToDo: define ALLOCATABLE_REGS_INTEGER and ALLOCATABLE_REGS_DOUBLE
-#endif
+allocatableRegsInteger :: Int
+allocatableRegsInteger
+ = length $ filter (\r -> regClass r == RcInteger)
+ $ map RealReg allocatableRegs
-trivColorable
- :: (Reg -> RegClass)
- -> Triv Reg RegClass Reg
-
-trivColorable regClass _ conflicts exclusions
- = {-# SCC "trivColorable" #-}
- let
- isSqueesed cI cF ufm
- = case ufm of
- NodeUFM _ _ left right
- -> case isSqueesed cI cF right of
- (# s, cI', cF' #)
- -> case s of
- False -> isSqueesed cI' cF' left
- True -> (# True, cI', cF' #)
-
- LeafUFM _ reg
- -> case regClass reg of
- RcInteger
- -> case cI +# _ILIT(1) of
- cI' -> (# cI' >=# ALLOCATABLE_REGS_INTEGER, cI', cF #)
-
- RcDouble
- -> case cF +# _ILIT(1) of
- cF' -> (# cF' >=# ALLOCATABLE_REGS_DOUBLE, cI, cF' #)
-
- RcFloat
- -> case cF +# _ILIT(1) of
- cF' -> (# cF' >=# ALLOCATABLE_REGS_FLOAT, cI, cF' #)
-
- EmptyUFM
- -> (# False, cI, cF #)
-
- in case isSqueesed (_ILIT(0)) (_ILIT(0)) conflicts of
- (# False, cI', cF' #)
- -> case isSqueesed cI' cF' exclusions of
- (# s, _, _ #) -> not s
-
- (# True, _, _ #)
- -> False
+allocatableRegsFloat :: Int
+allocatableRegsFloat
+ = length $ filter (\r -> regClass r == RcFloat
+ $ map RealReg allocatableRegs
+-}
View Lorry Controller Status