Try and allocate vregs spilled/reloaded from some slot to the same hreg

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 271c1a5..a2b98f1 100644 (file)
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -119,7 +119,7 @@ regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs
 
        -- rewrite regs in the code that have been coalesced
        let patchF reg  = case lookupUFM rmCoalesce reg of
-                               Just reg'       -> reg'
+                               Just reg'       -> patchF reg'
                                Nothing         -> reg
        let code_coalesced
                        = map (patchEraseLive patchF) code
@@ -246,16 +246,18 @@ buildGraph code
        let (conflictList, moveList) =
                unzip $ map slurpConflicts code
 
-       let conflictBag         = unionManyBags conflictList
-       let moveBag             = unionManyBags moveList
+       -- Slurp out the spill/reload coalesces
+       let moveList2           = map slurpReloadCoalesce code
 
        -- Add the reg-reg conflicts to the graph
+       let conflictBag         = unionManyBags conflictList
        let graph_conflict      = foldrBag graphAddConflictSet Color.initGraph conflictBag
 
        -- Add the coalescences edges to the graph.
+       let moveBag             = unionBags (unionManyBags moveList2) (unionManyBags moveList)
        let graph_coalesce      = foldrBag graphAddCoalesce graph_conflict moveBag
                        
-       return  graph_coalesce
+       return  $ Color.validateGraph (text "urk") graph_coalesce
 
 
 -- | Add some conflict edges to the graph.
@@ -326,7 +328,7 @@ patchRegsFromGraph graph code
                        (  text "There is no node in the graph for register " <> ppr reg
                        $$ ppr code
                        $$ Color.dotGraph (\_ -> text "white") trivColorable graph)
-       
+
    in  patchEraseLive patchF code
    
 

diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index 98aefb0..5f8db17 100644 (file)
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -22,6 +22,7 @@ module RegLiveness (
        stripLive,
        spillNatBlock,
        slurpConflicts,
+       slurpReloadCoalesce,
        lifetimeCount,
        eraseDeltasLive,
        patchEraseLive,
@@ -244,6 +245,51 @@ slurpConflicts live
                                        , moves) lis
 
 
+-- | For spill/reloads
+--
+--     SPILL  v1, slot1
+--     ...
+--     RELOAD slot1, v2
+--
+--     If we can arrange that v1 and v2 are allocated to the same hreg it's more likely
+--     the spill/reload instrs can be cleaned and replaced by a nop reg-reg move.
+--
+--     TODO: This only works intra-block at the momement. It's be nice to join up the mappings
+--           across blocks also.
+--
+slurpReloadCoalesce :: LiveCmmTop -> Bag (Reg, Reg)
+slurpReloadCoalesce live
+       = slurpCmm emptyBag live
+
+ where slurpCmm cs CmmData{}   = cs
+       slurpCmm cs (CmmProc _ _ _ (ListGraph blocks))
+               = foldl' slurpComp cs blocks
+
+       slurpComp  cs (BasicBlock _ blocks)
+               = foldl' slurpBlock cs blocks
+
+       slurpBlock cs (BasicBlock _ instrs)
+        = let  (_, mMoves)     = mapAccumL slurpLI emptyUFM instrs
+          in   unionBags cs (listToBag $ catMaybes mMoves)
+
+       slurpLI :: UniqFM Reg -> LiveInstr -> (UniqFM Reg, Maybe (Reg, Reg))
+       slurpLI slotMap (Instr instr _)
+
+               -- remember what reg was stored into the slot
+               | SPILL reg slot        <- instr
+               , slotMap'              <- addToUFM slotMap slot reg
+               = (slotMap', Nothing)
+
+               -- add an edge betwen the this reg and the last one stored into the slot
+               | RELOAD slot reg       <- instr
+               = case lookupUFM slotMap slot of
+                       Just reg2       -> (slotMap, Just (reg, reg2))
+                       Nothing         -> (slotMap, Nothing)
+
+               | otherwise
+               = (slotMap, Nothing)
+
+
 -- | Strip away liveness information, yielding NatCmmTop
 
 stripLive :: LiveCmmTop -> NatCmmTop