From d38f8225fbc3e6b294a8e355d49bd10448caec56 Mon Sep 17 00:00:00 2001 From: interp Date: Sat, 14 Sep 2002 16:35:34 +0000 Subject: [PATCH] small space profiling utilities --- scheme/httpd/surflets/profile.scm | 166 ++++++++++++++++++++++++++++++ 1 file changed, 166 insertions(+) create mode 100644 scheme/httpd/surflets/profile.scm diff --git a/scheme/httpd/surflets/profile.scm b/scheme/httpd/surflets/profile.scm new file mode 100644 index 0000000..b730da4 --- /dev/null +++ b/scheme/httpd/surflets/profile.scm @@ -0,0 +1,166 @@ +;; 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))))))) \ No newline at end of file