1.0.7.5: allow WITH-INTERRUPTS inside "system locked" sections

 * Fixes bug reported by Kristoffer Kvello on sbcl-help. (Regression
   caused by WITHOUT-INTERRUPT change caused GET-FOREGROUND wait to
   become uninterruptible.)

 * Test-case for the above, and another to show that condition-wait
   should not be interruptible if there is a surrounding
   WITHOUT-INTERRUPTS -- which currently fails on SB-LUTEX builds.

diff --git a/src/code/thread.lisp b/src/code/thread.lisp
index 5571ef8..fcf433b 100644 (file)
--- a/src/code/thread.lisp
+++ b/src/code/thread.lisp
@@ -89,7 +89,7 @@ provided the default value is used for the mutex."
         (without-gcing
           (funcall function))
         (without-interrupts
-          (funcall function))))
+          (allow-with-interrupts (funcall function)))))
 
   (defun call-with-recursive-system-spinlock (function lock
                                               &optional without-gcing-p)
@@ -99,7 +99,7 @@ provided the default value is used for the mutex."
         (without-gcing
           (funcall function))
         (without-interrupts
-          (funcall function))))
+          (allow-with-interrupts (funcall function)))))
 
   (defun call-with-mutex (function mutex value waitp)
     (declare (ignore mutex value waitp)
@@ -136,9 +136,10 @@ provided the default value is used for the mutex."
           (without-gcing
             (%call-with-system-mutex))
           (without-interrupts
-            (%call-with-system-mutex)))))
+            (allow-with-interrupts (%call-with-system-mutex))))))
 
-  (defun call-with-recursive-system-spinlock (function lock &optional without-gcing-p)
+  (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)))
@@ -152,7 +153,7 @@ provided the default value is used for the mutex."
           (without-gcing
             (%call-with-system-spinlock))
           (without-interrupts
-            (%call-with-system-spinlock)))))
+            (allow-with-interrupts (%call-with-system-spinlock))))))
 
   (defun call-with-spinlock (function spinlock)
     (declare (function function))

diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp
new file mode 100644 (file)
index 0000000..f078b5b
--- /dev/null
+++ b/tests/threads.pure.lisp
@@ -0,0 +1,52 @@
+;;;; miscellaneous tests of thread stuff
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;
+;;;; This software is in the public domain and is provided with
+;;;; absoluely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package :cl-user)
+
+(defpackage :thread-test
+  (:use :cl :sb-thread))
+
+(in-package :thread-test)
+
+(use-package :test-util)
+
+;;; Terminating a thread that's waiting for the terminal.
+
+#+sb-thread
+(let ((thread (make-thread (lambda ()
+                             (sb-thread::get-foreground)))))
+  (sleep 1)
+  (assert (thread-alive-p thread))
+  (terminate-thread thread)
+  (sleep 1)
+  (assert (not (thread-alive-p thread))))
+
+;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
+
+#+sb-thread
+(with-test (:name without-interrupts+condition-wait
+            :fails-on :sb-lutex)
+  (let* ((lock (make-mutex))
+         (queue (make-waitqueue))
+         (thread (make-thread (lambda ()
+                                (sb-sys:without-interrupts
+                                  (with-mutex (lock)
+                                    (condition-wait queue lock)))))))
+    (sleep 1)
+    (assert (thread-alive-p thread))
+    (terminate-thread thread)
+    (sleep 1)
+    (assert (thread-alive-p thread))
+    (condition-notify queue)
+    (sleep 1)
+    (assert (not (thread-alive-p thread)))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 53ef74f..8d02b1f 100644 (file)
--- 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".)
-"1.0.7.4"
+"1.0.7.5"