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/Coalesce.hs23
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/Main.hs56
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/Spill.hs46
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/SpillClean.hs95
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/SpillCost.hs48
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/Stats.hs149
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs176
7 files changed, 395 insertions, 198 deletions
diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
index 18e4b0edd1..8521e92601 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
@@ -8,11 +8,11 @@ module RegAlloc.Graph.Coalesce (
where
-import Cmm
-import Regs
import RegAlloc.Liveness
-import RegAllocInfo
+import Instruction
+import Reg
+import Cmm
import Bag
import UniqFM
import UniqSet
@@ -26,7 +26,11 @@ import Data.List
-- then the mov only serves to join live ranges. The two regs can be renamed to be
-- the same and the move instruction safely erased.
-regCoalesce :: [LiveCmmTop] -> UniqSM [LiveCmmTop]
+regCoalesce
+ :: Instruction instr
+ => [LiveCmmTop instr]
+ -> UniqSM [LiveCmmTop instr]
+
regCoalesce code
= do
let joins = foldl' unionBags emptyBag
@@ -57,7 +61,11 @@ sinkReg fm r
-- During a mov, if the source reg dies and the destiation reg is born
-- then we can rename the two regs to the same thing and eliminate the move.
--
-slurpJoinMovs :: LiveCmmTop -> Bag (Reg, Reg)
+slurpJoinMovs
+ :: Instruction instr
+ => LiveCmmTop instr
+ -> Bag (Reg, Reg)
+
slurpJoinMovs live
= slurpCmm emptyBag live
where
@@ -68,7 +76,7 @@ slurpJoinMovs live
slurpLI rs (Instr _ Nothing) = rs
slurpLI rs (Instr instr (Just live))
- | Just (r1, r2) <- isRegRegMove instr
+ | Just (r1, r2) <- takeRegRegMoveInstr instr
, elementOfUniqSet r1 $ liveDieRead live
, elementOfUniqSet r2 $ liveBorn live
@@ -80,4 +88,7 @@ slurpJoinMovs live
| otherwise
= rs
+ slurpLI rs SPILL{} = rs
+ slurpLI rs RELOAD{} = rs
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs
index fe99aba120..2e584617e9 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs
@@ -5,8 +5,7 @@
--
module RegAlloc.Graph.Main (
- regAlloc,
- regDotColor
+ regAlloc
)
where
@@ -17,9 +16,12 @@ 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
@@ -43,18 +45,26 @@ maxSpinCount = 10
-- | The top level of the graph coloring register allocator.
--
regAlloc
- :: DynFlags
+ :: (Outputable instr, Instruction instr)
+ => DynFlags
-> UniqFM (UniqSet Reg) -- ^ 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 targetRegClass
+
(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 )
@@ -74,7 +84,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
$ 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))
@@ -139,12 +149,12 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs 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 =
@@ -213,7 +223,8 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code
-- | Build a graph from the liveness and coalesce information in this code.
buildGraph
- :: [LiveCmmTop]
+ :: Instruction instr
+ => [LiveCmmTop instr]
-> UniqSM (Color.Graph Reg RegClass Reg)
buildGraph code
@@ -248,8 +259,8 @@ graphAddConflictSet set graph
= let reals = filterUFM isRealReg set
virtuals = filterUFM (not . isRealReg) set
- graph1 = Color.addConflicts virtuals regClass graph
- graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 regClass r2)
+ graph1 = Color.addConflicts virtuals targetRegClass graph
+ graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 targetRegClass r2)
graph1
[ (a, b)
| a <- uniqSetToList virtuals
@@ -276,13 +287,14 @@ graphAddCoalesce (r1, r2) graph
| otherwise
= Color.addCoalesce (regWithClass r1) (regWithClass r2) graph
- where regWithClass r = (r, regClass r)
+ where regWithClass r = (r, targetRegClass r)
-- | 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 Reg RegClass Reg
+ -> LiveCmmTop instr -> LiveCmmTop instr
patchRegsFromGraph graph code
= let
@@ -303,7 +315,7 @@ patchRegsFromGraph graph code
= 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 targetRegClass) graph)
in patchEraseLive patchF code
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
index b5a645188f..e6e5622a02 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -10,9 +10,8 @@ module RegAlloc.Graph.Spill (
where
import RegAlloc.Liveness
-import RegAllocInfo
-import Regs
-import Instrs
+import Instruction
+import Reg
import Cmm
import State
@@ -35,11 +34,12 @@ import Data.Maybe
-- address the spill slot directly.
--
regSpill
- :: [LiveCmmTop] -- ^ the code
+ :: Instruction instr
+ => [LiveCmmTop instr] -- ^ the code
-> UniqSet Int -- ^ available stack slots
-> UniqSet Reg -- ^ the regs to spill
-> UniqSM
- ([LiveCmmTop] -- code will spill instructions
+ ([LiveCmmTop instr] -- code will spill instructions
, UniqSet Int -- left over slots
, SpillStats ) -- stats about what happened during spilling
@@ -75,6 +75,20 @@ regSpill_block regSlotMap (BasicBlock i instrs)
= do instrss' <- mapM (regSpill_instr regSlotMap) instrs
return $ BasicBlock i (concat instrss')
+
+regSpill_instr
+ :: Instruction instr
+ => UniqFM Int
+ -> LiveInstr instr -> SpillM [LiveInstr instr]
+
+-- | The thing we're spilling shouldn't already have spill or reloads in it
+regSpill_instr _ SPILL{}
+ = panic "regSpill_instr: unexpected SPILL"
+
+regSpill_instr _ RELOAD{}
+ = panic "regSpill_instr: unexpected RELOAD"
+
+
regSpill_instr _ li@(Instr _ Nothing)
= do return [li]
@@ -82,7 +96,7 @@ regSpill_instr regSlotMap
(Instr instr (Just _))
= do
-- work out which regs are read and written in this instr
- let RU rlRead rlWritten = regUsage instr
+ let RU rlRead rlWritten = regUsageOfInstr instr
-- sometimes a register is listed as being read more than once,
-- nub this so we don't end up inserting two lots of spill code.
@@ -109,9 +123,9 @@ regSpill_instr regSlotMap
let postfixes = concat mPostfixes
-- final code
- let instrs' = map (\i -> Instr i Nothing) prefixes
- ++ [ Instr instr3 Nothing ]
- ++ map (\i -> Instr i Nothing) postfixes
+ let instrs' = prefixes
+ ++ [Instr instr3 Nothing]
+ ++ postfixes
return
{- $ pprTrace "* regSpill_instr spill"
@@ -139,6 +153,7 @@ spillRead regSlotMap instr reg
| otherwise = panic "RegSpill.spillRead: no slot defined for spilled reg"
+
spillWrite regSlotMap instr reg
| Just slot <- lookupUFM regSlotMap reg
= do (instr', nReg) <- patchInstr reg instr
@@ -152,6 +167,7 @@ spillWrite regSlotMap instr reg
| otherwise = panic "RegSpill.spillWrite: no slot defined for spilled reg"
+
spillModify regSlotMap instr reg
| Just slot <- lookupUFM regSlotMap reg
= do (instr', nReg) <- patchInstr reg instr
@@ -168,19 +184,25 @@ spillModify regSlotMap instr reg
-- | rewrite uses of this virtual reg in an instr to use a different virtual reg
-patchInstr :: Reg -> Instr -> SpillM (Instr, Reg)
+patchInstr
+ :: Instruction instr
+ => Reg -> instr -> SpillM (instr, Reg)
+
patchInstr reg instr
= do nUnique <- newUnique
let nReg = renameVirtualReg nUnique reg
let instr' = patchReg1 reg nReg instr
return (instr', nReg)
-patchReg1 :: Reg -> Reg -> Instr -> Instr
+patchReg1
+ :: Instruction instr
+ => Reg -> Reg -> instr -> instr
+
patchReg1 old new instr
= let patchF r
| r == old = new
| otherwise = r
- in patchRegs instr patchF
+ in patchRegsOfInstr instr patchF
------------------------------------------------------
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
index b68648bdaf..4f129c468a 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -29,13 +29,12 @@ module RegAlloc.Graph.SpillClean (
)
where
-import BlockId
import RegAlloc.Liveness
-import RegAllocInfo
-import Regs
-import Instrs
-import Cmm
+import Instruction
+import Reg
+import BlockId
+import Cmm
import UniqSet
import UniqFM
import Unique
@@ -51,12 +50,19 @@ type Slot = Int
-- | Clean out unneeded spill\/reloads from this top level thing.
-cleanSpills :: LiveCmmTop -> LiveCmmTop
+cleanSpills
+ :: Instruction instr
+ => LiveCmmTop instr -> LiveCmmTop instr
+
cleanSpills cmm
= evalState (cleanSpin 0 cmm) initCleanS
-- | do one pass of cleaning
-cleanSpin :: Int -> LiveCmmTop -> CleanM LiveCmmTop
+cleanSpin
+ :: Instruction instr
+ => Int
+ -> LiveCmmTop instr
+ -> CleanM (LiveCmmTop instr)
{-
cleanSpin spinCount code
@@ -103,7 +109,11 @@ cleanSpin spinCount code
-- | Clean one basic block
-cleanBlockForward :: LiveBasicBlock -> CleanM LiveBasicBlock
+cleanBlockForward
+ :: Instruction instr
+ => LiveBasicBlock instr
+ -> CleanM (LiveBasicBlock instr)
+
cleanBlockForward (BasicBlock blockId instrs)
= do
-- see if we have a valid association for the entry to this block
@@ -116,7 +126,11 @@ cleanBlockForward (BasicBlock blockId instrs)
return $ BasicBlock blockId instrs_reload
-cleanBlockBackward :: LiveBasicBlock -> CleanM LiveBasicBlock
+cleanBlockBackward
+ :: Instruction instr
+ => LiveBasicBlock instr
+ -> CleanM (LiveBasicBlock instr)
+
cleanBlockBackward (BasicBlock blockId instrs)
= do instrs_spill <- cleanBackward emptyUniqSet [] instrs
return $ BasicBlock blockId instrs_spill
@@ -130,11 +144,12 @@ cleanBlockBackward (BasicBlock blockId instrs)
-- then we don't need to do the reload.
--
cleanForward
- :: BlockId -- ^ the block that we're currently in
- -> Assoc Store -- ^ two store locations are associated if they have the same value
- -> [LiveInstr] -- ^ acc
- -> [LiveInstr] -- ^ instrs to clean (in backwards order)
- -> CleanM [LiveInstr] -- ^ cleaned instrs (in forward order)
+ :: Instruction instr
+ => BlockId -- ^ the block that we're currently in
+ -> Assoc Store -- ^ two store locations are associated if they have the same value
+ -> [LiveInstr instr] -- ^ acc
+ -> [LiveInstr instr] -- ^ instrs to clean (in backwards order)
+ -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order)
cleanForward _ _ acc []
= return acc
@@ -142,19 +157,19 @@ cleanForward _ _ acc []
-- write out live range joins via spill slots to just a spill and a reg-reg move
-- hopefully the spill will be also be cleaned in the next pass
--
-cleanForward blockId assoc acc (Instr i1 live1 : Instr i2 _ : instrs)
+cleanForward blockId assoc acc (li1 : li2 : instrs)
- | SPILL reg1 slot1 <- i1
- , RELOAD slot2 reg2 <- i2
+ | SPILL reg1 slot1 <- li1
+ , RELOAD slot2 reg2 <- li2
, slot1 == slot2
= do
modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
cleanForward blockId assoc acc
- (Instr i1 live1 : Instr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs)
+ (li1 : Instr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs)
cleanForward blockId assoc acc (li@(Instr i1 _) : instrs)
- | Just (r1, r2) <- isRegRegMove i1
+ | Just (r1, r2) <- takeRegRegMoveInstr i1
= if r1 == r2
-- erase any left over nop reg reg moves while we're here
-- this will also catch any nop moves that the "write out live range joins" case above
@@ -170,38 +185,50 @@ cleanForward blockId assoc acc (li@(Instr i1 _) : instrs)
cleanForward blockId assoc' (li : acc) instrs
-cleanForward blockId assoc acc (li@(Instr instr _) : instrs)
+cleanForward blockId assoc acc (li : instrs)
-- update association due to the spill
- | SPILL reg slot <- instr
+ | SPILL reg slot <- li
= let assoc' = addAssoc (SReg reg) (SSlot slot)
$ delAssoc (SSlot slot)
$ assoc
in cleanForward blockId assoc' (li : acc) instrs
-- clean a reload instr
- | RELOAD{} <- instr
+ | RELOAD{} <- li
= do (assoc', mli) <- cleanReload blockId assoc li
case mli of
Nothing -> cleanForward blockId assoc' acc instrs
Just li' -> cleanForward blockId assoc' (li' : acc) instrs
-- remember the association over a jump
- | targets <- jumpDests instr []
+ | Instr instr _ <- li
+ , targets <- jumpDestsOfInstr instr
, not $ null targets
= do mapM_ (accJumpValid assoc) targets
cleanForward blockId assoc (li : acc) instrs
-- writing to a reg changes its value.
- | RU _ written <- regUsage instr
+ | Instr instr _ <- li
+ , RU _ written <- regUsageOfInstr instr
= let assoc' = foldr delAssoc assoc (map SReg $ nub written)
in cleanForward blockId assoc' (li : acc) instrs
+-- bogus, to stop pattern match warning
+cleanForward _ _ _ _
+ = panic "RegAlloc.Graph.SpillClean.cleanForward: no match"
+
-- | Try and rewrite a reload instruction to something more pleasing
--
-cleanReload :: BlockId -> Assoc Store -> LiveInstr -> CleanM (Assoc Store, Maybe LiveInstr)
-cleanReload blockId assoc li@(Instr (RELOAD slot reg) _)
+cleanReload
+ :: Instruction instr
+ => BlockId
+ -> Assoc Store
+ -> LiveInstr instr
+ -> CleanM (Assoc Store, Maybe (LiveInstr instr))
+
+cleanReload blockId assoc li@(RELOAD slot reg)
-- if the reg we're reloading already has the same value as the slot
-- then we can erase the instruction outright
@@ -264,10 +291,10 @@ cleanReload _ _ _
-- we should really be updating the noReloads set as we cross jumps also.
--
cleanBackward
- :: UniqSet Int -- ^ slots that have been spilled, but not reloaded from
- -> [LiveInstr] -- ^ acc
- -> [LiveInstr] -- ^ instrs to clean (in forwards order)
- -> CleanM [LiveInstr] -- ^ cleaned instrs (in backwards order)
+ :: UniqSet Int -- ^ slots that have been spilled, but not reloaded from
+ -> [LiveInstr instr] -- ^ acc
+ -> [LiveInstr instr] -- ^ instrs to clean (in forwards order)
+ -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in backwards order)
cleanBackward noReloads acc lis
@@ -277,15 +304,15 @@ cleanBackward noReloads acc lis
cleanBackward' _ _ acc []
= return acc
-cleanBackward' reloadedBy noReloads acc (li@(Instr instr _) : instrs)
+cleanBackward' reloadedBy noReloads acc (li : instrs)
-- if nothing ever reloads from this slot then we don't need the spill
- | SPILL _ slot <- instr
+ | SPILL _ slot <- li
, Nothing <- lookupUFM reloadedBy (SSlot slot)
= do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
cleanBackward noReloads acc instrs
- | SPILL _ slot <- instr
+ | SPILL _ slot <- li
= if elementOfUniqSet slot noReloads
-- we can erase this spill because the slot won't be read until after the next one
@@ -299,7 +326,7 @@ cleanBackward' reloadedBy noReloads acc (li@(Instr instr _) : instrs)
cleanBackward noReloads' (li : acc) instrs
-- if we reload from a slot then it's no longer unused
- | RELOAD slot _ <- instr
+ | RELOAD slot _ <- li
, noReloads' <- delOneFromUniqSet noReloads slot
= cleanBackward noReloads' (li : acc) instrs
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
index 1d37cf71d6..d4dd75a4b7 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -16,14 +16,16 @@ module RegAlloc.Graph.SpillCost (
where
-import GraphBase
import RegAlloc.Liveness
-import RegAllocInfo
-import Instrs
-import Regs
+import Instruction
+import RegClass
+import Reg
+
+import GraphBase
+
+
import BlockId
import Cmm
-
import UniqFM
import UniqSet
import Outputable
@@ -62,7 +64,8 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2)
-- and the number of instructions it was live on entry to (lifetime)
--
slurpSpillCostInfo
- :: LiveCmmTop
+ :: (Outputable instr, Instruction instr)
+ => LiveCmmTop instr
-> SpillCostInfo
slurpSpillCostInfo cmm
@@ -89,11 +92,14 @@ slurpSpillCostInfo cmm
= return ()
-- skip over comment and delta pseudo instrs
- countLIs rsLive (Instr instr Nothing : lis)
- | COMMENT{} <- instr
+ countLIs rsLive (SPILL{} : lis)
+ = countLIs rsLive lis
+
+ countLIs rsLive (RELOAD{} : lis)
= countLIs rsLive lis
- | DELTA{} <- instr
+ countLIs rsLive (Instr instr Nothing : lis)
+ | isMetaInstr instr
= countLIs rsLive lis
| otherwise
@@ -106,7 +112,7 @@ slurpSpillCostInfo cmm
mapM_ incLifetime $ uniqSetToList rsLiveEntry
-- increment counts for what regs were read/written from
- let (RU read written) = regUsage instr
+ let (RU read written) = regUsageOfInstr instr
mapM_ incUses $ filter (not . isRealReg) $ nub read
mapM_ incDefs $ filter (not . isRealReg) $ nub written
@@ -226,8 +232,11 @@ lifeMapFromSpillCostInfo info
-- | Work out the degree (number of neighbors) of this node which have the same class.
-nodeDegree :: Graph Reg RegClass Reg -> Reg -> Int
-nodeDegree graph reg
+nodeDegree
+ :: (Reg -> RegClass)
+ -> Graph Reg RegClass Reg -> Reg -> Int
+
+nodeDegree regClass graph reg
| Just node <- lookupUFM (graphMap graph) reg
, virtConflicts <- length $ filter (\r -> regClass r == regClass reg)
$ uniqSetToList $ nodeConflicts node
@@ -238,12 +247,17 @@ nodeDegree graph reg
-- | Show a spill cost record, including the degree from the graph and final calulated spill cos
-pprSpillCostRecord :: Graph Reg RegClass Reg -> SpillCostRecord -> SDoc
-pprSpillCostRecord graph (reg, uses, defs, life)
+pprSpillCostRecord
+ :: (Reg -> RegClass)
+ -> (Reg -> SDoc)
+ -> Graph Reg RegClass Reg -> SpillCostRecord -> SDoc
+
+pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life)
= hsep
- [ ppr reg
+ [ pprReg reg
, ppr uses
, ppr defs
, ppr life
- , ppr $ nodeDegree graph reg
- , text $ show $ (fromIntegral (uses + defs) / fromIntegral (nodeDegree graph reg) :: Float) ]
+ , 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 8082f9e975..5e3dd3265b 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
@@ -5,7 +5,6 @@
module RegAlloc.Graph.Stats (
RegAllocStats (..),
- regDotColor,
pprStats,
pprStatsSpills,
@@ -22,13 +21,13 @@ where
import qualified GraphColor as Color
import RegAlloc.Liveness
-import RegAllocInfo
import RegAlloc.Graph.Spill
import RegAlloc.Graph.SpillCost
-import Regs
-import Instrs
-import Cmm
+import Instruction
+import RegClass
+import Reg
+import Cmm
import Outputable
import UniqFM
import UniqSet
@@ -36,11 +35,11 @@ import State
import Data.List
-data RegAllocStats
+data RegAllocStats instr
-- initial graph
= RegAllocStatsStart
- { raLiveCmm :: [LiveCmmTop] -- ^ initial code, with liveness
+ { 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
@@ -50,35 +49,35 @@ data RegAllocStats
, raCoalesced :: UniqFM Reg -- ^ the regs that were coaleced
, raSpillStats :: SpillStats -- ^ spiller stats
, raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for
- , raSpilled :: [LiveCmmTop] } -- ^ code with spill instructions added
+ , 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] -- ^ code with vregs replaced by hregs
- , raSpillClean :: [LiveCmmTop] -- ^ code with unneeded spill\/reloads cleaned out
- , raFinal :: [NatCmmTop] -- ^ final code
+ , 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 RegAllocStats where
+instance Outputable instr => Outputable (RegAllocStats instr) where
ppr (s@RegAllocStatsStart{})
= text "# Start"
$$ text "# Native code with liveness information."
$$ ppr (raLiveCmm s)
$$ text ""
- $$ text "# Initial register conflict graph."
- $$ Color.dotGraph regDotColor trivColorable (raGraph s)
+-- $$ text "# Initial register conflict graph."
+-- $$ Color.dotGraph regDotColor trivColorable (raGraph s)
ppr (s@RegAllocStatsSpill{})
= text "# Spill"
- $$ text "# Register conflict graph."
- $$ Color.dotGraph regDotColor trivColorable (raGraph s)
- $$ text ""
+-- $$ text "# Register conflict graph."
+-- $$ Color.dotGraph regDotColor trivColorable (raGraph s)
+-- $$ text ""
$$ (if (not $ isNullUFM $ raCoalesced s)
then text "# Registers coalesced."
@@ -86,9 +85,9 @@ instance Outputable RegAllocStats where
$$ text ""
else empty)
- $$ text "# Spill costs. reg uses defs lifetime degree cost"
- $$ vcat (map (pprSpillCostRecord (raGraph s)) $ eltsUFM $ raSpillCosts s)
- $$ text ""
+-- $$ text "# Spill costs. reg uses defs lifetime degree cost"
+-- $$ vcat (map (pprSpillCostRecord (raGraph s)) $ eltsUFM $ raSpillCosts s)
+-- $$ text ""
$$ text "# Spills inserted."
$$ ppr (raSpillStats s)
@@ -101,13 +100,13 @@ instance Outputable RegAllocStats where
ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) })
= text "# Colored"
- $$ text "# Register conflict graph (initial)."
- $$ Color.dotGraph regDotColor trivColorable (raGraph s)
- $$ text ""
+-- $$ text "# Register conflict graph (initial)."
+-- $$ Color.dotGraph regDotColor trivColorable (raGraph s)
+-- $$ text ""
- $$ text "# Register conflict graph (colored)."
- $$ Color.dotGraph regDotColor trivColorable (raGraphColored s)
- $$ text ""
+-- $$ text "# Register conflict graph (colored)."
+-- $$ Color.dotGraph regDotColor trivColorable (raGraphColored s)
+-- $$ text ""
$$ (if (not $ isNullUFM $ raCoalesced s)
then text "# Registers coalesced."
@@ -133,7 +132,7 @@ instance Outputable RegAllocStats where
$$ text ""
-- | Do all the different analysis on this list of RegAllocStats
-pprStats :: [RegAllocStats] -> Color.Graph Reg RegClass Reg -> SDoc
+pprStats :: [RegAllocStats instr] -> Color.Graph Reg RegClass Reg -> SDoc
pprStats stats graph
= let outSpills = pprStatsSpills stats
outLife = pprStatsLifetimes stats
@@ -145,7 +144,7 @@ pprStats stats graph
-- | Dump a table of how many spill loads \/ stores were inserted for each vreg.
pprStatsSpills
- :: [RegAllocStats] -> SDoc
+ :: [RegAllocStats instr] -> SDoc
pprStatsSpills stats
= let
@@ -163,7 +162,7 @@ pprStatsSpills stats
-- | Dump a table of how long vregs tend to live for in the initial code.
pprStatsLifetimes
- :: [RegAllocStats] -> SDoc
+ :: [RegAllocStats instr] -> SDoc
pprStatsLifetimes stats
= let info = foldl' plusSpillCostInfo zeroSpillCostInfo
@@ -191,7 +190,7 @@ binLifetimeCount fm
-- | Dump a table of how many conflicts vregs tend to have in the initial code.
pprStatsConflict
- :: [RegAllocStats] -> SDoc
+ :: [RegAllocStats instr] -> SDoc
pprStatsConflict stats
= let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))
@@ -208,7 +207,7 @@ pprStatsConflict stats
-- | For every vreg, dump it's how many conflicts it has and its lifetime
-- good for making a scatter plot.
pprStatsLifeConflict
- :: [RegAllocStats]
+ :: [RegAllocStats instr]
-> Color.Graph Reg RegClass Reg -- ^ global register conflict graph
-> SDoc
@@ -238,7 +237,10 @@ pprStatsLifeConflict stats graph
-- | Count spill/reload/reg-reg moves.
-- Lets us see how well the register allocator has done.
--
-countSRMs :: LiveCmmTop -> (Int, Int, Int)
+countSRMs
+ :: Instruction instr
+ => LiveCmmTop instr -> (Int, Int, Int)
+
countSRMs cmm
= execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
@@ -246,16 +248,17 @@ countSRM_block (BasicBlock i instrs)
= do instrs' <- mapM countSRM_instr instrs
return $ BasicBlock i instrs'
-countSRM_instr li@(Instr instr _)
- | SPILL _ _ <- instr
+countSRM_instr li
+ | SPILL _ _ <- li
= do modify $ \(s, r, m) -> (s + 1, r, m)
return li
- | RELOAD _ _ <- instr
+ | RELOAD _ _ <- li
= do modify $ \(s, r, m) -> (s, r + 1, m)
return li
- | Just _ <- isRegRegMove instr
+ | Instr instr _ <- li
+ , Just _ <- takeRegRegMoveInstr instr
= do modify $ \(s, r, m) -> (s, r, m + 1)
return li
@@ -266,77 +269,9 @@ countSRM_instr li@(Instr instr _)
addSRM (s1, r1, m1) (s2, r2, m2)
= (s1+s2, r1+r2, m1+m2)
------
--- Register colors for drawing conflict graphs
--- Keep this out of MachRegs.hs because it's specific to the graph coloring allocator.
-
-
--- reg colors for x86
-#if i386_TARGET_ARCH
-regDotColor :: Reg -> SDoc
-regDotColor reg
- = let Just str = lookupUFM regColors reg
- in text str
-
-regColors
- = listToUFM
- $ [ (eax, "#00ff00")
- , (ebx, "#0000ff")
- , (ecx, "#00ffff")
- , (edx, "#0080ff")
-
- , (fake0, "#ff00ff")
- , (fake1, "#ff00aa")
- , (fake2, "#aa00ff")
- , (fake3, "#aa00aa")
- , (fake4, "#ff0055")
- , (fake5, "#5500ff") ]
-
-
--- reg colors for x86_64
-#elif x86_64_TARGET_ARCH
-regDotColor :: Reg -> SDoc
-regDotColor reg
- = let Just str = lookupUFM regColors reg
- in text str
-
-regColors
- = listToUFM
- $ [ (rax, "#00ff00"), (eax, "#00ff00")
- , (rbx, "#0000ff"), (ebx, "#0000ff")
- , (rcx, "#00ffff"), (ecx, "#00ffff")
- , (rdx, "#0080ff"), (edx, "#00ffff")
- , (r8, "#00ff80")
- , (r9, "#008080")
- , (r10, "#0040ff")
- , (r11, "#00ff40")
- , (r12, "#008040")
- , (r13, "#004080")
- , (r14, "#004040")
- , (r15, "#002080") ]
-
- ++ zip (map RealReg [16..31]) (repeat "red")
-
-
--- reg colors for ppc
-#elif powerpc_TARGET_ARCH
-regDotColor :: Reg -> SDoc
-regDotColor reg
- = case regClass reg of
- RcInteger -> text "blue"
- RcFloat -> text "red"
- RcDouble -> text "green"
-
-#elif sparc_TARGET_ARCH
-regDotColor :: Reg -> SDoc
-regDotColor reg
- = case regClass reg of
- RcInteger -> text "blue"
- RcFloat -> text "red"
- RcDouble -> text "green"
-#else
-#error ToDo: regDotColor
-#endif
+
+
+
{-
diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
new file mode 100644
index 0000000000..6a7211dd06
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
@@ -0,0 +1,176 @@
+
+module RegAlloc.Graph.TrivColorable (
+ trivColorable,
+)
+
+where
+
+#include "HsVersions.h"
+
+import RegClass
+import Reg
+
+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.
+{-
+trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool
+trivColorable classN conflicts exclusions
+ = let
+
+ acc :: Reg -> (Int, Int) -> (Int, Int)
+ acc r (cd, cf)
+ = case regClass r of
+ RcInteger -> (cd+1, cf)
+ RcDouble -> (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
+
+ in squeese < allocatableRegsInClass classN
+
+-- | Worst case displacement
+-- node N of classN has n neighbors of class C.
+--
+-- We currently only have RcInteger and RcDouble, which don't conflict at all.
+-- This is a bit boring compared to what's in RegArchX86.
+--
+worst :: Int -> RegClass -> RegClass -> Int
+worst n classN classC
+ = case classN of
+ RcInteger
+ -> case classC of
+ RcInteger -> min n (allocatableRegsInClass RcInteger)
+ RcDouble -> 0
+
+ RcDouble
+ -> case classC of
+ RcDouble -> min n (allocatableRegsInClass RcDouble)
+ 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))
+
+#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(3))
+#define ALLOCATABLE_REGS_DOUBLE (_ILIT(6))
+#define ALLOCATABLE_REGS_FLOAT (_ILIT(0))
+
+#else
+#error ToDo: define ALLOCATABLE_REGS_INTEGER and ALLOCATABLE_REGS_DOUBLE
+#endif
+
+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
View Lorry Controller Status