diff --git a/src/code/cross-thread.lisp b/src/code/cross-thread.lisp index eafb3fb71..eb71d1f82 100644 --- a/src/code/cross-thread.lisp +++ b/src/code/cross-thread.lisp @@ -5,3 +5,5 @@ (defmacro with-recursive-lock ((mutex) &body body) `(progn ,@body)) + + diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 8983094fa..9b69d9111 100644 --- a/src/code/target-thread.lisp +++ b/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*)))) \ No newline at end of file diff --git a/src/code/target-unithread.lisp b/src/code/target-unithread.lisp index 33f4b68ce..fde8f13d2 100644 --- a/src/code/target-unithread.lisp +++ b/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) + diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 50be15f2b..e1e0417fd 100644 --- a/src/code/thread.lisp +++ b/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) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 5aadeec0d..a8f278b3a 100644 --- a/src/code/toplevel.lisp +++ b/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 - "~@") - (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 + "~@") + (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 diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 1c9a1b520..d7f4a4201 100644 --- a/src/runtime/interrupt.c +++ b/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); diff --git a/src/runtime/interrupt.h b/src/runtime/interrupt.h index 35e221d3b..11eca74cd 100644 --- a/src/runtime/interrupt.h +++ b/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, diff --git a/src/runtime/linux-os.c b/src/runtime/linux-os.c index bf3982319..03d950f30 100644 --- a/src/runtime/linux-os.c +++ b/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) diff --git a/version.lisp-expr b/version.lisp-expr index d96cdd736..93f90cdf1 100644 --- a/version.lisp-expr +++ b/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"