source: project/chicken/trunk/chicken-profile.scm @ 15823

Last change on this file since 15823 was 12937, checked in by felix winkelmann, 11 years ago

updateed copyright

File size: 7.8 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-2009, 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        srfi-69
33        posix
34        utils))
35
36(define sort-by #f)
37(define file #f)
38(define no-unused #f)
39(define seconds-digits 3)
40(define average-digits 3)
41(define percent-digits 3)
42(define top 0)
43
44(define (print-usage)
45  (display #<#EOF
46Usage: chicken-profile [FILENAME | OPTION] ...
47
48 -sort-by-calls            sort output by call frequency
49 -sort-by-time             sort output by procedure execution time
50 -sort-by-avg              sort output by average procedure execution time
51 -sort-by-name             sort output alphabetically by procedure name
52 -decimals DDD             set number of decimals for seconds, average and
53                           percent columns (three digits, default: #{seconds-digits}#{average-digits}#{percent-digits})
54 -no-unused                remove procedures that are never called
55 -top N                    display only the top N entries
56 -help                     show this text and exit
57 -version                  show version and exit
58 -release                  show release number and exit
59
60 FILENAME defaults to the `PROFILE.<number>', selecting the one with
61 the highest modification time, in case multiple profiles exist.
62
63EOF
64)
65 (exit 64) )
66
67(define (run args)
68  (let loop ([args args])
69    (if (null? args)
70        (begin
71          (unless file 
72            (set! file
73              (let ((fs (glob "PROFILE.*")))
74                (if (null? fs)
75                    (error "no PROFILEs found")
76                    (first (sort fs 
77                                 (lambda (f1 f2)
78                                   (> (file-modification-time f1)
79                                      (file-modification-time f2))) ) ) ) ) ) )
80          (write-profile) )
81        (let ([arg (car args)]
82              [rest (cdr args)] )
83          (define (next-arg)
84            (if (null? rest)
85                (error "missing argument to option" arg)
86                (let ((narg (car rest)))
87                  (set! rest (cdr rest))
88                  narg)))
89          (define (next-number)
90            (let ((n (string->number (next-arg))))
91              (if (and n (> n 0)) n (error "invalid argument to option" arg))))
92          (cond
93           [(member arg '("-h" "-help" "--help")) (print-usage)]
94           [(member arg '("-v" "-version"))
95            (print "chicken-profile - Version " (chicken-version))
96            (exit) ]
97           [(string=? arg "-release")
98            (print (chicken-version))
99            (exit) ]
100           [(string=? arg "-no-unused") (set! no-unused #t)]
101           [(string=? arg "-top") (set! top (next-number))]
102           [(string=? arg "-sort-by-calls") (set! sort-by sort-by-calls)]
103           [(string=? arg "-sort-by-time") (set! sort-by sort-by-time)]
104           [(string=? arg "-sort-by-avg") (set! sort-by sort-by-avg)]
105           [(string=? arg "-sort-by-name") (set! sort-by sort-by-name)]
106           [(string=? arg "-decimals") (set-decimals (next-arg))]
107           [(and (> (string-length arg) 1) (char=? #\- (string-ref arg 0)))
108            (error "invalid option" arg) ]
109           [file (print-usage)]
110           [else (set! file arg)] )
111          (loop rest) ) ) ) )
112
113(define (sort-by-calls x y)
114  (let ([c1 (second x)]
115        [c2 (second y)] )
116    (if (eqv? c1 c2)
117        (> (third x) (third y))
118        (if c1 (if c2 (> c1 c2) #t) #t) ) ) )
119
120(define (sort-by-time x y)
121  (let ([c1 (third x)]
122        [c2 (third y)] )
123    (if (= c1 c2)
124        (> (second x) (second y))
125        (> c1 c2) ) ) )
126
127(define (sort-by-avg x y)
128  (let ([c1 (cadddr x)]
129        [c2 (cadddr y)] )
130    (if (eqv? c1 c2)
131        (> (third x) (third y))
132        (> c1 c2) ) ) )
133
134(define (sort-by-name x y)
135  (string<? (symbol->string (first x)) (symbol->string (first y))) )
136
137(set! sort-by sort-by-time)
138
139(define (set-decimals arg)
140  (if (= (string-length arg) 3)
141      (begin
142        (define (arg-digit n)
143          (let ((n (- (char->integer (string-ref arg n))
144                      (char->integer #\0))))
145            (if (<= 0 n 9)
146                (if (= n 9) 8 n) ; 9 => overflow in format-real
147                (error "invalid argument to -decimals option" arg))))
148        (set! seconds-digits (arg-digit 0))
149        (set! average-digits (arg-digit 1))
150        (set! percent-digits (arg-digit 2)))
151      (error "invalid argument to -decimals option" arg)))
152
153(define (read-profile)
154  (let ((hash (make-hash-table eq?)))
155    (do ((line (read) (read)))
156        ((eof-object? line))
157      (hash-table-set!
158       hash (first line)
159       (map (lambda (x y) (and x y (+ x y)))
160            (hash-table-ref/default hash (first line) '(0 0)) 
161            (cdr line))))
162    (hash-table->alist hash)))
163
164(define (format-string str cols #!optional right (padc #\space))
165  (let* ((len (string-length str))
166         (pad (make-string (fxmax 0 (fx- cols len)) padc)) )
167    (if right
168        (string-append pad str)
169        (string-append str pad) ) ) )
170
171(define (format-real n d)
172  (let ((exact-value (inexact->exact (truncate n))))
173    (string-append
174     (number->string exact-value)
175     (if (> d 0) "." "")
176     (substring
177      (number->string
178       (inexact->exact
179        (truncate
180         (* (- n exact-value -1) (expt 10 d)))))
181      1 (+ d 1)))))
182
183(define (write-profile)
184  (print "reading `" file "' ...\n")
185  (let* ([data0 (with-input-from-file file read-profile)]
186         [max-t (fold (lambda (t result)
187                        (max (third t) result))
188                      0
189                      data0)]
190         [data (sort (map
191                      (lambda (t) (append t (let ((c (second t))
192                                                  (t (third t)))
193                                              (list (or (and c (> c 0) (/ t c))
194                                                        0)
195                                                    (or (and (> max-t 0) (* (/ t max-t) 100))
196                                                        0)
197                                                    ))))
198                      data0)
199                     sort-by)])
200    (if (< 0 top (length data))
201        (set! data (take data top)))
202    (set! data (map (lambda (entry)
203                      (let ([c (second entry)]
204                            [t (third entry)]
205                            [a (cadddr entry)]
206                            [p (list-ref entry 4)] )
207                        (list (##sys#symbol->qualified-string (first entry))
208                              (if (not c) "overflow" (number->string c))
209                              (format-real (/ t 1000) seconds-digits)
210                              (format-real (/ a 1000) average-digits)
211                              (format-real p percent-digits))))
212                    (remove (lambda (entry) 
213                              (if (second entry) 
214                                  (and (zero? (second entry)) no-unused)
215                                  #f) )
216                            data)))
217    (let* ([headers (list "procedure" "calls" "seconds" "average" "percent")]
218           [alignments (list #f #t #t #t #t)]
219           [spacing 2]
220           [spacer (make-string spacing #\space)]
221           [column-widths (fold
222                           (lambda (row max-widths)
223                             (map max (map string-length row) max-widths))
224                           (list 0 0 0 0 0)
225                           (cons headers data))])
226      (define (print-row row)
227        (print (string-join (map format-string row column-widths alignments) spacer)))
228      (print-row headers)
229      (print (make-string (+ (reduce + 0 column-widths)
230                             (* spacing (- (length alignments) 1)))
231                          #\-))
232      (for-each print-row data))))
233 
234(run (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.