compiler/nativeGen/RegCoalesce.hs

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