Do not trash registers in tests/win32-stack-unwind.c

[sbcl.git] / tests / threads.pure.lisp

diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp
index 717fb36..d4a5192 100644 (file)
--- a/tests/threads.pure.lisp
+++ b/tests/threads.pure.lisp
@@ -14,16 +14,29 @@
 (in-package :cl-user)
 
 (defpackage :thread-test
-  (:use :cl :sb-thread))
+  (:use :cl :sb-thread :sb-ext))
 
 (in-package :thread-test)
 
 (use-package :test-util)
 
+(with-test (:name atomic-update
+            :skipped-on '(not :sb-thread))
+  (let ((x (cons :count 0))
+        (nthreads (ecase sb-vm:n-word-bits (32 100) (64 1000))))
+    (mapc #'sb-thread:join-thread
+          (loop repeat 1000
+                collect (sb-thread:make-thread
+                         (lambda ()
+                           (loop repeat nthreads
+                                 do (atomic-update (cdr x) #'1+)
+                                    (sleep 0.00001))))))
+    (assert (equal x `(:count ,@(* 1000 nthreads))))))
+
 (with-test (:name mutex-owner)
   ;; Make sure basics are sane on unithreaded ports as well
   (let ((mutex (make-mutex)))
-    (get-mutex mutex)
+    (grab-mutex mutex)
     (assert (eq *current-thread* (mutex-value mutex)))
     (handler-bind ((warning #'error))
       (release-mutex mutex))
@@ -59,11 +72,11 @@
     (sleep 1)
     (assert (not (thread-alive-p thread)))))
 
-;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
+;;; GRAB-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
 
-(with-test (:name without-interrupts+get-mutex :skipped-on '(not :sb-thread))
+(with-test (:name without-interrupts+grab-mutex :skipped-on '(not :sb-thread))
   (let* ((lock (make-mutex))
-         (bar (progn (get-mutex lock) nil))
+         (bar (progn (grab-mutex lock) nil))
          (thread (make-thread (lambda ()
                                 (sb-sys:without-interrupts
                                     (with-mutex (lock)
@@ -400,14 +413,14 @@
     (assert (and (null value)
                  error))))
 
-(with-test (:name (:wait-for :basics))
+(with-test (:name (:wait-for :basics) :fails-on :win32)
   (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))
+(with-test (:name (:wait-for :deadline) :fails-on :win32)
   (assert (eq :ok
               (sb-sys:with-deadline (:seconds 10)
                 (assert (not (sb-ext:wait-for nil :timeout 0.1)))
@@ -419,7 +432,7 @@
                     (error "oops"))
                 (sb-sys:deadline-timeout () :deadline)))))
 
-(with-test (:name (:condition-wait :timeout :one-thread))
+(with-test (:name (:condition-wait :timeout :one-thread) :fails-on :win32)
   (let ((mutex (make-mutex))
         (waitqueue (make-waitqueue)))
     (assert (not (with-mutex (mutex)
@@ -452,7 +465,7 @@
       (unless (eql 50 ok)
         (error "Wanted 50, got ~S" ok)))))
 
-(with-test (:name (:wait-on-semaphore :timeout :one-thread))
+(with-test (:name (:wait-on-semaphore :timeout :one-thread) :fails-on :win32)
   (let ((sem (make-semaphore))
         (n 0))
     (signal-semaphore sem 10)
@@ -482,12 +495,12 @@
             :skipped-on '(not :sb-thread))
   (assert (eq :error
               (handler-case
-                  (join-thread (make-thread (lambda () (sleep 10))) :timeout 0.01)
+                  (join-thread (make-join-thread (lambda () (sleep 10))) :timeout 0.01)
                 (join-thread-error ()
                   :error))))
   (let ((cookie (cons t t)))
     (assert (eq cookie
-                (join-thread (make-thread (lambda () (sleep 10)))
+                (join-thread (make-join-thread (lambda () (sleep 10)))
                              :timeout 0.01
                              :default cookie)))))
 
@@ -513,7 +526,7 @@
                    #+sb-thread
                    (sb-thread::block-deferrable-signals))))))
       (let* ((threads (loop for i from 1 upto 100
-                            collect (make-thread #'critical :name (format nil "T~A" i))))
+                            collect (make-join-thread #'critical :name (format nil "T~A" i))))
              (safe nil)
              (unsafe nil)
              (interruptor (make-thread (lambda ()
@@ -547,3 +560,36 @@
     (signal-semaphore sem)
     (try-semaphore sem 1 note)
     (assert (semaphore-notification-status note))))
+
+(with-test (:name (:return-from-thread :normal-thread)
+            :skipped-on '(not :sb-thread))
+  (let* ((thread (make-thread (lambda ()
+                                (return-from-thread (values 1 2 3))
+                                :foo)))
+         (values (multiple-value-list (join-thread thread))))
+    (unless (equal (list 1 2 3) values)
+      (error "got ~S, wanted (1 2 3)" values))))
+
+(with-test (:name (:return-from-thread :main-thread))
+  (assert (main-thread-p))
+  (assert (eq :oops
+              (handler-case
+                  (return-from-thread t)
+                (thread-error ()
+                  :oops)))))
+
+(with-test (:name (:abort-thread :normal-thread)
+            :skipped-on '(not :sb-thread))
+  (let ((thread (make-thread (lambda ()
+                               (abort-thread)
+                               :foo))))
+    (assert (eq :aborted! (join-thread thread :default :aborted!)))))
+
+(with-test (:name (:abort-thread :main-thread))
+  (assert (main-thread-p))
+  (assert (eq :oops
+              (handler-case
+                  (abort-thread)
+                (thread-error ()
+                  :oops)))))
+