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