module GHC.CmmToAsm.Reg.Linear.Stats (
        binSpillReasons,
        countRegRegMovesNat,
        pprStats
)

where

import GHC.Prelude

import GHC.CmmToAsm.Reg.Linear.Base
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Instr
import GHC.Types.Unique (Unique)
import GHC.CmmToAsm.Types

import GHC.Types.Unique.FM

import GHC.Utils.Outputable
import GHC.Utils.Monad.State.Strict

-- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
binSpillReasons
        :: [SpillReason] -> UniqFM Unique [Int]
        -- See Note [UniqFM and the register allocator]
binSpillReasons :: [SpillReason] -> UniqFM Unique [Int]
binSpillReasons [SpillReason]
reasons
        = ([Int] -> [Int] -> [Int])
-> UniqFM Unique [Int] -> [(Unique, [Int])] -> UniqFM Unique [Int]
forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> [(key, elt)] -> UniqFM key 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 Unique [Int]
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM
                ((SpillReason -> (Unique, [Int]))
-> [SpillReason] -> [(Unique, [Int])]
forall a b. (a -> b) -> [a] -> [b]
map (\SpillReason
reason -> case SpillReason
reason of
                        SpillAlloc Unique
r    -> (Unique
r, [Int
1, Int
0, Int
0, Int
0, Int
0])
                        SpillClobber Unique
r  -> (Unique
r, [Int
0, Int
1, Int
0, Int
0, Int
0])
                        SpillLoad Unique
r     -> (Unique
r, [Int
0, Int
0, Int
1, Int
0, Int
0])
                        SpillJoinRR Unique
r   -> (Unique
r, [Int
0, Int
0, Int
0, Int
1, Int
0])
                        SpillJoinRM Unique
r   -> (Unique
r, [Int
0, Int
0, Int
0, Int
0, Int
1])) [SpillReason]
reasons)


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

countRegRegMovesNat :: forall instr statics.
Instruction instr =>
NatCmmDecl statics instr -> Int
countRegRegMovesNat 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) Int
0
 where
        countBlock :: GenBasicBlock b -> State s (GenBasicBlock b)
countBlock b :: GenBasicBlock b
b@(BasicBlock BlockId
_ [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 {b} {s}. (Instruction b, Num s) => b -> State s b
countInstr [b]
instrs
                GenBasicBlock b -> State s (GenBasicBlock b)
forall a. a -> State s a
forall (m :: * -> *) a. Monad m => a -> m a
return  GenBasicBlock b
b

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

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


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

pprStats :: forall instr statics.
Instruction instr =>
[NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc
pprStats [NatCmmDecl statics instr]
code [RegAllocStats]
statss
 = let  -- sum up all the instrs inserted by the spiller
        -- See Note [UniqFM and the register allocator]
        spills :: UniqFM Unique [Int]
        spills :: UniqFM Unique [Int]
spills          = (UniqFM Unique [Int] -> UniqFM Unique [Int] -> UniqFM Unique [Int])
-> UniqFM Unique [Int]
-> [UniqFM Unique [Int]]
-> UniqFM Unique [Int]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (([Int] -> [Int] -> [Int])
-> UniqFM Unique [Int]
-> UniqFM Unique [Int]
-> UniqFM Unique [Int]
forall {k} elt (key :: k).
(elt -> elt -> elt)
-> UniqFM key elt -> UniqFM key elt -> UniqFM key 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 Unique [Int]
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM
                        ([UniqFM Unique [Int]] -> UniqFM Unique [Int])
-> [UniqFM Unique [Int]] -> UniqFM Unique [Int]
forall a b. (a -> b) -> a -> b
$ (RegAllocStats -> UniqFM Unique [Int])
-> [RegAllocStats] -> [UniqFM Unique [Int]]
forall a b. (a -> b) -> [a] -> [b]
map RegAllocStats -> UniqFM Unique [Int]
ra_spillInstrs [RegAllocStats]
statss

        spillTotals :: [Int]
spillTotals     = ([Int] -> [Int] -> [Int]) -> [Int] -> [[Int]] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> b
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
(+))
                                [Int
0, Int
0, Int
0, Int
0, Int
0]
                        ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ UniqFM Unique [Int] -> [[Int]]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM Unique [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 a. Num a => [a] -> a
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 (a
reg, [a]
spills)
                = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
", ")  (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
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
forall doc. IsLine doc => String -> doc
text String
"-- spills-added-total"
        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"--    (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)"
        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
", ") ((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
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
""
        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-- spills-added"
        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"--    (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
        SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ (UniqFM Unique [Int] -> ([(Unique, [Int])] -> SDoc) -> SDoc
forall {k} (key :: k) a.
UniqFM key a -> ([(Unique, a)] -> SDoc) -> SDoc
pprUFMWithKeys UniqFM Unique [Int]
spills ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"")