From 0274e27768f230d0c2e1d17241c744d6b0861011 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Nov 2023 06:38:10 -0700 Subject: [PATCH] adjust timing tests (#758) For tests that involve time: use CPU time whenever possible, retry tests that unavoidably involve real time, and and scale an expected upper limit on CPU time by timing a baseline calculation. Also, scale down a test that pushes memory use to 1.7GB on a 64-bit machine, bringing peak memory down below 500MB. --- mats/4.ms | 20 ++++++----- mats/5_1.ms | 42 ++++++++++++++++------ mats/6.ms | 5 +-- mats/8.ms | 16 ++++++--- mats/mat.ss | 3 +- mats/thread.ms | 95 +++++++++++++++++++++++++++++--------------------- 6 files changed, 115 insertions(+), 66 deletions(-) diff --git a/mats/4.ms b/mats/4.ms index c0e18a018..c303ebaf7 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -4369,11 +4369,14 @@ ;; report how long a collection takes averaged ;; over `iters` tries (define iters 10) - (let loop ([g #f] [accum 0] [j iters]) + (let loop ([g #f] [accum 0] [j iters] [iters-mult 1]) (if (zero? j) (if (zero? accum) - g - (/ accum iters)) + ;; more iterations to get non-0 CPU time: + (loop g accum iters (add1 iters-mult)) + (begin + (keep-live g) + (/ accum (* iters iters-mult)))) (let ([g (let loop ([i n]) (let ([g (make-guardian ordered?)]) (if (zero? i) @@ -4381,14 +4384,15 @@ (let ([next-g (loop (sub1 i))]) (g (get-key next-g) next-g) g))))]) - (let ([start (current-time)]) + (let ([start (current-time 'time-process)]) (collect (collect-maximum-generation)) - (let ([delta (time-difference (current-time) start)]) + (let ([delta (time-difference (current-time 'time-process) start)]) (loop g (+ accum (* (time-second delta) 1e9) (time-nanosecond delta)) - (sub1 j)))))))) + (sub1 j) + iters-mult))))))) ;; Make sure guardian chains imply GC times that ;; look linear, as opposed to quadratic @@ -4948,11 +4952,11 @@ (collect 2) (let*-values ([(key es) (mk n (gensym) '())] [(root holds) (mk* n key es)]) - (let ([start (current-time)]) + (let ([start (current-time 'time-process)]) (collect 0 1) (collect 1 2) (collect 2 2) - (let ([delta (time-difference (current-time) start)]) + (let ([delta (time-difference (current-time 'time-process) start)]) ;; Sanity check on ephemerons (for-each (lambda (e) (when (eq? #!bwp (ephemeron-key e)) diff --git a/mats/5_1.ms b/mats/5_1.ms index f354f24de..281247da0 100644 --- a/mats/5_1.ms +++ b/mats/5_1.ms @@ -492,6 +492,34 @@ (time (equal? (make-x 100) y))) ; tests that stress corrected SRFI 85 implementation + (begin + (define $ok-comparison-duration? + (let () + (define (duration->inexact t) (+ (* (time-second t) 1e9) + (inexact (time-nanosecond t)))) + (let* ([baseline + ;; measure a loop to use as a scale + (let* ([t0 (current-time 'time-process)] + [l1 (list (current-time) (current-time))] + [l2 (list (car l1) (cadr l1))] + [init-i 1000]) + (let f ([i init-i] [iters 1] [x #t]) + (if (fx= i 0) + (and x + (let ([n (/ (duration->inexact (time-difference (current-time 'time-process) t0)) + iters)]) + (if (zero? n) + ;; more iterations to get a non-0 CPU time + (f init-i (add1 iters) #t) + n))) + (f (fx- i 1) iters (and x (equal? l1 l2))))))] + ;; scale to a machine where hardwired `nsec`s make sense: + [scale (/ baseline 20000.0)]) + (lambda (t0 t nsec) + (< (duration->inexact (time-difference t t0)) + (* nsec scale)))))) + #t) + (or (equal? (let ([v1 '#200=(#200#)] [v2 '#201=(#201#)]) (let ([t0 (current-time 'time-process)]) @@ -502,9 +530,7 @@ (list ans (let ([t (current-time 'time-process)]) - (< (+ (* (- (time-second t) (time-second t0)) 1000000000) - (- (time-nanosecond t) (time-nanosecond t0))) - 30000000)))))) + ($ok-comparison-duration? t0 t 30000000)))))) '(#t #t)) (#%$enable-check-heap)) @@ -516,10 +542,8 @@ (list ans (let ([t (current-time 'time-process)]) - (> (+ (* (- (time-second t) (time-second t0)) 1000000000) - (- (time-nanosecond t) (time-nanosecond t0))) - 100000000)))))) - '(#t #f)) + ($ok-comparison-duration? t0 t 100000000)))))) + '(#t #t)) (#%$enable-check-heap)) (or (equal? @@ -534,9 +558,7 @@ (let ([t (current-time 'time-process)]) (list ans - (< (+ (* (- (time-second t) (time-second t0)) 1000000000) - (- (time-nanosecond t) (time-nanosecond t0))) - 200000000)))))))) + ($ok-comparison-duration? t0 t 200000000)))))))) '(#t #t)) (#%$enable-check-heap)) ) diff --git a/mats/6.ms b/mats/6.ms index 8fef13bbd..ea25fd6c1 100644 --- a/mats/6.ms +++ b/mats/6.ms @@ -1052,7 +1052,8 @@ (mat fasl-depth (begin - (define fasl-deep-N 100000) + (define fasl-deep-N 100000) ; large to overflow even on a big C stack + (define fasl-code-deep-N 10000) ; smaller to avoid excessive memory use (define (check v) (let-values ([(o get) (open-bytevector-output-port)]) (fasl-write v o) @@ -1080,7 +1081,7 @@ (compile-to-port (list `(lambda () - ,(let loop ([n fasl-deep-N]) + ,(let loop ([n fasl-code-deep-N]) (if (zero? n) ''end `(if (stop?) diff --git a/mats/8.ms b/mats/8.ms index fdebe1c57..449b31546 100644 --- a/mats/8.ms +++ b/mats/8.ms @@ -11881,11 +11881,17 @@ 'truncate) (collect) (parameterize ([collect-request-handler void]) - (let ([start (current-time)]) - (load "testfile.ss" expand) - (let ([delta (time-difference (current-time) start)]) - (+ (* #e1e9 (time-second delta)) - (time-nanosecond delta)))))) + (let ([start (current-time 'time-process)]) + (let loop ([iters 1]) + (load "testfile.ss" expand) + (let ([delta (time-difference (current-time 'time-process) start)]) + (let ([n (/ (+ (* #e1e9 (time-second delta)) + (time-nanosecond delta)) + iters)]) + (if (zero? n) + ;; more iterations to get a non-0 time + (loop (add1 iters)) + n))))))) (let loop ([tries 3]) (when (zero? tries) diff --git a/mats/mat.ss b/mats/mat.ss index 63e3e8671..4c96d4fbe 100644 --- a/mats/mat.ss +++ b/mats/mat.ss @@ -258,7 +258,8 @@ (if universe-ct (let-values ([(ct . ignore) (with-profile-tracker go)]) (store-coverage universe-ct ct (format "~a.covout" mat))) - (go)))) + (go)) + (printf "\npeak memory use: ~s\n" (maximum-memory-bytes)))) (lambda () (close-output-port (mat-output)))))))))) (set! record-run-coverage diff --git a/mats/thread.ms b/mats/thread.ms index 89ffb00ab..9ad989c00 100644 --- a/mats/thread.ms +++ b/mats/thread.ms @@ -106,6 +106,16 @@ (let ([t (time-difference stop start)]) (<= (abs (- (+ (time-second t) (* (time-nanosecond t) 1e-9)) target)) 0.2)))) + (define-syntax $retry-for-timing + ;; timing tests can go wrong, especially on a share machine like + ;; one for CI, so try a few times to reduce the chance of + ;; failure due to a real-time delay + (lambda (stx) + (syntax-case stx () + [(_ e) #'(let loop ([n 5]) + (or e + (and (> n 0) + (loop (- n 1)))))]))) (andmap procedure? (list $threads $fib $thread-check $time-in-range?))) ($thread-check) (not (= (let ([n #f]) @@ -157,46 +167,51 @@ (or (equal? result '(196418 317811 514229 832040 1346269 2178309)) (errorf #f "result=~s" result))) ($thread-check) - (let ([m (make-mutex)] [c (make-condition)]) - (with-mutex m - (let* ([start (current-time)] - [r (condition-wait c m (make-time 'time-duration 250000000 1))] - [stop (current-time)]) - (and (not r) - ($time-in-range? start stop 1.25))))) - (let ([m (make-mutex)] [c (make-condition)]) - (with-mutex m - (let* ([start (current-time)] - [r (condition-wait c m - (add-duration start (make-time 'time-duration 250000000 1)))] - [stop (current-time)]) - (and (not r) - ($time-in-range? start stop 1.25))))) - (let ([m (make-mutex)] [c (make-condition)]) - (with-mutex m - (let* ([start (current-time)] - [r (condition-wait c m (make-time 'time-duration 0 -1))] - [stop (current-time)]) - (and (not r) - ($time-in-range? start stop 0.0))))) - (let ([m (make-mutex)] [c (make-condition)]) - (with-mutex m - (let* ([start (current-time)] - [r (condition-wait c m - (add-duration start (make-time 'time-duration 0 -1)))] - [stop (current-time)]) - (and (not r) - ($time-in-range? start stop 0.0))))) - (let ([m (make-mutex)] [c (make-condition)]) - (with-mutex m - (fork-thread - (lambda () - (with-mutex m (sleep (make-time 'time-duration 250000000 0))))) - (let* ([start (current-time)] - [r (condition-wait c m (make-time 'time-duration 100000000 0))] - [stop (current-time)]) - (and (not r) - ($time-in-range? start stop 0.25))))) + ($retry-for-timing + (let ([m (make-mutex)] [c (make-condition)]) + (with-mutex m + (let* ([start (current-time)] + [r (condition-wait c m (make-time 'time-duration 250000000 1))] + [stop (current-time)]) + (and (not r) + ($time-in-range? start stop 1.25)))))) + ($retry-for-timing + (let ([m (make-mutex)] [c (make-condition)]) + (with-mutex m + (let* ([start (current-time)] + [r (condition-wait c m + (add-duration start (make-time 'time-duration 250000000 1)))] + [stop (current-time)]) + (and (not r) + ($time-in-range? start stop 1.25)))))) + ($retry-for-timing + (let ([m (make-mutex)] [c (make-condition)]) + (with-mutex m + (let* ([start (current-time)] + [r (condition-wait c m (make-time 'time-duration 0 -1))] + [stop (current-time)]) + (and (not r) + ($time-in-range? start stop 0.0)))))) + ($retry-for-timing + (let ([m (make-mutex)] [c (make-condition)]) + (with-mutex m + (let* ([start (current-time)] + [r (condition-wait c m + (add-duration start (make-time 'time-duration 0 -1)))] + [stop (current-time)]) + (and (not r) + ($time-in-range? start stop 0.0)))))) + ($retry-for-timing + (let ([m (make-mutex)] [c (make-condition)]) + (with-mutex m + (fork-thread + (lambda () + (with-mutex m (sleep (make-time 'time-duration 250000000 0))))) + (let* ([start (current-time)] + [r (condition-wait c m (make-time 'time-duration 100000000 0))] + [stop (current-time)]) + (and (not r) + ($time-in-range? start stop 0.25)))))) (let ([count 300] [live 0] [live-m (make-mutex)]) (parameterize ([collect-request-handler (lambda ()