(:timeouts . 0))
(deftest mailbox.multiple-producers-multiple-consumers
- (test-mailbox-producers-consumers :n-senders 100
- :n-receivers 100
+ (test-mailbox-producers-consumers :n-senders 50
+ :n-receivers 50
:n-messages 1000)
- (:received . 100000)
+ (:received . 50000)
(:garbage . 0)
(:errors . 0)
(:timeouts . 0))
(deftest mailbox.interrupts-safety.1
(multiple-value-bind (received garbage errors timeouts)
(test-mailbox-producers-consumers
- :n-senders 100
- :n-receivers 100
+ :n-senders 50
+ :n-receivers 50
:n-messages 1000
:interruptor #'(lambda (threads &aux (n (length threads)))
;; 99 so even in the unlikely case that only
(defmethod compute-test ((x symbol) (y symbol))
'symbol)
-(test-util:with-test (:name :compute-test :fails-on :win32)
+(test-util:with-test (:name :compute-test
+ :fails-on (and :win32 (not :sb-thread)))
(compute-test 1 2)
;; Check that we actually interrupted something.
(dotimes (i n)
(push i y))
(mapc #'sb-thread:join-thread
- (loop repeat 1000
+ (loop repeat (ecase sb-vm:n-word-bits (32 100) (64 1000))
collect (sb-thread:make-thread
(lambda ()
(loop for z = (atomic-pop y)
(defun bug-308914-storage (x)
(the (simple-array flt (*)) (bug-308914-unknown x)))
-(with-test (:name :bug-308914-workaround :fails-on :win32)
+(with-test (:name :bug-308914-workaround)
;; This used to hang in ORDER-UVL-SETS.
(handler-case
(with-timeout 10
(declare (ignore x y k1))
t))))))
-(with-test (:name :bug-309448 :fails-on :win32)
+(with-test (:name :bug-309448)
;; Like all tests trying to verify that something doesn't blow up
;; compile-times this is bound to be a bit brittle, but at least
;; here we try to establish a decent baseline.
(flet ((time-it (lambda want)
(gc :full t) ; let's keep GCs coming from other code out...
(let* ((start (get-internal-run-time))
- (fun (compile nil lambda))
+ (fun (dotimes (internal-time-resolution-too-low-workaround
+ #+win32 10
+ #-win32 0
+ (compile nil lambda))
+ (compile nil lambda)))
(end (get-internal-run-time))
(got (funcall fun)))
(unless (eql want got)
;; stunted, ending at _sigtramp, when we add :TIMEOUT NIL to
;; the frame we expect. If we leave it out, the backtrace is
;; fine -- but the test fails. I can only boggle right now.
- :fails-on '(and :x86 :linux))
+ :fails-on '(or (and :x86 :linux)
+ (and :win32 :sb-thread)))
(let ((m (sb-thread:make-mutex))
(q (sb-thread:make-waitqueue)))
(assert (verify-backtrace
(recurse)))))
(assert (= exhaust-count recurse-count *count*))))
-(with-test (:name (:exhaust :binding-stack) :skipped-on :win32)
+(with-test (:name (:exhaust :binding-stack))
(let ((ok nil)
(symbols (loop repeat 1024 collect (gensym)))
(values (loop repeat 1024 collect nil)))
(assert ok))))
(with-test (:name (:exhaust :alien-stack)
- :skipped-on '(not :c-stack-is-control-stack)
- :fails-on :win32)
+ :skipped-on '(or (not :c-stack-is-control-stack)))
(let ((ok nil))
(labels ((exhaust-alien-stack (i)
(with-alien ((integer-array (array int 500)))
(write-byte #xe0 s)
(dotimes (i 40)
(write-sequence a s))))
-(with-test (:name (:character-decode-large :attempt-resync)
- :fails-on :win32)
+(with-test (:name (:character-decode-large :attempt-resync))
(with-open-file (s *test-path* :direction :input
:external-format :utf-8)
(let ((count 0))
(assert (= (sb-ext:generation-number-of-gcs-before-promotion i) 1))))
(defun stress-gc ()
- (let* ((x (make-array (truncate (* 0.2 (dynamic-space-size))
+ ;; Kludge or not? I don't know whether the smaller allocation size
+ ;; for sb-safepoint is a legitimate correction to the test case, or
+ ;; rather hides the actual bug this test is checking for... It's also
+ ;; not clear to me whether the issue is actually safepoint-specific.
+ ;; But the main problem safepoint-related bugs tend to introduce is a
+ ;; delay in the GC triggering -- and if bug-936304 fails, it also
+ ;; causes bug-981106 to fail, even though there is a full GC in
+ ;; between, which makes it seem unlikely to me that the problem is
+ ;; delay- (and hence safepoint-) related. --DFL
+ (let* ((x (make-array (truncate #-sb-safepoint (* 0.2 (dynamic-space-size))
+ #+sb-safepoint (* 0.1 (dynamic-space-size))
sb-vm:n-word-bytes))))
(elt x 0)))
(assert (not (special-operator-p 'declare)))
;;; WITH-TIMEOUT should accept more than one form in its body.
-(with-test (:name :with-timeout-forms :fails-on :win32)
+(with-test (:name :with-timeout-forms)
(handler-bind ((sb-ext:timeout #'continue))
(sb-ext:with-timeout 3
(sleep 2)
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
-#-sb-thread
+#+(or :win32 (not :sb-thread))
(sb-ext:exit :code 104)
(use-package :sb-alien)
;;; bug 350: bignum printing so memory-hungry that heap runs out
;;; -- just don't stall here forever on a slow box
-(with-test (:name bug-350 :fails-on :win32)
+(with-test (:name bug-350)
(handler-case
(with-timeout 10
(print (ash 1 1000000)))
#+#.(cl:if (cl:find-package "SB-POSIX") '(or) '(and))
(let ((asdf:*central-registry*
(cons "../contrib/systems/" asdf:*central-registry*)))
- (asdf:oos 'asdf:load-op 'sb-posix))
+ (handler-bind (#+win32 (warning #'muffle-warning))
+ (asdf:oos 'asdf:load-op 'sb-posix)))
(load "test-util.lisp")
(use-package :test-util)
-(with-test (:name (:async-unwind :specials) :fails-on :win32)
+(with-test (:name (:async-unwind :specials))
(let ((*x0* nil) (*x1* nil) (*x2* nil) (*x3* nil) (*x4* nil))
(declare (special *x0* *x1* *x2* *x3* *x4*))
(loop repeat 10 do
(require :sb-posix)
-(with-test (:name (:signal :errno) :fails-on :win32)
+(with-test (:name (:signal :errno)
+ ;; This test asserts that nanosleep behaves correctly
+ ;; for invalid values and sets EINVAL. Well, we have
+ ;; nanosleep on Windows, but it depends on the caller
+ ;; (namely SLEEP) to produce known-good arguments, and
+ ;; even if we wanted to check argument validity,
+ ;; integration with `errno' is not to be expected.
+ :skipped-on :win32)
(let* (saved-errno
(returning nil)
(timer (make-timer (lambda ()
(loop repeat 1000000000)
(assert (= saved-errno (sb-unix::get-errno)))))
-(with-test (:name :handle-interactive-interrupt :fails-on :win32)
+(with-test (:name :handle-interactive-interrupt
+ ;; It is desirable to support C-c on Windows, but SIGINT
+ ;; is not the mechanism to use on this platform.
+ :skipped-on :win32)
(assert (eq :condition
(handler-case
(sb-thread::kill-safely
(defun fact (n)
"A function that does work with the CPU."
(if (zerop n) 1 (* n (fact (1- n)))))
-(let ((work (lambda () (fact 15000))))
- (let ((zero (scaling-test work 0))
- (four (scaling-test work 4)))
- ;; a slightly weak assertion, but good enough for starters.
- (assert (< four (* 1.5 zero)))))
+
+(with-test (:name :lurking-threads)
+ (let ((work (lambda () (fact 15000))))
+ (let ((zero (scaling-test work 0))
+ (four (scaling-test work 4)))
+ ;; a slightly weak assertion, but good enough for starters.
+ (assert (< four (* 1.5 zero))))))
;;; For one of the interupt-thread tests, we want a foreign function
;;; that does not make syscalls
-(with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
- (format o "void loop_forever() { while(1) ; }~%"))
-(sb-ext:run-program "/bin/sh"
- '("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
- "-o" "threads-foreign.so" "threads-foreign.c")
- :environment (test-util::test-env))
-(sb-alien:load-shared-object (truename "threads-foreign.so"))
-(sb-alien:define-alien-routine loop-forever sb-alien:void)
-(delete-file "threads-foreign.c")
-
+#-win32
+(progn
+ (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
+ (format o "void loop_forever() { while(1) ; }~%"))
+ (sb-ext:run-program "/bin/sh"
+ '("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
+ "-o" "threads-foreign.so" "threads-foreign.c")
+ :environment (test-util::test-env))
+ (sb-alien:load-shared-object (truename "threads-foreign.so"))
+ (sb-alien:define-alien-routine loop-forever sb-alien:void)
+ (delete-file "threads-foreign.c"))
;;; elementary "can we get a lock and release it again"
(with-test (:name (:mutex :basics))
(let ((child (test-interrupt (lambda () (loop)))))
(terminate-thread child)))
-(with-test (:name (:interrupt-thread :interrupt-foreign-loop))
+(with-test (:name (:interrupt-thread :interrupt-foreign-loop)
+ ;; This feature is explicitly unsupported on Win32.
+ :skipped-on :win32)
(test-interrupt #'loop-forever :quit))
(with-test (:name (:interrupt-thread :interrupt-sleep))
(abort-thread)))))))
;; (nanosleep -1 0) does not fail on FreeBSD
-(with-test (:name (:exercising-concurrent-syscalls))
+(with-test (:name (:exercising-concurrent-syscalls) :fails-on :win32)
(let* (#-freebsd
(nanosleep-errno (progn
(sb-unix:nanosleep -1 0)
(format t "~&thread startup sigmask test done~%")
-(with-test (:name (:debugger-no-hang-on-session-lock-if-interrupted))
+(with-test (:name (:debugger-no-hang-on-session-lock-if-interrupted)
+ :fails-on :win32)
+ #+win32 (error "user would have to touch a key interactively to proceed")
(sb-debug::enable-debugger)
(let* ((main-thread *current-thread*)
(interruptor-thread
(list d1 d2 d3 i))))
(format t "parallel defclass test done~%")
-(with-test (:name (:deadlock-detection :interrupts))
+(with-test (:name (:deadlock-detection :interrupts) :fails-on :win32)
+ #+win32 ;be more explicit than just :skipped-on
+ (error "not attempting, because of deadlock error in background thread")
(let* ((m1 (sb-thread:make-mutex :name "M1"))
(m2 (sb-thread:make-mutex :name "M2"))
(t1-can-go (sb-thread:make-semaphore :name "T1 can go"))
(let ((x (cons :count 0))
(nthreads (ecase sb-vm:n-word-bits (32 100) (64 1000))))
(mapc #'sb-thread:join-thread
- (loop repeat 1000
+ (loop repeat nthreads
collect (sb-thread:make-thread
(lambda ()
- (loop repeat nthreads
+ (loop repeat 1000
do (atomic-update (cdr x) #'1+)
(sleep 0.00001))))))
(assert (equal x `(:count ,@(* 1000 nthreads))))))
;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
(with-test (:name without-interrupts+condition-wait
- :skipped-on '(not :sb-thread))
+ :skipped-on '(not :sb-thread)
+ :fails-on '(and :win32 :sb-futex))
(let* ((lock (make-mutex))
(queue (make-waitqueue))
(thread (make-thread (lambda ()
(loop repeat (random 128)
do (setf ** *)))))))
(write-string "; ")
- (dotimes (i 15000)
+ (dotimes (i #+win32 2000 #-win32 15000)
(when (zerop (mod i 200))
(write-char #\.)
(force-output))
(assert (and (null value)
error))))
-(with-test (:name (:wait-for :basics) :fails-on :win32)
+(with-test (:name (:wait-for :basics))
(assert (not (sb-ext:wait-for nil :timeout 0.1)))
(assert (eql 42 (sb-ext:wait-for 42)))
(let ((n 0))
(assert (eql 100 (sb-ext:wait-for (when (= 100 (incf n))
n))))))
-(with-test (:name (:wait-for :deadline) :fails-on :win32)
+(with-test (:name (:wait-for :deadline))
(assert (eq :ok
(sb-sys:with-deadline (:seconds 10)
(assert (not (sb-ext:wait-for nil :timeout 0.1)))
(error "oops"))
(sb-sys:deadline-timeout () :deadline)))))
-(with-test (:name (:condition-wait :timeout :one-thread) :fails-on :win32)
+(with-test (:name (:condition-wait :timeout :one-thread))
(let ((mutex (make-mutex))
(waitqueue (make-waitqueue)))
(assert (not (with-mutex (mutex)
(unless (eql 50 ok)
(error "Wanted 50, got ~S" ok)))))
-(with-test (:name (:wait-on-semaphore :timeout :one-thread) :fails-on :win32)
+(with-test (:name (:wait-on-semaphore :timeout :one-thread))
(let ((sem (make-semaphore))
(n 0))
(signal-semaphore sem 10)
(defun wait-for-threads (threads)
(loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
-(with-test (:name (:with-timeout :many-at-the-same-time) :skipped-on '(not :sb-thread))
+(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
#-sb-thread
(loop repeat 10 do (test))))
-(with-test (:name (:timer :threaded-stress) :skipped-on '(not :sb-thread))
+(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 ()
(signal 'restart-condition))
foo)
+#+win32
+(defun decline ()
+ ;; these tests currently fail no matter whether threads are enabled or
+ ;; not, but on threaded builds the failure mode is particularly
+ ;; unfortunate. As a workaround, opt out of running the test.
+ #+sb-thread
+ (error "this test fails with exception 0xc0000029 ~
+ (STATUS_INVALID_UNWIND_TARGET), from which we cannot currently ~
+ recover"))
+
(defun test-restart (name)
+ #+win32 (decline)
(setf *a* nil)
(let ((*foo* 'x))
(let ((*foo* 'y)
foo)
(defun test-return (name)
+ #+win32 (decline)
(setf *a* nil)
(let ((*foo* 'x))
(let ((*foo* 'y))
(setf *b* (multiple-value-list (b :*c* :good))))))
(defun test-locals (name)
+ #+win32 (decline)
(handler-bind ((in-a (lambda (c)
(declare (ignore c))
(return-from-frame `(flet a :in ,name) 'x 'y)))
(defparameter *anon-4* (make-anon-4))
(defun test-anon (fun var-name &optional in)
+ #+win32 (decline)
(handler-bind ((anon-condition (lambda (c)
(declare (ignore c))
(return-from-frame
(push :unwind-2 *unwind-state*)))
(defun test-unwind (fun wanted)
+ #+win32 (decline)
(handler-bind ((return-condition (lambda (c)
(declare (ignore c))
(return-from-frame fun
projects / sbcl.git / commitdiff