cs: avoid race with GC in (current-memory-use 'cumulative)
Thanks to Alex Harsanyi for reporting the problem.
This commit is contained in:
parent
4590c51d32
commit
bcfbf2249e
17
pkgs/racket-test/tests/racket/stress/cumulative-memory.rkt
Normal file
17
pkgs/racket-test/tests/racket/stress/cumulative-memory.rkt
Normal file
|
@ -0,0 +1,17 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
;; Check whether `(current-memory-use 'cumulative)` is always increasing
|
||||||
|
|
||||||
|
(define (work n)
|
||||||
|
(length (let loop ([n n])
|
||||||
|
(if (zero? n)
|
||||||
|
'()
|
||||||
|
(cons (make-vector n) (loop (sub1 n)))))))
|
||||||
|
|
||||||
|
(let loop ([n 20000] [u (current-memory-use 'cumulative)])
|
||||||
|
(unless (zero? n)
|
||||||
|
(work (random 1000))
|
||||||
|
(let ([u2 (current-memory-use 'cumulative)])
|
||||||
|
(if (u2 . < . u)
|
||||||
|
(error "oops")
|
||||||
|
(loop (sub1 n) u2)))))
|
|
@ -190,7 +190,8 @@
|
||||||
[(mode)
|
[(mode)
|
||||||
(cond
|
(cond
|
||||||
[(not mode) (bytes-allocated)]
|
[(not mode) (bytes-allocated)]
|
||||||
[(eq? mode 'cumulative) (+ (bytes-deallocated) (bytes-allocated))]
|
[(eq? mode 'cumulative) (with-interrupts-disabled
|
||||||
|
(+ (bytes-deallocated) (bytes-allocated)))]
|
||||||
;; must be a custodian; hook is reposnsible for complaining if not
|
;; must be a custodian; hook is reposnsible for complaining if not
|
||||||
[else (custodian-memory-use mode (bytes-allocated))])]))
|
[else (custodian-memory-use mode (bytes-allocated))])]))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user