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 (cl:in-package #:cl-user)
  15
  16 (cl:use-package '#:test-util)
  17 (cl:use-package '#:assertoid)
  18
  19 (setf sb-unix::*on-dangerous-wait* :error)
  20
  21 (defun make-quiet-io-stream (&key
  22                             (input (make-synonym-stream '*standard-input*))
  23                             (output (make-broadcast-stream)))
  24   (make-two-way-stream input output))
  25
  26 (defun get-foreground-quietly ()
  27   (let ((*query-io* (make-quiet-io-stream)))
  28     (sb-thread::get-foreground)))
  29
  30 ;; this used to deadlock on session-lock
  31 (with-test (:name (:no-session-deadlock))
  32   (make-join-thread (lambda () (sb-ext:gc))))
  33
  34 (with-test (:name (:debugger-no-hang-on-session-lock-if-interrupted)
  35                   :fails-on :win32)
  36   #+win32 (error "user would have to touch a key interactively to proceed")
  37   (sb-debug::enable-debugger)
  38   (let ((main-thread sb-thread:*current-thread*))
  39     (make-join-thread
  40      (lambda ()
  41        (sleep 2)
  42        (sb-thread:interrupt-thread
  43         main-thread (lambda ()
  44                       (sb-thread::with-interrupts
  45                         (break))))
  46        (sleep 2)
  47        (sb-thread:interrupt-thread main-thread #'continue))
  48      :name "interruptor"))
  49   ;; Somewhat verify output.
  50   (let* ((error-output (make-string-output-stream))
  51          (debug-output (make-string-output-stream)))
  52     (let ((*error-output* error-output)
  53           (*debug-io* (make-quiet-io-stream :output debug-output)))
  54       (sb-thread::with-session-lock (sb-thread::*session*)
  55         (sleep 3)))
  56     (let ((output (get-output-stream-string error-output)))
  57       (assert (search "debugger invoked" output))
  58       (assert (search "break" output)))
  59     (let ((output (get-output-stream-string debug-output)))
  60       (assert (search "Type HELP for debugger help" output))
  61       (assert (search "[CONTINUE" output))
  62       (assert (search "Return from BREAK" output)))))
  63
  64 ;;; The sequence of actions in this test creates a situation in which
  65 ;;; the list of interactive threads of the current session contains a
  66 ;;; single thread.
  67 (with-test (:name (sb-thread::get-foreground :inifite-loop :bug-1682671))
  68   (let ((state nil)
  69         (lock (sb-thread:make-mutex :name "get-foreground test lock"))
  70         (variable (sb-thread:make-waitqueue :name "get-foreground test waitqueue")))
  71     (flet ((enter-state (new-state)
  72              (sb-thread:with-mutex (lock)
  73                (setf state new-state)
  74                (sb-thread:condition-notify variable)))
  75            (wait-for-state (goal)
  76              (sb-thread:with-mutex (lock)
  77                (loop :until (eq state goal) :do
  78                   (sb-thread:condition-wait variable lock)))))
  79
  80       (make-join-thread (lambda ()
  81                           (enter-state :ready)
  82                           (get-foreground-quietly)
  83                           (enter-state :done))
  84                         :name "get-foreground test thread 2")
  85
  86       (wait-for-state :ready)
  87       (sb-thread:release-foreground)
  88
  89       (wait-for-state :done)
  90       (get-foreground-quietly))))
  91
  92 (with-test (:name (sb-thread:release-foreground :bug-1682867))
  93   (let ((thread (make-join-thread (lambda ())
  94                                   :name "release-foreground test thread")))
  95     (sb-thread:release-foreground thread)
  96     (let ((interactive-threads
  97            (sb-thread::with-session-lock (sb-thread::*session*)
  98              (copy-list (sb-thread::interactive-threads)))))
  99       (assert (not (member sb-thread::*current-thread*
 100                            interactive-threads))))))
 101
 102 ;;; On termination, interactive (including foreground) threads remove
 103 ;;; themselves from the list of interactive threads in their
 104 ;;; session. However, this did not previously include broadcasting the
 105 ;;; interactive threads waitqueue, resulting in GET-FOREGROUND hanging
 106 ;;; after termination of the previous foreground thread.
 107 (with-test (:name (sb-thread::get-foreground :hang :missing-broadcast))
 108   (let ((thread (make-join-thread
 109                  (lambda () (sleep 1))
 110                  :name "get-foreground hang missing-broadcast test")))
 111     (sb-thread:release-foreground thread)
 112     (get-foreground-quietly)))
 113
 114 ;;; Releasing foreground to an already dead thread previously made the
 115 ;;; dead thread the foreground thread. At that point, all succeeding
 116 ;;; GET-FOREGROUND calls would just hang.
 117 (with-test (:name (sb-thread::get-foreground :hang :already-dead))
 118   (let ((thread (sb-thread:make-thread
 119                  (lambda ())
 120                  :name "get-foreground hang already-dead test")))
 121     (sb-thread:join-thread thread)
 122     (sb-thread:release-foreground thread)
 123     (get-foreground-quietly)))