Update tests for threaded windows builds

As with previous changes to the test keywords, some tests are marked
as expected failures or skipped, but merely to keep test suite
output clean; these failures are not expected to be permament and
shall be improved upon later.

contrib/sb-concurrency/tests/test-mailbox.lisp

@@ -195,19 +195,19 @@
   (: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

tests/clos-interrupts.impure.lisp

@@ -77,7 +77,8 @@
 (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.

tests/compare-and-swap.impure.lisp

@@ -436,7 +436,7 @@
       (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)

tests/compiler.impure.lisp

@@ -1190,7 +1190,7 @@
 (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

tests/compiler.pure.lisp

@@ -3710,14 +3710,18 @@
                             (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)

tests/debug.impure.lisp

@@ -177,7 +177,8 @@
                   ;; 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

tests/exhaust.impure.lisp

@@ -83,7 +83,7 @@
              (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)))
@@ -98,8 +98,7 @@
       (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)))

tests/external-format.impure.lisp

@@ -124,8 +124,7 @@
     (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))

tests/gc.impure.lisp

@@ -65,7 +65,17 @@
         (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)))
 

tests/interface.pure.lisp

@@ -61,7 +61,7 @@
 (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)

tests/kill-non-lisp-thread.impure.lisp

@@ -11,7 +11,7 @@
 ;;;; 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)

tests/print.impure.lisp

@@ -268,7 +268,7 @@
 
 ;;; 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)))

tests/run-tests.lisp

@@ -4,7 +4,8 @@
 #+#.(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")
 

tests/signals.impure.lisp

@@ -13,7 +13,7 @@
 
 (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
@@ -38,7 +38,14 @@
 
 (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 ()
@@ -57,7 +64,10 @@
     (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

tests/threads.impure.lisp

@@ -195,25 +195,28 @@
 (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))
@@ -551,7 +554,9 @@
   (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))
@@ -753,7 +758,7 @@
               (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)
@@ -789,7 +794,9 @@
 
 (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
@@ -1405,7 +1412,9 @@
           (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"))

tests/threads.pure.lisp

@@ -25,10 +25,10 @@
   (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))))))
@@ -56,7 +56,8 @@
 ;;; 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 ()
@@ -208,7 +209,7 @@
                                         (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))
@@ -413,14 +414,14 @@
     (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)))
@@ -432,7 +433,7 @@
                     (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)
@@ -465,7 +466,7 @@
       (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)

tests/timer.impure.lisp

@@ -196,7 +196,8 @@
 (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
@@ -297,7 +298,11 @@
   #-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 ()