suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
Also, speed up hashing and logging a little by adjusting semaphores to
succeed with `$record-cas!` when no waiting is necessary.
This commit is contained in:
Matthew Flatt 2019-04-08 11:13:01 +02:00
parent 39c67f8b6a
commit d87be8789e
11 changed files with 94 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

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

3
racket/src/common/queue.rkt
View File

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

1
racket/src/cs/compile-file.ss
View File

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

28
racket/src/cs/rumble/hash.ss
View File

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

1
racket/src/cs/rumble/layout.ss
View File

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

4
racket/src/cs/rumble/struct.ss
View File

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

2
racket/src/cs/rumble/unsafe.ss
View File

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

4
racket/src/cs/thread.sls
View File

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

4
racket/src/racket/src/schvers.h
View File

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

2
racket/src/thread/main.rkt
View File

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

100
racket/src/thread/semaphore.rkt
View File

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