Don't allocate a new result vector to pass to SELECT-REGISTRY-TEST

each time that it is called.  Instead, maintain a pool of these
vectors and pick one from the pool if it's available.

diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm
index 234783c98f3f18d9cf7b49317f07516cefe4d06e..efd03063f897e89eaf3a4d4b0abd0ecd9f733241 100644 (file)
--- a/v7/src/runtime/unxprm.scm
+++ b/v7/src/runtime/unxprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unxprm.scm,v 1.24 1993/04/27 09:14:10 cph Exp $
+$Id: unxprm.scm,v 1.25 1993/07/27 00:46:19 cph Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -249,7 +249,10 @@ MIT in each case. |#
 ;;; Queues after-restart daemon to clean up environment space
 
 (define (initialize-system-primitives!)
-  (add-event-receiver! event:after-restart reset-environment-variables!))
+  (add-event-receiver! event:after-restart reset-environment-variables!)
+  (discard-select-registry-result-vectors!)
+  (add-event-receiver! event:after-restart
+                      discard-select-registry-result-vectors!))
 
 (define (make-select-registry . descriptors)
   (let ((registry (make-string ((ucode-primitive select-registry-size 0)))))
@@ -265,29 +268,6 @@ MIT in each case. |#
 (define (remove-from-select-registry! registry descriptor)
   ((ucode-primitive select-registry-clear 2) registry descriptor))
 
-(define (select-registry-test registry block?)
-  (let ((result-vector
-        (make-vector ((ucode-primitive select-registry-lub 0)) #f)))
-    (let ((result
-          ((ucode-primitive select-registry-test 3) registry block?
-                                                    result-vector)))
-      (cond ((fix:> result 0)
-            (let loop ((index (fix:- result 1)) (descriptors '()))
-              (let ((descriptors
-                     (cons (vector-ref result-vector index) descriptors)))
-                (if (fix:= 0 index)
-                    descriptors
-                    (loop (fix:- index 1) descriptors)))))
-           ((fix:= 0 result)
-            #f)
-           ((fix:= -1 result)
-            (subprocess-global-status-tick)
-            'PROCESS-STATUS-CHANGE)
-           ((fix:= -2 result)
-            'INTERRUPT)
-           (else
-            (error "Illegal result from SELECT-REGISTRY-TEST:" result))))))
-
 (define (select-descriptor descriptor block?)
   (let ((result ((ucode-primitive select-descriptor 2) descriptor block?)))
     (case result
@@ -301,4 +281,62 @@ MIT in each case. |#
       ((-2)
        'INTERRUPT)
       (else
-       (error "Illegal result from CHANNEL-SELECT:" result)))))
\ No newline at end of file
+       (error "Illegal result from CHANNEL-SELECT:" result)))))
+\f
+(define (select-registry-test registry block?)
+  (let ((result-vector (allocate-select-registry-result-vector)))
+    (let ((result
+          ((ucode-primitive select-registry-test 3) registry block?
+                                                    result-vector)))
+      (if (fix:> result 0)
+         (let loop ((index (fix:- result 1)) (descriptors '()))
+           (let ((descriptors
+                  (cons (vector-ref result-vector index) descriptors)))
+             (if (fix:= 0 index)
+                 (begin
+                   (deallocate-select-registry-result-vector result-vector)
+                   descriptors)
+                 (loop (fix:- index 1) descriptors))))
+         (begin
+           (deallocate-select-registry-result-vector result-vector)
+           (cond ((fix:= 0 result)
+                  #f)
+                 ((fix:= -1 result)
+                  (subprocess-global-status-tick)
+                  'PROCESS-STATUS-CHANGE)
+                 ((fix:= -2 result)
+                  'INTERRUPT)
+                 (else
+                  (error "Illegal result from SELECT-REGISTRY-TEST:"
+                         result))))))))
+
+(define select-registry-result-vectors)
+
+(define (discard-select-registry-result-vectors!)
+  (set! select-registry-result-vectors '())
+  unspecific)
+
+(define (allocate-select-registry-result-vector)
+  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+    (let ((v
+          (let loop ((rv select-registry-result-vectors))
+            (cond ((null? rv)
+                   (make-vector ((ucode-primitive select-registry-lub 0)) #f))
+                  ((car rv)
+                   => (lambda (v) (set-car! rv #f) v))
+                  (else
+                   (loop (cdr rv)))))))
+      (set-interrupt-enables! interrupt-mask)
+      v)))
+
+(define (deallocate-select-registry-result-vector v)
+  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+    (let loop ((rv select-registry-result-vectors))
+      (cond ((null? rv)
+            (set! select-registry-result-vectors
+                  (cons v select-registry-result-vectors)))
+           ((car rv)
+            (loop (cdr rv)))
+           (else
+            (set-car! rv v))))
+    (set-interrupt-enables! interrupt-mask)))
\ No newline at end of file