cacheann.hs

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

{------------------------------------------------------------------------}
{--- An assembly code annotator for gcc >= 2.7.X on x86-linux-2.X     ---}
{---                                                      CacheAnn.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 Char
import List
import IO
import System
import Arch_x86
import Generics


{-----------------------------------------------------------}
{--- Stage 1.  Break input string into pre-parsed lines  ---}
{-----------------------------------------------------------}

-- This stage is separated from instruction parsing
-- proper mostly for conceptual cleanliness.

-- Lines can either be:
--    a label definition, on its own (Label)
--    an instruction (Real)
--    anything else (Pseudo)
-- If instruction counting is to work properly,
-- labels should not be concealed inside Pseudos. 

data PreLine
   = PrePseudo Int String
   | PreLabel  Int String
   | PreReal   Int String
     deriving Show

instance PP PreLine where
   pp m (PrePseudo ln s)  = "preP: " ++ s
   pp m (PreLabel  ln s)  = "preL: " ++ s
   pp m (PreReal   ln s)  = "preR: " ++ s

-- section-main
preparse :: String -> [PreLine]
preparse  
   = concatMap preparseLine . zip [1..] . lines


preparseLine :: (Int, String) -> [PreLine]
preparseLine (line_number,s)
   | null cleaned 
   = []
   | looks_like_label cleaned
   = case span isLabelIsh cleaned of
        (label_name, rest) 
           -> (PreLabel line_number (label_name ++ [head rest]))
              : preparseLine (line_number, tail rest)
   | head cleaned `elem` ".#"
   = [PrePseudo line_number s]
   | otherwise
   = case span (/= ';') cleaned of
        (presemi, postsemi)
           -> (PreReal line_number presemi)
              : preparseLine (line_number, drop 1 postsemi)

     where
        cleaned    = dropWhile isSpace s
        untabbed x = not (null x) && head x /= '\t'

        looks_like_label :: String -> Bool
        looks_like_label x 
           = case span isLabelIsh x of
                (label_name, rest) 
                   -> not (null label_name) 
                      && take 1 rest == ":"
                      && (null (tail rest) 
                          || isSpace (head (tail rest)))


{-----------------------------------------------------------}
{--- Stage 2.  Parse instructions.                       ---}
{-----------------------------------------------------------}

-- Turn the list of PreLines into Lines by parsing
-- the instructions.

data PPM 
   = PPM_Debug | PPM_User
     deriving Eq

class PP a where
   pp  :: PPM -> a -> String
   ppu :: a -> String
   ppd :: a -> String
   ppl :: PPM -> [a] -> String

   ppu = pp PPM_User
   ppd = pp PPM_Debug
   ppl m = concat . intersperse "," . map (pp m)


data Line 
   = Pseudo Int String
   | Label  Int String
   | Real   Int CC Insn
     deriving (Show, Eq)

instance PP Line where
   pp PPM_User  (Pseudo ln s)     = s
   pp PPM_Debug (Pseudo ln s)     = "P: " ++ s
   pp PPM_User  (Label ln s)      = s
   pp PPM_Debug (Label ln s)      = "L: " ++ s

   pp PPM_User  (Real ln cc insn) 
      = "\t" ++ pp PPM_User insn
   pp PPM_Debug (Real ln cc insn) 
      = "R:        " ++ pp PPM_Debug insn ++
       if   isNoCC cc 
       then ""
       else "\n             CC = " ++ pp PPM_Debug cc

getLineNo (Pseudo ln s)    = ln
getLineNo (Label  ln s)    = ln
getLineNo (Real   ln cc i) = ln

insnOfLine (Real ln cc i) = i
insnOfLine other          = internal "insnOfLine"

isReal (Real ln cc i) = True
isReal other          = False

isPseudo (Pseudo ln s) = True
isPseudo other         = False

data CC
   = NoCC
   | CC String Int String  -- file name, line no, fn name
     deriving (Show, Eq)

instance PP CC where
   pp ppm NoCC = "NoCC"
   pp ppm (CC filename lineno fnname)
      = filename ++ ":" ++ show lineno ++ " " ++ fnname

setCC (Real ln oldcc i) cc = Real ln cc i
setCC other             cc = internal "setCC"

getCC (Real ln cc i) = cc
getCC other          = NoCC

isNoCC NoCC       = True
isNoCC (CC _ _ _) = False

ccGetFileNm (CC filenm ln funcnm) = filenm
ccGetLineNo (CC filenm ln funcnm) = ln
ccGetFuncNm (CC filenm ln funcnm) = funcnm



-- section-main
parse :: [PreLine] -> [Line]
parse 
   = map f
     where 
        f (PrePseudo ln s) = Pseudo ln s
        f (PreLabel  ln s) = Label  ln s
        f (PreReal   ln s)
           = case pInsn (olex s) of
                POk i [] -> Real ln NoCC i
                _        -> bomb ln s
   
        bomb ln s
           = inputerr ("(stdin):" ++ show ln
                       ++ ": syntax error on `" ++ s ++ "'\n" )
 

{-------------------------------------------}
{--- an lexer for x86,                   ---}
{--- using the AT&T syntax               ---}
{-------------------------------------------}

olex :: String -> [Lex]

olex [] = []
olex (c:cs)
   | isSpace c = olex cs
   | c == '('  = LLParen : olex cs
   | c == ')'  = LRParen : olex cs
   | c == ','  = LComma  : olex cs
   | c == '+'  = LPlus   : olex cs
   | c == '-'  = LMinus  : olex cs
   | c == '*'  = LStar   : olex cs
   | c == '$'  = LDollar : olex cs
   | c == '#'  = []   -- comment; arch specific

   | c == '%'
   = case span isAlpha cs of 
        (rname, rest)
           | rname == "st" && not (null rest) 
             && head rest == '('
           -> case span (`elem` "(01234567)") rest of
                 (frname,rest2) -> (LReg (c:rname++frname)) : olex rest2
           | (c:rname) `elem` reg_names
           -> (LReg (c:rname)) : olex rest
           | otherwise
           -> barf (c:cs)
   | isDigit c
   = case span isDigitish cs of 
        (num, rest) -> (LNum (c:num)) : olex rest
   | isAlpha c || c == '_'
   = case span isNameIsh cs of
        (nmcs, rest) -> (LName (c:nmcs)) : olex rest
   | c == '.'
   = case span isLabelIsh cs of
        (lbcs, rest) -> (LLabel (c:lbcs)) : olex rest

   | otherwise
   = barf (c:cs)


isDigitish c = isDigit c || c `elem` "xabcdefABCDEF"
isNameIsh c  = isAlpha c || isDigit c || c == '_' || c == '.'
isLabelIsh c = isAlpha c || isDigit c || c == '.' || c == '_'
isRegChar c  = isAlpha c || c `elem` "(0)"

barf s = inputerr ( "lexical error on: `" ++ s ++ "'")


{-------------------------------------------}
{--- an instruction parser for x86,      ---}
{--- using the AT&T syntax               ---}
{-------------------------------------------}


{- operand ::= reg
             | $ const
             | const
             | const amode
             | amode

   amode ::= (reg)          -- B
           | (reg,reg)      -- B I
           | (,reg,num)     -- I S
           | (reg,reg,num)  -- B I S 

   const  ::= (OPTIONAL '-') const_factor 
                             (ZEROORMORE signed_const_factor)

   signed_const_factor ::=   + const_factor
                         |   - const_factor

   const_factor ::= const_atom
                  | const_atom '*' const_factor
                  | '(' const_factor ')'

   const_atom ::= number
                | label
                | name

   reg ::=  %eax | %ebx | %ecx | %edx | %esi | %edi | %ebp | %esp ...
-}

data Annot
   = AnnR Int Operand
   | AnnM Int Operand
   | AnnW Int Operand
   | AnnC String        -- just a comment
     deriving (Show, Eq)

getAnnOp (AnnR w o) = o
getAnnOp (AnnM w o) = o
getAnnOp (AnnW w o) = o

isAnnC (AnnC _) = True
isAnnC _        = False

mkAnnC comment = SomeAnns [AnnC comment]
mkNoAnns = SomeAnns []

hasRealAnns (Insn ann _ _)
   = (not . null . filter (not.isAnnC) . getAnns) ann

data Anns
   = DontAnnMe
   | SomeAnns [Annot]
     deriving (Show, Eq)

getAnns DontAnnMe       = []
getAnns (SomeAnns anns) = anns

isDontAnnMe DontAnnMe = True
isDontAnnMe _         = False

data Insn 
   = Insn Anns Opcode [Operand]
     deriving (Show, Eq)

annsOfInsn   (Insn anns opcode operand) = anns
opcodeOfInsn (Insn anns opcode operand) = opcode

data Operand
   = OP_REG   Reg
   | OP_LIT   Const
   | OP_D     Const
   | OP_DA    Const AMode
   | OP_A     AMode
   | OP_STAR  Operand
     deriving (Show, Eq)

data AMode
   = AM_B   Reg  
   | AM_BI  Reg Reg
   | AM_IS  Reg String
   | AM_BIS Reg Reg String
     deriving (Show, Eq)



newtype Const 
   = Const [SignedFactor]
     deriving (Show, Eq)

data SignedFactor  = Neg UnsignedFactor | Pos UnsignedFactor
     deriving (Show, Eq)

data UnsignedFactor
   = UF_NUM String  
   | UF_NAME String 
   | UF_LABEL String
   | UF_TIMES UnsignedFactor UnsignedFactor
     deriving (Show, Eq)

data Reg 
   = EAX | EBX | ECX | EDX | EDI | ESI | EBP | ESP
   | AX | BX | CX | DX | SI | DI | BP
   | AL | BL | CL | DL
   | AH | BH | CH | DH
   | ST_0 | ST_1 | ST_2 | ST_3 
   | ST_4 | ST_5 | ST_6 | ST_7
     deriving (Show, Eq)

pOpcode :: Parser Opcode
pOpcode
   = pAlts (map (\o -> pName (drop 2 (show (fst o))) (fst o)) x86info)

pInsn :: Parser Insn
pInsn 
   = p2 (Insn (SomeAnns [])) pOpcode (pStarComma pOperand)

pOperand :: Parser Operand
pOperand
   = pAlts [
        pApply OP_REG pReg,
        p2 (\_ c -> OP_LIT c) pLDollar pConst,
        p2 (\c a -> OP_DA c a) pConst pAMode,
        pApply (\c -> OP_D c) pConst,
        pApply (\a -> OP_A a) pAMode,
        p2 (\_ operand -> OP_STAR operand) pLStar pOperand