X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=ec06a870ca3df381d17ba265ed8e0f0aae83cd97;hb=dbfe7e6c8b06e1b0b1ba35d9894fae13e6305602;hp=176336ee0118fd80c9daa05a9cae98f0beb9dab7;hpb=be76f6319dcb41477209676e6f26e0030e4659ba;p=sbcl.git

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 176336e..ec06a87 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -63,7 +63,7 @@
 	(eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
 
 (defmacro with-spinlock ((queue) &body body)
-  (let ((pid (gensym "PID")))
+  (with-unique-names (pid)
     `(unwind-protect
       (let ((,pid (current-thread-id)))
 	(get-spinlock ,queue 2 ,pid)
@@ -89,25 +89,29 @@
     ;; the sigcont?  For that matter, can we get interrupted?
     (block-sigcont)
     (when lock (release-mutex lock))
-    (get-spinlock queue 2 pid)
-    (pushnew pid (waitqueue-data queue))
-    (setf (waitqueue-lock queue) 0)
+    (sb!sys:without-interrupts
+     (get-spinlock queue 2 pid)
+     (pushnew pid (waitqueue-data queue))
+     (setf (waitqueue-lock queue) 0))
     (unblock-sigcont-and-sleep)))
 
 (defun dequeue (queue)
   (let ((pid (current-thread-id)))
-    (get-spinlock queue 2 pid)
-    (setf (waitqueue-data queue)
-	  (delete pid (waitqueue-data queue)))
-    (setf (waitqueue-lock queue) 0)))
+    (sb!sys:without-interrupts
+     (get-spinlock queue 2 pid)
+     (setf (waitqueue-data queue)
+	   (delete pid (waitqueue-data queue)))
+     (setf (waitqueue-lock queue) 0))))
 
 (defun signal-queue-head (queue)
-  (let ((pid (current-thread-id)))
-    (get-spinlock queue 2 pid)
-    (let ((h (car (waitqueue-data queue))))
-      (setf (waitqueue-lock queue) 0)
-      (when h
-	(sb!unix:unix-kill h :sigcont)))))
+  (let ((pid (current-thread-id))
+	h)
+    (sb!sys:without-interrupts
+     (get-spinlock queue 2 pid)
+     (setf h (car (waitqueue-data queue)))
+     (setf (waitqueue-lock queue) 0))
+    (when h
+      (sb!unix:unix-kill h :sigcont))))
 
 ;;;; mutex
 
@@ -127,25 +131,18 @@
 
 (defun release-mutex (lock &optional (new-value nil))
   (declare (type mutex lock))
-  (let ((old-value (mutex-value lock))
-	(t1 nil))
-    (loop
-     (unless
-	 ;; args are object slot-num old-value new-value
-	 (eql old-value
-	      (setf t1
-		    (sb!vm::%instance-set-conditional lock 4 old-value new-value)))       
-       (signal-queue-head lock)
-       (return t))
-     (setf old-value t1))))
+  ;; we assume the lock is ours to release
+  (setf (mutex-value lock) new-value)
+  (signal-queue-head lock))
+
 
 (defmacro with-mutex ((mutex &key value (wait-p t))  &body body)
-  (let ((block (gensym "NIL")))
-    `(unwind-protect
-      (block ,block
-	(unless (get-mutex ,mutex ,value ,wait-p) (return-from ,block nil))
-	,@body)
-      (release-mutex ,mutex))))
+  (with-unique-names (got)
+    `(let ((,got (get-mutex ,mutex ,value ,wait-p)))
+      (when ,got
+	(unwind-protect
+	     (progn ,@body)
+	  (release-mutex ,mutex))))))
 
 
 ;;;; condition variables
@@ -203,7 +200,7 @@ time we reacquire LOCK and return to the caller."
 ;;;; job control
 
 (defvar *background-threads-wait-for-debugger* t)
-;;; may be T, NIL, or a function called with an fd-stream and thread id 
+;;; may be T, NIL, or a function called with a stream and thread id 
 ;;; as its two arguments, returning NIl or T
 
 ;;; called from top of invoke-debugger
@@ -213,12 +210,11 @@ already the foreground thread, or transfers control to the first applicable
 restart if *BACKGROUND-THREADS-WAIT-FOR-DEBUGGER* says to do that instead"
   (let* ((wait-p *background-threads-wait-for-debugger*)
 	 (*background-threads-wait-for-debugger* nil)
-	 (fd-stream (sb!impl::get-underlying-stream stream :input))
 	 (lock *session-lock*))
     (when (not (eql (mutex-value lock)   (CURRENT-THREAD-ID)))
       (when (functionp wait-p) 
 	(setf wait-p 
-	      (funcall wait-p fd-stream (CURRENT-THREAD-ID))))
+	      (funcall wait-p stream (CURRENT-THREAD-ID))))
       (cond (wait-p (get-foreground))
 	    (t  (invoke-restart (car (compute-restarts))))))))