+
;;;; miscellaneous tests of thread stuff
;;;; This software is part of the SBCL system. See the README file for
(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")
(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)
(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
(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)))
(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*))))
(interrupt-thread c
(lambda ()
(princ ".") (force-output)
- (assert (eq (thread-state *current-thread*) :running))
+ (assert (thread-alive-p *current-thread*))
(assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
(terminate-thread c)
(wait-for-threads (list c)))
(format t "~&session lock test done~%")
-(sb-ext:gc :full t)
(loop repeat 20 do
(wait-for-threads
(loop for i below 100 collect
- (sb-thread:make-thread (lambda ()))))
- (sb-ext:gc :full t)
- (princ "+")
- (force-output))
+ (sb-thread:make-thread (lambda ())))))
(format t "~&creation test done~%")
-;; watch out for *current-thread* being the parent thread after exit
-(let ((thread (sb-thread:make-thread (lambda ()))))
- (wait-for-threads (list thread))
- (assert (null (symbol-value-in-thread 'sb-thread:*current-thread*
- thread))))
-
;; 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*
| (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)))))
+
+
+
+
projects / sbcl.git / blobdiff