add missing import
[nofib.git] / gc / cacheprof / Main.hs
1
2 {------------------------------------------------------------------------}
3 {--- An assembly code annotator for gcc >= 2.7.X on x86-linux-2.X ---}
4 {--- CacheAnn.hs ---}
5 {------------------------------------------------------------------------}
6
7 {-
8 This file is part of Cacheprof, a profiling tool for finding
9 sources of cache misses in programs.
10
11 Copyright (C) 1999 Julian Seward (jseward@acm.org)
12 Home page: http://www.cacheprof.org
13
14 This program is free software; you can redistribute it and/or
15 modify it under the terms of the GNU General Public License as
16 published by the Free Software Foundation; either version 2 of the
17 License, or (at your option) any later version.
18
19 This program is distributed in the hope that it will be useful, but
20 WITHOUT ANY WARRANTY; without even the implied warranty of
21 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
22 General Public License for more details.
23
24 You should have received a copy of the GNU General Public License
25 along with this program; if not, write to the Free Software
26 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
27 02111-1307, USA.
28
29 The GNU General Public License is contained in the file LICENSE.
30 -}
31
32 module Main ( main ) where
33 import Data.Char
34 import Data.List
35 import System.IO
36 import System.Environment
37 import System.Exit
38 import Arch_x86
39 import Generics
40
41
42 {-----------------------------------------------------------}
43 {--- Stage 1. Break input string into pre-parsed lines ---}
44 {-----------------------------------------------------------}
45
46 -- This stage is separated from instruction parsing
47 -- proper mostly for conceptual cleanliness.
48
49 -- Lines can either be:
50 -- a label definition, on its own (Label)
51 -- an instruction (Real)
52 -- anything else (Pseudo)
53 -- If instruction counting is to work properly,
54 -- labels should not be concealed inside Pseudos.
55
56 data PreLine
57 = PrePseudo Int String
58 | PreLabel Int String
59 | PreReal Int String
60 deriving Show
61
62 instance PP PreLine where
63 pp m (PrePseudo ln s) = "preP: " ++ s
64 pp m (PreLabel ln s) = "preL: " ++ s
65 pp m (PreReal ln s) = "preR: " ++ s
66
67 -- section-main
68 preparse :: String -> [PreLine]
69 preparse
70 = concatMap preparseLine . zip [1..] . lines
71
72
73 preparseLine :: (Int, String) -> [PreLine]
74 preparseLine (line_number,s)
75 | null cleaned
76 = []
77 | looks_like_label cleaned
78 = case span isLabelIsh cleaned of
79 (label_name, rest)
80 -> (PreLabel line_number (label_name ++ [head rest]))
81 : preparseLine (line_number, tail rest)
82 | head cleaned `elem` ".#"
83 = [PrePseudo line_number s]
84 | otherwise
85 = case span (/= ';') cleaned of
86 (presemi, postsemi)
87 -> (PreReal line_number presemi)
88 : preparseLine (line_number, drop 1 postsemi)
89
90 where
91 cleaned = dropWhile isSpace s
92 untabbed x = not (null x) && head x /= '\t'
93
94 looks_like_label :: String -> Bool
95 looks_like_label x
96 = case span isLabelIsh x of
97 (label_name, rest)
98 -> not (null label_name)
99 && take 1 rest == ":"
100 && (null (tail rest)
101 || isSpace (head (tail rest)))
102
103
104 {-----------------------------------------------------------}
105 {--- Stage 2. Parse instructions. ---}
106 {-----------------------------------------------------------}
107
108 -- Turn the list of PreLines into Lines by parsing
109 -- the instructions.
110
111 data PPM
112 = PPM_Debug | PPM_User
113 deriving Eq
114
115 class PP a where
116 pp :: PPM -> a -> String
117 ppu :: a -> String
118 ppd :: a -> String
119 ppl :: PPM -> [a] -> String
120
121 ppu = pp PPM_User
122 ppd = pp PPM_Debug
123 ppl m = concat . intersperse "," . map (pp m)
124
125
126 data Line
127 = Pseudo Int String
128 | Label Int String
129 | Real Int CC Insn
130 deriving (Show, Eq)
131
132 instance PP Line where
133 pp PPM_User (Pseudo ln s) = s
134 pp PPM_Debug (Pseudo ln s) = "P: " ++ s
135 pp PPM_User (Label ln s) = s
136 pp PPM_Debug (Label ln s) = "L: " ++ s
137
138 pp PPM_User (Real ln cc insn)
139 = "\t" ++ pp PPM_User insn
140 pp PPM_Debug (Real ln cc insn)
141 = "R: " ++ pp PPM_Debug insn ++
142 if isNoCC cc
143 then ""
144 else "\n CC = " ++ pp PPM_Debug cc
145
146 getLineNo (Pseudo ln s) = ln
147 getLineNo (Label ln s) = ln
148 getLineNo (Real ln cc i) = ln
149
150 insnOfLine (Real ln cc i) = i
151 insnOfLine other = internal "insnOfLine"
152
153 isReal (Real ln cc i) = True
154 isReal other = False
155
156 isPseudo (Pseudo ln s) = True
157 isPseudo other = False
158
159 data CC
160 = NoCC
161 | CC String Int String -- file name, line no, fn name
162 deriving (Show, Eq)
163
164 instance PP CC where
165 pp ppm NoCC = "NoCC"
166 pp ppm (CC filename lineno fnname)
167 = filename ++ ":" ++ show lineno ++ " " ++ fnname
168
169 setCC (Real ln oldcc i) cc = Real ln cc i
170 setCC other cc = internal "setCC"
171
172 getCC (Real ln cc i) = cc
173 getCC other = NoCC
174
175 isNoCC NoCC = True
176 isNoCC (CC _ _ _) = False
177
178 ccGetFileNm (CC filenm ln funcnm) = filenm
179 ccGetLineNo (CC filenm ln funcnm) = ln
180 ccGetFuncNm (CC filenm ln funcnm) = funcnm
181
182
183
184 -- section-main
185 parse :: [PreLine] -> [Line]
186 parse
187 = map f
188 where
189 f (PrePseudo ln s) = Pseudo ln s
190 f (PreLabel ln s) = Label ln s
191 f (PreReal ln s)
192 = case pInsn (olex s) of
193 POk i [] -> Real ln NoCC i
194 _ -> bomb ln s
195
196 bomb ln s
197 = inputerr ("(stdin):" ++ show ln
198 ++ ": syntax error on `" ++ s ++ "'\n" )
199
200
201 {-------------------------------------------}
202 {--- an lexer for x86, ---}
203 {--- using the AT&T syntax ---}
204 {-------------------------------------------}
205
206 olex :: String -> [Lex]
207
208 olex [] = []
209 olex (c:cs)
210 | isSpace c = olex cs
211 | c == '(' = LLParen : olex cs
212 | c == ')' = LRParen : olex cs
213 | c == ',' = LComma : olex cs
214 | c == '+' = LPlus : olex cs
215 | c == '-' = LMinus : olex cs
216 | c == '*' = LStar : olex cs
217 | c == '$' = LDollar : olex cs
218 | c == '#' = [] -- comment; arch specific
219
220 | c == '%'
221 = case span isAlpha cs of
222 (rname, rest)
223 | rname == "st" && not (null rest)
224 && head rest == '('
225 -> case span (`elem` "(01234567)") rest of
226 (frname,rest2) -> (LReg (c:rname++frname)) : olex rest2
227 | (c:rname) `elem` reg_names
228 -> (LReg (c:rname)) : olex rest
229 | otherwise
230 -> barf (c:cs)
231 | isDigit c
232 = case span isDigitish cs of
233 (num, rest) -> (LNum (c:num)) : olex rest
234 | isAlpha c || c == '_'
235 = case span isNameIsh cs of
236 (nmcs, rest) -> (LName (c:nmcs)) : olex rest
237 | c == '.'
238 = case span isLabelIsh cs of
239 (lbcs, rest) -> (LLabel (c:lbcs)) : olex rest
240
241 | otherwise
242 = barf (c:cs)
243
244
245 isDigitish c = isDigit c || c `elem` "xabcdefABCDEF"
246 isNameIsh c = isAlpha c || isDigit c || c == '_' || c == '.'
247 isLabelIsh c = isAlpha c || isDigit c || c == '.' || c == '_'
248 isRegChar c = isAlpha c || c `elem` "(0)"
249
250 barf s = inputerr ( "lexical error on: `" ++ s ++ "'")
251
252
253 {-------------------------------------------}
254 {--- an instruction parser for x86, ---}
255 {--- using the AT&T syntax ---}
256 {-------------------------------------------}
257
258
259 {- operand ::= reg
260 | $ const
261 | const
262 | const amode
263 | amode
264
265 amode ::= (reg) -- B
266 | (reg,reg) -- B I
267 | (,reg,num) -- I S
268 | (reg,reg,num) -- B I S
269
270 const ::= (OPTIONAL '-') const_factor
271 (ZEROORMORE signed_const_factor)
272
273 signed_const_factor ::= + const_factor
274 | - const_factor
275
276 const_factor ::= const_atom
277 | const_atom '*' const_factor
278 | '(' const_factor ')'
279
280 const_atom ::= number
281 | label
282 | name
283
284 reg ::= %eax | %ebx | %ecx | %edx | %esi | %edi | %ebp | %esp ...
285 -}
286
287 data Annot
288 = AnnR Int Operand
289 | AnnM Int Operand
290 | AnnW Int Operand
291 | AnnC String -- just a comment
292 deriving (Show, Eq)
293
294 getAnnOp (AnnR w o) = o
295 getAnnOp (AnnM w o) = o
296 getAnnOp (AnnW w o) = o
297
298 isAnnC (AnnC _) = True
299 isAnnC _ = False
300
301 mkAnnC comment = SomeAnns [AnnC comment]
302 mkNoAnns = SomeAnns []
303
304 hasRealAnns (Insn ann _ _)
305 = (not . null . filter (not.isAnnC) . getAnns) ann
306
307 data Anns
308 = DontAnnMe
309 | SomeAnns [Annot]
310 deriving (Show, Eq)
311
312 getAnns DontAnnMe = []
313 getAnns (SomeAnns anns) = anns
314
315 isDontAnnMe DontAnnMe = True
316 isDontAnnMe _ = False
317
318 data Insn
319 = Insn Anns Opcode [Operand]
320 deriving (Show, Eq)
321
322 annsOfInsn (Insn anns opcode operand) = anns
323 opcodeOfInsn (Insn anns opcode operand) = opcode
324
325 data Operand
326 = OP_REG Reg
327 | OP_LIT Const
328 | OP_D Const
329 | OP_DA Const AMode
330 | OP_A AMode
331 | OP_STAR Operand
332 deriving (Show, Eq)
333
334 data AMode
335 = AM_B Reg
336 | AM_BI Reg Reg
337 | AM_IS Reg String
338 | AM_BIS Reg Reg String
339 deriving (Show, Eq)
340
341
342
343 newtype Const
344 = Const [SignedFactor]
345 deriving (Show, Eq)
346
347 data SignedFactor = Neg UnsignedFactor | Pos UnsignedFactor
348 deriving (Show, Eq)
349
350 data UnsignedFactor
351 = UF_NUM String
352 | UF_NAME String
353 | UF_LABEL String
354 | UF_TIMES UnsignedFactor UnsignedFactor
355 deriving (Show, Eq)
356
357 data Reg
358 = EAX | EBX | ECX | EDX | EDI | ESI | EBP | ESP
359 | AX | BX | CX | DX | SI | DI | BP
360 | AL | BL | CL | DL
361 | AH | BH | CH | DH
362 | ST_0 | ST_1 | ST_2 | ST_3
363 | ST_4 | ST_5 | ST_6 | ST_7
364 deriving (Show, Eq)
365
366 pOpcode :: Parser Opcode
367 pOpcode
368 = pAlts (map (\o -> pName (drop 2 (show (fst o))) (fst o)) x86info)
369
370 pInsn :: Parser Insn
371 pInsn
372 = p2 (Insn (SomeAnns [])) pOpcode (pStarComma pOperand)
373
374 pOperand :: Parser Operand
375 pOperand
376 = pAlts [
377 pApply OP_REG pReg,
378 p2 (\_ c -> OP_LIT c) pLDollar pConst,
379 p2 (\c a -> OP_DA c a) pConst pAMode,
380 pApply (\c -> OP_D c) pConst,
381 pApply (\a -> OP_A a) pAMode,
382 p2 (\_ operand -> OP_STAR operand) pLStar pOperand
383 ]
384
385 pAMode :: Parser AMode
386 pAMode
387 = pInParens (
388 pAlts [
389 p3 AM_BIS pReg (pPreComma pReg) (pPreComma pLNum),
390 p2 AM_BI pReg (pPreComma pReg),
391 p2 AM_IS (pPreComma pReg) (pPreComma pLNum),
392 pApply AM_B pReg
393 ]
394 )
395
396 pUnsignedA :: Parser UnsignedFactor
397 pUnsignedA
398 = pAlts [
399 pApply UF_NUM pLNum,
400 pApply UF_NAME pLName,
401 pApply UF_LABEL pLLabel
402 ]
403
404 pUnsignedF :: Parser UnsignedFactor
405 pUnsignedF
406 = pAlts [
407 p3 (\x times y -> UF_TIMES x y) pUnsignedA pLStar pUnsignedF,
408 p3 (\left x right -> x) pLLParen pUnsignedF pLRParen,
409 pUnsignedA
410 ]
411
412 pSignedF :: Parser SignedFactor
413 pSignedF
414 = pAlts [
415 p2 (\_ ca -> Pos ca) pLPlus pUnsignedF,
416 p2 (\_ ca -> Neg ca) pLMinus pUnsignedF
417 ]
418
419 pConst :: Parser Const
420 pConst
421 = pAlts [
422 p2 (\ ca cas -> Const ((Pos ca):cas))
423 pUnsignedF (pStar pSignedF),
424 p3 (\_ ca cas -> Const ((Neg ca):cas))
425 pLMinus pUnsignedF (pStar pSignedF)
426 ]
427
428 pReg
429 = pApply findReg pLReg
430 where
431 findReg r = case lookup r reg_map of
432 Nothing -> incomplete ("findReg: `" ++ r ++ "'")
433 Just reg -> reg
434
435 test = pInsn . olex
436
437 pLLiteral = pApply unLLiteral (pSat isLLiteral)
438 pLNum = pApply unLNum (pSat isLNum)
439 pLReg = pApply unLReg (pSat isLReg)
440 pLName = pApply unLName (pSat isLName)
441 pLLabel = pApply unLLabel (pSat isLLabel)
442
443 reg_map
444 = [("%eax",EAX),("%ebx",EBX),("%ecx",ECX),("%edx",EDX),
445 ("%edi",EDI),("%esi",ESI),("%ebp",EBP),("%esp",ESP),
446
447 ("%ax",AX), ("%bx",BX), ("%cx",CX), ("%dx",DX),
448 ("%si",SI), ("%di",DI), ("%bp",BP),
449
450 ("%al",AL), ("%bl",BL), ("%cl",CL), ("%dl",DL),
451 ("%ah",AH), ("%bh",BH), ("%ch",CH), ("%dh",DH),
452
453 ("%st", ST_0), ("%st(0)", ST_0),
454 ("%st(1)", ST_1), ("%st(2)", ST_2), ("%st(3)", ST_3),
455 ("%st(4)", ST_4), ("%st(5)", ST_5), ("%st(6)", ST_6),
456 ("%st(7)", ST_7)
457 ]
458
459 reg_names
460 = map fst reg_map
461
462
463
464
465 instance PP Insn where
466 pp ppm insn@(Insn ann opcode operands)
467 = main_part
468 ++ (if ppm == PPM_User
469 || null (getAnns ann)
470 then []
471 else take (max 0 (36 - length main_part)) (repeat ' ')
472 ++ (if hasRealAnns insn
473 then " # ANN " else " # ")
474 ++ ppl ppm (getAnns ann)
475 )
476 where
477 main_part
478 = pp ppm opcode
479 ++ (if null operands
480 then []
481 else " " ++ ppl ppm operands)
482
483 instance PP Annot where
484 pp ppm (AnnR w op) = "r" ++ show w ++ ": " ++ pp ppm op
485 pp ppm (AnnM w op) = "m" ++ show w ++ ": " ++ pp ppm op
486 pp ppm (AnnW w op) = "w" ++ show w ++ ": " ++ pp ppm op
487 pp ppm (AnnC comm) = comm
488 ppl ppm = concat . intersperse " " . map (pp ppm)
489
490 instance PP Operand where
491 pp ppm (OP_REG r) = pp ppm r
492 pp ppm (OP_LIT c) = "$" ++ pp ppm c
493 pp ppm (OP_D c) = pp ppm c
494 pp ppm (OP_A a) = pp ppm a
495 pp ppm (OP_DA c a) = pp ppm c ++ pp ppm a
496 pp ppm (OP_STAR o) = "*" ++ pp ppm o
497
498 instance PP AMode where
499 pp ppm (AM_B r1) = paren (pp ppm r1)
500 pp ppm (AM_BI r1 r2) = paren (pp ppm r1 ++ "," ++ pp ppm r2)
501 pp ppm (AM_IS r1 n) = paren ("," ++ pp ppm r1 ++ "," ++ n)
502 pp ppm (AM_BIS r1 r2 n)
503 = paren (pp ppm r1 ++ "," ++ pp ppm r2 ++ "," ++ n)
504
505 instance PP Const where
506 pp ppm (Const signed_factors)
507 = dropWhile (== '+') (concatMap (pp ppm) signed_factors)
508
509 instance PP SignedFactor where
510 pp ppm (Neg factor) = "-" ++ pp ppm factor
511 pp ppm (Pos factor) = "+" ++ pp ppm factor
512
513 instance PP UnsignedFactor where
514 pp ppm (UF_NUM n) = n
515 pp ppm (UF_NAME n) = n
516 pp ppm (UF_LABEL l) = l
517 pp ppm (UF_TIMES a b) = pp ppm a ++ "*" ++ pp ppm b
518
519 instance PP Reg where
520 pp ppm ST_0 = "%st"
521 pp ppm ST_1 = "%st(1)"
522 pp ppm ST_2 = "%st(2)"
523 pp ppm ST_3 = "%st(3)"
524 pp ppm ST_4 = "%st(4)"
525 pp ppm ST_5 = "%st(5)"
526 pp ppm ST_6 = "%st(6)"
527 pp ppm ST_7 = "%st(7)"
528 pp ppm r = "%" ++ map toLower (show r)
529
530 instance PP Opcode where
531 pp ppm o = (drop 2 . show) o
532
533 paren s = "(" ++ s ++ ")"
534
535 {-----------------------------------------------------------}
536 {--- Stage 3. Simplify some complex instructions into ---}
537 {--- equivalent sequences of simpler ones. ---}
538 {-----------------------------------------------------------}
539
540 -- we carry along a counter `lc' so as to be able to
541 -- manufacture labels.
542
543 -- section-main
544 simplify :: [Line] -> [Line]
545 simplify = simpl_wrk 0
546
547
548 simpl_wrk lc []
549 = []
550
551 simpl_wrk lc ((Real ln cc (Insn (SomeAnns []) O_rep [])) :
552 (Real _ _ (Insn (SomeAnns []) o_op [])) : lines)
553 | o_op `elem` [O_movsl, O_movsw, O_movsb,
554 O_stosl, O_stosw, O_stosb]
555 = let (l1,l2)
556 = (lc,lc+1)
557 -- This lot gratuitiously cloned below
558 labelName n
559 = "cacheprof_x86_rep_expansion" ++ show n
560 mkInsn oc ops
561 = Real ln cc (Insn DontAnnMe oc ops)
562 mkInsnA oc ops
563 = Real ln cc (Insn (SomeAnns []) oc ops)
564 mkLabelD ln
565 = Pseudo ln (mk_arch_label_def (labelName ln))
566 mkLabelU ln
567 = OP_D (Const [Pos (UF_LABEL
568 (mk_arch_label_use (labelName ln)))])
569 in
570 [mkInsn O_pushfl [],
571 mkLabelD l1,
572 mkInsn O_testl [OP_REG ECX, OP_REG ECX],
573 mkInsn O_jz [mkLabelU l2],
574 mkInsn O_decl [OP_REG ECX],
575 mkInsnA o_op [],
576 mkInsn O_jmp [mkLabelU l1],
577 mkLabelD l2,
578 mkInsn O_popfl []
579 ]
580 ++ simpl_wrk (lc+2) lines
581
582 simpl_wrk lc ((Real ln cc (Insn (SomeAnns []) o_reppy [])) :
583 (Real _ _ (Insn (SomeAnns []) o_op [])) : lines)
584 | o_reppy `elem` [O_repz, O_repnz]
585 && o_op `elem` [O_cmpsb, O_scasb] -- also w and l sizes
586 = let o_exit
587 | o_reppy `elem` [O_repnz]
588 = O_jz
589 | o_reppy `elem` [O_repz]
590 = O_jnz
591 | otherwise
592 = incomplete ("simpl_wrk rep: can't handle "
593 ++ show (o_reppy, o_op) ++ "\n")
594 (l1,l2,l3)
595 = (lc,lc+1,lc+2)
596
597 -- This lot gratuitiously cloned from above
598 labelName n
599 = "cacheprof_x86_rep_expansion" ++ show n
600 mkInsn oc ops
601 = Real ln cc (Insn DontAnnMe oc ops)
602 mkInsnA oc ops
603 = Real ln cc (Insn (SomeAnns []) oc ops)
604 mkLabelD ln
605 = Pseudo ln (mk_arch_label_def (labelName ln))
606 mkLabelU ln
607 = OP_D (Const [Pos (UF_LABEL
608 (mk_arch_label_use (labelName ln)))])
609
610
611 in
612 [mkLabelD l1,
613 mkInsn O_pushfl [],
614 mkInsn O_testl [OP_REG ECX, OP_REG ECX],
615 mkInsn O_jz [mkLabelU l2],
616 mkInsn O_popfl [],
617 mkInsnA o_op [],
618 mkInsn O_pushfl [],
619 mkInsn O_decl [OP_REG ECX],
620 mkInsn O_popfl [],
621 mkInsn o_exit [mkLabelU l3],
622 mkInsn O_jmp [mkLabelU l1],
623 mkLabelD l2,
624 mkInsn O_popfl [],
625 mkLabelD l3
626 ]
627 ++ simpl_wrk (lc+3) lines
628
629 simpl_wrk lc ((Real ln cc (Insn (SomeAnns []) O_leave [])):lines)
630 = [Real ln cc (Insn mkNoAnns O_movl [OP_REG EBP, OP_REG ESP]),
631 Real ln cc (Insn mkNoAnns O_popl [OP_REG EBP])]
632 ++ simpl_wrk lc lines
633
634 simpl_wrk lc (line:lines)
635 = line : simpl_wrk lc lines
636
637
638 {-----------------------------------------------------------}
639 {--- Stage 4. Identify basic blocks. ---}
640 {-----------------------------------------------------------}
641
642 -- This is to make instruction counting tolerably
643 -- efficient. It's safe but inefficient to put
644 -- each instruction into its own basic block.
645
646 newtype BB = BB [Line]
647
648 instance PP BB where
649 pp ppm (BB ls)
650 = "{ -- basic block\n"
651 ++ unlines (map (pp ppm) ls)
652 ++ "}"
653
654 -- section-main
655 identify_bbs :: [Line] -> [BB]
656 {-
657 -- brain-dead, reference implementation
658 identify_bbs = map (\line -> BB [line])
659 -}
660
661 -- something a bit better
662 -- It could still be improved.
663 -- Use --ddump-ident-bbs to get ideas.
664 identify_bbs
665 = merge_bbs . map (\line -> BB [line])
666 where
667 merge_bbs [] = []
668 merge_bbs [bb] = [bb]
669 merge_bbs (bb1@(BB lines1) : bb2@(BB [line]) : bbs)
670
671 | isPseudo line
672 = let bigger_bb = BB (lines1++[line])
673 in merge_bbs (bigger_bb : bbs)
674
675 | isOriginalInsn line
676 && any isReal lines1
677 && isOriginalInsn last_Real_lines1
678 && opcodeOfInsn (insnOfLine last_Real_lines1)
679 `elem` nonJumpyOpcodes
680
681 = let bigger_bb = BB (lines1++[line])
682 in merge_bbs (bigger_bb : bbs)
683
684 | otherwise
685 = bb1 : merge_bbs (bb2:bbs)
686
687 where
688 last_Real_lines1 = last (filter isReal lines1)
689
690 {-----------------------------------------------------------}
691 {--- Stage 5. Add insn count annotations to BBs. ---}
692 {-----------------------------------------------------------}
693
694 -- section-main
695 use_bbs :: [BB] -> [Line]
696 use_bbs = concatMap use_bb
697
698 use_bb :: BB -> [Line]
699 use_bb (BB [])
700 = internal "use_bb: empty bb"
701 use_bb (BB lines)
702 = let n_original_insns
703 = length (filter isOriginalInsn lines)
704 lineNo
705 = getLineNo (head lines)
706 synthd_insns
707 = map (Real lineNo NoCC)
708 (incSequence n_original_insns "cacheprof_icount")
709 in
710 if n_original_insns == 0
711 then lines
712 else synthd_insns ++ lines
713
714 -- Instructions haven't been annotated yet.
715 -- So the way to detect an original insn (ie, one
716 -- not generated by simplification) is:
717 -- insns created by simplify have DontAnnMe,
718 -- whereas originals have SomeAnns [].
719
720 isOriginalInsn (Real ln cc insn)
721 = case annsOfInsn insn of
722 DontAnnMe -> False
723 SomeAnns [] -> True
724 other -> internal "isOriginalInsn"
725 isOriginalInsn other
726 = False
727
728 {-----------------------------------------------------------}
729 {--- Stage 6. Annotate instructions with memory ---}
730 {--- read/modify/write info. ---}
731 {-----------------------------------------------------------}
732
733 -- section-main
734 annotate :: [Line] -> [Line]
735 annotate
736 = map f
737 where
738 f (Real ln cc insn) = Real ln cc (annotate_insn insn)
739 f label_or_pseudo = label_or_pseudo
740
741 annotate_insn :: Insn -> Insn
742 annotate_insn insn@(Insn old_ann opcode operands)
743 | isDontAnnMe old_ann
744 = insn
745 | otherwise
746 = Insn (SomeAnns (filter (isMemOp.getAnnOp)
747 (annsOf opcode operands)))
748 opcode operands
749
750 isMemOp (OP_REG r) = False
751 isMemOp (OP_LIT c) = False
752 isMemOp (OP_D d) = True
753 isMemOp (OP_DA d a) = True
754 isMemOp (OP_A a) = True
755 isMemOp (OP_STAR o) = incomplete "isMemOp: not sure about *-form"
756
757 the_edi = OP_A (AM_B EDI)
758 the_esi = OP_A (AM_B ESI)
759 the_sp = OP_A (AM_B ESP)
760 the_sp_plus_4 = OP_DA (Const [Pos (UF_NUM "4")]) (AM_B ESP)
761 the_sp_plus_8 = OP_DA (Const [Pos (UF_NUM "8")]) (AM_B ESP)
762
763 annsOf :: Opcode -> [Operand] -> [Annot]
764 annsOf opcode operands
765 = let opInfo
766 = getOperandInfo opcode
767 no_applicable_info
768 = incomplete ("operand info ("
769 ++ show opInfo
770 ++ ") doesn't match operand(s): "
771 ++ ppd (Insn mkNoAnns opcode operands))
772
773 in case opInfo of
774
775 OI effects
776 -> case annsFromEffects effects operands of
777 Just anns -> anns
778 Nothing -> no_applicable_info
779
780 OI_Jumpy
781 -> case operands of
782 [op1] -> case op1 of
783 { OP_STAR o -> [AnnR 4 o]; _ -> [] }
784 other -> no_applicable_info
785
786 OI_NoEffect
787 -> []
788
789 OI_Error
790 -> internal ( "unsimplified opcode: "
791 ++ ppd (Insn mkNoAnns opcode operands))
792
793 OI_Special
794 | opcode == O_pushl
795 -> case operands of
796 [op1] -> [AnnR 4 op1, AnnW 4 the_sp_plus_4]
797 other -> no_applicable_info
798
799 | opcode == O_call
800 -> case operands of
801 [op1] -> case op1 of
802 OP_STAR o -> [AnnR 4 o, AnnW 4 the_sp_plus_4]
803 direct -> [AnnW 4 the_sp_plus_4]
804 other -> no_applicable_info
805
806 | opcode == O_popl
807 -> case operands of
808 [op1] -> [AnnR 4 the_sp_plus_8, AnnW 4 op1]
809
810 | opcode == O_ret
811 -> [AnnR 4 the_sp_plus_8]
812
813 | opcode == O_scasb
814 -> [AnnR 1 the_edi]
815 | opcode == O_cmpsb
816 -> [AnnR 1 the_edi, AnnR 1 the_esi]
817 | opcode == O_movsl
818 -> [AnnR 4 the_esi, AnnW 4 the_edi]
819 | opcode == O_movsw
820 -> [AnnR 2 the_esi, AnnW 2 the_edi]
821 | opcode == O_movsb
822 -> [AnnR 1 the_esi, AnnW 1 the_edi]
823 | opcode == O_stosl
824 -> [AnnW 4 the_edi] -- a guess
825 | opcode == O_stosw
826 -> [AnnW 2 the_edi] -- a guess
827 | opcode == O_stosb
828 -> [AnnW 1 the_edi] -- a guess
829 other
830 -> incomplete ("\nunclassifiable opcode: "
831 ++ ppd (Insn mkNoAnns opcode operands) )
832
833
834 annsFromEffects :: [OperandEffect] -> [Operand] -> Maybe [Annot]
835 annsFromEffects effects operands
836 | null effects
837 = Nothing
838 | otherwise
839 = let mismatch = annsFromEffects (tail effects) operands
840 in
841 case head effects of
842
843 OE_RR s1 s2
844 -> case operands of
845 [op1, op2] -> Just [AnnR s1 op1, AnnR s2 op2]
846 other -> mismatch
847
848 OE_RM s1 s2
849 -> case operands of
850 [op1, op2] -> Just [AnnR s1 op1, AnnM s2 op2]
851 other -> mismatch
852
853 OE_RW s1 s2
854 -> case operands of
855 [op1, op2] -> Just [AnnR s1 op1, AnnW s2 op2]
856 other -> mismatch
857
858 OE_R s1
859 -> case operands of
860 [op1] -> Just [AnnR s1 op1]
861 other -> mismatch
862
863 OE_M s1
864 -> case operands of
865 [op1] -> Just [AnnM s1 op1]
866 other -> mismatch
867
868 OE_W s1
869 -> case operands of
870 [op1] -> Just [AnnW s1 op1]
871 other -> mismatch
872
873 OE_nW s2
874 -> case operands of
875 [op1,op2] -> Just [AnnW s2 op2]
876 other -> mismatch
877
878 OE_RRM s1 s2 s3
879 -> case operands of
880 [op1,op2,op3] -> Just [AnnR s1 op1, AnnR s2 op2,
881 AnnM s3 op3]
882 other -> mismatch
883
884
885 getOperandInfo :: Opcode -> OperandInfo
886 getOperandInfo opcR
887 = case [oi | (opc, oi) <- x86info, opc == opcR] of
888 [oi] -> oi
889 _ -> incomplete ("getOperandInfo: no info for: "
890 ++ show opcR ++ "\n")
891
892
893 {-----------------------------------------------------------}
894 {--- Stage 7a for level 2 profiling. Look at the ---}
895 {--- debugging info, so as to guess file and function ---}
896 {--- names, and line numbers. Stick this info onto ---}
897 {--- every instruction for which we want to bill a ---}
898 {--- memory transaction. ---}
899 {-----------------------------------------------------------}
900
901 -- section-main
902 addCCs :: [Line] -> [Line]
903 addCCs
904 = addCCs_wrk (Guessed "_unknown_file_")
905 0
906 (Guessed "_unknown_function_")
907
908 data PossiblyString
909 = Stated String
910 | Guessed String
911
912 isGuessed ps = case ps of { Guessed _ -> True; _ -> False }
913 getTheString (Stated s) = s
914 getTheString (Guessed s) = s
915
916 -- file name, line number, function name
917 addCCs_wrk :: PossiblyString -> Int -> PossiblyString
918 -> [Line] -> [Line]
919 addCCs_wrk inm lno fnm []
920 = []
921 addCCs_wrk inm lno fnm (l:ls)
922 = case l of
923 Real _ _ insn
924 | hasRealAnns insn
925 -> setCC l (CC (getTheString inm) lno (getTheString fnm))
926 : addCCs_wrk inm lno fnm ls
927 | otherwise
928 -> l : addCCs_wrk inm lno fnm ls
929 Pseudo ln s
930 -> case updCC s of
931 (inm2, lno2, fnm2)
932 -> l : addCCs_wrk inm2 lno2 fnm2 ls
933 Label ln s
934 -> case updL s of
935 (inm2, lno2, fnm2)
936 -> l : addCCs_wrk inm2 lno2 fnm2 ls
937 where
938 updCC s
939 = upd2 (words (dropWhile isSpace s))
940
941 upd2 (".stabn" : args : _)
942 = case splitArgs args of
943 ("68":_:lns:_) -> (inm, read lns, fnm)
944 _ -> (inm, lno, fnm)
945
946 upd2 (".stabs" : args : _)
947 = case splitArgs args of
948 (filenm:"100":_) | last filenm /= '/'
949 -> (Stated (deQuote filenm), lno, fnm)
950 (filenm:"132":_) -> (Stated (deQuote filenm), lno, fnm)
951 (fnnm:"36":_) | (not.null.deQuote) fnnm
952 -> (inm, lno,
953 Stated (deQuote
954 (takeWhile (/=':') fnnm)))
955 _ -> (inm, lno, fnm)
956
957 upd2 [".file", filenm]
958 | isGuessed inm && isQuoted filenm
959 = (Guessed (deQuote filenm), lno, fnm)
960
961 upd2 _
962 = (inm, lno, fnm)
963
964 -- Try to guess function names from labels
965 -- if no debugging info is available.
966 -- If debugging info is available, don't override it.
967 updL label_text
968 | isGuessed fnm && take 2 cleaned /= ".L"
969 = (inm, lno, Guessed (init cleaned))
970 | otherwise
971 = (inm, lno, fnm)
972 where
973 cleaned = dropWhile isSpace label_text
974
975 splitArgs = breakOnComma . zapCIQ
976
977 zapCIQ s = out s -- zap commas inside quotes
978 out [] = []
979 out (c:cs) | c == '"' = c : inn cs
980 | otherwise = c : out cs
981
982 inn [] = []
983 inn (c:cs) | c == '"' = c : out cs
984 | c == ',' = '_' : inn cs
985 | otherwise = c : inn cs
986
987 breakOnComma :: String -> [String]
988 breakOnComma [] = []
989 breakOnComma s
990 = case span (/= ',') s of
991 (pre,post) -> pre : breakOnComma (drop 1 post)
992
993 isQuoted s
994 = length s >= 2 && head s == '"' && last s == '"'
995 deQuote s
996 = filter (/= '"') s -- " fool Haskell-mode highlighting
997
998
999 {-----------------------------------------------------------}
1000 {--- Stage 7b for level 2 profiling. Examine the CC ---}
1001 {--- descriptors that stage 7a created. Each one will ---}
1002 {--- require some storage in the final assembly output. ---}
1003 {--- Also, run over the annotated instructions, and ---}
1004 {--- insert calls to the cache simulator. ---}
1005 {-----------------------------------------------------------}
1006
1007 {-- A complex stage.
1008
1009 1. Round up the CCs that Stage 7a attached.
1010
1011 2. Condense them into a convenient form
1012 holding the names of source files, source functions
1013 and sourcepoints mentioned in this file.
1014 (this is makeCCdescriptors)
1015
1016 3. Using (2), generate a data area in which holds
1017 the file & function names, and the array of counters,
1018 one per source point.
1019 (this is useCCdescriptors)
1020
1021 4. Independently of 1, 2 and 3, travel over the
1022 output of section 7a, and insert calls to the
1023 cache simulator around every insn marked as doing
1024 a memory access which we want to know about.
1025 (mapAccumL synthLine)
1026 ---}
1027
1028
1029 -- section-main
1030 synth_2 :: [Line] -> [Line]
1031 synth_2 ccd_assy
1032 = let -- get the ccs (part 1)
1033 ccs
1034 = map getCC ccd_assy
1035 -- make a handy package (part 2)
1036 cc_descriptors
1037 = makeCCdescriptors ccs
1038 -- generate the data areas (part 3)
1039 data_areas
1040 = useCCdescriptors cc_descriptors
1041 -- insert calls to cache simulator (part 4)
1042 num_ccs_avail
1043 = case cc_descriptors of
1044 (dbg, file_names, fn_names, src_points)
1045 -> length src_points
1046 (num_ccs_used, synthd_assy_grps)
1047 = mapAccumL synthLine 0 ccd_assy
1048 synthd_assy
1049 = if num_ccs_used == num_ccs_avail -- paranoid :-)
1050 then concat synthd_assy_grps
1051 else internal "doFile: cc supply/usage mismatch\n"
1052 in
1053 synthd_assy ++ data_areas
1054
1055
1056 {-------------------------------------------}
1057 {--- part 2. ---}
1058 {--- Roll CC info into a handy package. ---}
1059 {--- Is arch independant. ---}
1060 {-------------------------------------------}
1061
1062 makeCCdescriptors :: [CC] -> ([String],[String],[String],[(Int,Int,Int)])
1063 makeCCdescriptors allCcs
1064 = let -- interesting ccs
1065 ccs = filter (not.isNoCC) allCcs
1066
1067 -- the filenames
1068 filenames = nub (map ccGetFileNm ccs)
1069
1070 -- make a map from each function to its
1071 -- canonical name, by adding the name of the
1072 -- function in which it first appears
1073 canonical_fn_map
1074 = canonicalise (
1075 zip (map ccGetFuncNm ccs) (map ccGetFileNm ccs))
1076 (canonical_fn_map_fsts, canonical_fn_map_snds)
1077 = unzip canonical_fn_map
1078
1079 canonicalise [] = []
1080 canonicalise ((fn,file):rest)
1081 = (fn,fn++"("++file++")")
1082 : canonicalise (filter ((/= fn).fst) rest)
1083
1084 toSrcPoint :: CC -> (Int,Int,Int)
1085 toSrcPoint cc
1086 = (indexOf filenames (ccGetFileNm cc),
1087 ccGetLineNo cc,
1088 indexOf canonical_fn_map_fsts (ccGetFuncNm cc))
1089
1090 srcPoints = map toSrcPoint ccs
1091
1092 debugging_text
1093 = ["file names:"]
1094 ++ map indent filenames
1095 ++ ["canonicalised function names:"]
1096 ++ map indent canonical_fn_map_snds
1097 ++ ["raw source points:"]
1098 ++ map indent (map show ccs)
1099 ++ ["cooked source points:"]
1100 ++ map indent (map show srcPoints)
1101
1102 indent s = " " ++ s
1103 indexOf xs y
1104 = f 0 xs
1105 where
1106 f n [] = internal ("indexOf: " ++ show y ++ "\n")
1107 f n (z:zs) = if y == z then n else f (n+1) zs
1108 in
1109 (debugging_text,
1110 filenames,
1111 canonical_fn_map_snds,
1112 srcPoints)
1113
1114
1115
1116 {-------------------------------------------}
1117 {--- part 3. ---}
1118 {--- Generate data area from the handy ---}
1119 {--- package. Is arch dependant. ---}
1120 {-------------------------------------------}
1121
1122 {- Generate assembly code to define a data area like this:
1123
1124 <msb_first_word> #filenames
1125 <msb_first_word> #funcnames
1126 <msb_first_word> #sourcepoints
1127 filenames, 0 terminated, end-to-end
1128 funcnames, 0 terminated, end-to-end
1129 sourcepoints
1130
1131 The comment text can be included too.
1132
1133 Each sourcepoint is a 28-byte area with
1134 the following format:
1135 4 bytes file number
1136 4 bytes line number
1137 4 bytes function number
1138 8 bytes number of references, initially zero
1139 8 bytes number of misses, initially zero
1140 The fields are regarded as integers stored in the
1141 native endianness, ie on x86 the byte order is
1142 3 2 1 0 for the first three and 7 6 5 4 3 2 1 0
1143 for the last two.
1144 -}
1145
1146 mk_arch_label_def s = ".L" ++ s ++ ":"
1147 mk_arch_label_use s = ".L" ++ s
1148 tABLE_START_STRING = "cacheprof_magic_table"
1149 bUCKETS_START_STRING = "cacheprof_magic_buckets"
1150
1151 useCCdescriptors :: ([String],[String],[String],[(Int,Int,Int)])
1152 -> [Line]
1153 useCCdescriptors (debugging_text, filenames, funcnames, points)
1154 = let length_words
1155 = [mk_comment "number of filenames, funcnames, points, cc addr"]
1156 ++ map mk_word [length filenames,
1157 length funcnames,
1158 length points]
1159 ++ [mk_word_l bUCKETS_START_STRING]
1160 strings
1161 = filenames ++ funcnames
1162 string_bytes
1163 = concatMap mk_string strings
1164 point_words
1165 = concatMap mk_point_words points
1166 comments
1167 = map mk_comment debugging_text
1168 pre_comments
1169 = map mk_comment ["", "---- start of the cost centers ----"]
1170 post_comments
1171 = map mk_comment ["", "---- end of the cost centers ----"]
1172 mk_point_words p@(fileno,lineno,funcno)
1173 = mk_comment (show p)
1174 : map mk_word [fileno, lineno, funcno, 0,0, 0,0]
1175 preamble
1176 = mk_dataSeg ++ mk_align
1177
1178 mk_Pseudo = Pseudo 0
1179 mk_label_def s = mk_arch_label_def s
1180 mk_word i = "\t.long " ++ show i
1181 mk_word_l l = "\t.long " ++ mk_arch_label_use l
1182 mk_byte i = "\t.byte " ++ show i
1183 mk_comment s = "\t# " ++ s
1184 mk_string s = [mk_comment (show s)]
1185 ++ map (mk_byte.ord) s
1186 ++ [mk_byte 0]
1187 mk_dataSeg = ["\t.data"]
1188 mk_align = ["\t.align 4"]
1189 in
1190 map mk_Pseudo (
1191 concat [pre_comments, comments,
1192 preamble,
1193 [mk_label_def tABLE_START_STRING],
1194 length_words, string_bytes,
1195 mk_align,
1196 [mk_label_def bUCKETS_START_STRING],
1197 point_words, post_comments]
1198 )
1199
1200
1201
1202 {-------------------------------------------}
1203 {--- Generate calls to the ---}
1204 {--- cache simulator (part 4) ---}
1205 {-------------------------------------------}
1206
1207 synthLine :: Int -> Line -> (Int, [Line])
1208 synthLine nextcc (Pseudo ln stuff)
1209 = (nextcc, [Pseudo ln stuff])
1210 synthLine nextcc (Label ln stuff)
1211 = (nextcc, [Label ln stuff])
1212 synthLine nextcc (Real ln cc insn)
1213 | hasRealAnns insn
1214 = (nextcc+1, map (Real ln cc) (synth_wrk nextcc insn))
1215 | otherwise
1216 = (nextcc, [Real ln cc insn])
1217
1218
1219
1220 synth_wrk :: Int -> Insn -> [Insn]
1221 synth_wrk ccid_to_use insn@(Insn ann opcode operands)
1222 = concatMap (useAnnot ccid_to_use) (getAnns ann)
1223 ++ [insn]
1224
1225 insn_pushl reg
1226 = Insn (mkAnnC "save") O_pushl [OP_REG reg]
1227 insn_popl reg
1228 = Insn (mkAnnC "rest") O_popl [OP_REG reg]
1229
1230 std_preamble
1231 = [insn_pushl EAX, insn_pushl EBX]
1232 std_postamble
1233 = [insn_popl EBX, insn_popl EAX]
1234
1235 useAnnot :: Int -> Annot -> [Insn]
1236 useAnnot ccid (AnnC c)
1237 = internal "useAnnot on comment annotation"
1238
1239 useAnnot ccid (AnnR sz op)
1240 = std_preamble
1241 ++
1242 [ Insn (mkAnnC "rd-1") O_leal
1243 [op, OP_REG EAX],
1244 Insn (mkAnnC "rd-2") O_movl
1245 [mk_bucket_addr ccid, OP_REG EBX],
1246 Insn (mkAnnC "rd-3") O_call
1247 [OP_D (Const [Pos (mk_rd_hook_name sz)])]
1248 ]
1249 ++ std_postamble
1250
1251 useAnnot ccid (AnnM sz op)
1252 = std_preamble
1253 ++
1254 [ Insn (mkAnnC "mo-1") O_leal
1255 [op, OP_REG EAX],
1256 Insn (mkAnnC "mo-2") O_movl
1257 [mk_bucket_addr ccid, OP_REG EBX],
1258 Insn (mkAnnC "mo-3") O_call
1259 [OP_D (Const [Pos (mk_mo_hook_name sz)])]
1260 ]
1261 ++ std_postamble
1262
1263 useAnnot ccid (AnnW sz op)
1264 = std_preamble
1265 ++
1266 [ Insn (mkAnnC "wr-1") O_leal
1267 [op, OP_REG EAX],
1268 Insn (mkAnnC "wr-2") O_movl
1269 [mk_bucket_addr ccid, OP_REG EBX],
1270 Insn (mkAnnC "wr-3") O_call
1271 [OP_D (Const [Pos (mk_wr_hook_name sz)])]
1272 ]
1273 ++ std_postamble
1274
1275 mk_bucket_addr ccid
1276 = OP_D (Const [Pos (UF_LABEL
1277 ("$" ++ mk_arch_label_use bUCKETS_START_STRING)),
1278 Pos (UF_NUM (show (28 * ccid)))])
1279
1280 mk_rd_hook_name sz
1281 = UF_NAME ("cacheprof_hook_Rd" ++ show sz)
1282 mk_mo_hook_name sz
1283 = UF_NAME ("cacheprof_hook_Mo" ++ show sz)
1284 mk_wr_hook_name sz
1285 = UF_NAME ("cacheprof_hook_Wr" ++ show sz)
1286
1287
1288 {-----------------------------------------------------------}
1289 {--- Stage 7 for level 1 profiling. At each notifiable ---}
1290 {--- memory reference (ie, at each place where level 2 ---}
1291 {--- profiling would insert a call to the cache ---}
1292 {--- simulator, just increment the total read/write ---}
1293 {--- counts. ---}
1294 {-----------------------------------------------------------}
1295
1296 -- section-main
1297 synth_1 :: [Line] -> [Line]
1298 synth_1 = concatMap synth_1_wrk
1299
1300 synth_1_wrk :: Line -> [Line]
1301 synth_1_wrk (Pseudo ln stuff)
1302 = [Pseudo ln stuff]
1303 synth_1_wrk (Label ln stuff)
1304 = [Label ln stuff]
1305 synth_1_wrk line@(Real ln cc insn@(Insn ann opcode operands))
1306 | hasRealAnns insn
1307 = map (Real ln cc) (concatMap useIncAnns (getAnns ann))
1308 ++ [line]
1309 | otherwise
1310 = [Real ln cc insn]
1311 where
1312 useIncAnns (AnnW sz op)
1313 = incSequence 1 "cacheprof_level1_writes"
1314 useIncAnns (AnnR sz op)
1315 = incSequence 1 "cacheprof_level1_reads"
1316 useIncAnns (AnnM sz op)
1317 = incSequence 1 "cacheprof_level1_reads" ++
1318 incSequence 1 "cacheprof_level1_writes"
1319
1320 -- generate a sequence to increment a 64-bit counter in
1321 -- memory, labelled "name", by k
1322 incSequence :: Int -> String -> [Insn]
1323 incSequence k name
1324 = [Insn DontAnnMe O_pushfl [],
1325 Insn DontAnnMe O_addl
1326 [OP_LIT (Const [Pos (UF_NUM (show k))]),
1327 OP_D (Const [Pos (UF_NAME name)])],
1328 Insn DontAnnMe O_adcl
1329 [OP_LIT (Const [Pos (UF_NUM "0")]),
1330 OP_D (Const [Pos (UF_NUM "4"),
1331 Pos (UF_NAME name)])],
1332 Insn DontAnnMe O_popfl []
1333 ]
1334
1335
1336 {-----------------------------------------------------------}
1337 {--- Stage 8. Peephole opt to remove some stupidities. ---}
1338 {-----------------------------------------------------------}
1339
1340 {- The idea is to clean up (eg)
1341 pushfl
1342 addl $3,cacheprof_icount
1343 adcl $0,4+cacheprof_icount
1344 popfl
1345 pushfl
1346 addl $1,cacheprof_level1_writes
1347 adcl $0,4+cacheprof_level1_writes
1348 popfl
1349 into
1350 pushfl
1351 addl $3,cacheprof_icount
1352 adcl $0,4+cacheprof_icount
1353 addl $1,cacheprof_level1_writes
1354 adcl $0,4+cacheprof_level1_writes
1355 popfl
1356 -}
1357
1358 -- section-main
1359 peephole :: [Line] -> [Line]
1360
1361 peephole ( line1@(Real ln1 cc1 insn1) :
1362 line2@(Real ln2 cc2 insn2) :
1363 line3@(Real ln3 cc3 (Insn anns3 O_popfl [])) :
1364 line4@(Real ln4 cc4 (Insn anns4 O_pushfl [])) :
1365 line5@(Real ln5 cc5 insn5) :
1366 line6@(Real ln6 cc6 insn6) :
1367 the_rest )
1368 | incs_a_counter insn1 insn2
1369 && incs_a_counter insn5 insn6
1370 = peephole (line1 : line2 : line5 : line6 : the_rest)
1371
1372 peephole ( line: the_rest)
1373 = line : peephole the_rest
1374 peephole []
1375 = []
1376
1377
1378 -- Say after me: We love pattern matching
1379 incs_a_counter (Insn anns1 O_addl
1380 [OP_LIT (Const [Pos (UF_NUM n)]),
1381 OP_D (Const [Pos (UF_NAME name1)])])
1382 (Insn anns2 O_adcl
1383 [OP_LIT (Const [Pos (UF_NUM zero)]),
1384 OP_D (Const [Pos (UF_NUM four),
1385 Pos (UF_NAME name2)])])
1386 = take 10 name1 == "cacheprof_"
1387 && take 10 name2 == "cacheprof_"
1388 && zero == "0" && four == "4"
1389
1390 incs_a_counter insn1 insn2
1391 = False
1392
1393
1394 {-----------------------------------------------------------}
1395 {--- Stage 9. Final cleanup -- zap debugging info. ---}
1396 {-----------------------------------------------------------}
1397
1398 -- section-main
1399 final_cleanup :: [Line] -> String
1400 final_cleanup
1401 = unlines . map ppu . filter (not.isStabLine)
1402 where
1403 isStabLine (Pseudo ln s)
1404 = take 5 (dropWhile isSpace s) == ".stab"
1405 isStabLine other
1406 = False
1407
1408
1409 {-----------------------------------------------------------}
1410 {--- Main! ---}
1411 {-----------------------------------------------------------}
1412
1413 main = seq stderr ( -- avoid bug in ghc-4.04
1414 do args <- --getArgs
1415 return ["--level2"]
1416
1417 let prof_level
1418 = if "--level0" `elem` args then 0
1419 else if "--level1" `elem` args then 1
1420 else if "--level2" `elem` args then 2
1421 else internal
1422 "profiling level not supplied by `cacheprof'"
1423
1424 let bad_ddump_flags
1425 = filter (`notElem` ddump_flags)
1426 (filter ((== "--ddump-") . take 8) args)
1427
1428 if (not (null bad_ddump_flags))
1429 then do hPutStr stderr (
1430 "cacheann: bad debugging flag(s): " ++
1431 unwords bad_ddump_flags ++
1432 "\n valid debugging flags are\n" ++
1433 unlines (map (" "++) ddump_flags)
1434 )
1435 exitWith (ExitFailure 1)
1436 else return ()
1437
1438 ifVerb args (hPutStr stderr "cacheann-0.01: annotating ...\n")
1439 f <- getContents
1440 aux <- case prof_level of
1441 0 -> return ""
1442 1 -> readFile "cacheprof_hooks1_x86.s"
1443 2 -> readFile "cacheprof_hooks2_x86.s"
1444
1445 out <- doFile prof_level args f
1446 putStr out
1447 putStr aux
1448 ifVerb args (hPutStr stderr "cacheann-0.01: done\n")
1449 )
1450
1451 ifVerb :: [String] -> IO () -> IO ()
1452 ifVerb flags ioact
1453 = if "-v" `elem` flags then ioact else return ()
1454
1455 doFile :: Int -> [String] -> String -> IO String
1456 doFile prof_level args input_text
1457 = let preparsed = preparse input_text
1458 parsed = map forceLine (parse preparsed)
1459 simplified = simplify parsed
1460 with_bbs_ident = identify_bbs simplified
1461 with_icounts = use_bbs with_bbs_ident
1462 annotated = annotate with_icounts
1463 with_ccs = addCCs annotated
1464 with_synth_2 = synth_2 with_ccs
1465 with_synth_1 = synth_1 annotated
1466 with_synth = case prof_level of
1467 0 -> simplified
1468 1 -> with_synth_1
1469 2 -> with_synth_2
1470 peepholed = peephole with_synth
1471 final = final_cleanup peepholed
1472
1473 debugging_io
1474 = do ifopt [0,1,2] ddump_preparsed preparsed
1475 ifopt [0,1,2] ddump_parsed parsed
1476 ifopt [0,1,2] ddump_simplified simplified
1477 ifopt [1,2] ddump_ident_bbs with_bbs_ident
1478 ifopt [1,2] ddump_use_bbs with_icounts
1479 ifopt [1,2] ddump_annotated annotated
1480 ifopt [2] ddump_ccs with_ccs
1481 ifopt [0,1,2] ddump_synth with_synth
1482 ifopt [0,1,2] ddump_peephole peepholed
1483
1484 ifopt valid_levels flag stuff
1485 | prof_level `elem` valid_levels
1486 && flag `elem` args
1487 = hPutStr stderr (
1488 "\n\n-------- DEBUGGING OUTPUT FOR "
1489 ++ flag ++ ":\n\n"
1490 ++ unlines (map ppd stuff)
1491 ++ "\n\n" )
1492 | otherwise
1493 = return ()
1494
1495 forceLine :: Line -> Line
1496 forceLine line | line == line = line
1497 | otherwise = internal "forceLine"
1498 in
1499 debugging_io >> return final
1500
1501
1502 ddump_preparsed = "--ddump-preparsed"
1503 ddump_parsed = "--ddump-parsed"
1504 ddump_simplified = "--ddump-simplified"
1505 ddump_ident_bbs = "--ddump-ident-bbs"
1506 ddump_use_bbs = "--ddump-use-bbs"
1507 ddump_annotated = "--ddump-annotated"
1508 ddump_ccs = "--ddump-ccs"
1509 ddump_synth = "--ddump-synth"
1510 ddump_peephole = "--ddump-peephole"
1511
1512 ddump_flags
1513 = [ddump_preparsed, ddump_parsed, ddump_simplified,
1514 ddump_ident_bbs, ddump_use_bbs, ddump_annotated,
1515 ddump_ccs, ddump_synth, ddump_peephole]
1516
1517 {------------------------------------------------------------------------}
1518 {--- end CacheAnn.hs ---}
1519 {------------------------------------------------------------------------}