compiler/nativeGen/RegCoalesce.hs

   1 -- | Register coalescing.
   2 --
   3
   4 module RegCoalesce (
   5         regCoalesce,
   6         slurpJoinMovs
   7 )
   8
   9 where
  10
  11 import Cmm
  12 import MachRegs
  13 import RegLiveness
  14 import RegAllocInfo
  15
  16 import Bag
  17 import UniqFM
  18 import UniqSet
  19 import UniqSupply
  20
  21 import Control.Monad
  22 import Data.List
  23
  24 -- | Do register coalescing on this top level thing
  25 --      For Reg -> Reg moves, if the first reg dies at the same time the second reg is born
  26 --      then the mov only serves to join live ranges. The two regs can be renamed to be
  27 --      the same and the move instruction safely erased.
  28
  29 regCoalesce :: [LiveCmmTop] -> UniqSM [LiveCmmTop]
  30 regCoalesce code
  31  = do
  32         let joins       = foldl' unionBags emptyBag
  33                         $ map slurpJoinMovs code
  34
  35         let alloc       = foldl' buildAlloc emptyUFM
  36                         $ bagToList joins
  37
  38         let patched     = map (patchEraseLive (sinkReg alloc)) code
  39
  40         return patched
  41
  42
  43 buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
  44 buildAlloc fm (r1, r2)
  45  = let  rmin    = min r1 r2
  46         rmax    = max r1 r2
  47    in   addToUFM fm rmax rmin
  48
  49 sinkReg :: UniqFM Reg -> Reg -> Reg
  50 sinkReg fm r
  51  = case lookupUFM fm r of
  52         Nothing -> r
  53         Just r' -> sinkReg fm r'
  54
  55
  56 -- | Slurp out mov instructions that only serve to join live ranges.
  57 --      During a mov, if the source reg dies and the destiation reg is born
  58 --      then we can rename the two regs to the same thing and eliminate the move.
  59 --
  60 slurpJoinMovs :: LiveCmmTop -> Bag (Reg, Reg)
  61 slurpJoinMovs live
  62         = slurpCmm emptyBag live
  63  where
  64         slurpCmm   rs  CmmData{}                         = rs
  65         slurpCmm   rs (CmmProc _ _ _ (ListGraph blocks)) = foldl' slurpComp  rs blocks
  66         slurpComp  rs (BasicBlock _ blocks)              = foldl' slurpBlock rs blocks
  67         slurpBlock rs (BasicBlock _ instrs)              = foldl' slurpLI    rs instrs
  68
  69         slurpLI    rs (Instr _  Nothing)                 = rs
  70         slurpLI    rs (Instr instr (Just live))
  71                 | Just (r1, r2) <- isRegRegMove instr
  72                 , elementOfUniqSet r1 $ liveDieRead live
  73                 , elementOfUniqSet r2 $ liveBorn live
  74
  75                 -- only coalesce movs between two virtuals for now, else we end up with
  76                 --      allocatable regs in the live regs list..
  77                 , isVirtualReg r1 && isVirtualReg r2
  78                 = consBag (r1, r2) rs
  79
  80                 | otherwise
  81                 = rs
  82
  83