diff --git a/pkgs/racket-benchmarks/info.rkt b/pkgs/racket-benchmarks/info.rkt index 9a3c38bb27..dee520a7a2 100644 --- a/pkgs/racket-benchmarks/info.rkt +++ b/pkgs/racket-benchmarks/info.rkt @@ -8,7 +8,10 @@ "scheme-lib" "racket-test" "typed-racket-lib" - "gui-lib")) + "plot" + "draw-lib" + "gui-lib" + "pict-lib")) (define pkg-desc "Racket benchmarks") (define pkg-authors '(eli jay mflatt robby samth stamourv)) diff --git a/pkgs/racket-benchmarks/mini-bar-plot/bm.rkt b/pkgs/racket-benchmarks/mini-bar-plot/bm.rkt new file mode 100644 index 0000000000..2a9723fff0 --- /dev/null +++ b/pkgs/racket-benchmarks/mini-bar-plot/bm.rkt @@ -0,0 +1,214 @@ +#lang racket/base +(require racket/class + racket/cmdline + racket/path + racket/draw + pict + "main.rkt") + +(module+ main + (define current-dest-file (make-parameter #f)) + (define current-sort (make-parameter #f)) + (define current-mean-wrt (make-parameter #f)) + (define current-rev-inputs (make-parameter null)) + (define current-rev-implementations (make-parameter null)) + + (define inputs + (command-line + #:once-each + [("-o" "--dest") file "Write plot to inferring format from extension" + (current-dest-file file)] + [("--sort-wrt") impl vs-impl "Sort by ratio of to " + (current-sort (cons (string->symbol impl) (string->symbol vs-impl)))] + [("--mean-wrt") impl "Show goemetric mean of ration relative to " + (current-mean-wrt (string->symbol impl))] + #:multi + [("++file") file impl "Load using instead file's recorded " + (let ([impl (string->symbol impl)]) + (current-rev-inputs (cons (input file (lambda (n) impl)) + (current-rev-inputs))))] + [("++bar") impl name color "Set order and colors of bars" + (current-rev-implementations (cons (implementation (string->symbol impl) name color) + (current-rev-implementations)))] + #:args file + (append + (reverse (current-rev-inputs)) + (for/list ([file (in-list file)]) + (input file (lambda (n) n)))))) + + (define p (benchmark-plot inputs + #:implementations (reverse (current-rev-implementations)) + #:sort-by-ratio (current-sort) + #:geometic-mean-wrt (current-mean-wrt))) + + (let ([file (current-dest-file)]) + (cond + [(not file) + (parameterize ([current-command-line-arguments (vector)]) + ((dynamic-require 'slideshow 'slide) (scale p 0.5)))] + [else + (define ext (path-get-extension file)) + (define bm-format + (case ext + [(#".png") 'png] + [(#".jpg" #".jpeg") 'jpeg] + [(#".bmp") 'bmp] + [else #f])) + (cond + [bm-format + (send (pict->bitmap p) save-file file bm-format) + (void)] + [(equal? ext #".pdf") + (define pss (new ps-setup%)) + (send pss set-scaling 1.0 1.0) + (parameterize ([current-ps-setup pss]) + (define dc (new pdf-dc% + [interactive #f] + [as-eps #t] + [width (pict-width p)] + [height (pict-height p)] + [output file])) + (send dc start-doc "plot") + (send dc start-page) + (draw-pict p dc 0 0) + (send dc end-page) + (send dc end-doc))] + [else + (raise-user-error 'bm "could not determine format for output: ~a" file)])]))) + +(struct input (file impl->impl)) +(struct implementation (key name color)) + +(define (benchmark-plot inputs + #:implementations [implementations null] + #:sort-by-ratio [sort-by-ratio/names #f] + #:geometic-mean-wrt [geo-mean-impl #f]) + (define all-timess + (for/fold ([accum #hasheq()]) ([i (in-list inputs)]) + (get-times #:accum accum + (input-file i) + #:impl->impl (input-impl->impl i)))) + + (define med-timess (median-times all-timess)) + + (define given-keys + (for/list ([i (in-list implementations)]) + (implementation-key i))) + + (define keys (append given-keys + (for/list ([k (in-hash-keys med-timess)] + #:unless (member k given-keys)) + k))) + + (define names + (for/list ([k (in-list keys)]) + (or (for/or ([i (in-list implementations)]) + (and (eq? k (implementation-key i)) + (implementation-name i))) + k))) + + (define timess + (for/list ([k (in-list keys)]) + (hash-ref med-timess k))) + + (define colors + (let ([cs (for/list ([i (in-list implementations)]) + (implementation-color i))]) + (append cs + (generate-colors (list-tail keys (length cs)) + #:used cs)))) + + (define (find-key k) + (or (for/or ([a-k (in-list keys)] + [i (in-naturals)]) + (and (eq? k a-k) i)) + (raise-user-error 'bm "sort key not found: ~a" k))) + + (define sort-by-ratio + (and sort-by-ratio/names + (cons (find-key (car sort-by-ratio/names)) + (find-key (cdr sort-by-ratio/names))))) + + (define ((ratio-geo-mean wrt-times) times) + (define sq-ratios + (for/list ([(k v) (in-hash times)]) + (expt (/ v (hash-ref wrt-times k)) 2))) + (hash '|geometric mean| + (sqrt (/ (apply + sq-ratios) (length sq-ratios))))) + + (define (plot timess + #:key->pict [key->pict (lambda (k) #f)]) + (define base (mini-bar-plot names + timess + #:sort-ratio sort-by-ratio + #:columns 6 + #:colors colors + #:key->pict key->pict + #:suffix " msec")) + (cond + [geo-mean-impl + (ht-append (* 2 (current-h-plot-sep)) + (mini-bar-plot names + (map (ratio-geo-mean (hash-ref med-timess geo-mean-impl)) + timess) + #:decimal-places 2 + #:colors colors + #:key->pict (lambda (s) ((current-t) (format "~a" s)))) + base)] + [else base])) + + (define ((filter-times ?) ht) + (for/hasheq ([(k v) (in-hash ht)] + #:when (? k)) + (values k v))) + + (cond + [(ormap r5rs? (hash-keys (car timess))) + (vc-append (current-v-plot-sep) + (plot (map (filter-times (lambda (x) (not (r5rs? x)))) timess)) + (plot (map (filter-times r5rs?) timess) + #:key->pict (lambda (k) + (colorize ((current-tt) (symbol->string k)) r5rs-color))))] + [else (plot timess)])) + +(define (get-times f + #:accum [hts #hasheq()] + #:impl->impl [impl->impl (lambda (impl) impl)]) + (call-with-input-file* + f + (lambda (i) + (for/fold ([hts hts]) ([i (in-port read i)]) + (define impl (impl->impl (car i))) + (define ht (hash-ref hts impl #hasheq())) + (define k (rename (cadr i))) + (define t (caaddr i)) + (define e (hash-ref ht k null)) + (hash-set hts impl (if t + (hash-set ht k (cons t e)) + ht)))))) + +(define (median-times hts) + (define (median l) + (list-ref (sort l <) (quotient (length l) 2))) + (for/hasheq ([(impl ht) (in-hash hts)]) + (values impl + (for/hasheq ([(k e) (in-hash ht)] + #:unless (or (eq? k 'nothing) + (eq? k 'hello))) + (values k (median e)))))) + +(define (rename k) + (hash-ref #hasheq((mandelbrot-generic . mandelbrot-g) + (reversecomplement . reversecomp) + (spectralnorm-generic . spectralnorm-g) + (nbody-vec-generic . nbody-vec-g) + (cheapconcurrency . cheapconcur)) + k + k)) + +(define r5rs-color "forestgreen") + +(define r5rs-keys + '(conform destruct dynamic lattice maze peval psyntax scheme-c scheme-i scheme sort1)) +(define (r5rs? key) (memq key r5rs-keys)) + diff --git a/pkgs/racket-benchmarks/mini-bar-plot/main.rkt b/pkgs/racket-benchmarks/mini-bar-plot/main.rkt new file mode 100644 index 0000000000..b927c88d85 --- /dev/null +++ b/pkgs/racket-benchmarks/mini-bar-plot/main.rkt @@ -0,0 +1,175 @@ +#lang racket/base +(require pict + racket/draw + racket/list + racket/format) + +(provide mini-bar-plot + + current-h-plot-sep + current-v-plot-sep + current-tt + current-t + + generate-colors) + +(define current-h-plot-sep (make-parameter 24)) +(define (current-v-plot-sep) (* 2 (current-h-plot-sep))) + +(define (default-t s) (text s 'swiss 32)) +(define (default-tt s) (text s '(bold . modern) 32)) + +(define current-t (make-parameter default-t)) +(define current-tt (make-parameter default-tt)) + +(define (mini-bar-plot names + timess + #:colors [colors (generate-colors names)] + #:t [t (current-t)] + #:tt [tt (current-tt)] + #:measurement-t [measurement-t tt] + #:bar-t [bar-t t] + #:h-plot-sep [h-plot-sep (current-h-plot-sep)] + #:v-plot-sep [v-plot-sep (* 2 h-plot-sep)] + #:columns [columns 1] + #:bar-sep [bar-sep 0] + #:bar-text-scale [bar-text-scale 0.5] + #:vertical-bars? [vertical-bars? #f] + #:width [W 200] + #:height [H (* 2 bar-text-scale (if vertical-bars? 70 30))] + #:normalize-max? [normalize-max? #f] + #:pin-max? [pin-max? #f] + #:max [starting-max 0] + #:sort-ratio [sort-ratio #f] + #:key->pict [key->pict (lambda (k) #f)] + #:reverse? [reverse? #f] + #:ghost-label [ghost-label #f] + #:details [details (map (lambda (v) #hasheq()) timess)] + #:detail-spec [detail-spec #f] + #:display-scale [display-scale 1] + #:decimal-places [decimal-places 0] + #:fill-vertical? [fill-vertical? #f] + #:widen? [widen? vertical-bars?] + #:pad-left [pad-left 0] + #:prefix [prefix ""] + #:suffix [suffix ""]) + (define keys ((if reverse? reverse values) + (sort (hash-keys (car timess)) + (lambda (a b) + (cond + [sort-ratio + (define (ratio a) + (/ (hash-ref (list-ref timess (car sort-ratio)) a) + (hash-ref (list-ref timess (cdr sort-ratio)) a))) + (< (ratio a) (ratio b))] + [else (symbolpict key) + (measurement-t (~a key))) + (widen + (apply + (if vertical-bars? hb-append vr-append) + bar-sep + (for/list ([name (in-list names)] + [color (in-list colors)] + [times (in-list timess)] + [detail (in-list details)]) + (define time (hash-ref times key)) + ((if vertical-bars? (lambda (sep a b) (vc-append sep b a)) hc-append) + 5 + (let ([l (colorize (if (pict? name) name (t (~a name))) color)]) + (let ([p (if ghost-label + (if vertical-bars? + (ctl-superimpose l (ghost ghost-label)) + (rtl-superimpose l (ghost ghost-label))) + l)]) + (if vertical-bars? + (let ([p2 (scale p (min 1 (/ H (pict-width p))))]) + (cc-superimpose p2 (blank 0 (pict-height p)))) + p))) + (let ([lbl (scale (let ([tp (t (format "~a~a~a" + prefix + (~r (* time display-scale) #:precision decimal-places) + suffix))]) + tp) + 0.5)] + [bar (let ([bar (overlay-detail + (colorize (if vertical-bars? + (filled-rectangle H (* W (/ time (max 1 max-time)))) + (filled-rectangle (* W (/ time (max 1 max-time))) H)) + color) + time detail key)]) + (if (and pin-max? (time . > . max-time)) + (if vertical-bars? + (inset bar 0 (- W (pict-height bar)) 0 0) + (inset bar 0 0 (- W (pict-width bar)) 0)) + bar))]) + (define labelled-bar + ((if vertical-bars? cb-superimpose lb-superimpose) + bar + (inset (colorize lbl "white") + 4))) + ((if vertical-bars? cb-superimpose lt-superimpose) + (pin-under (clip (refocus labelled-bar bar)) + lbl lt-find + (colorize lbl color)) + (if vertical-bars? + (blank H (if fill-vertical? W 0)) + (blank W H))))))))))) + (define (pad plots) + (append plots + (let ([n (remainder (length plots) columns)]) + (if (zero? n) + null + (make-list (- columns n) (blank)))))) + (table columns + (pad plots) + cc-superimpose cc-superimpose + h-plot-sep v-plot-sep)) + +(define (generate-colors names #:used [used '()]) + (define nice-colors (for/list ([c '("red" "blue" "forestgreen" "purple" "orange")] + #:unless (member c used)) + c)) + (define n (length names)) + (define nice-n (length nice-colors)) + (if (n . <= . nice-n) + (take nice-colors n) + (append nice-colors + (for ([i (in-range nice-n n)]) + (make-color (modulo (* i 101) 256) + (modulo (* i 203) 256) + (modulo (* i 53) 256))))))