X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fthreads.impure.lisp;h=c285c81acca221e1332be9b3d25d65be488da495;hb=402958f92506b9d3de852601b8c1ccb99b5ee558;hp=d3cc1623074e2476ae317f9d30601d35a2112a93;hpb=aede5ac0bbafc2ec5ef5044a51e47a9e10963d54;p=sbcl.git diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index d3cc162..c285c81 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,9 @@ (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) '("-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") @@ -114,11 +116,10 @@ (with-mutex (l) (with-recursive-lock (l))))) -(let ((l (make-spinlock :name "spinlock")) - (p *current-thread*)) +(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 @@ -470,37 +471,96 @@ (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))) -(with-test (:name (:thread-start :dynamic-values-and-gc)) - (let ((gc-thread (sb-thread:make-thread (lambda () - (loop (sleep (random 0.2)) - (sb-ext:gc :full t)))))) - (wait-for-threads - (loop for i below 3000 - when (zerop (mod i 30)) - do (princ ".") - collect - (let ((*x* (lambda ()))) - (declare (special *x*)) - (sb-thread:make-thread (lambda () (functionp *x*)))))) - (sb-thread:terminate-thread gc-thread) - (terpri))) - +;;;; 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* @@ -513,3 +573,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))))) + + + +