X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=c68b61518da484e4fe9ebcd79245da81760d058f;hb=87cd7d9848d9beddbf74e9d56a0c0aea6e189ead;hp=97f98f42fb72224d5dd8e991f7de028d55b8369c;hpb=0c5c2fec5aae5fc87fc392192b009d234ea99462;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 97f98f4..c68b615 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -16,8 +16,10 @@ (use-package :test-util) (use-package "ASSERTOID") +(setf sb-unix::*on-dangerous-select* :error) + (defun wait-for-threads (threads) - (mapc #'sb-thread:join-thread threads) + (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)))) @@ -41,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*)) @@ -58,8 +112,7 @@ :default sym))))) (with-test (:name '(:join-thread :nlx :error)) - (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))) - :errorp t))) + (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit)))))) (with-test (:name '(:join-thread :multiple-values)) (assert (equal '(1 2 3) @@ -100,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")) @@ -127,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 @@ -470,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 @@ -477,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)))