~ chicken-core (chicken-5) /chicken-profile.scm

  1;;;; chicken-profile.scm - Formatted display of profile outputs - felix -*- Scheme -*-
  2;
  3; Copyright (c) 2008-2022, The CHICKEN Team
  4; Copyright (c) 2000-2007, Felix L. Winkelmann
  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(declare (block))
 28
 29(module main ()
 30
 31(import scheme
 32	chicken.base
 33	chicken.file
 34	chicken.file.posix
 35	chicken.fixnum
 36	chicken.internal
 37	chicken.platform
 38	chicken.process-context
 39	chicken.sort
 40	chicken.string)
 41
 42(include "mini-srfi-1.scm")
 43
 44(define symbol-table-size 3001)
 45
 46(define sort-by #f)
 47(define file #f)
 48(define no-unused #f)
 49(define seconds-digits 3)
 50(define average-digits 3)
 51(define percent-digits 3)
 52(define top 0)
 53
 54(define (print-usage)
 55  (display #<#EOF
 56Usage: chicken-profile [OPTION ...] [FILENAME ...]
 57
 58 -sort-by-calls            sort output by call frequency
 59 -sort-by-time             sort output by procedure execution time
 60 -sort-by-avg              sort output by average procedure execution time
 61 -sort-by-name             sort output alphabetically by procedure name
 62 -decimals DDD             set number of decimals for seconds, average and
 63                           percent columns (three digits, default: #{seconds-digits}#{average-digits}#{percent-digits})
 64 -no-unused                remove procedures that are never called
 65 -top N                    display only the top N entries
 66 -help                     show this text and exit
 67 -version                  show version and exit
 68 -release                  show release number and exit
 69
 70 FILENAME defaults to the `PROFILE.<number>', selecting the one with
 71 the highest modification time, in case multiple profiles exist.
 72
 73EOF
 74;|
 75)
 76 (exit 64) )
 77
 78(define (run args)
 79  (let loop ([args args])
 80    (if (null? args)
 81	(begin
 82	  (unless file 
 83	    (set! file
 84	      (let ((fs (glob "PROFILE.*")))
 85		(if (null? fs)
 86		    (error "no PROFILEs found")
 87		    (first (sort fs 
 88				 (lambda (f1 f2)
 89				   (> (file-modification-time f1)
 90				      (file-modification-time f2))) ) ) ) ) ) )
 91	  (write-profile) )
 92	(let ([arg (car args)]
 93	      [rest (cdr args)] )
 94	  (define (next-arg)
 95	    (if (null? rest)
 96		(error "missing argument to option" arg)
 97		(let ((narg (car rest)))
 98		  (set! rest (cdr rest))
 99		  narg)))
100	  (define (next-number)
101	    (let ((n (string->number (next-arg))))
102	      (if (and n (> n 0)) n (error "invalid argument to option" arg))))
103	  (cond 
104	   [(member arg '("-h" "-help" "--help")) (print-usage)]
105	   [(string=? arg "-version")
106	    (print "chicken-profile - Version " (chicken-version))
107	    (exit) ]
108	   [(string=? arg "-release")
109	    (print (chicken-version))
110	    (exit) ]
111	   [(string=? arg "-no-unused") (set! no-unused #t)]
112	   [(string=? arg "-top") (set! top (next-number))]
113	   [(string=? arg "-sort-by-calls") (set! sort-by sort-by-calls)]
114	   [(string=? arg "-sort-by-time") (set! sort-by sort-by-time)]
115	   [(string=? arg "-sort-by-avg") (set! sort-by sort-by-avg)]
116	   [(string=? arg "-sort-by-name") (set! sort-by sort-by-name)]
117	   [(string=? arg "-decimals") (set-decimals (next-arg))]
118	   [(and (> (string-length arg) 1) (char=? #\- (string-ref arg 0)))
119	    (error "invalid option" arg) ]
120	   [file (print-usage)]
121	   [else (set! file arg)] )
122	  (loop rest) ) ) ) )
123
124(define (sort-by-calls x y)
125  (let ([c1 (second x)]
126	[c2 (second y)] )
127    (if (eqv? c1 c2)
128	(> (third x) (third y))
129	(if c1 (if c2 (> c1 c2) #t) #t) ) ) )
130
131(define (sort-by-time x y)
132  (let ([c1 (third x)]
133	[c2 (third y)] )
134    (if (= c1 c2)
135	(> (second x) (second y))
136	(> c1 c2) ) ) )
137
138(define (sort-by-avg x y)
139  (let ([c1 (cadddr x)]
140	[c2 (cadddr y)] )
141    (if (eqv? c1 c2)
142	(> (third x) (third y))
143	(> c1 c2) ) ) )
144
145(define (sort-by-name x y)
146  (string<? (symbol->string (first x)) (symbol->string (first y))) )
147
148(set! sort-by sort-by-time)
149
150(define (set-decimals arg)
151  (define (arg-digit n)
152    (let ((n (- (char->integer (string-ref arg n))
153		(char->integer #\0))))
154      (if (<= 0 n 9)
155	  (if (= n 9) 8 n)		; 9 => overflow in format-real
156	  (error "invalid argument to -decimals option" arg))))
157  (if (= (string-length arg) 3)
158      (begin
159	(set! seconds-digits (arg-digit 0))
160	(set! average-digits (arg-digit 1))
161	(set! percent-digits (arg-digit 2)))
162      (error "invalid argument to -decimals option" arg)))
163
164(define (make-symbol-table)
165  (make-vector symbol-table-size '()))
166
167(define (read-profile)
168  (let* ((hash (make-symbol-table))
169	 (header (read))
170	 (type (if (symbol? header) header 'instrumented)))
171    (do ((line (if (symbol? header) (read) header) (read)))
172	((eof-object? line))
173      (hash-table-set!
174       hash (first line)
175       (map (lambda (x y) (and x y (+ x y)))
176	    (or (hash-table-ref hash (first line)) '(0 0))
177	    (cdr line))))
178    (let ((alist '()))
179      (hash-table-for-each
180       (lambda (sym counts)
181	 (set! alist (alist-cons sym counts alist)))
182       hash)
183      (cons type alist))))
184
185(define (format-string str cols #!optional right (padc #\space))
186  (let* ((len (string-length str))
187	 (pad (make-string (fxmax 0 (fx- cols len)) padc)) )
188    (if right
189	(string-append pad str)
190	(string-append str pad) ) ) )
191
192(define (format-real n d)
193  (let ((exact-value (inexact->exact (truncate n))))
194    (string-append
195     (number->string exact-value)
196     (if (> d 0) "." "")
197     (substring
198      (number->string
199       (inexact->exact
200	(truncate
201	 (* (- n exact-value -1) (expt 10 d)))))
202      1 (+ d 1)))))
203
204(define (write-profile)
205  (print "reading `" file "' ...\n")
206  (let* ((type&data0 (with-input-from-file file read-profile))
207	 (type  (car type&data0))
208	 (data0 (cdr type&data0))
209	 ;; Instrumented profiling results in total runtime being
210	 ;; counted for the outermost "main" procedure, while
211	 ;; statistical counts time spent only inside the procedure
212	 ;; itself.  Ideally we'd have both, but that's tricky to do.
213	 (total-t (foldl (if (eq? type 'instrumented)
214			     (lambda (r t) (max r (third t)))
215			     (lambda (r t) (+ r (third t))))
216			 0 data0))
217	 (data (sort (map
218		      (lambda (t)
219			(append
220			 t
221			 (let ((c (second t)) ; count
222			       (t (third t))) ; time tallied to procedure
223			   (list (or (and c (> c 0) (/ t c)) ; time / count
224				     0)
225				 (or (and (> total-t 0) (* (/ t total-t) 100)) ; % of total-time
226				     0)
227				 ))))
228		      data0)
229                     sort-by)))
230    (if (< 0 top (length data))
231	(set! data (take data top)))
232    (set! data (map (lambda (entry)
233		      (let ((c (second entry)) ; count
234			    (t (third entry))  ; total time
235			    (a (fourth entry)) ; average time
236			    (p (fifth entry)) ) ; % of max time
237			(list (##sys#symbol->string (first entry))
238			      (if (not c) "overflow" (number->string c))
239			      (format-real (/ t 1000) seconds-digits)
240			      (format-real (/ a 1000) average-digits)
241			      (format-real p percent-digits))))
242		    (if no-unused
243			(filter (lambda (entry) (> (second entry) 0)) data)
244			data)))
245    (let* ((headers (list "procedure" "calls" "seconds" "average" "percent"))
246	   (alignments (list #f #t #t #t #t))
247	   (spacing 2)
248	   (spacer (make-string spacing #\space))
249	   (column-widths (foldl
250			   (lambda (max-widths row)
251			     (map max (map string-length row) max-widths))
252			   (list 0 0 0 0 0)
253			   (cons headers data))))
254      (define (print-row row)
255	(print (string-intersperse (map format-string row column-widths alignments) spacer)))
256      (print-row headers)
257      (print (make-string (+ (foldl + 0 column-widths)
258			     (* spacing (- (length alignments) 1)))
259			  #\-))
260      (for-each print-row data))))
261  
262(run (command-line-arguments))
263
264)