diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index cca5e0664c..8d38dcf597 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -53,7 +53,6 @@ engine-timeout engine-return call-with-engine-completion - current-engine-state set-ctl-c-handler! get-ctl-c-handler set-scheduler-lock-callbacks! diff --git a/racket/src/cs/rumble/control.ss b/racket/src/cs/rumble/control.ss index 8ec12ce4f5..30c1d493c2 100644 --- a/racket/src/cs/rumble/control.ss +++ b/racket/src/cs/rumble/control.ss @@ -337,7 +337,7 @@ (#%apply values r)))])))))])))) ;; Simplified `call-in-empty-metacontinuation-frame` suitable for swapping engines: -(define (call-in-empty-metacontinuation-frame-for-swap proc) +(define (call-with-empty-metacontinuation-frame-for-swap proc) (assert-in-uninterrupted) (assert-not-in-system-wind) (call/cc @@ -355,7 +355,7 @@ (current-winders '()) (current-mark-splice empty-mark-frame) (current-metacontinuation (cons mf (current-metacontinuation))) - (let ([r (proc)]) + (let ([r (proc (current-metacontinuation))]) (let ([mf (car (current-metacontinuation))]) (pop-metacontinuation-frame) ((metacontinuation-frame-resume-k mf) r))))))) @@ -1423,8 +1423,8 @@ (maybe-future-barricade orig-tag) (let ([tag (strip-impersonator orig-tag)]) (cond - [(#%procedure? k) - (let ([mc (saved-metacontinuation-mc (k))]) + [(#%procedure? k) ; => an engine + (let ([mc (k)]) (make-continuation-mark-set (prune-mark-chain-suffix who @@ -1900,9 +1900,7 @@ ;; ---------------------------------------- ;; Metacontinuation swapping for engines -(define-record saved-metacontinuation (mc system-winders exn-state)) - -(define empty-metacontinuation (make-saved-metacontinuation '() '() (create-exception-state))) +(define empty-metacontinuation '()) ;; Similar to `call-with-current-continuation` plus ;; applying an old continuation, but does not run winders; @@ -1913,17 +1911,10 @@ [(current-system-wind-start-k) => (lambda (k) (call-with-current-metacontinuation-with-system-wind proc k))] [else - (call-in-empty-metacontinuation-frame-for-swap - (lambda () - (proc (make-saved-metacontinuation - (current-metacontinuation) - (#%$current-winders) - (current-exception-state)))))])) + (call-with-empty-metacontinuation-frame-for-swap proc)])) (define (apply-meta-continuation saved k) - (current-metacontinuation (saved-metacontinuation-mc saved)) - (#%$current-winders (saved-metacontinuation-system-winders saved)) - (current-exception-state (saved-metacontinuation-exn-state saved)) + (current-metacontinuation saved) (k)) ;; ---------------------------------------- diff --git a/racket/src/cs/rumble/engine.ss b/racket/src/cs/rumble/engine.ss index 2cb8c5d2c3..aa07f83183 100644 --- a/racket/src/cs/rumble/engine.ss +++ b/racket/src/cs/rumble/engine.ss @@ -11,7 +11,7 @@ (define-record engine-state (complete-or-expire thread-cell-values init-break-enabled-cell)) -(define-virtual-register current-engine-state #f) +(define-virtual-register current-engine-state (make-engine-state #f #f #f)) (define (set-ctl-c-handler! proc) (keyboard-interrupt-handler (case-lambda @@ -26,6 +26,18 @@ (define (set-engine-exit-handler! proc) (set! engine-exit proc)) +(define (currently-in-engine?) + (engine-state-complete-or-expire (current-engine-state))) + +(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 ;; procedure must be tail-called either within `call-with-engine-completion` or ;; in an engine call's `complete-or-expire` callback: @@ -81,9 +93,7 @@ (apply-meta-continuation to-saves (lambda () - (current-engine-state - (make-engine-state complete-or-expire thread-cell-values init-break-enabled-cell)) - (reset-handler engine-reset-handler) + (set-current-engine-state! complete-or-expire thread-cell-values init-break-enabled-cell) (timer-interrupt-handler engine-block-via-timer) (end-implicit-uninterrupted 'create) (set-timer ticks) @@ -95,18 +105,25 @@ (define (call-with-engine-completion proc) (call-with-current-metacontinuation (lambda (saves) - (let ([rh (reset-handler)]) + (let ([rh (reset-handler)] + [ws (#%$current-winders)] + [exns (current-exception-state)]) + (reset-handler engine-reset-handler) + (#%$current-winders '()) + (current-exception-state (create-exception-state)) (proc (lambda args - (current-engine-state #f) + (clear-current-engine-state!) (apply-meta-continuation saves (lambda () (reset-handler rh) + (#%$current-winders ws) + (current-exception-state exns) (#%apply values args))))))))) (define (engine-reset-handler) (end-uninterrupted 'reset) - (if (current-engine-state) + (if (currently-in-engine?) (engine-return (void)) (chez:exit))) @@ -116,31 +133,31 @@ (pending-interrupt-callback engine-block/timeout)] [else (engine-block/timeout)])) - + (define engine-block (case-lambda [(timeout?) (assert-not-in-uninterrupted) (timer-interrupt-handler void) - (let ([es (current-engine-state)] + (let ([complete-or-expire (engine-state-complete-or-expire (current-engine-state))] + [thread-cell-values (engine-state-thread-cell-values (current-engine-state))] + [init-break-enabled-cell (engine-state-init-break-enabled-cell (current-engine-state))] [remain-ticks (if timeout? 0 (set-timer 0))]) - (unless es + (unless complete-or-expire (error 'engine-block "not currently running an engine")) (start-implicit-uninterrupted 'block) (call-with-current-metacontinuation (lambda (saves) (end-implicit-uninterrupted 'block) - (current-engine-state #f) - ((engine-state-complete-or-expire es) - (create-engine - saves - (lambda (prefix) (prefix)) - (engine-state-thread-cell-values es) - (engine-state-init-break-enabled-cell es)) - #f - remain-ticks))))] + (clear-current-engine-state!) + (complete-or-expire (create-engine saves + (lambda (prefix) (prefix)) + thread-cell-values + init-break-enabled-cell) + #f + remain-ticks))))] [() (engine-block #f)])) (define (engine-block/timeout) @@ -160,16 +177,16 @@ (define (engine-return . results) (assert-not-in-uninterrupted) (timer-interrupt-handler void) - (let ([es (current-engine-state)]) - (unless es + (let ([complete-or-expire (engine-state-complete-or-expire (current-engine-state))]) + (unless complete-or-expire (error 'engine-return "not currently running an engine")) (let ([remain-ticks (set-timer 0)]) (start-implicit-uninterrupted 'block) (call-with-current-metacontinuation (lambda (ignored-saves) (end-implicit-uninterrupted 'block) - (current-engine-state #f) - ((engine-state-complete-or-expire es) #f results remain-ticks)))))) + (clear-current-engine-state!) + (complete-or-expire #f results remain-ticks)))))) (define (make-empty-thread-cell-values) (make-ephemeron-eq-hashtable)) @@ -179,10 +196,8 @@ (define original-thread-id (get-thread-id)) (define (current-engine-thread-cell-values) - (let ([es (current-engine-state)]) - (if es - (engine-state-thread-cell-values es) - (root-thread-cell-values)))) + (or (engine-state-thread-cell-values (current-engine-state)) + (root-thread-cell-values))) (define (set-current-engine-thread-cell-values! new-t) (let ([current-t (current-engine-thread-cell-values)]) @@ -209,7 +224,5 @@ new-t)) (define (current-engine-init-break-enabled-cell none-v) - (let ([es (current-engine-state)]) - (if es - (engine-state-init-break-enabled-cell es) - none-v))) + (or (engine-state-init-break-enabled-cell (current-engine-state)) + none-v)) diff --git a/racket/src/cs/rumble/foreign.ss b/racket/src/cs/rumble/foreign.ss index e9f948eff4..a858d10b62 100644 --- a/racket/src/cs/rumble/foreign.ss +++ b/racket/src/cs/rumble/foreign.ss @@ -213,7 +213,7 @@ (define/who (ptr-equal? p1 p2) (let ([p1 (unwrap-cpointer who p1)] [p2 (unwrap-cpointer who p2)]) - (with-interrupts-disabled ; disable GC while extracting addresses + (with-interrupts-disabled* ; disable GC while extracting addresses (= (cpointer-address p1) (cpointer-address p2))))) (define/who (ptr-offset p) @@ -900,7 +900,7 @@ (eq? 'utf-16be host-rep) (eq? 'utf-32le host-rep) (eq? 'utf-32be host-rep)) - (let ([v (with-interrupts-disabled + (let ([v (with-interrupts-disabled* (foreign-ref 'uptr (cpointer-address p) 0))]) (case host-rep [(utf-16le) (utf16->string (uptr->bytes/2-byte-nul v) 'little #t)] @@ -909,7 +909,7 @@ [(utf-32be) (utf16->string (uptr->bytes/4-byte-nul v) 'big #t)]))] [else ;; Disable interrupts to avoid a GC: - (with-interrupts-disabled + (with-interrupts-disabled* ;; Special treatment is needed for 'scheme-object, since the ;; host Scheme rejects the use of 'scheme-object with ;; `foreign-ref` @@ -1086,7 +1086,7 @@ "atomic destination" orig-p)] [else ;; Disable interrupts to avoid a GC: - (with-interrupts-disabled + (with-interrupts-disabled* ;; Special treatment is needed for 'scheme-object, since ;; the host Scheme rejects the use of 'scheme-object with ;; `foreign-set!` @@ -1133,7 +1133,7 @@ "destination" to "source" from)])] [else - (with-interrupts-disabled + (with-interrupts-disabled* (let ([to (+ (cpointer*-address to) to-offset)] [from (+ (cpointer*-address from) from-offset)]) (cond @@ -1275,7 +1275,7 @@ (raise-arguments-error 'memset "cannot set non-atomic" "destination" to)] [else - (with-interrupts-disabled + (with-interrupts-disabled* (let ([to (fx+ (cpointer*-address to) to-offset)]) (let loop ([to to] [len len]) (unless (fx= len 0) @@ -1420,7 +1420,7 @@ (define/who (free p) (let ([p (unwrap-cpointer who p)]) - (with-interrupts-disabled + (with-interrupts-disabled* (foreign-free (cpointer-address p))))) (define-record-type (cpointer/cell make-cpointer/cell cpointer/cell?) @@ -1618,13 +1618,13 @@ (make-ftype-pointer ,id p)))) ids) '())))]) - (let* ([wb (with-interrupts-disabled + (let* ([wb (with-interrupts-disabled* (weak-hash-ref ffi-expr->code expr #f))] [code (if wb (car wb) #!bwp)]) (if (eq? code #!bwp) (let ([code (eval/foreign expr (if call? 'comp-ffi-call 'comp-ffi-back))]) (hashtable-set! ffi-code->expr (car code) expr) - (with-interrupts-disabled + (with-interrupts-disabled* (weak-hash-set! ffi-expr->code expr (weak-cons code #f))) code) code)))] @@ -1667,24 +1667,24 @@ [proc (case-lambda [() - (c->s out-type (with-interrupts-disabled (proc)))] + (c->s out-type (with-interrupts-disabled* (proc)))] [(orig-a) (let ([a (unwrap orig-a (car in-types))]) (c->s out-type (retain orig-a - (with-interrupts-disabled (proc (unpack a (car in-types)))))))] + (with-interrupts-disabled* (proc (unpack a (car in-types)))))))] [(orig-a orig-b) (let ([a (unwrap orig-a (car in-types))] [b (unwrap orig-b (cadr in-types))]) (c->s out-type (retain orig-a orig-b - (with-interrupts-disabled + (with-interrupts-disabled* (proc (unpack a (car in-types)) (unpack b (cadr in-types)))))))] [(orig-a orig-b orig-c) (let ([a (unwrap orig-a (car in-types))] [b (unwrap orig-b (cadr in-types))] [c (unwrap orig-c (caddr in-types))]) - (c->s out-type (with-interrupts-disabled + (c->s out-type (with-interrupts-disabled* (retain orig-a orig-b orig-c (proc (unpack a (car in-types)) @@ -1697,21 +1697,21 @@ [d (unwrap orig-d (cadddr in-types))]) (c->s out-type (retain orig-a orig-b orig-c orig-d - (with-interrupts-disabled + (with-interrupts-disabled* (proc (unpack a (car in-types)) (unpack b (cadr in-types)) (unpack c (caddr in-types)) (unpack d (cadddr in-types)))))))] [orig-args (let ([args (map (lambda (a t) (unwrap a t)) orig-args in-types)]) - (c->s out-type (with-interrupts-disabled + (c->s out-type (with-interrupts-disabled* (retain orig-args (#%apply proc (map (lambda (a t) (unpack a t)) args in-types))))))])] [else (lambda orig-args (let ([args (map (lambda (a t) (unwrap a t)) orig-args in-types)]) - (c->s out-type (with-interrupts-disabled + (c->s out-type (with-interrupts-disabled* (retain orig-args (#%apply (gen-proc (cpointer-address proc-p)) @@ -1743,7 +1743,7 @@ ;; result is a struct type; need to allocate space for it (normalized-malloc ret-size ret-malloc-mode))]) (when lock (mutex-acquire lock)) - (with-interrupts-disabled + (with-interrupts-disabled* (when blocking? (currently-blocking? #t)) (retain orig-args diff --git a/racket/src/cs/rumble/interrupt.ss b/racket/src/cs/rumble/interrupt.ss index 6ac28740cf..c0374c8b63 100644 --- a/racket/src/cs/rumble/interrupt.ss +++ b/racket/src/cs/rumble/interrupt.ss @@ -1,4 +1,16 @@ +;; Like `with-interrupts-disabled`, but with no winders +;; and ways returning a single value. Avoiding winders +;; is important in "foreign.ss" so htat callbacks do +;; not return to a world with Scheme-level winders, which +;; will not interact correctly with engines. +(define-syntax-rule (with-interrupts-disabled* e0 e ...) + (begin + (disable-interrupts) + (let ([v (begin e0 e ...)]) + (enable-interrupts) + v))) + ;; Enabling uninterrupted mode defers a timer callback ;; until leaving uninterrupted mode. This is the same ;; as disabling and enabling interrupts at the Chez diff --git a/racket/src/cs/rumble/memory.ss b/racket/src/cs/rumble/memory.ss index c13e08fc0a..a6e8b717ba 100644 --- a/racket/src/cs/rumble/memory.ss +++ b/racket/src/cs/rumble/memory.ss @@ -95,7 +95,7 @@ (fx= gen (collect-maximum-generation))) (reachable-size-increments-callback compute-size-increments)) (when (and (= gen (collect-maximum-generation)) - (current-engine-state)) + (currently-in-engine?)) ;; This `set-timer` doesn't necessarily penalize the right thread, ;; but it's likely to penalize a thread that is allocating quickly: (set-timer 1)) diff --git a/racket/src/cs/thread.sls b/racket/src/cs/thread.sls index 0ca6faff69..13cf3904ef 100644 --- a/racket/src/cs/thread.sls +++ b/racket/src/cs/thread.sls @@ -12,7 +12,6 @@ [make-engine rumble:make-engine] [engine-timeout rumble:engine-timeout] [engine-return rumble:engine-return] - [current-engine-state rumble:current-engine-state] [call-with-engine-completion rumble:call-with-engine-completion] [make-condition rumble:make-condition] [condition-wait rumble:condition-wait] @@ -132,7 +131,6 @@ 'make-engine rumble:make-engine 'engine-timeout rumble:engine-timeout 'engine-return rumble:engine-return - 'current-engine-state (lambda (v) (rumble:current-engine-state v)) 'call-with-engine-completion rumble:call-with-engine-completion 'set-ctl-c-handler! rumble:set-ctl-c-handler! 'poll-will-executors poll-will-executors diff --git a/racket/src/thread/bootstrap.rkt b/racket/src/thread/bootstrap.rkt index 9c275651b0..64e8e8ffa5 100644 --- a/racket/src/thread/bootstrap.rkt +++ b/racket/src/thread/bootstrap.rkt @@ -280,8 +280,6 @@ 'condition-broadcast (lambda args (error "condition-broadcast: not ready")) 'threaded? (lambda () #f) - 'current-engine-state (lambda args - (error "current-engine state: not ready")) 'make-mutex (lambda () (make-semaphore 1)) 'mutex-acquire (lambda (s) (semaphore-wait s)) 'mutex-release (lambda (s) (semaphore-post s)) diff --git a/racket/src/thread/host.rkt b/racket/src/thread/host.rkt index f511fd90cd..ec6c85115c 100644 --- a/racket/src/thread/host.rkt +++ b/racket/src/thread/host.rkt @@ -36,7 +36,6 @@ make-engine engine-timeout engine-return - current-engine-state call-with-engine-completion current-process-milliseconds set-ctl-c-handler! diff --git a/racket/src/thread/schedule.rkt b/racket/src/thread/schedule.rkt index 8667185dd6..f09a2c9019 100644 --- a/racket/src/thread/schedule.rkt +++ b/racket/src/thread/schedule.rkt @@ -33,7 +33,9 @@ (make-initial-thread (lambda () (set-place-host-roots! initial-place (host:current-place-roots)) (thunk))) - (poll-and-select-thread! 0)) + (call-with-engine-completion + (lambda (done) + (poll-and-select-thread! 0)))) ;; Initializes the thread system in a new place: (define (call-in-another-main-thread c thunk) @@ -41,8 +43,8 @@ (set-root-custodian! c) (init-system-idle-evt!) (init-future-place!) - (call-in-main-thread thunk) - (init-schedule-counters!)) + (init-schedule-counters!) + (call-in-main-thread thunk)) ;; ----------------------------------------