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

cs: small further improvement to thread swapping

Browse Source 
Instead of mutating a record, update virtual registers. Updating a
virtual register doesn't involve a write barrier.
This commit is contained in:
Matthew Flatt 2019-10-06 08:18:06 -06:00
parent 88e7e0a5e4
commit ca285c384d
3 changed files with 28 additions and 31 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 collection 'multi)
(define version "7.4.0.11") (define version "7.4.0.12")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

49
racket/src/cs/rumble/engine.ss
View File

@ -9,9 +9,12 @@
;; Don't mix Chez engines with this implementation, because we take ;; Don't mix Chez engines with this implementation, because we take
;; over the timer. ;; over the timer.
(define-record engine-state (complete-or-expire thread-cell-values init-break-enabled-cell)) (define-record-type engine-cell-state
(fields thread-cell-values init-break-enabled-cell))
(define empty-engine-cell-state (make-engine-cell-state #f #f))
(define-virtual-register current-engine-state (make-engine-state #f #f #f)) (define-virtual-register current-engine-complete-or-expire #f)
(define-virtual-register current-engine-cell-state empty-engine-cell-state)
(define (set-ctl-c-handler! proc) (define (set-ctl-c-handler! proc)
(keyboard-interrupt-handler (case-lambda (keyboard-interrupt-handler (case-lambda
@ -27,16 +30,7 @@
(set! engine-exit proc)) (set! engine-exit proc))
(define (currently-in-engine?) (define (currently-in-engine?)
(engine-state-complete-or-expire (current-engine-state))) (current-engine-complete-or-expire))
(define (set-current-engine-state! complete-or-expire thread-cell-values init-break-enabled-cell)
(let ([es (current-engine-state)])
(set-engine-state-complete-or-expire! es complete-or-expire)
(set-engine-state-thread-cell-values! es thread-cell-values)
(set-engine-state-init-break-enabled-cell! es init-break-enabled-cell)))
(define (clear-current-engine-state!)
(set-current-engine-state! #f #f #f))
;; An engine is repesented by a procedure that takes three arguments, where the ;; An engine is repesented by a procedure that takes three arguments, where the
;; procedure must be tail-called either within `call-with-engine-completion` or ;; procedure must be tail-called either within `call-with-engine-completion` or
@ -76,14 +70,15 @@
prompt-tag prompt-tag
abort-handler)) abort-handler))
engine-return)))) engine-return))))
(make-engine-cell-state
(if empty-config? (if empty-config?
(make-empty-thread-cell-values) (make-empty-thread-cell-values)
(new-engine-thread-cell-values)) (new-engine-thread-cell-values))
init-break-enabled-cell))) init-break-enabled-cell))))
;; Internal: creates an engine procedure to be called within `call-with-engine-completion` ;; Internal: creates an engine procedure to be called within `call-with-engine-completion`
;; or from an enginer procedure's `complete-or-expire` callback ;; or from an enginer procedure's `complete-or-expire` callback
(define (create-engine to-saves proc thread-cell-values init-break-enabled-cell) (define (create-engine to-saves proc cell-state)
(case-lambda (case-lambda
;; For `continuation-marks`: ;; For `continuation-marks`:
[() to-saves] [() to-saves]
@ -93,7 +88,8 @@
(apply-meta-continuation (apply-meta-continuation
to-saves to-saves
(lambda () (lambda ()
(set-current-engine-state! complete-or-expire thread-cell-values init-break-enabled-cell) (current-engine-complete-or-expire complete-or-expire)
(current-engine-cell-state cell-state)
(timer-interrupt-handler engine-block-via-timer) (timer-interrupt-handler engine-block-via-timer)
(end-implicit-uninterrupted 'create) (end-implicit-uninterrupted 'create)
(set-timer ticks) (set-timer ticks)
@ -112,7 +108,8 @@
(#%$current-winders '()) (#%$current-winders '())
(current-exception-state (create-exception-state)) (current-exception-state (create-exception-state))
(proc (lambda args (proc (lambda args
(clear-current-engine-state!) (current-engine-complete-or-expire #f)
(current-engine-cell-state empty-engine-cell-state)
(apply-meta-continuation (apply-meta-continuation
saves saves
(lambda () (lambda ()
@ -139,9 +136,8 @@
[(timeout?) [(timeout?)
(assert-not-in-uninterrupted) (assert-not-in-uninterrupted)
(timer-interrupt-handler void) (timer-interrupt-handler void)
(let ([complete-or-expire (engine-state-complete-or-expire (current-engine-state))] (let ([complete-or-expire (current-engine-complete-or-expire)]
[thread-cell-values (engine-state-thread-cell-values (current-engine-state))] [cell-state (current-engine-cell-state)]
[init-break-enabled-cell (engine-state-init-break-enabled-cell (current-engine-state))]
[remain-ticks (if timeout? [remain-ticks (if timeout?
0 0
(set-timer 0))]) (set-timer 0))])
@ -151,11 +147,11 @@
(call-with-current-metacontinuation (call-with-current-metacontinuation
(lambda (saves) (lambda (saves)
(end-implicit-uninterrupted 'block) (end-implicit-uninterrupted 'block)
(clear-current-engine-state!) (current-engine-complete-or-expire #f)
(current-engine-cell-state empty-engine-cell-state)
(complete-or-expire (create-engine saves (complete-or-expire (create-engine saves
(lambda (prefix) (prefix)) (lambda (prefix) (prefix))
thread-cell-values cell-state)
init-break-enabled-cell)
#f #f
remain-ticks))))] remain-ticks))))]
[() (engine-block #f)])) [() (engine-block #f)]))
@ -177,7 +173,7 @@
(define (engine-return . results) (define (engine-return . results)
(assert-not-in-uninterrupted) (assert-not-in-uninterrupted)
(timer-interrupt-handler void) (timer-interrupt-handler void)
(let ([complete-or-expire (engine-state-complete-or-expire (current-engine-state))]) (let ([complete-or-expire (current-engine-complete-or-expire)])
(unless complete-or-expire (unless complete-or-expire
(error 'engine-return "not currently running an engine")) (error 'engine-return "not currently running an engine"))
(let ([remain-ticks (set-timer 0)]) (let ([remain-ticks (set-timer 0)])
@ -185,7 +181,8 @@
(call-with-current-metacontinuation (call-with-current-metacontinuation
(lambda (ignored-saves) (lambda (ignored-saves)
(end-implicit-uninterrupted 'block) (end-implicit-uninterrupted 'block)
(clear-current-engine-state!) (current-engine-complete-or-expire #f)
(current-engine-cell-state empty-engine-cell-state)
(complete-or-expire #f results remain-ticks)))))) (complete-or-expire #f results remain-ticks))))))
(define (make-empty-thread-cell-values) (define (make-empty-thread-cell-values)
@ -196,7 +193,7 @@
(define original-thread-id (get-thread-id)) (define original-thread-id (get-thread-id))
(define (current-engine-thread-cell-values) (define (current-engine-thread-cell-values)
(or (engine-state-thread-cell-values (current-engine-state)) (or (engine-cell-state-thread-cell-values (current-engine-cell-state))
(root-thread-cell-values))) (root-thread-cell-values)))
(define (set-current-engine-thread-cell-values! new-t) (define (set-current-engine-thread-cell-values! new-t)
@ -224,5 +221,5 @@
new-t)) new-t))
(define (current-engine-init-break-enabled-cell none-v) (define (current-engine-init-break-enabled-cell none-v)
(or (engine-state-init-break-enabled-cell (current-engine-state)) (or (engine-cell-state-init-break-enabled-cell (current-engine-cell-state))
none-v)) none-v))

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

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 4 #define MZSCHEME_VERSION_Y 4
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 11 #define MZSCHEME_VERSION_W 12
/* A level of indirection makes `#` work as needed: */ /* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x #define AS_a_STR_HELPER(x) #x