X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=9893bd887da23ae62c11c3b452e3592a5ec1f9fa;hb=174feb792c8082846666e1218c58d5b0ab3b85b0;hp=0a9ab3bd72acde05ba436f7807dc8f48514bbef5;hpb=c2e825e81b3ed9355f7f3e3607cbc0274daaee84;p=sbcl.git

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 0a9ab3b..9893bd8 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -27,18 +27,39 @@
 	       (funcall real-function))
 	     0))))))))
 
+;;; Conventional wisdom says that it's a bad idea to use these unless
+;;; you really need to.  Use a lock or a waitqueue instead
+(defun suspend-thread (thread-id)
+  (sb!unix:unix-kill thread-id :sigstop))
+(defun resume-thread (thread-id)
+  (sb!unix:unix-kill thread-id :sigcont))
+;;; Note warning about cleanup forms
 (defun destroy-thread (thread-id)
+  "Destroy the thread identified by THREAD-ID abruptly, without running cleanup forms"
   (sb!unix:unix-kill thread-id :sigterm)
   ;; may have been stopped for some reason, so now wake it up to
   ;; deliver the TERM
   (sb!unix:unix-kill thread-id :sigcont))
 
-;; Conventional wisdom says that it's a bad idea to use these unless
-;; you really need to.  Use a lock or a waitqueue instead
-(defun suspend-thread (thread-id)
-  (sb!unix:unix-kill thread-id :sigstop))
-(defun resume-thread (thread-id)
-  (sb!unix:unix-kill thread-id :sigcont))
+
+;;; a moderate degree of care is expected for use of interrupt-thread,
+;;; due to its nature: if you interrupt a thread that was holding
+;;; important locks then do something that turns out to need those
+;;; locks, you probably won't like the effect.  Used with thought
+;;; though, it's a good deal gentler than the last-resort functions above
+
+(defun interrupt-thread (thread function)
+  "Interrupt THREAD and make it run FUNCTION.  "
+  (sb!unix::syscall* ("interrupt_thread"
+		      sb!alien:unsigned-long  sb!alien:unsigned-long)
+		     thread
+		     thread (sb!kernel:get-lisp-obj-address
+			     (coerce function 'function))))
+(defun terminate-thread (thread-id)
+  "Terminate the thread identified by THREAD-ID, by causing it to run
+SB-EXT:QUIT - the usual cleanup forms will be evaluated"
+  (interrupt-thread thread-id 'sb!ext:quit))
+
 
 (defun current-thread-id ()
   (sb!sys:sap-int
@@ -63,7 +84,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)
@@ -83,31 +104,32 @@
 (sb!alien:define-alien-routine "block_sigcont"  void)
 (sb!alien:define-alien-routine "unblock_sigcont_and_sleep"  void)
 
+;;; this should only be called while holding the queue spinlock.
+;;; it releases the spinlock before sleeping
 (defun wait-on-queue (queue &optional lock)
   (let ((pid (current-thread-id)))
     ;; FIXME what should happen if we get interrupted when we've blocked
     ;; 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))
+    (sb!sys:without-interrupts
+     (pushnew pid (waitqueue-data queue)))
     (setf (waitqueue-lock queue) 0)
     (unblock-sigcont-and-sleep)))
 
+;;; this should only be called while holding the queue spinlock.  It doesn't
+;;; release it
 (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     
+     (setf (waitqueue-data queue)
+	   (delete pid (waitqueue-data queue))))))
 
+;;; this should probably only be called while holding the queue spinlock.
+;;; not sure
 (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 ((p (car (waitqueue-data queue))))
+    (when p (sb!unix:unix-kill p  :sigcont))))
 
 ;;;; mutex
 
@@ -116,36 +138,34 @@
   (let ((pid (current-thread-id)))
     (unless new-value (setf new-value pid))
     (assert (not (eql new-value (mutex-value lock))))
+    (get-spinlock lock 2 pid)
     (loop
      (unless
 	 ;; args are object slot-num old-value new-value
 	 (sb!vm::%instance-set-conditional lock 4 nil new-value)
        (dequeue lock)
+       (setf (waitqueue-lock lock) 0)
        (return t))
-     (unless wait-p (return nil))
+     (unless wait-p
+       (setf (waitqueue-lock lock) 0)
+       (return nil))
      (wait-on-queue lock nil))))
 
 (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
+  (with-spinlock (lock)
+    (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
@@ -154,18 +174,23 @@
   "Atomically release LOCK and enqueue ourselves on QUEUE.  Another
 thread may subsequently notify us using CONDITION-NOTIFY, at which
 time we reacquire LOCK and return to the caller."
-  (unwind-protect
-       (wait-on-queue queue lock)
-    ;; If we are interrupted while waiting, we should do these things
-    ;; before returning.  Ideally, in the case of an unhandled signal,
-    ;; we should do them before entering the debugger, but this is
-    ;; better than nothing.
-    (dequeue queue)
-    (get-mutex lock)))
+  (assert lock)
+  (let ((value (mutex-value lock)))
+    (unwind-protect
+	 (progn
+	   (get-spinlock queue 2 (current-thread-id))
+	   (wait-on-queue queue lock))
+      ;; If we are interrupted while waiting, we should do these things
+      ;; before returning.  Ideally, in the case of an unhandled signal,
+      ;; we should do them before entering the debugger, but this is
+      ;; better than nothing.
+      (with-spinlock (queue)
+	(dequeue queue))
+      (get-mutex lock value))))
 
 (defun condition-notify (queue)
   "Notify one of the processes waiting on QUEUE"
-  (signal-queue-head queue))
+  (with-spinlock (queue) (signal-queue-head queue)))
 
 
 ;;;; multiple independent listeners
@@ -221,7 +246,8 @@ restart if *BACKGROUND-THREADS-WAIT-FOR-DEBUGGER* says to do that instead"
       (cond (wait-p (get-foreground))
 	    (t  (invoke-restart (car (compute-restarts))))))))
 
-;;; install this with (setf SB!INT:*REPL-PROMPT-FUN* #'thread-prompt-fun)
+;;; install this with
+;;; (setf SB-INT:*REPL-PROMPT-FUN* #'sb-thread::thread-repl-prompt-fun)
 ;;; One day it will be default
 (defun thread-repl-prompt-fun (out-stream)
   (let ((lock *session-lock*))