From d87be8789e50ded6bc175ff3ae12747338b9343b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 8 Apr 2019 11:13:01 +0200 Subject: [PATCH] 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 | 2 +- racket/src/common/queue.rkt | 3 +- racket/src/cs/compile-file.ss | 1 + racket/src/cs/rumble/hash.ss | 28 ++++----- racket/src/cs/rumble/layout.ss | 1 - racket/src/cs/rumble/struct.ss | 4 +- racket/src/cs/rumble/unsafe.ss | 2 +- racket/src/cs/thread.sls | 4 +- racket/src/racket/src/schvers.h | 4 +- racket/src/thread/main.rkt | 2 + racket/src/thread/semaphore.rkt | 100 +++++++++++++++++++++----------- 11 files changed, 94 insertions(+), 57 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index f0530d4dab..aef37769df 100644 --- a/pkgs/base/info.rkt +++ b/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])) diff --git a/racket/src/common/queue.rkt b/racket/src/common/queue.rkt index 3de14192f9..b0697f4201 100644 --- a/racket/src/common/queue.rkt +++ b/racket/src/common/queue.rkt @@ -2,7 +2,8 @@ ;; Mutable queue -(provide make-queue +(provide queue + make-queue queue-empty? queue-remove! queue-fremove! diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss index 10012e614b..0bdfcc1595 100644 --- a/racket/src/cs/compile-file.ss +++ b/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!) ;; ---------------------------------------- diff --git a/racket/src/cs/rumble/hash.ss b/racket/src/cs/rumble/hash.ss index 71b76b8ef5..6c32dde976 100644 --- a/racket/src/cs/rumble/hash.ss +++ b/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)] - [want-len (or i 0)]) - (or (> len want-len) - (and (fx= len want-len) + (fixnum? i) + (let ([len (#%vector-length vec)]) + (or (fx> len i) + (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) - none - (cdr p))]) - (if (eq? v none) + [v (cdr p)]) + (if (or (bwp-object? key) + (bwp-object? v)) (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?) - (if pair? - (cons key v) - (values key v))] - [key? key] + [key? + (if value? + (if pair? + (cons key v) + (values key v)) + key)] [else v])))] [(and (impersonator? ht) (authentic-hash? (impersonator-val ht))) diff --git a/racket/src/cs/rumble/layout.ss b/racket/src/cs/rumble/layout.ss index d22537c4a0..98c75a8459 100644 --- a/racket/src/cs/rumble/layout.ss +++ b/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) diff --git a/racket/src/cs/rumble/struct.ss b/racket/src/cs/rumble/struct.ss index 862e634bea..0d723790bb 100644 --- a/racket/src/cs/rumble/struct.ss +++ b/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)) diff --git a/racket/src/cs/rumble/unsafe.ss b/racket/src/cs/rumble/unsafe.ss index 31f6761645..a51cb1fedf 100644 --- a/racket/src/cs/rumble/unsafe.ss +++ b/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!)) diff --git a/racket/src/cs/thread.sls b/racket/src/cs/thread.sls index 9346bcbc83..8a054de0e1 100644 --- a/racket/src/cs/thread.sls +++ b/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 - 1/semaphore-post) + unsafe-semaphore-wait + unsafe-semaphore-post) (set-scheduler-atomicity-callbacks! (lambda () (current-atomic (fx+ (current-atomic) 1))) diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 2b4783d886..3570c8cd05 100644 --- a/racket/src/racket/src/schvers.h +++ b/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) diff --git a/racket/src/thread/main.rkt b/racket/src/thread/main.rkt index 5cd9ed018d..9a9c8615d8 100644 --- a/racket/src/thread/main.rkt +++ b/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? diff --git a/racket/src/thread/semaphore.rkt b/racket/src/thread/semaphore.rkt index 00dac020c4..5644c75eca 100644 --- a/racket/src/thread/semaphore.rkt +++ b/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] - queue) + unsafe-semaphore-post + 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 - (define c (semaphore-count s)) - (cond - [(positive? c) - (set-semaphore-count! s (sub1 c)) - void] - [else - (define w (current-thread)) - (define q (semaphore-queue s)) - (define n (queue-add! q w)) - (waiter-suspend! - w - ;; On break/kill/suspend: - (lambda () (queue-remove-node! q n)) - ;; 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)))])))) + (unsafe-semaphore-wait s)) + +(define (unsafe-semaphore-wait s) + (define c (if (impersonator? s) + -1 + (semaphore-count s))) + (cond + [(and (positive? c) + (unsafe-struct*-cas! s count-field-pos c (sub1 c))) + (void)] + [else + ((atomically + (define c (semaphore-count s)) + (cond + [(positive? c) + (set-semaphore-count! s (sub1 c)) + void] + [else + (define w (current-thread)) + (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! q w)) + (define n (queue-add! s 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)))]))