tests/threads.pure.lisp

   1 ;;;; miscellaneous tests of thread stuff
   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 (in-package :cl-user)
  15
  16 (defpackage :thread-test
  17   (:use :cl :sb-thread))
  18
  19 (in-package :thread-test)
  20
  21 (use-package :test-util)
  22
  23 ;;; Terminating a thread that's waiting for the terminal.
  24
  25 #+sb-thread
  26 (let ((thread (make-thread (lambda ()
  27                              (sb-thread::get-foreground)))))
  28   (sleep 1)
  29   (assert (thread-alive-p thread))
  30   (terminate-thread thread)
  31   (sleep 1)
  32   (assert (not (thread-alive-p thread))))
  33
  34 ;;; Condition-wait should not be interruptible under WITHOUT-INTERRUPTS
  35
  36 #+sb-thread
  37 (with-test (:name without-interrupts+condition-wait
  38             :fails-on :sb-lutex)
  39   (let* ((lock (make-mutex))
  40          (queue (make-waitqueue))
  41          (thread (make-thread (lambda ()
  42                                 (sb-sys:without-interrupts
  43                                   (with-mutex (lock)
  44                                     (condition-wait queue lock)))))))
  45     (sleep 1)
  46     (assert (thread-alive-p thread))
  47     (terminate-thread thread)
  48     (sleep 1)
  49     (assert (thread-alive-p thread))
  50     (condition-notify queue)
  51     (sleep 1)
  52     (assert (not (thread-alive-p thread)))))
  53
  54 ;;; GET-MUTEX should not be interruptible under WITHOUT-INTERRUPTS
  55
  56 #+sb-thread
  57 (with-test (:name without-interrupts+get-mutex
  58             :fails-on :sb-lutex)
  59   (let* ((lock (make-mutex))
  60          (foo (get-mutex lock))
  61          (bar nil)
  62          (thread (make-thread (lambda ()
  63                                 (sb-sys:without-interrupts
  64                                     (with-mutex (lock)
  65                                       (setf bar t)))))))
  66     (sleep 1)
  67     (assert (thread-alive-p thread))
  68     (terminate-thread thread)
  69     (sleep 1)
  70     (assert (thread-alive-p thread))
  71     (release-mutex lock)
  72     (sleep 1)
  73     (assert (not (thread-alive-p thread)))
  74     (assert (eq :aborted (join-thread thread :default :aborted)))
  75     (assert bar)))