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

cs & thread: add missing check on thread-suspend

Browse Source 
Also, fix non-atomic check for shut-down custodian in `thread-resume`.

Closes #3660
This commit is contained in:
Matthew Flatt 2021-01-29 07:00:33 -07:00
parent b55f268510
commit f685a27b41
3 changed files with 178 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/racket-test-core/tests/racket/thread.rktl
View File

@ -1275,6 +1275,22 @@
(test #f thread-running? t1)
(test #f thread-running? t2))
;; Attempting to shut down a thread without the managing custodian
(let ([t (thread (lambda () (sync (make-semaphore))))])
(parameterize ([current-custodian (make-custodian)])
(err/rt-test (thread-suspend t) exn:fail:contract? #rx"does not solely manage")))
(let ([c1 (make-custodian)]
[c2 (make-custodian)])
(define t (parameterize ([current-custodian c1])
(thread (lambda () (sync (make-semaphore))))))
(thread-resume t c2)
(parameterize ([current-custodian c1])
(err/rt-test (thread-suspend t) exn:fail:contract? #rx"does not solely manage"))
(parameterize ([current-custodian c2])
(err/rt-test (thread-suspend t) exn:fail:contract? #rx"does not solely manage"))
(test (void) thread-suspend t))
;; ----------------------------------------
;; plumbers

119
racket/src/cs/schemified/thread.scm
View File

@ -6935,38 +6935,7 @@
(if (1/thread? t_0)
(void)
(raise-argument-error 'kill-thread "thread?" t_0))
(if (let ((lst_0 (thread-custodian-references t_0)))
(begin
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (result_0 lst_1)
(begin
(if (pair? lst_1)
(let ((cr_0 (unsafe-car lst_1)))
(let ((rest_0 (unsafe-cdr lst_1)))
(let ((result_1
(let ((result_1
(custodian-manages-reference?
(1/current-custodian)
cr_0)))
(values result_1))))
(if (if (not
(let ((x_0 (list cr_0)))
(not result_1)))
#t
#f)
(for-loop_0 result_1 rest_0)
result_1))))
result_0))))))
(for-loop_0 #t lst_0))))
(void)
(raise-arguments-error
'kill-thread
"the current custodian does not solely manage the specified thread"
"thread"
t_0))
(check-current-custodian-manages 'kill-thread t_0)
(if (thread-suspend-to-kill? t_0)
(|#%app|
(begin
@ -7019,6 +6988,41 @@
(do-thread-suspend t_0)
(do-kill-thread t_0))
(void))))))
(define check-current-custodian-manages
(lambda (who_0 t_0)
(let ((c_0 (1/current-custodian)))
(if (let ((lst_0 (thread-custodian-references t_0)))
(begin
(letrec*
((for-loop_0
(|#%name|
for-loop
(lambda (result_0 lst_1)
(begin
(if (pair? lst_1)
(let ((cr_0 (unsafe-car lst_1)))
(let ((rest_0 (unsafe-cdr lst_1)))
(let ((result_1
(let ((result_1
(custodian-manages-reference?
c_0
cr_0)))
(values result_1))))
(if (if (not
(let ((x_0 (list cr_0)))
(not result_1)))
#t
#f)
(for-loop_0 result_1 rest_0)
result_1))))
result_0))))))
(for-loop_0 #t lst_0))))
(void)
(raise-arguments-error
who_0
"the current custodian does not solely manage the specified thread"
"thread"
t_0)))))
(define thread-representative-custodian
(lambda (t_0)
(begin
@ -7258,6 +7262,7 @@
(if (1/thread? t_0)
(void)
(raise-argument-error 'thread-suspend "thread?" t_0))
(check-current-custodian-manages 'thread-suspend t_0)
(|#%app|
(begin
(start-atomic)
@ -7308,20 +7313,18 @@
'thread-resume
"(or/c #f thread? custodian?)"
benefactor14_0))
(if (if (1/custodian? benefactor14_0)
(1/custodian-shut-down? benefactor14_0)
#f)
(if (begin
(start-atomic)
(begin0
(do-thread-resume t15_0 benefactor14_0)
(end-atomic)))
(void)
(begin-unsafe
(raise-arguments-error
'thread-resume
"the custodian has been shut down"
"custodian"
benefactor14_0))
(void))
(start-atomic)
(begin0
(do-thread-resume t15_0 benefactor14_0)
(end-atomic))))))))
benefactor14_0)))))))))
(|#%name|
thread-resume
(case-lambda
@ -7330,8 +7333,11 @@
(define do-thread-resume
(lambda (t_0 benefactor_0)
(if (1/thread-dead? t_0)
(void)
(begin
(not
(if (1/custodian? benefactor_0)
(1/custodian-shut-down? benefactor_0)
#f))
(let ((add-ok?_0
(if (1/thread? benefactor_0)
(begin
(let ((lst_0 (thread-custodian-references benefactor_0)))
@ -7353,10 +7359,12 @@
(values)))))))
(for-loop_0 lst_0))))
(void)
(add-transitive-resume-to-thread! benefactor_0 t_0))
(add-transitive-resume-to-thread! benefactor_0 t_0)
#t)
(if (1/custodian? benefactor_0)
(add-custodian-to-thread! t_0 benefactor_0)
(void)))
#t))))
(begin
(if (if (thread-suspended? t_0)
(pair? (thread-custodian-references t_0))
#f)
@ -7365,14 +7373,16 @@
(if resumed-evt_0
(begin
(set-suspend-resume-evt-thread! resumed-evt_0 t_0)
(semaphore-post-all (suspend-resume-evt-sema resumed-evt_0))
(semaphore-post-all
(suspend-resume-evt-sema resumed-evt_0))
(set-thread-resumed-evt! t_0 #f))
(void))
(set-thread-suspended?! t_0 #f)
(run-suspend/resume-callbacks t_0 cdr)
(thread-reschedule! t_0)
(do-resume-transitive-resumes t_0 #f)))
(void))))))
(void))
add-ok?_0)))))
(define add-custodian-to-thread!
(lambda (t_0 c_0)
(letrec*
@ -7382,24 +7392,25 @@
(lambda (crs_0 accum_0)
(begin
(if (null? crs_0)
(let ((new-crs_0
(cons
(let ((cr_0
(1/unsafe-custodian-register
c_0
t_0
remove-thread-custodian
#f
#t)
accum_0)))
#t)))
(if (not cr_0)
#f
(begin
(set-thread-custodian-references! t_0 new-crs_0)
(do-resume-transitive-resumes t_0 c_0)))
(set-thread-custodian-references! t_0 (cons cr_0 accum_0))
(do-resume-transitive-resumes t_0 c_0)
#t)))
(let ((old-c_0 (custodian-reference->custodian (car crs_0))))
(if (let ((or-part_0 (eq? c_0 old-c_0)))
(if or-part_0
or-part_0
(custodian-subordinate? c_0 old-c_0)))
(void)
#t
(if (custodian-subordinate? old-c_0 c_0)
(loop_0 (cdr crs_0) accum_0)
(let ((app_0 (cdr crs_0)))

61
racket/src/thread/thread.rkt
View File

@ -294,11 +294,7 @@
(define/who (kill-thread t)
(check who thread? t)
(unless (for/and ([cr (in-list (thread-custodian-references t))])
(custodian-manages-reference? (current-custodian) cr))
(raise-arguments-error who
"the current custodian does not solely manage the specified thread"
"thread" t))
(check-current-custodian-manages who t)
(cond
[(thread-suspend-to-kill? t)
((atomically
@ -333,6 +329,14 @@
[else
(do-kill-thread t)])))
(define (check-current-custodian-manages who t)
(define c (current-custodian))
(unless (for/and ([cr (in-list (thread-custodian-references t))])
(custodian-manages-reference? c cr))
(raise-arguments-error who
"the current custodian does not solely manage the specified thread"
"thread" t)))
(define (thread-representative-custodian t)
(atomically
(define cs (thread-custodian-references t))
@ -483,6 +487,7 @@
(define/who (thread-suspend t)
(check who thread? t)
(check-current-custodian-manages who t)
((atomically
(do-thread-suspend t))))
@ -520,23 +525,31 @@
(check who (lambda (p) (or (not p) (thread? p) (custodian? p)))
#:contract "(or/c #f thread? custodian?)"
benefactor)
(when (and (custodian? benefactor)
(custodian-shut-down? benefactor))
(raise-custodian-is-shut-down who benefactor))
(atomically
(do-thread-resume t benefactor)))
(unless (atomically
(do-thread-resume t benefactor))
(raise-custodian-is-shut-down who benefactor)))
;; in atomic mode
;; returns #f if `benefactor` is a shut-down custodian
(define (do-thread-resume t benefactor)
(assert-atomic-mode)
(unless (thread-dead? t)
(cond
[(thread-dead? t)
;; not resuming thread, but still potentially report whether the
;; given custodian is shutdown
(not (and (custodian? benefactor)
(custodian-shut-down? benefactor)))]
[else
(define add-ok?
(cond
[(thread? benefactor)
(for ([cr (in-list (thread-custodian-references benefactor))])
(add-custodian-to-thread! t (custodian-reference->custodian cr)))
(add-transitive-resume-to-thread! benefactor t)]
(add-transitive-resume-to-thread! benefactor t)
#t]
[(custodian? benefactor)
(add-custodian-to-thread! t benefactor)])
(add-custodian-to-thread! t benefactor)]
[else #t]))
(when (and (thread-suspended? t)
(pair? (thread-custodian-references t)))
(define resumed-evt (thread-resumed-evt t))
@ -547,27 +560,33 @@
(set-thread-suspended?! t #f)
(run-suspend/resume-callbacks t cdr)
(thread-reschedule! t)
(do-resume-transitive-resumes t #f))))
(do-resume-transitive-resumes t #f))
add-ok?]))
;; in atomic mode
;; returns #f if `benefactor` is a shut-down custodian
(define (add-custodian-to-thread! t c)
(assert-atomic-mode)
(let loop ([crs (thread-custodian-references t)]
[accum null])
(cond
[(null? crs)
(define new-crs
(cons (unsafe-custodian-register c t remove-thread-custodian #f #t)
accum))
(set-thread-custodian-references! t new-crs)
(do-resume-transitive-resumes t c)]
(define cr (unsafe-custodian-register c t remove-thread-custodian #f #t))
(cond
[(not cr)
;; add failed due to shut-down custodian
#f]
[else
(set-thread-custodian-references! t (cons cr accum))
(do-resume-transitive-resumes t c)
#t])]
[else
(define old-c (custodian-reference->custodian (car crs)))
(cond
[(or (eq? c old-c)
(custodian-subordinate? c old-c))
;; no need to add new
(void)]
;; no need to add new (and apparently not shut down)
#t]
[(custodian-subordinate? old-c c)
;; new one replaces old one; we can simplify forget the
;; old reference