time)
(loop until finishedp)))
-#-win32
-(with-test (:name (:timer :deferrables-blocked))
+(with-test (:name (:timer :deferrables-blocked) :skipped-on :win32)
(make-and-schedule-and-wait (lambda ()
(check-deferrables-blocked-or-lose 0))
(random 0.1))
(check-deferrables-unblocked-or-lose 0))
-#-win32
-(with-test (:name (:timer :deferrables-unblocked))
+(with-test (:name (:timer :deferrables-unblocked) :skipped-on :win32)
(make-and-schedule-and-wait (lambda ()
(sb-sys:with-interrupts
(check-deferrables-unblocked-or-lose 0)))
(random 0.1))
(check-deferrables-unblocked-or-lose 0))
-#-win32
-(with-test (:name (:timer :deferrables-unblocked :unwind))
+(with-test (:name (:timer :deferrables-unblocked :unwind) :skipped-on :win32)
(catch 'xxx
(make-and-schedule-and-wait (lambda ()
(check-deferrables-blocked-or-lose 0)
`(handler-case (progn (progn ,@body) nil)
(sb-ext:timeout () t)))
-#-win32
(with-test (:name (:timer :relative)
- :fails-on '(and :sparc :linux))
+ :fails-on '(and :sparc :linux)
+ :skipped-on :win32)
(let* ((has-run-p nil)
(timer (make-timer (lambda () (setq has-run-p t))
:name "simple timer")))
(assert has-run-p)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-#-win32
(with-test (:name (:timer :absolute)
- :fails-on '(and :sparc :linux))
+ :fails-on '(and :sparc :linux)
+ :skipped-on :win32)
(let* ((has-run-p nil)
(timer (make-timer (lambda () (setq has-run-p t))
:name "simple timer")))
(assert has-run-p)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-#+sb-thread
-(with-test (:name (:timer :other-thread))
- (let* ((thread (sb-thread:make-thread (lambda () (sleep 2))))
+(with-test (:name (:timer :other-thread) :skipped-on '(not :sb-thread))
+ (let* ((thread (make-kill-thread (lambda () (sleep 2))))
(timer (make-timer (lambda ()
(assert (eq thread sb-thread:*current-thread*)))
:thread thread)))
(schedule-timer timer 0.1)))
-#+sb-thread
-(with-test (:name (:timer :new-thread))
+(with-test (:name (:timer :new-thread) :skipped-on '(not :sb-thread))
(let* ((original-thread sb-thread:*current-thread*)
(timer (make-timer
(lambda ()
:thread t)))
(schedule-timer timer 0.1)))
-#-win32
(with-test (:name (:timer :repeat-and-unschedule)
- :fails-on '(and :sparc :linux))
+ :fails-on '(and :sparc :linux)
+ :skipped-on :win32)
(let* ((run-count 0)
timer)
(setq timer
(assert (not (timer-scheduled-p timer)))
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-#-win32
-(with-test (:name (:timer :reschedule))
+(with-test (:name (:timer :reschedule) :skipped-on :win32)
(let* ((has-run-p nil)
(timer (make-timer (lambda ()
(setq has-run-p t)))))
(assert has-run-p)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-#-win32
-(with-test (:name (:timer :stress))
+(with-test (:name (:timer :stress) :skipped-on :win32)
(let ((time (1+ (get-universal-time))))
(loop repeat 200 do
(schedule-timer (make-timer (lambda ())) time :absolute-p t))
(sleep 2)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-#-win32
-(with-test (:name (:timer :stress2))
+(with-test (:name (:timer :stress2) :skipped-on :win32)
(let ((time (1+ (get-universal-time)))
(n 0))
(loop for time-n from time upto (+ 1/10 time) by (/ 1/10 200)
(sleep 2)
(assert (zerop (length (sb-impl::%pqueue-contents sb-impl::*schedule*))))))
-#-win32
-(with-test (:name (:with-timeout :timeout))
+(with-test (:name (:with-timeout :timeout) :skipped-on :win32)
(assert (raises-timeout-p
(sb-ext:with-timeout 0.2
(sleep 1)))))
-#-win32
-(with-test (:name (:with-timeout :fall-through))
+(with-test (:name (:with-timeout :fall-through) :skipped-on :win32)
(assert (not (raises-timeout-p
(sb-ext:with-timeout 0.3
(sleep 0.1))))))
-#-win32
-(with-test (:name (:with-timeout :nested-timeout-smaller))
+(with-test (:name (:with-timeout :nested-timeout-smaller) :skipped-on :win32)
(assert(raises-timeout-p
(sb-ext:with-timeout 10
(sb-ext:with-timeout 0.5
(sleep 2))))))
-#-win32
-(with-test (:name (:with-timeout :nested-timeout-bigger))
+(with-test (:name (:with-timeout :nested-timeout-bigger) :skipped-on :win32)
(assert(raises-timeout-p
(sb-ext:with-timeout 0.5
(sb-ext:with-timeout 2
(defun wait-for-threads (threads)
(loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
-#+sb-thread
-(with-test (:name (:with-timeout :many-at-the-same-time))
+(with-test (:name (:with-timeout :many-at-the-same-time)
+ :skipped-on '(not :sb-thread))
(let ((ok t))
(let ((threads (loop repeat 10 collect
(sb-thread:make-thread
(wait-for-threads threads)))))
(assert ok))))
-#+sb-thread
-(with-test (:name (:with-timeout :dead-thread))
- (sb-thread:make-thread
+(with-test (:name (:with-timeout :dead-thread) :skipped-on '(not :sb-thread))
+ (make-join-thread
(lambda ()
(let ((timer (make-timer (lambda ()))))
(schedule-timer timer 3)
;;; FIXME: Since timeouts do not work on Windows this would loop
;;; forever.
-#-win32
-(with-test (:name (:hash-cache :interrupt))
+(with-test (:name (:hash-cache :interrupt) :skipped-on :win32)
(let* ((type1 (random-type 500))
(type2 (random-type 500))
(wanted (subtypep type1 type2)))
;;; Used to hang occasionally at least on x86. Two bugs caused it:
;;; running out of stack (due to repeating timers being rescheduled
;;; before they ran) and dying threads were open interrupts.
-#+sb-thread
-(with-test (:name (:timer :parallel-unschedule) :fails-on :ppc)
- #+darwin
- (error "Prone to hang on Darwin due to interrupt issues.")
- #+ppc
- (error "Prone to hang the host on linux/ppc for unknown reasons.")
+(with-test (:name (:timer :parallel-unschedule)
+ :skipped-on '(not :sb-thread)
+ :broken-on ':ppc)
(let ((timer (sb-ext:make-timer (lambda () 42) :name "parallel schedulers"))
(other nil))
(flet ((flop ()
(sleep (random 0.01))
(loop repeat 10000
do (sb-ext:unschedule-timer timer))))
- (loop repeat 5
- do (mapcar #'sb-thread:join-thread
- (loop for i from 1 upto 10
- collect (let* ((thread (sb-thread:make-thread #'flop
- :name (format nil "scheduler ~A" i)))
- (ticker (make-limited-timer (lambda () 13)
- 1000
- :thread (or other thread)
- :name (format nil "ticker ~A" i))))
- (setf other thread)
- (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
- thread)))))))
+ (sb-sys:with-deadline (:seconds 30)
+ (loop repeat 5
+ do (mapcar #'sb-thread:join-thread
+ (loop for i from 1 upto 10
+ collect (let* ((thread (sb-thread:make-thread #'flop
+ :name (format nil "scheduler ~A" i)))
+ (ticker (make-limited-timer (lambda () 13)
+ 1000
+ :thread (or other thread)
+ :name (format nil "ticker ~A" i))))
+ (setf other thread)
+ (sb-ext:schedule-timer ticker 0 :repeat-interval 0.00001)
+ thread))))))))
;;;; FIXME: OS X 10.4 doesn't like these being at all, and gives us a SIGSEGV
;;;; instead of using the Mach expection system! 10.5 on the other tends to
;;;;
;;;; Used to have problems in genereal, see comment on (:TIMER
;;;; :PARALLEL-UNSCHEDULE).
-#-win32
-(with-test (:name (:timer :schedule-stress))
+(with-test (:name (:timer :schedule-stress) :skipped-on :win32)
(flet ((test ()
(let* ((slow-timers
(loop for i from 1 upto 1
#-sb-thread
(loop repeat 10 do (test))))
-#+sb-thread
-(with-test (:name (:timer :threaded-stress))
+(with-test (:name (:timer :threaded-stress)
+ :skipped-on '(not :sb-thread)
+ :fails-on :win32)
+ #+win32
+ (error "fixme")
(let ((barrier (sb-thread:make-semaphore))
(goal 100))
(flet ((wait-for-goal ()
(dolist (thread threads)
(sched thread)))
(mapcar #'sb-thread:join-thread threads)))))
+
+;; SB-THREAD:MAKE-THREAD used to lock SB-THREAD:*MAKE-THREAD-LOCK*
+;; before entering WITHOUT-INTERRUPTS. When a thread which was
+;; executing SB-THREAD:MAKE-THREAD was interrupted with code which
+;; also called SB-THREAD:MAKE-THREAD, it could happen that the first
+;; thread already owned SB-THREAD:*MAKE-THREAD-LOCK* and the
+;; interrupting code thus made a recursive lock attempt. A timer with
+;; :THREAD T or :THREAD <some thread spawning child threads> could
+;; also trigger this problem.
+;;
+;; See (MAKE-THREAD :INTERRUPT-WITH MAKE-THREAD :BUG-1180102) in
+;; threads.pure.lisp.
+(with-test (:name (:timer :dispatch-thread :make-thread :bug-1180102)
+ :skipped-on '(not :sb-thread))
+ (flet ((test (thread)
+ (let ((timer (make-timer (lambda ()) :thread thread)))
+ (schedule-timer timer .01 :repeat-interval 0.1)
+ (dotimes (i 100)
+ (let ((threads '()))
+ (dotimes (i 100)
+ (push (sb-thread:make-thread (lambda () (sleep .01)))
+ threads))
+ (mapc #'sb-thread:join-thread threads)))
+ (unschedule-timer timer))))
+ (test t)
+ (test sb-thread:*current-thread*)))
projects / sbcl.git / blobdiff