Changeset 8304

Timestamp:

Jan 27, 2008, 8:34:03 AM (17 years ago)

Author:

gz

Message:

Update to trunk rev 8303

Location:

branches/event-ide/ccl

Files:

• level-0/l0-io.lisp (modified) (1 diff)
• level-1/l1-files.lisp (modified) (2 diffs)
• level-1/l1-readloop-lds.lisp (modified) (2 diffs)
• level-1/l1-sockets.lisp (modified) (6 diffs)
• level-1/l1-streams.lisp (modified) (4 diffs)
• level-1/linux-files.lisp (modified) (3 diffs)
• lib/backtrace-lds.lisp (modified) (1 diff)
• lib/backtrace.lisp (modified) (2 diffs)
• lib/foreign-types.lisp (modified) (1 diff)
• lib/macros.lisp (modified) (1 diff)
• library/darwinppc-syscalls.lisp (modified) (1 diff)
• library/x8664-freebsd-syscalls.lisp (modified) (1 diff)
• library/x8664-linux-syscalls.lisp (modified) (1 diff)
• lisp-kernel/x86-macros.s (modified) (1 diff)

branches/event-ide/ccl/level-0/l0-io.lisp

@@ -162 +162 @@
 ;;; write nbytes bytes from buffer buf to file-descriptor fd.
 (defun fd-write (fd buf nbytes)
-  (syscall syscalls::write fd buf nbytes))
+  (ignoring-eintr (syscall syscalls::write fd buf nbytes)))
 
 (defun fd-read (fd buf nbytes)
-  (loop
-    (let* ((n  (syscall syscalls::read fd buf nbytes)))
-      (unless (eql n (- #$EINTR)) (return n)))))
+  (ignoring-eintr (syscall syscalls::read fd buf nbytes)))
 
 

branches/event-ide/ccl/level-1/l1-files.lisp

@@ -184 +184 @@
 
 (defun create-file (path &key (if-exists :error) (create-directory t))
-  (native-to-pathname (%create-file path :if-exists if-exists
+  (let* ((p (%create-file path :if-exists if-exists
                                       :create-directory create-directory)))
+    (and p
+         (native-to-pathname p))))
+
 (defun %create-file (path &key
                          (if-exists :error)
@@ -195 +198 @@
   (assert (or (eql if-exists :overwrite)
               (null if-exists)
+              (eq if-exists :error)
               (not (probe-file path))) ()
           "~s ~s not implemented yet" :if-exists if-exists)
   (let* ((unix-name (native-translated-namestring path))
          (fd (fd-open unix-name (logior #$O_WRONLY #$O_CREAT #$O_TRUNC
-                                        (if (null if-exists)
+                                        (if (or (null if-exists)
+                                                (eq if-exists :error))
                                           #$O_EXCL
                                           0)))))
     (if (< fd 0)
-      (if (eql fd (- #$EEXIST))         ; #$O_EXCL was set and file exists
+      (if (and (null if-exists)
+               (eql fd (- #$EEXIST)))
         (return-from %create-file nil)
         (signal-file-error fd path))

branches/event-ide/ccl/level-1/l1-readloop-lds.lisp

@@ -331 +331 @@
                           (cons keyword params)
                           keyword)))
-                    (params param)))))))))))
+                    (params (eval param))))))))))))
 
 ;;; Read a form from the specified stream.
@@ -414 +414 @@
 
 (defun abnormal-application-exit ()
-  (print-call-history)
-  (force-output *debug-io*)
-  (quit -1))
+  (ignore-errors
+    (print-call-history)
+    (force-output *debug-io*)
+    (quit -1))
+  (#__exit -1))
 
 (defun break-loop-handle-error (condition error-pointer)

branches/event-ide/ccl/level-1/l1-sockets.lisp

@@ -674 +674 @@
       (fd-close fd))))
 
-(defun %socket-connect (fd addr addrlen)
-  (let* ((err (c_connect fd addr addrlen)))
+(defun %socket-connect (fd addr addrlen &optional timeout)
+  (let* ((err (c_connect fd addr addrlen timeout)))
     (declare (fixnum err))
-    (when (eql err (- #$EINPROGRESS))
-      (process-output-wait fd)
-      (setq err (- (int-getsockopt fd #$SOL_SOCKET #$SO_ERROR))))
     (unless (eql err 0) (socket-error nil "connect" err))))
     
@@ -992 +989 @@
 
 (defun timeval-setsockopt (socket level optname timeout)
-    (multiple-value-bind (seconds millis)
-        (milliseconds timeout)
-      (rlet ((valptr :timeval :tv_sec seconds :tv_usec millis))
+    (multiple-value-bind (seconds micros)
+        (microseconds timeout)
+      (rlet ((valptr :timeval :tv_sec seconds :tv_usec micros))
         (socket-call socket "setsockopt"
           (c_setsockopt socket level optname valptr (record-length :timeval))))))
@@ -1077 +1074 @@
     (rlet ((hostent :hostent)
            (hp (* (struct :hostent)))
-           (herr :signed))
+           (herr :signed 0))
        (do* ((buflen 1024 (+ buflen buflen))) ()
          (declare (fixnum buflen))
@@ -1085 +1082 @@
              (unless (eql res #$ERANGE)
                (return
-                 (if (eql res 0)
+                 (let* ((err (pref herr :signed)))
+                 (if (and (eql res 0) (eql err 0))
                    (%get-unsigned-long
                     (%get-ptr (pref (%get-ptr hp) :hostent.h_addr_list)))
-                   (values nil (- (pref herr :signed))))))))))))
+                   (values nil (- err))))))))))))
 
 (defun _getservbyname (name proto)
@@ -1203 +1201 @@
       (syscall syscalls::socketcall 2 params))))
 
-(defun c_connect (sockfd addr len)
-  #+(or darwin-target linuxx8664-target freebsd-target)
-  (syscall syscalls::connect sockfd addr len)
-  #+linuxppc-target
-  (progn
-    #+ppc32-target
-    (%stack-block ((params 12))
-      (setf (%get-long params 0) sockfd
-            (%get-ptr params 4) addr
-            (%get-long params 8) len)
-      (syscall syscalls::socketcall 3 params))
-    #+ppc64-target
-    (%stack-block ((params 24))
-      (setf (%%get-unsigned-longlong params 0) sockfd
-            (%get-ptr params 8) addr
-            (%%get-unsigned-longlong params 16) len)
-      (syscall syscalls::socketcall 3 params))))
+
+;;; If attempts to connnect are interrupted, we basically have to
+;;; wait in #_select (or the equivalent).  There's a good rant
+;;; about these issues in:
+;;; <http://www.madore.org/~david/computers/connect-intr.html>
+(defun c_connect (sockfd addr len &optional timeout)
+  (let* ((err 
+          #+(or darwin-target linuxx8664-target freebsd-target)
+          (syscall syscalls::connect sockfd addr len)
+          #+linuxppc-target
+          (progn
+            #+ppc32-target
+            (%stack-block ((params 12))
+              (setf (%get-long params 0) sockfd
+                    (%get-ptr params 4) addr
+                    (%get-long params 8) len)
+              (syscall syscalls::socketcall 3 params))
+            #+ppc64-target
+            (%stack-block ((params 24))
+              (setf (%%get-unsigned-longlong params 0) sockfd
+                    (%get-ptr params 8) addr
+                    (%%get-unsigned-longlong params 16) len)
+              (syscall syscalls::socketcall 3 params)))))
+    (cond ((or (eql err (- #$EINPROGRESS)) (eql err (- #$EINTR)))
+           (if (process-output-wait sockfd timeout)
+             (- (int-getsockopt sockfd #$SOL_SOCKET #$SO_ERROR))
+             (- #$ETIMEDOUT)))
+          (t err))))
 
 (defun c_listen (sockfd backlog)
@@ -1238 +1247 @@
 
 (defun c_accept (sockfd addrp addrlenp)
-  #+(or darwin-target linuxx8664-target freebsd-target)
-  (syscall syscalls::accept sockfd addrp addrlenp)
-  #+linuxppc-target
-  (progn
-    #+ppc32-target
-    (%stack-block ((params 12))
-      (setf (%get-long params 0) sockfd
-            (%get-ptr params 4) addrp
-            (%get-ptr params 8) addrlenp)
-      (syscall syscalls::socketcall 5 params))
-    #+ppc64-target
-    (%stack-block ((params 24))
-      (setf (%%get-unsigned-longlong params 0) sockfd
-            (%get-ptr params 8) addrp
-            (%get-ptr params 16) addrlenp)
-      (syscall syscalls::socketcall 5 params))))
+  (ignoring-eintr 
+   #+(or darwin-target linuxx8664-target freebsd-target)
+   (syscall syscalls::accept sockfd addrp addrlenp)
+   #+linuxppc-target
+   (progn
+     #+ppc32-target
+     (%stack-block ((params 12))
+       (setf (%get-long params 0) sockfd
+             (%get-ptr params 4) addrp
+             (%get-ptr params 8) addrlenp)
+       (syscall syscalls::socketcall 5 params))
+     #+ppc64-target
+     (%stack-block ((params 24))
+       (setf (%%get-unsigned-longlong params 0) sockfd
+             (%get-ptr params 8) addrp
+             (%get-ptr params 16) addrlenp)
+       (syscall syscalls::socketcall 5 params)))))
 
 (defun c_getsockname (sockfd addrp addrlenp)

branches/event-ide/ccl/level-1/l1-streams.lisp

@@ -5206 +5206 @@
     (- #$ETIMEDOUT)))
     
-(defun process-input-wait (fd &optional ticks)
+(defun process-input-wait (fd &optional timeout)
   "Wait until input is available on a given file-descriptor."
-  (let* ((wait-end (if ticks (+ (get-tick-count) ticks))))
-    (loop
-      ;; FD-INPUT-AVAILABLE-P can return NIL (e.g., if the
-      ;; thread receives an interrupt) before a timeout is
-      ;; reached.
-      (when (fd-input-available-p fd ticks)
-        (return t))
-      ;; If it returned and a timeout was specified, check
-      ;; to see if it's been exceeded.  If so, return NIL;
-      ;; otherwise, adjust the remaining timeout.
-      ;; If there was no timeout, continue to wait forever.
-      (when ticks
-        (let* ((now (get-tick-count)))
-          (if (and wait-end (>= now wait-end))
-            (return)
-            (setq ticks (- wait-end now))))))))
+  (rlet ((now :timeval))
+    (let* ((wait-end 
+            (if timeout
+              (multiple-value-bind (seconds millis) (milliseconds timeout)
+                (#_gettimeofday now +null-ptr+)
+                (setq timeout (+ (* seconds 1000) millis))
+                (+ (timeval->milliseconds now) timeout)))))
+      (loop
+        ;; FD-INPUT-AVAILABLE-P can return NIL (e.g., if the
+        ;; thread receives an interrupt) before a timeout is
+        ;; reached.
+        (when (fd-input-available-p fd (or timeout -1))
+          (return t))
+        ;; If it returned and a timeout was specified, check
+        ;; to see if it's been exceeded.  If so, return NIL;
+        ;; otherwise, adjust the remaining timeout.
+        ;; If there was no timeout, continue to wait forever.
+        (when timeout
+          (#_gettimeofday now +null-ptr+)
+          (setq timeout (- wait-end (timeval->milliseconds now)))
+          (if (<= timeout 0)
+            (return)))))))
 
 
@@ -5231 +5237 @@
     (- #$ETIMEDOUT)))
 
-(defun process-output-wait (fd)
+(defun process-output-wait (fd &optional timeout)
   "Wait until output is possible on a given file descriptor."
-  (loop
-    (when (fd-ready-for-output-p fd nil)
-      (return t))))
+  (rlet ((now :timeval))
+    (let* ((wait-end 
+            (if timeout
+              (multiple-value-bind (seconds millis) (milliseconds timeout)
+                (#_gettimeofday now +null-ptr+)
+                (setq timeout (+ (* seconds 1000) millis))
+                (+ (timeval->milliseconds now) timeout)))))
+      (loop
+        ;; FD-INPUT-AVAILABLE-P can return NIL (e.g., if the
+        ;; thread receives an interrupt) before a timeout is
+        ;; reached.
+        (when (fd-ready-for-output-p fd (or timeout -1))
+          (return t))
+        ;; If it returned and a timeout was specified, check
+        ;; to see if it's been exceeded.  If so, return NIL;
+        ;; otherwise, adjust the remaining timeout.
+        ;; If there was no timeout, continue to wait forever.
+        (when timeout
+          (#_gettimeofday now +null-ptr+)
+          (setq timeout (- wait-end (timeval->milliseconds now)))
+          (if (<= timeout 0)
+            (return)))))))
 
 
@@ -5249 +5274 @@
               (pref tv :timeval.tv_usec) us)))))
 
-(defun fd-input-available-p (fd &optional ticks)
-  (rletZ ((tv :timeval))
-    (ticks-to-timeval ticks tv)
-    (%stack-block ((infds *fd-set-size*))
-      (fd-zero infds)
-      (fd-set fd infds)
-      (let* ((res (syscall syscalls::select (1+ fd) infds (%null-ptr) (%null-ptr)
-                           (if ticks tv (%null-ptr)))))
-        (> res 0)))))
-
-(defun fd-ready-for-output-p (fd &optional ticks)
-  (rletZ ((tv :timeval))
-    (ticks-to-timeval ticks tv)
-    (%stack-block ((outfds *fd-set-size*))
-      (fd-zero outfds)
-      (fd-set fd outfds)
-      (let* ((res (#_select (1+ fd) (%null-ptr) outfds (%null-ptr)
-                            (if ticks tv (%null-ptr)))))
-        (> res 0)))))
+(defun fd-input-available-p (fd &optional milliseconds)
+  (rlet ((pollfds (:array (:struct :pollfd) 1)))
+    (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd
+          (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLIN)
+    (let* ((res (ignoring-eintr (syscall syscalls::poll pollfds 1 (or milliseconds -1)))))
+      (> res 0))))
+
+
+(defun fd-ready-for-output-p (fd &optional milliseconds)
+  (rlet ((pollfds (:array (:struct :pollfd) 1)))
+    (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd
+          (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLOUT)
+    (let* ((res (ignoring-eintr (syscall syscalls::poll pollfds 1 (or milliseconds -1)))))
+      (> res 0))))
 
 (defun fd-urgent-data-available-p (fd &optional ticks)
@@ -5577 +5597 @@
          (tem-path (merge-pathnames (make-pathname :name (%integer-to-string date) :type "tem" :defaults nil) path)))
     (loop
-      (when (%create-file tem-path :if-exists nil) (return tem-path))
+      (when (%create-file tem-path :if-exists nil) (return tem-path))      
       (setf (%pathname-name tem-path) (%integer-to-string (setq date (1+ date)))))))
 

branches/event-ide/ccl/level-1/linux-files.lisp

@@ -66 +66 @@
       (setq r 0)
       (setq r (floor (* r 1000))))
+    (values q r)))
+
+(defun microseconds (n)
+  (unless (and (typep n 'fixnum)
+               (>= (the fixnum n) 0))
+    (check-type n (real 0 #xffffffff)))
+  (multiple-value-bind (q r)
+      (floor n)
+    (if (zerop r)
+      (setq r 0)
+      (setq r (floor (* r 1000000))))
     (values q r)))
 
@@ -433 +444 @@
           (pref result :timeval.tv_usec) micros)
     result))
+
+;;; Return T iff the time denoted by the timeval a is not later than the
+;;; time denoted by the timeval b.
+(defun %timeval<= (a b)
+  (let* ((asec (pref a :timeval.tv_sec))
+         (bsec (pref b :timeval.tv_sec)))
+    (or (< asec bsec)
+        (and (= asec bsec)
+             (< (pref a :timeval.tv_usec)
+                (pref b :timeval.tv_usec))))))
 
 
@@ -832 +853 @@
         (signal-semaphore (external-process-completed p))
         (return))
-      (if in-fd
-        (when (fd-input-available-p in-fd *ticks-per-second*)
+      (when in-fd
+        (when (fd-input-available-p in-fd 0)
           (%stack-block ((buf 1024))
             (let* ((n (fd-read in-fd buf 1024)))

branches/event-ide/ccl/lib/backtrace-lds.lisp

@@ -39 +39 @@
 (defun frame-supplied-args (frame lfun pc child context)
   (declare (ignore child))
-  (let* ((arglist (arglist-from-map lfun))
-         (args (arguments-and-locals context frame lfun pc))
-         (state :required))
-    (collect ((arg-values)
-              (types)
-              (names))
-      (dolist (arg arglist)
-        (if (or (member arg lambda-list-keywords)
-                (eq arg '&lexpr))
-          (setq state arg)
-          (let* ((pair (pop args)))
-            (case state
-              (&lexpr
-               (with-list-from-lexpr (rest (cdr pair))
-                 (dolist (r rest) (arg-values r) (names nil) (types nil)))
-               (return))
-              (&rest
-               (dolist (r (cdr pair)) (arg-values r) (names nil) (types nil))
-               (return))
-              (&key
-               (arg-values arg)
-               (names nil)
-               (types nil)))
-            (let* ((value (cdr pair)))
-              (if (eq value (%unbound-marker))
-                (return))
-              (names (car pair))
-              (arg-values value)
-              (types nil)))))
-      (values (arg-values) (types) (names)))))
-
-;;; I'm skeptical about a lot of this stuff on the PPC, but if anything it's
-;;; pretty PPC-specific
-#+ppc-target
-(progn
-;;; Act as if VSTACK-INDEX points somewhere where DATA could go & put it there.
-(defun set-lisp-data (vstack-index data)
-  (let* ((old (%access-lisp-data vstack-index)))
-    (if (closed-over-value-p old)
-      (set-closed-over-value old data)
-      (%store-lisp-data vstack-index data))))
+  (if (null pc)
+    (values nil nil nil)
+    (if (<= pc target::arg-check-trap-pc-limit)
+      (values (arg-check-call-arguments frame lfun) nil nil)
+      (let* ((arglist (arglist-from-map lfun))
+             (args (arguments-and-locals context frame lfun pc))
+             (state :required))
+        (collect ((arg-values)
+                  (types)
+                  (names))
+          (dolist (arg arglist)
+            (if (or (member arg lambda-list-keywords)
+                    (eq arg '&lexpr))
+              (setq state arg)
+              (let* ((pair (pop args)))
+                (case state
+                  (&lexpr
+                   (with-list-from-lexpr (rest (cdr pair))
+                     (dolist (r rest) (arg-values r) (names nil) (types nil)))
+                   (return))
+                  (&rest
+                   (dolist (r (cdr pair)) (arg-values r) (names nil) (types nil))
+                   (return))
+                  (&key
+                   (arg-values arg)
+                   (names nil)
+                   (types nil)))
+                (let* ((value (cdr pair)))
+                  (if (eq value (%unbound-marker))
+                    (return))
+                  (names (car pair))
+                  (arg-values value)
+                  (types nil)))))
+          (values (arg-values) (types) (names)))))))
 
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;;extensions to let user access and modify values
-
-
-
-
-
-;;; nth-frame-info, set-nth-frame-info, & frame-lfun are in "inspector;new-backtrace"
-
-
-
-
-
-
-(defparameter *saved-register-count+1*
-  (1+ *saved-register-count*))
-
-
-
-(defparameter *saved-register-numbers*
-  #+x8664-target #(wrong)
-  #+ppc-target #(31 30 29 28 27 26 25 24))
-
-;;; Don't do unbound checks in compiled code
-(declaim (type t *saved-register-count* *saved-register-count+1*
-               *saved-register-names* *saved-register-numbers*))
-
-(defmacro %cons-saved-register-vector ()
-  `(make-array (the fixnum *saved-register-count+1*) :initial-element nil))
-
-(defun copy-srv (from-srv &optional to-srv)
-  (if to-srv
-    (if (eq from-srv to-srv)
-      to-srv
-      (dotimes (i (uvsize from-srv) to-srv)
-        (setf (uvref to-srv i) (uvref from-srv i))))
-    (copy-uvector from-srv)))
-
-(defmacro srv.unresolved (saved-register-vector)
-  `(svref ,saved-register-vector 0))
-
-(defmacro srv.register-n (saved-register-vector n)
-  `(svref ,saved-register-vector (1+ ,n)))
-
-;;; This isn't quite right - has to look at all functions on stack,
-;;; not just those that saved VSPs.
-
-
-(defun frame-restartable-p (target &optional context)
-  (multiple-value-bind (frame last-catch srv) (last-catch-since-saved-vars target context)
-    (when frame
-      (loop
-        (when (null frame)
-          (return-from frame-restartable-p nil))
-        (when (eq frame target) (return))
-        (multiple-value-setq (frame last-catch srv)
-          (ccl::parent-frame-saved-vars context frame last-catch srv srv)))
-      (when (and srv (eql 0 (srv.unresolved srv)))
-        (setf (srv.unresolved srv) last-catch)
-        srv))))
-
-
-;;; get the saved register addresses for this frame
-;;; still need to worry about this unresolved business
-;;; could share some code with parent-frame-saved-vars
-(defun my-saved-vars (frame &optional (srv-out (%cons-saved-register-vector)))
-  (let ((unresolved 0))
-    (multiple-value-bind (lfun pc) (cfp-lfun frame)
-        (if lfun
-          (multiple-value-bind (mask where) (registers-used-by lfun pc)
-            (when mask
-              (if (not where) 
-                (setq unresolved (%ilogior unresolved mask))
-                (let ((vsp (- (frame-vsp frame) where (1- (logcount mask))))
-                      (j *saved-register-count*))
-                  (declare (fixnum j))
-                  (dotimes (i j)
-                    (declare (fixnum i))
-                    (when (%ilogbitp (decf j) mask)
-                      (setf (srv.register-n srv-out i) vsp
-                            vsp (1+ vsp)
-                            unresolved (%ilogand unresolved (%ilognot (%ilsl j 1))))))))))
-          (setq unresolved (1- (ash 1 *saved-register-count*)))))
-    (setf (srv.unresolved srv-out) unresolved)
-    srv-out))
-
-(defun parent-frame-saved-vars 
-       (context frame last-catch srv &optional (srv-out (%cons-saved-register-vector)))
-  (copy-srv srv srv-out)
-  (let* ((parent (and frame (parent-frame frame context)))
-         (grand-parent (and parent (parent-frame parent context))))
-    (when grand-parent
-      (loop (let ((next-catch (and last-catch (next-catch last-catch))))
-              ;(declare (ignore next-catch))
-              (if (and next-catch (%stack< (catch-frame-sp next-catch) grand-parent context))
-                (progn
-                  (setf last-catch next-catch
-                        (srv.unresolved srv-out) 0)
-                  (dotimes (i *saved-register-count*)
-                    (setf (srv.register-n srv i) nil)))
-                (return))))
-      (lookup-registers parent context grand-parent srv-out)
-      (values parent last-catch srv-out))))
-
-(defun lookup-registers (parent context grand-parent srv-out)
-  (unless (or (eql (frame-vsp grand-parent) 0)
-              (let ((gg-parent (parent-frame grand-parent context)))
-                (eql (frame-vsp gg-parent) 0)))
-    (multiple-value-bind (lfun pc) (cfp-lfun parent)
-      (when lfun
-        (multiple-value-bind (mask where) (registers-used-by lfun pc)
-          (when mask
-            (locally (declare (fixnum mask))
-              (if (not where) 
-                (setf (srv.unresolved srv-out) (%ilogior (srv.unresolved srv-out) mask))
-                (let* ((grand-parent-vsp (frame-vsp grand-parent)))
-
-                  (let ((vsp (- grand-parent-vsp where 1))
-                        (j *saved-register-count*))
-                    (declare (fixnum j))
-                    (dotimes (i j)
-                      (declare (fixnum i))
-                      (when (%ilogbitp (decf j) mask)
-                        (setf (srv.register-n srv-out i) vsp
-                              vsp (1- vsp)
-                              (srv.unresolved srv-out)
-                              (%ilogand (srv.unresolved srv-out) (%ilognot (%ilsl j 1))))))))))))))))
-
-;;; initialization for looping on parent-frame-saved-vars
-(defun last-catch-since-saved-vars (frame context)
-  (let* ((parent (parent-frame frame context))
-         (last-catch (and parent (last-catch-since parent context))))
-    (when last-catch
-      (let ((frame (catch-frame-sp last-catch))
-            (srv (%cons-saved-register-vector)))
-        (setf (srv.unresolved srv) 0)
-        (let* ((parent (parent-frame frame context))
-               (child (and parent (child-frame parent context))))
-          (when child
-            (lookup-registers child context parent srv))
-          (values child last-catch srv))))))
-
-;;; Returns 2 values:
-;;; mask srv
-;;; The mask says which registers are used at PC in LFUN.  srv is a
-;;; saved-register-vector whose register contents are the register
-;;; values registers whose bits are not set in MASK or set in
-;;; UNRESOLVED will be returned as NIL.
-
-(defun saved-register-values 
-       (lfun pc child last-catch srv &optional (srv-out (%cons-saved-register-vector)))
-  (declare (ignore child))
-  (cond ((null srv-out) (setq srv-out (copy-uvector srv)))
-        ((eq srv-out srv))
-        (t (dotimes (i (the fixnum (uvsize srv)))
-             (setf (uvref srv-out i) (uvref srv i)))))
-  (let ((mask (or (registers-used-by lfun pc) 0))
-        (unresolved (srv.unresolved srv))
-        (j *saved-register-count*))
-    (declare (fixnum j))
-    (dotimes (i j)
-      (declare (fixnum i))
-      (setf (srv.register-n srv-out i)
-            (and (%ilogbitp (setq j (%i- j 1)) mask)
-                 (not (%ilogbitp j unresolved))
-                 (safe-cell-value (get-register-value (srv.register-n srv i) last-catch j)))))
-    (setf (srv.unresolved srv-out) mask)
-    (values mask srv-out)))
-
-; Set the nth saved register to value.
-(defun set-saved-register (value n lfun pc child last-catch srv)
-  (declare (ignore lfun pc child) (dynamic-extent saved-register-values))
-  (let ((j (- target::node-size n))
-        (unresolved (srv.unresolved srv))
-        (addr (srv.register-n srv n)))
-    (when (logbitp j unresolved)
-      (error "Can't set register ~S to ~S" n value))
-    (set-register-value value addr last-catch j))
-  value)
-
-
-
-
-
-(defun return-from-nth-frame (n &rest values)
-  (apply-in-nth-frame n #'values values))
-
-(defun apply-in-nth-frame (n fn arglist)
-  (let* ((bt-info (car *backtrace-contexts*)))
-    (and bt-info
-         (let* ((frame (nth-frame nil (bt.youngest bt-info) n bt-info)))
-           (and frame (apply-in-frame frame fn arglist)))))
-  (format t "Can't return to frame ~d ." n))
-
-;;; This method is shadowed by one for the backtrace window.
-(defmethod nth-frame (w target n context)
-  (declare (ignore w))
-  (and target (dotimes (i n target)
-                (declare (fixnum i))
-                (unless (setq target (parent-frame target context)) (return nil)))))
-
-; If this returns at all, it's because the frame wasn't restartable.
-(defun apply-in-frame (frame fn arglist &optional context)
-  (let* ((srv (frame-restartable-p frame context))
-         (target-sp (and srv (srv.unresolved srv))))
-    (if target-sp
-      (apply-in-frame-internal context frame fn arglist srv))))
-
-(defun apply-in-frame-internal (context frame fn arglist srv)
-  (let* ((tcr (if context (bt.tcr context) (%current-tcr))))
-    (if (eq tcr (%current-tcr))
-      (%apply-in-frame frame fn arglist srv)
-      (let ((process (tcr->process tcr)))
-        (if process
-          (process-interrupt
-           process
-           #'%apply-in-frame
-           frame fn arglist srv)
-          (error "Can't find active process for ~s" tcr))))))
-
-
-
-
-;;; (srv.unresolved srv) is the last catch frame, left there by
-;;; frame-restartable-p The registers in srv are locations of
-;;; variables saved between frame and that catch frame.
-(defun %apply-in-frame (frame fn arglist srv)
-  (declare (fixnum frame))
-  (let* ((catch (srv.unresolved srv))
-         (tsp-count 0)
-         (tcr (%current-tcr))
-         (parent (parent-frame frame tcr))
-         (vsp (frame-vsp parent))
-         (catch-top (%catch-top tcr))
-         (db-link (%svref catch target::catch-frame.db-link-cell))
-         (catch-count 0))
-    (declare (fixnum parent vsp db-link catch-count))
-    ;; Figure out how many catch frames to throw through
-    (loop
-      (unless catch-top
-        (error "Didn't find catch frame"))
-      (incf catch-count)
-      (when (eq catch-top catch)
-        (return))
-      (setq catch-top (next-catch catch-top)))
-    ;; Figure out where the db-link should be
-    (loop
-      (when (or (eql db-link 0) (>= db-link vsp))
-        (return))
-      (setq db-link (%fixnum-ref db-link)))
-    ;; Figure out how many TSP frames to pop after throwing.
-    (let ((sp (catch-frame-sp catch)))
-      (loop
-        (multiple-value-bind (f pc) (cfp-lfun sp)
-          (when f (incf tsp-count (active-tsp-count f pc))))
-        (setq sp (parent-frame sp tcr))
-        (when (eql sp parent) (return))
-        (unless sp (error "Didn't find frame: ~s" frame))))
-    #+debug
-    (cerror "Continue" "(apply-in-frame ~s ~s ~s ~s ~s ~s ~s)"
-            catch-count srv tsp-count db-link parent fn arglist)
-    (%%apply-in-frame catch-count srv tsp-count db-link parent fn arglist)))
-
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Code to determine how many tsp frames to pop.
-;;; This is done by parsing the code.
-;;; active-tsp-count is the entry point below.
-;;;
-
-#+ppc-target
-(progn
-
-(defstruct (branch-tree (:print-function print-branch-tree))
-  first-instruction
-  last-instruction
-  branch-target     ; a branch-tree or nil
-  fall-through)     ; a branch-tree or nil
-
-(defun print-branch-tree (tree stream print-level)
-  (declare (ignore print-level))
-  (print-unreadable-object (tree stream :type t :identity t)
-    (format stream "~s-~s"
-            (branch-tree-first-pc tree)
-            (branch-tree-last-pc tree))))
-
-(defun branch-tree-first-pc (branch-tree)
-  (let ((first (branch-tree-first-instruction branch-tree)))
-    (and first (instruction-element-address first))))
-
-(defun branch-tree-last-pc (branch-tree)
-  (let ((last (branch-tree-last-instruction branch-tree)))
-    (if last
-      (instruction-element-address last)
-      (branch-tree-first-pc branch-tree))))
-
-(defun branch-tree-contains-pc-p (branch-tree pc)
-  (<= (branch-tree-first-pc branch-tree)
-      pc
-      (branch-tree-last-pc branch-tree)))
-
-(defvar *branch-tree-hash*
-  (make-hash-table :test 'eq :weak :value))
-
-(defun get-branch-tree (function)
-  (or (gethash function *branch-tree-hash*)
-      (let* ((dll (function-to-dll-header function))
-             (tree (dll-to-branch-tree dll)))
-        (setf (gethash function *branch-tree-hash*) tree))))         
-
-; Return the number of TSP frames that will be active after throwing out
-; of all the active catch frames in function at pc.
-; PC is a byte address, a multiple of 4.
-(defun active-tsp-count (function pc)
-  (setq function
-        (require-type
-         (if (symbolp function)
-           (symbol-function function)
-           function)
-         'compiled-function))
-  (let* ((tree (get-branch-tree function))
-         (visited nil))
-    (labels ((find-pc (branch path)
-               (unless (memq branch visited)
-                 (push branch path)
-                 (if (branch-tree-contains-pc-p branch pc)
-                   path
-                   (let ((target (branch-tree-branch-target branch))
-                         (fall-through (branch-tree-fall-through branch)))
-                     (push branch visited)
-                     (if fall-through
-                       (or (and target (find-pc target path))
-                           (find-pc fall-through path))
-                       (and target (find-pc target path))))))))
-      (let* ((path (nreverse (find-pc tree nil)))
-             (last-tree (car (last path)))
-             (catch-count 0)
-             (tsp-count 0))
-        (unless path
-          (error "Can't find path to pc: ~s in ~s" pc function))
-        (dolist (tree path)
-          (let ((next (branch-tree-first-instruction tree))
-                (last (branch-tree-last-instruction tree)))
-            (loop
-              (when (and (eq tree last-tree)
-                         (eql pc (instruction-element-address next)))
-                ; If the instruction before the current one is an ff-call,
-                ; then callback pushed a TSP frame.
-                #| ; Not any more
-                (when (ff-call-instruction-p (dll-node-pred next))
-                  (incf tsp-count))
-                |#
-                (return))
-              (multiple-value-bind (type target fall-through count) (categorize-instruction next)
-                (declare (ignore target fall-through))
-                (case type
-                  (:tsp-push
-                   (when (eql catch-count 0)
-                     (incf tsp-count count)))
-                  (:tsp-pop
-                   (when (eql catch-count 0)
-                     (decf tsp-count count)))
-                  ((:catch :unwind-protect)
-                   (incf catch-count))
-                  (:throw
-                   (decf catch-count count))))
-              (when (eq next last)
-                (return))
-              (setq next (dll-node-succ next)))))
-        tsp-count))))
-        
-
-(defun dll-to-branch-tree (dll)
-  (let* ((hash (make-hash-table :test 'eql))    ; start-pc -> branch-tree
-         (res (collect-branch-tree (dll-header-first dll) dll hash))
-         (did-something nil))
-    (loop
-      (setq did-something nil)
-      (let ((mapper #'(lambda (key value)
-                        (declare (ignore key))
-                        (flet ((maybe-collect (pc)
-                                 (when (integerp pc)
-                                   (let ((target-tree (gethash pc hash)))
-                                     (if target-tree
-                                       target-tree
-                                       (progn
-                                         (collect-branch-tree (dll-pc->instr dll pc) dll hash)
-                                         (setq did-something t)
-                                         nil))))))
-                          (declare (dynamic-extent #'maybe-collect))
-                          (let ((target-tree (maybe-collect (branch-tree-branch-target value))))
-                            (when target-tree (setf (branch-tree-branch-target value) target-tree)))
-                          (let ((target-tree (maybe-collect (branch-tree-fall-through value))))
-                            (when target-tree (setf (branch-tree-fall-through value) target-tree)))))))
-        (declare (dynamic-extent mapper))
-        (maphash mapper hash))
-      (unless did-something (return)))
-    ; To be totally correct, we should fix up the trees containing
-    ; the BLR instruction for unwind-protect cleanups, but none
-    ; of the users of this code yet care that it appears that the code
-    ; stops there.
-    res))
-
-(defun collect-branch-tree (instr dll hash)
-  (unless (eq instr dll)
-    (let ((tree (make-branch-tree :first-instruction instr))
-          (pred nil)
-          (next instr))
-      (setf (gethash (instruction-element-address instr) hash)
-            tree)
-      (loop
-        (when (eq next dll)
-          (setf (branch-tree-last-instruction tree) pred)
-          (return))
-        (multiple-value-bind (type target fall-through) (categorize-instruction next)
-          (case type
-            (:label
-             (when pred
-               (setf (branch-tree-last-instruction tree) pred
-                     (branch-tree-fall-through tree) (instruction-element-address next))
-               (return)))
-            ((:branch :catch :unwind-protect)
-             (setf (branch-tree-last-instruction tree) next
-                   (branch-tree-branch-target tree) target
-                   (branch-tree-fall-through tree) fall-through)
-             (return))))
-        (setq pred next
-              next (dll-node-succ next)))
-      tree)))
-
-;;; Returns 4 values:
-;;; 1) type: one of :regular, :label, :branch, :catch, :unwind-protect, :throw, :tsp-push, :tsp-pop
-;;; 2) branch target (or catch or unwind-protect cleanup)
-;;; 3) branch-fallthrough (or catch or unwind-protect body)
-;;; 4) Count for throw, tsp-push, tsp-pop
-#+ppc-target
-(defun categorize-instruction (instr)
-  (etypecase instr
-    (lap-label :label)
-    (lap-instruction
-     (let* ((opcode (lap-instruction-opcode instr))
-            (opcode-p (typep opcode 'opcode))
-            (name (if opcode-p (opcode-name opcode) opcode))
-            (pc (lap-instruction-address instr))
-            (operands (lap-instruction-parsed-operands instr)))
-       (cond ((equalp name "bla")
-              (let ((subprim (car operands)))
-                (case subprim
-                  (.SPmkunwind
-                   (values :unwind-protect (+ pc 4) (+ pc 8)))
-                  ((.SPmkcatch1v .SPmkcatchmv)
-                   (values :catch (+ pc 4) (+ pc 8)))
-                  (.SPthrow
-                   (values :branch nil nil))
-                  ((.SPnthrowvalues .SPnthrow1value)
-                   (let* ((prev-instr (require-type (lap-instruction-pred instr)
-                                                    'lap-instruction))
-                          (prev-name (opcode-name (lap-instruction-opcode prev-instr)))
-                          (prev-operands (lap-instruction-parsed-operands prev-instr)))
-                     ; Maybe we should recognize the other possible outputs of ppc2-lwi, but I
-                     ; can't imagine we'll ever see them
-                     (unless (and (equalp prev-name "li")
-                                  (equalp (car prev-operands) "imm0"))
-                       (error "Can't determine throw count for ~s" instr))
-                     (values :throw nil (+ pc 4) (ash (cadr prev-operands) (- target::fixnum-shift)))))
-                  ((.SPprogvsave
-                    .SPstack-rest-arg .SPreq-stack-rest-arg .SPstack-cons-rest-arg
-                    .SPmakestackblock .SPmakestackblock0 .SPmakestacklist .SPstkgvector
-                    .SPstkconslist .SPstkconslist-star
-                    .SPmkstackv .SPstack-misc-alloc .SPstack-misc-alloc-init
-                    .SPstkvcell0 .SPstkvcellvsp
-                    .SPsave-values)
-                   (values :tsp-push nil nil 1))
-                  (.SPrecover-values
-                   (values :tsp-pop nil nil 1))
-                  (t :regular))))
-             ((or (equalp name "lwz") (equalp name "addi"))
-              (if (equalp (car operands) "tsp")
-                (values :tsp-pop nil nil 1)
-                :regular))
-             ((equalp name "stwu")
-              (if (equalp (car operands) "tsp")
-                (values :tsp-push nil nil 1)
-                :regular))
-             ((member name '("ba" "blr" "bctr") :test 'equalp)
-              (values :branch nil nil))
-             ; It would probably be faster to determine the branch address by adding the PC and the offset.
-             ((equalp name "b")
-              (values :branch (branch-label-address instr (car (last operands))) nil))
-             ((and opcode-p (eql (opcode-majorop opcode) 16))
-              (values :branch (branch-label-address instr (car (last operands))) (+ pc 4)))
-             (t :regular))))))
-
-(defun branch-label-address (instr label-name &aux (next instr))
-  (loop
-    (setq next (dll-node-succ next))
-    (when (eq next instr)
-      (error "Couldn't find label ~s" label-name))
-    (when (and (typep next 'lap-label)
-               (eq (lap-label-name next) label-name))
-      (return (instruction-element-address next)))))
-
-(defun dll-pc->instr (dll pc)
-  (let ((next (dll-node-succ dll)))
-    (loop
-      (when (eq next dll)
-        (error "Couldn't find pc: ~s in ~s" pc dll))
-      (when (eql (instruction-element-address next) pc)
-        (return next))
-      (setq next (dll-node-succ next)))))
-
-)  ; end of #+ppc-target progn
-) ; end of another #+ppc-target progn
 #|
 (setq *save-local-symbols* t)

branches/event-ide/ccl/lib/backtrace.lisp

@@ -96 +96 @@
           (call 'funcall)
           (call `(function ,(concatenate 'string "#<" (%lfun-name-string lfun) ">")))))
-      (if (<= pc target::arg-check-trap-pc-limit)
+      (if (and pc (<= pc target::arg-check-trap-pc-limit))
         (append (call) (arg-check-call-arguments cfp lfun))
         (multiple-value-bind (req opt restp keys)
@@ -102 +102 @@
           (when (or (not (eql 0 req)) (not (eql 0 opt)) restp keys)
             (let* ((arglist (arglist-from-map lfun)))
-              (if (null arglist)
+              (if (or (null arglist) (null pc))
                 (call "???")
                 (progn

branches/event-ide/ccl/lib/foreign-types.lisp

@@ -1701 +1701 @@
       (canonicalize-foreign-type-ordinal '(:* (:struct :hostent)))
       (canonicalize-foreign-type-ordinal '(:array :int 2))
-      )))
+      (canonicalize-foreign-type-ordinal '(:array (:struct :pollfd) 1)))))
 
 (defun install-standard-foreign-types (ftd)

branches/event-ide/ccl/lib/macros.lisp

@@ -3513 +3513 @@
           (return ,res))))))
 
+(defmacro ignoring-eintr (&body body)
+  (let* ((res (gensym))
+         (eintr (symbol-value (read-from-string "#$EINTR"))))
+    `(loop
+      (let* ((,res ,@body))
+        (unless (eql ,res (- ,eintr))
+          (return ,res))))))
+
 (defmacro basic-stream-ioblock (s)
   `(or (basic-stream.state ,s)

branches/event-ide/ccl/library/darwinppc-syscalls.lisp

@@ -93 +93 @@
 (define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ftruncate 201 (:unsigned-fullword :unsigned-doubleword) :signed-fullword )
 
+(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::poll 230 ((:* (:struct :pollfd)) :int :int) :int)
+
 #+notdefinedyet
 (progn

branches/event-ide/ccl/library/x8664-freebsd-syscalls.lisp

@@ -156 +156 @@
 (define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::getcwd 326 (:address :unsigned-fullword) :signed-fullword )
 
-
+(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::poll 209 ((:* (:struct :pollfd)) :int :int) :int)
 
 #+notdefinedyet

branches/event-ide/ccl/library/x8664-linux-syscalls.lisp

@@ -34 +34 @@
 (define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64)  syscalls::fstat 5 (:unsigned-fullword :address) :signed-fullword )
 (define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64)  syscalls::lstat 6 (:address :address) :signed-fullword)
-
+(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::poll 7 ((:* (:struct :pollfd)) :int :int) :int)
 (define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64)  syscalls::lseek 8 (:int :off_t :int) :off_t )
 

branches/event-ide/ccl/lisp-kernel/x86-macros.s

@@ -65 +65 @@
         .macro zero_dnodes base,disp,nbytes
         .ifgt \nbytes
-        __(movapd %fpzero,\disp(\base))
+        movapd %fpzero,\disp(\base)
         zero_dnodes \base,"\disp+dnode_size","\nbytes-dnode_size"
         .endif