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