;;;; miscellaneous tests of thread stuff

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;
;;;; This software is in the public domain and is provided with
;;;; absoluely no warranty. See the COPYING and CREDITS files for
;;;; more information.

#-sb-thread (invoke-restart 'run-tests::skip-file)

(shadowing-import 'assertoid:assert-error)
(use-package "SB-THREAD")
(use-package "SB-SYS")

(setf sb-unix::*on-dangerous-wait* :error)

;;; semaphores

(defmacro raises-timeout-p (&body body)
  `(handler-case (progn (progn ,@body) nil)
    (sb-ext:timeout () t)))

(with-test (:name (semaphore :wait-forever)
            :skipped-on (:and :sb-safepoint :linux)) ; hangs
  (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
      (assert (= 0 (wait-on-semaphore sem))))))

(with-test (:name (semaphore :wait-then-signal))
  (let ((sem (make-semaphore))
        (signalled-p nil))
    (make-join-thread (lambda ()
                        (sleep 0.1)
                        (setq signalled-p t)
                        (signal-semaphore sem)))
    (assert (= 0 (wait-on-semaphore sem)))
    (assert signalled-p)))

(with-test (:name (semaphore :signal-then-wait))
  (let ((sem (make-semaphore))
        (signalled-p nil))
    (make-join-thread (lambda ()
                        (signal-semaphore sem)
                        (setq signalled-p t)))
    (loop until signalled-p)
    (assert (= 0 (wait-on-semaphore sem)))
    (assert signalled-p)))

(defun test-semaphore-multiple-signals (wait-on-semaphore)
  (let* ((sem (make-semaphore :count 5))
         (threads (loop repeat 20 collecting
                        (make-join-thread (lambda ()
                                            (funcall 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))))))

(with-test (:name (semaphore :multiple-signals))
  (test-semaphore-multiple-signals #'wait-on-semaphore))

(with-test (:name (try-semaphore :trivial-fail))
  (assert (eq (try-semaphore (make-semaphore :count 0)) 'nil)))

(with-test (:name (try-semaphore :trivial-success))
  (let ((sem (make-semaphore :count 1)))
    (assert (= 0 (try-semaphore sem)))
    (assert (zerop (semaphore-count sem)))))

(with-test (:name (try-semaphore :trivial-fail :n>1))
  (assert (eq (try-semaphore (make-semaphore :count 1) 2) 'nil)))

(with-test (:name (try-semaphore :trivial-success :n>1))
  (let ((sem (make-semaphore :count 10)))
    (assert (= 5 (try-semaphore sem 5)))
    (assert (= 0 (try-semaphore sem 5)))
    (assert (zerop (semaphore-count sem)))))

(with-test (:name (try-semaphore :emulate-wait-on-semaphore))
  (flet ((busy-wait-on-semaphore (sem)
           (loop until (try-semaphore sem) do (sleep 0.001))))
    (test-semaphore-multiple-signals #'busy-wait-on-semaphore)))

;;; Here we test that interrupting TRY-SEMAPHORE does not leave a
;;; semaphore in a bad state.
(with-test (:name (try-semaphore :interrupt-safe))
  (flet ((make-threads (count fn)
           (loop repeat count collect (make-thread fn)))
         (kill-thread (thread)
           (when (thread-alive-p thread)
             (ignore-errors (terminate-thread thread))))
         (count-live-threads (threads)
           (count-if #'thread-alive-p threads)))
    ;; WAITERS will already be waiting on the semaphore while
    ;; threads-being-interrupted will perform TRY-SEMAPHORE on that
    ;; semaphore, and MORE-WAITERS are new threads trying to wait on
    ;; the semaphore during the interruption-fire.
    (let* ((sem (make-semaphore :count 100))
           (waiters (make-threads 20 #'(lambda ()
                                         (wait-on-semaphore sem))))
           (triers  (make-threads 40 #'(lambda ()
                                         (sleep (random 0.01))
                                         (try-semaphore sem (1+ (random 5))))))
           (more-waiters
            (loop repeat 10
                  do (kill-thread (nth (random 40) triers))
                  collect (make-thread #'(lambda () (wait-on-semaphore sem)))
                  do (kill-thread (nth (random 40) triers)))))
      (sleep 0.5)
      ;; Now ensure that the waiting threads will all be waked up,
      ;; i.e. that the semaphore is still working.
      (loop repeat (+ (count-live-threads waiters)
                      (count-live-threads more-waiters))
            do (signal-semaphore sem))
      (sleep 0.5)
      (assert (zerop (count-live-threads triers)))
      (assert (zerop (count-live-threads waiters)))
      (assert (zerop (count-live-threads more-waiters))))))

;; At some point %DECREMENT-SEMAPHORE did not adjust the remaining
;; timeout after spurious wakeups, potentially leading to
;; longer/infinite waiting despite the specified timeout.
(with-test (:name (semaphore :timeout :spurious-wakeup))
  (let* ((semaphore (make-semaphore))
         (done nil)
         (thread (make-thread (lambda ()
                                (let ((mutex (sb-thread::semaphore-mutex semaphore))
                                      (queue (sb-thread::semaphore-queue semaphore)))
                                  (loop :until done :do
                                     (with-mutex (mutex)
                                       (condition-notify queue))))))))
    (assert (eq nil (wait-on-semaphore semaphore :timeout .5)))
    (setf done t)
    (join-thread thread)))

;; 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

(with-test (:name (interrupt-thread :more-basics))
  (let ((child (test-interrupt (lambda () (loop)))))
    (terminate-thread child)))

;;; For one of the interupt-thread tests, we want a foreign function
;;; that does not make syscalls

#-win32
(progn
  ;; When running from a read-only filesystem, and/or under a test scaffold in which
  ;; no C compiler exists, we'll trust that the extra "test data file" was prepared
  ;; already. Moreover we have to assume that it can't get out-of-date with respect
  ;; to this lisp file. i.e. it always contains at least the one C function neccesary.
  ;; (There's logically no "make clean ; make")
  (unless (probe-file "threads-foreign.so")
    (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
      (format o "void loop_forever() { while(1) ; }~%"))
    (sb-ext:run-program "/bin/sh"
                        '("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
                          "-o" "threads-foreign.so" "threads-foreign.c"))
    (delete-file "threads-foreign.c"))
  (sb-alien:load-shared-object (truename "threads-foreign.so"))
  (sb-alien:define-alien-routine loop-forever sb-alien:void))

(with-test (:name (interrupt-thread :interrupt-foreign-loop)
                  ;; This feature is explicitly unsupported on Win32.
            :skipped-on :win32)
  (test-interrupt #'loop-forever :quit))

(with-test (:name (interrupt-thread :interrupt-sleep))
  (let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
    (terminate-thread child)
    (wait-for-threads (list child))))

(defvar *runningp* nil)

(with-test (:name (interrupt-thread :no-nesting))
  (let ((thread (make-thread (lambda ()
                               (catch 'xxx
                                 (loop))))))
    (declare (special runningp))
    (sleep 0.2)
    (interrupt-thread thread (lambda ()
                               (let ((*runningp* t))
                                 (sleep 1))))
    (sleep 0.2)
    (interrupt-thread thread (lambda ()
                               (throw 'xxx *runningp*)))
    (assert (not (join-thread thread)))))

(with-test (:name (interrupt-thread :nesting))
  (let ((thread (make-thread (lambda ()
                               (catch 'xxx
                                 (loop))))))
    (declare (special runningp))
    (sleep 0.2)
    (interrupt-thread thread (lambda ()
                               (let ((*runningp* t))
                                 (sb-sys:with-interrupts
                                   (sleep 1)))))
    (sleep 0.2)
    (interrupt-thread thread (lambda ()
                               (throw 'xxx *runningp*)))
    (assert (join-thread thread))))

(with-test (:name :all-threads-have-abort-restart)
  ;; This test can fail with without the extra semaphore.
  ;; See also TEST-INTERRUPT in test-util for further explanation.
  (let* ((sem (make-semaphore))
         (thread (make-kill-thread
                  (lambda ()
                    (signal-semaphore sem)
                    (sleep 100000000)))))
    (wait-on-semaphore sem)
    (interrupt-thread thread (lambda ()
                               (assert (find-restart 'abort))))
    (process-all-interrupts thread)))

(sb-ext:gc :full t)

;; expose thread creation races by exiting quickly
(with-test (:name (:no-thread-creation-race :light))
  (make-join-thread (lambda ())))

(with-test (:name (:no-thread-creation-race :heavy))
  (loop repeat 20 do
        (wait-for-threads
         (loop for i below 100 collect
               (make-thread (lambda ()))))))

;; interrupt handlers are per-thread with pthreads, make sure the
;; handler installed in one thread is global
(with-test (:name (:global-interrupt-handler))
  (make-join-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*))

#+(or x86 x86-64 riscv loongarch64) ;the only platforms with a *binding-stack-pointer* variable
(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)
         (binding-pointer-delta (ash 2 (- sb-vm:word-shift sb-vm:n-fixnum-tag-bits))))
     ;; bump bsp as if a BIND had just started
     (incf sb-vm::*binding-stack-pointer* binding-pointer-delta)
     (wait-for-gc)
     (decf sb-vm::*binding-stack-pointer* binding-pointer-delta))))

#+(or x86 x86-64 riscv loongarch64) ;the only platforms with a *binding-stack-pointer* variable
(with-test (:name (:binding-stack-gc-safety))
  (let (threads)
    (unwind-protect
         (progn
           (push (make-kill-thread #'exercise-binding) threads)
           (push (make-kill-thread (lambda ()
                                     (loop
                                      (sleep 0.1)
                                      (send-gc))))
                 threads)
           (sleep 3))
      (mapc #'terminate-thread threads))))

(with-test (:name :test-%thread-local-references
                  ;; test is doing something very suspicious
                  ;; and needs to be rewritten to not do that
                  :skipped-on :tls-load-indirect)
  (let ((mysym (gensym))
        (fool1 (cons 1 2))
        (fool2 (cons 2 3)))
    (progv (list mysym) '(nil)
      (let* ((i (sb-kernel:symbol-tls-index mysym))
             (j (+ i sb-vm:n-word-bytes)))
        (assert (eql (sap-ref-word (sb-thread::current-thread-sap) j)
                     sb-vm:no-tls-value-marker))
        (setf (sap-ref-lispobj (sb-thread::current-thread-sap) i) fool1
              (sap-ref-lispobj (sb-thread::current-thread-sap) j) fool2)
        ;; assert that my pointer arithmetic worked as expected
        (assert (eq (symbol-value mysym) fool1))
        ;; assert that FOOL1 is found by the TLS scan and that FOOL2 is not.
        (let ((list (sb-thread::%thread-local-references)))
          (assert (not (find sb-vm:no-tls-value-marker list
                             :key #'sb-kernel:get-lisp-obj-address)))
          (assert (member fool1 list))
          (assert (not (member fool2 list))))
        ;; repair the TLS entry that was corrupted by the test
        (setf (sap-ref-word (sb-thread::current-thread-sap) j)
              sb-vm:no-tls-value-marker)))))


#|  ;; 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)))
|#

;;; Make sure that a deadline handler is not invoked twice in a row in
;;; CONDITION-WAIT. See LP #512914 for a detailed explanation.
;;;
(with-test (:name (condition-wait :deadlines :LP-512914))
  (let ((n 2)                      ; was empirically enough to trigger the bug
        (mutex (make-mutex))
        (waitq (make-waitqueue))
        (threads nil)
        (deadline-handler-run-twice? nil))
    (dotimes (i n)
      (let ((child
              (make-thread
               (lambda ()
                 (handler-bind
                     ((sb-sys:deadline-timeout
                       (let ((already? nil))
                         #'(lambda (c)
                             (when already?
                               (setq deadline-handler-run-twice? t))
                             (setq already? t)
                             (sleep 0.2)
                             (sb-thread:condition-broadcast waitq)
                             (sb-sys:defer-deadline 10.0 c)))))
                   (sb-sys:with-deadline (:seconds 0.1)
                     (with-mutex (mutex)
                       (condition-wait waitq mutex))))))))
        (push child threads)))
    (mapc #'join-thread threads)
    (assert (not deadline-handler-run-twice?))))

;; You have to shoehorn this arbitrary sexpr into a feature expression
;; to have the test summary show that a test was disabled.
(unless (eql (extern-alien "verify_gens" int)
             (+ sb-vm:+highest-normal-generation+ 2))
  (pushnew :verify-gens *features*))

(with-test (:name :backtrace :broken-on :verify-gens)
  ;; Printing backtraces from several threads at once used to hang the
  ;; whole SBCL process (discovered by accident due to a timer.impure
  ;; test misbehaving). The cause was that packages weren't even
  ;; thread-safe for only doing FIND-SYMBOL, and while printing
  ;; backtraces a loot of symbol lookups need to be done due to
  ;; *PRINT-ESCAPE*.
  (let* ((threads (loop repeat 10
                        collect (make-thread
                                 (lambda ()
                                   (dotimes (i 1000)
                                     (with-output-to-string (*debug-io*)
                                       (sb-debug:print-backtrace :count 10))))))))
    (wait-for-threads threads)))



(defun subtypep-hash-cache-test ()
  (dotimes (i 10000)
    (let ((type1 (random-type 500))
          (type2 (random-type 500)))
      (let ((a (subtypep type1 type2)))
        (dotimes (i 100)
          (assert (eq (subtypep type1 type2) a))))))
  (write-char #\.)
  (force-output))

(with-test (:name (:hash-cache subtypep))
  (mapc #'join-thread
        ;; this didn't "reliably fail" with a small number of threads.
        ;; 30 is a compromise between running time and confidence in the result.
        (loop repeat 30
              collect (make-thread #'subtypep-hash-cache-test)))
  (terpri))

;;;; FUNCTIONAL TESTS

(with-test (:name (:parallel defclass))
  (write-line "WARNING, WILL HANG ON FAILURE!")
  (defclass test-1 () ((a :initform :orig-a)))
  (defclass test-2 () ((b :initform :orig-b)))
  (defclass test-3 (test-1 test-2) ((c :initform :orig-c)))
  ;; This test is more likely to pass on Windows with the FORCE-OUTPUT
  ;; calls disabled in the folloving code.  (As seen on a Server 2012
  ;; installation.)  Clearly, this sort of workaround in a test is
  ;; cheating, and might be hiding the underlying bug that the test is
  ;; exposing.  Let's review this later.
  (let* ((run t)
         (output nil)
         (d1 (sb-thread:make-thread (lambda ()
                                      (loop while run
                                            do (defclass test-1 () ((a :initform :new-a)))
                                            (when output (write-char #\1))
                                            #-win32 (force-output)))
                                    :name "d1"))
         (d2 (sb-thread:make-thread (lambda ()
                                      (loop while run
                                            do (defclass test-2 () ((b :initform :new-b)))
                                               (when output (write-char #\2))
                                               #-win32 (force-output)))
                                    :name "d2"))
         (d3 (sb-thread:make-thread (lambda ()
                                      (loop while run
                                            do (defclass test-3 (test-1 test-2) ((c :initform :new-c)))
                                               (when output (write-char #\3))
                                               #-win32 (force-output)))
                                    :name "d3"))
         (i (sb-thread:make-thread (lambda ()
                                     (loop while run
                                           do (let ((i (make-instance 'test-3)))
                                                (assert (member (slot-value i 'a) '(:orig-a :new-a)))
                                                (assert (member (slot-value i 'b) '(:orig-b :new-b)))
                                                (assert (member (slot-value i 'c) '(:orig-c :new-c))))
                                              (when output (write-char #\i))
                                              #-win32 (force-output)))
                                   :name "i")))
    (format t "~%sleeping!~%")
    (sleep 2.0)
    (format t "~%stopping!~%")
    (setf run nil)
    (mapc (lambda (th)
            (sb-thread:join-thread th)
            (format t "~&joined ~S~%" (sb-thread:thread-name th)))
          (list d1 d2 d3 i))
    (force-output)))

(with-test (:name :spinlock-api)
  (handler-bind ((warning #'error))
    (destructuring-bind (with make get release)
        (assert-signal
         (list (compile nil `(lambda (lock)
                               (sb-thread::with-spinlock (lock)
                                 t)))
               (compile nil `(lambda ()
                               (sb-thread::make-spinlock :name "foo")))
               (compile nil `(lambda (lock)
                               (sb-thread::get-spinlock lock)))
               (compile nil `(lambda (lock)
                               (sb-thread::release-spinlock lock))))
         early-deprecation-warning 4)
      (let ((lock (funcall make)))
        (funcall get lock)
        (funcall release lock)
        (assert (eq t (funcall with lock)))))))

(with-test (:name :interrupt-io-unnamed-pipe
            :skipped-on :win32)
  (let (result)
    (labels
        ((reader (fd)
           (let ((stream (sb-sys:make-fd-stream fd
                                                :element-type :default
                                                :serve-events nil)))
             (time
              (let ((ok (handler-case
                            (catch 'stop
                              (progn
                                (read-char stream)
                                (sleep 0.1)
                                (sleep 0.1)
                                (sleep 0.1)))
                          (error (c)
                            c))))
                (setf result ok)
                (progn
                  (format *trace-output* "~&=> ~A~%" ok)
                  (force-output *trace-output*))))
             (sleep 2)
             (ignore-errors (close stream))))

         (writer ()
           (multiple-value-bind (read write)
               (sb-unix:unix-pipe)
             (let* ((reader (sb-thread:make-thread (lambda () (reader read))))
                    (stream (sb-sys:make-fd-stream write
                                                   :output t
                                                   :element-type :default
                                                   :serve-events nil))
                    (ok :ok))
               (sleep 1)
               (sb-thread:interrupt-thread reader (lambda ()
                                                    (print :throwing)
                                                    (force-output)
                                                    (throw 'stop ok)))
               (sleep 1)
               (setf ok :not-ok)
               (write-char #\x stream)
               (close stream)
               (sb-thread:join-thread reader)))))
      (writer))
    (assert (eq result :ok))))

(with-test (:name :thread-alloca)
  (unless (probe-file "alloca.so")
    (sb-ext:run-program "sh"
                        '("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
                          "alloca.c" "-o" "alloca.so")
                        :search t))
  (load-shared-object (truename "alloca.so"))
  (alien-funcall (extern-alien "alloca_test" (function void)))
  (sb-thread:join-thread
   (sb-thread:make-thread
    (lambda ()
      (alien-funcall (extern-alien "alloca_test" (function void)))))))

(with-test (:name :fp-mode-inheritance-threads)
  (labels ((fp-mode ()
             (let ((reserved-bits #+x86 (ash #b1110000011000000 16)
                                  #-x86 0))
               (logandc2 (dpb 0 sb-vm:float-sticky-bits (sb-vm:floating-point-modes))
                         reserved-bits)))
           (test ()
             (let* ((fp-mode (fp-mode))
                    (thread-fp-mode
                      (sb-thread:join-thread
                       (sb-thread:make-thread
                        (lambda ()
                          (fp-mode))))))
               (assert (= fp-mode thread-fp-mode)))))
    (test)
    (sb-int:with-float-traps-masked (:divide-by-zero)
      (test))
    (setf (sb-vm:floating-point-modes)
          (dpb sb-vm:float-divide-by-zero-trap-bit
               sb-vm:float-traps-byte
               (sb-vm:floating-point-modes)))
    (test)))
