+ (sleep 5)
+ (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
+ (format t "parent releasing lock~%"))
+ (terminate-thread child)
+ (wait-for-threads (list child)))
+
+(format t "~&locking test done~%")
+
+(defun alloc-stuff () (copy-list '(1 2 3 4 5)))
+
+(progn
+ (let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
+ (let ((killers
+ (loop repeat 4 collect
+ (sb-thread:make-thread
+ (lambda ()
+ (loop repeat 25 do
+ (sleep (random 0.1d0))
+ (princ ".")
+ (force-output)
+ (sb-thread:interrupt-thread thread (lambda ()))))))))
+ (wait-for-threads killers)
+ (sb-thread:terminate-thread thread)
+ (wait-for-threads (list thread))))
+ (sb-ext:gc :full t))
+
+(format t "~&multi interrupt test done~%")
+
+(let ((c (make-thread (lambda () (loop (alloc-stuff))))))
+ ;; NB this only works on x86: other ports don't have a symbol for
+ ;; pseudo-atomic atomicity
+ (dotimes (i 100)
+ (sleep (random 0.1d0))
+ (interrupt-thread c
+ (lambda ()
+ (princ ".") (force-output)
+ (assert (thread-alive-p *current-thread*))
+ (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
+ (terminate-thread c)
+ (wait-for-threads (list c)))
+
+(format t "~&interrupt test done~%")
+
+(defparameter *interrupt-count* 0)
+
+(declaim (notinline check-interrupt-count))
+(defun check-interrupt-count (i)
+ (declare (optimize (debug 1) (speed 1)))
+ ;; This used to lose if eflags were not restored after an interrupt.
+ (unless (typep i 'fixnum)
+ (error "!!!!!!!!!!!")))
+
+(let ((c (make-thread
+ (lambda ()
+ (handler-bind ((error #'(lambda (cond)
+ (princ cond)
+ (sb-debug:backtrace
+ most-positive-fixnum))))
+ (loop (check-interrupt-count *interrupt-count*)))))))
+ (let ((func (lambda ()
+ (princ ".")
+ (force-output)
+ (sb-impl::atomic-incf/symbol *interrupt-count*))))
+ (setq *interrupt-count* 0)
+ (dotimes (i 100)
+ (sleep (random 0.1d0))
+ (interrupt-thread c func))
+ (loop until (= *interrupt-count* 100) do (sleep 0.1))
+ (terminate-thread c)
+ (wait-for-threads (list c))))
+
+(format t "~&interrupt count test done~%")
+
+(let (a-done b-done)
+ (make-thread (lambda ()
+ (dotimes (i 100)
+ (sb-ext:gc) (princ "\\") (force-output))
+ (setf a-done t)))
+ (make-thread (lambda ()
+ (dotimes (i 25)
+ (sb-ext:gc :full t)
+ (princ "/") (force-output))
+ (setf b-done t)))
+ (loop
+ (when (and a-done b-done) (return))
+ (sleep 1)))
+
+(terpri)
+
+(defun waste (&optional (n 100000))
+ (loop repeat n do (make-string 16384)))
+
+(loop for i below 100 do
+ (princ "!")
+ (force-output)
+ (sb-thread:make-thread
+ #'(lambda ()
+ (waste)))
+ (waste)
+ (sb-ext:gc))
+
+(terpri)
+
+(defparameter *aaa* nil)
+(loop for i below 100 do
+ (princ "!")
+ (force-output)
+ (sb-thread:make-thread
+ #'(lambda ()
+ (let ((*aaa* (waste)))
+ (waste))))
+ (let ((*aaa* (waste)))
+ (waste))
+ (sb-ext:gc))
+
+(format t "~&gc test done~%")
+
+;; this used to deadlock on session-lock
+(sb-thread:make-thread (lambda () (sb-ext:gc)))
+;; expose thread creation races by exiting quickly
+(sb-thread:make-thread (lambda ()))
+
+(defun exercise-syscall (fn reference-errno)
+ (sb-thread:make-thread
+ (lambda ()
+ (loop do
+ (funcall fn)
+ (let ((errno (sb-unix::get-errno)))
+ (sleep (random 0.1d0))
+ (unless (eql errno reference-errno)
+ (format t "Got errno: ~A (~A) instead of ~A~%"
+ errno
+ (sb-unix::strerror)
+ reference-errno)
+ (force-output)
+ (sb-ext:quit :unix-status 1)))))))
+
+(let* ((nanosleep-errno (progn
+ (sb-unix:nanosleep -1 0)
+ (sb-unix::get-errno)))
+ (open-errno (progn
+ (open "no-such-file"
+ :if-does-not-exist nil)
+ (sb-unix::get-errno)))
+ (threads
+ (list
+ (exercise-syscall (lambda () (sb-unix:nanosleep -1 0)) nanosleep-errno)
+ (exercise-syscall (lambda () (open "no-such-file"
+ :if-does-not-exist nil))
+ open-errno)
+ (sb-thread:make-thread (lambda () (loop (sb-ext:gc) (sleep 1)))))))
+ (sleep 10)
+ (princ "terminating threads")
+ (dolist (thread threads)
+ (sb-thread:terminate-thread thread)))
+
+(format t "~&errno test done~%")
+
+(loop repeat 100 do
+ (let ((thread (sb-thread:make-thread (lambda () (sleep 0.1)))))
+ (sb-thread:interrupt-thread
+ thread
+ (lambda ()
+ (assert (find-restart 'sb-thread:terminate-thread))))))
+
+(sb-ext:gc :full t)
+
+(format t "~&thread startup sigmask test done~%")
+
+(sb-debug::enable-debugger)
+(let* ((main-thread *current-thread*)
+ (interruptor-thread
+ (make-thread (lambda ()
+ (sleep 2)
+ (interrupt-thread main-thread #'break)
+ (sleep 2)
+ (interrupt-thread main-thread #'continue)))))
+ (with-session-lock (*session*)
+ (sleep 3))
+ (loop while (thread-alive-p interruptor-thread)))
+
+(format t "~&session lock test done~%")
+
+(loop repeat 20 do
+ (wait-for-threads
+ (loop for i below 100 collect
+ (sb-thread:make-thread (lambda ())))))
+
+(format t "~&creation test done~%")
+
+;; 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~%")