3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package :sb-concurrency-test)
14 (defmacro deftest* ((name &key fails-on) form &rest results)
16 (when (sb-impl::featurep ',fails-on)
17 (pushnew ',name sb-rt::*expected-failures*))
18 (deftest ,name ,form ,@results)))
20 (defun test-frlocks (&key (reader-count 100) (read-count 1000000)
21 (outer-read-pause 0) (inner-read-pause 0)
22 (writer-count 10) (write-count 10000)
23 (outer-write-pause 0.0001) (inner-write-pause 0))
24 (let ((rw (make-frlock))
29 (w-e! (cons :write-oops nil))
30 (r-e! (cons :read-oops nil)))
31 (flet ((maybe-pause (pause &optional value)
33 (sb-thread:thread-yield)
35 (sleep (random pause))))
39 (loop repeat reader-count
43 (loop until run! do (thread-yield))
45 (loop repeat read-count
46 do (multiple-value-bind (a b c)
48 a b (maybe-pause inner-read-pause c))
49 (maybe-pause outer-read-pause)
50 (unless (eql c (+ a b))
51 (sb-ext:atomic-update (cdr r-e!) #'cons
54 (sb-ext:atomic-update (cdr r-e!) #'cons e))))))
55 (loop repeat writer-count
58 (loop until run! do (thread-yield))
60 (loop repeat write-count
62 (let* ((a_ (random 10000))
68 (maybe-pause inner-write-pause)
69 (unless (and (eql c c_)
72 (sb-ext:atomic-update (cdr w-e!) #'cons
73 (list a a_ b b_ c c_)))))
74 (maybe-pause outer-write-pause))
76 (sb-ext:atomic-update (cdr w-e!) #'cons e))))))
80 (values (cdr w-e!) (cdr r-e!))))
83 (deftest* (frlock.1 :fails-on :win32)
85 (sb-ext:with-timeout 60 (test-frlocks))