/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs

-- | Register coalescing.
--

{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

module RegAlloc.Graph.Coalesce (
	regCoalesce,
	slurpJoinMovs
)

where

import RegAlloc.Liveness
import Instruction
import Reg

import OldCmm
import Bag
import Digraph
import UniqFM
import UniqSet
import UniqSupply

import Data.List

-- | Do register coalescing on this top level thing
--	For Reg -> Reg moves, if the first reg dies at the same time the second reg is born
--	then the mov only serves to join live ranges. The two regs can be renamed to be 
--	the same and the move instruction safely erased.
regCoalesce 
	:: Instruction instr
	=> [LiveCmmDecl statics instr] 
	-> UniqSM [LiveCmmDecl statics instr]

regCoalesce code
 = do	
 	let joins	= foldl' unionBags emptyBag
			$ map slurpJoinMovs code

	let alloc	= foldl' buildAlloc emptyUFM 
			$ bagToList joins

	let patched	= map (patchEraseLive (sinkReg alloc)) code
			
	return patched


buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
buildAlloc fm (r1, r2)
 = let	rmin	= min r1 r2
 	rmax	= max r1 r2
   in	addToUFM fm rmax rmin

sinkReg :: UniqFM Reg -> Reg -> Reg
sinkReg fm r
 = case lookupUFM fm r of
 	Nothing	-> r
	Just r'	-> sinkReg fm r'	
	

-- | Slurp out mov instructions that only serve to join live ranges.
--	During a mov, if the source reg dies and the destiation reg is born
--	then we can rename the two regs to the same thing and eliminate the move.
slurpJoinMovs 
	:: Instruction instr
	=> LiveCmmDecl statics instr 
	-> Bag (Reg, Reg)

slurpJoinMovs live
	= slurpCmm emptyBag live
 where	
  	slurpCmm   rs  CmmData{}		    = rs
	slurpCmm   rs (CmmProc _ _ sccs) 	= foldl' slurpBlock rs (flattenSCCs sccs)
	slurpBlock rs (BasicBlock _ instrs)	= foldl' slurpLI    rs instrs
                
	slurpLI    rs (LiveInstr _	Nothing)    = rs
	slurpLI    rs (LiveInstr instr (Just live))
	 	| Just (r1, r2)	<- takeRegRegMoveInstr instr
		, elementOfUniqSet r1 $ liveDieRead live
		, elementOfUniqSet r2 $ liveBorn live

		-- only coalesce movs between two virtuals for now, else we end up with
		--	allocatable regs in the live regs list.. 
		, isVirtualReg r1 && isVirtualReg r2
		= consBag (r1, r2) rs
		
		| otherwise
		= rs