source: project/chicken/branches/prerelease/chicken-profile.scm @ 9381

Last change on this file since 9381 was 9381, checked in by Ivan Raikov, 12 years ago

Merged trunk into prerelease

File size: 7.7 KB
Line 
1;;;; chicken-profile.scm - Formatted display of profile outputs - felix -*- Scheme -*-
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (block)
30  (uses srfi-1
31        srfi-13
32        posix
33        utils))
34
35(define sort-by #f)
36(define file #f)
37(define no-unused #f)
38(define seconds-digits 3)
39(define average-digits 3)
40(define percent-digits 3)
41(define top 0)
42
43(define (print-usage)
44  (display #<#EOF
45Usage: chicken-profile [FILENAME | OPTION] ...
46
47 -sort-by-calls            sort output by call frequency
48 -sort-by-time             sort output by procedure execution time
49 -sort-by-avg              sort output by average procedure execution time
50 -sort-by-name             sort output alphabetically by procedure name
51 -decimals DDD             set number of decimals for seconds, average and
52                           percent columns (three digits, default: #{seconds-digits}#{average-digits}#{percent-digits})
53 -no-unused                remove procedures that are never called
54 -top N                    display only the top N entries
55 -help                     show this text and exit
56 -version                  show version and exit
57 -release                  show release number and exit
58
59 FILENAME defaults to the `PROFILE.<number>', selecting the one with
60 the highest modification time, in case multiple profiles exist.
61
62EOF
63)
64 (exit 64) )
65
66(define (run args)
67  (let loop ([args args])
68    (if (null? args)
69        (begin
70          (unless file 
71            (set! file
72              (let ((fs (glob "PROFILE.*")))
73                (if (null? fs)
74                    (error "no PROFILEs found")
75                    (first (sort fs 
76                                 (lambda (f1 f2)
77                                   (> (file-modification-time f1)
78                                      (file-modification-time f2))) ) ) ) ) ) )
79          (write-profile) )
80        (let ([arg (car args)]
81              [rest (cdr args)] )
82          (define (next-arg)
83            (if (null? rest)
84                (error "missing argument to option" arg)
85                (let ((narg (car rest)))
86                  (set! rest (cdr rest))
87                  narg)))
88          (define (next-number)
89            (let ((n (string->number (next-arg))))
90              (if (and n (> n 0)) n (error "invalid argument to option" arg))))
91          (match arg
92            [(or "-h" "-help" "--help") (print-usage)]
93            [(or "-v" "-version") 
94             (print "chicken-profile - Version " (chicken-version))
95             (exit) ]
96            ["-release" 
97             (print (chicken-version))
98             (exit) ]
99            ["-no-unused" (set! no-unused #t)]
100            ["-top" (set! top (next-number))]
101            ["-sort-by-calls" (set! sort-by sort-by-calls)]
102            ["-sort-by-time" (set! sort-by sort-by-time)]
103            ["-sort-by-avg" (set! sort-by sort-by-avg)]
104            ["-sort-by-name" (set! sort-by sort-by-name)]
105            ["-decimals" (set-decimals (next-arg))]
106            [_ (cond [(and (> (string-length arg) 1) (char=? #\- (string-ref arg 0)))
107                      (error "invalid option" arg) ]
108                     [file (print-usage)]
109                     [else (set! file arg)] ) ] )
110          (loop rest) ) ) ) )
111
112(define (sort-by-calls x y)
113  (let ([c1 (second x)]
114        [c2 (second y)] )
115    (if (eqv? c1 c2)
116        (> (third x) (third y))
117        (if c1 (if c2 (> c1 c2) #t) #t) ) ) )
118
119(define (sort-by-time x y)
120  (let ([c1 (third x)]
121        [c2 (third y)] )
122    (if (= c1 c2)
123        (> (second x) (second y))
124        (> c1 c2) ) ) )
125
126(define (sort-by-avg x y)
127  (let ([c1 (cadddr x)]
128        [c2 (cadddr y)] )
129    (if (eqv? c1 c2)
130        (> (third x) (third y))
131        (> c1 c2) ) ) )
132
133(define (sort-by-name x y)
134  (string<? (symbol->string (first x)) (symbol->string (first y))) )
135
136(set! sort-by sort-by-time)
137
138(define (set-decimals arg)
139  (if (= (string-length arg) 3)
140      (begin
141        (define (arg-digit n)
142          (let ((n (- (char->integer (string-ref arg n))
143                      (char->integer #\0))))
144            (if (<= 0 n 9)
145                (if (= n 9) 8 n) ; 9 => overflow in format-real
146                (error "invalid argument to -decimals option" arg))))
147        (set! seconds-digits (arg-digit 0))
148        (set! average-digits (arg-digit 1))
149        (set! percent-digits (arg-digit 2)))
150      (error "invalid argument to -decimals option" arg)))
151
152(define (read-profile)
153  (let ((hash (make-hash-table eq?)))
154    (do ((line (read) (read)))
155        ((eof-object? line))
156      (hash-table-set!
157       hash (first line)
158       (map (lambda (x y) (and x y (+ x y)))
159            (hash-table-ref/default hash (first line) '(0 0)) 
160            (cdr line))))
161    (hash-table->alist hash)))
162
163(define (format-string str cols #!optional right (padc #\space))
164  (let* ((len (string-length str))
165         (pad (make-string (fxmax 0 (fx- cols len)) padc)) )
166    (if right
167        (string-append pad str)
168        (string-append str pad) ) ) )
169
170(define (format-real n d)
171  (let ((exact-value (inexact->exact (truncate n))))
172    (string-append
173     (number->string exact-value)
174     (if (> d 0) "." "")
175     (substring
176      (number->string
177       (inexact->exact
178        (truncate
179         (* (- n exact-value -1) (expt 10 d)))))
180      1 (+ d 1)))))
181
182(define (write-profile)
183  (print "reading `" file "' ...\n")
184  (let* ([data0 (with-input-from-file file read-profile)]
185         [max-t (fold (lambda (t result)
186                        (max (third t) result))
187                      0
188                      data0)]
189         [data (sort (map
190                      (lambda (t) (append t (let ((c (second t))
191                                                  (t (third t)))
192                                              (list (or (and c (> c 0) (/ t c))
193                                                        0)
194                                                    (or (and (> max-t 0) (* (/ t max-t) 100))
195                                                        0)
196                                                    ))))
197                      data0)
198                     sort-by)])
199    (if (< 0 top (length data))
200        (set! data (take data top)))
201    (set! data (map (lambda (entry)
202                      (let ([c (second entry)]
203                            [t (third entry)]
204                            [a (cadddr entry)]
205                            [p (list-ref entry 4)] )
206                        (list (##sys#symbol->qualified-string (first entry))
207                              (if (not c) "overflow" (number->string c))
208                              (format-real (/ t 1000) seconds-digits)
209                              (format-real (/ a 1000) average-digits)
210                              (format-real p percent-digits))))
211                    (remove (lambda (entry) 
212                              (if (second entry) 
213                                  (and (zero? (second entry)) no-unused)
214                                  #f) )
215                            data)))
216    (let* ([headers (list "procedure" "calls" "seconds" "average" "percent")]
217           [alignments (list #f #t #t #t #t)]
218           [spacing 2]
219           [spacer (make-string spacing #\space)]
220           [column-widths (fold
221                           (lambda (row max-widths)
222                             (map max (map string-length row) max-widths))
223                           (list 0 0 0 0 0)
224                           (cons headers data))])
225      (define (print-row row)
226        (print (string-join (map format-string row column-widths alignments) spacer)))
227      (print-row headers)
228      (print (make-string (+ (reduce + 0 column-widths)
229                             (* spacing (- (length alignments) 1)))
230                          #\-))
231      (for-each print-row data))))
232 
233(run (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.