suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Chez Scheme: fix race in a test

Browse Source
This commit is contained in:
Matthew Flatt 2020-10-23 08:28:55 -06:00
parent 614992a65c
commit 9caa0554bc
1 changed files with 40 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
racket/src/ChezScheme/mats/misc.ms
View File

@ -1108,49 +1108,49 @@
(let loop () (let loop ()
(unless (check) (unless (check)
(sleep (make-time 'time-duration 10000 0)) (sleep (make-time 'time-duration 10000 0))
(loop))))] (loop))))])
[th (fork-thread
(lambda ()
(let ([bstr (make-bytevector N)])
(box-cas! ready #f 'go)
;; Block so that thread becomes deactivated
(mutex-acquire m)
(mutex-release m)
;; bstr is retained in the thread's continuation until here
(set-box! saved (bytevector-u8-ref bstr 0))
(pause-until (lambda () (box-cas! ready 'finish 'done)))
;; Block so that thread becomes deactivated, again
(mutex-acquire m)
(mutex-release m))))])
(mutex-acquire m) (mutex-acquire m)
;; Wait for thread to start (let ([th (fork-thread
(pause-until (lambda () (eq? 'go (unbox ready)))) (lambda ()
;; Wait for thread to become inactive, blocked on the mutex (let ([bstr (make-bytevector N)])
(pause-until (lambda () (= 1 (#%$top-level-value '$active-threads)))) (box-cas! ready #f 'go)
;; Get thread's size, which should include bstr ;; Block so that thread becomes deactivated
(let ([pre-sizes (compute-size-increments (list th))]) (mutex-acquire m)
(mutex-release m) (mutex-release m)
;; Wait for bytevector to be discarded in the thread ;; bstr is retained in the thread's continuation until here
(pause-until (lambda () (unbox saved))) (set-box! saved (bytevector-u8-ref bstr 0))
(mutex-acquire m) (pause-until (lambda () (box-cas! ready 'finish 'done)))
(set-box! ready 'finish) ;; Block so that thread becomes deactivated, again
;; Wait for thread to become inactive again (mutex-acquire m)
(mutex-release m))))])
;; Wait for thread to start
(pause-until (lambda () (eq? 'go (unbox ready))))
;; Wait for thread to become inactive, blocked on the mutex
(pause-until (lambda () (= 1 (#%$top-level-value '$active-threads)))) (pause-until (lambda () (= 1 (#%$top-level-value '$active-threads))))
;; Get thread's size, which should'nt include bstr ;; Get thread's size, which should include bstr
(let ([post-sizes (compute-size-increments (list th))]) (let ([pre-sizes (compute-size-increments (list th))])
(mutex-release m) (mutex-release m)
;; Wait for thread to exit ;; Wait for bytevector to be discarded in the thread
(let () (pause-until (lambda () (unbox saved)))
(define $threads (foreign-procedure "(cs)threads" () scheme-object)) (mutex-acquire m)
(pause-until (lambda () (= 1 (length ($threads)))))) (set-box! ready 'finish)
;; Make sure `compute-size-increments` doesn't crash on a ;; Wait for thread to become inactive again
;; terminated thread: (pause-until (lambda () (= 1 (#%$top-level-value '$active-threads))))
(compute-size-increments (list th)) ;; Get thread's size, which shouldn't include bstr
;; Main result: detected size of `bstr` in the thread (let ([post-sizes (compute-size-increments (list th))])
;; while it was part of the continuation (mutex-release m)
(or (eq? (current-eval) interpret) ; interpreter continuaton is not precise enough ;; Wait for thread to exit
(and (> (car pre-sizes) N) (let ()
(< (car post-sizes) N))))))) (define $threads (foreign-procedure "(cs)threads" () scheme-object))
(pause-until (lambda () (= 1 (length ($threads))))))
;; Make sure `compute-size-increments` doesn't crash on a
;; terminated thread:
(compute-size-increments (list th))
;; Main result: detected size of `bstr` in the thread
;; while it was part of the continuation
(or (eq? (current-eval) interpret) ; interpreter continuation is not precise enough
(and (> (car pre-sizes) N)
(< (car post-sizes) N))))))))
) )
(mat collect+compute-size-increments (mat collect+compute-size-increments