diff --git a/pkgs/racket-doc/scribblings/reference/chaperones.scrbl b/pkgs/racket-doc/scribblings/reference/chaperones.scrbl index 2313d93e25..3a35356854 100644 --- a/pkgs/racket-doc/scribblings/reference/chaperones.scrbl +++ b/pkgs/racket-doc/scribblings/reference/chaperones.scrbl @@ -973,7 +973,14 @@ and it must return a chaperone of that value. Pairs of @racket[prop] and @racket[prop-val] (the number of arguments to @racket[chaperone-evt] must be even) add impersonator properties -or override impersonator-property values of @racket[evt].} +or override impersonator-property values of @racket[evt]. + +The result is @racket[chaperone-of?] the argument @racket[evt]. +However, if @racket[evt] is a @tech{thread}, @tech{semaphore}, +@tech{input port}, @tech{output port}, or @tech{will executor}, the +result is not recognized as such. For example, @racket[thread?] +applied to the result of @racket[chaperone-evt] will always produce +@racket[#f].} @defproc[(chaperone-channel [channel channel?] diff --git a/pkgs/racket-test-core/tests/racket/chaperone.rktl b/pkgs/racket-test-core/tests/racket/chaperone.rktl index 0d562f1e90..fe97d7e8db 100644 --- a/pkgs/racket-test-core/tests/racket/chaperone.rktl +++ b/pkgs/racket-test-core/tests/racket/chaperone.rktl @@ -2682,6 +2682,26 @@ v))) (test #t values checked?)) +;; ---------------------------------------- +;; Evt variants where `chaperone-evt` is allowed to defeat predicates + +(define (check-other-evt-chaperone x other?) + (test #t other? x) + (test #t evt? (chaperone-evt x (lambda (v) (values v (lambda (r) r))))) + (test #f other? (chaperone-evt x (lambda (v) (values v (lambda (r) r))))) + (test x sync (chaperone-evt x (lambda (v) (values v (lambda (r) r))))) + (test #t chaperone-of? (chaperone-evt x (lambda (v) (values v (lambda (r) r)))) x)) + +(check-other-evt-chaperone (thread void) thread?) +(check-other-evt-chaperone (make-semaphore 1) semaphore?) +(check-other-evt-chaperone (open-input-bytes #"x") input-port?) +(check-other-evt-chaperone (open-output-bytes) output-port?) +(unless (eq? 'cgc (system-type 'gc)) + (define we (make-will-executor)) + (will-register we (gensym) void) + (collect-garbage) + (check-other-evt-chaperone we will-executor?)) + ;; ---------------------------------------- ;; channel chaperones diff --git a/racket/src/common/queue.rkt b/racket/src/common/queue.rkt index b0697f4201..0978ad1af3 100644 --- a/racket/src/common/queue.rkt +++ b/racket/src/common/queue.rkt @@ -14,10 +14,13 @@ queue-length queue-remove-end!) -(struct queue (start end) #:mutable) +(struct queue (start end) + #:mutable + #:authentic) (struct node (elem [prev #:mutable] - [next #:mutable])) + [next #:mutable]) + #:authentic) (define (make-queue) (queue #f #f)) diff --git a/racket/src/cs/thread.sls b/racket/src/cs/thread.sls index c6083a653e..adf69fde11 100644 --- a/racket/src/cs/thread.sls +++ b/racket/src/cs/thread.sls @@ -175,7 +175,8 @@ 'mutex-acquire rumble:mutex-acquire 'mutex-release rumble:mutex-release 'threaded? rumble:threaded? - 'continuation-current-primitive rumble:continuation-current-primitive)] + 'continuation-current-primitive rumble:continuation-current-primitive + 'prop:unsafe-authentic-override prop:unsafe-authentic-override)] [else #f])) ;; Tie knots: diff --git a/racket/src/thread/evt.rkt b/racket/src/thread/evt.rkt index d7f563f5dc..75178f3a9c 100644 --- a/racket/src/thread/evt.rkt +++ b/racket/src/thread/evt.rkt @@ -83,13 +83,15 @@ ;; If a poller does any work that can allow some thread to ;; become unblocked, then it must tell the scheduler via ;; `schedule-info-did-work!`. -(struct poller (proc)) +(struct poller (proc) + #:authentic) ;; Provided to a `poller` function: (struct poll-ctx (poll? ; whether events are being polled once (i.e., 0 timeout) select-proc ; callback to asynchronously select the event being polled sched-info ; instructions to the scheduler, such as timeouts - [incomplete? #:mutable])) ; #t => getting back the same event does not imply a completed poll + [incomplete? #:mutable]) ; #t => getting back the same event does not imply a completed poll + #:authentic) ;; If a `poller` callback keeps `select-proc` for asynchronous use, ;; then it should return a `control-state-evt` to ensure that ;; `select-proc` is not called if the event is abandoned. @@ -191,7 +193,8 @@ [else (values #f the-never-evt)]))) ;; Possible result from `evt-poll`: -(struct delayed-poll (resume)) +(struct delayed-poll (resume) + #:authentic) (struct poller-evt (poller) #:property prop:evt (struct-field-index poller)) diff --git a/racket/src/thread/host.rkt b/racket/src/thread/host.rkt index 7734880840..1887145c40 100644 --- a/racket/src/thread/host.rkt +++ b/racket/src/thread/host.rkt @@ -98,4 +98,6 @@ [call-as-asynchronous-callback host:call-as-asynchronous-callback] [post-as-asynchronous-callback host:post-as-asynchronous-callback] - continuation-current-primitive) + continuation-current-primitive + + [prop:unsafe-authentic-override host:prop:unsafe-authentic-override]) diff --git a/racket/src/thread/impersonator.rkt b/racket/src/thread/impersonator.rkt index 78db1e44ba..46cb5b182c 100644 --- a/racket/src/thread/impersonator.rkt +++ b/racket/src/thread/impersonator.rkt @@ -97,15 +97,13 @@ (define (check-chaperone-of what new-r r) (unless (chaperone-of? new-r r) - (raise - (exn:fail:contract - (string-append - what " chaperone: non-chaperone result;\n" - " received a value that is not a chaperone of the original value\n" - " value: " ((error-value->string-handler) r) "\n" - " non-chaperone value: " - ((error-value->string-handler) new-r)) - (current-continuation-marks))))) + (raise-arguments-error + (string->symbol (string-append what " chaperone")) + (string-append + "non-chaperone result;\n" + " received a value that is not a chaperone of the original value\n") + "value" r + "non-chaperone value" new-r))) (define (check-impersonator-properties who args) (let loop ([args args]) diff --git a/racket/src/thread/place-object.rkt b/racket/src/thread/place-object.rkt index 823df99ede..585a80acb7 100644 --- a/racket/src/thread/place-object.rkt +++ b/racket/src/thread/place-object.rkt @@ -29,6 +29,8 @@ [wakeup-handle #:mutable] [dequeue-semas #:mutable] ; semaphores reflecting place-channel waits to recheck [future-scheduler #:mutable]) ; #f or a scheduler of futures + #:authentic + #:property host:prop:unsafe-authentic-override #t ; allow evt chaperone #:property prop:evt (struct-field-index pch) #:property prop:place-message (lambda (self) (lambda () (lambda () (place-pch self))))) diff --git a/racket/src/thread/semaphore.rkt b/racket/src/thread/semaphore.rkt index 6594ef58c8..50515a6e4f 100644 --- a/racket/src/thread/semaphore.rkt +++ b/racket/src/thread/semaphore.rkt @@ -3,6 +3,7 @@ "check.rkt" "../common/queue.rkt" "internal-error.rkt" + "host.rkt" "atomic.rkt" "parameter.rkt" "waiter.rkt" @@ -29,6 +30,8 @@ unsafe-semaphore-wait) (struct semaphore queue ([count #:mutable]) ; -1 => non-empty queue + #:authentic + #:property host:prop:unsafe-authentic-override #t ; allow evt chaperone #:property prop:evt (poller (lambda (s poll-ctx) @@ -65,9 +68,7 @@ (unsafe-semaphore-post s)) (define (unsafe-semaphore-post s) - (define c (if (impersonator? s) - -1 - (semaphore-count s))) + (define c (semaphore-count s)) (cond [(and (c . >= . 0) (unsafe-struct*-cas! s count-field-pos c (add1 c))) @@ -125,9 +126,7 @@ (unsafe-semaphore-wait s)) (define (unsafe-semaphore-wait s) - (define c (if (impersonator? s) - -1 - (semaphore-count s))) + (define c (semaphore-count s)) (cond [(and (positive? c) (unsafe-struct*-cas! s count-field-pos c (sub1 c))) @@ -153,7 +152,7 @@ ;; This callback is used, in addition to the previous one, if ;; the thread receives a break signal but doesn't escape ;; (either because breaks are disabled or the handler - ;; continues), if if the interrupt was to suspend and the thread + ;; continues), or if the interrupt was to suspend and the thread ;; is resumed: (lambda () (semaphore-wait s)))])))])) diff --git a/racket/src/thread/thread-group.rkt b/racket/src/thread/thread-group.rkt index 848ca761b6..57bcb62a3d 100644 --- a/racket/src/thread/thread-group.rkt +++ b/racket/src/thread/thread-group.rkt @@ -1,8 +1,10 @@ #lang racket/base (require "place-local.rkt" + "host.rkt" "check.rkt" "internal-error.rkt" - "atomic.rkt") + "atomic.rkt" + "debug.rkt") (provide (struct-out node) @@ -24,17 +26,35 @@ ;; Threads and thread groups subtype `node`: (struct node ([prev #:mutable] - [next #:mutable])) + [next #:mutable]) + #:authentic) (define (child-node child) child) ; a child instantiates a `node` subtype (define (node-child n) n) (struct thread-group node (parent [chain-start #:mutable] ; all children [chain #:mutable] ; children remaining to be scheduled round-robin - [chain-end #:mutable])) + [chain-end #:mutable]) + #:authentic) + +(debug-select + #:on + [(define not-added-key 'none) + (define (assert-not-added n) + (unless (and (eq? (node-prev n) 'none) + (eq? (node-next n) 'none)) + (internal-error "thread-group-add!: thread or group is added already"))) + (define (assert-added n) + (when (or (eq? (node-prev n) 'none) + (eq? (node-next n) 'none)) + (internal-error "thread-group-remove!: thread or group is removed already")))] + #:off + [(define not-added-key #f) + (define (assert-not-added n) (void)) + (define (assert-added n) (void))]) (define (make-root-thread-group) - (thread-group 'none 'none #f #f #f #f)) + (thread-group not-added-key not-added-key #f #f #f #f)) (define-place-local root-thread-group (make-root-thread-group)) @@ -52,7 +72,7 @@ (define/who (make-thread-group [parent (current-thread-group)]) (check who thread-group? parent) - (define tg (thread-group 'none 'none parent #f #f #f)) + (define tg (thread-group not-added-key not-added-key parent #f #f #f)) tg) ;; Called atomically in scheduler: @@ -82,9 +102,7 @@ (define t (thread-group-chain-start parent)) (define was-empty? (not t)) (define n (child-node child)) - (unless (and (eq? (node-prev n) 'none) - (eq? (node-next n) 'none)) - (internal-error "thread-group-add!: thread or group is added already")) + (assert-not-added n) (set-node-next! n t) (set-node-prev! n #f) (if t @@ -103,9 +121,7 @@ (define (thread-group-remove! parent child) (assert-atomic-mode) (define n (child-node child)) - (when (or (eq? (node-prev n) 'none) - (eq? (node-next n) 'none)) - (internal-error "thread-group-remove!: thread or group is removed already")) + (assert-added n) (if (node-next n) (set-node-prev! (node-next n) (node-prev n)) (set-thread-group-chain-end! parent (node-prev n))) @@ -114,8 +130,8 @@ (set-thread-group-chain-start! parent (node-next n))) (when (eq? n (thread-group-chain parent)) (set-thread-group-chain! parent (node-next n))) - (set-node-next! n 'none) - (set-node-prev! n 'none) + (set-node-next! n not-added-key) + (set-node-prev! n not-added-key) (unless (thread-group? child) (set! num-threads-in-groups (sub1 num-threads-in-groups))) (when (not (thread-group-chain-end parent)) @@ -133,4 +149,3 @@ [(not n) accum] [else (loop (node-next n) (thread-group-all-threads (node-child n) accum))]))])) - diff --git a/racket/src/thread/thread.rkt b/racket/src/thread/thread.rkt index 5adad30509..bb5c78abe5 100644 --- a/racket/src/thread/thread.rkt +++ b/racket/src/thread/thread.rkt @@ -132,6 +132,8 @@ [future #:mutable] ; current would-be future [condition-wakeup #:mutable]) + #:authentic + #:property host:prop:unsafe-authentic-override #t ; allow evt chaperone #:property prop:waiter (make-waiter-methods #:suspend! (lambda (t i-cb r-cb) (thread-deschedule! t #f i-cb r-cb)) diff --git a/racket/src/thread/will-executor.rkt b/racket/src/thread/will-executor.rkt index bd25f0d09e..2e57a3df7c 100644 --- a/racket/src/thread/will-executor.rkt +++ b/racket/src/thread/will-executor.rkt @@ -17,6 +17,8 @@ will-execute) (struct will-executor (host-we sema) + #:authentic + #:property host:prop:unsafe-authentic-override #t ; allow evt chaperone #:property prop:evt (lambda (we) (wrap-evt (semaphore-peek-evt (will-executor-sema we)) (lambda (v) we))))