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

cs & io: fix atomic-mode step in sync/enable-break

Browse Source
This commit is contained in:
Matthew Flatt 2021-01-08 12:04:18 -07:00
parent a5744bec62
commit f347fe299a
4 changed files with 25 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -7978,12 +7978,15 @@
(hasheq ignore_0 #t bc_0 #t)))))))
(define thread-remove-ignored-break-cell!
(lambda (t_0 bc_0)
(if (thread-ignore-break-cell? t_0 bc_0)
(let ((ignore_0 (thread-ignore-break-cells t_0)))
(set-thread-ignore-break-cells!
t_0
(if (eq? ignore_0 bc_0) #f (hash-remove ignore_0 bc_0))))
(void))))
(begin
(start-atomic)
(if (thread-ignore-break-cell? t_0 bc_0)
(let ((ignore_0 (thread-ignore-break-cells t_0)))
(set-thread-ignore-break-cells!
t_0
(if (eq? ignore_0 bc_0) #f (hash-remove ignore_0 bc_0))))
(void))
(end-atomic))))
(define enqueue-mail!
(lambda (thd_0 v_0) (queue-add! (thread-mailbox thd_0) v_0)))
(define dequeue-mail!

13
racket/src/thread/atomic.rkt
View File

@ -4,7 +4,8 @@
"place-local.rkt"
"internal-error.rkt"
"parameter.rkt"
"debug.rkt")
"debug.rkt"
(for-syntax racket/base))
(provide atomically
current-atomic
@ -145,10 +146,12 @@
(internal-error "not implicitly in atomic mode?"))
(current-implicit-atomic #f))
(define-syntax-rule (assert-atomic-mode)
(unless (or (current-implicit-atomic)
(positive? (current-atomic)))
(internal-error "should be in atomic mode")))]
(define-syntax (assert-atomic-mode stx)
(syntax-case stx ()
[(_)
#`(unless (or (current-implicit-atomic)
(positive? (current-atomic)))
(internal-error #,(format "should be in atomic mode: ~s" stx)))]))]
#:off
[(define-syntax-rule (start-implicit-atomic-mode) (begin))
(define-syntax-rule (end-implicit-atomic-mode) (begin))

1
racket/src/thread/place.rkt
View File

@ -90,6 +90,7 @@
(define host-thread
(host:fork-place
(lambda ()
(start-implicit-atomic-mode)
(call-in-another-main-thread
orig-cust
(lambda ()

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

@ -890,14 +890,14 @@
;; Convert to set
(hasheq ignore #t bc #t)]))))
;; in atomic mode
(define (thread-remove-ignored-break-cell! t bc)
(assert-atomic-mode)
(when (thread-ignore-break-cell? t bc)
(let ([ignore (thread-ignore-break-cells t)])
(set-thread-ignore-break-cells! t (cond
[(eq? ignore bc) #f]
[else (hash-remove ignore bc)])))))
(atomically
(when (thread-ignore-break-cell? t bc)
(let ([ignore (thread-ignore-break-cells t)])
(set-thread-ignore-break-cells! t (cond
[(eq? ignore bc) #f]
[else (hash-remove ignore bc)]))))
(void)))
;; ----------------------------------------
;; Thread mailboxes