cacheprint.hs

深入理解计算机系统（computer system：a programmer s perpective)是一本非常经典的教材

{------------------------------------------------------------------------}
{--- Print the contents of cacheprof.out in a readable way,           ---}
{--- and print annotated source code too.               CachePrint.hs ---}
{------------------------------------------------------------------------}

{- 
   This file is part of Cacheprof, a profiling tool for finding
   sources of cache misses in programs.

   Copyright (C) 1999 Julian Seward ([e-mail])
   Home page: http://www.cacheprof.org

   This program is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License as
   published by the Free Software Foundation; either version 2 of the
   License, or (at your option) any later version.

   This program is distributed in the hope that it will be useful, but
   WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
   02111-1307, USA.

   The GNU General Public License is contained in the file LICENSE.
-}

module Main ( main ) where
import System
import IO
import Char
import List
import StaticFM

#ifdef __HBC__
import Trace(trace)
hPutStrLn h s = do { hPutStr h s ; hPutStr h "\n" }
#else
#ifdef __NHC__
import NonStdTrace(trace)
#else
import IOExts(trace)
#endif
#endif

data Module
   = Module [String] [String] [CC]
     deriving Show
     --     filenames fnnames  ccs

getFileNames (Module filenames fnnames ccs) = filenames
getFnNames   (Module filenames fnnames ccs) = fnnames
getCCs       (Module filenames fnnames ccs) = ccs

data CC
   = CC Int Int Int Integer Integer
     deriving Show
     -- file#  line#  fn#  #rd+wr  #miss

getFileNo (CC fileno lineno fnno ntrans nmiss) = fileno
getLineNo (CC fileno lineno fnno ntrans nmiss) = lineno
getFnNo   (CC fileno lineno fnno ntrans nmiss) = fnno
getNTrans (CC fileno lineno fnno ntrans nmiss) = ntrans
getNMiss  (CC fileno lineno fnno ntrans nmiss) = nmiss

addCosts (CC fileno lineno fnno ntrans nmiss) ntrans_more nmiss_more
   = CC fileno lineno fnno (ntrans+ntrans_more) (nmiss+nmiss_more)

data ProfFile
   = ProfFile {
        mods::[Module],
        n_insns::Integer,
        n_r1 ::Integer, n_r2 ::Integer, n_r4 ::Integer, n_r8 ::Integer,
        n_mr1::Integer, n_mr2::Integer, n_mr4::Integer, n_mr8::Integer,
        n_w1 ::Integer, n_w2 ::Integer, n_w4 ::Integer, n_w8 ::Integer,
        n_mw1::Integer, n_mw2::Integer, n_mw4::Integer, n_mw8::Integer
     }
     deriving Show

internal fn
   = error ("\ncacheprint: Internal error: " ++ fn ++ "\n")
warn msg x
   = trace ("\ncacheprint warning: " ++ msg ++ "\n") x
noprofile
   = do hPutStrLn stderr (
           "cacheprint: Can't open profile file `cacheprof.out'.\n" ++
           "   (perhaps you specified only a level-1 profile?)  Giving up." )
        exitWith (ExitFailure 1)

zapDirName
   = reverse . takeWhile (/= '/') . reverse

main
   = stderr `seq`     -- work around bug in ghc-4.04 (sigh)
     do args0 <- getArgs
        txt   <- catch (readFile "cacheprof.out")
                      (\e -> noprofile)
        let prof = readProfFile (map words (lines txt))
            args = map zapDirName args0
         in case prof of
                Nothing
                   -> do hPutStrLn stderr (
                            "cacheprint: syntax error in `cacheprof.out'" ++
                            " -- giving up")
                Just info
                   -> let merged  = mergeModules (mods info)
                          reconst = info {mods = [merged]}
                          tryReadFile fname
                             = catch (readFile fname) (\e -> return "")
                      in  
                      do files <- mapM tryReadFile args0
                         let names_n_files = zip args files
                         putStrLn (makeTextFrom reconst names_n_files)

mergeModules :: [Module] -> Module
mergeModules []
   = internal "mergeModules"
mergeModules mods
   = let
         -- a list of all file names
         filenames
            = (nub . sort . concatMap getFileNames) mods
         fnnames         
            = (nub . sort . concatMap getFnNames) mods
         mergedCCs
            = concatMap (makeMapsAndRename filenames fnnames) mods
     in
         Module filenames fnnames mergedCCs

whereIs :: Eq a => a -> [a] -> Int
whereIs x xs
   = f 0 xs
     where
        f n []     = internal "whereIs"         
        f n (y:ys) = if x==y then n else f (n+1) ys

makeMapping :: Eq a => [a] -> [a] -> [Int]
makeMapping lesserMap biggerMap
   = map (flip whereIs biggerMap) lesserMap

renameUsingMaps :: [Int] -> [Int] -> CC -> CC
renameUsingMaps filenameMap fnnameMap 
   (CC fileno lineno funno ntrans nmiss)
   = CC (filenameMap!!fileno) lineno (fnnameMap!!funno)
        ntrans nmiss

makeMapsAndRename :: [String] -> [String] -> Module -> [CC]
makeMapsAndRename globalfis globalfns (Module localfis localfns ccs)
   = let filenameMap = makeMapping localfis globalfis
         fnnameMap   = makeMapping localfns globalfns
     in  map (renameUsingMaps filenameMap fnnameMap) ccs

makeTextFrom :: ProfFile -> [(String,String)] -> String
makeTextFrom pf names_n_files
   = unlines (
        title "Aggregate figures" ++ summary_text ++ blankline
        -- ++ title "File and function names" ++ names_text ++ blankline
        ++ title "Per-function summary" ++ per_fn_text ++ blankline
        ++ annotated_sources
     )
     where
        blankline = [ "" ]
        line = repeat '-'
        title_width = 108 :: Int
        title s = map (take title_width)
                      ["", line, "--- " ++ s ++ " " ++ line, line, ""]

        n_t1 = n_r1 pf + n_w1 pf
        n_t2 = n_r2 pf + n_w2 pf
        n_t4 = n_r4 pf + n_w4 pf
        n_t8 = n_r8 pf + n_w8 pf

        n_mt1 = n_mr1 pf + n_mw1 pf
        n_mt2 = n_mr2 pf + n_mw2 pf
        n_mt4 = n_mr4 pf + n_mw4 pf
        n_mt8 = n_mr8 pf + n_mw8 pf

        n_r  = n_r1 pf  + n_r2 pf  + n_r4 pf  + n_r8 pf
        n_w  = n_w1 pf  + n_w2 pf  + n_w4 pf  + n_w8 pf
        n_t  = n_t1     + n_t2     + n_t4     + n_t8

        n_mr = n_mr1 pf + n_mr2 pf + n_mr4 pf + n_mr8 pf
        n_mw = n_mw1 pf + n_mw2 pf + n_mw4 pf + n_mw8 pf
        n_mt = n_mt1    + n_mt2    + n_mt4    + n_mt8

        (Module filenames fnnames ccs) 
           = case mods pf of
                [x]   -> x
                other -> internal "makeTextFrom"


        ---------------------------------------------------
        --- Per-source file info --------------------------
        ---------------------------------------------------

        annotated_sources
           = concatMap annotate_source names_n_files

        annotate_source :: (String, String) -> [String]
        annotate_source (sfilename, stext)
           = let relevant_ccs
                    = getCCs_for_source sfilename
                 initial_fn_starts    -- [(fn_number, start_line)]
                    = get_fn_extents relevant_ccs
                 tagged_lines
                    = zip [1..] (lines stext)
                 
                 -- if we emit a function summary, remove the entry
                 -- from the function list, so that the summary is not
                 -- emitted again.  line_texts_from_here are the
                 -- lines starting at lno.
                 -- inefficient ...
                 extras lno line_texts_from_here fnstarts
                    = case filterOne this_is_a_fn_start fnstarts of
                         (Nothing, fnstarts2)
                            -> ([], fnstarts2)
                         (Just (fnno,fnlno), fnstarts2)
                            -> (mk_inline_function_summary
                                   (fnnames!!fnno),
                                fnstarts2)
                      where
                         this_is_a_fn_start (fnno,fnlno)
                            = fnlno `elem` [lno .. lno+10]
                              && looks_like_interfn_space
                                    line_texts_from_here

                         -- C/C++ specific hack :-(
                         looks_like_interfn_space (l1:ls)
                            = cleanup l1 == "" &&
                              any ('(' `elem`) (map cleanup (take 5 ls)) &&
                              any ('{' `elem`) (map cleanup (take 6 ls))
                         looks_like_interfn_space other
                            = False

                         cleanup
                            = filter (not.isSpace)

                 -- work through the CCs in order and the lines in
                 -- order, and produce annotated lines
                 f :: [CC] -> [(Int,String)] -> [(Int,Int)] -> [String]
                 f ccs0@(cc:ccs) pairs0@((lno,ltext):pairs) fnstarts

                    | getLineNo cc == lno
                    = case extras lno (map snd pairs0) fnstarts of
                         (xtext, fnstarts1)
                             -> xtext ++ [tag cc ltext] 
                                ++ f ccs pairs fnstarts1

                    | getLineNo cc > lno
                    = case extras lno (map snd pairs0) fnstarts of
                         (xtext, fnstarts1)
                             -> xtext ++ [notag ltext]
                                ++ f ccs0 pairs fnstarts1

                    | otherwise
                    = internal "makeTextFrom.annotate_source.f"

                 f [] pairs0@((lno,ltext):pairs) fnstarts
                    = case extras lno (map snd pairs0) fnstarts of
                         (xtext,fnstarts1)
                            -> xtext ++ [notag ltext]
                               ++ f [] pairs fnstarts1

                 f ccs@(_:_) [] fnstarts
                    = warn ( "cacheprof.out contains annotations for\n"
                             ++ "   non-existent source lines:\n"
                             ++ "      " ++ sfilename ++ ":" 
                             ++ show (getLineNo (head ccs)) ++ " up to "
                             ++ sfilename ++ ":" 
                             ++ show (getLineNo (last ccs)))
                           []

                 f [] [] fnstarts
                    = []

                 tag cc l
                    = ppN 11 (getNTrans cc)
                      ++ " " ++ ppN 10 (getNMiss cc)
                      ++ "  " ++ l
                 notag l
                    = "                        " ++ l
             in
                 title ("Annotated source: " ++ sfilename) 
                 ++ (if   null relevant_ccs 
                     then map ("   "++)
                          [ "Either this file can't be found or read,",
                           "or it does exist, but no memory references ",
                           "were recorded as originating from it."]
                     else f relevant_ccs tagged_lines initial_fn_starts)
                 -- ++ blankline
                 -- ++ map show fn_starts

        -- Get the CCs for a given source file.  Merge all CCs for
        -- the same line, and put the CCs in order of increasing line
        -- number.
        getCCs_for_source :: String -> [CC]
        getCCs_for_source sfilename
           | sfilename `notElem` filenames
           = []
           | otherwise
           = let fileno 
                    = whereIs sfilename filenames
                 ccs_raw 
                    = filter ((== fileno).getFileNo) ccs
                 ccs_nonzero
                    = filter ((> 0).getNTrans) ccs_raw
                 ccs_sorted
                    = sortBy (\cc1 cc2 -> compare (getLineNo cc1) 
                                                  (getLineNo cc2))
                             ccs_nonzero
                 ccs_merged
                    = merge_ccs ccs_sorted

                 merge_ccs []  = []
                 merge_ccs [x] = [x]
                 merge_ccs (cc1:cc2:ccs)
                    | getLineNo cc1 == getLineNo cc2
                    = merge_ccs 
                        ((addCosts cc2 (getNTrans cc1) (getNMiss cc1)):ccs)
                    | otherwise
                    = cc1 : merge_ccs (cc2:ccs)

                 sane_ccs [] = True
                 sane_ccs [_] = True
                 sane_ccs (cc1:cc2:ccs)
                    = getLineNo cc1 < getLineNo cc2
                      && getFileNo cc1 == getFileNo cc2
                      && sane_ccs (cc2:ccs)
             in
                 if   sane_ccs ccs_merged
                 then ccs_merged
                 else internal "makeTextFrom.getCCs_for_source"


        -- given a list of CCs pertaining to a specific source file, 
        -- return a list of function numbers in that file, along with the 
        -- least and greatest known line numbers for each function.
        -- actually, just returns the function starts ...
        get_fn_extents :: [CC] -> [(Int, Int)]
        get_fn_extents ccs
           = let 
                 fns = (nukeAdjacent . sort . map getFnNo) ccs
 
                 lim :: Int -> Int -> [CC] -> Int -> (Int,Int)
                 lim lo hi []       fn = (fn, lo)
                 lim lo hi (cc:ccs) fn
                    | fn == getFnNo cc
                    = let n = getLineNo cc 
                      in lim (min lo n) (max hi n) ccs fn
                    | otherwise
                    = lim lo hi ccs fn
                        
                 lims = map (lim 999999999 (-1) ccs) fns
              in
                 lims


        ---------------------------------------------------
        --- Per-fn info -----------------------------------
        ---------------------------------------------------

        mk_inline_function_summary :: String -> [String]
        mk_inline_function_summary fn_name
           = case filterOne ((==fn_name).fst3) full_per_fn_info of
                (Nothing, _)
                   -> internal "mk_inline_function_summary"
                (Just (_, nt, nm), _)
                   -> mk_inline_function_summary_text fn_name nt nm