From: Matt Birkholz Date: Tue, 16 Feb 2016 21:48:58 +0000 (-0700) Subject: Interrupt handlers DO want to use signal-thread-event. X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~137 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0335513678bd4dbea94d5403832688ed7db99ec1;p=mit-scheme.git Interrupt handlers DO want to use signal-thread-event. Undo ba92c7c's changes to runtime/intrpt.scm. Also, call %maybe- toggle-thread-timer after calling %signal-thread-event in runtime/ gcnote and runtime/process. --- diff --git a/src/runtime/gcnote.scm b/src/runtime/gcnote.scm index 1b69510e9..62c9b3cb7 100644 --- a/src/runtime/gcnote.scm +++ b/src/runtime/gcnote.scm @@ -108,34 +108,34 @@ USA. (and entry (weak-cdr entry)))) (define (signal-gc-events) - (let ((statistic last-statistic)) - (if (< (gc-statistic/heap-left statistic) 4096) - (begin - (for-each - (lambda (entry) - (let ((thread (weak-car entry)) - (event (weak-cdr entry))) - (if (and thread event) - (signal-event thread abort-heap-low)))) - gc-events) - (let ((console-thread - (thread-mutex-owner (port/thread-mutex console-i/o-port)))) - (if (not (weak-assq console-thread gc-events)) - (signal-event console-thread abort-heap-low)))) - (for-each - (lambda (entry) - (let ((thread (weak-car entry)) - (event (weak-cdr entry))) - (if (and thread event) - (signal-event thread (named-lambda (gc-event) - (event statistic)))))) - gc-events)))) - -(define (signal-event thread event) - (without-interrupts - (lambda () - (if (not (eq? 'DEAD (thread-execution-state thread))) - (%signal-thread-event thread event))))) + (let ((statistic last-statistic) + (signaled? #f)) + + (define (signal-event thread event) + (if (and thread (not (eq? 'DEAD (thread-execution-state thread)))) + (begin + (%signal-thread-event thread event) + (set! signaled? #t)))) + + (without-interrupts + (lambda () + (if (< (gc-statistic/heap-left statistic) 4096) + (begin + (for-each + (lambda (entry) + (signal-event (weak-car entry) abort-heap-low)) + gc-events) + (let ((thread (console-thread))) + (if (and thread (not (weak-assq thread gc-events))) + (signal-event thread abort-heap-low)))) + (for-each + (lambda (entry) + (let ((thread (weak-car entry)) + (event (weak-cdr entry))) + (signal-event thread (named-lambda (gc-event) + (event statistic))))) + gc-events)) + (if signaled? (%maybe-toggle-thread-timer)))))) (define (weak-assq obj alist) (let loop ((alist alist)) diff --git a/src/runtime/intrpt.scm b/src/runtime/intrpt.scm index 011bf7971..5cceb67d9 100644 --- a/src/runtime/intrpt.scm +++ b/src/runtime/intrpt.scm @@ -136,11 +136,9 @@ USA. (clear-interrupts! interrupt-bit/global-3) (cond ((console-thread) => (lambda (thread) - (without-interrupts - (lambda () - (%signal-thread-event thread - (lambda () - (event-distributor/invoke! event:console-resize))))))))) + (signal-thread-event thread + (lambda () + (event-distributor/invoke! event:console-resize))))))) (define ((illegal-interrupt-handler interrupt-bit) interrupt-code interrupt-enables) @@ -193,7 +191,7 @@ USA. (define (signal-interrupt hook/interrupt hook/clean-input char interrupt) (let ((thread (thread-mutex-owner (port/thread-mutex console-i/o-port)))) (if thread - (%signal-thread-event thread + (signal-thread-event thread (lambda () (if hook/interrupt (hook/interrupt)) @@ -246,7 +244,7 @@ USA. (vector-set! system-interrupt-vector character-slot external-interrupt-handler) (vector-set! interrupt-mask-vector character-slot - interrupt-mask/gc-ok) + interrupt-mask/timer-ok) (vector-set! system-interrupt-vector after-gc-slot after-gc-interrupt-handler) diff --git a/src/runtime/process.scm b/src/runtime/process.scm index 655a9a4d2..d7b3e3c47 100644 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@ -282,7 +282,10 @@ USA. (if (not (eq? status current)) (begin (%signal-thread-event - thread (and event (lambda () (event current)))) + thread (and event + (named-lambda (immediate-subprocess-status-event) + (event current)))) + (%maybe-toggle-thread-timer) (set-subprocess-registration/status! registration current)))))) registration)) @@ -321,7 +324,7 @@ USA. (define (%handle-subprocess-status-change) (if ((ucode-primitive process-status-sync-all 0)) - (begin + (let ((signaled? #f)) (for-each (lambda (weak) (let ((subprocess (weak-car weak))) (if subprocess @@ -336,7 +339,10 @@ USA. (let ((event (subprocess-registration/event registration))) (%signal-thread-event (subprocess-registration/thread registration) - (and event (lambda () (event status)))) + (and event + (named-lambda (subprocess-status-event) + (event status)))) + (set! signaled? #t) (set-subprocess-registration/status! registration status))))) subprocess-registrations) @@ -346,7 +352,8 @@ USA. (subprocess-registration/status registration))) (not (or (eq? status 'EXITED) (eq? status 'SIGNALLED))))) - subprocess-registrations))))) + subprocess-registrations)) + (if signaled? (%maybe-toggle-thread-timer))))) (define-integrable subprocess-job-control-available? (ucode-primitive os-job-control? 0)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 20ba5c364..8848df1c2 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2037,6 +2037,7 @@ USA. (export (runtime thread) %deregister-gc-event) (import (runtime thread) + %maybe-toggle-thread-timer %signal-thread-event) (initialization (initialize-package!))) @@ -2484,8 +2485,6 @@ USA. generate-suspend-file?) (export (runtime swank) keyboard-interrupt-vector) - (import (runtime thread) - %signal-thread-event) (initialization (initialize-package!))) (define-package (runtime lambda-abstraction) @@ -3908,6 +3907,7 @@ USA. deregister-subprocess-events %handle-subprocess-status-change) (import (runtime thread) + %maybe-toggle-thread-timer %signal-thread-event subprocess-registrations subprocess-support-loaded?)