tests/session.impure.lisp

   1 ;;;; session-related tests
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 #-sb-thread (invoke-restart 'run-tests::skip-file)
  15
  16 (setf sb-unix::*on-dangerous-wait* :error)
  17
  18 (defun make-quiet-io-stream (&key
  19                             (input (make-synonym-stream '*standard-input*))
  20                             (output (make-broadcast-stream)))
  21   (make-two-way-stream input output))
  22
  23 (defun get-foreground-quietly ()
  24   (let ((*query-io* (make-quiet-io-stream)))
  25     (sb-thread::get-foreground)))
  26
  27 ;; this used to deadlock on session-lock
  28 (with-test (:name (:no-session-deadlock))
  29   (make-join-thread (lambda () (sb-ext:gc))))
  30
  31 (with-test (:name (:make-thread-while-holding-session-lock))
  32   (let ((thr1 nil)
  33         (thr2 nil)
  34         (sem1 (sb-thread:make-semaphore))
  35         (sem2 (sb-thread:make-semaphore)))
  36     (sb-thread::with-session-lock (sb-thread::*session*)
  37       (setq thr1 (sb-thread:make-thread
  38                   #'sb-thread:signal-semaphore :arguments sem1)
  39             thr2 (sb-thread:make-thread
  40                   #'sb-thread:signal-semaphore :arguments sem2))
  41       ;; This used to hang right here because threads could not make progress
  42       ;; in their lisp-side trampoline.
  43       (sb-thread:wait-on-semaphore sem1)
  44       (sb-thread:wait-on-semaphore sem2))
  45     (sb-thread:join-thread thr1)
  46     (sb-thread:join-thread thr2)))
  47
  48 (with-test (:name (:debugger-no-hang-on-session-lock-if-interrupted)
  49             :broken-on :win32)
  50   (sb-debug::enable-debugger)
  51   (let ((main-thread sb-thread:*current-thread*))
  52     (make-join-thread
  53      (lambda ()
  54        (sleep 2)
  55        (sb-thread:interrupt-thread
  56         main-thread (lambda ()
  57                       (sb-thread::with-interrupts
  58                         (break))))
  59        (sleep 2)
  60        (sb-thread:interrupt-thread main-thread #'continue))
  61      :name "interruptor"))
  62   ;; Somewhat verify output.
  63   (let* ((error-output (make-string-output-stream))
  64          (debug-output (make-string-output-stream)))
  65     (let ((*error-output* error-output)
  66           (*debug-io* (make-quiet-io-stream :output debug-output)))
  67       (sb-thread::with-session-lock (sb-thread::*session*)
  68         (sleep 3)))
  69     (let ((output (get-output-stream-string error-output)))
  70       (assert (search "debugger invoked" output))
  71       (assert (search "break" output)))
  72     (let ((output (get-output-stream-string debug-output)))
  73       (assert (search "Type HELP for debugger help" output))
  74       (assert (search "[CONTINUE" output))
  75       (assert (search "Return from BREAK" output)))))
  76
  77 ;;; The sequence of actions in this test creates a situation in which
  78 ;;; the list of interactive threads of the current session contains a
  79 ;;; single thread.
  80 (with-test (:name (sb-thread::get-foreground :inifite-loop :bug-1682671))
  81   (let ((state nil)
  82         (lock (sb-thread:make-mutex :name "get-foreground test lock"))
  83         (variable (sb-thread:make-waitqueue :name "get-foreground test waitqueue")))
  84     (flet ((enter-state (new-state)
  85              (sb-thread:with-mutex (lock)
  86                (setf state new-state)
  87                (sb-thread:condition-notify variable)))
  88            (wait-for-state (goal)
  89              (sb-thread:with-mutex (lock)
  90                (loop :until (eq state goal) :do
  91                   (sb-thread:condition-wait variable lock)))))
  92
  93       (make-join-thread (lambda ()
  94                           (enter-state :ready)
  95                           (get-foreground-quietly)
  96                           (enter-state :done))
  97                         :name "get-foreground test thread 2")
  98
  99       (wait-for-state :ready)
 100       (sb-thread:release-foreground)
 101
 102       (wait-for-state :done)
 103       (get-foreground-quietly))))
 104
 105 (with-test (:name (sb-thread:release-foreground :bug-1682867))
 106   (let ((thread (make-join-thread (lambda ())
 107                                   :name "release-foreground test thread")))
 108     (sb-thread:release-foreground thread)
 109     (let ((interactive-threads
 110            (sb-thread::with-session-lock (sb-thread::*session*)
 111              (copy-list (sb-thread::interactive-threads)))))
 112       (assert (not (member sb-thread::*current-thread*
 113                            interactive-threads))))))
 114
 115 ;;; On termination, interactive (including foreground) threads remove
 116 ;;; themselves from the list of interactive threads in their
 117 ;;; session. However, this did not previously include notifying the
 118 ;;; interactive threads waitqueue, resulting in GET-FOREGROUND hanging
 119 ;;; after termination of the previous foreground thread.
 120 (with-test (:name (sb-thread::get-foreground :hang :missing-broadcast))
 121   (let ((thread (make-join-thread
 122                  (lambda () (sleep 1))
 123                  :name "get-foreground hang missing-broadcast test")))
 124     (sb-thread:release-foreground thread)
 125     (get-foreground-quietly)))
 126
 127 ;;; Releasing foreground to an already dead thread previously made the
 128 ;;; dead thread the foreground thread. At that point, all succeeding
 129 ;;; GET-FOREGROUND calls would just hang.
 130 (with-test (:name (sb-thread::get-foreground :hang :already-dead))
 131   (let ((thread (sb-thread:make-thread
 132                  (lambda ())
 133                  :name "get-foreground hang already-dead test")))
 134     (sb-thread:join-thread thread)
 135     (sb-thread:release-foreground thread)
 136     (get-foreground-quietly)))
 137
 138 (with-test (:name :new-session)
 139   (let ((old-session sb-thread::*session*))
 140     (sb-thread:with-new-session ()
 141       (let ((new-session sb-thread::*session*))
 142         (assert (not (eq old-session new-session)))
 143         ;; this thread should not be in session-threads of the old session
 144         (assert (not (member sb-thread:*current-thread*
 145                              (sb-thread::session-threads old-session))))
 146         (assert (member sb-thread:*current-thread*
 147                         (sb-thread::session-threads new-session)))))))