small space profiling utilities

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)))))))