cacheann.hs

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

annsOf opcode operands
   = let opInfo
            = getOperandInfo opcode
         no_applicable_info
            = incomplete ("operand info (" 
                     ++ show opInfo
                     ++ ") doesn't match operand(s): "
                     ++ ppd (Insn mkNoAnns opcode operands))

     in case opInfo of

           OI effects
              -> case annsFromEffects effects operands of
                    Just anns -> anns
                    Nothing   -> no_applicable_info

           OI_Jumpy
              -> case operands of 
                    [op1] -> case op1 of 
                                { OP_STAR o -> [AnnR 4 o]; _ -> [] }
                    other -> no_applicable_info

           OI_NoEffect
              -> []
   
           OI_Error
              -> internal ( "unsimplified opcode: "
                            ++ ppd (Insn mkNoAnns opcode operands))
   
           OI_Special
              |  opcode == O_pushl
              -> case operands of 
                    [op1] -> [AnnR 4 op1, AnnW 4 the_sp_plus_4]
                    other -> no_applicable_info
   
              |  opcode == O_call
              -> case operands of 
                    [op1] -> case op1 of
                       OP_STAR o -> [AnnR 4 o, AnnW 4 the_sp_plus_4]
                       direct    -> [AnnW 4 the_sp_plus_4]
                    other -> no_applicable_info

              |  opcode == O_popl
              -> case operands of 
                    [op1] -> [AnnR 4 the_sp_plus_8, AnnW 4 op1]
   
              |  opcode == O_ret
              -> [AnnR 4 the_sp_plus_8]
   
              |  opcode == O_scasb
              -> [AnnR 1 the_edi]
              |  opcode == O_cmpsb
              -> [AnnR 1 the_edi, AnnR 1 the_esi]
              |  opcode == O_movsl
              -> [AnnR 4 the_esi, AnnW 4 the_edi]
              |  opcode == O_movsw
              -> [AnnR 2 the_esi, AnnW 2 the_edi]
              |  opcode == O_movsb
              -> [AnnR 1 the_esi, AnnW 1 the_edi]
              |  opcode == O_stosl
              -> [AnnW 4 the_edi]  -- a guess
              |  opcode == O_stosw
              -> [AnnW 2 the_edi]  -- a guess
              |  opcode == O_stosb
              -> [AnnW 1 the_edi]  -- a guess
           other
              -> incomplete ("\nunclassifiable opcode: " 
                             ++ ppd (Insn mkNoAnns opcode operands) )
     

annsFromEffects :: [OperandEffect] -> [Operand] -> Maybe [Annot]
annsFromEffects effects operands
   | null effects
   = Nothing
   | otherwise
   = let mismatch = annsFromEffects (tail effects) operands
     in
     case head effects of

        OE_RR s1 s2
           -> case operands of 
                 [op1, op2] -> Just [AnnR s1 op1, AnnR s2 op2]
                 other      -> mismatch

        OE_RM s1 s2
           -> case operands of 
                 [op1, op2] -> Just [AnnR s1 op1, AnnM s2 op2]
                 other      -> mismatch

        OE_RW s1 s2
           -> case operands of 
                 [op1, op2] -> Just [AnnR s1 op1, AnnW s2 op2]
                 other      -> mismatch
   
        OE_R s1
           -> case operands of 
                 [op1] -> Just [AnnR s1 op1]
                 other -> mismatch
   
        OE_M s1
           -> case operands of 
                 [op1] -> Just [AnnM s1 op1]
                 other -> mismatch
   
        OE_W s1
           -> case operands of 
                 [op1] -> Just [AnnW s1 op1]
                 other -> mismatch
      
        OE_nW s2
           -> case operands of 
                 [op1,op2] -> Just [AnnW s2 op2]
                 other     -> mismatch
   
        OE_RRM s1 s2 s3
           -> case operands of 
                 [op1,op2,op3] -> Just [AnnR s1 op1, AnnR s2 op2,
                                                     AnnM s3 op3]
                 other         -> mismatch


getOperandInfo :: Opcode -> OperandInfo
getOperandInfo opcR
   = case [oi | (opc, oi) <- x86info, opc == opcR] of
        [oi] -> oi
        _    -> incomplete ("getOperandInfo: no info for: " 
                            ++ show opcR ++ "\n")


{-----------------------------------------------------------}
{--- Stage 7a for level 2 profiling.  Look at the        ---}
{--- debugging info, so as to guess file and function    ---}
{--- names, and line numbers.  Stick this info onto      ---}
{--- every instruction for which we want to bill a       ---}
{--- memory transaction.                                 ---}
{-----------------------------------------------------------}

-- section-main
addCCs :: [Line] -> [Line]
addCCs 
   = addCCs_wrk (Guessed "_unknown_file_")
                0 
                (Guessed "_unknown_function_")

data PossiblyString
   = Stated  String
   | Guessed String

isGuessed ps = case ps of { Guessed _ -> True;  _ -> False }
getTheString (Stated s)  = s
getTheString (Guessed s) = s

-- file name, line number, function name
addCCs_wrk :: PossiblyString -> Int -> PossiblyString
              -> [Line] -> [Line]
addCCs_wrk inm lno fnm [] 
   = []
addCCs_wrk inm lno fnm (l:ls)
   = case l of
        Real _ _ insn
           |  hasRealAnns insn
           -> setCC l (CC (getTheString inm) lno (getTheString fnm))
              : addCCs_wrk inm lno fnm ls
           |  otherwise
           -> l : addCCs_wrk inm lno fnm ls
        Pseudo ln s
           -> case updCC s of
                 (inm2, lno2, fnm2)
                    -> l : addCCs_wrk inm2 lno2 fnm2 ls
        Label ln s
           -> case updL s of
                 (inm2, lno2, fnm2)
                    -> l : addCCs_wrk inm2 lno2 fnm2 ls
     where
        updCC s 
            = upd2 (words (dropWhile isSpace s))

        upd2 (".stabn" : args : _)
            = case splitArgs args of
                 ("68":_:lns:_) -> (inm, read lns, fnm)
                 _              -> (inm, lno, fnm)

        upd2 (".stabs" : args : _)
            = case splitArgs args of
                 (filenm:"100":_) | last filenm /= '/'
                                  -> (Stated (deQuote filenm), lno, fnm)
                 (filenm:"132":_) -> (Stated (deQuote filenm), lno, fnm)
                 (fnnm:"36":_)    |  (not.null.deQuote) fnnm
                                  -> (inm, lno, 
                                      Stated (deQuote 
                                                (takeWhile (/=':') fnnm)))
                 _                -> (inm, lno, fnm)
 
        upd2 [".file", filenm]
           | isGuessed inm && isQuoted filenm
           = (Guessed (deQuote filenm), lno, fnm)

        upd2 _
            = (inm, lno, fnm)

        -- Try to guess function names from labels
        -- if no debugging info is available.
        -- If debugging info is available, don't override it.
        updL label_text
            | isGuessed fnm && take 2 cleaned /= ".L"
            = (inm, lno, Guessed (init cleaned))
            | otherwise
            = (inm, lno, fnm)
              where 
                 cleaned = dropWhile isSpace label_text

        splitArgs = breakOnComma . zapCIQ

        zapCIQ s = out s   -- zap commas inside quotes
        out []                  = []
        out (c:cs) | c == '"'   = c   : inn cs
                   | otherwise  = c   : out cs

        inn []                  = []
        inn (c:cs) | c == '"'   = c   : out cs
                   | c == ','   = '_' : inn cs
                   | otherwise  = c   : inn cs

        breakOnComma :: String -> [String]
        breakOnComma [] = []
        breakOnComma s
           = case span (/= ',') s of
                (pre,post) -> pre : breakOnComma (drop 1 post)

        isQuoted s
           = length s >= 2 && head s == '"' && last s == '"'
        deQuote s 
           = filter (/= '"') s    -- " fool Haskell-mode highlighting


{-----------------------------------------------------------}
{--- Stage 7b for level 2 profiling.  Examine the CC     ---}
{--- descriptors that stage 7a created.  Each one will   ---}
{--- require some storage in the final assembly output.  ---}
{--- Also, run over the annotated instructions, and      ---}
{--- insert calls to the cache simulator.                ---}
{-----------------------------------------------------------}

{-- A complex stage.

    1.  Round up the CCs that Stage 7a attached.

    2.  Condense them into a convenient form
        holding the names of source files, source functions 
        and sourcepoints mentioned in this file.
        (this is makeCCdescriptors)

    3.  Using (2), generate a data area in which holds
        the file & function names, and the array of counters,
        one per source point.
        (this is useCCdescriptors)

    4.  Independently of 1, 2 and 3, travel over the
        output of section 7a, and insert calls to the
        cache simulator around every insn marked as doing
        a memory access which we want to know about.
        (mapAccumL synthLine)
---}


-- section-main
synth_2 :: [Line] -> [Line]
synth_2 ccd_assy
   = let -- get the ccs (part 1)
         ccs
            = map getCC ccd_assy
         -- make a handy package (part 2)
         cc_descriptors
            = makeCCdescriptors ccs
         -- generate the data areas (part 3)
         data_areas
            = useCCdescriptors cc_descriptors
         -- insert calls to cache simulator (part 4)
         num_ccs_avail
            = case cc_descriptors of
                 (dbg, file_names, fn_names, src_points)
                    -> length src_points
         (num_ccs_used, synthd_assy_grps)
            = mapAccumL synthLine 0 ccd_assy
         synthd_assy
            = if   num_ccs_used == num_ccs_avail -- paranoid :-)
              then concat synthd_assy_grps
              else internal "doFile: cc supply/usage mismatch\n"
     in
         synthd_assy ++ data_areas


{-------------------------------------------}
{--- part 2.                             ---}
{--- Roll CC info into a handy package.  ---}
{--- Is arch independant.                ---}
{-------------------------------------------}

makeCCdescriptors :: [CC] -> ([String],[String],[String],[(Int,Int,Int)])
makeCCdescriptors allCcs
   = let -- interesting ccs
         ccs = filter (not.isNoCC) allCcs

         -- the filenames
         filenames = nub (map ccGetFileNm ccs)
         
         -- make a map from each function to its
         -- canonical name, by adding the name of the
         -- function in which it first appears
         canonical_fn_map
            = canonicalise (
                 zip (map ccGetFuncNm ccs) (map ccGetFileNm ccs))
         (canonical_fn_map_fsts, canonical_fn_map_snds)
            = unzip canonical_fn_map

         canonicalise [] = []
         canonicalise ((fn,file):rest)
            = (fn,fn++"("++file++")")
              : canonicalise (filter ((/= fn).fst) rest)

         toSrcPoint :: CC -> (Int,Int,Int)
         toSrcPoint cc
            = (indexOf filenames (ccGetFileNm cc),
               ccGetLineNo cc,
               indexOf canonical_fn_map_fsts (ccGetFuncNm cc))

         srcPoints = map toSrcPoint ccs

         debugging_text
            = ["file names:"]
              ++ map indent filenames
              ++ ["canonicalised function names:"]
              ++ map indent canonical_fn_map_snds
              ++ ["raw source points:"]
              ++ map indent (map show ccs)
              ++ ["cooked source points:"]
              ++ map indent (map show srcPoints)

         indent s = "   " ++ s
         indexOf xs y
            = f 0 xs 
              where
                 f n [] = internal ("indexOf: " ++ show y ++ "\n")
                 f n (z:zs) = if y == z then n else f (n+1) zs
     in
         (debugging_text, 
          filenames,
          canonical_fn_map_snds,
          srcPoints)



{-------------------------------------------}
{--- part 3.                             ---}
{--- Generate data area from the handy   ---}
{--- package.  Is arch dependant.        ---}
{-------------------------------------------}

{- Generate assembly code to define a data area like this:

      <msb_first_word> #filenames
      <msb_first_word> #funcnames
      <msb_first_word> #sourcepoints
      filenames, 0 terminated, end-to-end
      funcnames, 0 terminated, end-to-end
      sourcepoints

   The comment text can be included too.

   Each sourcepoint is a 28-byte area with
      the following format:
         4 bytes    file number
         4 bytes    line number
         4 bytes    function number
         8 bytes    number of references, initially zero
         8 bytes    number of misses, initially zero
   The fields are regarded as integers stored in the
   native endianness, ie on x86 the byte order is
   3 2 1 0 for the first three and 7 6 5 4 3 2 1 0
   for the last two.
-}