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

[ghc-hetmet.git] / compiler / nativeGen / RegLiveness.hs

diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index 5b867f3..5f8db17 100644 (file)
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -5,7 +5,7 @@
 -- (c) The University of Glasgow 2004
 --
 -----------------------------------------------------------------------------
-{-# OPTIONS -fno-warn-missing-signatures #-}
+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
 
 module RegLiveness (
        RegSet,
@@ -22,6 +22,7 @@ module RegLiveness (
        stripLive,
        spillNatBlock,
        slurpConflicts,
+       slurpReloadCoalesce,
        lifetimeCount,
        eraseDeltasLive,
        patchEraseLive,
@@ -36,7 +37,7 @@ import MachRegs
 import MachInstrs
 import PprMach
 import RegAllocInfo
-import Cmm
+import Cmm hiding (RegSet)
 
 import Digraph
 import Outputable
@@ -154,6 +155,7 @@ mapBlockTopM f (CmmProc header label params (ListGraph comps))
  = do  comps'  <- mapM (mapBlockCompM f) comps
        return  $ CmmProc header label params (ListGraph comps')
 
+mapBlockCompM :: Monad m => (a -> m a') -> (GenBasicBlock a) -> m (GenBasicBlock a')
 mapBlockCompM f (BasicBlock i blocks)
  = do  blocks' <- mapM f blocks
        return  $ BasicBlock i blocks'
@@ -243,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
@@ -588,6 +635,7 @@ livenessBack liveregs blockmap acc (instr : instrs)
    in  livenessBack liveregs' blockmap (instr' : acc) instrs
 
 -- don't bother tagging comments or deltas with liveness
+liveness1 :: RegSet -> BlockMap RegSet -> Instr -> (RegSet, LiveInstr)
 liveness1 liveregs _   (instr@COMMENT{})
        = (liveregs, Instr instr Nothing)