+
+(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-id))
+ (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))))))
+ ;; Interrupting a sleep form causes it to return early. Welcome to Unix.
+ ;; Just to be sure our LOOP form works, let's check the child is still
+ ;; there
+ (assert (zerop (sb-unix:unix-kill child 0)))
+ (terminate-thread 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-id))))
+ (assert (not (eql (mutex-value lock) (current-thread-id))))
+ (sleep 60))))
+ ;;hold onto lock for long enough that child can't get it immediately
+ (sleep 20)
+ (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
+ (format t "parent releasing lock~%"))
+ (terminate-thread child))
+
+(defun alloc-stuff () (copy-list '(1 2 3 4 5)))
+(let ((c (test-interrupt (lambda () (loop (alloc-stuff))))))
+ ;; NB this only works on x86
+ (loop
+ (sleep (random 1d0))
+ (interrupt-thread c
+ (lambda ()
+ (princ ".") (force-output)
+ (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
+ (terminate-thread c))
+
+;; I'm not sure that this one is always successful. Note race potential:
+;; I haven't checked if decf is atomic here
+(let ((done 2))
+ (make-thread (lambda () (dotimes (i 100) (sb-ext:gc)) (decf done)))
+ (make-thread (lambda () (dotimes (i 25) (sb-ext:gc :full t)) (decf done)))
+ (loop
+ (when (zerop done) (return))
+ (sleep 1)))
+
+;; give the other thread time to die before we leave, otherwise the
+;; overall exit status is 0, not 104
+(sleep 2)
+
+;(sb-ext:quit :unix-status 104)