;; 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)
(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
(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))))
+\f
+;;;; 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
projects / mit-scheme.git / commitdiff