sunet/scheme/httpd/surflets/profile.scm

166 lines
5.4 KiB
Scheme
Raw Normal View History

2002-09-14 12:35:34 -04:00
;; Does profiling things, mainly space measurements
;; Copyright Andreas Bernauer, 2002
(define *debug* #f)
(define-record-type space-info :space-info
(make-space-info pair symbol vector closure location cell channel port
ratnum record continuation extended-number template
weak-pointer shared-binding unused-d-header1
unused-d-header2 string byte-vector double bignum total)
space-info?
(pair space-info-pair set-space-info-pair!)
(symbol space-info-symbol set-space-info-symbol!)
(vector space-info-vector set-space-info-vector!)
(closure space-info-closure set-space-info-closure!)
(location space-info-location set-space-info-location!)
(cell space-info-cell set-space-info-cell!)
(channel space-info-channel set-space-info-channel!)
(port space-info-port set-space-info-port!)
(ratnum space-info-ratnum set-space-info-ratnum!)
(record space-info-record set-space-info-record!)
(continuation space-info-continuation set-space-info-continuation!)
(extended-number space-info-extended-number set-space-info-extended-number!)
(template space-info-template set-space-info-template!)
(weak-pointer space-info-weak-pointer set-space-info-weak-pointer!)
(shared-binding space-info-shared-binding set-space-info-shared-binding!)
(unused-d-header1 space-info-unused-d-header1 set-space-info-unused-d-header1!)
(unused-d-header2 space-info-unused-d-header2 set-space-info-unused-d-header2!)
(string space-info-string set-space-info-string!)
(byte-vector space-info-byte-vector set-space-info-byte-vector!)
(double space-info-double set-space-info-double!)
(bignum space-info-bignum set-space-info-bignum!)
(total space-info-total set-space-info-total!))
(define pure-count first)
(define pure-bytes second)
(define impure-count third)
(define impure-bytes fourth)
(define total-count fifth)
(define total-bytes sixth)
(define *run-count* 0)
(define (set-run-count! x)
(set! *run-count* x))
(define (profile-space . maybe-file-name)
(let ((file-name
(:optional maybe-file-name
(create-temp-file "/var/tmp/profile"))))
(let ((out (open-output-file file-name open/append)))
(set! *run-count* (+ 1 *run-count*))
(format out "~%Run #~a~%" *run-count*)
(with-current-output-port* out space)
(close out))
file-name))
(define (profile-result file-name nth)
(let* ((in (open-input-file file-name))
(result (get-space-info in nth)))
(close in)
result))
(define (get-space-info in nth)
(if (eof-object? (skip-runs in nth))
'eof
(begin
(skip-headers in)
(let ((assoc-list (read-data in)))
(make-space-info
(get-record "pair" assoc-list)
(get-record "symbol" assoc-list)
(get-record "vector" assoc-list)
(get-record "closure" assoc-list)
(get-record "location" assoc-list)
(get-record "cell" assoc-list)
(get-record "channel" assoc-list)
(get-record "port" assoc-list)
(get-record "ratnum" assoc-list)
(get-record "record" assoc-list)
(get-record "continuation" assoc-list)
(get-record "extended-number" assoc-list)
(get-record "template" assoc-list)
(get-record "weak-pointer" assoc-list)
(get-record "shared-binding" assoc-list)
(get-record "unused-d-header1" assoc-list)
(get-record "unused-d-header2" assoc-list)
(get-record "string" assoc-list)
(get-record "byte-vector" assoc-list)
(get-record "double" assoc-list)
(get-record "bignum" assoc-list)
(get-record "total" assoc-list))))))
(define (get-record key assoc-list)
(let ((record (assoc key assoc-list)))
(if record
(cdr record)
(error "wrong data format - field missing" 'pair))))
(define (skip-headers in)
(read-line in)
(read-line in))
;; skip runs until write-out is reached
(define run-regexp (rx "Run #" (submatch (* digit))))
(define (skip-runs in nth)
(let loop ((line (read-line in)))
(if (eof-object? line)
line
(let ((match (regexp-search run-regexp line)))
(if (and match
(or (eq? 'first nth)
(= (string->number (match:substring match 1))
nth)))
#t
(loop (read-line in)))))))
(define (trim-string->number s)
(string->number (string-trim s)))
(define (read-data in)
(let loop ((count 0)
(line (read-line in))
(assoc-list '()))
; (format #t "line: ~a~%" line)
(if (< count 22)
(loop (+ 1 count)
(read-line in)
(cons
(cons (string-trim (substring/shared line 0 16)) ; name
(map trim-string->number
(list (substring/shared line 16 23) ;pure-count
(substring/shared line 23 30) ;pure-bytes
(substring/shared line 30 37) ;impure-count
(substring/shared line 37 44) ;impure-bytes
(substring/shared line 44 51) ;total count
(substring/shared line 51 59)))) ;total bytes
assoc-list))
assoc-list)))
(define (profile-results file-name)
(let ((in (open-input-file file-name)))
(let loop ((space-info (get-space-info in 'first))
(result '()))
(if (eq? 'eof space-info)
(reverse result)
(loop (get-space-info in 'first)
(cons space-info result))))))
(define (make-gnuplot-data output-file selector space-info-list)
(let ((out (open-output-file output-file)))
(display "# generated by profile.scm\n" out)
(let loop ((count 0)
(space-info-list space-info-list))
(if (null? space-info-list)
(close out)
(begin
(display count out)
(display " " out)
(display (selector (car space-info-list)) out)
(newline out)
(loop (+ 1 count)
(cdr space-info-list)))))))