/usr/lib/s9fes/runtime-stats.scm is in scheme9 2010.11.13-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 | ; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010
; See the LICENSE file of the S9fES package for terms of use
;
; (runtime-stats procedure <option> ...) ==> list
;
; Measure the runtime of the unary PROCEDURE when applied to
; a range of values (see below) RUNTIME-STATS returns a list
; containing the data it gathered. Each entry of the list has
; the following form:
;
; (value (seconds microsecs) reductions conses nodes gcs)
;
; VALUE is the valued passed to the procedure. The sum of SECONDS
; and MICROSECS is the time the procedure took to complete.
; REDUCTIONS is the number of reductions (i.e.: primitive S9
; operations) that the compuation of the procedure value took.
; CONSES and NODES are the number of cons cells and the total
; amount of storage allocated, respectively. GCs is the number
; of garbage collections performed during the computation.
;
; The following options are used to pass ranges to RUNTIME-STATS:
;
; 'START: INTEGER The smallest value to be measured.
; 'END: INTEGER The largtest value to be measured.
; 'STEP: INTEGER The increment between values.
; 'SET: LIST A set of values.
;
; There options are used to control the output of RUNTIME-STATS:
;
; 'PLOT: SYMBOL Instead of returning the data, plot them.
; SYMBOL is used to specify the field to plot:
; 'VALUE, 'TIME, 'REDUCTIONS, 'CONSES, 'STORAGE
; 'GC.
; 'WIDTH: INTEGER The width and height of the graph printed by
; 'HEIGHT: INTEGER the 'PLOT: option (default: h x w = 77x22 plus
; border).
; 'TABLE: #T Instead of returning the data, print a nicely
; formatted table containing the values.
; 'COMPRESS: #F By default RUNTIME-STATS will compress the curve
; so that the graph will always fill the entire
; X-range. Setting this value to #F will disable
; compression.
;
; (Example): (runtime-stats (lambda (x) (expt 2 x)) 1000 10000 1000)
; ==> (( 1000 (0 23755) 276 96237 97242 0)
; ( 2000 (0 86518) 297 353246 354328 3)
; ( 3000 (0 177415) 322 783333 784501 6)
; ( 4000 (0 301546) 318 1354943 1356102 11)
; ( 5000 (0 477758) 335 2140334 2141561 18)
; ( 6000 (0 681763) 343 2935950 2937195 25)
; ( 7000 (0 923639) 343 4145271 4146516 36)
; ( 8000 (1 180418) 339 5293779 5295015 46)
; ( 9000 (1 519193) 356 6806279 6807583 60)
; (10000 (1 855957) 356 8327850 8329154 73))
(require-extension sys-unix)
(load-from-library "keyword-value.scm")
(load-from-library "char-canvas.scm")
(load-from-library "position.scm")
(load-from-library "count.scm")
(define data-names '(value time reductions conses storage gcs))
(define map-data-ref
(let ((data-names data-names))
(lambda (data what)
(let* ((pos (posq what data-names))
(data (map (lambda (x)
(list-ref x pos))
data)))
(if (eq? 'time what)
(map (lambda (time)
(+ (cadr time)
(* 1000000 (car time))))
data)
data)))))
(define (plot-stats data label height width compr)
(let* ((d-size (length data))
(d-max (apply max data))
(d-min (if compr
(apply min data)
0))
(d-range (max 1 (- d-max d-min)))
(scale (max 1 (quotient d-range (* 10 width))))
(canvas (make-canvas width height (quotient d-range scale) d-size))
(data (map (lambda (x)
(- x d-min))
data))
(data (if (> d-range (* 10 width))
(map (lambda (x)
(quotient x scale))
data)
data)))
(let plot ((px #f)
(py #f)
(x* data)
(y 0))
(if (null? x*)
(let* ((mid (- (quotient width 2) 5))
(line (make-string (+ 2 width) #\-))
(label (symbol->string label))
(s1 (substring line 1 mid))
(s2 (substring line mid (- width
(string-length label)
3)))
(line (string-append s1 " " label " --> " s2)))
(format #t "~A~%" line)
(let* ((bars (make-string height #\|))
(bars (if (>= height 8)
(let* ((mid (- (quotient height 2) 3))
(s1 (substring bars 0 mid))
(s2 (substring bars
(- height mid)
height)))
(string-append s1 "^input" s2))
bars)))
(for-each (lambda (b x)
(format #t "~C~A~2:*~C~1*~%" b x))
(string->list bars)
(vector->list (canvas-dump canvas))))
(format #t "~A" line)
(newline))
(begin (if (not px)
(canvas-plot canvas (car x*) y #\*)
(canvas-plot-line canvas px py (car x*) y #\*))
(plot (car x*) y (cdr x*) (+ 1 y)))))))
(define print-stats
(let ((data-names data-names))
(lambda (data)
(letrec
((digits
(lambda (x)
(let loop ((i 1)
(v 9))
(if (< v x)
(loop (+ 1 i) (+ 9 (* 10 v)))
(+ i (quotient i 3)))))))
(let* ((size #f)
(data* (map (lambda (name)
(map-data-ref data name))
data-names))
(data* (map (lambda (rec)
(map (lambda (x)
(if (pair? x)
(begin (set! size #t)
(count x))
x))
rec))
data*))
(width* (map (lambda (x)
(max 4 (digits (apply max x))))
data*)))
(for-each (lambda (v w)
(format #t "~V@A" (+ 2 w) v))
(list (if size "SIZE" "VAL") "USEC" "REDN" "CONS"
"STOR" "GCS")
width*)
(newline)
(for-each (lambda (v*)
(for-each (lambda (v w)
(format #t "~V:D" (+ 2 w) v))
v*
width*)
(newline))
(transpose data*)))))))
(define (run-stats proc val)
(letrec
((sval->integer
(lambda (sval)
(let loop ((sval sval)
(int 0))
(if (null? sval)
int
(loop (cdr sval)
(+ (* 1000 int)
(car sval)))))))
(seconds
(lambda (t0 tn)
(let ((d (- (car tn) (car t0))))
(if (< (cadr tn) (cadr t0))
(- d 1)
d))))
(useconds
(lambda (t0 tn)
(if (< (cadr tn) (cadr t0))
(- 1000000 (- (cadr t0) (cadr tn)))
(- (cadr tn) (cadr t0))))))
(let* ((t0 (sys:gettimeofday))
(sval* (cdr (stats `(,proc ',val))))
(tn (sys:gettimeofday))
(time (list (seconds t0 tn)
(useconds t0 tn))))
`(,val ,time ,@(map sval->integer sval*)))))
(define runtime-stats
(let ((run-stats run-stats))
(lambda (proc . opts)
(accept-keywords "runtime-stats"
opts
'(start: end: step: set: plot: table:
height: width: compress:))
(let* ((start (keyword-value opts 'start: 1))
(end (keyword-value opts 'end: 10))
(step (keyword-value opts 'step: 1))
(set (keyword-value opts 'set: #f))
(plot (keyword-value opts 'plot: #f))
(height (keyword-value opts 'height: 22))
(width (keyword-value opts 'width: 77))
(table (keyword-value opts 'table: #f))
(compr (keyword-value opts 'compress: #t))
(data (if set
(let loop ((set set)
(res '()))
(if (null? set)
(reverse! res)
(loop (cdr set)
(cons (run-stats proc (car set))
res))))
(let loop ((i start)
(res '()))
(if (> i end)
(reverse! res)
(loop (+ i step)
(cons (run-stats proc i)
res)))))))
(cond (plot
(plot-stats (map-data-ref data plot)
plot
height
width
compr))
(table
(print-stats data))
(else
data))))))
|