Changeset 4895

Timestamp:

Jul 23, 2006, 12:12:42 AM (18 years ago)

Author:

Gary Byers

Message:

Fix a few botches.

:private arg to stream creation primitives replaced with :sharing, which can
have values:

:private (the default; stream can only be accessed by the creating thread)
:lock (the old, often slow, default); most accesses to stream involve locking
:nil or :external (stream code doesn't enforce exclusion).

Location:

trunk/ccl/level-1

Files:

• l1-boot-2.lisp (modified) (2 diffs)
• l1-sockets.lisp (modified) (5 diffs)
• l1-streams.lisp (modified) (13 diffs)
• l1-sysio.lisp (modified) (3 diffs)

trunk/ccl/level-1/l1-boot-2.lisp

@@ -83 +83 @@
 (def-ccl-pointers fd-streams ()
   (setq *stdin* (make-fd-stream 0
-                                :private nil
+                                :sharing :lock
                                 :direction :input
                                 :interactive (not *batch-flag*)))
-  (setq *stdout* (make-fd-stream 1 :direction :output :private nil))
-
-  (setq *stderr* (make-fd-stream 2 :direction :output :private nil))
+  (setq *stdout* (make-fd-stream 1 :direction :output :sharing :lock))
+
+  (setq *stderr* (make-fd-stream 2 :direction :output :sharing :lock))
   (if *batch-flag*
     (let* ((tty-fd (let* ((fd (fd-open "/dev/tty" #$O_RDWR)))
@@ -98 +98 @@
                                           :direction :input
                                           :interactive t
-                                          :private nil)
-         *terminal-output* (make-fd-stream tty-fd :direction :output :private nil)
+                                          :sharing :lock)
+         *terminal-output* (make-fd-stream tty-fd :direction :output :sharing :lock)
          *terminal-io* (make-echoing-two-way-stream
                         *terminal-input* *terminal-output*))

trunk/ccl/level-1/l1-sockets.lisp

@@ -569 +569 @@
                     keepalive reuse-address nodelay broadcast linger
                     local-port local-host backlog class out-of-band-inline
-                    local-filename remote-filename private)
+                    local-filename remote-filename sharing)
   "Create and return a new socket."
   (declare (dynamic-extent keys))
@@ -575 +575 @@
                    keepalive reuse-address nodelay broadcast linger
                    local-port local-host backlog class out-of-band-inline
-                   local-filename remote-filename private))
+                   local-filename remote-filename sharing))
   (ecase address-family
     ((:file) (apply #'make-file-socket keys))
@@ -666 +666 @@
 
 
-(defun make-tcp-stream (fd &key format eol (class 'tcp-stream) private &allow-other-keys)
+(defun make-tcp-stream (fd &key format eol (class 'tcp-stream) sharing &allow-other-keys)
   (declare (ignore eol))                ;???
   (let ((element-type (ecase format
@@ -677 +677 @@
                     :direction :io
                     :element-type element-type
-                    :private private)))
-
-(defun make-file-socket-stream (fd &key format eol (class 'file-socket-stream)  private &allow-other-keys)
+                    :sharing sharing)))
+
+(defun make-file-socket-stream (fd &key format eol (class 'file-socket-stream)  sharing &allow-other-keys)
   (declare (ignore eol))                ;???
   (let ((element-type (ecase format
@@ -690 +690 @@
                     :direction :io
                     :element-type element-type
-                    :private private)))
+                    :sharing sharing)))
 
 (defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys)

trunk/ccl/level-1/l1-streams.lisp

@@ -275 +275 @@
 (defmethod close ((stream stream) &key abort)
   (declare (ignore abort))
-  (with-slots ((closed closed)) stream
-    (unless closed
-      (setf closed t))))
+  (open-stream-p stream))
 
 
@@ -420 +418 @@
 
 (defmacro with-ioblock-input-locked ((ioblock) &body body)
-  `(if (check-ioblock-owner ,ioblock)
-    (progn ,@body)
-    (with-ioblock-lock-grabbed ((locally (declare (optimize (speed 3) (safety 0)))
+  (let* ((lock (gensym)))
+    `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0)))
+                                  (ioblock-inbuf-lock ,ioblock))))
+      (if ,lock
+        (with-ioblock-lock-grabbed ((locally (declare (optimize (speed 3) (safety 0)))
                                   (ioblock-inbuf-lock ,ioblock)))
-      ,@body)))
+          ,@body)
+        (progn
+          (check-ioblock-owner ,ioblock)
+          ,@body)))))
+
 
 (defmacro with-ioblock-output-locked ((ioblock) &body body)
-  `(if (check-ioblock-owner ,ioblock)
-    (progn ,@body)
-    (with-ioblock-lock-grabbed ((locally (declare (optimize (speed 3) (safety 0)))
+  (let* ((lock (gensym)))
+    `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0)))
+                                  (ioblock-inbuf-lock ,ioblock))))
+      (if ,lock
+        (with-ioblock-lock-grabbed ((locally (declare (optimize (speed 3) (safety 0)))
                                   (ioblock-outbuf-lock ,ioblock)))
-      ,@body)))
+          ,@body)
+        (progn
+          (check-ioblock-owner ,ioblock)
+          ,@body)))))
 
 (defmacro with-ioblock-output-locked-maybe ((ioblock) &body body)
-  `(if (check-ioblock-owner ,ioblock)
-    (progn ,@body)
-    (with-ioblock-lock-grabbed-maybe ((locally (declare (optimize (speed 3) (safety 0)))
-                                        (ioblock-outbuf-lock ,ioblock)))
-      ,@body)))
+  (let* ((lock (gensym)))
+    `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0)))
+                                  (ioblock-inbuf-lock ,ioblock))))
+      (if ,lock
+        (with-ioblock-lock-grabbed-maybe ((locally (declare (optimize (speed 3) (safety 0)))
+                                            (ioblock-outbuf-lock ,ioblock)))
+          ,@body)
+        (progn
+          (check-ioblock-owner ,ioblock)
+          ,@body)))))
 
 (defun %ioblock-advance (ioblock read-p)
@@ -484 +498 @@
       (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
       (schar (io-buffer-buffer buf) idx))))
+
+(declaim (inline %private-ioblock-tyi))
+(defun %private-ioblock-tyi (ioblock)
+  (declare (optimize (speed 3) (safety 0)))
+  (check-ioblock-owner ioblock)
+  (if (ioblock-untyi-char ioblock)
+    (prog1 (ioblock-untyi-char ioblock)
+      (setf (ioblock-untyi-char ioblock) nil))
+    (let* ((buf (ioblock-inbuf ioblock))
+           (idx (io-buffer-idx buf))
+           (limit (io-buffer-count buf)))
+      (declare (fixnum idx limit))
+      (when (= idx limit)
+        (unless (%ioblock-advance ioblock t)
+          (return-from %private-ioblock-tyi (if (ioblock-eof ioblock) :eof)))
+        (setq idx (io-buffer-idx buf)
+              limit (io-buffer-count buf)))
+      (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
+      (schar (io-buffer-buffer buf) idx))))
+
+(declaim (inline %locked-ioblock-tyi))
+(defun %locked-ioblock-tyi (ioblock)
+  (declare (optimize (speed 3) (safety 0)))
+  (with-ioblock-lock-grabbed ((locally (declare (optimize (speed 3) (safety 0)))
+                                (ioblock-inbuf-lock ioblock)))
+    (if (ioblock-untyi-char ioblock)
+      (prog1 (ioblock-untyi-char ioblock)
+        (setf (ioblock-untyi-char ioblock) nil))
+      (let* ((buf (ioblock-inbuf ioblock))
+             (idx (io-buffer-idx buf))
+             (limit (io-buffer-count buf)))
+        (declare (fixnum idx limit))
+        (when (= idx limit)
+          (unless (%ioblock-advance ioblock t)
+            (return-from %locked-ioblock-tyi (if (ioblock-eof ioblock) :eof)))
+          (setq idx (io-buffer-idx buf)
+                limit (io-buffer-count buf)))
+        (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
+        (schar (io-buffer-buffer buf) idx)))))
 
 (declaim (inline %ioblock-tyy-no-hang))
@@ -926 +979 @@
                             element-shift
                             interactive
-                            private
+                            (sharing :private)
+                            character-p
                             &allow-other-keys)
   (declare (ignorable element-shift))
+  (when sharing
+    (unless (or (eq sharing :private)
+                (eq sharing :lock))
+      (if (eq sharing :external)
+        (setq sharing nil)
+        (report-bad-arg sharing '(member nil :private :lock :external)))))
   (let* ((ioblock (or (let* ((ioblock (stream-ioblock stream nil)))
                         (when ioblock
@@ -934 +994 @@
                           ioblock))
                       (stream-create-ioblock stream))))
-    (when private
+    (when (eq sharing :private)
       (setf (ioblock-owner ioblock) *current-process*))
     (when insize
@@ -945 +1005 @@
                                 :size in-size-in-octets
                                 :limit insize))
-          (unless private
+          (when (eq sharing :lock)
             (setf (ioblock-inbuf-lock ioblock) (make-lock)))
+          (if character-p
+            (setf (ioblock-read-char-function ioblock)
+                   (case sharing
+                     (:private '%private-ioblock-tyi)
+                     (:lock '%locked-ioblock-tyi)
+                     (t '%ioblock-tyi))))
           (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log  (/ in-size-in-octets insize) 2))))
           )))
@@ -967 +1033 @@
                                   :limit outsize
                                   :size out-size-in-octets))
-            (unless private
+            (when (eq sharing :lock)
               (setf (ioblock-outbuf-lock ioblock) (make-lock)))
             (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ out-size-in-octets outsize) 2))))
@@ -1025 +1091 @@
                           (element-type 'character)
                           (class 'fd-stream)
-                          (private t))
+                          (sharing :private))
   (let* ((in-p (member direction '(:io :input)))
          (out-p (member direction '(:io :output)))
@@ -1044 +1110 @@
                                                   (select-stream-force-output-function class))
                          :close-function 'fd-stream-close
-                         :private private)))
+                         :sharing sharing
+                         :character-p char-p)))
   
 ;;;  Fundamental streams.
@@ -1133 +1200 @@
                                            fundamental-binary-stream
                                            binary-input-stream)
+    ())
+
+(defclass binary-output-stream (output-stream binary-stream)
     ())
 
@@ -1633 +1703 @@
   (when (slot-value s 'string)
     (setf (slot-value s 'string) nil)
-    (call-next-method)
     t))
 
@@ -2543 +2612 @@
                       (class *default-file-stream-class*)
                       (elements-per-buffer *elements-per-buffer*)
-                      (private t))
+                      (sharing :private))
   "Return a stream which reads from or writes to FILENAME.
   Defined keywords:
@@ -2563 +2632 @@
                           class
                           external-format
-                          private))
+                          sharing))
       (retry-open ()
                   :report (lambda (stream) (format stream "Retry opening ~s" filename))

trunk/ccl/level-1/l1-sysio.lisp

@@ -509 +509 @@
                          class
                          external-format
-                         private)
+                         sharing)
 
   (let* ((temp-name nil)
@@ -570 +570 @@
                               :element-type element-type
                               :elements-per-buffer elements-per-buffer
-                              :private private)
+                              :sharing sharing)
               (let* ((in-p (member direction '(:io :input)))
                      (out-p (member direction '(:io :output)))
@@ -614 +614 @@
                                :device fd
                                :external-format real-external-format
-                               :private private))
+                               :sharing sharing))
                      (ioblock (stream-ioblock fstream)))
                 (setf (stream-filename fstream) (namestring pathname)