Changeset 8611


Ignore:
Timestamp:
Feb 27, 2008, 7:52:26 PM (12 years ago)
Author:
hans
Message:

Merge the recent stream timeout and deadline changes from CCL trunk to
ITA branch. There now exist STREAM-INPUT-TIMEOUT, STREAM-OUTPUT-TIMEOUT
and STREAM-DEADLINE as well as associated initargs. Deadlines and timeouts
are specified in internal-time-units.

Location:
branches/working-0711/ccl
Files:
9 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-error-system.lisp

    r8020 r8611  
    368368(define-condition end-of-file (stream-error) ()
    369369  (:report (lambda (c s)
    370              (format s "Unexpected end of file ~s" (stream-error-context c)))))
     370             (format s "Unexpected end of file ~a" (stream-error-context c)))))
     371
     372(define-condition io-timeout (stream-error)
     373  ())
     374
     375(define-condition input-timeout (io-timeout)
     376  ()
     377  (:report (lambda (c s)
     378             (format s "Input timeout on ~s" (stream-error-stream c)))))
     379(define-condition output-timeout (io-timeout)
     380  ()
     381  (:report (lambda (c s)
     382             (format s "Output timeout on ~s" (stream-error-stream c)))))
     383(define-condition communication-deadline-expired (io-timeout)
     384  ()
     385  (:report (lambda (c s)
     386             (format s "Communication deadline timeout on ~s" (stream-error-stream c)))))
     387 
     388
     389
     390
    371391(define-condition impossible-number (reader-error)
    372392  ((token :initarg :token :reader impossible-number-token)
     
    382402(define-condition simple-stream-error (stream-error simple-condition) ()
    383403  (:report (lambda (c s)
    384              (format s "Error ~s : ~&~a" (stream-error-context c)
     404             (format s "~a : ~&~a" (stream-error-context c)
    385405                     (apply #'format
    386406                            nil
  • branches/working-0711/ccl/level-1/l1-sockets.lisp

    r7732 r8611  
    219219                           ;; TODO: this is a constant arg, there is a way to put this
    220220                           ;; in the class definition, just need to remember how...
    221                            :format-control "~a (error #~d) on ~s in ~a"
     221                           :format-control "~a (error #~d) during ~a"
    222222                           :format-arguments (list
    223223                                              (if nameserver-p
    224224                                                (%hstrerror errno)
    225225                                                (%strerror errno))
    226                                               errno stream where)))
     226                                              errno where)))
    227227    (error (make-condition 'socket-creation-error
    228228                           :code errno
     
    231231                           ;; TODO: this is a constant arg, there is a way to put this
    232232                           ;; in the class definition, just need to remember how...
    233                            :format-control "~a (error #~d) on ~s in ~a"
     233                           :format-control "~a (error #~d) during socket creation in ~a"
    234234                           :format-arguments (list
    235235                                              (if nameserver-p
    236236                                                (%hstrerror errno)
    237237                                                (%strerror errno))
    238                                               errno stream where)))))
     238                                              errno where)))))
    239239   
    240240
    241241
    242 ;; If true, this will try to allow other processes to run while
    243 ;; socket io is happening.
    244 (defvar *multiprocessing-socket-io* t)
     242;; If true, this will try to allow other cooperative processes to run
     243;; while socket io is happening.  Since CCL threads are preemptively
     244;; scheduled, this isn't particularly meaningful.
     245(defvar *multiprocessing-socket-io* nil)
    245246
    246247(defclass socket ()
     
    577578               local-filename)
    578579      (bind-unix-socket fd local-filename))   
    579     (when *multiprocessing-socket-io*
     580    (when (and nil *multiprocessing-socket-io*)
    580581      (socket-call socket "fcntl" (fd-set-flag fd #$O_NONBLOCK)))))
    581582
     
    603604                    local-port local-host backlog class out-of-band-inline
    604605                    local-filename remote-filename sharing basic
    605                     external-format (auto-close t))
     606                    external-format (auto-close t)
     607                    connect-timeout input-timeout output-timeout deadline)
    606608  "Create and return a new socket."
    607609  (declare (dynamic-extent keys))
     
    610612                   local-port local-host backlog class out-of-band-inline
    611613                   local-filename remote-filename sharing basic external-format
    612                    auto-close))
     614                   auto-close connect-timeout input-timeout output-timeout deadline))
    613615  (ecase address-family
    614616    ((:file) (apply #'make-file-socket keys))
     
    660662      (fd-close fd))))
    661663
    662 (defun %socket-connect (fd addr addrlen)
    663   (let* ((err (c_connect fd addr addrlen)))
     664(defun %socket-connect (fd addr addrlen &optional timeout)
     665  (let* ((err (c_connect fd addr addrlen timeout)))
    664666    (declare (fixnum err))
    665     (when (eql err (- #$EINPROGRESS))
    666       (process-output-wait fd)
    667       (setq err (- (int-getsockopt fd #$SOL_SOCKET #$SO_ERROR))))
    668667    (unless (eql err 0) (socket-error nil "connect" err))))
    669668   
    670 (defun inet-connect (fd host-n port-n)
     669(defun inet-connect (fd host-n port-n &optional connect-timeout)
    671670  (rlet ((sockaddr :sockaddr_in))
    672671    (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET
    673672          (pref sockaddr :sockaddr_in.sin_port) port-n
    674673          (pref sockaddr :sockaddr_in.sin_addr.s_addr) host-n)
    675     (%socket-connect fd sockaddr (record-length :sockaddr_in))))
     674    (%socket-connect fd sockaddr (record-length :sockaddr_in) connect-timeout)))
    676675               
    677676(defun file-socket-connect (fd remote-filename)
     
    683682(defun make-tcp-stream-socket (fd &rest keys
    684683                                  &key remote-host
    685                                   remote-port                             
     684                                  remote-port
     685                                  connect-timeout
    686686                                  &allow-other-keys)
    687687  (inet-connect fd
    688688                (host-as-inet-host remote-host)
    689                 (port-as-inet-port remote-port "tcp"))
     689                (port-as-inet-port remote-port "tcp")
     690                connect-timeout)
    690691  (apply #'make-tcp-stream fd keys))
    691692
     
    697698
    698699
    699 (defun make-tcp-stream (fd &key (format :bivalent) external-format (class 'tcp-stream) sharing (basic t) (auto-close t) &allow-other-keys)
     700(defun make-tcp-stream (fd
     701                        &key (format :bivalent)
     702                             external-format
     703                             (class 'tcp-stream)
     704                             sharing
     705                             (basic t)
     706                             (auto-close t)
     707                             input-timeout
     708                             output-timeout
     709                             deadline
     710                        &allow-other-keys)
    700711  (let* ((external-format (normalize-external-format :socket external-format)))
    701712    (let ((element-type (ecase format
     
    713724                      :line-termination (external-format-line-termination external-format)
    714725                      :basic basic
    715                       :auto-close auto-close))))
    716 
    717 (defun make-file-socket-stream (fd &key (format :bivalent) external-format (class 'file-socket-stream)  sharing basic (auto-close t) &allow-other-keys)
     726                      :auto-close auto-close
     727                      :input-timeout input-timeout
     728                      :output-timeout output-timeout
     729                      :deadline deadline))))
     730
     731(defun make-file-socket-stream (fd
     732                                &key (format :bivalent)
     733                                external-format
     734                                (class 'file-socket-stream)
     735                                sharing
     736                                basic
     737                                (auto-close t)
     738                                input-timeout
     739                                output-timeout
     740                                deadline
     741                                &allow-other-keys)
    718742  (let* ((external-format (normalize-external-format :socket external-format)))
    719743 
     
    732756                      :character-p (not (eq format :binary))
    733757                      :basic basic
    734                       :auto-close auto-close))))
     758                      :auto-close auto-close
     759                      :input-timeout input-timeout
     760                      :output-timeout output-timeout
     761                      :deadline deadline))))
    735762
    736763(defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys)
     
    9761003        (socket-error socket "getsockopt" err)))))
    9771004
     1005(defun timeval-setsockopt (socket level optname timeout)
     1006    (multiple-value-bind (seconds micros)
     1007        (microseconds timeout)
     1008      (rlet ((valptr :timeval :tv_sec seconds :tv_usec micros))
     1009        (socket-call socket "setsockopt"
     1010          (c_setsockopt socket level optname valptr (record-length :timeval))))))
     1011                   
    9781012(defun int-setsockopt (socket level optname optval)
    9791013  (rlet ((valptr :signed))
     
    10551089    (rlet ((hostent :hostent)
    10561090           (hp (* (struct :hostent)))
    1057            (herr :signed))
     1091           (herr :signed 0))
    10581092       (do* ((buflen 1024 (+ buflen buflen))) ()
    10591093         (declare (fixnum buflen))
     
    10631097             (unless (eql res #$ERANGE)
    10641098               (return
    1065                  (if (eql res 0)
     1099                 (let* ((err (pref herr :signed)))
     1100                 (if (and (eql res 0) (eql err 0))
    10661101                   (%get-unsigned-long
    10671102                    (%get-ptr (pref (%get-ptr hp) :hostent.h_addr_list)))
    1068                    (values nil (- (pref herr :signed))))))))))))
     1103                   (values nil (- err))))))))))))
    10691104
    10701105(defun _getservbyname (name proto)
     
    11811216      (syscall syscalls::socketcall 2 params))))
    11821217
    1183 (defun c_connect (sockfd addr len)
    1184   #+(or darwin-target linuxx8664-target freebsd-target)
    1185   (syscall syscalls::connect sockfd addr len)
    1186   #+linuxppc-target
    1187   (progn
    1188     #+ppc32-target
    1189     (%stack-block ((params 12))
    1190       (setf (%get-long params 0) sockfd
    1191             (%get-ptr params 4) addr
    1192             (%get-long params 8) len)
    1193       (syscall syscalls::socketcall 3 params))
    1194     #+ppc64-target
    1195     (%stack-block ((params 24))
    1196       (setf (%%get-unsigned-longlong params 0) sockfd
    1197             (%get-ptr params 8) addr
    1198             (%%get-unsigned-longlong params 16) len)
    1199       (syscall syscalls::socketcall 3 params))))
     1218
     1219;;; If attempts to connnect are interrupted, we basically have to
     1220;;; wait in #_select (or the equivalent).  There's a good rant
     1221;;; about these issues in:
     1222;;; <http://www.madore.org/~david/computers/connect-intr.html>
     1223(defun c_connect (sockfd addr len &optional timeout)
     1224  (let* ((flags (fd-get-flags sockfd)))
     1225    (unwind-protect
     1226         (progn
     1227           (fd-set-flags sockfd (logior flags #$O_NONBLOCK))
     1228           (let* ((err
     1229                   #+(or darwin-target linuxx8664-target freebsd-target)
     1230                   (syscall syscalls::connect sockfd addr len)
     1231                   #+linuxppc-target
     1232                   (progn
     1233                     #+ppc32-target
     1234                     (%stack-block ((params 12))
     1235                       (setf (%get-long params 0) sockfd
     1236                             (%get-ptr params 4) addr
     1237                             (%get-long params 8) len)
     1238                       (syscall syscalls::socketcall 3 params))
     1239                     #+ppc64-target
     1240                     (%stack-block ((params 24))
     1241                       (setf (%%get-unsigned-longlong params 0) sockfd
     1242                             (%get-ptr params 8) addr
     1243                             (%%get-unsigned-longlong params 16) len)
     1244                       (syscall syscalls::socketcall 3 params)))))
     1245             (cond ((or (eql err (- #$EINPROGRESS)) (eql err (- #$EINTR)))
     1246                    (if (process-output-wait sockfd timeout)
     1247                      (- (int-getsockopt sockfd #$SOL_SOCKET #$SO_ERROR))
     1248                      (- #$ETIMEDOUT)))
     1249                   (t err))))
     1250      (fd-set-flags sockfd flags))))
    12001251
    12011252(defun c_listen (sockfd backlog)
     
    12161267
    12171268(defun c_accept (sockfd addrp addrlenp)
    1218   #+(or darwin-target linuxx8664-target freebsd-target)
    1219   (syscall syscalls::accept sockfd addrp addrlenp)
    1220   #+linuxppc-target
    1221   (progn
    1222     #+ppc32-target
    1223     (%stack-block ((params 12))
    1224       (setf (%get-long params 0) sockfd
    1225             (%get-ptr params 4) addrp
    1226             (%get-ptr params 8) addrlenp)
    1227       (syscall syscalls::socketcall 5 params))
    1228     #+ppc64-target
    1229     (%stack-block ((params 24))
    1230       (setf (%%get-unsigned-longlong params 0) sockfd
    1231             (%get-ptr params 8) addrp
    1232             (%get-ptr params 16) addrlenp)
    1233       (syscall syscalls::socketcall 5 params))))
     1269  (ignoring-eintr
     1270   #+(or darwin-target linuxx8664-target freebsd-target)
     1271   (syscall syscalls::accept sockfd addrp addrlenp)
     1272   #+linuxppc-target
     1273   (progn
     1274     #+ppc32-target
     1275     (%stack-block ((params 12))
     1276       (setf (%get-long params 0) sockfd
     1277             (%get-ptr params 4) addrp
     1278             (%get-ptr params 8) addrlenp)
     1279       (syscall syscalls::socketcall 5 params))
     1280     #+ppc64-target
     1281     (%stack-block ((params 24))
     1282       (setf (%%get-unsigned-longlong params 0) sockfd
     1283             (%get-ptr params 8) addrp
     1284             (%get-ptr params 16) addrlenp)
     1285       (syscall syscalls::socketcall 5 params)))))
    12341286
    12351287(defun c_getsockname (sockfd addrp addrlenp)
     
    14891541    (or (find-if #'(lambda (i)
    14901542                     (and (eq #$AF_INET (ip-interface-address-family i))
     1543                          (ip-interface-addr i)
    14911544                          (let* ((flags (ip-interface-flags i)))
    14921545                            (and (not (logtest #$IFF_LOOPBACK flags))
  • branches/working-0711/ccl/level-1/l1-streams.lisp

    r8564 r8611  
    5858    :io
    5959    :output))
     60
     61(defun check-io-timeout (timeout)
     62  (when timeout
     63    (require-type timeout '(real 0 1000000))))
     64
     65(defmethod stream-input-timeout ((s input-stream))
     66  nil)
     67
     68(defmethod (setf input-stream-timeout) (new (s input-stream))
     69  (check-io-timeout new))
     70
     71(defmethod stream-output-timeout ((s output-stream))
     72  nil)
     73
     74(defmethod (setf stream-output-timeout) (new (s output-stream))
     75  (check-io-timeout new))
    6076
    6177;;; Try to return a string containing characters that're near the
     
    30493065                            encoding
    30503066                            line-termination
     3067                            input-timeout
     3068                            output-timeout
     3069                            deadline
    30513070                            &allow-other-keys)
    30523071  (declare (ignorable element-shift))
     
    31413160      (when bom-info
    31423161        (ioblock-check-input-bom ioblock bom-info sharing)))
     3162    (setf (ioblock-input-timeout ioblock) input-timeout)
     3163    (setf (ioblock-output-timeout ioblock) output-timeout)
     3164    (setf (ioblock-deadline ioblock) deadline)
    31433165    ioblock))
    31443166
     
    32603282
    32613283
    3262 (defun optimal-buffer-size (fd)
    3263   (or (nth-value 6 (%fstat fd)) *elements-per-buffer*))
     3284(defun optimal-buffer-size (fd element-type)
     3285  (let* ((octets (case (%unix-fd-kind fd)
     3286                   (:pipe (#_fpathconf fd #$_PC_PIPE_BUF))
     3287                   (:socket (int-getsockopt fd #$SOL_SOCKET #$SO_SNDLOWAT))
     3288                   ((:character-special :tty) (#_fpathconf fd #$_PC_MAX_INPUT))
     3289                   (t (or (nth-value 6 (%fstat fd)) *elements-per-buffer*)))))
     3290    (case (subtag-bytes (element-type-subtype element-type) 1)
     3291      (1 octets)
     3292      (2 (ash octets -1))
     3293      (4 (ash octets -2))
     3294      (8 (ash octets -3)))))
     3295
     3296
     3297(defun milliseconds-until-deadline (deadline ioblock)
     3298  (let* ((now (get-internal-real-time)))
     3299    (if (> now deadline)
     3300      (error 'communication-deadline-expired :stream (ioblock-stream ioblock))
     3301      (values (round (- deadline now) (/ internal-time-units-per-second 1000))))))
    32643302
    32653303
     
    32693307                          (direction :input)
    32703308                          (interactive t)
    3271                           (elements-per-buffer (optimal-buffer-size fd))
    32723309                          (element-type 'character)
    32733310                          (class 'fd-stream)
     
    32783315                          encoding
    32793316                          line-termination
    3280                           auto-close)
    3281   (when line-termination
    3282     (setq line-termination
    3283           (cdr (assoc line-termination *canonical-line-termination-conventions*))))
    3284   (when basic
    3285     (setq class (map-to-basic-stream-class-name class))
    3286     (setq basic (subtypep (find-class class) 'basic-stream)))
    3287   (let* ((in-p (member direction '(:io :input)))
    3288          (out-p (member direction '(:io :output)))
    3289          (class-name (select-stream-class class in-p out-p character-p))
    3290          (class (find-class class-name))
    3291          (stream
    3292           (make-ioblock-stream class
    3293                                :insize (if in-p elements-per-buffer)
    3294                                :outsize (if out-p elements-per-buffer)
    3295                                :device fd
    3296                                :interactive interactive
    3297                                :element-type element-type
    3298                                :advance-function (if in-p
    3299                                                     (select-stream-advance-function class direction))
    3300                                :listen-function (if in-p 'fd-stream-listen)
    3301                                :eofp-function (if in-p 'fd-stream-eofp)
    3302                                :force-output-function (if out-p
    3303                                                          (select-stream-force-output-function class direction))
    3304                                :close-function 'fd-stream-close
    3305                                :sharing sharing
    3306                                :character-p character-p
    3307                                :encoding encoding
    3308                                :line-termination line-termination)))
    3309     (if auto-close
    3310        (terminate-when-unreachable stream
    3311                                    (lambda (stream)
    3312                                      (close stream :abort t))))
    3313     stream))
     3317                          auto-close
     3318                          input-timeout
     3319                          output-timeout
     3320                          deadline)
     3321  (let* ((elements-per-buffer (optimal-buffer-size fd element-type)))
     3322    (when line-termination
     3323      (setq line-termination
     3324            (cdr (assoc line-termination *canonical-line-termination-conventions*))))
     3325    (when basic
     3326      (setq class (map-to-basic-stream-class-name class))
     3327      (setq basic (subtypep (find-class class) 'basic-stream)))
     3328    (let* ((in-p (member direction '(:io :input)))
     3329           (out-p (member direction '(:io :output)))
     3330           (class-name (select-stream-class class in-p out-p character-p))
     3331           (class (find-class class-name))
     3332           (stream
     3333            (make-ioblock-stream class
     3334                                 :insize (if in-p elements-per-buffer)
     3335                                 :outsize (if out-p elements-per-buffer)
     3336                                 :device fd
     3337                                 :interactive interactive
     3338                                 :element-type element-type
     3339                                 :advance-function (if in-p
     3340                                                     (select-stream-advance-function class direction))
     3341                                 :listen-function (if in-p 'fd-stream-listen)
     3342                                 :eofp-function (if in-p 'fd-stream-eofp)
     3343                                 :force-output-function (if out-p
     3344                                                          (select-stream-force-output-function class direction))
     3345                                 :close-function 'fd-stream-close
     3346                                 :sharing sharing
     3347                                 :character-p character-p
     3348                                 :encoding encoding
     3349                                 :line-termination line-termination
     3350                                 :input-timeout input-timeout
     3351                                 :output-timeout output-timeout
     3352                                 :deadline deadline)))
     3353      (if auto-close
     3354        (terminate-when-unreachable stream
     3355                                    (lambda (stream)
     3356                                      (close stream :abort t))))
     3357      stream)))
    33143358
    33153359 
     
    37783822           (synonym-method stream-direction)
    37793823           (synonym-method stream-device direction)
    3780            (synonym-method stream-surrounding-characters))
     3824           (synonym-method stream-surrounding-characters)
     3825           (synonym-method stream-input-timeout)
     3826           (synonym-method stream-output-timeout)
     3827           (synonym-method stream-deadline))
     3828
     3829(defmethod (setf input-stream-timeout) (new (s synonym-stream))
     3830  (setf (input-stream-timeout (symbol-value (synonym-stream-symbol s))) new))
     3831
     3832(defmethod (setf output-stream-timeout) (new (s synonym-stream))
     3833  (setf (output-stream-timeout (symbol-value (synonym-stream-symbol s))) new))
    37813834
    37823835
     
    38383891  (two-way-input-method stream-read-vector v start end)
    38393892  (two-way-input-method stream-surrounding-characters)
     3893  (two-way-input-method stream-input-timeout)
    38403894  (two-way-output-method stream-write-char c)
    38413895  (two-way-output-method stream-write-byte b)
     
    38503904  (two-way-output-method stream-finish-output)
    38513905  (two-way-output-method stream-write-list l c)
    3852   (two-way-output-method stream-write-vector v start end))
     3906  (two-way-output-method stream-write-vector v start end)
     3907  (two-way-output-method stream-output-timeout)
     3908  (two-way-output-method stream-deadline))
     3909
     3910(defmethod (setf stream-input-timeout) (new (s two-way-stream))
     3911  (setf (stream-input-timeout (two-way-stream-input-stream s)) new))
     3912
     3913(defmethod (setf stream-output-timeout) (new (s two-way-stream))
     3914  (setf (stream-output-timeout (two-way-stream-output-stream s)) new))
     3915
     3916(defmethod (setf stream-deadline) (new (s two-way-stream))
     3917  (setf (stream-deadline (two-way-stream-output-stream s)) new))
    38533918
    38543919(defmethod stream-device ((s two-way-stream) direction)
     
    40914156             (broadcast-method stream-force-output (s))
    40924157             (broadcast-method stream-finish-output (s))
    4093              (broadcast-method stream-stream-write-list (s l c))
     4158             (broadcast-method stream-write-list (s l c))
    40944159             (broadcast-method stream-write-vector (s v start end)))
    40954160
     
    44644529
    44654530(defmethod stream-surrounding-characters ((s string-input-stream))
    4466   (let* ((ioblock (basic-stream-ioblock s))
    4467          (start (string-input-stream-ioblock-start ioblock))
    4468          (idx (string-input-stream-ioblock-index ioblock))
    4469          (end (string-input-stream-ioblock-end ioblock))
    4470          (string (string-stream-ioblock-string ioblock)))
    4471     (subseq string (max (- idx 5) start) (min (+ idx 5) end))))
     4531  (let* ((ioblock (basic-stream.state s)))
     4532    (when ioblock
     4533      (let* ((start (string-input-stream-ioblock-start ioblock))
     4534             (idx (string-input-stream-ioblock-index ioblock))
     4535             (end (string-input-stream-ioblock-end ioblock))
     4536             (string (string-stream-ioblock-string ioblock)))
     4537        (subseq string (max (- idx 5) start) (min (+ idx 5) end))))))
    44724538   
    44734539
     
    52035269                                 :unsigned-fullword)))))
    52045270
    5205 (defun process-input-wait (fd &optional ticks)
     5271(defun process-input-would-block (fd)
     5272  (if (logtest #$O_NONBLOCK (the fixnum (fd-get-flags fd)))
     5273    (process-input-wait fd)
     5274    (- #$ETIMEDOUT)))
     5275   
     5276(defun process-input-wait (fd &optional timeout)
    52065277  "Wait until input is available on a given file-descriptor."
    5207   (let* ((wait-end (if ticks (+ (get-tick-count) ticks))))
    5208     (loop
    5209       ;; FD-INPUT-AVAILABLE-P can return NIL (e.g., if the
    5210       ;; thread receives an interrupt) before a timeout is
    5211       ;; reached.
    5212       (when (fd-input-available-p fd ticks)
    5213         (return t))
    5214       ;; If it returned and a timeout was specified, check
    5215       ;; to see if it's been exceeded.  If so, return NIL;
    5216       ;; otherwise, adjust the remaining timeout.
    5217       ;; If there was no timeout, continue to wait forever.
    5218       (when ticks
    5219         (let* ((now (get-tick-count)))
    5220           (if (and wait-end (>= now wait-end))
    5221             (return)
    5222             (setq ticks (- wait-end now))))))))
    5223 
    5224 
    5225 
    5226 (defun process-output-wait (fd)
     5278  (rlet ((now :timeval))
     5279    (let* ((wait-end
     5280            (when timeout
     5281              (#_gettimeofday now (%null-ptr))
     5282              (+ (timeval->milliseconds now) timeout))))
     5283      (loop
     5284        (multiple-value-bind (win error)
     5285            (fd-input-available-p fd (or timeout -1))
     5286          (when win
     5287            (return (values t nil nil)))
     5288          (when (eql error 0)         ;timed out
     5289            (return (values nil t nil)))
     5290          ;; If it returned and a timeout was specified, check
     5291          ;; to see if it's been exceeded.  If so, return NIL;
     5292          ;; otherwise, adjust the remaining timeout.
     5293          ;; If there was no timeout, continue to wait forever.
     5294          (unless (eql error (- #$EINTR))
     5295            (return (values nil nil error)))
     5296          (when timeout
     5297            (#_gettimeofday now (%null-ptr))
     5298            (setq timeout (- wait-end (timeval->milliseconds now)))
     5299            (if (<= timeout 0)
     5300              (return (values nil t nil)))))))))
     5301
     5302
     5303(defun process-output-would-block (fd)
     5304  (if (logtest #$O_NONBLOCK (the fixnum (fd-get-flags fd)))
     5305    (process-output-wait fd)
     5306    (- #$ETIMEDOUT)))
     5307
     5308(defun process-output-wait (fd &optional timeout)
    52275309  "Wait until output is possible on a given file descriptor."
    5228   (loop
    5229     (when (fd-ready-for-output-p fd nil)
    5230       (return t))))
    5231 
    5232 
    5233  
     5310  (rlet ((now :timeval))
     5311    (let* ((wait-end
     5312            (when timeout
     5313              (#_gettimeofday now (%null-ptr))
     5314              (+ (timeval->milliseconds now) timeout))))
     5315      (loop
     5316        (multiple-value-bind (win error)
     5317            (fd-ready-for-output-p fd (or timeout -1))
     5318          (when win
     5319            (return (values t nil nil)))
     5320          (when (eql error 0)
     5321            (return (values nil t nil)))
     5322          (unless (eql error (- #$EINTR))
     5323            (return (values nil nil error)))
     5324          ;; If it returned and a timeout was specified, check
     5325          ;; to see if it's been exceeded.  If so, return NIL;
     5326          ;; otherwise, adjust the remaining timeout.
     5327          ;; If there was no timeout, continue to wait forever.
     5328          (when timeout
     5329            (#_gettimeofday now (%null-ptr))
     5330            (setq timeout (- wait-end (timeval->milliseconds now)))
     5331            (if (<= timeout 0)
     5332              (return (values nil t nil)))))))))
    52345333
    52355334
     
    52425341              (pref tv :timeval.tv_usec) us)))))
    52435342
    5244 (defun fd-input-available-p (fd &optional ticks)
    5245   (rletZ ((tv :timeval))
    5246     (ticks-to-timeval ticks tv)
    5247     (%stack-block ((infds *fd-set-size*))
    5248       (fd-zero infds)
    5249       (fd-set fd infds)
    5250       (let* ((res (syscall syscalls::select (1+ fd) infds (%null-ptr) (%null-ptr)
    5251                            (if ticks tv (%null-ptr)))))
    5252         (> res 0)))))
    5253 
    5254 (defun fd-ready-for-output-p (fd &optional ticks)
    5255   (rletZ ((tv :timeval))
    5256     (ticks-to-timeval ticks tv)
    5257     (%stack-block ((outfds *fd-set-size*))
    5258       (fd-zero outfds)
    5259       (fd-set fd outfds)
    5260       (let* ((res (#_select (1+ fd) (%null-ptr) outfds (%null-ptr)
    5261                             (if ticks tv (%null-ptr)))))
    5262         (> res 0)))))
    5263 
    5264 (defun fd-urgent-data-available-p (fd &optional ticks)
    5265   (rletZ ((tv :timeval))
    5266     (ticks-to-timeval ticks tv)
    5267     (%stack-block ((errfds *fd-set-size*))
    5268       (fd-zero errfds)
    5269       (fd-set fd errfds)
    5270       (let* ((res (#_select (1+ fd) (%null-ptr) (%null-ptr)  errfds
    5271                             (if ticks tv (%null-ptr)))))
    5272         (> res 0)))))
     5343(defun fd-input-available-p (fd &optional milliseconds)
     5344  (rlet ((pollfds (:array (:struct :pollfd) 1)))
     5345    (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd
     5346          (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLIN)
     5347    (let* ((res (syscall syscalls::poll pollfds 1 (or milliseconds -1))))
     5348      (declare (fixnum res))
     5349      (values (> res 0) res))))
     5350
     5351
     5352(defun fd-ready-for-output-p (fd &optional milliseconds)
     5353  (rlet ((pollfds (:array (:struct :pollfd) 1)))
     5354    (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd
     5355          (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLOUT)
     5356    (let* ((res (syscall syscalls::poll pollfds 1 (or milliseconds -1))))
     5357      (declare (fixnum res))
     5358      (values (> res 0)  res))))
     5359
     5360
    52735361
    52745362;;; FD-streams, built on top of the ioblock mechanism.
     
    53465434         (buf (ioblock-inbuf ioblock))
    53475435         (bufptr (io-buffer-bufptr buf))
    5348          (size (io-buffer-size buf)))
     5436         (size (io-buffer-size buf))
     5437         (avail nil))
    53495438    (setf (io-buffer-idx buf) 0
    53505439          (io-buffer-count buf) 0
    53515440          (ioblock-eof ioblock) nil)
    5352     (let* ((avail nil))
    53535441      (when (or read-p (setq avail (stream-listen s)))
    5354         (if (and (ioblock-interactive ioblock)
    5355                  (not avail))
    5356           (process-input-wait fd))
     5442        (unless avail
     5443          (let* ((deadline (ioblock-deadline ioblock))
     5444                 (timeout
     5445                  (if deadline
     5446                    (milliseconds-until-deadline deadline ioblock)
     5447                    (ioblock-input-timeout ioblock))))
     5448            (when timeout
     5449              (multiple-value-bind (win timedout error)
     5450                  (process-input-wait fd timeout)
     5451                (unless win
     5452                  (if timedout
     5453                    (error (if deadline
     5454                             'communication-deadline-expired
     5455                             'input-timeout)
     5456                           :stream s)
     5457                    (stream-io-error s (- error) "read")))))))
    53575458        (let* ((n (with-eagain fd :input
    53585459                    (fd-read fd bufptr size))))
     
    53645465                    (ioblock-octets-to-elements ioblock n))
    53655466              (progn (setf (ioblock-eof ioblock) t)
    5366                      nil))))))))
     5467                     nil)))))))
    53675468
    53685469(defun fd-stream-eofp (s ioblock)
     
    54025503                (:file (fd-fsync fd))))
    54035504            octets-to-write)
     5505        (let* ((deadline (ioblock-deadline ioblock))
     5506               (timeout
     5507                (if deadline
     5508                  (milliseconds-until-deadline deadline ioblock)
     5509                  (ioblock-output-timeout ioblock))))
     5510          (when timeout
     5511            (multiple-value-bind (win timedout error)
     5512                (process-output-wait fd timeout)
     5513              (unless win
     5514                (if timedout
     5515                  (error (if deadline
     5516                           'communication-deadline-expired
     5517                           'output-timeout)
     5518                         :stream s)
     5519                  (stream-io-error s (- error) "write"))))))
    54045520        (let* ((written (with-eagain fd :output
    54055521                          (fd-write fd buf octets))))
     
    55385654                      (external-format :default)
    55395655                      (class 'file-stream)
    5540                       (elements-per-buffer *elements-per-buffer*)
    55415656                      (sharing :private)
    55425657                      (basic t))
     
    55575672                          if-exists
    55585673                          if-does-not-exist
    5559                           elements-per-buffer
    55605674                          class
    55615675                          external-format
     
    57465860        (normalize-external-format (stream-domain s) new)))
    57475861
     5862(defmethod stream-input-timeout ((s basic-input-stream))
     5863  (let* ((ioblock (basic-stream-ioblock s)))
     5864    (with-ioblock-input-locked (ioblock)
     5865      (let* ((timeout (ioblock-input-timeout ioblock)))
     5866        (when timeout
     5867          (values (floor timeout 1000.0)))))))
     5868
     5869(defmethod (setf stream-input-timeout) (new (s basic-input-stream))
     5870  (setq new (check-io-timeout new))
     5871  (let* ((ioblock (basic-stream-ioblock s)))
     5872    (with-ioblock-input-locked (ioblock)
     5873      (setf (ioblock-input-timeout ioblock)
     5874            (if new (round (* new 1000))))
     5875      new)))
     5876
     5877(defmethod stream-output-timeout ((s basic-output-stream))
     5878  (let* ((ioblock (basic-stream-ioblock s)))
     5879    (with-ioblock-output-locked (ioblock)
     5880      (let* ((timeout (ioblock-output-timeout ioblock)))
     5881        (when timeout
     5882          (values (floor timeout 1000.0)))))))
     5883
     5884(defmethod (setf stream-output-timeout) (new (s basic-output-stream))
     5885  (setq new (check-io-timeout new))
     5886  (let* ((ioblock (basic-stream-ioblock s)))
     5887    (with-ioblock-output-locked (ioblock)
     5888      (setf (ioblock-output-timeout ioblock)
     5889            (if new (round (* new 1000))))
     5890      new)))
     5891
     5892(defmethod stream-deadline ((s basic-output-stream))
     5893  (let* ((ioblock (basic-stream-ioblock s)))
     5894    (with-ioblock-output-locked (ioblock)
     5895      (ioblock-deadline ioblock))))
     5896 
     5897(defmethod (setf stream-deadline) (new (s basic-output-stream))
     5898  (let* ((ioblock (basic-stream-ioblock s)))
     5899    (with-ioblock-output-locked (ioblock)
     5900      (setf (ioblock-deadline ioblock) new)
     5901      new)))
     5902
     5903
     5904
     5905(defmethod stream-input-timeout ((s buffered-input-stream-mixin))
     5906  (let* ((ioblock (stream-ioblock s t)))
     5907    (with-ioblock-input-locked (ioblock)
     5908      (let* ((timeout (ioblock-input-timeout ioblock)))
     5909        (when timeout
     5910          (values (floor timeout 1000.0)))))))
     5911
     5912(defmethod (setf stream-input-timeout) (new (s buffered-input-stream-mixin))
     5913  (setq new (check-io-timeout new))
     5914  (let* ((ioblock (stream-ioblock s t)))
     5915    (with-ioblock-input-locked (ioblock)
     5916      (setf (ioblock-input-timeout ioblock)
     5917            (if new (round (* new 1000))))
     5918      new)))
     5919
     5920(defmethod stream-output-timeout ((s buffered-output-stream-mixin))
     5921  (let* ((ioblock (stream-ioblock s t)))
     5922    (with-ioblock-output-locked (ioblock)
     5923      (let* ((timeout (ioblock-output-timeout ioblock)))
     5924        (when timeout
     5925          (values (floor timeout 1000.0)))))))
     5926
     5927(defmethod (setf stream-output-timeout) (new (s buffered-output-stream-mixin))
     5928  (setq new (check-io-timeout new))
     5929  (let* ((ioblock (stream-ioblock s t)))
     5930    (with-ioblock-output-locked (ioblock)
     5931      (setf (ioblock-output-timeout ioblock)
     5932            (if new (round (* new 1000))))
     5933      new)))
     5934
     5935(defmethod stream-deadline ((s buffered-output-stream-mixin))
     5936  (let* ((ioblock (stream-ioblock s t)))
     5937    (with-ioblock-output-locked (ioblock)
     5938      (ioblock-deadline ioblock))))
     5939 
     5940(defmethod (setf stream-deadline) (new (s buffered-output-stream-mixin))
     5941  (let* ((ioblock (stream-ioblock s t)))
     5942    (with-ioblock-output-locked (ioblock)
     5943      (setf (ioblock-deadline ioblock) new)
     5944      new)))
     5945
     5946
    57485947
    57495948; end of L1-streams.lisp
  • branches/working-0711/ccl/level-1/l1-sysio.lisp

    r8217 r8611  
    6262                (do* ((i 0 (1+ i))
    6363                      (last-was-cr nil))
    64                      ((= nchars) (if last-was-cr :cr))
     64                     ((= i nchars) (if last-was-cr :cr))
    6565                  (declare (fixnum i))
    6666                  (let* ((char (schar string i)))
     
    726726                         if-exists
    727727                         if-does-not-exist
    728                          elements-per-buffer
    729728                         class
    730729                         external-format
    731730                         sharing
    732731                         basic)
    733 
    734732  (let* ((temp-name nil)
    735733         (dir (pathname-directory filename))
     
    785783              (make-fd-stream fd :direction direction
    786784                              :element-type element-type
    787                               :elements-per-buffer elements-per-buffer
    788785                              :sharing sharing
    789786                              :basic basic)
     
    797794                       (char-p (or (eq element-type 'character)
    798795                                   (subtypep element-type 'character)))
     796                       (elements-per-buffer (optimal-buffer-size fd element-type))
    799797                       (real-external-format
    800798                        (if char-p
  • branches/working-0711/ccl/level-1/linux-files.lisp

    r7951 r8611  
    6666      (setq r 0)
    6767      (setq r (floor (* r 1000))))
     68    (values q r)))
     69
     70(defun microseconds (n)
     71  (unless (and (typep n 'fixnum)
     72               (>= (the fixnum n) 0))
     73    (check-type n (real 0 #xffffffff)))
     74  (multiple-value-bind (q r)
     75      (floor n)
     76    (if (zerop r)
     77      (setq r 0)
     78      (setq r (floor (* r 1000000))))
    6879    (values q r)))
    6980
  • branches/working-0711/ccl/lib/ccl-export-syms.lisp

    r7624 r8611  
    556556     stream-read-vector
    557557     stream-write-vector
     558
     559     stream-input-timeout
     560     stream-output-timeout
     561     with-input-timeout
     562     with-output-timeout
     563     stream-deadline
     564
     565     input-timeout
     566     output-timeout
     567     communication-deadline-expired
    558568
    559569     make-heap-ivector
  • branches/working-0711/ccl/lib/foreign-types.lisp

    r7624 r8611  
    17011701      (canonicalize-foreign-type-ordinal '(:* (:struct :hostent)))
    17021702      (canonicalize-foreign-type-ordinal '(:array :int 2))
    1703       )))
     1703      (canonicalize-foreign-type-ordinal '(:array (:struct :pollfd) 1)))))
    17041704
    17051705(defun install-standard-foreign-types (ftd)
  • branches/working-0711/ccl/lib/macros.lisp

    r7956 r8611  
    35103510          (return ,res))))))
    35113511
     3512(defmacro ignoring-eintr (&body body)
     3513  (let* ((res (gensym))
     3514         (eintr (symbol-value (read-from-string "#$EINTR"))))
     3515    `(loop
     3516       (let* ((,res ,@body))
     3517         (unless (eql ,res (- ,eintr))
     3518           (return ,res))))))
     3519
    35123520(defmacro basic-stream-ioblock (s)
    35133521  `(or (basic-stream.state ,s)
     
    35573565  consing when N is a trivial constant integer."
    35583566  `(car (nthcdr ,n (multiple-value-list ,form))))
     3567
     3568
     3569
     3570(defmacro with-input-timeout (((stream-var &optional (stream-form stream-var)) timeout) &body body)
     3571  "Execute body with STREAM-VAR bound to STREAM-FORM and with that stream's
     3572stream-input-timeout set to TIMEOUT."
     3573  (let* ((old-input-timeout (gensym))
     3574         (stream (gensym)))
     3575    `(let* ((,stream ,stream-form)
     3576            (,stream-var ,stream)
     3577            (,old-input-timeout (stream-input-timeout ,stream)))
     3578      (unwind-protect
     3579           (progn
     3580             (setf (stream-input-timeout ,stream) ,timeout)
     3581             ,@body)
     3582        (setf (stream-input-timeout ,stream) ,old-input-timeout)))))
     3583
     3584(defmacro with-output-timeout (((stream-var &optional (stream-form stream-var)) timeout) &body body)
     3585  "Execute body with STREAM-VAR bound to STREAM-FORM and with that stream's
     3586stream-output-timeout set to TIMEOUT."
     3587  (let* ((old-output-timeout (gensym))
     3588         (stream (gensym)))
     3589    `(let* ((,stream ,stream-form)
     3590            (,stream-var ,stream)
     3591            (,old-output-timeout (stream-output-timeout ,stream)))
     3592      (unwind-protect
     3593           (progn
     3594             (setf (stream-output-timeout ,stream) ,timeout)
     3595             ,@body)
     3596        (setf (stream-output-timeout ,stream) ,old-output-timeout)))))
  • branches/working-0711/ccl/library/x8664-linux-syscalls.lisp

    r7720 r8611  
    3434(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64)  syscalls::fstat 5 (:unsigned-fullword :address) :signed-fullword )
    3535(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64)  syscalls::lstat 6 (:address :address) :signed-fullword)
    36 
     36(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::poll 7 ((:* (:struct :pollfd)) :int :int) :int)
    3737(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64)  syscalls::lseek 8 (:int :off_t :int) :off_t )
    3838
Note: See TracChangeset for help on using the changeset viewer.