- Allowing non-UTF8 output to be displayed in some way.
** http://drdr.plt-scheme.org/18034/collects/tests/mzscheme/benchmarks/shootout/mandelbrot-generic.ss - Adding Robby's new graphing system - Catching file difference errors - Handling new files differently svn: r18324
This commit is contained in:
Jay McCarthy
parent
2ce01fd5ce
commit
7a294ffd7e
|
|
@ -162,7 +162,9 @@
|
||||||
(define any-stderr? (ormap stderr? output-log))
|
(define any-stderr? (ormap stderr? output-log))
|
||||||
(define changed?
|
(define changed?
|
||||||
(if (previous-rev)
|
(if (previous-rev)
|
||||||
(with-handlers ([exn:fail? (lambda (x) #t)])
|
(with-handlers ([exn:fail?
|
||||||
|
; This #f means that new files are NOT considered changed
|
||||||
|
(lambda (x) #f)])
|
||||||
(define prev-log-pth ((rebase-path (revision-log-dir (current-rev)) (revision-log-dir (previous-rev))) log-pth))
|
(define prev-log-pth ((rebase-path (revision-log-dir (current-rev)) (revision-log-dir (previous-rev))) log-pth))
|
||||||
(log-different? output-log (status-output-log (read-cache prev-log-pth))))
|
(log-different? output-log (status-output-log (read-cache prev-log-pth))))
|
||||||
#f))
|
#f))
|
||||||
|
|
|
||||||
2
collects/meta/drdr/copy.sh
Executable file
2
collects/meta/drdr/copy.sh
Executable file
|
|
@ -0,0 +1,2 @@
|
||||||
|
#!/bin/bash
|
||||||
|
rsync -avz . plt-drdr:/opt/svn/drdr/ --exclude=.svn
|
||||||
|
|
@ -21,9 +21,9 @@
|
||||||
|
|
||||||
(for ([d (in-list (render-log-difference l1 l2))])
|
(for ([d (in-list (render-log-difference l1 l2))])
|
||||||
(match d
|
(match d
|
||||||
[(struct difference (e))
|
[(struct difference (e1 e2))
|
||||||
(printf "! ")
|
(printf "! ")
|
||||||
(event-print e)]
|
(event-print e1)]
|
||||||
[(struct same-itude (e))
|
[(struct same-itude (e))
|
||||||
(printf " ")
|
(printf " ")
|
||||||
(event-print e)])))
|
(event-print e)])))
|
||||||
|
|
|
||||||
|
|
@ -75,6 +75,10 @@
|
||||||
|
|
||||||
(define (path-timing-png p)
|
(define (path-timing-png p)
|
||||||
(path-add-suffix (path-timing-log p) #".png"))
|
(path-add-suffix (path-timing-log p) #".png"))
|
||||||
|
(define (path-timing-html p)
|
||||||
|
(path-add-suffix (path-timing-log p) #".html"))
|
||||||
|
(define (path-timing-png-prefix p)
|
||||||
|
(path-timing-log p))
|
||||||
|
|
||||||
(provide/contract
|
(provide/contract
|
||||||
[number-of-cpus (parameter/c exact-nonnegative-integer?)]
|
[number-of-cpus (parameter/c exact-nonnegative-integer?)]
|
||||||
|
|
@ -91,6 +95,8 @@
|
||||||
[plt-repository (parameter/c string?)]
|
[plt-repository (parameter/c string?)]
|
||||||
[path-timing-log (path-string? . -> . path?)]
|
[path-timing-log (path-string? . -> . path?)]
|
||||||
[path-timing-png (path-string? . -> . path?)]
|
[path-timing-png (path-string? . -> . path?)]
|
||||||
|
[path-timing-png-prefix (path-string? . -> . path?)]
|
||||||
|
[path-timing-html (path-string? . -> . path?)]
|
||||||
[future-record-path (exact-nonnegative-integer? . -> . path?)]
|
[future-record-path (exact-nonnegative-integer? . -> . path?)]
|
||||||
[current-make-timeout-seconds (parameter/c exact-nonnegative-integer?)]
|
[current-make-timeout-seconds (parameter/c exact-nonnegative-integer?)]
|
||||||
[current-make-install-timeout-seconds (parameter/c exact-nonnegative-integer?)]
|
[current-make-install-timeout-seconds (parameter/c exact-nonnegative-integer?)]
|
||||||
|
|
|
||||||
|
|
@ -1,320 +0,0 @@
|
||||||
#lang scheme/gui
|
|
||||||
|
|
||||||
;; a raw-line is
|
|
||||||
;; (list number number (listof (list number number number)))
|
|
||||||
|
|
||||||
;;; ========================================
|
|
||||||
|
|
||||||
;; a graph is
|
|
||||||
;; (make-graph revision-number revision-number (listof line))
|
|
||||||
(define-struct graph (start end lines) #:transparent)
|
|
||||||
|
|
||||||
;; a line is
|
|
||||||
;; (make-line number number (listof number) string symbol)
|
|
||||||
;; min, max: absolute values from the data
|
|
||||||
;; points: numbers between [0,1] indicating the percentage
|
|
||||||
;; of the time of the slowest run
|
|
||||||
;; style = (or/c 'overall 'cpu 'real 'gc)
|
|
||||||
(define-struct line (min max points color style) #:transparent)
|
|
||||||
|
|
||||||
(define graph-height 200)
|
|
||||||
(define graphs-width 1000)
|
|
||||||
(define graph-gap 4)
|
|
||||||
(define frame? #f)
|
|
||||||
|
|
||||||
(define-values (input-file output-file)
|
|
||||||
(command-line
|
|
||||||
#:once-each
|
|
||||||
[("-w" "--width")
|
|
||||||
width
|
|
||||||
"width of the image, defaults to 1000"
|
|
||||||
(set! graphs-width width)]
|
|
||||||
[("-e" "--height")
|
|
||||||
height
|
|
||||||
"height of the image, defaults to 200"
|
|
||||||
(set! graph-height height)]
|
|
||||||
[("-f" "--frame")
|
|
||||||
"open a window containing the image, instead of writing a file"
|
|
||||||
(set! frame? #t)]
|
|
||||||
#:args (input-file output-file) (values input-file output-file)))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;
|
|
||||||
;
|
|
||||||
;
|
|
||||||
;
|
|
||||||
; ;;
|
|
||||||
; ;
|
|
||||||
; ;;;;; ;;;;; ;;;; ;;;; ;; ;;;;; ;;;;;
|
|
||||||
; ;;;;; ;; ;; ;;; ;; ;; ;; ;;;;; ;;;;;
|
|
||||||
; ;; ;; ;;;; ;; ;;;; ;; ;; ;;;;;; ;;
|
|
||||||
; ;; ;; ;;;;;; ;; ;;;; ;; ;; ;;;;;; ;;
|
|
||||||
; ;;;;;;;;; ;;; ;; ;;; ;; ;; ;; ;;; ;;;;;
|
|
||||||
; ;;;;; ;;;;;; ;; ;;;; ;; ;; ;;; ;;;;;
|
|
||||||
; ;; ;; ;;
|
|
||||||
; ;; ;;;;;
|
|
||||||
;
|
|
||||||
;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;; this build ex2.ss out of ex.ss
|
|
||||||
;; adjust : raw-line -> raw-line
|
|
||||||
(define adjust
|
|
||||||
(let ([seen-time #f])
|
|
||||||
(lambda (l)
|
|
||||||
(match l
|
|
||||||
[`(,rev ,time ,times)
|
|
||||||
(cond
|
|
||||||
[(empty? times)
|
|
||||||
l]
|
|
||||||
[(not seen-time)
|
|
||||||
(set! seen-time 1)
|
|
||||||
l]
|
|
||||||
[(< seen-time 30)
|
|
||||||
(set! seen-time (+ seen-time 1))
|
|
||||||
l]
|
|
||||||
[else
|
|
||||||
(list (list-ref l 0)
|
|
||||||
(list-ref l 1)
|
|
||||||
(list (car (list-ref l 2))
|
|
||||||
(map (λ (x) (* x 10)) (car (list-ref l 2)))))])]))))
|
|
||||||
|
|
||||||
;; fetch-data : string -> (listof raw-line)
|
|
||||||
(define (fetch-data file)
|
|
||||||
(call-with-input-file file
|
|
||||||
(λ (port)
|
|
||||||
(let loop ()
|
|
||||||
(let ([l (read port)])
|
|
||||||
(if (eof-object? l)
|
|
||||||
'()
|
|
||||||
(cons l #; (adjust l) ;; to build ex2.ss
|
|
||||||
(loop))))))))
|
|
||||||
|
|
||||||
;; build-graphs : (listof raw-line) -> (listof graph)
|
|
||||||
(define (build-graphs data)
|
|
||||||
(let loop ([data data]
|
|
||||||
[working-graph '()])
|
|
||||||
(cond
|
|
||||||
[(null? data)
|
|
||||||
(if (null? working-graph)
|
|
||||||
'()
|
|
||||||
(list (finalize-graph (reverse working-graph))))]
|
|
||||||
[else
|
|
||||||
(let ([this (car data)])
|
|
||||||
(cond
|
|
||||||
[(matching-line? this working-graph)
|
|
||||||
(loop (cdr data)
|
|
||||||
(cons this working-graph))]
|
|
||||||
[else
|
|
||||||
(cons (finalize-graph (reverse working-graph))
|
|
||||||
(loop data '()))]))])))
|
|
||||||
|
|
||||||
;; match-line? : raw-line (listof raw-line) -> boolean
|
|
||||||
;; #t if the line fits into this graph
|
|
||||||
(define (matching-line? line working-graph)
|
|
||||||
(or (null? working-graph)
|
|
||||||
(match line
|
|
||||||
[`(,rev ,time ,line-seqs)
|
|
||||||
(match (car working-graph)
|
|
||||||
[`(,rev ,time ,working-line-seq)
|
|
||||||
(= (length line-seqs)
|
|
||||||
(length working-line-seq))])])))
|
|
||||||
|
|
||||||
;; finalize-graph : (non-empty-listof raw-line) -> graph
|
|
||||||
(define (finalize-graph working-graph)
|
|
||||||
(restart-colors)
|
|
||||||
(make-graph
|
|
||||||
(car (car working-graph))
|
|
||||||
(car (last working-graph))
|
|
||||||
(cons
|
|
||||||
(build-line 'overall (map second working-graph) "black")
|
|
||||||
(apply
|
|
||||||
append
|
|
||||||
(let ([cpu-real-gcss (map third working-graph)])
|
|
||||||
(for/list ([ele (car cpu-real-gcss)]
|
|
||||||
[i (in-naturals)])
|
|
||||||
(let ([color (next-color)])
|
|
||||||
(list (build-line 'cpu
|
|
||||||
(map (λ (x) (first (list-ref x i)))
|
|
||||||
cpu-real-gcss)
|
|
||||||
color)
|
|
||||||
(build-line 'real
|
|
||||||
(map (λ (x) (second (list-ref x i)))
|
|
||||||
cpu-real-gcss)
|
|
||||||
color)
|
|
||||||
(build-line 'gc
|
|
||||||
(map (λ (x) (third (list-ref x i)))
|
|
||||||
cpu-real-gcss)
|
|
||||||
color)))))))))
|
|
||||||
|
|
||||||
(define (average l)
|
|
||||||
(/ (apply + l)
|
|
||||||
(length l)))
|
|
||||||
|
|
||||||
(define IGNORE-COEFFICIENT 10)
|
|
||||||
(define (build-line which real-points color)
|
|
||||||
(if (empty? real-points)
|
|
||||||
(make-line 0 1 empty color which)
|
|
||||||
(local [(define average-v (average real-points))
|
|
||||||
(define points
|
|
||||||
(filter-not (λ (x) (> x (* IGNORE-COEFFICIENT average-v)))
|
|
||||||
real-points))
|
|
||||||
(define min-v (apply min points))
|
|
||||||
(define max-v (apply max points))]
|
|
||||||
(make-line min-v max-v (map (λ (x) (/ x max-v)) real-points) color which))))
|
|
||||||
|
|
||||||
(define-values (next-color restart-colors)
|
|
||||||
(let ([colors '("darkred"
|
|
||||||
"mediumvioletred"
|
|
||||||
"brown"
|
|
||||||
"olive"
|
|
||||||
"darkgreen"
|
|
||||||
"midnightblue")]
|
|
||||||
[i 0])
|
|
||||||
(values (λ ()
|
|
||||||
(begin0
|
|
||||||
(list-ref colors i)
|
|
||||||
(set! i (modulo (+ i 1) (length colors)))))
|
|
||||||
(λ ()
|
|
||||||
(set! i 0)))))
|
|
||||||
|
|
||||||
|
|
||||||
;
|
|
||||||
;
|
|
||||||
;
|
|
||||||
;
|
|
||||||
; ;; ;;
|
|
||||||
; ;; ;
|
|
||||||
; ;;;;; ;;;; ;;;;; ;; ;; ;; ;; ;;;;; ;;;;;
|
|
||||||
; ;;;;; ;;; ;; ;; ; ;; ;; ;; ;;;;; ;;;;;
|
|
||||||
; ;;; ;; ;; ;;;; ;;;;;;;; ;; ;; ;;;;;; ;;
|
|
||||||
; ;;; ;; ;; ;;;;;; ;;;;;;;; ;; ;; ;;;;;; ;;
|
|
||||||
; ;;;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;;;;;
|
|
||||||
; ;;;;; ;; ;;;;;; ;; ;; ;; ;; ;;; ;;;;;
|
|
||||||
; ;; ;;
|
|
||||||
; ;;;;;
|
|
||||||
;
|
|
||||||
; ;;;;;;;;
|
|
||||||
|
|
||||||
|
|
||||||
(define (draw-graphs dc graphs)
|
|
||||||
(let ([tot-points (apply + (map graph-point-count graphs))]
|
|
||||||
[tot-space (- graphs-width (* graph-gap (- (length graphs) 1)))])
|
|
||||||
(let loop ([sx 0]
|
|
||||||
[graphs graphs])
|
|
||||||
(unless (null? graphs)
|
|
||||||
(let* ([graph (car graphs)]
|
|
||||||
[points (graph-point-count graph)]
|
|
||||||
[this-w (* (/ points tot-points) tot-space)]
|
|
||||||
[next-sx (+ sx this-w graph-gap)])
|
|
||||||
(draw-graph dc graph sx this-w)
|
|
||||||
(unless (null? (cdr graphs))
|
|
||||||
(send dc set-pen "black" 1 'transparent)
|
|
||||||
(send dc set-brush "gray" 'solid)
|
|
||||||
(send dc set-alpha 1)
|
|
||||||
(send dc draw-rectangle
|
|
||||||
(- next-sx graph-gap)
|
|
||||||
0
|
|
||||||
graph-gap
|
|
||||||
graph-height))
|
|
||||||
(loop next-sx
|
|
||||||
(cdr graphs)))))))
|
|
||||||
|
|
||||||
(define (graph-point-count graph)
|
|
||||||
(length (line-points (car (graph-lines graph)))))
|
|
||||||
|
|
||||||
(define (draw-graph dc graph sx w)
|
|
||||||
(draw-legend dc sx w)
|
|
||||||
(for ([line (in-list (graph-lines graph))])
|
|
||||||
(let* ([num-points (length (line-points line))]
|
|
||||||
[i->x (λ (i) (+ sx (* (/ i num-points) w)))])
|
|
||||||
(send dc set-pen (line->pen line))
|
|
||||||
(send dc set-alpha (line->alpha line))
|
|
||||||
(for ([start (in-list (line-points line))]
|
|
||||||
[end (in-list (cdr (line-points line)))]
|
|
||||||
[i (in-naturals)])
|
|
||||||
(let* ([x-start (i->x i)]
|
|
||||||
[x-end (i->x (+ i 1))]
|
|
||||||
[y-start (* (- 1 start) graph-height)]
|
|
||||||
[y-end (* (- 1 end) graph-height)])
|
|
||||||
(send dc draw-line
|
|
||||||
x-start y-start
|
|
||||||
x-end y-end))))))
|
|
||||||
|
|
||||||
(define (draw-legend dc sx w)
|
|
||||||
(send dc set-pen "gray" 3 'solid)
|
|
||||||
(send dc set-alpha 1)
|
|
||||||
(let ([hline (λ (p)
|
|
||||||
(send dc draw-line
|
|
||||||
sx
|
|
||||||
(* p graph-height)
|
|
||||||
(+ sx w)
|
|
||||||
(* p graph-height)))])
|
|
||||||
(hline 0)
|
|
||||||
(hline 1/4)
|
|
||||||
(hline 1/2)
|
|
||||||
(hline 3/4)
|
|
||||||
(hline 1)))
|
|
||||||
|
|
||||||
(define (line->alpha line)
|
|
||||||
(case (line-style line)
|
|
||||||
[(overall) 1]
|
|
||||||
[(cpu) 1/2]
|
|
||||||
[(gc) 1/4]
|
|
||||||
[(real) 1]))
|
|
||||||
|
|
||||||
(define (line->pen line)
|
|
||||||
(send the-pen-list find-or-create-pen
|
|
||||||
(line-color line)
|
|
||||||
1
|
|
||||||
'solid))
|
|
||||||
|
|
||||||
(define (draw fgs dc)
|
|
||||||
(send dc set-smoothing 'aligned)
|
|
||||||
(draw-graphs dc fgs))
|
|
||||||
|
|
||||||
|
|
||||||
;
|
|
||||||
;
|
|
||||||
;
|
|
||||||
;
|
|
||||||
; ;;
|
|
||||||
; ;
|
|
||||||
; ;;;;; ;; ;;;;; ;; ;;;;;
|
|
||||||
; ;;;;;;;;; ;; ;; ;; ;;;;;
|
|
||||||
; ;; ;; ;; ;;;; ;; ;; ;;;
|
|
||||||
; ;; ;; ;; ;;;;;; ;; ;; ;;;
|
|
||||||
; ;; ;; ;; ;;; ;;; ;; ;; ;;;
|
|
||||||
; ;; ;; ;; ;;;;;; ;; ;; ;;;
|
|
||||||
;
|
|
||||||
;
|
|
||||||
;
|
|
||||||
;
|
|
||||||
|
|
||||||
|
|
||||||
(define (show fgs)
|
|
||||||
(define f (new frame% [label ""] [alignment '(center center)]))
|
|
||||||
(define c (new canvas%
|
|
||||||
[parent f]
|
|
||||||
[min-width graphs-width]
|
|
||||||
[min-height graph-height]
|
|
||||||
[stretchable-height #f]
|
|
||||||
[stretchable-width #f]
|
|
||||||
[paint-callback (λ (c dc) (draw fgs dc))]))
|
|
||||||
(send f show #t))
|
|
||||||
|
|
||||||
(define (save fgs)
|
|
||||||
(let* ([bm (make-object bitmap% graphs-width graph-height)]
|
|
||||||
[bdc (make-object bitmap-dc% bm)])
|
|
||||||
(send bdc clear)
|
|
||||||
(draw fgs bdc)
|
|
||||||
(send bm save-file output-file 'png)
|
|
||||||
(void)))
|
|
||||||
|
|
||||||
(let ([fgs (build-graphs (fetch-data input-file))])
|
|
||||||
(if frame?
|
|
||||||
(show fgs)
|
|
||||||
(save fgs)))
|
|
||||||
22
collects/meta/drdr/graphs/README
Normal file
22
collects/meta/drdr/graphs/README
Normal file
|
|
@ -0,0 +1,22 @@
|
||||||
|
- build the global .png files with a recent svn build:
|
||||||
|
|
||||||
|
mred-text mk-img.ss
|
||||||
|
|
||||||
|
This will dump some png files in the current directory. Put them in
|
||||||
|
some global place on the server
|
||||||
|
|
||||||
|
- to build a script for a particular page, do this:
|
||||||
|
|
||||||
|
mred-text build-graph.ss -l http://drdr.plt-scheme.org/~a/collects/path/to/file.scm \
|
||||||
|
--image-loc /static/data/graph-images/ \
|
||||||
|
file_scm.timing \
|
||||||
|
file_scm_png_file_prefix \
|
||||||
|
output.html
|
||||||
|
|
||||||
|
The -l flag is optional, without it clicking on the images won't go
|
||||||
|
anywhere; with it, clicking will go to the corresponding revision.
|
||||||
|
The --image-loc flag gives a url path to the directory containing
|
||||||
|
the images from the mk-img.ss setp. The other three args are the
|
||||||
|
timing data file, a prefix for the png files that generated for the
|
||||||
|
graphs, and the output html (which is a <div> ... </div>).
|
||||||
|
|
||||||
686
collects/meta/drdr/graphs/build-graph.ss
Normal file
686
collects/meta/drdr/graphs/build-graph.ss
Normal file
|
|
@ -0,0 +1,686 @@
|
||||||
|
#lang scheme/gui
|
||||||
|
(require xml)
|
||||||
|
|
||||||
|
(require "constants.ss")
|
||||||
|
|
||||||
|
;; example data:
|
||||||
|
;; http://drdr.plt-scheme.org/data/collects/tests/mzscheme/benchmarks/common/earley_ss.timing
|
||||||
|
|
||||||
|
;;; ========================================
|
||||||
|
|
||||||
|
;; a raw-line is
|
||||||
|
;; (list number number (listof (list number number number)))
|
||||||
|
|
||||||
|
;; a graph is
|
||||||
|
;; (make-graph revision-number revision-number (listof line))
|
||||||
|
(define-struct graph (start end lines) #:transparent)
|
||||||
|
|
||||||
|
;; a line is
|
||||||
|
;; (make-line number number (listof point) string symbol)
|
||||||
|
;; style = (or/c 'overall 'cpu 'real 'gc)
|
||||||
|
(define-struct line (min max points color style) #:transparent)
|
||||||
|
|
||||||
|
;; value : number between [0,1] indicating the percentage
|
||||||
|
;; of the time of the slowest run
|
||||||
|
;; revision : revision number
|
||||||
|
(define-struct point (value revision) #:transparent)
|
||||||
|
|
||||||
|
|
||||||
|
;; revision : nat
|
||||||
|
;; x-pixel : nat
|
||||||
|
(define-struct coordinate (revision x-pixel) #:transparent)
|
||||||
|
|
||||||
|
(define graph-gap 4)
|
||||||
|
(define max-revisions-per-graph (make-parameter 400))
|
||||||
|
|
||||||
|
(define max-graphs-per-image (floor (/ graphs-width (+ graph-gap 4))))
|
||||||
|
(define max-samples-per-image (floor (/ graphs-width 3)))
|
||||||
|
|
||||||
|
(define link-format-string #f)
|
||||||
|
|
||||||
|
(define image-loc "./")
|
||||||
|
|
||||||
|
(define full? #f)
|
||||||
|
|
||||||
|
(define-values (input-file image-filename-prefix image-url-prefix html-file)
|
||||||
|
(command-line
|
||||||
|
#|
|
||||||
|
#:argv
|
||||||
|
#("-l"
|
||||||
|
"http://drdr.plt-scheme.org/~a/collects/tests/mzscheme/benchmarks/mz/expand-class.scm"
|
||||||
|
"expand-class_scm.timing" "out" "out.html" )
|
||||||
|
|#
|
||||||
|
#:once-each
|
||||||
|
[("-f" "--full")
|
||||||
|
"indicates that a complete html file should be produced; otherwise, a single div is all you get"
|
||||||
|
(set! full? #t)]
|
||||||
|
[("-l" "--link")
|
||||||
|
link-format
|
||||||
|
"specifies where revisions link to; expected to be a url with a ~a in the middle"
|
||||||
|
(set! link-format-string link-format)]
|
||||||
|
[("--image-loc")
|
||||||
|
url-path
|
||||||
|
"specify the path to the image files for html generation (not just to the dir; to the file itself)"
|
||||||
|
(unless (regexp-match #rx"/$" url-path)
|
||||||
|
(error 'build-graph.ss "expected the image-loc to end with a /, got ~a" url-path))
|
||||||
|
(set! image-loc url-path)]
|
||||||
|
#:args (input-file image-filename-prefix image-url-prefix html-file)
|
||||||
|
(values input-file image-filename-prefix image-url-prefix html-file)))
|
||||||
|
|
||||||
|
(define dot-image-file (string-append image-loc "dot.png"))
|
||||||
|
(define before-image-file (string-append image-loc "before.png"))
|
||||||
|
(define after-image-file (string-append image-loc "after.png"))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
; ;;
|
||||||
|
; ;
|
||||||
|
; ;;;;; ;;;;; ;;;; ;;;; ;; ;;;;; ;;;;;
|
||||||
|
; ;;;;; ;; ;; ;;; ;; ;; ;; ;;;;; ;;;;;
|
||||||
|
; ;; ;; ;;;; ;; ;;;; ;; ;; ;;;;;; ;;
|
||||||
|
; ;; ;; ;;;;;; ;; ;;;; ;; ;; ;;;;;; ;;
|
||||||
|
; ;;;;;;;;; ;;; ;; ;;; ;; ;; ;; ;;; ;;;;;
|
||||||
|
; ;;;;; ;;;;;; ;; ;;;; ;; ;; ;;; ;;;;;
|
||||||
|
; ;; ;; ;;
|
||||||
|
; ;; ;;;;;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
|
||||||
|
;; orig-data : hash[revision-number -o> sexp]
|
||||||
|
;; the original lines from the files, indexed by revision number
|
||||||
|
(define orig-data (make-hash))
|
||||||
|
|
||||||
|
(define (revision->duration revision)
|
||||||
|
(let ([info (hash-ref orig-data revision)])
|
||||||
|
(floor (inexact->exact (list-ref info 1)))))
|
||||||
|
|
||||||
|
(define (revision->timings-array revision)
|
||||||
|
(let ([info (hash-ref orig-data revision)])
|
||||||
|
(apply
|
||||||
|
string-append
|
||||||
|
(append (list "[")
|
||||||
|
(add-between (map (λ (line)
|
||||||
|
(format "'cpu time: ~a real time: ~a gc time: ~a'"
|
||||||
|
(list-ref line 0)
|
||||||
|
(list-ref line 1)
|
||||||
|
(list-ref line 2)))
|
||||||
|
(list-ref info 2))
|
||||||
|
",")
|
||||||
|
(list "]")))))
|
||||||
|
|
||||||
|
;; this build ex2.ss out of ex.ss
|
||||||
|
;; adjust : raw-line -> raw-line
|
||||||
|
(define adjust
|
||||||
|
(let ([seen-time #f])
|
||||||
|
(lambda (l)
|
||||||
|
(match l
|
||||||
|
[`(,rev ,time ,times)
|
||||||
|
(cond
|
||||||
|
[(empty? times)
|
||||||
|
l]
|
||||||
|
[(not seen-time)
|
||||||
|
(set! seen-time 1)
|
||||||
|
l]
|
||||||
|
[(< seen-time 30)
|
||||||
|
(set! seen-time (+ seen-time 1))
|
||||||
|
l]
|
||||||
|
[else
|
||||||
|
(list (list-ref l 0)
|
||||||
|
(list-ref l 1)
|
||||||
|
(list (car (list-ref l 2))
|
||||||
|
(map (λ (x) (* x 10)) (car (list-ref l 2)))))])]))))
|
||||||
|
|
||||||
|
;; fetch-data : string -> (listof raw-line)[uniq revision-numbers]
|
||||||
|
(define (fetch-data file)
|
||||||
|
(call-with-input-file file
|
||||||
|
(λ (port)
|
||||||
|
(let loop ()
|
||||||
|
(let ([l (read port)])
|
||||||
|
(cond
|
||||||
|
[(eof-object? l) '()]
|
||||||
|
[(hash-ref orig-data (car l) #f)
|
||||||
|
;; skip duplicate revisions
|
||||||
|
(loop)]
|
||||||
|
[else
|
||||||
|
(hash-set! orig-data (car l) l)
|
||||||
|
(cons l (loop))]))))))
|
||||||
|
|
||||||
|
;; build-graphss : (listof raw-line) -> (listof (listof graph))
|
||||||
|
(define (build-graphss data)
|
||||||
|
(let ([large-graphs
|
||||||
|
(filter
|
||||||
|
(λ (x) (<= 2 (length (line-points (car (graph-lines x))))))
|
||||||
|
(build-large-graphs data))])
|
||||||
|
(reverse
|
||||||
|
(let loop ([graphs (reverse large-graphs)])
|
||||||
|
(let-values ([(first rest) (split-out-graph graphs)])
|
||||||
|
(cond
|
||||||
|
[(null? rest)
|
||||||
|
(list first)]
|
||||||
|
[else
|
||||||
|
(cons first (loop rest))]))))))
|
||||||
|
|
||||||
|
;; split-out-graphs : (listof graph) -> (values (listof graph) (listof graph))
|
||||||
|
;; first result is a set of graphs to go into a single image
|
||||||
|
;; limits the number of graphs and the number of total samples
|
||||||
|
;; expects the graphs to be in order from the right to the left
|
||||||
|
;; returns the first result in the opposite order and the second result in the same order.
|
||||||
|
(define (split-out-graph graphs)
|
||||||
|
(let loop ([graphs graphs]
|
||||||
|
[sample-count 0]
|
||||||
|
[graph-count 0]
|
||||||
|
[current '()])
|
||||||
|
(cond
|
||||||
|
[(null? graphs)
|
||||||
|
(values current graphs)]
|
||||||
|
[(< max-graphs-per-image graph-count)
|
||||||
|
(values current graphs)]
|
||||||
|
[else
|
||||||
|
(let* ([graph (car graphs)]
|
||||||
|
[this-graph-samples (graph-sample-count graph)])
|
||||||
|
(cond
|
||||||
|
[(<= (+ sample-count this-graph-samples) max-samples-per-image)
|
||||||
|
;; if this graph fits, take it.
|
||||||
|
(loop (cdr graphs)
|
||||||
|
(+ sample-count this-graph-samples)
|
||||||
|
(+ graph-count 1)
|
||||||
|
(cons graph current))]
|
||||||
|
[(<= sample-count (/ max-samples-per-image 2))
|
||||||
|
;; if the graph doesn't fit, and we have less than 1/2 of the samples that fill
|
||||||
|
;; the page, break this graph into two graphs, taking the first part of the split
|
||||||
|
(let-values ([(before after) (split-graph
|
||||||
|
graph
|
||||||
|
(- max-samples-per-image sample-count))])
|
||||||
|
(values (cons before current)
|
||||||
|
(cons after (cdr graphs))))]
|
||||||
|
[else
|
||||||
|
;; otherwise, just stop with what we have now
|
||||||
|
(values current
|
||||||
|
graphs)]))])))
|
||||||
|
|
||||||
|
;; split-graph : graph number -> (values graph graph)
|
||||||
|
;; break graph into two pieces where the first piece has 'max-samples' samples
|
||||||
|
;; split-point <= number of samples in graph
|
||||||
|
(define (split-graph graph split-point)
|
||||||
|
(let* ([this-graph-samples (graph-sample-count graph)]
|
||||||
|
[orig-lines (graph-lines graph)]
|
||||||
|
[lines-before (pull-out orig-lines (λ (x) (take x split-point)))]
|
||||||
|
[lines-after (pull-out orig-lines (λ (x) (drop x split-point)))]
|
||||||
|
[lines-before-last-revision
|
||||||
|
(apply max (map point-revision (line-points (car lines-before))))]
|
||||||
|
[lines-after-first-revision
|
||||||
|
(apply min (map point-revision (line-points (car lines-after))))])
|
||||||
|
(values (make-graph (graph-start graph)
|
||||||
|
lines-before-last-revision
|
||||||
|
lines-before)
|
||||||
|
(make-graph lines-after-first-revision
|
||||||
|
(graph-end graph)
|
||||||
|
lines-after))))
|
||||||
|
|
||||||
|
;; pull-out : (listof line) (-> (listof point) (listof point)) -> (listof line)
|
||||||
|
;; makes lines like 'lines', but using puller to select the relevant points
|
||||||
|
(define/contract (pull-out lines puller)
|
||||||
|
(-> (listof line?) (-> (listof point?) (listof point?)) (listof line?))
|
||||||
|
(map (λ (line)
|
||||||
|
(let* ([new-points (puller (line-points line))]
|
||||||
|
[max-v (apply max (map point-value new-points))]
|
||||||
|
[min-v (apply min (map point-value new-points))])
|
||||||
|
(make-line min-v
|
||||||
|
max-v
|
||||||
|
new-points
|
||||||
|
(line-color line)
|
||||||
|
(line-style line))))
|
||||||
|
lines))
|
||||||
|
|
||||||
|
(define (graph-sample-count graph)
|
||||||
|
(length (line-points (car (graph-lines graph)))))
|
||||||
|
|
||||||
|
;; build-large-graphs : (listof raw-line) -> (listof graph)
|
||||||
|
(define (build-large-graphs data)
|
||||||
|
(let loop ([data data]
|
||||||
|
[working-graph '()])
|
||||||
|
(cond
|
||||||
|
[(null? data)
|
||||||
|
(if (null? working-graph)
|
||||||
|
'()
|
||||||
|
(list (finalize-graph (reverse working-graph))))]
|
||||||
|
[else
|
||||||
|
(let ([this (car data)])
|
||||||
|
(cond
|
||||||
|
[(matching-line? this working-graph)
|
||||||
|
(loop (cdr data)
|
||||||
|
(cons this working-graph))]
|
||||||
|
[else
|
||||||
|
(cons (finalize-graph (reverse working-graph))
|
||||||
|
(loop data '()))]))])))
|
||||||
|
|
||||||
|
;; matching-line? : raw-line (listof raw-line) -> boolean
|
||||||
|
;; #t if the line fits into this graph
|
||||||
|
(define (matching-line? line working-graph)
|
||||||
|
(or (null? working-graph)
|
||||||
|
(match line
|
||||||
|
[`(,rev ,time ,line-seqs)
|
||||||
|
(match (car working-graph)
|
||||||
|
[`(,rev ,time ,working-line-seq)
|
||||||
|
(= (length line-seqs)
|
||||||
|
(length working-line-seq))])])))
|
||||||
|
|
||||||
|
;; split-up : (listof X) -> (listof (listof X))
|
||||||
|
;; splits up the working graph into at chunks of size at most
|
||||||
|
;; max-revisions-per-graph.
|
||||||
|
(define (split-up working-graph)
|
||||||
|
(reverse
|
||||||
|
(let loop ([working-graph (reverse working-graph)]
|
||||||
|
[i 0]
|
||||||
|
[pending '()])
|
||||||
|
(cond
|
||||||
|
[(null? working-graph)
|
||||||
|
(if (null? pending)
|
||||||
|
'()
|
||||||
|
(list pending))]
|
||||||
|
[else
|
||||||
|
(if (< i (max-revisions-per-graph))
|
||||||
|
(loop (cdr working-graph)
|
||||||
|
(+ i 1)
|
||||||
|
(cons (car working-graph) pending))
|
||||||
|
(cons pending
|
||||||
|
(loop working-graph 0 '())))]))))
|
||||||
|
|
||||||
|
;; poor man testing ....
|
||||||
|
(parameterize ([max-revisions-per-graph 3])
|
||||||
|
(unless (and (equal? (split-up '()) '())
|
||||||
|
(equal? (split-up '(1)) '((1)))
|
||||||
|
(equal? (split-up '(1 2)) '((1 2)))
|
||||||
|
(equal? (split-up '(1 2 3)) '((1 2 3)))
|
||||||
|
(equal? (split-up '(1 2 3 4)) '((1) (2 3 4)))
|
||||||
|
(equal? (split-up '(1 2 3 4 5)) '((1 2) (3 4 5)))
|
||||||
|
(equal? (split-up '(1 2 3 4 5 6)) '((1 2 3) (4 5 6)))
|
||||||
|
(equal? (split-up '(1 2 3 4 5 6 7)) '((1) (2 3 4) (5 6 7))))
|
||||||
|
(error 'tests-failed)))
|
||||||
|
|
||||||
|
;; finalize-graph : (non-empty-listof raw-line) -> graph
|
||||||
|
(define (finalize-graph working-graph)
|
||||||
|
(restart-colors)
|
||||||
|
(let ([revisions (map first working-graph)])
|
||||||
|
(make-graph
|
||||||
|
(car (car working-graph))
|
||||||
|
(car (last working-graph))
|
||||||
|
(cons
|
||||||
|
(build-line 'overall
|
||||||
|
(map second working-graph)
|
||||||
|
revisions
|
||||||
|
"black")
|
||||||
|
(apply
|
||||||
|
append
|
||||||
|
(let ([cpu-real-gcss (map third working-graph)])
|
||||||
|
(for/list ([ele (car cpu-real-gcss)]
|
||||||
|
[i (in-naturals)])
|
||||||
|
(let ([color (next-color)])
|
||||||
|
(list (build-line 'cpu
|
||||||
|
(map (λ (x) (first (list-ref x i)))
|
||||||
|
cpu-real-gcss)
|
||||||
|
revisions
|
||||||
|
color)
|
||||||
|
(build-line 'real
|
||||||
|
(map (λ (x) (second (list-ref x i)))
|
||||||
|
cpu-real-gcss)
|
||||||
|
revisions
|
||||||
|
color)
|
||||||
|
(build-line 'gc
|
||||||
|
(map (λ (x) (third (list-ref x i)))
|
||||||
|
cpu-real-gcss)
|
||||||
|
revisions
|
||||||
|
color))))))))))
|
||||||
|
|
||||||
|
(define (build-line which points revisions color)
|
||||||
|
(let ([min-v (apply max points)]
|
||||||
|
[max-v (apply max points)])
|
||||||
|
(make-line min-v
|
||||||
|
max-v
|
||||||
|
(map make-point points revisions)
|
||||||
|
color which)))
|
||||||
|
|
||||||
|
(define-values (next-color restart-colors)
|
||||||
|
(let ([colors '("darkred"
|
||||||
|
"mediumvioletred"
|
||||||
|
"brown"
|
||||||
|
"midnightblue")]
|
||||||
|
[i 0])
|
||||||
|
(values (λ ()
|
||||||
|
(begin0
|
||||||
|
(list-ref colors i)
|
||||||
|
(set! i (modulo (+ i 1) (length colors)))))
|
||||||
|
(λ ()
|
||||||
|
(set! i 0)))))
|
||||||
|
|
||||||
|
|
||||||
|
;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
; ;; ;;
|
||||||
|
; ;; ;
|
||||||
|
; ;;;;; ;;;; ;;;;; ;; ;; ;; ;; ;;;;; ;;;;;
|
||||||
|
; ;;;;; ;;; ;; ;; ; ;; ;; ;; ;;;;; ;;;;;
|
||||||
|
; ;;; ;; ;; ;;;; ;;;;;;;; ;; ;; ;;;;;; ;;
|
||||||
|
; ;;; ;; ;; ;;;;;; ;;;;;;;; ;; ;; ;;;;;; ;;
|
||||||
|
; ;;;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;;;;;
|
||||||
|
; ;;;;; ;; ;;;;;; ;; ;; ;; ;; ;;; ;;;;;
|
||||||
|
; ;; ;;
|
||||||
|
; ;;;;;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
|
||||||
|
|
||||||
|
;; record-points : (parameter (or/c #f (-> number[x-coordinate] number[revision] -> void)))
|
||||||
|
(define record-points (make-parameter #f))
|
||||||
|
|
||||||
|
(define (graphs->coordinates graphs)
|
||||||
|
(let ([dc (make-object bitmap-dc% (make-object bitmap% 1 1))]
|
||||||
|
[points (make-hash)])
|
||||||
|
(define (rp x-coord revision)
|
||||||
|
(let ([pixel (inexact->exact (floor x-coord))]
|
||||||
|
[prev (hash-ref points revision #f)])
|
||||||
|
(cond
|
||||||
|
[prev
|
||||||
|
(unless (equal? prev pixel)
|
||||||
|
(error
|
||||||
|
'graphs->coordinates
|
||||||
|
"revision ~s maps to two different pixel values! ~s and ~s"
|
||||||
|
revision
|
||||||
|
prev
|
||||||
|
pixel))]
|
||||||
|
[else
|
||||||
|
(hash-set! points revision pixel)])))
|
||||||
|
(parameterize ([record-points rp])
|
||||||
|
(draw-graphs dc graphs))
|
||||||
|
(sort (hash-map points (λ (revision pixel) (make-coordinate revision pixel)))
|
||||||
|
<
|
||||||
|
#:key coordinate-revision)))
|
||||||
|
|
||||||
|
(define (draw-graphs dc graphs)
|
||||||
|
(let ([tot-points (apply + (map graph-point-count graphs))]
|
||||||
|
[tot-space (- graphs-width (* graph-gap (- (length graphs) 1)))])
|
||||||
|
(let loop ([sx 0]
|
||||||
|
[graphs graphs])
|
||||||
|
(unless (null? graphs)
|
||||||
|
(let* ([graph (car graphs)]
|
||||||
|
[points (graph-point-count graph)]
|
||||||
|
[this-w (* (/ points tot-points) tot-space)]
|
||||||
|
[next-sx (+ sx this-w graph-gap)])
|
||||||
|
(draw-graph dc graph sx this-w)
|
||||||
|
(unless (null? (cdr graphs))
|
||||||
|
(send dc set-pen "black" 1 'transparent)
|
||||||
|
(send dc set-brush "gray" 'solid)
|
||||||
|
(send dc set-alpha 1)
|
||||||
|
(send dc draw-rectangle
|
||||||
|
(- next-sx graph-gap)
|
||||||
|
0
|
||||||
|
graph-gap
|
||||||
|
graph-height))
|
||||||
|
(loop next-sx
|
||||||
|
(cdr graphs)))))))
|
||||||
|
|
||||||
|
(define (graph-point-count graph)
|
||||||
|
(length (line-points (car (graph-lines graph)))))
|
||||||
|
|
||||||
|
(define (draw-graph dc graph sx w)
|
||||||
|
(draw-legend dc sx w)
|
||||||
|
(for ([line (in-list (graph-lines graph))])
|
||||||
|
(let* ([num-points (length (line-points line))]
|
||||||
|
[i->x (λ (i) (+ sx (* (/ i (- num-points 1)) w)))]
|
||||||
|
[point->y (λ (point)
|
||||||
|
(let ([lm (line-max line)])
|
||||||
|
(if (zero? lm) ;; everything must be zero in this case
|
||||||
|
graph-height
|
||||||
|
(* (- 1 (/ (point-value point) lm))
|
||||||
|
graph-height))))])
|
||||||
|
(send dc set-pen (line->pen line))
|
||||||
|
(send dc set-alpha (line->alpha line))
|
||||||
|
|
||||||
|
(for ([start (in-list (line-points line))]
|
||||||
|
[end (in-list (cdr (line-points line)))]
|
||||||
|
[i (in-naturals)])
|
||||||
|
(let* ([x-start (i->x i)]
|
||||||
|
[x-end (i->x (+ i 1))]
|
||||||
|
[y-start (point->y start)]
|
||||||
|
[y-end (point->y end)])
|
||||||
|
(let ([rp (record-points)])
|
||||||
|
(when rp
|
||||||
|
(when (= i 0) (rp x-start (point-revision start)))
|
||||||
|
(rp x-end (point-revision end))))
|
||||||
|
(send dc draw-line
|
||||||
|
x-start y-start
|
||||||
|
x-end y-end))))))
|
||||||
|
|
||||||
|
(define (draw-legend dc sx w)
|
||||||
|
(send dc set-pen "gray" 3 'solid)
|
||||||
|
(send dc set-alpha 1)
|
||||||
|
(let ([hline (λ (p [dy 0])
|
||||||
|
(send dc draw-line
|
||||||
|
sx
|
||||||
|
(+ dy (* p graph-height))
|
||||||
|
(+ sx w)
|
||||||
|
(+ dy (* p graph-height))))])
|
||||||
|
(hline 0 1)
|
||||||
|
(hline 1/4)
|
||||||
|
(hline 1/2)
|
||||||
|
(hline 3/4)
|
||||||
|
(hline 1 -2)))
|
||||||
|
|
||||||
|
(define (line->alpha line)
|
||||||
|
(case (line-style line)
|
||||||
|
[(overall) 1]
|
||||||
|
[(cpu) 1/2]
|
||||||
|
[(gc) 1/4]
|
||||||
|
[(real) 1]))
|
||||||
|
|
||||||
|
(define (line->pen line)
|
||||||
|
(send the-pen-list find-or-create-pen
|
||||||
|
(line-color line)
|
||||||
|
1
|
||||||
|
'solid))
|
||||||
|
|
||||||
|
(define (draw fgs dc)
|
||||||
|
(send dc set-smoothing 'aligned)
|
||||||
|
(draw-graphs dc fgs))
|
||||||
|
|
||||||
|
|
||||||
|
;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
; ;; ; ;;
|
||||||
|
; ;; ;; ;;
|
||||||
|
; ;; ;; ;;
|
||||||
|
; ;;;;;; ;;;; ;;;;;;;;; ;;
|
||||||
|
; ;; ;; ;; ;; ;;; ;;; ;;
|
||||||
|
; ;; ;; ;; ;; ;;; ;;; ;;
|
||||||
|
; ;; ;; ;; ;; ;;; ;;; ;;
|
||||||
|
; ;; ;; ;; ;; ;;; ;;; ;;
|
||||||
|
; ;; ;;; ;;;;;; ;;; ;;; ;;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
|
||||||
|
(define (write-html graphss)
|
||||||
|
(let ([xml (xexpr->xml (graphs->complete-xexpr graphss))])
|
||||||
|
(call-with-output-file html-file
|
||||||
|
(λ (port) (display-xml/content xml port))
|
||||||
|
#:exists 'truncate)))
|
||||||
|
|
||||||
|
(define (graphs->complete-xexpr graphss)
|
||||||
|
(let ([xexpr (graphs->xexpr graphss)])
|
||||||
|
(if full?
|
||||||
|
`(html (head)
|
||||||
|
(body ,xexpr))
|
||||||
|
xexpr)))
|
||||||
|
|
||||||
|
|
||||||
|
(define (graphs->xexpr graphss)
|
||||||
|
(let ([last-one (- (length graphss) 1)])
|
||||||
|
`(div
|
||||||
|
(script ((type "text/javascript"))
|
||||||
|
,(format "var current_pane=~a;\n" last-one)
|
||||||
|
"function move_bar(rev,x,w,duration,timing_strings) {\n"
|
||||||
|
" document.getElementById(\"rev_and_duration\").innerHTML='revision '+rev+' duration '+duration+' msec';\n"
|
||||||
|
,(make-cdata
|
||||||
|
'here
|
||||||
|
'there
|
||||||
|
" document.getElementById(\"timings\").innerHTML=timing_strings.join('<br />');\n")
|
||||||
|
" var barimg = document.getElementById(\"barimg\");\n"
|
||||||
|
" barimg.width=w;\n"
|
||||||
|
" barimg.height=200;\n"
|
||||||
|
" document.getElementById(\"bar\").style.left=x;\n"
|
||||||
|
,@(if link-format-string
|
||||||
|
(list (format
|
||||||
|
" document.getElementById(\"bara\").href='~a'+'?pane='+(current_pane+1)\n"
|
||||||
|
(format link-format-string "'+rev+'")))
|
||||||
|
'())
|
||||||
|
" return true;\n"
|
||||||
|
"}\n"
|
||||||
|
"function do_before(){\n"
|
||||||
|
" current_pane = current_pane-1;\n"
|
||||||
|
,(format " if (current_pane == -1) { current_pane=~a; }\n" last-one)
|
||||||
|
" update_pane();\n"
|
||||||
|
"}\n"
|
||||||
|
"function do_after(){\n"
|
||||||
|
" current_pane = current_pane+1;\n"
|
||||||
|
,(format " if (current_pane == ~a) { current_pane=0; }\n" (+ 1 last-one))
|
||||||
|
" update_pane();\n"
|
||||||
|
"}\n"
|
||||||
|
"function update_pane(){\n"
|
||||||
|
" var img = document.getElementById(\"img\");\n"
|
||||||
|
" img.useMap='#revmap'+current_pane;\n"
|
||||||
|
,(format " img.src='~a'+current_pane+'.png';\n" image-url-prefix)
|
||||||
|
" var p = current_pane+1;\n"
|
||||||
|
,(format " document.getElementById(\"paneid\").innerHTML=('Pane '+p+' of ~a');\n"
|
||||||
|
(+ last-one 1))
|
||||||
|
"}\n"
|
||||||
|
"// this function from http://www.netlobo.com/url_query_string_javascript.html\n"
|
||||||
|
"function gup (name) {\n"
|
||||||
|
" name = name.replace(/[\\[]/,\"\\\\\\[\").replace(/[\\]]/,\"\\\\\\]\");\n"
|
||||||
|
,(make-cdata 'here 'there " var regexS = \"[\\\\?&]\"+name+\"=([^&#]*)\";\n")
|
||||||
|
" var regex = new RegExp( regexS );\n"
|
||||||
|
" var results = regex.exec( window.location.href );\n"
|
||||||
|
" if( results == null )\n"
|
||||||
|
" return \"\";\n"
|
||||||
|
" else\n"
|
||||||
|
" return results[1];\n"
|
||||||
|
"}\n"
|
||||||
|
"function startup() {\n"
|
||||||
|
" current_pane = parseInt(gup('pane'));\n"
|
||||||
|
" if (isNaN(current_pane))\n"
|
||||||
|
,(format " current_pane = ~a;\n" last-one)
|
||||||
|
" else\n"
|
||||||
|
,(format " current_pane = Math.min(Math.max(current_pane,1),~a)-1\n" (+ last-one 1))
|
||||||
|
" update_pane();"
|
||||||
|
"}\n"
|
||||||
|
)
|
||||||
|
(table
|
||||||
|
((cellpadding "0")
|
||||||
|
(cellspacing "0"))
|
||||||
|
(tr
|
||||||
|
(td (a ((href "#") (onclick "javascript:do_before(); return false;"))
|
||||||
|
(img ((border "0")
|
||||||
|
(src ,before-image-file)))))
|
||||||
|
(td
|
||||||
|
(div ((style "position: relative;"))
|
||||||
|
(img ((src ,dot-image-file)
|
||||||
|
(border "0")
|
||||||
|
(id "img")
|
||||||
|
(height ,(format "~a" graph-height))
|
||||||
|
(width ,(format "~a" graphs-width))))
|
||||||
|
(div ((id "bar")
|
||||||
|
(style "position: absolute; top: 0px; left: 20px"))
|
||||||
|
(a ((id "bara"))
|
||||||
|
(img ((style "border:none")
|
||||||
|
(id "barimg")
|
||||||
|
(width "0")
|
||||||
|
(height ,(format "~a" graph-height))
|
||||||
|
(src ,dot-image-file)))))))
|
||||||
|
(td (a ((href "#") (onclick "javascript:do_after(); return false;"))
|
||||||
|
(img ((border "0")
|
||||||
|
(src ,after-image-file)))))))
|
||||||
|
(div (span ((id "paneid")) "")
|
||||||
|
(span ((id "rev_and_duration")) ""))
|
||||||
|
(tt (span ((id "timings")) ""))
|
||||||
|
|
||||||
|
,@(for/list ((graphs (in-list graphss))
|
||||||
|
(i (in-naturals)))
|
||||||
|
`(map ((name ,(format "revmap~a" i)))
|
||||||
|
,@(graphs->areas graphs i)))
|
||||||
|
|
||||||
|
(script ((type "text/javascript"))
|
||||||
|
"startup()"))))
|
||||||
|
|
||||||
|
(define (graphs->areas graphs i)
|
||||||
|
(let ([coordinates (graphs->coordinates graphs)])
|
||||||
|
(for/list ([c-1 (cons #f coordinates)]
|
||||||
|
[c coordinates]
|
||||||
|
[c+1 (append (cdr coordinates) (list #f))])
|
||||||
|
(let ([left (if c-1
|
||||||
|
(floor (average (coordinate-x-pixel c-1)
|
||||||
|
(coordinate-x-pixel c)))
|
||||||
|
(coordinate-x-pixel c))]
|
||||||
|
[right (if c+1
|
||||||
|
(floor (average (coordinate-x-pixel c)
|
||||||
|
(coordinate-x-pixel c+1)))
|
||||||
|
(coordinate-x-pixel c))])
|
||||||
|
`(area ((shape "rect")
|
||||||
|
(coords ,(format "~a,~a,~a,~a" left 0 right graph-height))
|
||||||
|
(onmouseover ,(format "move_bar('~a','~apx',~a,'~a',~a)"
|
||||||
|
(coordinate-revision c)
|
||||||
|
left
|
||||||
|
(- right left)
|
||||||
|
(revision->duration (coordinate-revision c))
|
||||||
|
(revision->timings-array
|
||||||
|
(coordinate-revision c))))))))))
|
||||||
|
|
||||||
|
(define (timing-strings c) (format "~s" c))
|
||||||
|
|
||||||
|
(define (average . l) (/ (apply + l) (length l)))
|
||||||
|
|
||||||
|
|
||||||
|
;; note: there is javascript code doing this same computation.
|
||||||
|
(define (i->image-file i) (format "~a~a.png" image-filename-prefix i))
|
||||||
|
|
||||||
|
|
||||||
|
;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
; ;;
|
||||||
|
; ;
|
||||||
|
; ;;;;; ;; ;;;;; ;; ;;;;;
|
||||||
|
; ;;;;;;;;; ;; ;; ;; ;;;;;
|
||||||
|
; ;; ;; ;; ;;;; ;; ;; ;;;
|
||||||
|
; ;; ;; ;; ;;;;;; ;; ;; ;;;
|
||||||
|
; ;; ;; ;; ;;; ;;; ;; ;; ;;;
|
||||||
|
; ;; ;; ;; ;;;;;; ;; ;; ;;;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
;
|
||||||
|
|
||||||
|
(define (save fgs i)
|
||||||
|
(let* ([bm (make-object bitmap% graphs-width graph-height)]
|
||||||
|
[bdc (make-object bitmap-dc% bm)])
|
||||||
|
(send bdc clear)
|
||||||
|
(draw fgs bdc)
|
||||||
|
(send bdc set-bitmap #f)
|
||||||
|
(send bm save-file (i->image-file i) 'png)
|
||||||
|
(void)))
|
||||||
|
|
||||||
|
(let ()
|
||||||
|
(define the-data (fetch-data input-file))
|
||||||
|
(define the-graphss (build-graphss the-data))
|
||||||
|
|
||||||
|
(write-html the-graphss)
|
||||||
|
(for ((the-graphs (in-list the-graphss))
|
||||||
|
(i (in-naturals)))
|
||||||
|
(save the-graphs i)))
|
||||||
7
collects/meta/drdr/graphs/constants.ss
Normal file
7
collects/meta/drdr/graphs/constants.ss
Normal file
|
|
@ -0,0 +1,7 @@
|
||||||
|
#lang scheme/base
|
||||||
|
(provide (all-defined-out))
|
||||||
|
(define total-width 800)
|
||||||
|
(define before-and-after-image-width 18)
|
||||||
|
(define graph-height 200)
|
||||||
|
(define graphs-width (- 800 (* 2 before-and-after-image-width)))
|
||||||
|
|
||||||
62
collects/meta/drdr/graphs/mk-img.ss
Normal file
62
collects/meta/drdr/graphs/mk-img.ss
Normal file
|
|
@ -0,0 +1,62 @@
|
||||||
|
#lang scheme/gui
|
||||||
|
|
||||||
|
(require 2htdp/image
|
||||||
|
"constants.ss")
|
||||||
|
|
||||||
|
;; make dot.png
|
||||||
|
(let* ([bm (make-object bitmap% 1 1)]
|
||||||
|
[mask (make-object bitmap% 1 1)]
|
||||||
|
[bdc (make-object bitmap-dc% bm)])
|
||||||
|
(send bm set-loaded-mask mask)
|
||||||
|
(send bdc set-brush (make-object color% 50 100 20) 'solid)
|
||||||
|
(send bdc set-pen "black" 1 'transparent)
|
||||||
|
(send bdc draw-rectangle 0 0 1 1)
|
||||||
|
(send bdc set-bitmap mask)
|
||||||
|
(send bdc set-brush (make-object color% 100 100 100) 'solid)
|
||||||
|
(send bdc draw-rectangle 0 0 1 1)
|
||||||
|
(send bdc set-bitmap #f)
|
||||||
|
(send bm save-file "dot.png" 'png)
|
||||||
|
(void))
|
||||||
|
|
||||||
|
(define (save-bitmap mask-image color filename)
|
||||||
|
(let* ([w (image-width mask-image)]
|
||||||
|
[h (image-height mask-image)]
|
||||||
|
[bm (make-object bitmap% w h)]
|
||||||
|
[mask (make-object bitmap% w h)]
|
||||||
|
[bdc (make-object bitmap-dc% bm)])
|
||||||
|
|
||||||
|
(unless (= w before-and-after-image-width)
|
||||||
|
(error 'mk-img.ss "expected ~a image's width to be ~a, got ~a"
|
||||||
|
filename
|
||||||
|
before-and-after-image-width
|
||||||
|
w))
|
||||||
|
|
||||||
|
(send bm set-loaded-mask mask)
|
||||||
|
(send bdc set-brush color 'solid)
|
||||||
|
(send bdc set-pen "black" 1 'transparent)
|
||||||
|
(send bdc draw-rectangle 0 0 w h)
|
||||||
|
(send bdc set-bitmap mask)
|
||||||
|
(send bdc clear)
|
||||||
|
(send mask-image draw bdc 0 0 0 0 w h 0 0 'show-caret)
|
||||||
|
(send bdc set-bitmap #f)
|
||||||
|
(send bm save-file filename 'png)
|
||||||
|
(void)))
|
||||||
|
|
||||||
|
|
||||||
|
(define (space-out img x-place)
|
||||||
|
(overlay/align
|
||||||
|
x-place
|
||||||
|
'center
|
||||||
|
img
|
||||||
|
(rectangle (+ (image-width img) 4)
|
||||||
|
graph-height
|
||||||
|
'solid
|
||||||
|
'white)))
|
||||||
|
|
||||||
|
(save-bitmap (space-out (rotate 90 (triangle 16 'solid 'black)) 'left)
|
||||||
|
"forestgreen"
|
||||||
|
"before.png")
|
||||||
|
|
||||||
|
(save-bitmap (space-out (rotate -90 (triangle 16 'solid 'black)) 'right)
|
||||||
|
"forestgreen"
|
||||||
|
"after.png")
|
||||||
|
|
@ -1,6 +1,7 @@
|
||||||
#lang at-exp scheme
|
#lang at-exp scheme
|
||||||
(require scheme/date
|
(require scheme/date
|
||||||
scheme/runtime-path
|
scheme/runtime-path
|
||||||
|
xml
|
||||||
"config.ss"
|
"config.ss"
|
||||||
"diff.ss"
|
"diff.ss"
|
||||||
"list-count.ss"
|
"list-count.ss"
|
||||||
|
|
@ -141,12 +142,15 @@
|
||||||
(format "http://svn.plt-scheme.org/view?view=rev&revision=~a"
|
(format "http://svn.plt-scheme.org/view?view=rev&revision=~a"
|
||||||
rev))
|
rev))
|
||||||
|
|
||||||
(define render-event
|
(define (render-event e)
|
||||||
(match-lambda
|
(with-handlers ([exn:fail?
|
||||||
[(struct stdout (bs))
|
(lambda (x)
|
||||||
`(pre ([class "stdout"]) ,(bytes->string/utf-8 bs))]
|
`(pre ([class "unprintable"]) "UNPRINTABLE"))])
|
||||||
[(struct stderr (bs))
|
(match e
|
||||||
`(pre ([class "stderr"]) ,(bytes->string/utf-8 bs))]))
|
[(struct stdout (bs))
|
||||||
|
`(pre ([class "stdout"]) ,(bytes->string/utf-8 bs))]
|
||||||
|
[(struct stderr (bs))
|
||||||
|
`(pre ([class "stderr"]) ,(bytes->string/utf-8 bs))])))
|
||||||
|
|
||||||
(define (render-log log-pth)
|
(define (render-log log-pth)
|
||||||
(match (log-rendering log-pth)
|
(match (log-rendering log-pth)
|
||||||
|
|
@ -158,9 +162,6 @@
|
||||||
(define-values (title breadcrumb) (path->breadcrumb log-pth #f))
|
(define-values (title breadcrumb) (path->breadcrumb log-pth #f))
|
||||||
(define the-base-path
|
(define the-base-path
|
||||||
(base-path log-pth))
|
(base-path log-pth))
|
||||||
; XXX use dirstruct functions
|
|
||||||
(define png-path
|
|
||||||
(format "/data~a" (path-add-suffix (path-add-suffix the-base-path #".timing") #".png")))
|
|
||||||
(define svn-url
|
(define svn-url
|
||||||
(format "http://svn.plt-scheme.org/view/trunk/~a?view=markup&pathrev=~a"
|
(format "http://svn.plt-scheme.org/view/trunk/~a?view=markup&pathrev=~a"
|
||||||
the-base-path
|
the-base-path
|
||||||
|
|
@ -197,9 +198,19 @@
|
||||||
'()
|
'()
|
||||||
`((div ([class "output"]) " "
|
`((div ([class "output"]) " "
|
||||||
,@output)))
|
,@output)))
|
||||||
(div ([class "timing"])
|
,(with-handlers ([exn:fail?
|
||||||
(a ([href ,png-path])
|
; XXX Remove this eventually
|
||||||
(img ([src ,png-path]))))
|
(lambda (x)
|
||||||
|
; XXX use dirstruct functions
|
||||||
|
(define png-path
|
||||||
|
(format "/data~a" (path-add-suffix (path-add-suffix the-base-path #".timing") #".png")))
|
||||||
|
`(div ([class "timing"])
|
||||||
|
(a ([href ,png-path])
|
||||||
|
(img ([src ,png-path])))))])
|
||||||
|
(make-cdata
|
||||||
|
#f #f
|
||||||
|
(file->string
|
||||||
|
(path-timing-html (substring (path->string* the-base-path) 1)))))
|
||||||
,(footer))))])]))
|
,(footer))))])]))
|
||||||
|
|
||||||
(define (number->string/zero v)
|
(define (number->string/zero v)
|
||||||
|
|
@ -670,38 +681,52 @@
|
||||||
(apply top-url show-file (newest-completed-revision) args)))
|
(apply top-url show-file (newest-completed-revision) args)))
|
||||||
|
|
||||||
(define (show-diff req r1 r2 f)
|
(define (show-diff req r1 r2 f)
|
||||||
(define l1 (status-output-log (read-cache (apply build-path (revision-log-dir r1) f))))
|
(define f1 (apply build-path (revision-log-dir r1) f))
|
||||||
(define l2 (status-output-log (read-cache (apply build-path (revision-log-dir r2) f))))
|
(with-handlers ([(lambda (x)
|
||||||
(define f-str (path->string (apply build-path f)))
|
(regexp-match #rx"File is not cached" (exn-message x)))
|
||||||
(define title
|
(lambda (x)
|
||||||
(format "DrDr / File Difference / ~a (~a:~a)"
|
; XXX Make a little nicer
|
||||||
f-str r1 r2))
|
(parameterize ([current-rev r1])
|
||||||
|
(file-not-found f1)))])
|
||||||
`(html (head (title ,title)
|
(define l1 (status-output-log (read-cache f1)))
|
||||||
(link ([rel "stylesheet"] [type "text/css"] [href "/render.css"])))
|
(define f2 (apply build-path (revision-log-dir r2) f))
|
||||||
(body
|
(with-handlers ([(lambda (x)
|
||||||
(div ([class "log, content"])
|
(regexp-match #rx"File is not cached" (exn-message x)))
|
||||||
(span ([class "breadcrumb"])
|
(lambda (x)
|
||||||
(a ([class "parent"] [href "/"])
|
; XXX Make a little nicer
|
||||||
"DrDr")
|
(parameterize ([current-rev r2])
|
||||||
" / "
|
(file-not-found f2)))])
|
||||||
(span ([class "this"])
|
(define l2 (status-output-log (read-cache f2)))
|
||||||
"File Difference"))
|
(define f-str (path->string (apply build-path f)))
|
||||||
(table ([class "data"])
|
(define title
|
||||||
(tr (td "First Revision:") (td (a ([href ,(format "/~a/~a" r1 f-str)]) ,(number->string r1))))
|
(format "DrDr / File Difference / ~a (~a:~a)"
|
||||||
(tr (td "Second Revision:") (td (a ([href ,(format "/~a/~a" r2 f-str)]) ,(number->string r2))))
|
f-str r1 r2))
|
||||||
(tr (td "File:") (td "/" ,f-str)))
|
|
||||||
(div ([class "output"])
|
`(html (head (title ,title)
|
||||||
(table ([class "diff"])
|
(link ([rel "stylesheet"] [type "text/css"] [href "/render.css"])))
|
||||||
,@(for/list ([d (in-list (render-log-difference l1 l2))])
|
(body
|
||||||
(match d
|
(div ([class "log, content"])
|
||||||
[(struct difference (old new))
|
(span ([class "breadcrumb"])
|
||||||
`(tr ([class "difference"])
|
(a ([class "parent"] [href "/"])
|
||||||
(td ,(render-event old))
|
"DrDr")
|
||||||
(td ,(render-event new)))]
|
" / "
|
||||||
[(struct same-itude (e))
|
(span ([class "this"])
|
||||||
`(tr (td ([colspan "2"]) ,(render-event e)))]))))
|
"File Difference"))
|
||||||
,(footer)))))
|
(table ([class "data"])
|
||||||
|
(tr (td "First Revision:") (td (a ([href ,(format "/~a/~a" r1 f-str)]) ,(number->string r1))))
|
||||||
|
(tr (td "Second Revision:") (td (a ([href ,(format "/~a/~a" r2 f-str)]) ,(number->string r2))))
|
||||||
|
(tr (td "File:") (td "/" ,f-str)))
|
||||||
|
(div ([class "output"])
|
||||||
|
(table ([class "diff"])
|
||||||
|
,@(for/list ([d (in-list (render-log-difference l1 l2))])
|
||||||
|
(match d
|
||||||
|
[(struct difference (old new))
|
||||||
|
`(tr ([class "difference"])
|
||||||
|
(td ,(render-event old))
|
||||||
|
(td ,(render-event new)))]
|
||||||
|
[(struct same-itude (e))
|
||||||
|
`(tr (td ([colspan "2"]) ,(render-event e)))]))))
|
||||||
|
,(footer)))))))
|
||||||
|
|
||||||
(define-values (top-dispatch top-url)
|
(define-values (top-dispatch top-url)
|
||||||
(dispatch-rules
|
(dispatch-rules
|
||||||
|
|
|
||||||
BIN
collects/meta/drdr/static/graph-images/after.png
Normal file
BIN
collects/meta/drdr/static/graph-images/after.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 310 B |
BIN
collects/meta/drdr/static/graph-images/before.png
Normal file
BIN
collects/meta/drdr/static/graph-images/before.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 305 B |
BIN
collects/meta/drdr/static/graph-images/dot.png
Normal file
BIN
collects/meta/drdr/static/graph-images/dot.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 70 B |
|
|
@ -35,7 +35,7 @@ body {
|
||||||
.stdout {
|
.stdout {
|
||||||
color: black;
|
color: black;
|
||||||
}
|
}
|
||||||
.difference {
|
.difference,.unprintable {
|
||||||
background: #00ffc8;
|
background: #00ffc8;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -2,6 +2,7 @@
|
||||||
(require (planet jaymccarthy/job-queue)
|
(require (planet jaymccarthy/job-queue)
|
||||||
scheme/system
|
scheme/system
|
||||||
"config.ss"
|
"config.ss"
|
||||||
|
"path-utils.ss"
|
||||||
"dirstruct.ss"
|
"dirstruct.ss"
|
||||||
"cache.ss")
|
"cache.ss")
|
||||||
|
|
||||||
|
|
@ -9,11 +10,14 @@
|
||||||
|
|
||||||
(define start-revision #f)
|
(define start-revision #f)
|
||||||
(define history? #f)
|
(define history? #f)
|
||||||
|
(define just-graphs? #f)
|
||||||
|
|
||||||
(command-line #:program "time"
|
(command-line #:program "time"
|
||||||
#:once-each
|
#:once-each
|
||||||
["-H" "Run on all revisions"
|
["-H" "Run on all revisions"
|
||||||
(set! history? #t)]
|
(set! history? #t)]
|
||||||
|
["-G" "Just graphs"
|
||||||
|
(set! just-graphs? #t)]
|
||||||
["-r" rev
|
["-r" rev
|
||||||
"Start with a particular revision"
|
"Start with a particular revision"
|
||||||
(set! start-revision (string->number rev))])
|
(set! start-revision (string->number rev))])
|
||||||
|
|
@ -22,31 +26,41 @@
|
||||||
(init-revisions!)
|
(init-revisions!)
|
||||||
(set! start-revision (newest-revision)))
|
(set! start-revision (newest-revision)))
|
||||||
|
|
||||||
|
(define rebaser
|
||||||
|
(rebase-path (plt-data-directory) "/data"))
|
||||||
|
|
||||||
(define (make-log! filename)
|
(define (make-log! filename)
|
||||||
(submit-job!
|
(submit-job!
|
||||||
test-workers
|
test-workers
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(apply
|
(define prefix
|
||||||
system*/exit-code
|
(path-timing-png-prefix filename))
|
||||||
(path->string
|
(unless just-graphs?
|
||||||
(build-path (plt-directory) "plt" "bin" "mzscheme"))
|
(apply
|
||||||
"-t"
|
system*/exit-code
|
||||||
(path->string (build-path (drdr-directory) "time-file.ss"))
|
(path->string
|
||||||
"--"
|
(build-path (plt-directory) "plt" "bin" "mzscheme"))
|
||||||
(append
|
"-t"
|
||||||
(if history?
|
(path->string (build-path (drdr-directory) "time-file.ss"))
|
||||||
(list "-H")
|
"--"
|
||||||
(list "-r" (number->string start-revision)))
|
(append
|
||||||
(list
|
(if history?
|
||||||
(path->string filename))))
|
(list "-H")
|
||||||
|
(list "-r" (number->string start-revision)))
|
||||||
|
(list
|
||||||
|
(path->string filename)))))
|
||||||
(system*/exit-code
|
(system*/exit-code
|
||||||
(path->string
|
(path->string
|
||||||
(build-path (plt-directory) "plt" "bin" "mred"))
|
(build-path (plt-directory) "plt" "bin" "mred-text"))
|
||||||
"-t"
|
"-t"
|
||||||
(path->string (build-path (drdr-directory) "graph.ss"))
|
(path->string (build-path (drdr-directory) "graphs" "build-graph.ss"))
|
||||||
"--"
|
"--"
|
||||||
|
"-l" (string-append "http://drdr.plt-scheme.org/~a/" (path->string* filename)) ; XXX
|
||||||
|
"--image-loc" "/graph-images/"
|
||||||
(path->string (path-timing-log filename))
|
(path->string (path-timing-log filename))
|
||||||
(path->string (path-timing-png filename))))))
|
(path->string prefix)
|
||||||
|
(path->string (rebaser prefix))
|
||||||
|
(path->string (path-timing-html filename))))))
|
||||||
|
|
||||||
(define (find-files p l)
|
(define (find-files p l)
|
||||||
(for ([f (in-list (cached-directory-list* p))])
|
(for ([f (in-list (cached-directory-list* p))])
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user