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

where

import GhcPrelude

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

import UniqFM
import Outputable

import State

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

binSpillReasons :: [SpillReason] -> UniqFM [Int]
binSpillReasons reasons :: [SpillReason]
reasons
        = ([Int] -> [Int] -> [Int])
-> UniqFM [Int] -> [(Unique, [Int])] -> UniqFM [Int]
forall key elt.
Uniquable key =>
(elt -> elt -> elt) -> UniqFM elt -> [(key, elt)] -> UniqFM elt
addListToUFM_C
                ((Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+))
                UniqFM [Int]
forall elt. UniqFM elt
emptyUFM
                ((SpillReason -> (Unique, [Int]))
-> [SpillReason] -> [(Unique, [Int])]
forall a b. (a -> b) -> [a] -> [b]
map (\reason :: SpillReason
reason -> case SpillReason
reason of
                        SpillAlloc r :: Unique
r    -> (Unique
r, [1, 0, 0, 0, 0])
                        SpillClobber r :: Unique
r  -> (Unique
r, [0, 1, 0, 0, 0])
                        SpillLoad r :: Unique
r     -> (Unique
r, [0, 0, 1, 0, 0])
                        SpillJoinRR r :: Unique
r   -> (Unique
r, [0, 0, 0, 1, 0])
                        SpillJoinRM r :: Unique
r   -> (Unique
r, [0, 0, 0, 0, 1])) [SpillReason]
reasons)


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

countRegRegMovesNat :: NatCmmDecl statics instr -> Int
countRegRegMovesNat cmm :: NatCmmDecl statics instr
cmm
        = State Int (NatCmmDecl statics instr) -> Int -> Int
forall s a. State s a -> s -> s
execState ((GenBasicBlock instr -> State Int (GenBasicBlock instr))
-> NatCmmDecl statics instr -> State Int (NatCmmDecl statics instr)
forall (m :: * -> *) i d h.
Monad m =>
(GenBasicBlock i -> m (GenBasicBlock i))
-> GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i))
mapGenBlockTopM GenBasicBlock instr -> State Int (GenBasicBlock instr)
forall b s.
(Instruction b, Num s) =>
GenBasicBlock b -> State s (GenBasicBlock b)
countBlock NatCmmDecl statics instr
cmm) 0
 where
        countBlock :: GenBasicBlock b -> State s (GenBasicBlock b)
countBlock b :: GenBasicBlock b
b@(BasicBlock _ instrs :: [b]
instrs)
         = do   (b -> State s b) -> [b] -> State s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ b -> State s b
forall a s. (Instruction a, Num s) => a -> State s a
countInstr [b]
instrs
                GenBasicBlock b -> State s (GenBasicBlock b)
forall (m :: * -> *) a. Monad m => a -> m a
return  GenBasicBlock b
b

        countInstr :: a -> State s a
countInstr instr :: a
instr
                | Just _        <- a -> Maybe (Reg, Reg)
forall instr. Instruction instr => instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr a
instr
                = do    (s -> s) -> State s ()
forall s. (s -> s) -> State s ()
modify (s -> s -> s
forall a. Num a => a -> a -> a
+ 1)
                        a -> State s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
instr

                | Bool
otherwise
                =       a -> State s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
instr


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

pprStats :: [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc
pprStats code :: [NatCmmDecl statics instr]
code statss :: [RegAllocStats]
statss
 = let  -- sum up all the instrs inserted by the spiller
        spills :: UniqFM [Int]
spills          = (UniqFM [Int] -> UniqFM [Int] -> UniqFM [Int])
-> UniqFM [Int] -> [UniqFM [Int]] -> UniqFM [Int]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (([Int] -> [Int] -> [Int])
-> UniqFM [Int] -> UniqFM [Int] -> UniqFM [Int]
forall elt.
(elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt
plusUFM_C ((Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)))
                                UniqFM [Int]
forall elt. UniqFM elt
emptyUFM
                        ([UniqFM [Int]] -> UniqFM [Int]) -> [UniqFM [Int]] -> UniqFM [Int]
forall a b. (a -> b) -> a -> b
$ (RegAllocStats -> UniqFM [Int])
-> [RegAllocStats] -> [UniqFM [Int]]
forall a b. (a -> b) -> [a] -> [b]
map RegAllocStats -> UniqFM [Int]
ra_spillInstrs [RegAllocStats]
statss

        spillTotals :: [Int]
spillTotals     = ([Int] -> [Int] -> [Int]) -> [Int] -> [[Int]] -> [Int]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+))
                                [0, 0, 0, 0, 0]
                        ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ UniqFM [Int] -> [[Int]]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM UniqFM [Int]
spills
                        -- See Note [Unique Determinism and code generation]

        -- count how many reg-reg-moves remain in the code
        moves :: Int
moves           = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (NatCmmDecl statics instr -> Int)
-> [NatCmmDecl statics instr] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map NatCmmDecl statics instr -> Int
forall instr statics.
Instruction instr =>
NatCmmDecl statics instr -> Int
countRegRegMovesNat [NatCmmDecl statics instr]
code

        pprSpill :: (a, [a]) -> SDoc
pprSpill (reg :: a
reg, spills :: [a]
spills)
                = SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate (String -> SDoc
text ", ")  (SDoc -> SDoc
doubleQuotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
reg) SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (a -> SDoc) -> [a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map a -> SDoc
forall a. Outputable a => a -> SDoc
ppr [a]
spills))

   in   (  String -> SDoc
text "-- spills-added-total"
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "--    (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)"
        SDoc -> SDoc -> SDoc
$$ (SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate (String -> SDoc
text ", ") ((Int -> SDoc) -> [Int] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Int]
spillTotals [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
moves])))
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text ""
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "-- spills-added"
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "--    (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
        SDoc -> SDoc -> SDoc
$$ (UniqFM [Int] -> ([(Unique, [Int])] -> SDoc) -> SDoc
forall a. UniqFM a -> ([(Unique, a)] -> SDoc) -> SDoc
pprUFMWithKeys UniqFM [Int]
spills ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc)
-> ([(Unique, [Int])] -> [SDoc]) -> [(Unique, [Int])] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Unique, [Int]) -> SDoc) -> [(Unique, [Int])] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Unique, [Int]) -> SDoc
forall a a. (Outputable a, Outputable a) => (a, [a]) -> SDoc
pprSpill))
        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "")