cs: use new $record-ref, etc., primitive

Also, speed up hashing and logging a little by adjusting semaphores to
succeed with `$record-cas!` when no waiting is necessary.

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "7.2.0.12")
+(define version "7.2.0.13")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

racket/src/common/queue.rkt

@@ -2,7 +2,8 @@
 
 ;; Mutable queue
 
-(provide make-queue
+(provide queue
+         make-queue
          queue-empty?
          queue-remove!
          queue-fremove!

racket/src/cs/compile-file.ss

@@ -53,6 +53,7 @@
                 (error 'eq-on-flonum "no")))))
 (check-defined 'procedure-known-single-valued?)
 (check-defined 'compress-format)
+(check-defined '#%$record-cas!)
 
 ;; ----------------------------------------
 

racket/src/cs/rumble/hash.ss

@@ -483,10 +483,10 @@
   (let ([vec (locked-iterable-hash-cells ht)])
     (cond
      [(and vec
-           (let ([len (#%vector-length vec)]
+           (fixnum? i)
-                 [want-len (or i 0)])
+           (let ([len (#%vector-length vec)])
-             (or (> len want-len)
+             (or (fx> len i)
-                 (and (fx= len want-len)
+                 (and (fx= len i)
                       (not (locked-iterable-hash-retry? ht))))))
       (lock-release (locked-iterable-hash-lock ht))
       vec]
@@ -499,7 +499,7 @@
                                  0)
                              32))])
         (let ([len (#%vector-length new-vec)])
-          (when (= len (hash-count ht))
+          (when (fx= len (hash-count ht))
             (set-locked-iterable-hash-retry?! ht #f))
           (when weak?
             (let loop ([i 0])
@@ -653,20 +653,20 @@
                         p))
                   '(#!bwp . #!bwp))]
            [key (car p)]
-           [v (if (bwp-object? key)
+           [v (cdr p)])
-                  none
+      (if (or (bwp-object? key)
-                  (cdr p))])
+              (bwp-object? v))
-      (if (eq? v none)
           (if (eq? bad-index-v none)
               (raise-arguments-error who "no element at index"
                                      "index" i)
               (bad-index-result key? value? pair? bad-index-v))
           (cond
-           [(and key? value?)
+           [key?
-            (if pair?
+            (if value?
-                (cons key v)
+                (if pair?
-                (values key v))]
+                    (cons key v)
-           [key? key]
+                    (values key v))
+                key)]
            [else v])))]
    [(and (impersonator? ht)
          (authentic-hash? (impersonator-val ht)))

racket/src/cs/rumble/layout.ss

@@ -2,4 +2,3 @@
 ;; and other representation details
 (define bytevector-content-offset 9)
 (define vector-content-offset (if (> (fixnum-width) 32) 9 5))
-(define record-content-offset vector-content-offset)

racket/src/cs/rumble/struct.ss

@@ -974,9 +974,9 @@
           (putprop (record-type-uid rtd) 'guards new-guards))))))
 
 (define (unsafe-struct*-ref s i)
-  (#%$object-ref 'scheme-object s (fx+ record-content-offset (fx* i (foreign-sizeof 'void*)))))
+  (#%$record-ref s i))
 (define (unsafe-struct*-set! s i v)
-  (#%$object-set! 'scheme-object s (fx+ record-content-offset (fx* i (foreign-sizeof 'void*))) v))
+  (#%$record-set! s i v))
 (define (unsafe-struct? v r)
   (#3%record? v r))
 

racket/src/cs/rumble/unsafe.ss

@@ -79,7 +79,7 @@
 (define unsafe-vector*-cas! (unsafe-primitive vector-cas!))
 
 (define (unsafe-struct*-cas! s k old new)
-  (#%vector-cas! s k old new))
+  (#3%$record-cas! s k old new))
 
 (define unsafe-unbox* (unsafe-primitive unbox))
 (define unsafe-set-box*! (unsafe-primitive set-box!))

racket/src/cs/thread.sls

@@ -171,8 +171,8 @@
      (|#%app| (|#%app| 1/exit-handler) v)))
 
   (set-scheduler-lock-callbacks! (lambda () (1/make-semaphore 1))
-                                 1/semaphore-wait
+                                 unsafe-semaphore-wait
-                                 1/semaphore-post)
+                                 unsafe-semaphore-post)
 
   (set-scheduler-atomicity-callbacks! (lambda ()
                                         (current-atomic (fx+ (current-atomic) 1)))

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "7.2.0.12"
+#define MZSCHEME_VERSION "7.2.0.13"
 
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 2
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 12
+#define MZSCHEME_VERSION_W 13
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

racket/src/thread/main.rkt

@@ -69,6 +69,8 @@
          semaphore-wait/enable-break
          call-with-semaphore
          call-with-semaphore/enable-break
+         unsafe-semaphore-post
+         unsafe-semaphore-wait
 
          semaphore-peek-evt
          semaphore-peek-evt?

racket/src/thread/semaphore.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require "check.rkt"
+(require racket/unsafe/ops
+         "check.rkt"
          "../common/queue.rkt"
          "internal-error.rkt"
          "atomic.rkt"
@@ -22,14 +23,17 @@
 
          semaphore-post/atomic
          semaphore-wait/atomic
-         semaphore-post-all/atomic)
+         semaphore-post-all/atomic
 
-(struct semaphore ([count #:mutable]
+         unsafe-semaphore-post
-                   queue)
+         unsafe-semaphore-wait)
+
+(struct semaphore queue ([count #:mutable]) ; -1 => non-empty queue
   #:property
   prop:evt
   (poller (lambda (s poll-ctx)
             (semaphore-wait/poll s poll-ctx))))
+(define count-field-pos 2) ; used with `unsafe-struct*-cas!`
 
 (struct semaphore-peek-evt (sema)
   #:property
@@ -51,24 +55,37 @@
                 (number->string init)
                 " is too large")
                (current-continuation-marks))))
-  (semaphore init (make-queue)))
+  (semaphore #f #f init))
 
 ;; ----------------------------------------
 
 (define/who (semaphore-post s)
   (check who semaphore? s)
-  (atomically (semaphore-post/atomic s)))
+  (unsafe-semaphore-post s))
+
+(define (unsafe-semaphore-post s)
+  (define c (if (impersonator? s)
+                -1
+                (semaphore-count s)))
+  (cond
+    [(and (c . >= . 0)
+          (unsafe-struct*-cas! s count-field-pos c (add1 c)))
+     (void)]
+    [else
+     (atomically (semaphore-post/atomic s))]))
 
 ;; In atomic mode:
 (define (semaphore-post/atomic s)
   (assert-atomic-mode)
   (let loop ()
-    (define w (queue-remove! (semaphore-queue s)))
+    (define w (queue-remove! s))
     (cond
       [(not w)
        (set-semaphore-count! s (add1 (semaphore-count s)))]
       [else
        (waiter-resume! w s)
+       (when (queue-empty? s)
+         (set-semaphore-count! s 0)) ; allow CAS again
        (when (semaphore-peek-select-waiter? w)
          ;; Don't consume a post for a peek waiter
          (loop))])))
@@ -77,7 +94,7 @@
 (define (semaphore-post-all/atomic s)
   (set-semaphore-count! s +inf.0)
   (queue-remove-all!
-   (semaphore-queue s)
+   s
    (lambda (w) (waiter-resume! w s))))
 
 (define (semaphore-post-all s)
@@ -87,7 +104,7 @@
 ;; In atomic mode:
 (define (semaphore-any-waiters? s)
   (assert-atomic-mode)
-  (not (queue-empty? (semaphore-queue s))))
+  (not (queue-empty? s)))
 
 ;; ----------------------------------------
 
@@ -104,26 +121,40 @@
 
 (define/who (semaphore-wait s)
   (check who semaphore? s)
-  ((atomically
+  (unsafe-semaphore-wait s))
-    (define c (semaphore-count s))
+
-    (cond
+(define (unsafe-semaphore-wait s)
-     [(positive? c)
+  (define c (if (impersonator? s)
-      (set-semaphore-count! s (sub1 c))
+                -1
-      void]
+                (semaphore-count s)))
-     [else
+  (cond
-      (define w (current-thread))
+    [(and (positive? c)
-      (define q (semaphore-queue s))
+          (unsafe-struct*-cas! s count-field-pos c (sub1 c)))
-      (define n (queue-add! q w))
+     (void)]
-      (waiter-suspend!
+    [else
-       w
+     ((atomically
-       ;; On break/kill/suspend:
+       (define c (semaphore-count s))
-       (lambda () (queue-remove-node! q n))
+       (cond
-       ;; This callback is used, in addition to the previous one, if
+         [(positive? c)
-       ;; the thread receives a break signal but doesn't escape
+          (set-semaphore-count! s (sub1 c))
-       ;; (either because breaks are disabled or the handler
+          void]
-       ;; continues), if if the interrupt was to suspend and the thread
+         [else
-       ;; is resumed:
+          (define w (current-thread))
-       (lambda () (semaphore-wait s)))]))))
+          (define n (queue-add! s w))
+          (set-semaphore-count! s -1) ; so CAS not tried for `semaphore-post`
+          (waiter-suspend!
+           w
+           ;; On break/kill/suspend:
+           (lambda ()
+             (queue-remove-node! s n)
+             (when (queue-empty? s)
+               (set-semaphore-count! s 0))) ; allow CAS again
+           ;; 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
+           ;; is resumed:
+           (lambda () (semaphore-wait s)))])))]))
 
 ;; In atomic mode
 (define (semaphore-wait/poll s poll-ctx
@@ -144,8 +175,8 @@
     (define w (if peek?
                   (semaphore-peek-select-waiter (poll-ctx-select-proc poll-ctx))
                   (select-waiter (poll-ctx-select-proc poll-ctx))))
-    (define q (semaphore-queue s))
+    (define n (queue-add! s w))
-    (define n (queue-add! q w))
+    (set-semaphore-count! s -1) ; so CAS not tried for `semaphore-post`
     ;; Replace with `async-evt`, but the `sema-waiter` can select the
     ;; event through a callback. Pair the event with a nack callback
     ;; to get back out of line.
@@ -154,7 +185,9 @@
              (control-state-evt async-evt
                                 (lambda ()
                                   (assert-atomic-mode)
-                                  (queue-remove-node! q n))
+                                  (queue-remove-node! s n)
+                                  (when (queue-empty? s)
+                                    (set-semaphore-count! s 0))) ; allow CAS again
                                 void
                                 (lambda ()
                                   ;; Retry: decrement or requeue
@@ -166,7 +199,8 @@
                                       (set-semaphore-count! s (sub1 c)))
                                     (values result #t)]
                                    [else
-                                    (set! n (queue-add! q w))
+                                    (set! n (queue-add! s w))
+                                    (set-semaphore-count! s -1) ; so CAS not tried for `semaphore-post`
                                     (values #f #f)])))
              (lambda (v) result)))]))