From f2847d6ed16e60390d000410d36ec7fb2570cdaf Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sun, 1 Jul 2007 12:35:30 +0000
Subject: [PATCH] 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.
---
 src/code/thread.lisp    | 11 ++++++-----
 tests/threads.pure.lisp | 52 +++++++++++++++++++++++++++++++++++++++++++++++++
 version.lisp-expr       |  2 +-
 3 files changed, 59 insertions(+), 6 deletions(-)
 create mode 100644 tests/threads.pure.lisp

diff --git a/src/code/thread.lisp b/src/code/thread.lisp
index 5571ef8a9..fcf433b39 100644
--- 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
index 000000000..f078b5b6d
--- /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 53ef74f29..8d02b1fda 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".)
-"1.0.7.4"
+"1.0.7.5"
-- 
2.11.4.GIT