{-# OPTIONS -Wall #-}
{-# LANGUAGE OverloadedStrings #-}


module Language.Pck.Tool.Profiler (
        -- * Profiler driver
          runProf
        , runProfIO
        , prof
        -- * Data type
        , ProfMode(..)
  ) where

import qualified Data.ByteString.Char8 as B
import Data.List (foldl', sortBy, nub)
import qualified Data.Map as Map
import Data.Function (on)
import Text.Printf (printf)

import Language.Pck.Cpu.Memory
import Language.Pck.Tool.Debugger


----------------------------------------
--  driver
----------------------------------------
-- | the profile mode for 'prof', 'runProf' and 'runProfIO'
data ProfMode = ProfInst    -- ^ instruction profile
              | ProfPC      -- ^ pc profile
              | ProfCall    -- ^ call profile
              | ProfBranch  -- ^ branch, jump, call profile
              | ProfLoad    -- ^ memory load profile
              | ProfStore   -- ^ memory store profile
              deriving Eq


-- | run the profiler
--
-- Example: instruction count profile
--
-- >  > runProf [ProfInst] [(0,[MOVI R1 0, MOVI R2 8, ST R1 R2, HALT])] []
-- >   instruction profile:
-- >   
-- >     MOVI  2
-- >     HALT  1
-- >     ST    1
-- >   
-- >     total 4
--
-- Example: memory store profile
--
-- >  > runProf [ProfStore] [(0,insts)] []
-- >  Memory store address profile:
-- >  
-- >    address       count
-- >    0x00000000    1
-- >    0x00000001    1
-- >    0x00000002    1
-- >    0x00000003    1
-- >    0x00000004    1
-- >    0x00000005    1
-- >    0x00000006    1
-- >  
-- >    total         7
--   
-- Example: branch,jump,call profile
--
-- >  > runProf [ProfBranch] [(0,insts)] []
-- >  Branch/Jump/Call target profile:
-- >  
-- >    address       count
-- >    0x00000007    6
-- >  
-- >    total 6
-- >  
-- >  
-- >  Branch/Jump/Call direction profile:
-- >  
-- >    T/N   count
-- >    Taken 6
-- >    Not   1
-- >  
-- >    total 7
--   
runProf :: [ProfMode] -> InstImage -> DataImage -> String
runProf profmd insts vals =
    let dbgtrc = modeProfToTrc profmd
        (trc, _) = runDbg dbgtrc [] insts vals
    in  prof profmd trc


-- | run the profiler for IO output
--
-- Example:
--
-- > > runProfIO [ProfInst] [(0,[MOVI R1 0, MOVI R2 8, ST R1 R2, HALT])] []
-- >  instruction profile:
-- >  
-- >    MOVI  2
-- >    HALT  1
-- >    ST    1
-- >  
-- >    total 4
--
runProfIO :: [ProfMode] -> InstImage -> DataImage -> IO ()
runProfIO profmd insts vals = putStr $ runProf profmd insts vals


-- | profile function
--
-- Example:
--
-- > > prof [ProfInst] $ fst $ runDbg [TrcInst] [] [(0,insts)] []
-- >  instruction profile:
-- >  
-- >    MOVI  2
-- >    HALT  1
-- >    ST    1
-- >  
-- >    total 4
--
prof :: [ProfMode] -> B.ByteString -> String
prof profmd trclog = concatMap (`profOne` trclog) profmd


modeProfToTrc :: [ProfMode] -> [DbgTrc]
modeProfToTrc profmd = nub $ foldl' (\v x -> gen x ++ v) [] profmd
    where gen ProfInst   = [TrcInst]
          gen ProfCall   = [TrcCall]
          gen ProfBranch = [TrcBranch]
          gen ProfLoad   = [TrcLoad]
          gen ProfStore  = [TrcStore]
          gen _          = []

----------------------------------------
--  profiler
----------------------------------------
profOne :: ProfMode -> B.ByteString -> String
profOne ProfInst   trclog = pprInstCounts trclog
profOne ProfCall   trclog = pprCallCounts trclog
profOne ProfBranch trclog = pprBranchAdCounts trclog ++ pprBranchTNCounts trclog
profOne ProfLoad   trclog = pprLoadCounts trclog
profOne ProfStore  trclog = pprStoreCounts trclog
profOne _         _      = ""



----------------------------------------
--  each profilings and pretty prints
----------------------------------------
-- instruction count
pprInstCounts :: B.ByteString -> String
pprInstCounts trclog = pprTrcCounts hfmt cfmt tfmt counts 50
    where hfmt = "\ninstruction profile:\n\n"
          cfmt = "  %s\t%s\n"
          tfmt = "\n  total %s\n\n"
          counts = calcTrcCounts "TrcInst:" 2 0 trclog

-- memory load count
pprLoadCounts :: B.ByteString -> String
pprLoadCounts trclog = pprTrcCounts hfmt cfmt tfmt counts 50
    where hfmt = "\nMemory load address profile:\n\n  address\tcount\n"
          cfmt = "  %s\t%s\n"
          tfmt = "\n  total   \t%s\n\n"
          counts = fstHex $ calcTrcCounts "TrcLoad:" 1 2 trclog

-- memory load count
pprStoreCounts :: B.ByteString -> String
pprStoreCounts trclog = pprTrcCounts hfmt cfmt tfmt counts 50
    where hfmt = "\nMemory store address profile:\n\n  address\tcount\n"
          cfmt = "  %s\t%s\n"
          tfmt = "\n  total   \t%s\n\n"
          counts = fstHex $ calcTrcCounts "TrcStore:" 1 2 trclog

-- call count
pprCallCounts :: B.ByteString -> String
pprCallCounts trclog = pprTrcCounts hfmt cfmt tfmt counts 50
    where hfmt = "\nCall target profile:\n\n  address\tcount\n"
          cfmt = "  %s\t%s\n"
          tfmt = "\n  total   \t%s\n\n"
          counts = fstHex $ calcTrcCounts "TrcCall:" 1 2 trclog

-- branch address count
pprBranchAdCounts :: B.ByteString -> String
pprBranchAdCounts trclog = pprTrcCounts hfmt cfmt tfmt counts 50
    where hfmt = "\nBranch/Jump/Call target profile:\n\n  address\tcount\n"
          cfmt = "  %s\t%s\n"
          tfmt = "\n  total\t%s\n\n"
          counts = fstHex $ calcTrcCounts "TrcBranch:" 1 2 
                          $ filterLines 2 0 (== "Taken") trclog

-- branch direction count
pprBranchTNCounts :: B.ByteString -> String
pprBranchTNCounts trclog = pprTrcCounts hfmt cfmt tfmt counts 50
    where hfmt = "\nBranch/Jump/Call direction profile:\n\n  T/N\tcount\n"
          cfmt = "  %s\t%s\n"
          tfmt = "\n  total\t%s\n\n"
          counts = calcTrcCounts "TrcBranch:" 2 0 trclog



----------------------------------------
-- statistics utility 
----------------------------------------
                      -- key          value
type KeyCounts = Map.Map B.ByteString Int

initKeyCounts :: KeyCounts
initKeyCounts = Map.empty

addKey :: KeyCounts -> B.ByteString -> KeyCounts
addKey kc key = Map.insertWithKey (\_ _ o -> o + 1) key 1 kc

calcKeyCounts :: [B.ByteString] -> KeyCounts
calcKeyCounts = foldl' addKey initKeyCounts



----------------------------------------
-- utility 
----------------------------------------
-- counter
pprTrcCounts :: String -> String -> String -> [(B.ByteString, Int)]
                  -> Int -> String
pprTrcCounts hfmt cfmt tfmt counts lim = hfmt ++ pprCounts ++ pprTotal
    where pprCounts = concatMap ppr (take lim counts)
          ppr (op, n) = printf cfmt (B.unpack op) (show n)
          total  = show . sum . map snd $ counts
          pprTotal = printf tfmt total

calcTrcCounts ::  B.ByteString -> Int -> Int -> B.ByteString
                    -> [(B.ByteString, Int)]
calcTrcCounts label ntab nspc =
                 sortBy (flip (compare `on` snd)) . Map.toList
               . calcKeyCounts
               . map (extractField ntab nspc)
               . extractLines label

extractLines :: B.ByteString -> B.ByteString -> [B.ByteString]
extractLines prefix = filter (prefix `B.isPrefixOf`)
                    . filter (`notElem` [""])
                    . B.lines

extractField :: Int -> Int -> B.ByteString -> B.ByteString
extractField ntab nspc xs = field
    where ftab  = B.splitWith (== '\t') xs
          fspc
            | null ftab = []
            | otherwise = B.splitWith (== ' ') (ftab !! ntab)
          field 
            | null fspc = ""
            | otherwise = fspc !! nspc

filterLines :: Int -> Int -> (B.ByteString -> Bool) ->
                 B.ByteString -> B.ByteString
filterLines ntab nspc f = B.unlines . filter cond . B.lines
    where cond xs = f $ extractField ntab nspc xs


-- converter
fstHex :: [(B.ByteString, Int)] -> [(B.ByteString, Int)]
fstHex = pairMap toHexBS id

toHexBS :: B.ByteString -> B.ByteString
toHexBS = B.pack . printf "0x%08x" . (read :: String -> Int) . B.unpack

pairMap :: (a->a1) -> (b->b1) -> [(a, b)] -> [(a1, b1)]
pairMap fa fb = map (\(a,b) -> (fa a, fb b))