cacheprof.hs

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

{------------------------------------------------------------------------}
{--- The driver program for cacheprof.                   CacheProf.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 Maybe
import List
import IO
import System

#ifdef __HBC__
-- Chalmers Haskell, hbc 0.9999.5b
import GetPid(getPid)
type ProcessID = Int
compiler = "hbc"
getProcessID = getPid
#else
#ifdef __NHC__
-- Niklas/Malcolm's NHC, v 1.0pre14 (991202)
compiler = "nhc"
--foreign import "getpid" getProcessID :: IO Int
-- pre14 dies on this f-i decl, for some reason
-- It will be fixed in pre15, MalcolmW tells me
getProcessID = return 9876
#else
-- assume Glasgow Haskell (GHC)
import Posix(ProcessID,getProcessID)
compiler = "ghc"
#endif
#endif

--import IOExts(trace)            -- only for debugging
--import IOExts(unsafePerformIO)  -- look away now

{- 
NB.  These notes are somewhat out of date.

1.  Get sources.

2.  Find stopping point.

3.  outname
       = if stopping at exe then (fromCmdLine or a.out)
         else 
         if # sources == 1 then fromCmdLine
         else none

4.  create initial actions

    if end < exe {
       for each src => Step src (outname or derived)
    } else {
       for each src which is not an object
         => Step src tmp_object
       and Link [tmp_objects ++ src objects] outname
    }

5.  Simplify actions

      Step s t
        |  s <= asm and (t == obj or t == ann)
        => Step s tmp1(asm) 
           Step tmp1(asm) tmp2(ann)
           Step tmp2(ann) t

6.  Do actions

7.  Delete temps
-}

-- A class for finite partial orders (yes, really!)
class Eq a => OrdPF a where
   -- required
   stepRel  :: [(a,a)]    -- in [(child,parent)] order

   -- defaults
   lt, leq, gt, geq, incompar :: a -> a -> Bool

   incompar x y = not (x `leq` y) && not (y `leq` x)
   lt x y       = x /= y && leq x y
   gt           = flip lt
   geq          = flip leq

   leq x y 
      = y `elem` upclosure [x]
        where
           step p
              = [qq | (pp,qq) <- stepRel, p == pp]
           upclosure ps
              = let newps = nub (ps ++ concatMap step ps)
                in  if eqBag newps ps then ps else upclosure newps
           eqBag bag1 bag2
              = all (`elem` bag1) bag2 && all (`elem` bag2) bag1


data Name 
   = Tmp String | Real String 
     deriving (Show,Eq)

data Action 
   = Step Stage Name Stage Name
   | Link [Name] Name
     deriving (Show,Eq)

data Stage 
   = SrcC         -- C/C++ source
   | SrcF         -- Fortran source
   | Cpp          -- cpp'd C/C++ source
   | Asm          -- nominally machine generated assembly
   | SrcS         -- (Handwritten) assembly source, needs cpp-ing
   | Ann          -- Annotated assembly
   | Obj          -- Object code
   | Exe          -- Executable
     deriving (Show,Eq)

data Program
   = PreProc
   | Compiler   -- originally meant cc1 but corrupted to mean gcc
   | Annotator
   | Assembler
   | Linker
     deriving (Eq, Show)

data RtsKind
   = Rts_GHC
   | Rts_HBC
   | Rts_Unknown
     deriving (Eq, Show)

-- pay attention!  Stage forms a finite partial order
instance OrdPF Stage where
   stepRel 
      = [(Exe,Obj), 
         (Obj,Ann), 
         (Ann,Asm), 
         (Asm,Cpp), (Asm,SrcS), (Asm,SrcF),
         (Cpp,SrcC)]



data Config
   = Config {
        cacheprof_name :: String,
        comp_name      :: String,
        lib_path       :: String,
        rts_opts       :: [String],
        prof_level     :: Int,
        debug_flags    :: [String],
        pid            :: Int,
        rts_kind       :: RtsKind,
        no_g           :: Bool
     }
     deriving Show


pp config (Tmp s)  = "/tmp/cacheprof" 
                     ++ show (pid config) ++ "_" ++ s
pp config (Real s) = s

actionFlag st
   = case st of Cpp -> "-E"; Asm -> "-S"; Obj -> "-c"
                _ -> error "actionFlag\n"                

suffix_and_stage
   = [("c",SrcC), ("cpp",SrcC), ("f",SrcF), ("i",Cpp),("s",Asm),
      ("sA",Ann), ("o",Obj), ("a",Obj), ("S",SrcS),
      -- misc obscure "ways" for building GHC
      ("a_o",Obj), ("b_o",Obj), ("c_o",Obj),
      ("p_o",Obj), ("u_o",Obj)]

suffixes
   = map fst suffix_and_stage

derive_name :: String -> Stage -> Maybe String -> Name
derive_name src stage (Just onm) = Real onm
derive_name src stage Nothing
   = (Real . reverse . takeWhile (/='/') . reverse)
     (basename src ++ "." ++ extFor stage)

extFor stage
   = case [ext | (ext,st) <- suffix_and_stage, st==stage] of
       (e:_) -> e
       []    -> error "extFor\n"

mkTmp st n = Tmp (show n ++ "." ++ extFor st)

basename = reverse . drop 1 . dropWhile (/= '.') . reverse
extname  = reverse . takeWhile (/= '.') . reverse

stageOf nm
   = let extt = extname nm 
     in
     case [st | (ext,st) <- suffix_and_stage, ext==extt] of
        [st] -> st
        _ -> error "stageOf\n"

mysplit p xs = (filter p xs, filter (not.p) xs)

-- 1. Get sources
get_srcs :: [String] -> [String]
get_srcs allflags 
   = filter isSrcName (zap_after ["-o"] allflags)

isSrcName f 
   = take 1 f /= "-" && (extname f) `elem` suffixes

-- 2. Find stopping point
stopping_pt :: [String] -> Stage
stopping_pt allflags
   | "-E"  `elem` allflags  = Cpp
   | "-S"  `elem` allflags  = Asm
   | "-SA" `elem` allflags  = Ann
   | "-c"  `elem` allflags  = Obj
   | otherwise              = Exe

-- 3. Decide on outname
specd_outname :: [String] -> Maybe String
specd_outname []  = Nothing
specd_outname [_] = Nothing
specd_outname (mo:nm:rest)
   | mo == "-o" && take 1 nm /= "-"
   = Just nm
   | otherwise 
   = specd_outname (nm:rest)

decide_outname :: [String] -> [String] -> Stage -> Maybe String
decide_outname allflags sources stopping_stage
   | stopping_stage == Exe
   = case specd of { Just n -> Just n ; Nothing -> Just "a.out" }
   | length sources == 1
   = specd
   | otherwise
   = Nothing
     where
        specd = specd_outname allflags

-- 4. Create initial actions
initial_actions :: [String] -> (Int, [Action])
initial_actions allflags
   = let sources        = get_srcs allflags
         stopping_stage = stopping_pt allflags
         outnm          = decide_outname allflags sources stopping_stage
     in  

     if   stopping_stage `gt` Exe

     then let f src
                 = Step (stageOf src) (Real src) stopping_stage
                        (derive_name src stopping_stage outnm)
          in
              (0, map f sources)

     else let (obj,notobj) = mysplit ((==Obj).stageOf) sources
              len_notobj = length notobj
              tmpnms = map (mkTmp Obj) [0 .. len_notobj-1]
              f :: String -> Name -> Action
              f src tmpnm
                 = Step (stageOf src) (Real src) Obj tmpnm
              to_objs = zipWith f notobj tmpnms
              link = case outnm of
                        Just onm -> Link (tmpnms ++ map Real obj) 
                                         (Real onm)
                        Nothing  -> error "initial_actions\n"
          in
              (len_notobj, to_objs ++ [link])

-- 5. Simplify actions
simplified_actions :: [String] -> [Action]
simplified_actions allflags
   = let (n_init, initials0) = initial_actions allflags
         initials = filter (not . nonsensical) initials0

         -- one simplification pass
         one_pass :: Int -> [Action] -> (Int, [Action])
         one_pass n []
            = (n, [])
         one_pass n (a:as)
            = case one_pass n as of
                 (n2, as2) 
                    -> case simplify1 a n2 of
                          Nothing       -> (n2, a:as2)
                          Just (n3,sis) -> (n3, sis ++ as2)

         -- simplify to a fixed point
         fix :: Int -> [Action] -> [Action]
         fix n as
            = case one_pass n as of
                 (nn, as2) 
                    -> if as == as2 then as else fix nn as2
     in
         fix n_init initials

nonsensical (Step sst _ tst _) = sst `lt` tst
nonsensical (Link _ _) = False

simplify1 :: Action -> Int -> Maybe (Int, [Action])
simplify1 (Step sst snm tst tnm) n

   | incompar sst tst
   = error ("cacheprof: illogical request in command line:\n" ++
            case (sst,tst) of
               (SrcF,Cpp) -> "   cpp-expansion of Fortran source\n"
               other      -> "   stages are " ++ show (sst,tst) ++ "\n"
           )

   | sst `gt` Asm && (tst == Obj || tst == Ann)
   = let t1 = mkTmp Asm n
         t2 = mkTmp Ann (n+1)
     in  Just (n+2, [Step sst snm Asm t1, 
                     Step Asm t1 Ann t2, 
                     Step Ann t2 tst tnm])

   | sst == Asm && tst == Obj
   = let t1 = mkTmp Ann n
     in  Just (n+1, [Step sst snm Ann t1, 
                     Step Ann t1 tst tnm])

   | sst == SrcC && tst == Asm
   = let t1 = mkTmp Cpp n
     in  Just (n+1, [Step sst snm Cpp t1,
                     Step Cpp t1 tst tnm])

   | otherwise
   = Nothing
simplify1 (Link _ _) n
   = Nothing


-- 6. Cook up commands
make_commands :: Config -> [String] -> IO ([String], Maybe String)
make_commands config allflags
   = let verbose
            = "-v" `elem` allflags
         extras
            = clean_extra_flags allflags
         stuff_to_do 
            = simplified_actions allflags
         rts_stuff
            = let flag_text = unwords (rts_opts config)
              in  case rts_kind config of
                     Rts_GHC -> "+RTS " ++ flag_text ++ " -H16m -RTS "
                     Rts_HBC -> " " ++ flag_text ++ " -H32m - "
                     Rts_Unknown
                        -> error "cacheprof: make_commands: rts_stuff"
         mk_basis_cmd (Step sst snm tst tnm)
            | sst == tst
            = if   snm == tnm
              then "" 
              else "cp -f " ++ pp config snm ++ " " ++ pp config tnm
         mk_basis_cmd (Step SrcS snm Asm tnm)
            = comp_name config 
              ++ " -E -o " ++ pp config tnm
              ++ " " ++ pp config snm 
              ++ " " ++ unwords (extraFlags SrcS Asm extras)
         mk_basis_cmd (Step Asm snm Ann tnm)
            = lib_path config ++ "/cacheann " ++ rts_stuff
              ++ lib_path config ++ " "