cs & thread: allow evt-chaperone to hide other membership

Make Racket CS consistent with traditional Racket in the way
`chaperone-evt` on a thread hides threadness, etc.

Hiding properties like threadness is not ideal and does not seem
entirely consistent with `chaperone-of`, but allowing things like
threads and semaphores to be chaperoned creates non-trivial expense
internally. It would have been better to have event constructors for
threads and such to (and then the consyructed events could be
chaperoned without imposing a cost on the original data structure).

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?]

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
 

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))

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:

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))

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])

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])

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)))))
 

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)))])))]))
 

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))]))]))
-

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))

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))))