diff --git a/racket/src/cs/demo/thread.ss b/racket/src/cs/demo/thread.ss index 85f2181fdf..58b88a7b16 100644 --- a/racket/src/cs/demo/thread.ss +++ b/racket/src/cs/demo/thread.ss @@ -132,6 +132,29 @@ (check tdelay (sync tdelay)) (printf "[That break was from a thread, and it's expected]\n") (check #t (>= (current-inexact-milliseconds) (+ now3 0.1))) + + (define got-here? #f) + (define break-self (thread (lambda () + (unsafe-start-atomic) + (break-thread (current-thread)) + (unsafe-end-atomic) + (set! got-here? #t)))) + (check break-self (sync break-self)) + (printf "[That break was from a thread, and it's expected]\n") + (check #f got-here?) + + (define break-self-immediate (thread (lambda () + (dynamic-wind + void + (lambda () + (unsafe-start-breakable-atomic) + (break-thread (current-thread)) + (set! got-here? #t)) + (lambda () + (unsafe-end-atomic)))))) + (check break-self-immediate (sync break-self-immediate)) + (printf "[That break was from a thread, and it's expected]\n") + (check #f got-here?) ;; Make sure breaks are disabled in a `dynamic-wind` post thunk (define dw-s (make-semaphore)) diff --git a/racket/src/cs/rumble/virtual-register.ss b/racket/src/cs/rumble/virtual-register.ss index 478f446a1e..e50759d24e 100644 --- a/racket/src/cs/rumble/virtual-register.ss +++ b/racket/src/cs/rumble/virtual-register.ss @@ -1,7 +1,7 @@ ;; We get a small number of virtual registers for fast, ;; pthread-specific bindings. -;; The last two virtual registers are reserved for use by the thread system +;; The last few virtual registers are reserved for use by the thread system (meta define num-reserved-virtual-registers 2) (meta define virtual-register-initial-values '()) @@ -11,8 +11,8 @@ [(_ id init-val) (with-syntax ([pos (datum->syntax #'here (length virtual-register-initial-values))]) (set! virtual-register-initial-values (cons #'init-val virtual-register-initial-values)) - (when (>= (length virtual-register-initial-values) (- (virtual-register-count) - num-reserved-virtual-registers)) + (when (> (length virtual-register-initial-values) (- (virtual-register-count) + num-reserved-virtual-registers)) (syntax-error stx "too many virtual-register definitions:")) #`(define-syntax id (syntax-rules () diff --git a/racket/src/cs/thread.sls b/racket/src/cs/thread.sls index b559a33fa1..839b9503f2 100644 --- a/racket/src/cs/thread.sls +++ b/racket/src/cs/thread.sls @@ -42,17 +42,17 @@ ;; Special handling of `current-atomic`: use the last virtual register; ;; we rely on the fact that the register's default value is 0. (define-syntax (define stx) - (syntax-case stx (current-atomic current-break-suspend make-pthread-parameter unsafe-make-place-local) + (syntax-case stx (current-atomic end-atomic-callback make-pthread-parameter unsafe-make-place-local) ;; Recognize definition of `current-atomic`: [(_ current-atomic (make-pthread-parameter 0)) (with-syntax ([(_ id _) stx] - [n (datum->syntax #'here (sub1 (virtual-register-count)))]) + [n (datum->syntax #'here (- (virtual-register-count) 1))]) #'(define-syntax id (syntax-rules () [(_) (virtual-register n)] [(_ v) (set-virtual-register! n v)])))] - ;; Recognize definition of `current-break-suspend`: - [(_ current-break-suspend (make-pthread-parameter 0)) + ;; Recognize definition of `end-atomic-callback`: + [(_ end-atomic-callback (make-pthread-parameter 0)) (with-syntax ([(_ id _) stx] [n (datum->syntax #'here (- (virtual-register-count) 2))]) #'(define-syntax id diff --git a/racket/src/io/port/bytes-port.rkt b/racket/src/io/port/bytes-port.rkt index 5656908c3f..ee3a94b099 100644 --- a/racket/src/io/port/bytes-port.rkt +++ b/racket/src/io/port/bytes-port.rkt @@ -1,5 +1,6 @@ #lang racket/base -(require "../common/check.rkt" +(require racket/fixnum + "../common/check.rkt" "../common/fixnum.rkt" "../common/object.rkt" "../host/thread.rkt" @@ -74,9 +75,9 @@ (method (lambda () (let ([pos i]) - (if (pos . < . len) + (if (pos . fx< . len) (begin - (set! i (add1 pos)) + (set! i (fx+ pos 1)) (progress!) (bytes-ref bstr pos)) eof)))) diff --git a/racket/src/io/port/read-and-peek.rkt b/racket/src/io/port/read-and-peek.rkt index 99d41cdca9..eb47c855bf 100644 --- a/racket/src/io/port/read-and-peek.rkt +++ b/racket/src/io/port/read-and-peek.rkt @@ -192,14 +192,14 @@ [(eof-object? b) (end-atomic) b] - [(evt? b) - (end-atomic) - (sync b) - (loop)] - [else + [(fixnum? b) (port-count-byte! in b) (end-atomic) - b])]))) + b] + [else ; must be an evt + (end-atomic) + (sync b) + (loop)])]))) ;; Use the general path; may return a procedure for a special (define (read-byte-via-bytes in #:special-ok? [special-ok? #t]) diff --git a/racket/src/thread/atomic.rkt b/racket/src/thread/atomic.rkt index 9043fb8ddb..a38f1196fa 100644 --- a/racket/src/thread/atomic.rkt +++ b/racket/src/thread/atomic.rkt @@ -1,5 +1,6 @@ #lang racket/base -(require "host.rkt" +(require racket/fixnum + "host.rkt" "place-local.rkt" "internal-error.rkt" "debug.rkt") @@ -16,7 +17,7 @@ in-atomic-mode? - set-end-atomic-callback! + add-end-atomic-callback! start-implicit-atomic-mode end-implicit-atomic-mode @@ -41,25 +42,35 @@ (end-atomic/no-interrupts)))) (define (start-atomic) - (current-atomic (add1 (current-atomic)))) + (current-atomic (fx+ (current-atomic) 1))) (define (end-atomic) - (define n (sub1 (current-atomic))) + (define n (fx- (current-atomic) 1)) (cond - [(and end-atomic-callback - (zero? n)) - (define cb end-atomic-callback) - (set! end-atomic-callback #f) - (current-atomic n) - (cb)] - [(negative? n) (internal-error "not in atomic mode to end")] + [(fx= n 0) + (if (eq? 0 (end-atomic-callback)) + (current-atomic n) + (do-end-atomic-callback))] + [(fx< n 0) (bad-end-atomic)] [else ;; There's a small chance that `end-atomic-callback` ;; was set by the scheduler after the check and ;; before we exit atomic mode. Make sure that rare - ;; event is ok. + ;; possibility remains ok. (current-atomic n)])) +(define (do-end-atomic-callback) + (define cbs (end-atomic-callback)) + (end-atomic-callback 0) + (current-atomic 0) + (let loop ([cbs cbs]) + (unless (eq? cbs 0) + ((car cbs)) + (loop (cdr cbs))))) + +(define (bad-end-atomic) + (internal-error "not in atomic mode to end")) + (define (start-atomic/no-interrupts) (start-atomic) (host:disable-interrupts)) @@ -73,11 +84,18 @@ ;; ---------------------------------------- -(define-place-local end-atomic-callback #f) - -(define (set-end-atomic-callback! cb) - (set! end-atomic-callback cb)) +;; A "list" of callbacks to run when exiting atomic mode, +;; but the list is terminated by 0 insteda of '(). +;; This definition is converted to a virtual register on +;; Chez Scheme, which explains why 0 is the "none" value. +(define end-atomic-callback (make-pthread-parameter 0)) +;; in atomic mode, but need to disable interrupts to ensure +;; no race with the scheduler +(define (add-end-atomic-callback! cb) + (host:disable-interrupts) + (end-atomic-callback (cons cb (end-atomic-callback))) + (host:enable-interrupts)) ;; ---------------------------------------- diff --git a/racket/src/thread/schedule.rkt b/racket/src/thread/schedule.rkt index 3c751f9f37..311356b0e6 100644 --- a/racket/src/thread/schedule.rkt +++ b/racket/src/thread/schedule.rkt @@ -114,7 +114,7 @@ ;; Swap out when the atomic region ends and at a point ;; where host-system interrupts are not disabled (i.e., ;; don't use `engine-block` instead of `engine-timeout`): - (set-end-atomic-callback! engine-timeout) + (add-end-atomic-callback! engine-timeout) (loop e)]))))))) (define (maybe-done callbacks) @@ -185,10 +185,8 @@ ;; Run foreign "async-apply" callbacks, now that we're in some thread (define (run-callbacks callbacks) (start-atomic) - (current-break-suspend (add1 (current-break-suspend))) (for ([callback (in-list callbacks)]) (callback)) - (current-break-suspend (sub1 (current-break-suspend))) (end-atomic)) ;; ---------------------------------------- diff --git a/racket/src/thread/thread.rkt b/racket/src/thread/thread.rkt index fe67a0b438..7cbfe10dba 100644 --- a/racket/src/thread/thread.rkt +++ b/racket/src/thread/thread.rkt @@ -40,7 +40,7 @@ break-enabled check-for-break break-enabled-key - current-break-suspend + current-breakable-atomic thread-push-kill-callback! thread-pop-kill-callback! @@ -80,7 +80,6 @@ current-break-enabled-cell check-for-break - current-break-suspend set-force-atomic-timeout-callback! @@ -722,8 +721,10 @@ ;; A continuation-mark key (not made visible to regular Racket code): (define break-enabled-default-cell (make-thread-cell #t)) -;; For disabling breaks, such as through `unsafe-start-atomic`: -(define current-break-suspend (make-pthread-parameter 0)) +;; For enable breaks despite atomic mode, such as through +;; `unsafe-start-breakable-atomic`; breaks are enabled as long as +;; `current-atomic` does not exceed `current-breakable-atomic`: +(define current-breakable-atomic (make-pthread-parameter 0)) (define (current-break-enabled-cell) (continuation-mark-set-first #f @@ -754,7 +755,7 @@ [(and (thread-pending-break t) (break-enabled) (not (thread-ignore-break-cell? t (current-break-enabled-cell))) - (zero? (current-break-suspend))) + (>= (add1 (current-breakable-atomic)) (current-atomic))) (define exn:break* (case (thread-pending-break t) [(hang-up) exn:break:hang-up/non-engine] [(terminate) exn:break:terminate/non-engine] @@ -804,7 +805,9 @@ (thread-reschedule! t)))) void]))) (when (eq? t check-t) - (check-for-break))) + (check-for-break) + (when (in-atomic-mode?) + (add-end-atomic-callback! check-for-break)))) (define (break>? k1 k2) (cond diff --git a/racket/src/thread/unsafe.rkt b/racket/src/thread/unsafe.rkt index 805bca4f51..5e769d1cec 100644 --- a/racket/src/thread/unsafe.rkt +++ b/racket/src/thread/unsafe.rkt @@ -1,5 +1,6 @@ #lang racket/base -(require "atomic.rkt" +(require racket/fixnum + "atomic.rkt" "thread.rkt" "schedule.rkt" "evt.rkt") @@ -12,21 +13,18 @@ unsafe-set-on-atomic-timeout!) (define (unsafe-start-breakable-atomic) - (start-atomic)) + (start-atomic) + (current-breakable-atomic (fx+ (current-breakable-atomic) 1))) (define (unsafe-end-breakable-atomic) + (current-breakable-atomic (fx- (current-breakable-atomic) 1)) (end-atomic)) (define (unsafe-start-atomic) - (start-atomic) - (current-break-suspend (add1 (current-break-suspend)))) + (start-atomic)) (define (unsafe-end-atomic) - (define bs (sub1 (current-break-suspend))) - (current-break-suspend bs) - (end-atomic) - (when (zero? bs) - (check-for-break))) + (end-atomic)) (define (unsafe-in-atomic?) (positive? (current-atomic)))