(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
(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.01))
- (sb-ext:gc :full t))))))
- (wait-for-threads
- (loop for i below 30000000
- when (zerop (mod i 30))
- do (princ ".") (force-output)
- collect
- (let ((*a* (lambda ()))
- (*b* (lambda ()))
- (*c* (lambda ()))
- (*d* (lambda ()))
- (*e* (lambda ()))
- (*f* (lambda ()))
- (*g* (lambda ()))
- (*h* (lambda ())))
- (declare (special *a* *b* *c* *d* *e* *f* *g* *h*))
- (sb-thread:make-thread (lambda ()
- (functionp *a*)
- (functionp *b*)
- (functionp *c*)
- (functionp *d*)
- (functionp *e*)
- (functionp *f*)
- (functionp *g*)
- (functionp *h*))))))
- (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*