From 3cd0a9aafc20ce12075f38ebaed86676c922fde2 Mon Sep 17 00:00:00 2001
From: David Lichteblau <david@lichteblau.com>
Date: Tue, 18 Sep 2012 17:12:13 +0200
Subject: [PATCH] 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 |   10 ++---
 tests/clos-interrupts.impure.lisp              |    3 +-
 tests/compare-and-swap.impure.lisp             |    2 +-
 tests/compiler.impure.lisp                     |    2 +-
 tests/compiler.pure.lisp                       |    8 +++-
 tests/debug.impure.lisp                        |    3 +-
 tests/exhaust.impure.lisp                      |    5 +--
 tests/external-format.impure.lisp              |    3 +-
 tests/gc.impure.lisp                           |   12 +++++-
 tests/interface.pure.lisp                      |    2 +-
 tests/kill-non-lisp-thread.impure.lisp         |    2 +-
 tests/print.impure.lisp                        |    2 +-
 tests/run-tests.lisp                           |    3 +-
 tests/signals.impure.lisp                      |   16 ++++++--
 tests/threads.impure.lisp                      |   47 ++++++++++++++----------
 tests/threads.pure.lisp                        |   17 +++++----
 tests/timer.impure.lisp                        |    9 ++++-
 tests/unwind-to-frame-and-call.impure.lisp     |   15 ++++++++
 18 files changed, 108 insertions(+), 53 deletions(-)

diff --git a/contrib/sb-concurrency/tests/test-mailbox.lisp b/contrib/sb-concurrency/tests/test-mailbox.lisp
index 88d3975..d38459b 100644
--- a/contrib/sb-concurrency/tests/test-mailbox.lisp
+++ b/contrib/sb-concurrency/tests/test-mailbox.lisp
@@ -195,10 +195,10 @@
   (: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))
@@ -206,8 +206,8 @@
 (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
diff --git a/tests/clos-interrupts.impure.lisp b/tests/clos-interrupts.impure.lisp
index e3a100e..8d7ec67 100644
--- a/tests/clos-interrupts.impure.lisp
+++ b/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.
diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp
index 1bbecf9..e1dc09b 100644
--- a/tests/compare-and-swap.impure.lisp
+++ b/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)
diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 01270c6..43e3bee 100644
--- a/tests/compiler.impure.lisp
+++ b/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
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 3003a2f..b28fe61 100644
--- a/tests/compiler.pure.lisp
+++ b/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)
diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 65683d4..e64e664 100644
--- a/tests/debug.impure.lisp
+++ b/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
diff --git a/tests/exhaust.impure.lisp b/tests/exhaust.impure.lisp
index 085036d..6233f11 100644
--- a/tests/exhaust.impure.lisp
+++ b/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)))
diff --git a/tests/external-format.impure.lisp b/tests/external-format.impure.lisp
index 4af0da3..6c33f4f 100644
--- a/tests/external-format.impure.lisp
+++ b/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))
diff --git a/tests/gc.impure.lisp b/tests/gc.impure.lisp
index ef4313a..1c3d9f9 100644
--- a/tests/gc.impure.lisp
+++ b/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)))
 
diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp
index 5957ce0..1e76ccd 100644
--- a/tests/interface.pure.lisp
+++ b/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)
diff --git a/tests/kill-non-lisp-thread.impure.lisp b/tests/kill-non-lisp-thread.impure.lisp
index b700420..f59e7f4 100644
--- a/tests/kill-non-lisp-thread.impure.lisp
+++ b/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)
diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp
index 4b6fed3..8fd8bad 100644
--- a/tests/print.impure.lisp
+++ b/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)))
diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp
index 2cdd163..5b27987 100644
--- a/tests/run-tests.lisp
+++ b/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")
 
diff --git a/tests/signals.impure.lisp b/tests/signals.impure.lisp
index ea6e895..716580c 100644
--- a/tests/signals.impure.lisp
+++ b/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
diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index cf9c676..18835aa 100644
--- a/tests/threads.impure.lisp
+++ b/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"))
diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp
index d4a5192..ea80fa3 100644
--- a/tests/threads.pure.lisp
+++ b/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)
diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp
index 19bc334..4bbaf91 100644
--- a/tests/timer.impure.lisp
+++ b/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 ()
diff --git a/tests/unwind-to-frame-and-call.impure.lisp b/tests/unwind-to-frame-and-call.impure.lisp
index f6a4419..7e56338 100644
--- a/tests/unwind-to-frame-and-call.impure.lisp
+++ b/tests/unwind-to-frame-and-call.impure.lisp
@@ -75,7 +75,18 @@
     (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)
@@ -129,6 +140,7 @@
   foo)
 
 (defun test-return (name)
+  #+win32 (decline)
   (setf *a* nil)
   (let ((*foo* 'x))
     (let ((*foo* 'y))
@@ -193,6 +205,7 @@
       (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)))
@@ -251,6 +264,7 @@
 (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
@@ -294,6 +308,7 @@
     (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
-- 
1.7.10.4