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...

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index f6eb756..853c3cd 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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