compiler/nativeGen/RegCoalesce.hs

   1
   2 -- | Register coalescing.
   3 --
   4
   5 {-# OPTIONS_GHC -w #-}
   6 -- The above warning supression flag is a temporary kludge.
   7 -- While working on this module you are encouraged to remove it and fix
   8 -- any warnings in the module. See
   9 --     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
  10 -- for details
  11
  12 module RegCoalesce (
  13         regCoalesce,
  14         slurpJoinMovs
  15 )
  16
  17 where
  18
  19 import Cmm
  20 import MachRegs
  21 import RegLiveness
  22 import RegAllocInfo
  23
  24 import Bag
  25 import UniqFM
  26 import UniqSet
  27 import UniqSupply
  28
  29 import Control.Monad
  30 import Data.List
  31
  32 -- | Do register coalescing on this top level thing
  33 --      For Reg -> Reg moves, if the first reg dies at the same time the second reg is born
  34 --      then the mov only serves to join live ranges. The two regs can be renamed to be
  35 --      the same and the move instruction safely erased.
  36
  37 regCoalesce :: [LiveCmmTop] -> UniqSM [LiveCmmTop]
  38 regCoalesce code
  39  = do
  40         let joins       = foldl' unionBags emptyBag
  41                         $ map slurpJoinMovs code
  42
  43         let alloc       = foldl' buildAlloc emptyUFM
  44                         $ bagToList joins
  45
  46         let patched     = map (patchEraseLive (sinkReg alloc)) code
  47
  48         return patched
  49
  50
  51 buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
  52 buildAlloc fm (r1, r2)
  53  = let  rmin    = min r1 r2
  54         rmax    = max r1 r2
  55    in   addToUFM fm rmax rmin
  56
  57 sinkReg :: UniqFM Reg -> Reg -> Reg
  58 sinkReg fm r
  59  = case lookupUFM fm r of
  60         Nothing -> r
  61         Just r' -> sinkReg fm r'
  62
  63
  64 -- | Slurp out mov instructions that only serve to join live ranges.
  65 --      During a mov, if the source reg dies and the destiation reg is born
  66 --      then we can rename the two regs to the same thing and eliminate the move.
  67 --
  68 slurpJoinMovs :: LiveCmmTop -> Bag (Reg, Reg)
  69 slurpJoinMovs live
  70         = slurpCmm emptyBag live
  71  where
  72         slurpCmm   rs  CmmData{}                = rs
  73         slurpCmm   rs (CmmProc _ _ _ blocks)    = foldl' slurpComp  rs blocks
  74         slurpComp  rs (BasicBlock i blocks)     = foldl' slurpBlock rs blocks
  75         slurpBlock rs (BasicBlock i instrs)     = foldl' slurpLI    rs instrs
  76
  77         slurpLI    rs (Instr _  Nothing)        = rs
  78         slurpLI    rs (Instr instr (Just live))
  79                 | Just (r1, r2) <- isRegRegMove 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