contrib/sb-concurrency/tests/test-frlock.lisp

   1 ;;;; -*-  Lisp -*-
   2 ;;;;
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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.
  11
  12 (in-package :sb-concurrency-test)
  13
  14 (defmacro deftest* ((name &key fails-on) form &rest results)
  15   `(progn
  16      (when (sb-impl::featurep ',fails-on)
  17        (pushnew ',name sb-rt::*expected-failures*))
  18      (deftest ,name ,form ,@results)))
  19
  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))
  25           (a 0)
  26           (b 0)
  27           (c 0)
  28           (run! nil)
  29           (w-e! (cons :write-oops nil))
  30           (r-e! (cons :read-oops nil)))
  31       (flet ((maybe-pause (pause &optional value)
  32                (if (eq t pause)
  33                    (sb-thread:thread-yield)
  34                    (when (> pause 0)
  35                      (sleep (random pause))))
  36                value))
  37         (mapc #'join-thread
  38              (nconc
  39               (loop repeat reader-count
  40                     collect
  41                        (make-thread
  42                         (lambda ()
  43                           (loop until run! do (thread-yield))
  44                           (handler-case
  45                               (loop repeat read-count
  46                                     do (multiple-value-bind (a b c)
  47                                            (frlock-read (rw)
  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
  52                                                                  (list a b c)))))
  53                             (error (e)
  54                               (sb-ext:atomic-update (cdr r-e!) #'cons e))))))
  55               (loop repeat writer-count
  56                     collect (make-thread
  57                              (lambda ()
  58                                (loop until run! do (thread-yield))
  59                                (handler-case
  60                                    (loop repeat write-count
  61                                          do (frlock-write (rw)
  62                                               (let* ((a_ (random 10000))
  63                                                      (b_ (random 10000))
  64                                                      (c_ (+ a_ b_)))
  65                                                 (setf a a_
  66                                                       b b_
  67                                                       c (+ a b))
  68                                                 (maybe-pause inner-write-pause)
  69                                                 (unless (and (eql c c_)
  70                                                              (eql b b_)
  71                                                              (eql a a_))
  72                                                   (sb-ext:atomic-update (cdr w-e!) #'cons
  73                                                                         (list a a_ b b_ c c_)))))
  74                                             (maybe-pause outer-write-pause))
  75                                  (error (e)
  76                                    (sb-ext:atomic-update (cdr w-e!) #'cons e))))))
  77               (progn
  78                 (setf run! t)
  79                 nil))))
  80       (values (cdr w-e!) (cdr r-e!))))
  81
  82 #+sb-thread
  83 (deftest* (frlock.1 :fails-on :win32)
  84     (handler-case
  85         (sb-ext:with-timeout 60 (test-frlocks))
  86       (sb-ext:timeout (c)
  87         (error "~A" c)))
  88   nil
  89   nil)