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 (defun test-frlocks (&key (reader-count 100) (read-count 1000000)
  15                           (outer-read-pause 0) (inner-read-pause 0)
  16                           (writer-count 10) (write-count 10000)
  17                           (outer-write-pause 0.0001) (inner-write-pause 0))
  18     (let ((rw (make-frlock))
  19           (a 0)
  20           (b 0)
  21           (c 0)
  22           (run! nil)
  23           (w-e! (cons :write-oops nil))
  24           (r-e! (cons :read-oops nil)))
  25       (flet ((maybe-pause (pause &optional value)
  26                (if (eq t pause)
  27                    (sb-thread:thread-yield)
  28                    (when (> pause 0)
  29                      (sleep (random pause))))
  30                value))
  31         (mapc #'join-thread
  32              (nconc
  33               (loop repeat reader-count
  34                     collect
  35                        (make-thread
  36                         (lambda ()
  37                           (loop until run! do (thread-yield))
  38                           (handler-case
  39                               (loop repeat read-count
  40                                     do (multiple-value-bind (a b c)
  41                                            (frlock-read (rw)
  42                                              a b (maybe-pause inner-read-pause c))
  43                                          (maybe-pause outer-read-pause)
  44                                          (unless (eql c (+ a b))
  45                                            (sb-ext:atomic-update (cdr r-e!) #'cons
  46                                                                  (list a b c)))))
  47                             (error (e)
  48                               (sb-ext:atomic-update (cdr r-e!) #'cons e))))))
  49               (loop repeat writer-count
  50                     collect (make-thread
  51                              (lambda ()
  52                                (loop until run! do (thread-yield))
  53                                (handler-case
  54                                    (loop repeat write-count
  55                                          do (frlock-write (rw)
  56                                               (let* ((a_ (random 10000))
  57                                                      (b_ (random 10000))
  58                                                      (c_ (+ a_ b_)))
  59                                                 (setf a a_
  60                                                       b b_
  61                                                       c (+ a b))
  62                                                 (maybe-pause inner-write-pause)
  63                                                 (unless (and (eql c c_)
  64                                                              (eql b b_)
  65                                                              (eql a a_))
  66                                                   (sb-ext:atomic-update (cdr w-e!) #'cons
  67                                                                         (list a a_ b b_ c c_)))))
  68                                             (maybe-pause outer-write-pause))
  69                                  (error (e)
  70                                    (sb-ext:atomic-update (cdr w-e!) #'cons e))))))
  71               (progn
  72                 (setf run! t)
  73                 nil))))
  74       (values (cdr w-e!) (cdr r-e!))))
  75
  76 (deftest frlock.1
  77     (test-frlocks)
  78   nil
  79   nil)