cacheann.hs

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

mk_arch_label_def s = ".L" ++ s ++ ":"
mk_arch_label_use s = ".L" ++ s
tABLE_START_STRING  = "cacheprof_magic_table"
bUCKETS_START_STRING = "cacheprof_magic_buckets"

useCCdescriptors :: ([String],[String],[String],[(Int,Int,Int)]) 
                    -> [Line]
useCCdescriptors (debugging_text, filenames, funcnames, points)
   = let length_words
            = [mk_comment "number of filenames, funcnames, points, cc addr"]
              ++ map mk_word [length filenames, 
                              length funcnames, 
                              length points]
              ++ [mk_word_l bUCKETS_START_STRING]
         strings
            = filenames ++ funcnames
         string_bytes
            = concatMap mk_string strings
         point_words
            = concatMap mk_point_words points
         comments
            = map mk_comment debugging_text
         pre_comments
            = map mk_comment ["", "---- start of the cost centers ----"]
         post_comments
            = map mk_comment ["", "---- end of the cost centers ----"]
         mk_point_words p@(fileno,lineno,funcno)
            = mk_comment (show p)
              : map mk_word [fileno, lineno, funcno, 0,0, 0,0]
         preamble
            = mk_dataSeg ++ mk_align

         mk_Pseudo      = Pseudo 0
         mk_label_def s = mk_arch_label_def s
         mk_word i      = "\t.long " ++ show i
         mk_word_l l    = "\t.long " ++ mk_arch_label_use l
         mk_byte i      = "\t.byte " ++ show i
         mk_comment s   = "\t# " ++ s
         mk_string s    = [mk_comment (show s)]
                          ++ map (mk_byte.ord) s
                          ++ [mk_byte 0]
         mk_dataSeg     = ["\t.data"]
         mk_align       = ["\t.align 4"]
     in
         map mk_Pseudo (
            concat [pre_comments, comments, 
                    preamble,
                    [mk_label_def tABLE_START_STRING],
                    length_words, string_bytes,
                    mk_align,
                    [mk_label_def bUCKETS_START_STRING],
                    point_words, post_comments]
         )



{-------------------------------------------}
{--- Generate calls to the               ---}
{--- cache simulator (part 4)            ---}
{-------------------------------------------}

synthLine :: Int -> Line -> (Int, [Line])
synthLine nextcc (Pseudo ln stuff) 
   = (nextcc, [Pseudo ln stuff])
synthLine nextcc (Label ln stuff) 
   = (nextcc, [Label ln stuff])
synthLine nextcc (Real ln cc insn)
   | hasRealAnns insn
   = (nextcc+1, map (Real ln cc) (synth_wrk nextcc insn))
   | otherwise
   = (nextcc, [Real ln cc insn])



synth_wrk :: Int -> Insn -> [Insn]
synth_wrk ccid_to_use insn@(Insn ann opcode operands)
   = concatMap (useAnnot ccid_to_use) (getAnns ann)
     ++ [insn]

insn_pushl reg
   = Insn (mkAnnC "save") O_pushl [OP_REG reg]
insn_popl reg
   = Insn (mkAnnC "rest") O_popl [OP_REG reg]

std_preamble
   = [insn_pushl EAX, insn_pushl EBX]
std_postamble
   = [insn_popl EBX, insn_popl EAX]

useAnnot :: Int -> Annot -> [Insn]
useAnnot ccid (AnnC c) 
   = internal "useAnnot on comment annotation"

useAnnot ccid (AnnR sz op)
   = std_preamble 
     ++
     [ Insn (mkAnnC "rd-1") O_leal 
                            [op, OP_REG EAX],
       Insn (mkAnnC "rd-2") O_movl 
                            [mk_bucket_addr ccid, OP_REG EBX],
       Insn (mkAnnC "rd-3") O_call 
                            [OP_D (Const [Pos (mk_rd_hook_name sz)])]
     ]
     ++ std_postamble

useAnnot ccid (AnnM sz op)
   = std_preamble 
     ++
     [ Insn (mkAnnC "mo-1") O_leal 
                            [op, OP_REG EAX],
       Insn (mkAnnC "mo-2") O_movl 
                            [mk_bucket_addr ccid, OP_REG EBX],
       Insn (mkAnnC "mo-3") O_call 
                            [OP_D (Const [Pos (mk_mo_hook_name sz)])]
     ]
     ++ std_postamble

useAnnot ccid (AnnW sz op)
   = std_preamble
     ++ 
     [ Insn (mkAnnC "wr-1") O_leal 
                            [op, OP_REG EAX],
       Insn (mkAnnC "wr-2") O_movl 
                            [mk_bucket_addr ccid, OP_REG EBX],
       Insn (mkAnnC "wr-3") O_call 
                            [OP_D (Const [Pos (mk_wr_hook_name sz)])]
     ]
     ++ std_postamble

mk_bucket_addr ccid
   = OP_D (Const [Pos (UF_LABEL 
                         ("$" ++ mk_arch_label_use bUCKETS_START_STRING)),
                  Pos (UF_NUM (show (28 * ccid)))])

mk_rd_hook_name sz
   = UF_NAME ("cacheprof_hook_Rd" ++ show sz)
mk_mo_hook_name sz
   = UF_NAME ("cacheprof_hook_Mo" ++ show sz)
mk_wr_hook_name sz
   = UF_NAME ("cacheprof_hook_Wr" ++ show sz)


{-----------------------------------------------------------}
{--- Stage 7 for level 1 profiling.  At each notifiable  ---}
{--- memory reference (ie, at each place where level 2   ---}
{--- profiling would insert a call to the cache          ---}
{--- simulator, just increment the total read/write      ---}
{--- counts.                                             ---}
{-----------------------------------------------------------}

-- section-main
synth_1 :: [Line] -> [Line]
synth_1 = concatMap synth_1_wrk

synth_1_wrk :: Line -> [Line]
synth_1_wrk (Pseudo ln stuff) 
   = [Pseudo ln stuff]
synth_1_wrk (Label ln stuff) 
   = [Label ln stuff]
synth_1_wrk line@(Real ln cc insn@(Insn ann opcode operands))
   | hasRealAnns insn
   = map (Real ln cc) (concatMap useIncAnns (getAnns ann))
     ++ [line]
   | otherwise
   = [Real ln cc insn]
     where
        useIncAnns (AnnW sz op)
           = incSequence 1 "cacheprof_level1_writes"
        useIncAnns (AnnR sz op)
           = incSequence 1 "cacheprof_level1_reads"
        useIncAnns (AnnM sz op)
           = incSequence 1 "cacheprof_level1_reads" ++
             incSequence 1 "cacheprof_level1_writes"

-- generate a sequence to increment a 64-bit counter in
-- memory, labelled "name", by k
incSequence :: Int -> String -> [Insn]
incSequence k name
   = [Insn DontAnnMe O_pushfl [],
      Insn DontAnnMe O_addl
                [OP_LIT (Const [Pos (UF_NUM (show k))]),
                 OP_D   (Const [Pos (UF_NAME name)])],
      Insn DontAnnMe O_adcl
                [OP_LIT (Const [Pos (UF_NUM "0")]),
                 OP_D   (Const [Pos (UF_NUM "4"),
                                Pos (UF_NAME name)])],
      Insn DontAnnMe O_popfl []
     ]


{-----------------------------------------------------------}
{--- Stage 8.  Peephole opt to remove some stupidities.  ---}
{-----------------------------------------------------------}

{- The idea is to clean up (eg)
        pushfl
        addl $3,cacheprof_icount
        adcl $0,4+cacheprof_icount
        popfl
        pushfl
        addl $1,cacheprof_level1_writes
        adcl $0,4+cacheprof_level1_writes
        popfl
   into 
        pushfl
        addl $3,cacheprof_icount
        adcl $0,4+cacheprof_icount
        addl $1,cacheprof_level1_writes
        adcl $0,4+cacheprof_level1_writes
        popfl
-}

-- section-main
peephole :: [Line] -> [Line]

peephole ( line1@(Real ln1 cc1 insn1) :
           line2@(Real ln2 cc2 insn2) :
           line3@(Real ln3 cc3 (Insn anns3 O_popfl [])) :
           line4@(Real ln4 cc4 (Insn anns4 O_pushfl [])) :
           line5@(Real ln5 cc5 insn5) :
           line6@(Real ln6 cc6 insn6) :
           the_rest )
   | incs_a_counter insn1 insn2 
     && incs_a_counter insn5 insn6
   = peephole (line1 : line2 : line5 : line6 : the_rest)

peephole ( line: the_rest)
   = line : peephole the_rest
peephole []
   = []


-- Say after me: We love pattern matching
incs_a_counter (Insn anns1 O_addl
                     [OP_LIT (Const [Pos (UF_NUM n)]),
                      OP_D   (Const [Pos (UF_NAME name1)])])
               (Insn anns2 O_adcl
                     [OP_LIT (Const [Pos (UF_NUM zero)]),
                      OP_D   (Const [Pos (UF_NUM four),
                                     Pos (UF_NAME name2)])])
   = take 10 name1 == "cacheprof_"
     && take 10 name2 == "cacheprof_"
     && zero == "0" && four == "4"

incs_a_counter insn1 insn2
   = False


{-----------------------------------------------------------}
{--- Stage 9.  Final cleanup -- zap debugging info.      ---}
{-----------------------------------------------------------}

-- section-main
final_cleanup :: [Line] -> String
final_cleanup
   = unlines . map ppu . filter (not.isStabLine)
     where
        isStabLine (Pseudo ln s) 
           = take 5 (dropWhile isSpace s) == ".stab"
        isStabLine other
           = False


{-----------------------------------------------------------}
{--- Main!                                               ---}
{-----------------------------------------------------------}

main = seq stderr (       -- avoid bug in ghc-4.04
       do args0 <- getArgs

          let (lib_path, args)
                 = if null args0
                   then internal
                           "lib_path not supplied by `cacheprof'"
                   else (head args0, tail args0)

          let prof_level
                 = if "--level0" `elem` args then 0
                   else if "--level1" `elem` args then 1
                   else if "--level2" `elem` args then 2
                   else internal 
                           "profiling level not supplied by `cacheprof'"

          let bad_ddump_flags
                 = filter (`notElem` ddump_flags) 
                      (filter ((== "--ddump-") . take 8) args)

          if (not (null bad_ddump_flags))
           then do hPutStr stderr (
                        "cacheann: bad debugging flag(s): " ++ 
                        unwords bad_ddump_flags ++ 
                        "\n   valid debugging flags are\n" ++
                        unlines (map ("      "++) ddump_flags)
                      )
                   exitWith (ExitFailure 1)
           else return ()

          ifVerb args (hPutStr stderr "cacheann-0.01: annotating ...\n")
          f   <- getContents
          aux <- case prof_level of
                  0 -> return ""
                  1 -> readFile (lib_path ++ "/cacheprof_hooks1_x86.s")
                  2 -> readFile (lib_path ++ "/cacheprof_hooks2_x86.s")

          out <- doFile prof_level args f
          putStr out
          putStr aux
          ifVerb args (hPutStr stderr "cacheann-0.01: done\n")
       )

ifVerb :: [String] -> IO () -> IO ()
ifVerb flags ioact 
   = if "-v" `elem` flags then ioact else return ()

doFile :: Int -> [String] -> String -> IO String
doFile prof_level args input_text
   = let preparsed      = preparse input_text
         parsed         = map forceLine (parse preparsed)
         simplified     = simplify parsed
         with_bbs_ident = identify_bbs simplified
         with_icounts   = use_bbs with_bbs_ident
         annotated      = annotate with_icounts
         with_ccs       = addCCs annotated
         with_synth_2   = synth_2 with_ccs
         with_synth_1   = synth_1 annotated
         with_synth     = case prof_level of
                             0 -> simplified
                             1 -> with_synth_1
                             2 -> with_synth_2
         peepholed      = peephole with_synth
         final          = final_cleanup peepholed

         debugging_io
            = do ifopt [0,1,2] ddump_preparsed  preparsed
                 ifopt [0,1,2] ddump_parsed     parsed
                 ifopt [0,1,2] ddump_simplified simplified
                 ifopt   [1,2] ddump_ident_bbs  with_bbs_ident
                 ifopt   [1,2] ddump_use_bbs    with_icounts
                 ifopt   [1,2] ddump_annotated  annotated
                 ifopt     [2] ddump_ccs        with_ccs
                 ifopt [0,1,2] ddump_synth      with_synth
                 ifopt [0,1,2] ddump_peephole   peepholed

         ifopt valid_levels flag stuff
            | prof_level `elem` valid_levels 
              && flag `elem` args
            = hPutStr stderr (
                 "\n\n-------- DEBUGGING OUTPUT FOR " 
                 ++ flag ++ ":\n\n"
                 ++ unlines (map ppd stuff)
                 ++ "\n\n" )
            | otherwise
            = return ()

         forceLine :: Line -> Line
         forceLine line | line == line = line
                        | otherwise    = internal "forceLine"
     in
         debugging_io >> return final


ddump_preparsed   = "--ddump-preparsed"
ddump_parsed      = "--ddump-parsed"
ddump_simplified  = "--ddump-simplified"
ddump_ident_bbs   = "--ddump-ident-bbs"
ddump_use_bbs     = "--ddump-use-bbs"
ddump_annotated   = "--ddump-annotated"
ddump_ccs         = "--ddump-ccs"
ddump_synth       = "--ddump-synth"
ddump_peephole    = "--ddump-peephole"

ddump_flags
   = [ddump_preparsed, ddump_parsed, ddump_simplified,
      ddump_ident_bbs, ddump_use_bbs, ddump_annotated,
      ddump_ccs, ddump_synth, ddump_peephole]

{------------------------------------------------------------------------}
{--- end                                                  CacheAnn.hs ---}
{------------------------------------------------------------------------}