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

cs: reduce the cost of entering & exiting atomic mode

Browse Source
This commit is contained in:
Matthew Flatt 2019-02-03 10:33:15 -07:00
parent 941fe38cee
commit 5ffb96e62d
9 changed files with 91 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
racket/src/cs/demo/thread.ss
View File

@ -132,6 +132,29 @@
(check tdelay (sync tdelay))
(printf "[That break was from a thread, and it's expected]\n")
(check #t (>= (current-inexact-milliseconds) (+ now3 0.1)))
(define got-here? #f)
(define break-self (thread (lambda ()
(unsafe-start-atomic)
(break-thread (current-thread))
(unsafe-end-atomic)
(set! got-here? #t))))
(check break-self (sync break-self))
(printf "[That break was from a thread, and it's expected]\n")
(check #f got-here?)
(define break-self-immediate (thread (lambda ()
(dynamic-wind
void
(lambda ()
(unsafe-start-breakable-atomic)
(break-thread (current-thread))
(set! got-here? #t))
(lambda ()
(unsafe-end-atomic))))))
(check break-self-immediate (sync break-self-immediate))
(printf "[That break was from a thread, and it's expected]\n")
(check #f got-here?)
;; Make sure breaks are disabled in a `dynamic-wind` post thunk
(define dw-s (make-semaphore))

6
racket/src/cs/rumble/virtual-register.ss
View File

@ -1,7 +1,7 @@
;; We get a small number of virtual registers for fast,
;; pthread-specific bindings.
;; The last two virtual registers are reserved for use by the thread system
;; The last few virtual registers are reserved for use by the thread system
(meta define num-reserved-virtual-registers 2)
(meta define virtual-register-initial-values '())
@ -11,8 +11,8 @@
[(_ id init-val)
(with-syntax ([pos (datum->syntax #'here (length virtual-register-initial-values))])
(set! virtual-register-initial-values (cons #'init-val virtual-register-initial-values))
(when (>= (length virtual-register-initial-values) (- (virtual-register-count)
num-reserved-virtual-registers))
(when (> (length virtual-register-initial-values) (- (virtual-register-count)
num-reserved-virtual-registers))
(syntax-error stx "too many virtual-register definitions:"))
#`(define-syntax id
(syntax-rules ()

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

@ -42,17 +42,17 @@
;; Special handling of `current-atomic`: use the last virtual register;
;; we rely on the fact that the register's default value is 0.
(define-syntax (define stx)
(syntax-case stx (current-atomic current-break-suspend make-pthread-parameter unsafe-make-place-local)
(syntax-case stx (current-atomic end-atomic-callback make-pthread-parameter unsafe-make-place-local)
;; Recognize definition of `current-atomic`:
[(_ current-atomic (make-pthread-parameter 0))
(with-syntax ([(_ id _) stx]
[n (datum->syntax #'here (sub1 (virtual-register-count)))])
[n (datum->syntax #'here (- (virtual-register-count) 1))])
#'(define-syntax id
(syntax-rules ()
[(_) (virtual-register n)]
[(_ v) (set-virtual-register! n v)])))]
;; Recognize definition of `current-break-suspend`:
[(_ current-break-suspend (make-pthread-parameter 0))
;; Recognize definition of `end-atomic-callback`:
[(_ end-atomic-callback (make-pthread-parameter 0))
(with-syntax ([(_ id _) stx]
[n (datum->syntax #'here (- (virtual-register-count) 2))])
#'(define-syntax id

7
racket/src/io/port/bytes-port.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../common/check.rkt"
(require racket/fixnum
"../common/check.rkt"
"../common/fixnum.rkt"
"../common/object.rkt"
"../host/thread.rkt"
@ -74,9 +75,9 @@
(method
(lambda ()
(let ([pos i])
(if (pos . < . len)
(if (pos . fx< . len)
(begin
(set! i (add1 pos))
(set! i (fx+ pos 1))
(progress!)
(bytes-ref bstr pos))
eof))))

12
racket/src/io/port/read-and-peek.rkt
View File

@ -192,14 +192,14 @@
[(eof-object? b)
(end-atomic)
b]
[(evt? b)
(end-atomic)
(sync b)
(loop)]
[else
[(fixnum? b)
(port-count-byte! in b)
(end-atomic)
b])])))
b]
[else ; must be an evt
(end-atomic)
(sync b)
(loop)])])))
;; Use the general path; may return a procedure for a special
(define (read-byte-via-bytes in #:special-ok? [special-ok? #t])

50
racket/src/thread/atomic.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "host.rkt"
(require racket/fixnum
"host.rkt"
"place-local.rkt"
"internal-error.rkt"
"debug.rkt")
@ -16,7 +17,7 @@
in-atomic-mode?
set-end-atomic-callback!
add-end-atomic-callback!
start-implicit-atomic-mode
end-implicit-atomic-mode
@ -41,25 +42,35 @@
(end-atomic/no-interrupts))))
(define (start-atomic)
(current-atomic (add1 (current-atomic))))
(current-atomic (fx+ (current-atomic) 1)))
(define (end-atomic)
(define n (sub1 (current-atomic)))
(define n (fx- (current-atomic) 1))
(cond
[(and end-atomic-callback
(zero? n))
(define cb end-atomic-callback)
(set! end-atomic-callback #f)
(current-atomic n)
(cb)]
[(negative? n) (internal-error "not in atomic mode to end")]
[(fx= n 0)
(if (eq? 0 (end-atomic-callback))
(current-atomic n)
(do-end-atomic-callback))]
[(fx< n 0) (bad-end-atomic)]
[else
;; There's a small chance that `end-atomic-callback`
;; was set by the scheduler after the check and
;; before we exit atomic mode. Make sure that rare
;; event is ok.
;; possibility remains ok.
(current-atomic n)]))
(define (do-end-atomic-callback)
(define cbs (end-atomic-callback))
(end-atomic-callback 0)
(current-atomic 0)
(let loop ([cbs cbs])
(unless (eq? cbs 0)
((car cbs))
(loop (cdr cbs)))))
(define (bad-end-atomic)
(internal-error "not in atomic mode to end"))
(define (start-atomic/no-interrupts)
(start-atomic)
(host:disable-interrupts))
@ -73,11 +84,18 @@
;; ----------------------------------------
(define-place-local end-atomic-callback #f)
(define (set-end-atomic-callback! cb)
(set! end-atomic-callback cb))
;; A "list" of callbacks to run when exiting atomic mode,
;; but the list is terminated by 0 insteda of '().
;; This definition is converted to a virtual register on
;; Chez Scheme, which explains why 0 is the "none" value.
(define end-atomic-callback (make-pthread-parameter 0))
;; in atomic mode, but need to disable interrupts to ensure
;; no race with the scheduler
(define (add-end-atomic-callback! cb)
(host:disable-interrupts)
(end-atomic-callback (cons cb (end-atomic-callback)))
(host:enable-interrupts))
;; ----------------------------------------

4
racket/src/thread/schedule.rkt
View File

@ -114,7 +114,7 @@
;; Swap out when the atomic region ends and at a point
;; where host-system interrupts are not disabled (i.e.,
;; don't use `engine-block` instead of `engine-timeout`):
(set-end-atomic-callback! engine-timeout)
(add-end-atomic-callback! engine-timeout)
(loop e)])))))))
(define (maybe-done callbacks)
@ -185,10 +185,8 @@
;; Run foreign "async-apply" callbacks, now that we're in some thread
(define (run-callbacks callbacks)
(start-atomic)
(current-break-suspend (add1 (current-break-suspend)))
(for ([callback (in-list callbacks)])
(callback))
(current-break-suspend (sub1 (current-break-suspend)))
(end-atomic))
;; ----------------------------------------

15
racket/src/thread/thread.rkt
View File

@ -40,7 +40,7 @@
break-enabled
check-for-break
break-enabled-key
current-break-suspend
current-breakable-atomic
thread-push-kill-callback!
thread-pop-kill-callback!
@ -80,7 +80,6 @@
current-break-enabled-cell
check-for-break
current-break-suspend
set-force-atomic-timeout-callback!
@ -722,8 +721,10 @@
;; A continuation-mark key (not made visible to regular Racket code):
(define break-enabled-default-cell (make-thread-cell #t))
;; For disabling breaks, such as through `unsafe-start-atomic`:
(define current-break-suspend (make-pthread-parameter 0))
;; For enable breaks despite atomic mode, such as through
;; `unsafe-start-breakable-atomic`; breaks are enabled as long as
;; `current-atomic` does not exceed `current-breakable-atomic`:
(define current-breakable-atomic (make-pthread-parameter 0))
(define (current-break-enabled-cell)
(continuation-mark-set-first #f
@ -754,7 +755,7 @@
[(and (thread-pending-break t)
(break-enabled)
(not (thread-ignore-break-cell? t (current-break-enabled-cell)))
(zero? (current-break-suspend)))
(>= (add1 (current-breakable-atomic)) (current-atomic)))
(define exn:break* (case (thread-pending-break t)
[(hang-up) exn:break:hang-up/non-engine]
[(terminate) exn:break:terminate/non-engine]
@ -804,7 +805,9 @@
(thread-reschedule! t))))
void])))
(when (eq? t check-t)
(check-for-break)))
(check-for-break)
(when (in-atomic-mode?)
(add-end-atomic-callback! check-for-break))))
(define (break>? k1 k2)
(cond

16
racket/src/thread/unsafe.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "atomic.rkt"
(require racket/fixnum
"atomic.rkt"
"thread.rkt"
"schedule.rkt"
"evt.rkt")
@ -12,21 +13,18 @@
unsafe-set-on-atomic-timeout!)
(define (unsafe-start-breakable-atomic)
(start-atomic))
(start-atomic)
(current-breakable-atomic (fx+ (current-breakable-atomic) 1)))
(define (unsafe-end-breakable-atomic)
(current-breakable-atomic (fx- (current-breakable-atomic) 1))
(end-atomic))
(define (unsafe-start-atomic)
(start-atomic)
(current-break-suspend (add1 (current-break-suspend))))
(start-atomic))
(define (unsafe-end-atomic)
(define bs (sub1 (current-break-suspend)))
(current-break-suspend bs)
(end-atomic)
(when (zero? bs)
(check-for-break)))
(end-atomic))
(define (unsafe-in-atomic?)
(positive? (current-atomic)))