Skip to content

Commit

Permalink
adjust timing tests (#758)
Browse files Browse the repository at this point in the history 
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.
  • Loading branch information
@mflatt
mflatt authored Nov 17, 2023
1 parent 49bc6bd commit 0274e27
Show file tree
Hide file tree
Showing 6 changed files with 115 additions and 66 deletions.
20 changes: 12 additions & 8 deletions mats/4.ms
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4369,26 +4369,30 @@
;; 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)
g
(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
Expand Down Expand Up @@ -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))
Expand Down
42 changes: 32 additions & 10 deletions mats/5_1.ms
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)])
Expand All @@ -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))

Expand All @@ -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?
Expand All @@ -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))
)
Expand Down
5 changes: 3 additions & 2 deletions mats/6.ms
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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?)
Expand Down
16 changes: 11 additions & 5 deletions mats/8.ms
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
3 changes: 2 additions & 1 deletion mats/mat.ss
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
95 changes: 55 additions & 40 deletions mats/thread.ms
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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])
Expand Down Expand Up @@ -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 ()
Expand Down

0 comments on commit 0274e27

Please sign in to comment.