From: Chris Hanson Date: Wed, 22 Jan 2003 19:46:40 +0000 (+0000) Subject: Change calling interface for test-select-registry so that all of the X-Git-Tag: 20090517-FFI~2055 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0a82041cf3f0bb619e8b123bfc16ead9f8b8042d;p=mit-scheme.git Change calling interface for test-select-registry so that all of the returned mode information is passed back. --- diff --git a/v7/src/microcode/prosio.c b/v7/src/microcode/prosio.c index 4f36a73d6..b20f7dbd4 100644 --- a/v7/src/microcode/prosio.c +++ b/v7/src/microcode/prosio.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: prosio.c,v 1.21 2003/01/22 18:42:26 cph Exp $ +$Id: prosio.c,v 1.22 2003/01/22 19:46:01 cph Exp $ Copyright 1987,1990,1991,1992,1993,1994 Massachusetts Institute of Technology Copyright 1996,1997,2001,2003 Massachusetts Institute of Technology @@ -304,20 +304,19 @@ DEFINE_PRIMITIVE ("TEST-SELECT-REGISTRY", Prim_test_selreg, 4, 4, 0) select_registry_t r = (arg_select_registry (1)); unsigned int rl = (OS_select_registry_length (r)); int blockp = (BOOLEAN_ARG (2)); - SCHEME_OBJECT vr = (VECTOR_ARG (3)); - SCHEME_OBJECT vw = (VECTOR_ARG (4)); + SCHEME_OBJECT vfd = (VECTOR_ARG (3)); + SCHEME_OBJECT vmode = (VECTOR_ARG (4)); int result; - if ((VECTOR_LENGTH (vr)) < (rl + 1)) + if ((VECTOR_LENGTH (vfd)) < rl) error_bad_range_arg (3); - if ((VECTOR_LENGTH (vw)) < (rl + 1)) + if ((VECTOR_LENGTH (vmode)) < rl) error_bad_range_arg (4); result = (OS_test_select_registry (r, blockp)); if (result > 0) { unsigned int i = 0; - unsigned int ir = 1; - unsigned int iw = 1; + unsigned int iv = 0; while (i < rl) { int fd; @@ -326,24 +325,12 @@ DEFINE_PRIMITIVE ("TEST-SELECT-REGISTRY", Prim_test_selreg, 4, 4, 0) OS_select_registry_result (r, i, (&fd), (&mode)); if (mode > 0) { - SCHEME_OBJECT sfd = (long_to_integer (fd)); - if (((mode & SELECT_MODE_READ) != 0) - || ((mode & SELECT_MODE_ERROR) != 0) - || ((mode & SELECT_MODE_HUP) != 0)) - { - VECTOR_SET (vr, ir, sfd); - ir += 1; - } - if ((mode & SELECT_MODE_WRITE) != 0) - { - VECTOR_SET (vw, iw, sfd); - iw += 1; - } + VECTOR_SET (vfd, iv, (long_to_integer (fd))); + VECTOR_SET (vmode, iv, (ulong_to_integer (mode))); + iv += 1; } i += 1; } - VECTOR_SET (vr, 0, (ulong_to_integer (ir - 1))); - VECTOR_SET (vw, 0, (ulong_to_integer (iw - 1))); } PRIMITIVE_RETURN (long_to_integer (result)); } diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index 200a9cefb..78efbab76 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: io.scm,v 14.68 2003/01/22 18:43:05 cph Exp $ +$Id: io.scm,v 14.69 2003/01/22 19:46:32 cph Exp $ Copyright 1986,1987,1988,1990,1991,1993 Massachusetts Institute of Technology Copyright 1994,1995,1998,1999,2000,2001 Massachusetts Institute of Technology @@ -1237,20 +1237,13 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. descriptor block? (encode-select-registry-mode mode)))) - (if (>= result 0) - (cond ((fix:= 8 (fix:and 8 result)) 'HANGUP) - ((fix:= 4 (fix:and 4 result)) 'ERROR) - (else - (if (fix:= 1 (fix:and 1 result)) - (if (fix:= 2 (fix:and 2 result)) 'READ/WRITE 'READ) - (if (fix:= 2 (fix:and 2 result)) 'WRITE #f)))) - (case result - ((-1) 'INTERRUPT) - ((-2) + (cond ((>= result 0) (decode-select-registry-mode result)) + ((= result -1) 'INTERRUPT) + ((= result -2) (subprocess-global-status-tick) 'PROCESS-STATUS-CHANGE) (else - (error "Illegal result from TEST-SELECT-DESCRIPTOR:" result)))))) + (error "Illegal result from TEST-SELECT-DESCRIPTOR:" result))))) (define (encode-select-registry-mode mode) (case mode @@ -1258,19 +1251,32 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ((WRITE) 2) ((READ/WRITE) 3) (else (error:bad-range-argument mode 'ENCODE-SELECT-REGISTRY-MODE)))) + +(define (decode-select-registry-mode mode) + (cond ((fix:= 8 (fix:and 8 mode)) 'HANGUP) + ((fix:= 4 (fix:and 4 mode)) 'ERROR) + (else + (if (fix:= 1 (fix:and 1 mode)) + (if (fix:= 2 (fix:and 2 mode)) 'READ/WRITE 'READ) + (if (fix:= 2 (fix:and 2 mode)) 'WRITE #f))))) (define (test-select-registry registry block?) - (receive (vr vw) (allocate-select-registry-result-vectors registry) + (receive (vfd vmode) (allocate-select-registry-result-vectors registry) (let ((result ((ucode-primitive test-select-registry 4) (select-registry-handle registry) block? - vr - vw))) + vfd + vmode))) (if (> result 0) - (cons vr vw) (begin - (deallocate-select-registry-result-vectors vr vw) + (do ((i 0 (fix:+ i 1))) + ((fix:= i result)) + (vector-set! vmode i + (decode-select-registry-mode (vector-ref vmode i)))) + (vector result vfd vmode)) + (begin + (deallocate-select-registry-result-vectors vfd vmode) (cond ((= 0 result) #f) ((= -1 result) 'INTERRUPT) ((= -2 result) @@ -1291,14 +1297,14 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. rl)))) (let loop ((rv select-registry-result-vectors)) (if (pair? rv) - (let ((vr (caar rv)) - (vw (cdar rv))) - (if (and vr (fix:< n (vector-length vr))) + (let ((vfd (caar rv)) + (vmode (cdar rv))) + (if (and vfd (fix:<= n (vector-length vfd))) (begin (set-car! (car rv) #f) (set-cdr! (car rv) #f) (set-interrupt-enables! interrupt-mask) - (values vr vw)) + (values vfd vmode)) (loop (cdr rv)))) (let loop ((m 16)) (if (fix:< n m) @@ -1307,15 +1313,15 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (values (make-vector m) (make-vector m))) (loop (fix:* m 2))))))))) -(define (deallocate-select-registry-result-vectors vr vw) +(define (deallocate-select-registry-result-vectors vfd vmode) (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) (let loop ((rv select-registry-result-vectors)) (if (pair? rv) (if (caar rv) (loop (cdr rv)) (begin - (set-car! (car rv) vr) - (set-cdr! (car rv) vw))) + (set-car! (car rv) vfd) + (set-cdr! (car rv) vmode))) (set! select-registry-result-vectors - (cons (cons vr vw) select-registry-result-vectors)))) + (cons (cons vfd vmode) select-registry-result-vectors)))) (set-interrupt-enables! interrupt-mask))) \ No newline at end of file diff --git a/v7/src/runtime/thread.scm b/v7/src/runtime/thread.scm index 50379cc28..900aef168 100644 --- a/v7/src/runtime/thread.scm +++ b/v7/src/runtime/thread.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: thread.scm,v 1.37 2003/01/22 02:05:41 cph Exp $ +$Id: thread.scm,v 1.38 2003/01/22 19:46:40 cph Exp $ Copyright 1991,1992,1993,1998,1999,2001 Massachusetts Institute of Technology Copyright 2003 Massachusetts Institute of Technology @@ -455,10 +455,14 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (wait-for-io))))))) (define (signal-select-result result) - (cond ((pair? result) - (signal-io-thread-events (car result) (cdr result))) + (cond ((vector? result) + (signal-io-thread-events (vector-ref result 0) + (vector-ref result 1) + (vector-ref result 2))) ((eq? 'PROCESS-STATUS-CHANGE result) - (signal-io-thread-events '#(1 PROCESS-STATUS-CHANGE) '#(0))))) + (signal-io-thread-events 1 + '#(PROCESS-STATUS-CHANGE) + '#(READ))))) (define (block-on-io-descriptor descriptor mode) (without-interrupts @@ -497,12 +501,14 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (%deregister-io-thread-event registration-1))))))) (define (permanently-register-io-thread-event descriptor mode thread event) + (guarantee-select-mode mode 'PERMANENTLY-REGISTER-IO-THREAD-EVENT) (guarantee-thread thread 'PERMANENTLY-REGISTER-IO-THREAD-EVENT) (without-interrupts (lambda () (%register-io-thread-event descriptor mode thread event #t #f)))) (define (register-io-thread-event descriptor mode thread event) + (guarantee-select-mode mode 'REGISTER-IO-THREAD-EVENT) (guarantee-thread thread 'REGISTER-IO-THREAD-EVENT) (without-interrupts (lambda () @@ -518,6 +524,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (%maybe-toggle-thread-timer)))) (define (deregister-io-descriptor-events descriptor mode) + (guarantee-select-mode mode 'DEREGISTER-IO-DESCRIPTOR-EVENTS) (without-interrupts (lambda () (let loop ((dentry io-registrations)) @@ -597,42 +604,44 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (not (tentry/permanent? tentry)))) (cons tentry tentries) tentries)))))))) + +(define (guarantee-select-mode mode procedure) + (if (not (memq mode '(READ WRITE READ-WRITE))) + (error:wrong-type-argument mode "select mode" procedure))) -(define (signal-io-thread-events vr vw) +(define (signal-io-thread-events n vfd vmode) (let ((search - (lambda (descriptor v) - (let ((n (vector-ref v 0))) - (let loop ((i 1)) - (and (fix:<= i n) - (or (eqv? descriptor (vector-ref v i)) - (loop (fix:+ i 1))))))))) - (let loop ((dentry io-registrations) (events '())) - (if dentry - (let ((mode - (let ((descriptor (dentry/descriptor dentry)) - (mode (dentry/mode dentry))) - (case mode - ((READ) (and (search descriptor vr) 'READ)) - ((WRITE) (and (search descriptor vw) 'WRITE)) - ((READ/WRITE) - (if (search descriptor vr) - (if (search descriptor vw) 'READ/WRITE 'READ) - (if (search descriptor vw) 'WRITE #f))) - (else #f))))) - (if mode - (let ((next (dentry/next dentry)) - (tentry (dentry/first-tentry dentry))) - (let ((events - (cons (cons (tentry/thread tentry) - (let ((e (tentry/event tentry))) - (and e - (lambda () (e mode))))) - events))) - (if (tentry/permanent? tentry) - (move-tentry-to-back! tentry) - (delete-tentry! tentry)) - (loop next events))) - (loop (dentry/next dentry) events))) + (lambda (descriptor predicate) + (let scan-dentries ((dentry io-registrations)) + (and dentry + (if (and (eqv? descriptor (dentry/descriptor dentry)) + (predicate (dentry/mode dentry))) + dentry + (scan-dentries (dentry/next dentry)))))))) + (let loop ((i 0) (events '())) + (if (fix:< i n) + (let ((descriptor (vector-ref vfd i)) + (mode (vector-ref vmode i))) + (let ((dentry + (search + descriptor + (case mode + ((READ) (lambda (mode) (memq mode '(READ READ/WRITE)))) + ((WRITE) (lambda (mode) (memq mode '(WRITE READ/WRITE)))) + ((READ/WRITE) (lambda (mode) mode)) + ((ERROR HANGUP) (lambda (mode) mode #t)) + (else (error "Illegal mode:" mode)))))) + (let ((tentry (dentry/first-tentry dentry))) + (let ((events + (cons (cons (tentry/thread tentry) + (let ((e (tentry/event tentry))) + (and e + (lambda () (e mode))))) + events))) + (if (tentry/permanent? tentry) + (move-tentry-to-back! tentry) + (delete-tentry! tentry)) + (loop (fix:+ i 1) events))))) (do ((events events (cdr events))) ((not (pair? events))) (%signal-thread-event (caar events) (cdar events)))))))