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 OldCmm
  16 import Bag
  17 import Digraph
  18 import UniqFM
  19 import UniqSet
  20 import UniqSupply
  21
  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 regCoalesce
  29         :: Instruction instr
  30         => [LiveCmmTop instr]
  31         -> UniqSM [LiveCmmTop instr]
  32
  33 regCoalesce code
  34  = do
  35         let joins       = foldl' unionBags emptyBag
  36                         $ map slurpJoinMovs code
  37
  38         let alloc       = foldl' buildAlloc emptyUFM
  39                         $ bagToList joins
  40
  41         let patched     = map (patchEraseLive (sinkReg alloc)) code
  42
  43         return patched
  44
  45
  46 buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
  47 buildAlloc fm (r1, r2)
  48  = let  rmin    = min r1 r2
  49         rmax    = max r1 r2
  50    in   addToUFM fm rmax rmin
  51
  52 sinkReg :: UniqFM Reg -> Reg -> Reg
  53 sinkReg fm r
  54  = case lookupUFM fm r of
  55         Nothing -> r
  56         Just r' -> sinkReg fm r'
  57
  58
  59 -- | Slurp out mov instructions that only serve to join live ranges.
  60 --      During a mov, if the source reg dies and the destiation reg is born
  61 --      then we can rename the two regs to the same thing and eliminate the move.
  62 slurpJoinMovs
  63         :: Instruction instr
  64         => LiveCmmTop instr
  65         -> Bag (Reg, Reg)
  66
  67 slurpJoinMovs live
  68         = slurpCmm emptyBag live
  69  where
  70         slurpCmm   rs  CmmData{}                    = rs
  71         slurpCmm   rs (CmmProc _ _ sccs)        = foldl' slurpBlock rs (flattenSCCs sccs)
  72         slurpBlock rs (BasicBlock _ instrs)     = foldl' slurpLI    rs instrs
  73
  74         slurpLI    rs (LiveInstr _      Nothing)    = rs
  75         slurpLI    rs (LiveInstr instr (Just live))
  76                 | Just (r1, r2) <- takeRegRegMoveInstr instr
  77                 , elementOfUniqSet r1 $ liveDieRead live
  78                 , elementOfUniqSet r2 $ liveBorn live
  79
  80                 -- only coalesce movs between two virtuals for now, else we end up with
  81                 --      allocatable regs in the live regs list..
  82                 , isVirtualReg r1 && isVirtualReg r2
  83                 = consBag (r1, r2) rs
  84
  85                 | otherwise
  86                 = rs
  87
  88