diff --git a/collects/meta/drdr/analyze.ss b/collects/meta/drdr/analyze.ss
index cfab2627f3..d51960e5f8 100644
--- a/collects/meta/drdr/analyze.ss
+++ b/collects/meta/drdr/analyze.ss
@@ -162,7 +162,9 @@
(define any-stderr? (ormap stderr? output-log))
(define changed?
(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))
(log-different? output-log (status-output-log (read-cache prev-log-pth))))
#f))
diff --git a/collects/meta/drdr/copy.sh b/collects/meta/drdr/copy.sh
new file mode 100755
index 0000000000..d5737d55ff
--- /dev/null
+++ b/collects/meta/drdr/copy.sh
@@ -0,0 +1,2 @@
+#!/bin/bash
+rsync -avz . plt-drdr:/opt/svn/drdr/ --exclude=.svn
diff --git a/collects/meta/drdr/diffcmd.ss b/collects/meta/drdr/diffcmd.ss
index ce44c690dd..0cada0b7d8 100644
--- a/collects/meta/drdr/diffcmd.ss
+++ b/collects/meta/drdr/diffcmd.ss
@@ -21,9 +21,9 @@
(for ([d (in-list (render-log-difference l1 l2))])
(match d
- [(struct difference (e))
+ [(struct difference (e1 e2))
(printf "! ")
- (event-print e)]
+ (event-print e1)]
[(struct same-itude (e))
(printf " ")
(event-print e)])))
diff --git a/collects/meta/drdr/dirstruct.ss b/collects/meta/drdr/dirstruct.ss
index 93751f5397..6064142d6a 100644
--- a/collects/meta/drdr/dirstruct.ss
+++ b/collects/meta/drdr/dirstruct.ss
@@ -75,6 +75,10 @@
(define (path-timing-png p)
(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
[number-of-cpus (parameter/c exact-nonnegative-integer?)]
@@ -91,6 +95,8 @@
[plt-repository (parameter/c string?)]
[path-timing-log (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?)]
[current-make-timeout-seconds (parameter/c exact-nonnegative-integer?)]
[current-make-install-timeout-seconds (parameter/c exact-nonnegative-integer?)]
diff --git a/collects/meta/drdr/graph.ss b/collects/meta/drdr/graph.ss
deleted file mode 100644
index ca3bba7171..0000000000
--- a/collects/meta/drdr/graph.ss
+++ /dev/null
@@ -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)))
diff --git a/collects/meta/drdr/graphs/README b/collects/meta/drdr/graphs/README
new file mode 100644
index 0000000000..95865db3aa
--- /dev/null
+++ b/collects/meta/drdr/graphs/README
@@ -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 ...
).
+
diff --git a/collects/meta/drdr/graphs/build-graph.ss b/collects/meta/drdr/graphs/build-graph.ss
new file mode 100644
index 0000000000..839952aad9
--- /dev/null
+++ b/collects/meta/drdr/graphs/build-graph.ss
@@ -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('
');\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)))
diff --git a/collects/meta/drdr/graphs/constants.ss b/collects/meta/drdr/graphs/constants.ss
new file mode 100644
index 0000000000..d30ccf9c32
--- /dev/null
+++ b/collects/meta/drdr/graphs/constants.ss
@@ -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)))
+
diff --git a/collects/meta/drdr/graphs/mk-img.ss b/collects/meta/drdr/graphs/mk-img.ss
new file mode 100644
index 0000000000..16cf3db237
--- /dev/null
+++ b/collects/meta/drdr/graphs/mk-img.ss
@@ -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")
diff --git a/collects/meta/drdr/render.ss b/collects/meta/drdr/render.ss
index 4a0e47346e..3459ddb128 100644
--- a/collects/meta/drdr/render.ss
+++ b/collects/meta/drdr/render.ss
@@ -1,6 +1,7 @@
#lang at-exp scheme
(require scheme/date
scheme/runtime-path
+ xml
"config.ss"
"diff.ss"
"list-count.ss"
@@ -141,12 +142,15 @@
(format "http://svn.plt-scheme.org/view?view=rev&revision=~a"
rev))
-(define render-event
- (match-lambda
- [(struct stdout (bs))
- `(pre ([class "stdout"]) ,(bytes->string/utf-8 bs))]
- [(struct stderr (bs))
- `(pre ([class "stderr"]) ,(bytes->string/utf-8 bs))]))
+(define (render-event e)
+ (with-handlers ([exn:fail?
+ (lambda (x)
+ `(pre ([class "unprintable"]) "UNPRINTABLE"))])
+ (match e
+ [(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)
(match (log-rendering log-pth)
@@ -158,9 +162,6 @@
(define-values (title breadcrumb) (path->breadcrumb log-pth #f))
(define the-base-path
(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
(format "http://svn.plt-scheme.org/view/trunk/~a?view=markup&pathrev=~a"
the-base-path
@@ -197,9 +198,19 @@
'()
`((div ([class "output"]) " "
,@output)))
- (div ([class "timing"])
- (a ([href ,png-path])
- (img ([src ,png-path]))))
+ ,(with-handlers ([exn:fail?
+ ; XXX Remove this eventually
+ (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))))])]))
(define (number->string/zero v)
@@ -670,38 +681,52 @@
(apply top-url show-file (newest-completed-revision) args)))
(define (show-diff req r1 r2 f)
- (define l1 (status-output-log (read-cache (apply build-path (revision-log-dir r1) f))))
- (define l2 (status-output-log (read-cache (apply build-path (revision-log-dir r2) f))))
- (define f-str (path->string (apply build-path f)))
- (define title
- (format "DrDr / File Difference / ~a (~a:~a)"
- f-str r1 r2))
-
- `(html (head (title ,title)
- (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"])))
- (body
- (div ([class "log, content"])
- (span ([class "breadcrumb"])
- (a ([class "parent"] [href "/"])
- "DrDr")
- " / "
- (span ([class "this"])
- "File Difference"))
- (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 f1 (apply build-path (revision-log-dir r1) f))
+ (with-handlers ([(lambda (x)
+ (regexp-match #rx"File is not cached" (exn-message x)))
+ (lambda (x)
+ ; XXX Make a little nicer
+ (parameterize ([current-rev r1])
+ (file-not-found f1)))])
+ (define l1 (status-output-log (read-cache f1)))
+ (define f2 (apply build-path (revision-log-dir r2) f))
+ (with-handlers ([(lambda (x)
+ (regexp-match #rx"File is not cached" (exn-message x)))
+ (lambda (x)
+ ; XXX Make a little nicer
+ (parameterize ([current-rev r2])
+ (file-not-found f2)))])
+ (define l2 (status-output-log (read-cache f2)))
+ (define f-str (path->string (apply build-path f)))
+ (define title
+ (format "DrDr / File Difference / ~a (~a:~a)"
+ f-str r1 r2))
+
+ `(html (head (title ,title)
+ (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"])))
+ (body
+ (div ([class "log, content"])
+ (span ([class "breadcrumb"])
+ (a ([class "parent"] [href "/"])
+ "DrDr")
+ " / "
+ (span ([class "this"])
+ "File Difference"))
+ (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)
(dispatch-rules
diff --git a/collects/meta/drdr/static/graph-images/after.png b/collects/meta/drdr/static/graph-images/after.png
new file mode 100644
index 0000000000..42f315bb51
Binary files /dev/null and b/collects/meta/drdr/static/graph-images/after.png differ
diff --git a/collects/meta/drdr/static/graph-images/before.png b/collects/meta/drdr/static/graph-images/before.png
new file mode 100644
index 0000000000..ddb4ef86d3
Binary files /dev/null and b/collects/meta/drdr/static/graph-images/before.png differ
diff --git a/collects/meta/drdr/static/graph-images/dot.png b/collects/meta/drdr/static/graph-images/dot.png
new file mode 100644
index 0000000000..0b8f2a27f9
Binary files /dev/null and b/collects/meta/drdr/static/graph-images/dot.png differ
diff --git a/collects/meta/drdr/static/render.css b/collects/meta/drdr/static/render.css
index 4de0c32119..53a4c7a21d 100644
--- a/collects/meta/drdr/static/render.css
+++ b/collects/meta/drdr/static/render.css
@@ -35,7 +35,7 @@ body {
.stdout {
color: black;
}
-.difference {
+.difference,.unprintable {
background: #00ffc8;
}
diff --git a/collects/meta/drdr/time.ss b/collects/meta/drdr/time.ss
index 18f9a093ab..c8fc3701a6 100644
--- a/collects/meta/drdr/time.ss
+++ b/collects/meta/drdr/time.ss
@@ -2,6 +2,7 @@
(require (planet jaymccarthy/job-queue)
scheme/system
"config.ss"
+ "path-utils.ss"
"dirstruct.ss"
"cache.ss")
@@ -9,11 +10,14 @@
(define start-revision #f)
(define history? #f)
+(define just-graphs? #f)
(command-line #:program "time"
#:once-each
["-H" "Run on all revisions"
(set! history? #t)]
+ ["-G" "Just graphs"
+ (set! just-graphs? #t)]
["-r" rev
"Start with a particular revision"
(set! start-revision (string->number rev))])
@@ -22,31 +26,41 @@
(init-revisions!)
(set! start-revision (newest-revision)))
+(define rebaser
+ (rebase-path (plt-data-directory) "/data"))
+
(define (make-log! filename)
(submit-job!
test-workers
(lambda ()
- (apply
- system*/exit-code
- (path->string
- (build-path (plt-directory) "plt" "bin" "mzscheme"))
- "-t"
- (path->string (build-path (drdr-directory) "time-file.ss"))
- "--"
- (append
- (if history?
- (list "-H")
- (list "-r" (number->string start-revision)))
- (list
- (path->string filename))))
+ (define prefix
+ (path-timing-png-prefix filename))
+ (unless just-graphs?
+ (apply
+ system*/exit-code
+ (path->string
+ (build-path (plt-directory) "plt" "bin" "mzscheme"))
+ "-t"
+ (path->string (build-path (drdr-directory) "time-file.ss"))
+ "--"
+ (append
+ (if history?
+ (list "-H")
+ (list "-r" (number->string start-revision)))
+ (list
+ (path->string filename)))))
(system*/exit-code
(path->string
- (build-path (plt-directory) "plt" "bin" "mred"))
+ (build-path (plt-directory) "plt" "bin" "mred-text"))
"-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-png filename))))))
+ (path->string prefix)
+ (path->string (rebaser prefix))
+ (path->string (path-timing-html filename))))))
(define (find-files p l)
(for ([f (in-list (cached-directory-list* p))])