X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=c68b61518da484e4fe9ebcd79245da81760d058f;hb=e9d20dbcc57faf5be8ebccf95b4a8da680589990;hp=0d5453b2fc817b3ab01da3afe7790001595e33f7;hpb=25fe91bf63fd473d9316675b0e0ca9be0079e9eb;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 0d5453b..c68b615 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -14,9 +14,13 @@ (in-package "SB-THREAD") ; this is white-box testing, really (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)))) @@ -39,6 +43,58 @@ #-sb-thread (sb-ext:quit :unix-status 104) +;;; 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 + do (sb-thread:thread-yield)) + (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~%") + (let ((old-threads (list-all-threads)) (thread (make-thread (lambda () (assert (find *current-thread* *all-threads*)) @@ -50,6 +106,19 @@ (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)) @@ -84,12 +153,13 @@ #-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")) @@ -111,16 +181,35 @@ (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 @@ -454,6 +543,7 @@ (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 @@ -461,7 +551,8 @@ (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))) @@ -641,16 +732,15 @@ (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)))