tests/threads.impure.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 #-sb-thread (quit :unix-status 104)
  15
  16 (in-package "SB-THREAD") ; this is white-box testing, really
  17
  18 ;;; elementary "can we get a lock and release it again"
  19 (let ((l (make-mutex :name "foo"))
  20       (p (current-thread-id)))
  21   (assert (eql (mutex-value l) nil))
  22   (assert (eql (mutex-lock l) 0))
  23   (sb-thread:get-mutex l)
  24   (assert (eql (mutex-value l) p))
  25   (assert (eql (mutex-lock l) 0))
  26   (sb-thread:release-mutex l)
  27   (assert (eql (mutex-value l) nil))
  28   (assert (eql (mutex-lock l) 0)))
  29
  30 (let ((queue (make-waitqueue :name "queue"))
  31       (lock (make-mutex :name "lock")))
  32   (labels ((in-new-thread ()
  33              (with-mutex (lock)
  34                (assert (eql (mutex-value lock) (current-thread-id)))
  35                (format t "~A got mutex~%" (current-thread-id))
  36                ;; now drop it and sleep
  37                (condition-wait queue lock)
  38                ;; after waking we should have the lock again
  39                (assert (eql (mutex-value lock) (current-thread-id))))))
  40     (make-thread #'in-new-thread)
  41     (sleep 2)                           ; give it  a chance to start
  42     ;; check the lock is free while it's asleep
  43     (format t "parent thread ~A~%" (current-thread-id))
  44     (assert (eql (mutex-value lock) nil))
  45     (assert (eql (mutex-lock lock) 0))
  46     (with-mutex (lock)
  47       (condition-notify queue))
  48     (sleep 1)))
  49
  50 (let ((queue (make-waitqueue :name "queue"))
  51       (lock (make-mutex :name "lock")))
  52   (labels ((ours-p (value)
  53              (sb-vm:control-stack-pointer-valid-p
  54               (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value))))
  55            (in-new-thread ()
  56              (with-recursive-lock (lock)
  57                (assert (ours-p (mutex-value lock)))
  58                (format t "~A got mutex~%" (mutex-value lock))
  59                ;; now drop it and sleep
  60                (condition-wait queue lock)
  61                ;; after waking we should have the lock again
  62                (format t "woken, ~A got mutex~%" (mutex-value lock))
  63                (assert (ours-p (mutex-value lock))))))
  64     (make-thread #'in-new-thread)
  65     (sleep 2)                           ; give it  a chance to start
  66     ;; check the lock is free while it's asleep
  67     (format t "parent thread ~A~%" (current-thread-id))
  68     (assert (eql (mutex-value lock) nil))
  69     (assert (eql (mutex-lock lock) 0))
  70     (with-recursive-lock (lock)
  71       (condition-notify queue))
  72     (sleep 1)))
  73
  74 ;;; success
  75 (sb-ext:quit :unix-status 104)