compiler/nativeGen/RegAlloc/Graph/Coalesce.hs

   1 -- | Register coalescing.
   2 --
   3
   4 module RegAlloc.Graph.Coalesce (
   5         regCoalesce,
   6         slurpJoinMovs
   7 )
   8
   9 where
  10
  11 import RegAlloc.Liveness
  12 import Instruction
  13 import Reg
  14
  15 import Cmm
  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
  30         :: Instruction instr
  31         => [LiveCmmTop instr]
  32         -> UniqSM [LiveCmmTop instr]
  33
  34 regCoalesce code
  35  = do
  36         let joins       = foldl' unionBags emptyBag
  37                         $ map slurpJoinMovs code
  38
  39         let alloc       = foldl' buildAlloc emptyUFM
  40                         $ bagToList joins
  41
  42         let patched     = map (patchEraseLive (sinkReg alloc)) code
  43
  44         return patched
  45
  46
  47 buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
  48 buildAlloc fm (r1, r2)
  49  = let  rmin    = min r1 r2
  50         rmax    = max r1 r2
  51    in   addToUFM fm rmax rmin
  52
  53 sinkReg :: UniqFM Reg -> Reg -> Reg
  54 sinkReg fm r
  55  = case lookupUFM fm r of
  56         Nothing -> r
  57         Just r' -> sinkReg fm r'
  58
  59
  60 -- | Slurp out mov instructions that only serve to join live ranges.
  61 --      During a mov, if the source reg dies and the destiation reg is born
  62 --      then we can rename the two regs to the same thing and eliminate the move.
  63 --
  64 slurpJoinMovs
  65         :: Instruction instr
  66         => LiveCmmTop instr
  67         -> Bag (Reg, Reg)
  68
  69 slurpJoinMovs live
  70         = slurpCmm emptyBag live
  71  where
  72         slurpCmm   rs  CmmData{}                         = rs
  73         slurpCmm   rs (CmmProc _ _ _ (ListGraph blocks)) = foldl' slurpComp  rs blocks
  74         slurpComp  rs (BasicBlock _ blocks)              = foldl' slurpBlock rs blocks
  75         slurpBlock rs (BasicBlock _ instrs)              = foldl' slurpLI    rs instrs
  76
  77         slurpLI    rs (Instr _  Nothing)                 = rs
  78         slurpLI    rs (Instr instr (Just live))
  79                 | Just (r1, r2) <- takeRegRegMoveInstr instr
  80                 , elementOfUniqSet r1 $ liveDieRead live
  81                 , elementOfUniqSet r2 $ liveBorn live
  82
  83                 -- only coalesce movs between two virtuals for now, else we end up with
  84                 --      allocatable regs in the live regs list..
  85                 , isVirtualReg r1 && isVirtualReg r2
  86                 = consBag (r1, r2) rs
  87
  88                 | otherwise
  89                 = rs
  90
  91         slurpLI    rs SPILL{}   = rs
  92         slurpLI    rs RELOAD{}  = rs
  93
  94