0.8.5.37.resistance-is-futex.3

Cosmetic cleanup: rename handle_rt_signal to interrupt_thread_handler
	- a bit more descriptive

	< and <= are not the same thing.  Re-enable threaded running
	on linux 2.4

	Added condition-broadcast for non-futex locking

	Rewrote the session locking stuff to work in a futex-threaded
	environment (we can't peek into the queues if they're in kernel
	space): also extended release-foreground with an optional
	argument to specify which thread should go next - wil be useful
	for :focus commands and similar

src/code/cross-thread.lisp

@@ -5,3 +5,5 @@
 (defmacro with-recursive-lock ((mutex) &body body)
   `(progn ,@body))
 
+
+

src/code/target-thread.lisp

@@ -297,14 +297,17 @@ time we reacquire LOCK and return to the caller."
     (setf (waitqueue-data queue) me)
     (futex-wake (waitqueue-data-address queue) 1)))
 
-;; FIXME need non-futex variant of this too
 #!+sb-futex
-(defun condition-broadcast (queue)
-  "Notify all of the processes waiting on QUEUE."
+(defun condition-broadcast/futex (queue)
   (let ((me (current-thread-id)))
     (setf (waitqueue-data queue) me)
     (futex-wake (waitqueue-data-address queue) (ash 1 30))))
 
+(defun condition-broadcast (queue)
+  "Notify all of the processes waiting on QUEUE."
+  (with-spinlock (queue)
+    (map nil #'signal-thread-to-dequeue (waitqueue-data queue))))
+
 ;;; Futexes may be available at compile time but not runtime, so we
 ;;; default to not using them unless os_init says they're available
 (defun maybe-install-futex-functions ()
@@ -313,6 +316,7 @@ time we reacquire LOCK and return to the caller."
     (setf (fdefinition 'get-mutex) #'get-mutex/futex
 	  (fdefinition 'release-mutex) #'release-mutex/futex
 	  (fdefinition 'condition-wait) #'condition-wait/futex
+	  (fdefinition 'condition-broadcast) #'condition-broadcast/futex
 	  (fdefinition 'condition-notify) #'condition-notify/futex)
     t))
 
@@ -350,22 +354,52 @@ time we reacquire LOCK and return to the caller."
   
 ;;;; job control
 
+
+(defvar *interactive-threads-lock* 
+  (make-mutex :name "*interactive-threads* lock"))
+(defvar *interactive-threads* nil)
+(defvar *interactive-threads-queue*
+  (make-waitqueue :name "All threads that need the terminal.  First ID on this list is running, the others are waiting"))
+
+(defun init-job-control ()
+  (with-mutex (*interactive-threads-lock*)
+    (setf *interactive-threads* (list (current-thread-id)))
+    (return-from init-job-control t)))
+
 ;;; called from top of invoke-debugger
 (defun debugger-wait-until-foreground-thread (stream)
   "Returns T if thread had been running in background, NIL if it was
-already the foreground thread."
-  (let ((lock *session-lock*))
-    (when (not (eql (mutex-value lock)   (CURRENT-THREAD-ID)))
-      (get-foreground))))
+interactive."
+  (prog1
+      (with-mutex (*interactive-threads-lock*)
+	(not (member (current-thread-id) *interactive-threads*)))
+    (get-foreground)))
 
-;;; note that this is broken in a futex world as no way to find out
-;;; which threads are on a kernel queue
 (defun thread-repl-prompt-fun (out-stream)
-  (let ((lock *session-lock*))
-    (get-foreground)
-    (let ((stopped-threads (waitqueue-data lock)))
-      (when stopped-threads
-	(format out-stream "~{~&Thread ~A suspended~}~%" stopped-threads))
-      (sb!impl::repl-prompt-fun out-stream))))
+  (get-foreground)
+  (let ((stopped-threads (cdr *interactive-threads*)))
+    (when stopped-threads
+      (format out-stream "~{~&Thread ~A suspended~}~%" stopped-threads))
+    (sb!impl::repl-prompt-fun out-stream)))
 
+(defun get-foreground ()
+  (loop
+   (with-mutex (*interactive-threads-lock*)
+     (let ((tid (current-thread-id)))
+       (when (eql (car *interactive-threads*) tid)
+	 (sb!sys:enable-interrupt sb!unix:sigint #'sb!unix::sigint-handler)
+	 (return-from get-foreground t))
+       (unless (member tid *interactive-threads*)
+	 (setf (cdr (last *interactive-threads*)) (list tid)))
+       (condition-wait
+	*interactive-threads-queue* *interactive-threads-lock* )))))
 
+(defun release-foreground (&optional next)
+  "Background this thread.  If NEXT is supplied, arrange for it to have the foreground next"
+  (with-mutex (*interactive-threads-lock*)
+    (let ((tid (current-thread-id)))
+      (setf *interactive-threads* (delete tid *interactive-threads*))
+      (sb!sys:enable-interrupt sb!unix:sigint :ignore)
+      (when next (setf *interactive-threads*
+		       (list* next (delete next *interactive-threads*))))
+      (condition-broadcast *interactive-threads-queue*))))

src/code/target-unithread.lisp

@@ -122,10 +122,9 @@ time we reacquire LOCK and return to the caller."
   (signal-queue-head queue))
 
 
-;;;; multiple independent listeners
-
-(defvar *session-lock* nil)
-
 ;;;; job control
 
 (defun debugger-wait-until-foreground-thread (stream) t)
+(defun get-foreground () t)
+(defun release-foreground (&optional next) t)
+

src/code/thread.lisp

@@ -1,7 +1,5 @@
 (in-package "SB!THREAD")
 
-(defvar *session-lock*)
-
 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
   #!+sb-thread
   (with-unique-names (cfp)
@@ -28,19 +26,3 @@
   #!-sb-thread
   `(progn ,@body))
 
-#!+sb-thread
-(defun get-foreground ()
-  (when (not (eql (mutex-value *session-lock*) (current-thread-id)))
-    (get-mutex *session-lock*))
-  (sb!sys:enable-interrupt sb!unix:sigint #'sb!unix::sigint-handler)
-  t)
-#!-sb-thread
-(defun get-foreground () t)
-
-#!+sb-thread
-(defun release-foreground ()
-  (sb!sys:enable-interrupt sb!unix:sigint :ignore)
-  (release-mutex *session-lock*)
-  t)
-#!-sb-thread
-(defun release-foreground () t)

src/code/toplevel.lisp

@@ -296,7 +296,7 @@
 (defun toplevel-init ()
 
   (/show0 "entering TOPLEVEL-INIT")
-  (setf sb!thread::*session-lock* (sb!thread:make-mutex :name "the terminal"))
+  (sb!thread::init-job-control)
   (sb!thread::get-foreground)
   (let (;; value of --sysinit option
 	(sysinit nil)
@@ -478,23 +478,6 @@
       ;; (classic CMU CL error message: "You're certainly a clever child.":-)
       (critically-unreachable "after TOPLEVEL-REPL"))))
 
-;;; hooks to support customized toplevels like ACL-style toplevel from
-;;; KMR on sbcl-devel 2002-12-21.  Altered by CSR 2003-11-16 for
-;;; threaded operation: altered *REPL-FUN* to *REPL-FUN-GENERATOR*.
-(defvar *repl-read-form-fun* #'repl-read-form-fun
-  "a function of two stream arguments IN and OUT for the toplevel REPL to
-  call: Return the next Lisp form to evaluate (possibly handling other
-  magic -- like ACL-style keyword commands -- which precede the next
-  Lisp form). The OUT stream is there to support magic which requires
-  issuing new prompts.")
-(defvar *repl-prompt-fun* #'repl-prompt-fun
-  "a function of one argument STREAM for the toplevel REPL to call: Prompt
-  the user for input.")
-(defvar *repl-fun-generator* (constantly #'repl-fun)
-  "a function of no arguments returning a function of one argument
-  NOPRINT that provides the REPL for the system.  Assumes that
-  *STANDARD-INPUT* and *STANDARD-OUTPUT* are set up.")
-
 ;;; read-eval-print loop for the default system toplevel
 (defun toplevel-repl (noprint)
   (/show0 "entering TOPLEVEL-REPL")
@@ -502,41 +485,34 @@
 	(- nil)
 	(+ nil) (++ nil) (+++ nil)
 	(/// nil) (// nil) (/ nil))
-    (/show0 "about to funcall *REPL-FUN-GENERATOR*")
-    (let ((repl-fun (funcall *repl-fun-generator*)))
-      ;; Each REPL in a multithreaded world should have bindings of
-      ;; most CL specials (most critically *PACKAGE*).
-      (with-rebound-io-syntax
-	;; WITH-SIMPLE-RESTART doesn't actually restart its body as
-	;; some (like WHN for an embarrassingly long time
-	;; ca. 2001-12-07) might think, but instead drops control back
-	;; out at the end. So when a TOPLEVEL or outermost-ABORT
-	;; restart happens, we need this outer LOOP wrapper to grab
-	;; control and start over again. (And it also wraps CATCH
-	;; 'TOPLEVEL-CATCHER for similar reasons.)
-	(loop
-	 (/show0 "about to set up restarts in TOPLEVEL-REPL")
-	 ;; There should only be one TOPLEVEL restart, and it's here,
-	 ;; so restarting at TOPLEVEL always bounces you all the way
-	 ;; out here.
-	 (with-simple-restart (toplevel
-			       "Restart at toplevel READ/EVAL/PRINT loop.")
-	   ;; We add a new ABORT restart for every debugger level, so
-	   ;; restarting at ABORT in a nested debugger gets you out to
-	   ;; the innermost enclosing debugger, and only when you're
-	   ;; in the outermost, unnested debugger level does
-	   ;; restarting at ABORT get you out to here.
-	   (with-simple-restart
-	       (abort
-		"~@<Reduce debugger level (leaving debugger, returning to toplevel).~@:>")
-	     (catch 'toplevel-catcher
-	       (sb!unix::reset-signal-mask)
-	       ;; in the event of a control-stack-exhausted-error, we
-	       ;; should have unwound enough stack by the time we get
-	       ;; here that this is now possible
-	       (sb!kernel::protect-control-stack-guard-page 1)
-	       (funcall repl-fun noprint)
-	       (critically-unreachable "after REPL")))))))))
+    ;; WITH-SIMPLE-RESTART doesn't actually restart its body as some
+    ;; (like WHN for an embarrassingly long time ca. 2001-12-07) might
+    ;; think, but instead drops control back out at the end. So when a
+    ;; TOPLEVEL or outermost-ABORT restart happens, we need this outer
+    ;; LOOP wrapper to grab control and start over again. (And it also
+    ;; wraps CATCH 'TOPLEVEL-CATCHER for similar reasons.)
+    (loop
+     (/show0 "about to set up restarts in TOPLEVEL-REPL")
+     ;; There should only be one TOPLEVEL restart, and it's here, so
+     ;; restarting at TOPLEVEL always bounces you all the way out here.
+     (with-simple-restart (toplevel
+			   "Restart at toplevel READ/EVAL/PRINT loop.")
+       ;; We add a new ABORT restart for every debugger level, so 
+       ;; restarting at ABORT in a nested debugger gets you out to the
+       ;; innermost enclosing debugger, and only when you're in the
+       ;; outermost, unnested debugger level does restarting at ABORT 
+       ;; get you out to here.
+       (with-simple-restart
+	   (abort
+	    "~@<Reduce debugger level (leaving debugger, returning to toplevel).~@:>")
+	 (catch 'toplevel-catcher
+	   (sb!unix::reset-signal-mask)
+	   ;; in the event of a control-stack-exhausted-error, we should
+	   ;; have unwound enough stack by the time we get here that this
+	   ;; is now possible
+	   (sb!kernel::protect-control-stack-guard-page 1)
+	   (funcall *repl-fun* noprint)
+	   (critically-unreachable "after REPL")))))))
 
 ;;; Our default REPL prompt is the minimal traditional one.
 (defun repl-prompt-fun (stream)
@@ -553,6 +529,21 @@
 	(quit)
 	form)))
 
+;;; hooks to support customized toplevels like ACL-style toplevel
+;;; from KMR on sbcl-devel 2002-12-21
+(defvar *repl-read-form-fun* #'repl-read-form-fun
+  "a function of two stream arguments IN and OUT for the toplevel REPL to
+  call: Return the next Lisp form to evaluate (possibly handling other
+  magic -- like ACL-style keyword commands -- which precede the next
+  Lisp form). The OUT stream is there to support magic which requires
+  issuing new prompts.")
+(defvar *repl-prompt-fun* #'repl-prompt-fun
+  "a function of one argument STREAM for the toplevel REPL to call: Prompt
+  the user for input.")
+(defvar *repl-fun* #'repl-fun
+  "a function of one argument NOPRINT that provides the REPL for the system.
+  Assumes that *standard-input* and *standard-output* are setup.")
+
 (defun repl-fun (noprint)
   (/show0 "entering REPL")
   (loop

src/runtime/interrupt.c

@@ -655,13 +655,13 @@ void arrange_return_to_lisp_function(os_context_t *context, lispobj function)
 }
 
 #ifdef LISP_FEATURE_SB_THREAD
-void handle_rt_signal(int num, siginfo_t *info, void *v_context)
+void interrupt_thread_handler(int num, siginfo_t *info, void *v_context)
 {
     os_context_t *context = (os_context_t*)arch_os_get_context(&v_context);
     struct thread *th=arch_os_get_current_thread();
     struct interrupt_data *data=
 	th ? th->interrupt_data : global_interrupt_data;
-    if(maybe_defer_handler(handle_rt_signal,data,num,info,context)){
+    if(maybe_defer_handler(interrupt_thread_handler,data,num,info,context)){
 	return ;
     }
     arrange_return_to_lisp_function(context,info->si_value.sival_int);

src/runtime/interrupt.h

@@ -51,7 +51,7 @@ extern void interrupt_internal_error(int, siginfo_t*, os_context_t*,
 extern boolean handle_control_stack_guard_triggered(os_context_t *,void *);
 extern boolean interrupt_maybe_gc(int, siginfo_t*, void*);
 #ifdef LISP_FEATURE_SB_THREAD
-extern void handle_rt_signal(int, siginfo_t*, void*);
+extern void interrupt_thread_handler(int, siginfo_t*, void*);
 extern void sig_stop_for_gc_handler(int, siginfo_t*, void*);
 #endif
 extern void undoably_install_low_level_interrupt_handler (int signal,

src/runtime/linux-os.c

@@ -91,7 +91,7 @@ void os_init(void)
 	lose("linux kernel version too old: major version=%d (can't run in version < 2.0.0)",
 	     major_version);
     }
-    if (!(major_version>2 || minor_version > 4)) {
+    if (!(major_version>2 || minor_version >= 4)) {
 #ifdef LISP_FEATURE_SB_THREAD
 	lose("linux kernel 2.4 required for thread-enabled SBCL");
 #endif
@@ -277,7 +277,7 @@ os_install_interrupt_handlers(void)
 						 sigsegv_handler);
 #ifdef LISP_FEATURE_SB_THREAD
     undoably_install_low_level_interrupt_handler(SIG_INTERRUPT_THREAD,
-						 handle_rt_signal);
+						 interrupt_thread_handler);
     undoably_install_low_level_interrupt_handler(SIG_STOP_FOR_GC,
 						 sig_stop_for_gc_handler);
     if(!linux_supports_futex)

version.lisp-expr

@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.5.37.resistance-is-futex.2"
+"0.8.5.37.resistance-is-futex.3"