|
| 1 | +#lang racket/base |
| 2 | + |
| 3 | +(require data/monocle |
| 4 | + json |
| 5 | + net/http-easy |
| 6 | + plot |
| 7 | + racket/date |
| 8 | + racket/format |
| 9 | + racket/list |
| 10 | + racket/match |
| 11 | + racket/promise |
| 12 | + racket/runtime-path |
| 13 | + rackunit |
| 14 | + threading |
| 15 | + (only-in web-server/http make-header response/full) |
| 16 | + "private/common.rkt") |
| 17 | + |
| 18 | +(provide |
| 19 | + benchmarks) |
| 20 | + |
| 21 | +(define-runtime-path benchmarks.json |
| 22 | + "benchmarks.json") |
| 23 | + |
| 24 | +(define (~machine) |
| 25 | + (string->symbol |
| 26 | + (format |
| 27 | + "Racket ~a ~a (~a ~a) [~a]" |
| 28 | + (system-type 'vm) |
| 29 | + (version) |
| 30 | + (system-type 'os*) |
| 31 | + (system-type 'arch) |
| 32 | + (system-type 'machine)))) |
| 33 | + |
| 34 | +(define (keep lst n) |
| 35 | + (take lst (min (length lst) n))) |
| 36 | + |
| 37 | +(define (read-benchmarks) |
| 38 | + (with-handlers ([exn:fail:filesystem? (λ (_) (hash))]) |
| 39 | + (call-with-input-file benchmarks.json read-json))) |
| 40 | + |
| 41 | +(define (write-benchmarks benchmarks) |
| 42 | + (call-with-output-file benchmarks.json |
| 43 | + #:exists 'truncate/replace |
| 44 | + (lambda (out) |
| 45 | + (write-json |
| 46 | + #:indent 2 |
| 47 | + benchmarks out)))) |
| 48 | + |
| 49 | +(define (plot-results name) |
| 50 | + (define machine (~machine)) |
| 51 | + (define benchmarks |
| 52 | + (~> (read-benchmarks) |
| 53 | + ((&opt-hash-ref* machine name)) |
| 54 | + (or null) |
| 55 | + (sort > #:key (λ (ht) (hash-ref ht 'timestamp))) |
| 56 | + (keep 5) |
| 57 | + (reverse))) |
| 58 | + (parameterize ([plot-y-label "Time (ms)"] |
| 59 | + [plot-x-label "Measurements"]) |
| 60 | + (plot-pict |
| 61 | + #:title (~a name) |
| 62 | + (for/list ([(bench idx) (in-indexed (in-list benchmarks))]) |
| 63 | + (define timestamp |
| 64 | + (hash-ref bench 'timestamp)) |
| 65 | + (discrete-histogram |
| 66 | + #:label (date->string (seconds->date timestamp) #t) |
| 67 | + #:line-color (add1 idx) |
| 68 | + #:color (add1 idx) |
| 69 | + #:x-min (add1 idx) |
| 70 | + #:skip (+ (length benchmarks) 0.5) |
| 71 | + (list |
| 72 | + (list "Real" (hash-ref bench 'real-time)) |
| 73 | + (list "CPU" (hash-ref bench 'cpu-time)) |
| 74 | + (list "GC" (hash-ref bench 'gc-time)))))))) |
| 75 | + |
| 76 | +(define (delete-benchmark name) |
| 77 | + (define machine (~machine)) |
| 78 | + (define benchmarks (read-benchmarks)) |
| 79 | + (define &benchmark (&opt-hash-ref* machine name)) |
| 80 | + (write-benchmarks (&benchmark benchmarks #f))) |
| 81 | + |
| 82 | +(define-check (check-benchmark name tolerance proc) |
| 83 | + (define timestamp (current-seconds)) |
| 84 | + (define machine (~machine)) |
| 85 | + (sync (system-idle-evt)) |
| 86 | + (collect-garbage) |
| 87 | + (collect-garbage) |
| 88 | + (define-values (_ cpu-time real-time gc-time) |
| 89 | + (time-apply proc null)) |
| 90 | + (define benchmarks |
| 91 | + (read-benchmarks)) |
| 92 | + (define &benchmark |
| 93 | + (&opt-hash-ref* machine name)) |
| 94 | + (define existing-benchmarks |
| 95 | + (or (&benchmark benchmarks) null)) |
| 96 | + (unless (null? existing-benchmarks) |
| 97 | + (match-define |
| 98 | + (hash* ['real-time old-real-time] |
| 99 | + ['cpu-time old-cpu-time] |
| 100 | + ['gc-time old-gc-time]) |
| 101 | + (car existing-benchmarks)) |
| 102 | + (when (or (> cpu-time (* old-cpu-time tolerance)) |
| 103 | + (> real-time (* old-real-time tolerance)) |
| 104 | + (> gc-time (* old-gc-time tolerance))) |
| 105 | + (fail-check |
| 106 | + (string-append |
| 107 | + (format "benchmark ~a failed~n" name) |
| 108 | + (format " cpu time: ~s (was: ~s; slowdown: ~a)~n" cpu-time old-cpu-time (~slowdown cpu-time old-cpu-time)) |
| 109 | + (format " real time: ~s (was: ~s; slowdown: ~a)~n" real-time old-real-time (~slowdown real-time old-real-time)) |
| 110 | + (format " gc time: ~s (was: ~s; slowdown: ~a)" gc-time old-gc-time (~slowdown gc-time old-gc-time)))))) |
| 111 | + (write-benchmarks |
| 112 | + (&benchmark |
| 113 | + benchmarks |
| 114 | + (cons |
| 115 | + (hasheq |
| 116 | + 'timestamp timestamp |
| 117 | + 'real-time real-time |
| 118 | + 'cpu-time cpu-time |
| 119 | + 'gc-time gc-time) |
| 120 | + (keep existing-benchmarks 49))))) |
| 121 | + |
| 122 | +(define (~slowdown current old) |
| 123 | + (define % (if (zero? old) 1.0 (/ current old))) |
| 124 | + (~a (~r #:precision '(= 2) (* % 100)) "%")) |
| 125 | + |
| 126 | +(define (handle-OK _req) |
| 127 | + (response/full |
| 128 | + #;code 200 |
| 129 | + #;message #"OK" |
| 130 | + #;seconds (current-seconds) |
| 131 | + #;mime #"text/plain" |
| 132 | + #;headers (list (make-header #"Content-Length" #"2")) |
| 133 | + #;body (list #"OK"))) |
| 134 | + |
| 135 | +(define benchmarks |
| 136 | + (test-suite |
| 137 | + "http-easy" |
| 138 | + |
| 139 | + (test-suite |
| 140 | + "benchmarks" |
| 141 | + |
| 142 | + (test-case "sequential GETs" |
| 143 | + (call-with-web-server |
| 144 | + handle-OK |
| 145 | + (lambda (addr) |
| 146 | + (parameterize ([current-session (make-session)]) |
| 147 | + (check-benchmark |
| 148 | + 'sequential-GET 1.20 |
| 149 | + (lambda () |
| 150 | + (for ([_ (in-range 10000)]) |
| 151 | + (get addr)))) |
| 152 | + (session-close! (current-session)))))) |
| 153 | + |
| 154 | + (test-case "concurrent GETs" |
| 155 | + (call-with-web-server |
| 156 | + handle-OK |
| 157 | + (lambda (addr) |
| 158 | + (define sema (make-semaphore 3)) |
| 159 | + (parameterize ([current-session (make-session)]) |
| 160 | + (check-benchmark |
| 161 | + 'concurrent-GET 1.10 |
| 162 | + (lambda () |
| 163 | + (define promises |
| 164 | + (for/list ([_ (in-range 10000)]) |
| 165 | + (delay/thread |
| 166 | + (call-with-semaphore sema |
| 167 | + (lambda () |
| 168 | + (get addr)))))) |
| 169 | + (for-each force promises))) |
| 170 | + (session-close! (current-session))))))))) |
| 171 | + |
| 172 | +(module+ test |
| 173 | + (require rackunit/text-ui) |
| 174 | + (run-tests benchmarks)) |
| 175 | + |
| 176 | +(module+ main |
| 177 | + (require pict) |
| 178 | + (hc-append |
| 179 | + (plot-results 'sequential-GET) |
| 180 | + (plot-results 'concurrent-GET))) |
0 commit comments