X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=56d610bbe0a168c5656c95e442da725f9f908063;hb=f76b45e1a3bb2008540e0db90b591c591315f129;hp=b4e5bba343a93bb373a1b41192ed8a2c7414fe4d;hpb=0b5119848b6b8713e473fa669356645747e11dbd;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index b4e5bba..56d610b 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -1,3 +1,4 @@ + ;;;; miscellaneous tests of thread stuff ;;;; This software is part of the SBCL system. See the README file for @@ -81,8 +82,10 @@ (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede) (format o "void loop_forever() { while(1) ; }~%")) (sb-ext:run-program - "cc" - (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c") + #-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") (error "Missing shared library compilation options for this platform")) :search t) (sb-alien:load-shared-object "threads-foreign.so") @@ -99,8 +102,7 @@ (assert (eql (mutex-value l) nil) nil "5")) (labels ((ours-p (value) - (sb-vm:control-stack-pointer-valid-p - (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))) + (eq *current-thread* value))) (let ((l (make-mutex :name "rec"))) (assert (eql (mutex-value l) nil) nil "1") (sb-thread:with-recursive-lock (l) @@ -110,11 +112,15 @@ (assert (ours-p (mutex-value l)) nil "5")) (assert (eql (mutex-value l) nil) nil "6"))) -(let ((l (make-spinlock :name "spinlock")) - (p *current-thread*)) +(with-test (:name (:mutex :nesting-mutex-and-recursive-lock)) + (let ((l (make-mutex :name "a mutex"))) + (with-mutex (l) + (with-recursive-lock (l))))) + +(let ((l (make-spinlock :name "spinlock"))) (assert (eql (spinlock-value l) 0) nil "1") (with-spinlock (l) - (assert (eql (spinlock-value l) p) nil "2")) + (assert (eql (spinlock-value l) 1) nil "2")) (assert (eql (spinlock-value l) 0) nil "3")) ;; test that SLEEP actually sleeps for at least the given time, even @@ -151,8 +157,7 @@ (let ((queue (make-waitqueue :name "queue")) (lock (make-mutex :name "lock"))) (labels ((ours-p (value) - (sb-vm:control-stack-pointer-valid-p - (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value)))) + (eq *current-thread* value)) (in-new-thread () (with-recursive-lock (lock) (assert (ours-p (mutex-value lock))) @@ -176,7 +181,7 @@ (let ((me *current-thread*)) (dotimes (i 100) (with-mutex (mutex) - (sleep .1) + (sleep .03) (assert (eql (mutex-value mutex) me))) (assert (not (eql (mutex-value mutex) me)))) (format t "done ~A~%" *current-thread*)))) @@ -460,28 +465,103 @@ (format t "~&session lock test done~%") -(wait-for-threads - (loop for i below 2000 collect - (sb-thread:make-thread (lambda ())))) +(loop repeat 20 do + (wait-for-threads + (loop for i below 100 collect + (sb-thread:make-thread (lambda ()))))) (format t "~&creation test done~%") -;; watch out for *current-thread* being the parent thread after exit -(let* (sap - (thread (sb-thread:make-thread - (lambda () - (setq sap (thread-sap-for-id - (thread-os-thread *current-thread*))))))) - (wait-for-threads (list thread)) - (assert (null (symbol-value-in-thread 'sb-thread:*current-thread* - sap)))) - ;; interrupt handlers are per-thread with pthreads, make sure the ;; handler installed in one thread is global (sb-thread:make-thread (lambda () (sb-ext:run-program "sleep" '("1") :search t :wait nil))) +;;;; Binding stack safety + +(defparameter *x* nil) +(defparameter *n-gcs-requested* 0) +(defparameter *n-gcs-done* 0) + +(let ((counter 0)) + (defun make-something-big () + (let ((x (make-string 32000))) + (incf counter) + (let ((counter counter)) + (sb-ext:finalize x (lambda () (format t " ~S" counter) + (force-output))))))) + +(defmacro wait-for-gc () + `(progn + (incf *n-gcs-requested*) + (loop while (< *n-gcs-done* *n-gcs-requested*)))) + +(defun send-gc () + (loop until (< *n-gcs-done* *n-gcs-requested*)) + (format t "G") + (force-output) + (sb-ext:gc) + (incf *n-gcs-done*)) + +(defun exercise-binding () + (loop + (let ((*x* (make-something-big))) + (let ((*x* 42)) + ;; at this point the binding stack looks like this: + ;; NO-TLS-VALUE-MARKER, *x*, SOMETHING, *x* + t)) + (wait-for-gc) + ;; sig_stop_for_gc_handler binds FREE_INTERRUPT_CONTEXT_INDEX. By + ;; now SOMETHING is gc'ed and the binding stack looks like this: 0, + ;; 0, SOMETHING, 0 (because the symbol slots are zeroed on + ;; unbinding but values are not). + (let ((*x* nil)) + ;; bump bsp as if a BIND had just started + (incf sb-vm::*binding-stack-pointer* 2) + (wait-for-gc) + (decf sb-vm::*binding-stack-pointer* 2)))) + +(with-test (:name (:binding-stack-gc-safety)) + (let (threads) + (unwind-protect + (progn + (push (sb-thread:make-thread #'exercise-binding) threads) + (push (sb-thread:make-thread (lambda () + (loop + (sleep 0.1) + (send-gc)))) + threads) + (sleep 4)) + (mapc #'sb-thread:terminate-thread threads)))) + +(format t "~&binding test done~%") + +;; Try to corrupt the NEXT-VECTOR. Operations on a hash table with a +;; cyclic NEXT-VECTOR can loop endlessly in a WITHOUT-GCING form +;; causing the next gc hang SBCL. +(with-test (:name (:hash-table-thread-safety)) + (let* ((hash (make-hash-table)) + (threads (list (sb-thread:make-thread + (lambda () + (loop + ;;(princ "1") (force-output) + (setf (gethash (random 100) hash) 'h)))) + (sb-thread:make-thread + (lambda () + (loop + ;;(princ "2") (force-output) + (remhash (random 100) hash)))) + (sb-thread:make-thread + (lambda () + (loop + (sleep (random 1.0)) + (sb-ext:gc :full t))))))) + (unwind-protect + (sleep 5) + (mapc #'sb-thread:terminate-thread threads)))) + +(format t "~&hash table test done~%") #| ;; a cll post from eric marsden | (defun crash () | (setq *debugger-hook* @@ -494,3 +574,47 @@ | (mp:make-process #'roomy) | (mp:make-process #'roomy))) |# + +(with-test (:name (:condition-variable :notify-multiple)) + (flet ((tester (notify-fun) + (let ((queue (make-waitqueue :name "queue")) + (lock (make-mutex :name "lock")) + (data nil)) + (labels ((test (x) + (loop + (with-mutex (lock) + (format t "condition-wait ~a~%" x) + (force-output) + (condition-wait queue lock) + (format t "woke up ~a~%" x) + (force-output) + (push x data))))) + (let ((threads (loop for x from 1 to 10 + collect + (let ((x x)) + (sb-thread:make-thread (lambda () + (test x))))))) + (sleep 5) + (with-mutex (lock) + (funcall notify-fun queue)) + (sleep 5) + (mapcar #'terminate-thread threads) + ;; Check that all threads woke up at least once + (assert (= (length (remove-duplicates data)) 10))))))) + (tester (lambda (queue) + (format t "~&(condition-notify queue 10)~%") + (force-output) + (condition-notify queue 10))) + (tester (lambda (queue) + (format t "~&(condition-broadcast queue)~%") + (force-output) + (condition-broadcast queue))))) + +(with-test (:name (:mutex :finalization)) + (let ((a nil)) + (dotimes (i 500000) + (setf a (make-mutex))))) + + + +