/ghc-7.0.4/compiler/nativeGen/RegAlloc/Linear/Stats.hs

module RegAlloc.Linear.Stats (
	binSpillReasons,
	countRegRegMovesNat,
	pprStats
)

where

import RegAlloc.Linear.Base
import RegAlloc.Liveness
import Instruction

import Cmm		(GenBasicBlock(..))

import UniqFM
import Outputable

import Data.List
import State

-- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
binSpillReasons
	:: [SpillReason] -> UniqFM [Int]

binSpillReasons reasons
	= addListToUFM_C
		(zipWith (+))
		emptyUFM
		(map (\reason -> case reason of
			SpillAlloc r	-> (r, [1, 0, 0, 0, 0])
			SpillClobber r	-> (r, [0, 1, 0, 0, 0])
			SpillLoad r	-> (r, [0, 0, 1, 0, 0])
			SpillJoinRR r	-> (r, [0, 0, 0, 1, 0])
			SpillJoinRM r	-> (r, [0, 0, 0, 0, 1])) reasons)


-- | Count reg-reg moves remaining in this code.
countRegRegMovesNat 
	:: Instruction instr
	=> NatCmmTop instr -> Int

countRegRegMovesNat cmm
	= execState (mapGenBlockTopM countBlock cmm) 0
 where
 	countBlock b@(BasicBlock _ instrs)
	 = do	mapM_ countInstr instrs
	 	return	b

	countInstr instr
		| Just _	<- takeRegRegMoveInstr instr
		= do	modify (+ 1)
			return instr

		| otherwise
		=	return instr


-- | Pretty print some RegAllocStats
pprStats 
	:: Instruction instr 
	=> [NatCmmTop instr] -> [RegAllocStats] -> SDoc

pprStats code statss
 = let	-- sum up all the instrs inserted by the spiller
 	spills		= foldl' (plusUFM_C (zipWith (+)))
 				emptyUFM
			$ map ra_spillInstrs statss

	spillTotals	= foldl' (zipWith (+))
				[0, 0, 0, 0, 0]
			$ eltsUFM spills

	-- count how many reg-reg-moves remain in the code
	moves		= sum $ map countRegRegMovesNat code

	pprSpill (reg, spills)
		= parens $ (hcat $ punctuate (text ", ")  (doubleQuotes (ppr reg) : map ppr spills))

   in	(  text "-- spills-added-total"
	$$ text "--    (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)"
	$$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves])))
	$$ text ""
	$$ text "-- spills-added"
   	$$ text "--    (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
	$$ (vcat $ map pprSpill
   		 $ ufmToList spills)
	$$ text "")