cacheprof.hs

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

              ++ "--level" ++ show (prof_level config) ++ " "
              ++ unwords (debug_flags config) ++ " "
              ++ (if verbose then "-v " else "")
              ++ "< " ++ pp config snm ++ " > " ++ pp config tnm
         mk_basis_cmd (Step sst snm tst tnm)
            | (sst,tst) `elem` 
              [ (SrcC,Cpp), (Cpp,Asm), (Ann,Obj), (SrcF,Asm) ]
            = comp_name config ++ " "
              ++ (if tst `geq` Asm && not (no_g config) then "-g " else "") 
              ++ (if sst == Ann then "-x assembler " else "")
              ++ "-o " ++ pp config tnm ++ " " 
              ++ actionFlag tst ++ " " ++ pp config snm
              ++ " " ++ unwords (extraFlags sst tst extras)
         mk_basis_cmd (Link ins out)
            = comp_name config ++ " -o " ++ pp config out 
              ++ (if   prof_level config > 0
                  then " " ++ lib_path config ++ "/cachesim.o " 
                  else " ")
              ++ unwords (map (pp config) ins)
              ++ " " ++ unwords (extraFlags Obj Exe extras)
         mk_basis_cmd other
            = error ( "\ncacheprof: mk_basis_command: can't handle\n\t"
                      ++ show other ++ "\n" )

         tnms
            = concat (map tnmsIn stuff_to_do)
         nuke_command
            = "rm -f " 
               ++ (unwords . sort . nub 
                   . filter (not . any (== '*'))
                   . filter (not . any (== '?'))
                   . filter (not.null) . map (pp config)) tnms
         basis_cmds 
            = (map escapeStr (filter (not.null) (map mk_basis_cmd stuff_to_do)),
               if null tnms then Nothing else Just nuke_command)
         unknowns
            = unknown_flags extras
     in
         if   null unknowns
         then return basis_cmds
         else do hPutStr stderr  
                         (cacheprof_name config 
                          ++ ": warning: can't map flags: " 
                          ++ unwords unknowns ++ "\n")
                 return basis_cmds

escapeStr 
   = concatMap escapeChar
     where escapeChar '"' = ['\\', '"']
           escapeChar c   = [c]

tnmsIn (Step _ snm _ tnm) = filter isTnm [snm,tnm]
tnmsIn (Link ins out)     = filter isTnm (out:ins)
isTnm nm = case nm of Tmp _ -> True; Real _ -> False

extraFlags :: Stage -> Stage -> [String] -> [String]
extraFlags sst tst allExtras
   = let prog = program_for_step sst tst

         loop (f:f2:fs)
            | is_paired_flag f
            = if   prog `elem` relevant_progs_for f
              then f:f2: loop fs
              else loop fs
         loop (f:fs)
            = if   prog `elem` relevant_progs_for f
              then f : loop fs
              else loop fs
         loop [] 
            = []

     in  loop allExtras

relevant_progs_for :: String -> [Program]
relevant_progs_for flag
   = (nub.concat)
        [progs | (patt,progs) <- flag_mapping_table, matches flag patt]

unknown_flags :: [String] -> [String]
unknown_flags (f:f2:fs)
   | is_paired_flag f
   = (if null (relevant_progs_for f) then [f,f2] else [])
     ++ unknown_flags fs
unknown_flags (f:fs)
   = (if null (relevant_progs_for f) then [f] else [])
     ++ unknown_flags fs
unknown_flags []
   = []

matches :: String -> String -> Bool
matches f patt
   | last patt == '*'
   = init patt `isPrefixOf` f
   | otherwise
   = patt == f

matchesAny :: String -> [String] -> Bool
matchesAny f patts
   = any (matches f) patts

program_for_step :: Stage -> Stage -> Program
-- all single steps
program_for_step SrcC Cpp = PreProc
program_for_step SrcS Asm = PreProc
program_for_step Cpp  Asm = Compiler
program_for_step SrcF Asm = Compiler
program_for_step Asm  Ann = Annotator
program_for_step Ann  Obj = Assembler
program_for_step Obj  Exe = Linker
-- kludges :-(
program_for_step SrcC  Asm = Compiler
program_for_step sst tst 
   = error ("program_for_step: " ++ show (sst,tst))

is_paired_flag :: String -> Bool
is_paired_flag f = f `elem` paired_flags

-- flags in which the following flag is really part of it,
-- eg    -u Wurble
paired_flags :: [String]
paired_flags 
   = ["-u"]

flag_mapping_table :: [(String, [Program])]
flag_mapping_table 
   = [
        ("-v", [PreProc, Compiler, Annotator, Assembler, Linker]),

        ("-I*", [PreProc]), ("-D*", [PreProc]), ("-U*", [PreProc]),

        ("-O*",       [Compiler]),
        ("-W*",       [Compiler]),
        ("-f*",       [Compiler]),
        ("-ansi",     [PreProc, Compiler]),
        ("-pedantic", [PreProc, Compiler]),

        ("-L*", [Linker]), ("-l*", [Linker]), ("-u", [Linker])
     ]        

zappable_flags
   = [ "-E", "-S", "-SA", "-c", "-g" ]
zappable_afters
   = [ "-o" ]
incompatible_flags
   = [ "-p", "-pg", "-pipe" ]

clean_extra_flags
   = zap_flags zappable_flags 
     . zap_sourcenames
     . zap_after zappable_afters 

zap_sourcenames flags
   = filter (not.isSrcName) flags
zap_flags these_ones flags
   = filter (`notElem` these_ones) flags
zap_after these_ones flags
   = f flags
     where
        f []  = []
        f [x] = if x `elem` these_ones then [] else [x]
        f (x:y:xs) 
           | x `elem` these_ones = f xs
           | otherwise           = x : f (y:xs)


-- 7.  Generate the actions, or fail
generate_actions :: Config -> [String] -> IO (Maybe ([String],Maybe String))
generate_actions config allflags
   | null incompats
   = do cmds <- make_commands config allflags
        return (Just cmds)
   | otherwise
   = do hPutStr stderr (
           cacheprof_name config ++ ": incompatible flags: "
           ++ unwords incompats ++ "\n")
        return Nothing
   where
      incompats = filter (`elem` incompatible_flags) allflags


known_cacheprof_flags
   = ["--dryrun", "--help", "-v", "--verbose", 
      "--level0", "--level1", "--level2",
      "--cacheprofdir=*", "-H*", "-K*", "-ddump-*", 
       "--license", "--no-g"]

known_compilers
   = ["gcc", "g++", "g77"]

helpString prog_name
   = unlines [
        "",
        "cacheprof profiling suite, version 0.1 (991209), at your service.",
        "",
        "usage: " ++ prog_name ++ " [options_for_cacheprof] compile_command",
        "",
        "options_for_cacheprof are:",
        "   --dryrun     don't do anything -- just show what would be done",
        "   --help       produces this message",
        "   -v           be verbose",
        "   --license    show the license",
        "   -H16m        set heap size for annotator prog to (eg) 16 megs",
        "   -K1m         set stack size for annotator prog to (eg) 1 meg",
        "   --level0     no profiling; just simplify (for debugging)",
        "   --level1     just count insns",
        "   --level2     (default) count insns and do cache profiling",
        "   --cacheprofdir=/xxx/yyy/zzz",
        "                cacheprof installation directory is /xxx/yyy/zzz",
        "                   (otherwise: use env variable CACHEPROFDIR,",
        "                    and if that isn't set, \"./\")",
        "   --ddump-foo  (debugging) show cacheann structures after",
        "                   phase foo",
        "   --no-g       don't ask the compiler for debug information",
        "",
        "compile_command is whatever you would have normally compiled with",
        "   eg    g++ -o myFile.o -c myFile.cpp -O -Wall -I/some/incl/dir",
        ""
     ]

licenseString
   = (unlines . map ("   "++)) [
        "",
        "This program is Cacheprof, a profiling tool for finding",
        "sources of cache misses in programs.  Version 0.1 (991209).",
        "",
        "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.",
        ""
     ]

more_info_msg prog_name
   = "   try `" ++ prog_name ++ " --help' for more information.\n"

guess_lib_path :: [String] -> IO String
guess_lib_path myflags
   = case filter (flip matches "--cacheprofdir=*") myflags of
        (f:fs) -> return (drop (length "--cacheprofdir=") f)
        []     -> catch (getEnv "CACHEPROFDIR") (\e -> return ".")

get_rts_opts :: [String] -> [String]
get_rts_opts myflags
   = filter (flip matchesAny ["-H*", "-K*"]) myflags

-- 8.  Main!
main :: IO ()
main = stderr `seq` 
       (getArgs >>= mainArgs)

mainArgs allflags
   = do prog_name <- getProgName
        pid       <- getProcessID
        let (myflags, theirflags0) 
               = span ((=="-") . take 1) allflags
            (compiler_name:theirflags) = theirflags0
            dryrun  = "--dryrun"  `elem` myflags
            help    = "--help"    `elem` myflags
            license = "--license" `elem` myflags
            no_g    = "--no-g"    `elem` myflags
            prof_level
                    = if "--level0" `elem` myflags then 0
                      else if "--level1" `elem` myflags then 1
                      else if "--level2" `elem` myflags then 2
                      else 2

            verbose = "-v" `elem` (myflags ++ theirflags)
            srcs = get_srcs theirflags
            bad_my_flags = filter (\f -> not (matchesAny f 
                                                 known_cacheprof_flags))
                                  myflags
            debug_flags = filter (flip matches "--ddump-*") myflags
            more_info = more_info_msg prog_name
            rts_kind
               = case compiler of
                    "hbc" -> Rts_HBC
                    "ghc" -> Rts_GHC
                    "nhc" -> Rts_GHC
                    other -> Rts_Unknown

        if    help
         then do hPutStr stderr (helpString prog_name)
                 exitWith ExitSuccess
         else
         if   license
         then do hPutStr stderr licenseString
                 exitWith ExitSuccess
         else
         if   not (null bad_my_flags)
         then do hPutStr stderr 
                         (prog_name ++ ": unrecognised option `" 
                          ++ head bad_my_flags ++ "'\n" ++ more_info)
                 exitWith (ExitFailure 1)
         else
         if   null theirflags0
         then do hPutStr stderr 
                         (prog_name ++ ": no compile command to run\n"
                          ++ more_info)
                 exitWith (ExitFailure 1)
         else
         if   take 3 compiler_name `notElem` known_compilers
         then do hPutStr stderr 
                         (prog_name ++ ": `" ++ compiler_name 
                          ++ "' is not a recognised compiler name.\n   "
                          ++ "recognised compiler names are: " 
                          ++ unwords known_compilers ++ "\n" ++ more_info)
                 exitWith (ExitFailure 1)
         else
         if   null srcs
         then do hPutStr stderr
                         (prog_name ++ ": no input files in compile command\n"
                          ++ more_info)
                 exitWith (ExitFailure 1)
         else
         do lib_path <- guess_lib_path myflags
            let rts_opts = get_rts_opts myflags
            let config = Config { cacheprof_name = prog_name,
                                  lib_path       = lib_path,
                                  comp_name      = compiler_name,
                                  rts_opts       = rts_opts,
                                  prof_level     = prof_level,
                                  debug_flags    = debug_flags,
                                  pid            = pid,
                                  rts_kind       = rts_kind,
                                  no_g           = no_g }
            acts <- generate_actions config theirflags
            case acts of
              Nothing
                 -> exitWith (ExitFailure 1)
              Just (cmdlines, nuke_command)
                 |  dryrun
                 -> do hPutStr stderr 
                               (unlines (cmdlines ++ catMaybes [nuke_command]))
                       exitWith ExitSuccess
                 |  otherwise
                 -> cmdLoop verbose nuke_command cmdlines


cmdLoop :: Bool -> Maybe String -> [String] -> IO ()
cmdLoop verbose nuke_command [] 
   = case nuke_command of
        Nothing        -> exitWith ExitSuccess
        Just nuke_tmps -> do r <- system nuke_tmps
                             exitWith ExitSuccess

cmdLoop verbose nuke_command (cmd:cmds)
   = do (if   verbose 
         then do hPutStr stderr equalzzz 
                 hPutStr stderr ("=== " ++ cmd ++ "\n")
                 hPutStr stderr equalzzz
         else return ())
        r <- system cmd
        if    r == ExitSuccess 
         then cmdLoop verbose nuke_command cmds 
         else case nuke_command of
                 Nothing        -> exitWith r
                 Just nuke_tmps -> do r2 <- system nuke_tmps
                                      exitWith r

equalzzz 
   = "==================================================\n"


{------------------------------------------------------------------------}
{--- end                                                 CacheProf.hs ---}
{------------------------------------------------------------------------}