+(let ((mutex (make-mutex :name "contended")))
+ (labels ((run ()
+ (let ((me *current-thread*))
+ (dotimes (i 100)
+ (with-mutex (mutex)
+ (sleep .1)
+ (assert (eql (mutex-value mutex) me)))
+ (assert (not (eql (mutex-value mutex) me))))
+ (format t "done ~A~%" *current-thread*))))
+ (let ((kid1 (make-thread #'run))
+ (kid2 (make-thread #'run)))
+ (format t "contention ~A ~A~%" kid1 kid2)
+ (wait-for-threads (list kid1 kid2)))))
+
+;;; semaphores
+
+(defmacro raises-timeout-p (&body body)
+ `(handler-case (progn (progn ,@body) nil)
+ (sb-ext:timeout () t)))
+
+(with-test (:name (:semaphore :wait-forever))
+ (let ((sem (make-semaphore :count 0)))
+ (assert (raises-timeout-p
+ (sb-ext:with-timeout 0.1
+ (wait-on-semaphore sem))))))
+
+(with-test (:name (:semaphore :initial-count))
+ (let ((sem (make-semaphore :count 1)))
+ (sb-ext:with-timeout 0.1
+ (wait-on-semaphore sem))))
+
+(with-test (:name (:semaphore :wait-then-signal))
+ (let ((sem (make-semaphore))
+ (signalled-p nil))
+ (make-thread (lambda ()
+ (sleep 0.1)
+ (setq signalled-p t)
+ (signal-semaphore sem)))
+ (wait-on-semaphore sem)
+ (assert signalled-p)))
+
+(with-test (:name (:semaphore :signal-then-wait))
+ (let ((sem (make-semaphore))
+ (signalled-p nil))
+ (make-thread (lambda ()
+ (signal-semaphore sem)
+ (setq signalled-p t)))
+ (loop until signalled-p)
+ (wait-on-semaphore sem)
+ (assert signalled-p)))
+
+(with-test (:name (:semaphore :multiple-signals))
+ (let* ((sem (make-semaphore :count 5))
+ (threads (loop repeat 20
+ collect (make-thread (lambda ()
+ (wait-on-semaphore sem))))))
+ (flet ((count-live-threads ()
+ (count-if #'thread-alive-p threads)))
+ (sleep 0.5)
+ (assert (= 15 (count-live-threads)))
+ (signal-semaphore sem 10)
+ (sleep 0.5)
+ (assert (= 5 (count-live-threads)))
+ (signal-semaphore sem 3)
+ (sleep 0.5)
+ (assert (= 2 (count-live-threads)))
+ (signal-semaphore sem 4)
+ (sleep 0.5)
+ (assert (= 0 (count-live-threads))))))
+
+(format t "~&semaphore tests done~%")
+
+(defun test-interrupt (function-to-interrupt &optional quit-p)
+ (let ((child (make-thread function-to-interrupt)))
+ ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
+ (sleep 2)
+ (format t "interrupting child ~A~%" child)
+ (interrupt-thread child
+ (lambda ()
+ (format t "child pid ~A~%" *current-thread*)
+ (when quit-p (sb-ext:quit))))
+ (sleep 1)
+ child))
+
+;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
+;; (d) waiting on a lock, (e) some code which we hope is likely to be
+;; in pseudo-atomic
+
+(let ((child (test-interrupt (lambda () (loop))))) (terminate-thread child))
+
+(test-interrupt #'loop-forever :quit)
+
+(let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
+ (terminate-thread child)
+ (wait-for-threads (list child)))
+
+(let ((lock (make-mutex :name "loctite"))
+ child)
+ (with-mutex (lock)
+ (setf child (test-interrupt
+ (lambda ()
+ (with-mutex (lock)
+ (assert (eql (mutex-value lock) *current-thread*)))
+ (assert (not (eql (mutex-value lock) *current-thread*)))
+ (sleep 10))))
+ ;;hold onto lock for long enough that child can't get it immediately
+ (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 (eq (thread-state *current-thread*) :running))
+ (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~%")
+
+(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))
+
+(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)))
+
+#| ;; a cll post from eric marsden
+| (defun crash ()
+| (setq *debugger-hook*
+| (lambda (condition old-debugger-hook)
+| (debug:backtrace 10)
+| (unix:unix-exit 2)))
+| #+live-dangerously
+| (mp::start-sigalrm-yield)
+| (flet ((roomy () (loop (with-output-to-string (*standard-output*) (room)))))
+| (mp:make-process #'roomy)
+| (mp:make-process #'roomy)))
+|#