From: Matt Birkholz Date: Fri, 13 Mar 2015 17:41:00 +0000 (-0700) Subject: Merge branch 'Gtk-Screen' into SMP-Gtk. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c22f1e7f99000cb8774d4e90b6036ac7c7e1fda1;p=mit-scheme.git Merge branch 'Gtk-Screen' into SMP-Gtk. --- c22f1e7f99000cb8774d4e90b6036ac7c7e1fda1 diff --cc src/edwin/tterm.scm index e2542d934,6b1538bf8..31824312b --- a/src/edwin/tterm.scm +++ b/src/edwin/tterm.scm @@@ -307,14 -313,17 +307,17 @@@ USA (values (named-lambda (halt-update?) (or (fix:< start end) - (read-more? #f))) + (read-more? #f #f))) - (named-lambda (peek-no-hang) - (let ((event (->event (match-event #f)))) - (if (input-event? event) - (begin - (apply-input-event event) - #f) - event))) + (named-lambda (peek-no-hang msec) + (keyboard-peek-busy-no-hang + (lambda () + (let ((event (->event (match-event #f)))) + (if (input-event? event) + (begin + (apply-input-event event) + #f) + event))) + msec)) (named-lambda (peek) (->event (match-event #t))) (named-lambda (read) diff --cc src/microcode/osio.h index ee8d32af4,9f58fff92..4899af0c9 --- a/src/microcode/osio.h +++ b/src/microcode/osio.h @@@ -109,10 -109,6 +109,10 @@@ extern int OS_test_select_registr (select_registry_t registry, int blockp); extern int OS_test_select_descriptor (int fd, int blockp, unsigned int mode); +#ifdef ENABLE_SMP +extern void OS_copy_select_registry + (select_registry_t from, select_registry_t to); +#endif - extern int OS_pause (void); + extern int OS_pause (int blockp); #endif /* SCM_OSIO_H */ diff --cc src/microcode/uxio.c index 092f29948,8011c9ece..2819fac3f --- a/src/microcode/uxio.c +++ b/src/microcode/uxio.c @@@ -575,25 -538,17 +575,36 @@@ OS_select_registry_length (select_regis return (SR_N_FDS (r)); } +#ifdef ENABLE_SMP +void +OS_copy_select_registry (select_registry_t from, select_registry_t to) +{ + struct select_registry_s * f = from; + struct select_registry_s * t = to; + int fl = SR_LENGTH (f); + int tl = SR_LENGTH (t); + if (tl < fl) + { + free (SR_ENTRIES (t)); + (SR_ENTRIES (t)) = (UX_malloc (SR_BYTES (fl))); + (SR_LENGTH (t)) = fl; + } + memcpy ((SR_ENTRIES (t)), (SR_ENTRIES (f)), (SR_BYTES (SR_N_FDS (f)))); + (SR_N_FDS (t)) = (SR_N_FDS (f)); +} +#endif + + void + OS_select_registry_entry (select_registry_t registry, + unsigned int index, + int * fd_r, + unsigned int * mode_r) + { + struct select_registry_s * r = registry; + (*fd_r) = ((SR_ENTRY (r, index)) -> fd); + (*mode_r) = (ENCODE_MODE ((SR_ENTRY (r, index)) -> events)); + } + void OS_select_registry_result (select_registry_t registry, unsigned int index, @@@ -949,18 -889,25 +964,31 @@@ safe_pause (void n = SELECT_INTERRUPT; } UX_sigprocmask (SIG_SETMASK, &old, NULL); - return (n); -#else - /* Wait-for-io must spin. */ - return - ((OS_process_any_status_change ()) - ? SELECT_PROCESS_STATUS_CHANGE - : SELECT_INTERRUPT); + +#else /* not HAVE_SIGSUSPEND */ + INTERRUPTABLE_EXTENT + (n, (((OS_process_any_status_change ()) + || (pending_interrupts_p ())) + ? ((errno = EINTR), (-1)) + : ((UX_pause ()), (0)))); + if (OS_process_any_status_change()) + n = SELECT_PROCESS_STATUS_CHANGE; + else + n = SELECT_INTERRUPT; + #endif + return (n); } + + int + OS_pause (int blockp) + { + if (!blockp) + { + return ((OS_process_any_status_change ()) + ? SELECT_PROCESS_STATUS_CHANGE + : SELECT_INTERRUPT); + } + else + return (safe_pause ()); + } diff --cc src/runtime/ffi.scm index 8572955ae,b8ebdf251..91dd2ae8a --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@@ -449,13 -439,9 +449,11 @@@ USA (else (next-id (1+ id))))))) (define (de-register-c-callback id) - (vector-set! registered-callbacks id #f) - (if (< id first-free-id) - (set! first-free-id id))) + (with-thread-mutex-locked registered-callbacks-mutex + (lambda () + (vector-set! registered-callbacks id #f) - ;; Uncomment to recycle ids. + (if (< id first-free-id) - (set! first-free-id id)) - ))) ++ (set! first-free-id id))))) (define (normalize-aliens! args) ;; Any vectors among ARGS are assumed to be freshly-consed aliens @@@ -608,7 -597,7 +607,7 @@@ (syntax-rules () ((_ MSG ...) (if %trace? - (outf-error MSG ...))))) + (outf-error MSG ... "\n"))))) -(define (tindent) - (make-string (* 2 (length calloutback-stack)) #\space)) +(define (tindent id) - (make-string (* 2 (length (vector-ref calloutback-stacks id))) #\space)) ++ (make-string (* 2 (length (vector-ref calloutback-stacks id))) #\space)) diff --cc src/runtime/io.scm index 3f0720812,e8292e2c4..8f1699d04 --- a/src/runtime/io.scm +++ b/src/runtime/io.scm @@@ -757,11 -760,17 +757,11 @@@ USA (pathname=? pathname* pathname)))))) (define (find-dld-handle predicate) - (find-matching-item dld-handles predicate)) + (with-thread-mutex-locked dld-handles-mutex + (lambda () + (find-matching-item dld-handles predicate)))) (define (all-dld-handles) - (list-copy dld-handles)) - -(define (unload-all-dld-object-files) - (without-interrupts - (lambda () - (let loop () - (if (pair? dld-handles) - (let ((handle (car dld-handles))) - (set! dld-handles (cdr dld-handles)) - (%dld-unload-file handle) - (loop))))))) + (with-thread-mutex-locked dld-handles-mutex + (lambda () - (list-copy dld-handles)))) ++ (list-copy dld-handles)))) diff --cc src/runtime/process.scm index c2ad76fe8,d8a0a8274..efdb1a943 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@@ -245,8 -271,14 +257,10 @@@ USA ((3) 'JOB-CONTROL) (else (error "Illegal process job-control status:" n))))) + (define last-global-tick '()) + (define (handle-subprocess-status-change) - (let ((latest-tick (subprocess-global-status-tick))) - (if (not (eq? latest-tick last-global-tick)) - (begin - (signal-subprocess-status-change) - (set! last-global-tick latest-tick)))) + (with-threads-locked %handle-subprocess-status-change) (if (eq? 'NT microcode-id/operating-system) (for-each (lambda (process) (if (memq (subprocess-status process) '(EXITED SIGNALLED)) diff --cc src/runtime/thread.scm index a5f48846c,e17fadf20..20cea287a --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@@ -792,42 -556,64 +792,78 @@@ USA (define (%maybe-deregister-io-thread-event tentry) ;; Ensure that another thread does not unwind our registration. - (if (eq? (current-thread) (tentry/thread tentry)) + (assert-locked '%maybe-deregister-io-thread-event) + (if (and (tentry/dentry tentry) + (eq? (%current-thread (%id)) (tentry/thread tentry))) (delete-tentry! tentry))) + + (define (block-on-process-status-change) + (without-interrupts + (lambda () + (let ((registration)) + (dynamic-wind + (lambda () + (let ((thread (current-thread))) + (set! registration + (%register-io-thread-event + 'PROCESS-STATUS-CHANGE + 'READ + thread + (lambda (mode) + (declare (ignore mode)) + unspecific) + #f #t))) + (%maybe-toggle-thread-timer)) + (lambda () + (%suspend-current-thread)) + (lambda () + (%deregister-io-thread-event registration) + (%maybe-toggle-thread-timer))))))) + + (define (register-subprocess-status-change-event event) + (guarantee-procedure-of-arity event 1 'register-subprocess-status-change-event) + (without-interrupts + (lambda () + (%register-io-thread-event + 'PROCESS-STATUS-CHANGE + 'READ + (current-thread) + event + #t ;permanent? + #f ;front? + )))) (define (permanently-register-io-thread-event descriptor mode thread event) - (register-io-thread-event-1 descriptor mode thread event - #t 'PERMANENTLY-REGISTER-IO-THREAD-EVENT)) + (guarantee-select-mode mode 'permanently-register-io-thread-event) + (guarantee-thread thread 'permanently-register-io-thread-event) + (let ((registration)) + (set! registration + (make-tentry thread + (lambda (mode*) + (event mode*) + (with-threads-locked + (lambda () + (%register-io-thread-event descriptor mode + registration #f) + (%maybe-toggle-thread-timer) + (%maybe-wake-io-waiter)))))) + (with-threads-locked + (lambda () + (%register-io-thread-event descriptor mode registration #f) + (%maybe-toggle-thread-timer) + (%maybe-wake-io-waiter))) + registration)) (define (register-io-thread-event descriptor mode thread event) - (register-io-thread-event-1 descriptor mode thread event - #f 'REGISTER-IO-THREAD-EVENT)) - -(define (register-io-thread-event-1 descriptor mode thread event - permanent? caller) - (guarantee-select-mode mode caller) - (guarantee-thread thread caller) - (without-interrupts - (lambda () - (let ((registration - (%register-io-thread-event descriptor mode thread event - permanent? #f))) + (guarantee-select-mode mode 'register-io-thread-event) + (guarantee-thread thread 'register-io-thread-event) + (let ((registration (make-tentry thread event))) + (with-threads-locked + (lambda () + (%register-io-thread-event descriptor mode registration #f) (%maybe-toggle-thread-timer) - registration)))) + (%maybe-wake-io-waiter))) + registration)) (define (deregister-io-thread-event tentry) (if (not (tentry? tentry))