cacheann.hs

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

     ]

pAMode :: Parser AMode
pAMode
   = pInParens (
        pAlts [
           p3 AM_BIS pReg (pPreComma pReg) (pPreComma pLNum),
           p2 AM_BI  pReg (pPreComma pReg),
           p2 AM_IS  (pPreComma pReg) (pPreComma pLNum),
           pApply AM_B pReg
        ]
     )

pUnsignedA :: Parser UnsignedFactor
pUnsignedA
   = pAlts [
        pApply UF_NUM pLNum,
        pApply UF_NAME pLName,
        pApply UF_LABEL pLLabel
     ]

pUnsignedF :: Parser UnsignedFactor
pUnsignedF
   = pAlts [
        p3 (\x times y -> UF_TIMES x y) pUnsignedA pLStar pUnsignedF,
        p3 (\left x right -> x) pLLParen pUnsignedF pLRParen,
        pUnsignedA
     ]

pSignedF :: Parser SignedFactor
pSignedF
   = pAlts [
        p2 (\_ ca -> Pos ca) pLPlus  pUnsignedF,
        p2 (\_ ca -> Neg ca) pLMinus pUnsignedF
     ]

pConst :: Parser Const
pConst
   = pAlts [
        p2 (\  ca cas -> Const ((Pos ca):cas))
           pUnsignedF (pStar pSignedF),
        p3 (\_ ca cas -> Const ((Neg ca):cas)) 
           pLMinus pUnsignedF (pStar pSignedF)
     ]

pReg
   = pApply findReg pLReg
     where
        findReg r = case lookup r reg_map of
                       Nothing  -> incomplete ("findReg: `" ++ r ++ "'")
                       Just reg -> reg

test = pInsn . olex

pLLiteral = pApply unLLiteral (pSat isLLiteral)
pLNum     = pApply unLNum     (pSat isLNum)
pLReg     = pApply unLReg     (pSat isLReg)
pLName    = pApply unLName    (pSat isLName)
pLLabel   = pApply unLLabel   (pSat isLLabel)

reg_map
   = [("%eax",EAX),("%ebx",EBX),("%ecx",ECX),("%edx",EDX),
      ("%edi",EDI),("%esi",ESI),("%ebp",EBP),("%esp",ESP),

      ("%ax",AX), ("%bx",BX), ("%cx",CX), ("%dx",DX), 
      ("%si",SI), ("%di",DI), ("%bp",BP),

      ("%al",AL), ("%bl",BL), ("%cl",CL), ("%dl",DL),
      ("%ah",AH), ("%bh",BH), ("%ch",CH), ("%dh",DH),

      ("%st", ST_0), ("%st(0)", ST_0), 
      ("%st(1)", ST_1), ("%st(2)", ST_2), ("%st(3)", ST_3), 
      ("%st(4)", ST_4), ("%st(5)", ST_5), ("%st(6)", ST_6),
      ("%st(7)", ST_7)
     ]

reg_names
   = map fst reg_map




instance PP Insn where
   pp ppm insn@(Insn ann opcode operands)
      = main_part 
        ++ (if   ppm == PPM_User
                 || null (getAnns ann)
            then [] 
            else take (max 0 (36 - length main_part)) (repeat ' ')
                 ++ (if hasRealAnns insn 
                     then " # ANN " else " #     ") 
                 ++ ppl ppm (getAnns ann)
           )
        where
           main_part
              = pp ppm opcode 
                ++ (if   null operands 
                    then [] 
                    else " " ++ ppl ppm operands)

instance PP Annot where
   pp ppm (AnnR w op) = "r" ++ show w ++ ": " ++ pp ppm op
   pp ppm (AnnM w op) = "m" ++ show w ++ ": " ++ pp ppm op
   pp ppm (AnnW w op) = "w" ++ show w ++ ": " ++ pp ppm op
   pp ppm (AnnC comm) = comm
   ppl ppm = concat . intersperse "   " . map (pp ppm)

instance PP Operand where
   pp ppm (OP_REG r)  = pp ppm r
   pp ppm (OP_LIT c)  = "$" ++ pp ppm c
   pp ppm (OP_D c)    = pp ppm c
   pp ppm (OP_A a)    = pp ppm a
   pp ppm (OP_DA c a) = pp ppm c ++ pp ppm a
   pp ppm (OP_STAR o) = "*" ++ pp ppm o

instance PP AMode where
   pp ppm (AM_B r1)        = paren (pp ppm r1)
   pp ppm (AM_BI r1 r2)    = paren (pp ppm r1 ++ "," ++ pp ppm r2)
   pp ppm (AM_IS r1  n)    = paren ("," ++ pp ppm r1 ++ "," ++ n)
   pp ppm (AM_BIS r1 r2 n) 
      = paren (pp ppm r1 ++ "," ++ pp ppm r2 ++ "," ++ n)

instance PP Const where
   pp ppm (Const signed_factors)
      = dropWhile (== '+') (concatMap (pp ppm) signed_factors)

instance PP SignedFactor where
   pp ppm (Neg factor) = "-" ++ pp ppm factor
   pp ppm (Pos factor) = "+" ++ pp ppm factor

instance PP UnsignedFactor where
   pp ppm (UF_NUM n)     = n
   pp ppm (UF_NAME n)    = n
   pp ppm (UF_LABEL l)   = l
   pp ppm (UF_TIMES a b) = pp ppm a ++ "*" ++ pp ppm b

instance PP Reg where
   pp ppm ST_0 = "%st"
   pp ppm ST_1 = "%st(1)"
   pp ppm ST_2 = "%st(2)"
   pp ppm ST_3 = "%st(3)"
   pp ppm ST_4 = "%st(4)"
   pp ppm ST_5 = "%st(5)"
   pp ppm ST_6 = "%st(6)"
   pp ppm ST_7 = "%st(7)"
   pp ppm r    = "%" ++ map toLower (show r)

instance PP Opcode where
   pp ppm o = (drop 2 . show) o

paren s = "(" ++ s ++ ")"

{-----------------------------------------------------------}
{--- Stage 3.  Simplify some complex instructions into   ---}
{--- equivalent sequences of simpler ones.               ---}
{-----------------------------------------------------------}

-- we carry along a counter `lc' so as to be able to
-- manufacture labels.

-- section-main
simplify :: [Line] -> [Line]
simplify = simpl_wrk 0


simpl_wrk lc []
   = []

simpl_wrk lc ((Real ln cc (Insn (SomeAnns []) O_rep [])) :
              (Real _   _ (Insn (SomeAnns []) o_op [])) : lines)
   | o_op `elem` [O_movsl, O_movsw, O_movsb, 
                  O_stosl, O_stosw, O_stosb]
   = let (l1,l2)
            = (lc,lc+1)
         -- This lot gratuitiously cloned below
         labelName n
            = "cacheprof_x86_rep_expansion" ++ show n
         mkInsn oc ops
            = Real ln cc (Insn DontAnnMe oc ops)
         mkInsnA oc ops
            = Real ln cc (Insn (SomeAnns []) oc ops)
         mkLabelD ln
            = Pseudo ln (mk_arch_label_def (labelName ln))
         mkLabelU ln
            = OP_D (Const [Pos (UF_LABEL 
                               (mk_arch_label_use (labelName ln)))])
     in
         [mkInsn   O_pushfl  [],
          mkLabelD l1,
          mkInsn   O_testl  [OP_REG ECX, OP_REG ECX],
          mkInsn   O_jz     [mkLabelU l2],
          mkInsn   O_decl   [OP_REG ECX],
          mkInsnA  o_op     [],
          mkInsn   O_jmp    [mkLabelU l1],
          mkLabelD l2,
          mkInsn   O_popfl   []
         ]
         ++ simpl_wrk (lc+2) lines

simpl_wrk lc ((Real ln cc (Insn (SomeAnns []) o_reppy [])) :
              (Real _   _ (Insn (SomeAnns []) o_op [])) : lines)
   | o_reppy `elem` [O_repz, O_repnz]
     && o_op `elem` [O_cmpsb, O_scasb] -- also w and l sizes
   = let o_exit
            | o_reppy `elem` [O_repnz]
            = O_jz
            | o_reppy `elem` [O_repz]
            = O_jnz
            | otherwise
            = incomplete ("simpl_wrk rep: can't handle " 
                          ++ show (o_reppy, o_op) ++ "\n")
         (l1,l2,l3)
            = (lc,lc+1,lc+2)

         -- This lot gratuitiously cloned from above
         labelName n
            = "cacheprof_x86_rep_expansion" ++ show n
         mkInsn oc ops
            = Real ln cc (Insn DontAnnMe oc ops)
         mkInsnA oc ops
            = Real ln cc (Insn (SomeAnns []) oc ops)
         mkLabelD ln
            = Pseudo ln (mk_arch_label_def (labelName ln))
         mkLabelU ln
            = OP_D (Const [Pos (UF_LABEL 
                               (mk_arch_label_use (labelName ln)))])


     in
         [mkLabelD l1,
          mkInsn   O_pushfl [],
          mkInsn   O_testl  [OP_REG ECX, OP_REG ECX],
          mkInsn   O_jz     [mkLabelU l2],
          mkInsn   O_popfl  [],
          mkInsnA  o_op     [],
          mkInsn   O_pushfl [],
          mkInsn   O_decl   [OP_REG ECX],
          mkInsn   O_popfl  [],
          mkInsn   o_exit   [mkLabelU l3],
          mkInsn   O_jmp    [mkLabelU l1],
          mkLabelD l2,
          mkInsn   O_popfl  [],
          mkLabelD l3
         ]
         ++ simpl_wrk (lc+3) lines

simpl_wrk lc ((Real ln cc (Insn (SomeAnns []) O_leave [])):lines)
   = [Real ln cc (Insn mkNoAnns O_movl [OP_REG EBP, OP_REG ESP]),
      Real ln cc (Insn mkNoAnns O_popl [OP_REG EBP])]
     ++ simpl_wrk lc lines

simpl_wrk lc (line:lines)
   = line : simpl_wrk lc lines


{-----------------------------------------------------------}
{--- Stage 4.  Identify basic blocks.                    ---}
{-----------------------------------------------------------}

-- This is to make instruction counting tolerably
-- efficient.  It's safe but inefficient to put
-- each instruction into its own basic block.

newtype BB = BB [Line]

instance PP BB where
   pp ppm (BB ls)
      = "{ -- basic block\n" 
        ++ unlines (map (pp ppm) ls)
        ++ "}"

-- section-main
identify_bbs :: [Line] -> [BB]
{-
-- brain-dead, reference implementation
identify_bbs = map (\line -> BB [line])
-}

-- something a bit better
-- It could still be improved.  
-- Use --ddump-ident-bbs to get ideas.
identify_bbs 
   = merge_bbs . map (\line -> BB [line])
     where
        merge_bbs []   = []
        merge_bbs [bb] = [bb]
        merge_bbs (bb1@(BB lines1) : bb2@(BB [line]) : bbs)

           | isPseudo line
           = let bigger_bb = BB (lines1++[line])
             in  merge_bbs (bigger_bb : bbs)

           | isOriginalInsn line 
             && any isReal lines1
             && isOriginalInsn last_Real_lines1
             && opcodeOfInsn (insnOfLine last_Real_lines1)
                   `elem` nonJumpyOpcodes

           = let bigger_bb = BB (lines1++[line])
             in  merge_bbs (bigger_bb : bbs)

           | otherwise
           = bb1 : merge_bbs (bb2:bbs)

             where
                last_Real_lines1 = last (filter isReal lines1)

{-----------------------------------------------------------}
{--- Stage 5.  Add insn count annotations to BBs.        ---}
{-----------------------------------------------------------}

-- section-main
use_bbs :: [BB] -> [Line]
use_bbs = concatMap use_bb

use_bb :: BB -> [Line]
use_bb (BB [])
   = internal "use_bb: empty bb"
use_bb (BB lines)
   = let n_original_insns
            = length (filter isOriginalInsn lines)
         lineNo
            = getLineNo (head lines)
         synthd_insns
            = map (Real lineNo NoCC)
                  (incSequence n_original_insns "cacheprof_icount")
     in
         if   n_original_insns == 0
         then lines
         else synthd_insns ++ lines

-- Instructions haven't been annotated yet.
-- So the way to detect an original insn (ie, one
-- not generated by simplification) is:
--    insns created by simplify have DontAnnMe,
--    whereas originals have SomeAnns [].

isOriginalInsn (Real ln cc insn)
   = case annsOfInsn insn of
        DontAnnMe   -> False
        SomeAnns [] -> True
        other       -> internal "isOriginalInsn"
isOriginalInsn other
   = False

{-----------------------------------------------------------}
{--- Stage 6.  Annotate instructions with memory         ---}
{--- read/modify/write info.                             ---}
{-----------------------------------------------------------}

-- section-main
annotate :: [Line] -> [Line]
annotate
   = map f
     where
        f (Real ln cc insn) = Real ln cc (annotate_insn insn)
        f label_or_pseudo   = label_or_pseudo

annotate_insn :: Insn -> Insn
annotate_insn insn@(Insn old_ann opcode operands)
   | isDontAnnMe old_ann
   = insn
   | otherwise
   = Insn (SomeAnns (filter (isMemOp.getAnnOp) 
                            (annsOf opcode operands)))
          opcode operands

isMemOp (OP_REG r)  = False
isMemOp (OP_LIT c)  = False
isMemOp (OP_D d)    = True
isMemOp (OP_DA d a) = True
isMemOp (OP_A a)    = True
isMemOp (OP_STAR o) = incomplete "isMemOp: not sure about *-form"

the_edi       = OP_A (AM_B EDI)
the_esi       = OP_A (AM_B ESI)
the_sp        = OP_A (AM_B ESP)
the_sp_plus_4 = OP_DA (Const [Pos (UF_NUM "4")]) (AM_B ESP)
the_sp_plus_8 = OP_DA (Const [Pos (UF_NUM "8")]) (AM_B ESP)

annsOf :: Opcode -> [Operand] -> [Annot]