0.8.12.6:

[sbcl.git] / src / code / target-thread.lisp

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 2390437..69860df 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -1,16 +1,27 @@
+;;;; support for threads in the target machine
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
 (in-package "SB!THREAD")
 
 ;;; FIXME it would be good to define what a thread id is or isn't (our
 ;;; current assumption is that it's a fixnum).  It so happens that on
 ;;; Linux it's a pid, but it might not be on posix thread implementations
 
-(sb!alien::define-alien-routine ("create_thread" %create-thread)
-     sb!alien:unsigned-long
-  (lisp-fun-address sb!alien:unsigned-long))
+(define-alien-routine ("create_thread" %create-thread)
+    unsigned-long
+  (lisp-fun-address unsigned-long))
 
-(sb!alien::define-alien-routine "signal_thread_to_dequeue"
-    sb!alien:unsigned-int
-  (thread-id sb!alien:unsigned-long))
+(define-alien-routine "signal_thread_to_dequeue"
+    unsigned-int
+  (thread-id unsigned-long))
 
 (defvar *session* nil)
 
@@ -155,16 +166,6 @@
   (setf (mutex-value lock) nil)
   (futex-wake (mutex-value-address lock) 1))
 
-
-(defmacro with-mutex ((mutex &key value (wait-p t))  &body body)
-  (with-unique-names (got)
-    `(let ((,got (get-mutex ,mutex ,value ,wait-p)))
-      (when ,got
-       (unwind-protect
-            (progn ,@body)
-         (release-mutex ,mutex))))))
-
-
 ;;;; condition variables
 
 (defun condition-wait (queue lock)
@@ -299,12 +300,15 @@ time we reacquire LOCK and return to the caller."
 ;;; 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))))
+  "Interrupt THREAD and make it run FUNCTION."
+  (let ((function (coerce function 'function)))
+    (sb!sys:with-pinned-objects (function)
+      (sb!unix::syscall* ("interrupt_thread"
+                         sb!alien:unsigned-long  sb!alien:unsigned-long)
+                        thread
+                        thread 
+                        (sb!kernel:get-lisp-obj-address 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"
@@ -383,33 +387,32 @@ thread is not the foreground thread"
 (defun debugger-wait-until-foreground-thread (stream)
   "Returns T if thread had been running in background, NIL if it was
 interactive."
+  (declare (ignore stream))
   (prog1
       (with-mutex ((session-lock *session*))
        (not (member (current-thread-id) 
                     (session-interactive-threads *session*))))
     (get-foreground)))
 
-(defun thread-repl-prompt-fun (out-stream)
-  (get-foreground)
-  (let ((stopped-threads (cdr (session-interactive-threads *session*))))
-    (when stopped-threads
-      (format out-stream "~{~&Thread ~A suspended~}~%" stopped-threads))
-    (sb!impl::repl-prompt-fun out-stream)))
 
 (defun get-foreground ()
-  (loop
-   (with-mutex ((session-lock *session*))
-     (let ((tid (current-thread-id))
-          (int-t (session-interactive-threads *session*)))
-       (when (eql (car int-t) tid)
-        (sb!sys:enable-interrupt sb!unix:sigint #'sb!unix::sigint-handler)
-        (return-from get-foreground t))
-       (unless (member tid int-t)
-        (setf (cdr (last int-t))
-              (list tid)))
-       (condition-wait
-       (session-interactive-threads-queue *session*)
-       (session-lock *session*))))))
+  (let ((was-foreground t))
+    (loop
+     (with-mutex ((session-lock *session*))
+       (let ((tid (current-thread-id))
+            (int-t (session-interactive-threads *session*)))
+        (when (eql (car int-t) tid)
+          (unless was-foreground
+            (format *query-io* "Resuming thread ~A~%" tid))
+          (sb!sys:enable-interrupt sb!unix:sigint #'sb!unix::sigint-handler)
+          (return-from get-foreground t))
+        (setf was-foreground nil)
+        (unless (member tid int-t)
+          (setf (cdr (last int-t))
+                (list tid)))
+        (condition-wait
+         (session-interactive-threads-queue *session*)
+         (session-lock *session*)))))))
 
 (defun release-foreground (&optional next)
   "Background this thread.  If NEXT is supplied, arrange for it to have the foreground next"