From 068cf4b55af3f8f8acf2c7c06869441612261cd4 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 12 Mar 2008 18:32:45 +0000 Subject: [PATCH] 1.0.15.20: refactor "system locks" framework, one TIMER buglet * Choose the degree of GC/interrupt suppression at compile-time. * Default is not to allow interrupts at all, callers which need WITH-INTERRUPTS to work can now specify :ALLOW-WITH-INTERRUPTS. * Should fix reported Stumpwm crashes due to attempts to recursively obtain *SCHEDULER-LOCK*. (Caused by SIGALRM interrupting GET-MUTEX inside the call to %TIMER-CANCEL-FUNCTION, which led to recursive entry to WITH-SCHEDULER-LOCK.) * Don't reschedule timers for dead threads. * Three new test-cases for timers, which (1) represent my failing attempts to trigger the Stumpwm bug described above (2) led to noticing the rescheduling promblem (3) fail horribly on OS X Tiger -- not sure if this is our or Darwin's problem... --- src/code/fd-stream.lisp | 4 +- src/code/final.lisp | 5 +- src/code/run-program.lisp | 3 +- src/code/target-thread.lisp | 22 ++++-- src/code/thread.lisp | 175 ++++++++++++++++++++++--------------------- src/code/timer.lisp | 16 ++-- 6 files changed, 124 insertions(+), 101 deletions(-) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index f6eb756..853c3cd 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -70,8 +70,8 @@ ;; ;; ...again, once we have smarted locks the spinlock here can become ;; a mutex. - `(sb!thread::call-with-system-spinlock (lambda () ,@body) - *available-buffers-spinlock*)) + `(sb!thread::with-system-spinlock (*available-buffers-spinlock*) + ,@body)) (defconstant +bytes-per-buffer+ (* 4 1024) #!+sb-doc diff --git a/src/code/final.lisp b/src/code/final.lisp index c2ef070..8b21939 100644 --- a/src/code/final.lisp +++ b/src/code/final.lisp @@ -17,9 +17,8 @@ (sb!thread:make-mutex :name "Finalizer store lock.")) (defmacro with-finalizer-store-lock (&body body) - `(sb!thread::call-with-system-mutex (lambda () ,@body) - *finalizer-store-lock* - t)) + `(sb!thread::with-system-mutex (*finalizer-store-lock* :without-gcing t) + ,@body)) (defun finalize (object function &key dont-save) #!+sb-doc diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 9a59ddb..d223e77 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -154,7 +154,8 @@ ;;; accesses it, that's why we need without-interrupts. (defmacro with-active-processes-lock (() &body body) #-win32 - `(sb-thread::call-with-system-mutex (lambda () ,@body) *active-processes-lock*) + `(sb-thread::with-system-mutex (*active-processes-lock* :allow-with-interrupts t) + ,@body) #+win32 `(progn ,@body)) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index c99c30b..e2a6cfc 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -60,7 +60,8 @@ in future versions." (defvar *all-threads-lock* (make-mutex :name "all threads lock")) (defmacro with-all-threads-lock (&body body) - `(call-with-system-mutex (lambda () ,@body) *all-threads-lock*)) + `(with-system-mutex (*all-threads-lock*) + ,@body)) (defun list-all-threads () #!+sb-doc @@ -500,11 +501,21 @@ on this semaphore, then N of them is woken up." (defvar *session* nil) -;;; the debugger itself tries to acquire the session lock, don't let +;;; The debugger itself tries to acquire the session lock, don't let ;;; funny situations (like getting a sigint while holding the session -;;; lock) occur +;;; lock) occur. At the same time we need to allow interrupts while +;;; *waiting* for the session lock for things like GET-FOREGROUND +;;; to be interruptible. +;;; +;;; Take care: we sometimes need to obtain the session lock while holding +;;; on to *ALL-THREADS-LOCK*, so we must _never_ obtain it _after_ getting +;;; a session lock! (Deadlock risk.) +;;; +;;; FIXME: It would be good to have ordered locks to ensure invariants like +;;; the above. (defmacro with-session-lock ((session) &body body) - `(call-with-system-mutex (lambda () ,@body) (session-lock ,session))) + `(with-system-mutex ((session-lock ,session) :allow-with-interrupts t) + ,@body)) (defun new-session () (make-session :threads (list *current-thread*) @@ -778,7 +789,8 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." "The thread that was not interrupted.") (defmacro with-interruptions-lock ((thread) &body body) - `(call-with-system-mutex (lambda () ,@body) (thread-interruptions-lock ,thread))) + `(with-system-mutex ((thread-interruptions-lock ,thread)) + ,@body)) ;; Called from the signal handler in C. (defun run-interruption () diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 1d751ac..6e6ebec 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -58,12 +58,22 @@ and the mutex is in use, sleep until it is available" ,value ,wait-p))) -(sb!xc:defmacro with-system-mutex ((mutex &key without-gcing) &body body) +(sb!xc:defmacro with-system-mutex ((mutex &key without-gcing allow-with-interrupts) &body body) `(dx-flet ((with-system-mutex-thunk () ,@body)) - (call-with-system-mutex - #'with-system-mutex-thunk - ,mutex - ,without-gcing))) + (,(cond (without-gcing + 'call-with-system-mutex/without-gcing) + (allow-with-interrupts + 'call-with-system-mutex/allow-with-interrupts) + (t + 'call-with-system-mutex)) + #'with-system-mutex-thunk + ,mutex))) + +(sb!xc:defmacro with-system-spinlock ((spinlock &key) &body body) + `(dx-flet ((with-system-spinlock-thunk () ,@body)) + (call-with-system-spinlock + #'with-system-spinlock-thunk + ,spinlock))) (sb!xc:defmacro with-recursive-lock ((mutex) &body body) #!+sb-doc @@ -82,13 +92,16 @@ provided the default value is used for the mutex." #'with-recursive-spinlock-thunk ,spinlock))) -(sb!xc:defmacro with-recursive-system-spinlock ((spinlock &key without-gcing) +(sb!xc:defmacro with-recursive-system-spinlock ((spinlock + &key without-gcing) &body body) `(dx-flet ((with-recursive-system-spinlock-thunk () ,@body)) - (call-with-recursive-system-spinlock - #'with-recursive-system-spinlock-thunk - ,spinlock - ,without-gcing))) + (,(cond (without-gcing + 'call-with-recursive-system-spinlock/without-gcing) + (t + 'call-with-recursive-system-spinlock)) + #'with-recursive-system-spinlock-thunk + ,spinlock))) (sb!xc:defmacro with-spinlock ((spinlock) &body body) `(dx-flet ((with-spinlock-thunk () ,@body)) @@ -102,33 +115,22 @@ provided the default value is used for the mutex." ;;; using them. #!-sb-thread (progn - (defun call-with-system-mutex (function mutex &optional without-gcing-p) - (declare (ignore mutex) - (function function)) - (if without-gcing-p - (without-gcing - (funcall function)) - (without-interrupts - (allow-with-interrupts (funcall function))))) - - (defun call-with-system-spinlock (function spinlock &optional without-gcing-p) - (declare (ignore spinlock) - (function function)) - (if without-gcing-p - (without-gcing - (funcall function)) - (without-interrupts - (allow-with-interrupts (funcall function))))) - - (defun call-with-recursive-system-spinlock (function lock - &optional without-gcing-p) - (declare (ignore lock) - (function function)) - (if without-gcing-p - (without-gcing - (funcall function)) - (without-interrupts - (allow-with-interrupts (funcall function))))) + (macrolet ((def (name &optional variant) + `(defun ,(if variant (symbolicate name "/" variant) name) (function lock) + (declare (ignore lock) (function function)) + ,(ecase variant + (:without-gcing + `(without-gcing (funcall function))) + (:allow-with-interrupts + `(without-interrupts (allow-with-interrupts (funcall function)))) + ((nil) + `(without-interrupts (funcall function))))))) + (def call-with-system-mutex) + (def call-with-system-mutex :without-gcing) + (def call-with-system-mutex :allow-with-interrupts) + (def call-with-system-spinlock) + (def call-with-recursive-system-spinlock) + (def call-with-recursive-system-spinlock :without-gcing)) (defun call-with-mutex (function mutex value waitp) (declare (ignore mutex value waitp) @@ -149,55 +151,60 @@ provided the default value is used for the mutex." #!+sb-thread ;;; KLUDGE: These need to use DX-LET, because the cleanup form that -;;; closes over GOT-IT causes a value-cell to be allocated for it -- and -;;; we prefer that to go on the stack since it can. +;;; closes over GOT-IT causes a value-cell to be allocated for it -- +;;; and we prefer that to go on the stack since it can. (progn - (defun call-with-system-mutex (function mutex &optional without-gcing-p) - (declare (function function)) - (flet ((%call-with-system-mutex () - (dx-let (got-it) - (unwind-protect - (when (setf got-it (get-mutex mutex)) - (funcall function)) - (when got-it - (release-mutex mutex)))))) - (if without-gcing-p - (without-gcing - (%call-with-system-mutex)) - (without-interrupts - (allow-with-interrupts (%call-with-system-mutex)))))) - - (defun call-with-system-spinlock (function spinlock &optional without-gcing-p) + (macrolet ((def (name &optional variant) + `(defun ,(if variant (symbolicate name "/" variant) name) (function mutex) + (declare (function function)) + (flet ((%call-with-system-mutex () + (dx-let (got-it) + (unwind-protect + (when (setf got-it (get-mutex mutex)) + (funcall function)) + (when got-it + (release-mutex mutex)))))) + (declare (inline %call-with-system-mutex)) + ,(ecase variant + (:without-gcing + `(without-gcing (%call-with-system-mutex))) + (:allow-with-interrupts + `(without-interrupts (allow-with-interrupts (%call-with-system-mutex)))) + ((nil) + `(without-interrupts (%call-with-system-mutex)))))))) + (def call-with-system-mutex) + (def call-with-system-mutex :without-gcing) + (def call-with-system-mutex :allow-with-interrupts)) + + (defun call-with-system-spinlock (function spinlock) (declare (function function)) - (flet ((%call-with-system-spinlock () - (dx-let (got-it) - (unwind-protect - (when (setf got-it (get-spinlock spinlock)) - (funcall function)) - (when got-it - (release-spinlock spinlock)))))) - (if without-gcing-p - (without-gcing - (%call-with-system-spinlock)) - (without-interrupts - (allow-with-interrupts (%call-with-system-spinlock)))))) - - (defun call-with-recursive-system-spinlock (function lock - &optional without-gcing-p) - (declare (function function)) - (flet ((%call-with-system-spinlock () - (dx-let ((inner-lock-p (eq *current-thread* (spinlock-value lock))) - (got-it nil)) - (unwind-protect - (when (or inner-lock-p (setf got-it (get-spinlock lock))) - (funcall function)) - (when got-it - (release-spinlock lock)))))) - (if without-gcing-p - (without-gcing - (%call-with-system-spinlock)) - (without-interrupts - (allow-with-interrupts (%call-with-system-spinlock)))))) + (without-interrupts + (dx-let (got-it) + (unwind-protect + (when (setf got-it (get-spinlock spinlock)) + (funcall function)) + (when got-it + (release-spinlock spinlock)))))) + + (macrolet ((def (name &optional variant) + `(defun ,(if variant (symbolicate name "/" variant) name) (function spinlock) + (declare (function function)) + (flet ((%call-with-system-spinlock () + (dx-let ((inner-lock-p (eq *current-thread* (spinlock-value spinlock))) + (got-it nil)) + (unwind-protect + (when (or inner-lock-p (setf got-it (get-spinlock spinlock))) + (funcall function)) + (when got-it + (release-spinlock spinlock)))))) + (declare (inline %call-with-system-spinlock)) + ,(ecase variant + (:without-gcing + `(without-gcing (%call-with-system-spinlock))) + ((nil) + `(without-interrupts (%call-with-system-spinlock)))))))) + (def call-with-recursive-system-spinlock) + (def call-with-recursive-system-spinlock :without-gcing)) (defun call-with-spinlock (function spinlock) (declare (function function)) diff --git a/src/code/timer.lisp b/src/code/timer.lisp index b644f71..36235ac 100644 --- a/src/code/timer.lisp +++ b/src/code/timer.lisp @@ -200,8 +200,9 @@ from now. For timers with a repeat interval it returns true." (defvar *scheduler-lock* (sb!thread:make-mutex :name "Scheduler lock")) (defmacro with-scheduler-lock ((&optional) &body body) - ;; don't let the SIGALRM handler mess things up - `(sb!thread::call-with-system-mutex (lambda () ,@body) *scheduler-lock*)) + ;; Don't let the SIGALRM handler mess things up. + `(sb!thread::with-system-mutex (*scheduler-lock*) + ,@body)) (defun under-scheduler-lock-p () #!-sb-thread @@ -292,10 +293,13 @@ triggers." ;;; Not public, but related (defun reschedule-timer (timer) - (with-scheduler-lock () - (setf (%timer-expire-time timer) (+ (get-internal-real-time) - (%timer-repeat-interval timer))) - (%schedule-timer timer))) + (let ((thread (%timer-thread timer))) + (if (and (sb!thread::thread-p thread) (not (sb!thread:thread-alive-p thread))) + (unschedule-timer timer) + (with-scheduler-lock () + (setf (%timer-expire-time timer) (+ (get-internal-real-time) + (%timer-repeat-interval timer))) + (%schedule-timer timer))))) ;;; Expiring timers -- 1.7.10.4