(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)
(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)
(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)))
(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))
--- /dev/null
+;;;; 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)))))