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

expander & thread: accomodate spurious failure from CAS

Browse Source
This commit is contained in:
Matthew Flatt 2020-06-27 13:54:52 -06:00
parent 38d90a5b0b
commit a186e0070a
5 changed files with 44 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
racket/src/expander/compile/header.rkt
View File

@ -122,9 +122,16 @@
,(add-module-path-index! mpis self)
,self-id
,inspector-id)])
(begin
(vector-cas! ,syntax-literals-id pos #f stx)
(unsafe-vector*-ref ,syntax-literals-id pos))))))))))
;; loop in case of spurious CAS failure
(letrec-values ([(loop)
(lambda ()
(begin
(vector-cas! ,syntax-literals-id pos #f stx)
(let-values ([(stx) (unsafe-vector*-ref ,syntax-literals-id pos)])
(if stx
stx
(loop)))))])
(loop))))))))))
;; Generate on-demand deserialization (shared across instances); the
;; result defines `deserialize-syntax-id`

14
racket/src/racket/src/startup.inc
View File

@ -30709,10 +30709,22 @@ static const char *startup_source =
"(add-module-path-index! mpis_0 self_0)"
" self-id"
" inspector-id)))"
"(list*"
" 'letrec-values"
"(list"
"(list"
" '(loop)"
"(list"
" 'lambda"
" '()"
"(list"
" 'begin"
"(list* 'vector-cas! syntax-literals-id '(pos #f stx))"
"(list* 'unsafe-vector*-ref syntax-literals-id '(pos))))))))))))))))))))"
"(list*"
" 'let-values"
"(list(list '(stx)(list* 'unsafe-vector*-ref syntax-literals-id '(pos))))"
" '((if stx stx(loop))))))))"
" '((loop))))))))))))))))))))"
"(define-values"
"(generate-lazy-syntax-literals-data!)"
"(lambda(sl_0 mpis_0)"

17
racket/src/schemify/path-and-fasl.rkt
View File

@ -138,9 +138,20 @@
(fasl->s-exp v
#:datum-intern? #t
#:external-lifts (to-fasl-lifts tf))))
(box-cas! vb v v2)
(set-to-fasl-wrt! tf #f)
(unbox vb)]
(let loop ()
(cond
[(box-cas! vb v v2)
(set-to-fasl-wrt! tf #f)
v2]
[else
(let ([v (unbox vb)])
(cond
[(bytes? v)
;; must be a spurious CAS failure
(loop)]
[else
;; other thread beat us to it
v]))]))]
[else
;; already forced (or never fasled)
v])]))

5
racket/src/thread/future.rkt
View File

@ -653,7 +653,10 @@
;; lock-free synchronization to check whether the box content is #f
(define (worker-pinged? w)
(box-cas! (worker-ping w) #t #t))
(cond
[(box-cas! (worker-ping w) #t #t) #t]
[(box-cas! (worker-ping w) #f #f) #f]
[else (worker-pinged? w)]))
;; called with scheduler lock
(define (check-in w)

6
racket/src/thread/place.rkt
View File

@ -155,7 +155,7 @@
(host:mutex-release (place-lock p))))
(define (place-has-activity! p)
(box-cas! (place-activity-canary p) #f #t)
(set-box! (place-activity-canary p) #t)
(sandman-wakeup (place-wakeup-handle p)))
(void
@ -163,8 +163,8 @@
;; Called in atomic mode by scheduler
(lambda (callbacks)
(define p current-place)
(unless (box-cas! (place-activity-canary p) #f #f)
(box-cas! (place-activity-canary p) #t #f)
(when (unbox (place-activity-canary p))
(set-box! (place-activity-canary p) #f)
(host:mutex-acquire (place-lock p))
(define queued-result (place-queued-result p))
(define break (place-pending-break p))