From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Tue, 9 Aug 2011 00:03:19 +0000 (-0700)
Subject: Wrote analyze-file, for logs with these performance timings.
X-Git-Tag: mit-scheme-pucked-9.2.12~651
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3480220aa43c404b6745f42a33aa1776173f7240;p=mit-scheme.git

Wrote analyze-file, for logs with these performance timings.
---

diff --git a/tests/gtk/test-gport-performance.scm b/tests/gtk/test-gport-performance.scm
index aece3027e..b0ce57cba 100644
--- a/tests/gtk/test-gport-performance.scm
+++ b/tests/gtk/test-gport-performance.scm
@@ -28,52 +28,54 @@ USA.
 ;; The number of trials for each test.
 (define repeats 7)
 
-(define (compare-gport-performance)
-  (test-port-performance)
-  (test-gport-performance))
+(define (test-port-performance)
+  (test-sys-port-performance)
+  (test-gnu-port-performance))
 
-(define test-port-performance
+(define test-sys-port-performance
   (let ((cwd (directory-pathname (current-load-pathname))))
     (named-lambda (test-port-performance)
       (with-working-directory-pathname cwd
 	(lambda ()
-	  (note "Expressions")
-	  (let ((data (test-io (make-read-exprs call-with-input-file)
+	  (let ((data (test-io "Expressions"
+			       (make-read-exprs call-with-input-file)
 			       (make-write-exprs call-with-tmp-output-file))))
 	    (note "    "(length data)" files,"
 		  " "(reduce-left + 0 (map length data))" exprs\n"))
-	  (note "Lines")
-	  (let ((data (test-io (make-read-lines call-with-input-file)
+	  (let ((data (test-io "Lines"
+			       (make-many-read-lines call-with-input-file)
 			       (make-write-lines call-with-tmp-output-file))))
 	    (note "    "(length data)" lines\n")))))))
 
-(define test-gport-performance
+(define test-gnu-port-performance
   (let ((cwd (directory-pathname (current-load-pathname))))
     (named-lambda (test-gport-performance)
       (with-working-directory-pathname cwd
 	(lambda ()
-	  (note "Expressions via GIO")
-	  (let ((data (test-io (make-read-exprs call-with-input-gfile)
+	  (let ((data (test-io "Expressions via GIO"
+			       (make-read-exprs call-with-input-gfile)
 			       (make-write-exprs call-with-tmp-output-gfile))))
 	    (note "    "(length data)" files,"
 		  " "(reduce-left + 0 (map length data))" exprs\n"))
-	  (note "Lines via GIO")
-	  (let ((data (test-io (make-read-lines call-with-input-gfile)
+	  (let ((data (test-io "Lines via GIO"
+			       (make-many-read-lines call-with-input-gfile)
 			       (make-write-lines call-with-tmp-output-gfile))))
 	    (note "    "(length data)" lines\n")))))))
 
-(define (test-io read write)
+(define (test-io what read write)
   (let ((data (read)))
-    (note "    reading")
+    (note "Start Test: Reading "what)
     (for-each (lambda (i)
 		(gc-flip)
 		(show-time read))
 	      (iota repeats))
-    (note "    writing")
+    (note "End Test: Reading "what)
+    (note "Start Test: Writing "what)
     (for-each (lambda (i)
 		(gc-flip)
 		(show-time (lambda () (write data))))
 	      (iota repeats))
+    (note "End Test: Writing "what)
     data))
 
 (define (make-read-exprs with-input-port)
@@ -99,19 +101,18 @@ USA.
      (lambda (port)
        (write data port)(newline port)))))
 
-(define (make-read-lines with-input-port)
-  (named-lambda (read-lines)
-    (append-map! (lambda (file)
-		   (with-input-port
-		    file
-		    (lambda (port)
-		      (let loop ()
-			(let ((obj (read-line port)))
-			  (if (eof-object? obj)
-			      '()
-			      (cons obj (loop))))))))
+(define (make-read-many-lines with-input-port)
+  (named-lambda (read-many-lines)
+    (append-map! (lambda (file) (with-input-port file read-lines))
 		 (scm-files "../../src/runtime/*.scm"))))
 
+(define (read-lines port)
+  (let loop ()
+    (let ((line (read-line port)))
+      (if (eof-object? line)
+	  '()
+	  (cons line (loop))))))
+
 (define (make-write-lines with-output-port)
   (named-lambda (write-lines lines)
     (with-output-port
@@ -159,4 +160,265 @@ USA.
 (define (note . objects)
   (write-notification-line
    (lambda (port)
-     (for-each (lambda (object) (display object port)) objects))))
\ No newline at end of file
+     (for-each (lambda (object) (display object port)) objects))))
+
+;;;; Statistics
+
+(define (analyze-file logfile)
+  ;; LOGFILE should have an even number of pages (separated by
+  ;; formfeeds) that look like this:
+  ;;
+  ;; commit 12345...
+  ;; ...
+  ;; ;Start Test: TESTNAME
+  ;; ...
+  ;; ;process time: 1234 (1234 RUN + 0 GC); real time: ...
+  ;; ...
+  ;; ;End Test: TESTNAME
+  ;; ...
+  ;; ;    181 files, 9084 exprs
+  ;; ...
+  ;; ;    75938 lines
+  ;;
+  ;; The process times for each TESTNAME are averaged and compared to
+  ;; a similar TESTNAME on the next page, and the results are
+  ;; displayed in a table.
+  ;;
+  ;; The file, expression and line totals on each page are also
+  ;; compared.  A warning is issued if they are not exactly equal.
+
+  (call-with-input-file logfile
+    (lambda (port)
+      (let loop ()
+	(let ((before-page (read-page port)))
+	  (if (null? before-page)
+	      unspecific
+	      (let ((after-page (read-page port)))
+		(if (null? after-page)
+		    (error "Odd pages."))
+		(let ((before-timings (page-timings before-page))
+		      (after-timings (page-timings after-page)))
+		  (display-comparison before-timings after-timings)
+		  (loop)))))))))
+
+(define (display-comparison before-timings after-timings)
+  (write-string "\f\n")
+  (let ((before-commitid (substring (car before-timings) 7 14))
+	(after-commitid (substring (car after-timings) 7 14)))
+    (run-synchronous-subprocess
+     "git" (list "log" "--oneline"
+		 (string before-commitid ".." after-commitid)))
+    (newline)
+    (display-table
+     '(left       right   right    right)
+     `(("Test" "Change" "After" "Before")
+       ,@(map (lambda (before after)
+		(if (and (timing? before)
+			 (timing? after)
+			 (string=? (car before) (car after)))
+		    (let ((before-proc (cadr before))
+			  (after-proc (cadr after)))
+		      (list (car before)
+			    (format-percent
+			     (and (not (zero? before-proc))
+				  (/ (- after-proc before-proc) before-proc)))
+			    (format-time after)
+			    (format-time before)))
+		    (error "format-comparison: unexpected:" before after)))
+	      (cdr before-timings) (cdr after-timings))))))
+
+(define (display-table alignments lists)
+  (let ((widths (column-widths lists)))
+    (if (not (= (length alignments) (length widths)))
+	(error "Too few/many alignments:" alignments widths))
+    (for-each
+      (lambda (row)
+	(for-each
+	  (lambda (cell width align)
+	    (write-string "  ")
+	    (write-string
+	     (case align
+	       ((LEFT) (string-pad-right cell width))
+	       ((RIGHT) (string-pad-left cell width))
+	       (else (error "Bogus alignment:" align)))))
+	  row
+	  widths
+	  alignments)
+	(newline))
+      lists)))
+
+(define (column-widths lists)
+  (map (lambda (column-index)
+	 (reduce max 0
+		 (map (lambda (row)
+			(string-length (list-ref row column-index)))
+		      lists)))
+       (iota (length (car lists)))))
+
+(define (format-time timing)
+  (number->string (round (cadr timing))))
+
+(define (format-percent ratio)
+  (string-append
+   (if ratio
+       (let ((percent (round (* ratio 100))))
+	 (if (positive? percent)
+	     (string-append "+" (number->string percent))
+	     (number->string percent)))
+       "+-")
+   "%"))
+
+(define (timing? obj)
+  (and (let ((l (list?->length obj)))
+	 (and l (= 4 l)))
+       (string? (car obj))
+       (real? (cadr obj))
+       (real? (caddr obj))
+       (real? (cadddr obj))))
+
+(define (page-timings lines)
+
+    (define (line)
+      (car lines))
+
+    (define (next)
+      (set! lines (cdr lines)))
+
+    (define (prefix? prefix)
+      (string-prefix? prefix (line)))
+
+    (define (prefix-next prefix)
+      (if (string-prefix? prefix (line))
+	  (next)
+	  (error "Invalid prefix:" prefix (line))))
+
+    (define (prefix-find prefix)
+      (let loop ()
+	(cond ((null? lines)
+	       (error "Could not find a line with prefix:" prefix))
+	      ((prefix? prefix) #t)
+	      (else
+	       (next)
+	       (loop)))))
+
+    (define (prefix-find-next prefix)
+      (prefix-find prefix)
+      (next))
+
+    (define (parse-timing)
+      (let* ((digits "\\([0-9]+\\)")
+	     (pattern (string-append
+";process time: "digits" ("digits" RUN \\+ "digits" GC); real time: "))
+	     (line (line))
+	     (regs (re-string-match pattern line)))
+	(if regs
+	    (list (string->number (re-match-extract line regs 1))
+		  (string->number (re-match-extract line regs 2))
+		  (string->number (re-match-extract line regs 3)))
+	    (error "Bogus timing line:" line))))
+
+    (define (parse-timings)
+      (let loop ()
+	(cond ((prefix? ";process time: ")
+	       (let ((timing (parse-timing)))
+		 (next)
+		 (cons timing (loop))))
+	      ((prefix? ";End Test:")
+	       '())
+	      (else
+	       (next)
+	       (loop)))))
+
+    (define (parse-test-timings)
+      (if (not (prefix? ";Start Test: "))
+	  (error "Not at Start Test:" (line)))
+      (let* ((test-name
+	      (let* ((line (line))
+		     (regs (re-string-match ";Start Test: \\(.*\\)" line)))
+		(if regs
+		    (re-match-extract line regs 1)
+		    (error "No Start Test:" line))))
+	     (timings (parse-timings)))
+	(if (not (string=? (line) (string ";End Test: "test-name)))
+	    (error "End of wrong test:" test-name (line)))
+	(next)
+	(cons test-name timings)))
+
+    (define (parse-r/w-timings)
+      (if (not (prefix? ";Start Test: Reading"))
+	  (error "Not at ;Start Test:" (line)))
+      (let ((read-timings (parse-test-timings)))
+	(let ((write-timings (parse-test-timings)))
+	  (list read-timings write-timings))))
+
+    (define (parse-file.expr-totals)
+      (let* ((line (line))
+	     (regs
+	      (re-string-match
+	       ";    \\([0-9]+\\) files, \\([0-9]+\\) exprs" line)))
+	(if regs
+	    (begin
+	      (next)
+	      (cons (string->number (re-match-extract line regs 1))
+		    (string->number (re-match-extract line regs 2))))
+	    (error "Bogus file.expr totals:" line))))
+
+    (define (parse-line-total)
+      (let* ((line (line))
+	     (regs
+	      (re-string-match
+	       ";    \\([0-9]+\\) lines" line)))
+	(if regs
+	    (begin
+	      (next)
+	      (string->number (re-match-extract line regs 1)))
+	    (error "Bogus file.expr totals:" line))))
+
+    (prefix-find "commit ")
+    (let ((commit (line)))
+      (prefix-find ";Start Test:")
+      (let* ((sys-expr-timings (parse-r/w-timings))
+	     (sys-file.expr-totals (parse-file.expr-totals)))
+	(prefix-find ";Start Test:")
+	(let* ((sys-line-timings (parse-r/w-timings))
+	       (sys-line-total (parse-line-total)))
+	  (prefix-find ";Start Test:")
+	  (let* ((gio-expr-timings (parse-r/w-timings))
+		 (gio-file.expr-totals (parse-file.expr-totals)))
+	    (prefix-find ";Start Test:")
+	    (let* ((gio-line-timings (parse-r/w-timings))
+		   (gio-line-total (parse-line-total)))
+	      (if (not (= (car sys-file.expr-totals)
+			  (car gio-file.expr-totals)))
+		  (warn "File totals not in agreement."))
+	      (if (not (= (cdr sys-file.expr-totals)
+			  (cdr gio-file.expr-totals)))
+		  (warn "Expression totals not in agreement."))
+	      (if (not (= sys-line-total gio-line-total))
+		  (warn "Line totals not in agreement."))
+	      (cons commit
+		    (map ave-timings
+			 (append sys-expr-timings sys-line-timings
+				 gio-expr-timings gio-line-timings)))))))))
+
+(define (ave-timings timings)
+  (let* ((data (cdr timings))
+	 (count (length data)))
+    (if (< count 3)
+	(begin
+	  (warn "Too few data:" timings)
+	  0)
+	(list
+	 (car timings)
+	 (/ (reduce + 0 (map car data)) count)
+	 (/ (reduce + 0 (map cadr data)) count)
+	 (/ (reduce + 0 (map caddr data)) count)))))
+
+(define (read-page port)
+  (let loop ()
+    (let ((line (read-line port)))
+      (cond ((eof-object? line) '())
+	    ((string=? line "\f") '())
+	    (else (cons line (loop)))))))
+
+(define %trace display*)
\ No newline at end of file