Changeset 7611 for branches/working-0710


Ignore:
Timestamp:
Nov 8, 2007, 9:30:14 AM (13 years ago)
Author:
gb
Message:

Make sure that CCL::PIPE and CCL::FD-OPEN try to force finalization if
they run out of FDs.

Push new entries on the finalization queue via CCL::ATOMIC-PUSH-UVECTOR-CELL.
Defer GC when deleting entries from the finalization queue in
CANCEL-TERMINATE-WHEN-UNREACHABLE.

"canonicalize" the foreign type (:ARRAY :INT 2); using it would make the
code for CCL::PIPE a little clearer, but there are bootstrapping issues.

Location:
branches/working-0710/ccl
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0710/ccl/level-0/l0-io.lisp

    r7393 r7611  
    172172(defun fd-open (path flags &optional (create-mode #o666))
    173173  (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((p path))
    174     (syscall syscalls::open p flags create-mode)))
     174    (let* ((fd (syscall syscalls::open p flags create-mode)))
     175      (declare (fixnum fd))
     176      (when (or (= fd (- #$EMFILE))
     177                (= fd (- #$EMFILE)))
     178        (gc)
     179        (drain-termination-queue)
     180        (setq fd (syscall syscalls::open p flags create-mode)))
     181      fd)))
    175182
    176183(defun fd-chmod (fd mode)
  • branches/working-0710/ccl/level-1/l1-lisp-threads.lisp

    r7601 r7611  
    941941
    942942
    943 (defvar *termination-population*
     943(defstatic *termination-population*
    944944  (%cons-terminatable-alist))
    945945
    946 (defvar *termination-population-lock* (make-lock))
     946(defstatic *termination-population-lock* (make-lock))
    947947
    948948
     
    957957or releasing of resources which needs to happen when a certain object is
    958958no longer being used."
    959   (let ((new-cell (list (cons object function)))
     959  (let ((new-cell (cons object function))
    960960        (population *termination-population*))
    961961    (without-interrupts
    962962     (with-lock-grabbed (*termination-population-lock*)
    963        (setf (cdr new-cell) (population-data population)
    964              (population-data population) new-cell)))
     963       (atomic-push-uvector-cell population population.data new-cell)))
    965964    function))
    966965
     
    979978
    980979(defun cancel-terminate-when-unreachable (object &optional (function nil function-p))
    981   (let ((found-it? nil))
    982     (flet ((test (object cell)
    983              (and (eq object (car cell))
    984                   (or (not function-p)
    985                       (eq function (cdr cell)))
    986                   (setq found-it? t))))
    987       (declare (dynamic-extent #'test))
    988       (without-interrupts
    989        (with-lock-grabbed (*termination-population-lock*)
    990          (setf (population-data *termination-population*)
    991                (delete object (population-data *termination-population*)
    992                        :test #'test
    993                        :count 1))))
    994       found-it?)))
     980  (let* ((found nil))
     981    (with-lock-grabbed (*termination-population-lock*)
     982      ;; Have to defer GCing, e.g., defer responding to a GC
     983      ;; suspend request here (that also defers interrupts)
     984      ;; We absolutely, positively can't take an exception
     985      ;; in here, so don't even bother to typecheck on
     986      ;; car/cdr etc.
     987      (with-deferred-gc
     988          (do ((spine (population-data *termination-population*) (cdr spine))
     989               (prev nil spine))
     990              ((null spine))
     991            (declare (optimize (speed 3) (safety 0)))
     992            (let* ((head (car spine))
     993                   (tail (cdr spine))
     994                   (o (car head))
     995                   (f (cdr head)))
     996              (when (and (eq o object)
     997                         (or (null function-p)
     998                             (eq function f)))
     999                (if prev
     1000                  (setf (cdr prev) tail)
     1001                  (setf (population-data *termination-population*) tail))
     1002                (setq found t)
     1003                (return)))))
     1004      found)))
     1005
    9951006
    9961007(defun termination-function (object)
  • branches/working-0710/ccl/level-1/linux-files.lisp

    r7514 r7611  
    641641
    642642
    643 #+linux-target
    644 (defun pipe ()
    645   (%stack-block ((pipes 8))
    646     (let* ((status (syscall syscalls::pipe pipes)))
    647       (if (= 0 status)
    648         (values (%get-long pipes 0) (%get-long pipes 4))
    649         (%errno-disp status)))))
     643
    650644
    651645
    652646;;; I believe that the Darwin/FreeBSD syscall infterface is rather ... odd.
    653647;;; Use libc's interface.
    654 #+(or darwin-target freebsd-target)
    655648(defun pipe ()
     649  ;;  (rlet ((filedes (:array :int 2)))
    656650  (%stack-block ((filedes 8))
    657     (let* ((status (#_pipe filedes)))
     651    (let* ((status (#_pipe filedes))
     652           (errno (if (eql status 0) 0 (%get-errno))))
     653      (unless (zerop status)
     654        (when (or (eql errno (- #$EMFILE))
     655                  (eql errno (- #$ENFILE)))
     656          (gc)
     657          (drain-termination-queue)
     658          (setq status (#_pipe filedes)
     659                errno (if (zerop status) 0 (%get-errno)))))
    658660      (if (zerop status)
    659661        (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))
    660         (%errno-disp (%get-errno))))))
     662        (%errno-disp errno)))))
    661663
    662664
  • branches/working-0710/ccl/lib/foreign-types.lisp

    r6503 r7611  
    17001700      (canonicalize-foreign-type-ordinal '(:struct :dbm-constant))
    17011701      (canonicalize-foreign-type-ordinal '(:* (:struct :hostent)))
     1702      (canonicalize-foreign-type-ordinal '(:array :int 2))
    17021703      )))
    17031704
Note: See TracChangeset for help on using the changeset viewer.