(in-package "SB-THREAD") ; this is white-box testing, really
+;;; compare-and-swap
+
+(defmacro defincf (name accessor &rest args)
+ `(defun ,name (x)
+ (let* ((old (,accessor x ,@args))
+ (new (1+ old)))
+ (loop until (eq old (sb-ext:compare-and-swap (,accessor x ,@args) old new))
+ do (setf old (,accessor x ,@args)
+ new (1+ old)))
+ new)))
+
+(defstruct cas-struct (slot 0))
+
+(defincf incf-car car)
+(defincf incf-cdr cdr)
+(defincf incf-slot cas-struct-slot)
+(defincf incf-symbol-value symbol-value)
+(defincf incf-svref/1 svref 1)
+(defincf incf-svref/0 svref 0)
+
+(defmacro def-test-cas (name init incf op)
+ `(progn
+ (defun ,name (n)
+ (declare (fixnum n))
+ (let* ((x ,init)
+ (run nil)
+ (threads
+ (loop repeat 10
+ collect (sb-thread:make-thread
+ (lambda ()
+ (loop until run)
+ (loop repeat n do (,incf x)))))))
+ (setf run t)
+ (dolist (th threads)
+ (sb-thread:join-thread th))
+ (assert (= (,op x) (* 10 n)))))
+ (,name 200000)))
+
+(def-test-cas test-cas-car (cons 0 nil) incf-car car)
+(def-test-cas test-cas-cdr (cons nil 0) incf-cdr cdr)
+(def-test-cas test-cas-slot (make-cas-struct) incf-slot cas-struct-slot)
+(def-test-cas test-cas-value (let ((x '.x.))
+ (set x 0)
+ x)
+ incf-symbol-value symbol-value)
+(def-test-cas test-cas-svref/0 (vector 0 nil) incf-svref/0 (lambda (x)
+ (svref x 0)))
+(def-test-cas test-cas-svref/1 (vector nil 0) incf-svref/1 (lambda (x)
+ (svref x 1)))
+(format t "~&compare-and-swap tests done~%")
+
(use-package :test-util)
+(use-package "ASSERTOID")
+
+(setf sb-unix::*on-dangerous-select* :error)
(defun wait-for-threads (threads)
- (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01)))
+ (mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads)
+ (assert (not (some #'sb-thread:thread-alive-p threads))))
(assert (eql 1 (length (list-all-threads))))
(sleep 3)
(assert (not (thread-alive-p thread))))
+(with-test (:name '(:join-thread :nlx :default))
+ (let ((sym (gensym)))
+ (assert (eq sym (join-thread (make-thread (lambda () (sb-ext:quit)))
+ :default sym)))))
+
+(with-test (:name '(:join-thread :nlx :error))
+ (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))))
+
+(with-test (:name '(:join-thread :multiple-values))
+ (assert (equal '(1 2 3)
+ (multiple-value-list
+ (join-thread (make-thread (lambda () (values 1 2 3))))))))
+
;;; We had appalling scaling properties for a while. Make sure they
;;; don't reappear.
(defun scaling-test (function &optional (nthreads 5))
#-sunos "cc" #+sunos "gcc"
(or #+(or linux freebsd sunos) '(#+x86-64 "-fPIC"
"-shared" "-o" "threads-foreign.so" "threads-foreign.c")
- #+darwin '("-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
+ #+darwin '(#+x86-64 "-arch" #+x86-64 "x86_64"
+ "-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
(error "Missing shared library compilation options for this platform"))
:search t)
(sb-alien:load-shared-object "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"
(let ((l (make-mutex :name "foo"))
(assert (ours-p (mutex-value l)) nil "5"))
(assert (eql (mutex-value l) nil) nil "6")))
+(labels ((ours-p (value)
+ (eq *current-thread* value)))
+ (let ((l (make-spinlock :name "rec")))
+ (assert (eql (spinlock-value l) nil) nil "1")
+ (with-recursive-spinlock (l)
+ (assert (ours-p (spinlock-value l)) nil "3")
+ (with-recursive-spinlock (l)
+ (assert (ours-p (spinlock-value l)) nil "4"))
+ (assert (ours-p (spinlock-value l)) nil "5"))
+ (assert (eql (spinlock-value l) nil) nil "6")))
+
(with-test (:name (:mutex :nesting-mutex-and-recursive-lock))
(let ((l (make-mutex :name "a mutex")))
(with-mutex (l)
(with-recursive-lock (l)))))
+(with-test (:name (:spinlock :nesting-spinlock-and-recursive-spinlock))
+ (let ((l (make-spinlock :name "a spinlock")))
+ (with-spinlock (l)
+ (with-recursive-spinlock (l)))))
+
(let ((l (make-spinlock :name "spinlock")))
- (assert (eql (spinlock-value l) 0) nil "1")
+ (assert (eql (spinlock-value l) nil) ((spinlock-value l))
+ "spinlock not free (1)")
(with-spinlock (l)
- (assert (eql (spinlock-value l) 1) nil "2"))
- (assert (eql (spinlock-value l) 0) nil "3"))
+ (assert (eql (spinlock-value l) *current-thread*) ((spinlock-value l))
+ "spinlock not taken"))
+ (assert (eql (spinlock-value l) nil) ((spinlock-value l))
+ "spinlock not free (2)"))
;; test that SLEEP actually sleeps for at least the given time, even
;; if interrupted by another thread exiting/a gc/anything
(sb-ext:quit :unix-status 1)))))))
;; (nanosleep -1 0) does not fail on FreeBSD
-(let* (#-freebsd
+(let* (#-freebsd
(nanosleep-errno (progn
(sb-unix:nanosleep -1 0)
(sb-unix::get-errno)))
(format t "~&thread startup sigmask test done~%")
+;; FIXME: What is this supposed to test?
(sb-debug::enable-debugger)
(let* ((main-thread *current-thread*)
(interruptor-thread
(sleep 2)
(interrupt-thread main-thread #'break)
(sleep 2)
- (interrupt-thread main-thread #'continue)))))
+ (interrupt-thread main-thread #'continue))
+ :name "interruptor")))
(with-session-lock (*session*)
(sleep 3))
(loop while (thread-alive-p interruptor-thread)))
(let* ((ok t)
(threads (loop for i from 0 to 10
collect (sb-thread:make-thread
- (let ((i i))
- (lambda ()
- (dotimes (j 100)
- (write-char #\-)
- (finish-output)
- (let ((n (infodb-test)))
- (unless (zerop n)
- (setf ok nil)
- (format t "N != 0 (~A)~%" n)
- (quit))))))))))
+ (lambda ()
+ (dotimes (j 100)
+ (write-char #\-)
+ (finish-output)
+ (let ((n (infodb-test)))
+ (unless (zerop n)
+ (setf ok nil)
+ (format t "N != 0 (~A)~%" n)
+ (sb-ext:quit)))))))))
(wait-for-threads threads)
(assert ok)))
projects / sbcl.git / blobdiff