[slime-cvs] CVS slime
dcrosher
dcrosher at common-lisp.net
Thu Apr 13 04:26:32 UTC 2006
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv7256
Modified Files:
ChangeLog swank-scl.lisp
Log Message:
* Update the Scieneer CL backend.
--- /project/slime/cvsroot/slime/ChangeLog 2006/04/12 08:43:55 1.880
+++ /project/slime/cvsroot/slime/ChangeLog 2006/04/13 04:26:31 1.881
@@ -1,3 +1,20 @@
+2006-04-13 Douglas Crosher <dcrosher at common-lisp.net>
+
+ * swank-scl (make-socket-io-stream): set the stream to ignore
+ character conversion errors, and to substitute the character #\?.
+ Without this the communication channel is prone to lockup when a
+ conversion error occurs.
+
+ * swank-scl (inspect-for-emacs function): correct the index into the
+ closure environment; it was reading off the end of the closure
+ environment and picking up a corrupting value.
+
+ * swank-scl (mailbox): rework the mailbox implementation to better
+ handle interruption. Use a polling loop rather than condition
+ variables because interrupting a condition variable wait leaves the
+ thread with the condition variable lock held and leads to a deadlock
+ error.
+
2006-04-12 Robert Macomber <slime at rojoma.com>
* swank-backend.lisp (make-recursive-lock): New interface
function.
--- /project/slime/cvsroot/slime/swank-scl.lisp 2006/03/22 16:40:01 1.6
+++ /project/slime/cvsroot/slime/swank-scl.lisp 2006/04/13 04:26:31 1.7
@@ -12,26 +12,10 @@
;;; swank-mop
-(import-swank-mop-symbols :clos '(:slot-definition-documentation
- :eql-specializer
- :eql-specializer-object))
+(import-swank-mop-symbols :clos '(:slot-definition-documentation))
(defun swank-mop:slot-definition-documentation (slot)
- (slot-value slot 'documentation))
-
-(defun swank-mop:specializer-direct-methods (obj)
- (declare (ignore obj))
- nil)
-
-(deftype swank-mop:eql-specializer ()
- '(or kernel:member-type kernel:numeric-type))
-
-(defun swank-mop:eql-specializer-object (obj)
- (etypecase obj
- (kernel:numeric-type
- (kernel:type-specifier obj))
- (kernel:member-type
- (first (kernel:member-type-members obj)))))
+ (documentation slot t))
;;;; TCP server
@@ -94,10 +78,15 @@
(defun make-socket-io-stream (fd external-format buffering)
"Create a new input/output fd-stream for 'fd."
- (let ((external-format (find-external-format external-format)))
- (sys:make-fd-stream fd :input t :output t :element-type 'base-char
- :buffering buffering
- :external-format external-format)))
+ (let* ((external-format (find-external-format external-format))
+ (stream (sys:make-fd-stream fd :input t :output t
+ :element-type 'base-char
+ :buffering buffering
+ :external-format external-format)))
+ ;; Ignore character conversion errors. Without this the communication
+ ;; channel is prone to lockup if a character conversion error occurs.
+ (setf (cl::stream-character-conversion-error-value stream) #\?)
+ stream))
;;;; Stream handling
@@ -1762,23 +1751,6 @@
(t
(scl-inspect o))))
-(defimplementation inspect-for-emacs ((o standard-object)
- (inspector scl-inspector))
- (declare (ignore inspector))
- (let ((c (class-of o)))
- (values "An object."
- `("Class: " (:value ,c) (:newline)
- "Slots:" (:newline)
- ,@(loop for slotd in (clos:class-slots c)
- for name = (clos:slot-definition-name slotd)
- collect `(:value ,slotd ,(string name))
- collect " = "
- collect (if (clos:slot-boundp-using-class c o name)
- `(:value ,(clos:slot-value-using-class
- c o name))
- "#<unbound>")
- collect '(:newline))))))
-
(defun scl-inspect (o)
(destructuring-bind (text labeledp . parts)
(inspect::describe-parts o)
@@ -1809,7 +1781,8 @@
(append
(label-value-line "Function" (kernel:%closure-function o))
`("Environment:" (:newline))
- (loop for i from 0 below (1- (kernel:get-closure-length o))
+ (loop for i from 0 below (- (kernel:get-closure-length o)
+ (1- vm:closure-info-offset))
append (label-value-line
i (kernel:%closure-index-ref o i))))))
((eval::interpreted-function-p o)
@@ -1999,9 +1972,9 @@
(defvar *mailbox-lock* (thread:make-lock "Mailbox lock"))
(defstruct (mailbox)
- (lock (thread:make-lock "Thread mailbox" :type :error-check)
+ (lock (thread:make-lock "Thread mailbox" :type :error-check
+ :interruptible nil)
:type thread:error-check-lock)
- (cond-var (thread:make-cond-var "Thread mailbox") :type thread:cond-var)
(queue '() :type list))
(defun mailbox (thread)
@@ -2012,22 +1985,31 @@
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
- (lock (mailbox-lock mbox))
- (cond-var (mailbox-cond-var mbox)))
- (thread:with-lock-held (lock "Mailbox Send")
- (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox) (list message)))
- (thread:cond-var-broadcast cond-var))
+ (lock (mailbox-lock mbox)))
+ (sys:without-interrupts
+ (thread:with-lock-held (lock "Mailbox Send")
+ (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
+ (list message)))))
+ (mp:process-wakeup thread)
message))
(defimplementation receive ()
(let* ((mbox (mailbox thread:*thread*))
- (lock (mailbox-lock mbox))
- (cond-var (mailbox-cond-var mbox)))
- (thread:with-lock-held (lock "Mailbox Receive")
- (loop
- (when (mailbox-queue mbox)
- (return (pop (mailbox-queue mbox))))
- (thread:cond-var-timedwait cond-var lock 10 "Mailbox receive wait")))))
+ (lock (mailbox-lock mbox)))
+ (loop
+ (mp:process-wait-with-timeout "Mailbox read wait" 1
+ #'(lambda () (mailbox-queue mbox)))
+ (multiple-value-bind (message winp)
+ (sys:without-interrupts
+ (mp:with-lock-held (lock "Mailbox read")
+ (let ((queue (mailbox-queue mbox)))
+ (cond (queue
+ (setf (mailbox-queue mbox) (cdr queue))
+ (values (car queue) t))
+ (t
+ (values nil nil))))))
+ (when winp
+ (return message))))))
More information about the slime-cvs
mailing list