+++ /dev/null
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Fri Apr 14 11:13:17 CEST 2006
-;;;; Contains: Multithreading API regression tests
-
-(in-package :cl-test)
-
-;;; Date: 14/04/2012
-;;; Ensure that at creation name and counter are set, and mailbox is empty.
-(deftest mailbox-make-and-counter
- (loop with name = "mbox-make-and-counter"
- for count from 4 to 63
- for mbox = (mp:make-mailbox :name name :count count)
- always (and (eq (mp:mailbox-name mbox) name)
- (>= (mp:mailbox-count mbox) count)
- (mp:mailbox-empty-p mbox)
- t))
- t)
-
-;;; Date: 14/04/2012
-;;; Ensure that the mailbox works in a nonblocking fashion (when the
-;;; number of messages < mailbox size in a single producer and single
-;;; consumer setting. We do not need to create new threads for this.
-(deftest mbox-mailbox-nonblocking-io-1-to-1
- (loop with count = 30
- with name = "mbox-mailbox-nonblocking-io-1-to-1"
- with mbox = (mp:make-mailbox :name name :count count)
- for l from 1 to 10
- for messages = (loop for i from 1 to l
- do (mp:mailbox-send mbox i)
- collect i)
- always
- (and (not (mp:mailbox-empty-p mbox))
- (equalp (loop for i from 1 to l
- collect (mp:mailbox-read mbox))
- messages)
- (mp:mailbox-empty-p mbox)
- t))
- t)
-
-;;; Date: 14/04/2012
-;;; The mailbox blocks a process when it saturates the write queue.
-(def-mp-test mbox-blocks-1-to-1
- (let* ((flag nil)
- (mbox (mp:make-mailbox :name "mbox-signal-one" :count 32))
- (size (mp:mailbox-count mbox))
- (a-process (mp:process-run-function
- "mbox-signal-one-process"
- #'(lambda ()
- ;; This does not block
- (loop for i from 1 to size
- do (mp:mailbox-send mbox i))
- ;; Here we block
- (setf flag t)
- (mp:mailbox-send mbox (1+ size))
- ;; Now we unblock
- (setf flag nil)))))
- (sleep 0.2) ; give time for all messages to arrive
- (and (not (mp:mailbox-empty-p mbox)) ; the queue has messages
- (mp:process-active-p a-process) ; the process is active
- flag ; and it is blocked
- (loop for i from 1 to (1+ size) ; messages arrive in order
- always (= i (mp:mailbox-read mbox)))
- (null flag) ; and process unblocked
- (mp:mailbox-empty-p mbox)
- t))
- t)
-
-;;; Date: 14/04/2012
-;;; N producers and 1 consumer
-(def-mp-test mbox-n-to-1-communication
- (loop with length = 10000
- with mbox = (mp:make-mailbox :name "mbox-n-to-1-communication" :count 128)
- for n from 1 to 10
- for m = (round length n)
- for messages = (loop for i from 0 below (* n m) collect i)
- for producers = (loop for i from 0 below n
- do (mp:process-run-function
- "mbox-n-to-1-producer"
- (let ((proc-no i))
- #'(lambda ()
- (loop for i from 0 below m
- for msg = (+ i (* proc-no m))
- do (mp:mailbox-send mbox msg))))))
- always (and (equalp
- (sort (loop for i from 1 to (* n m)
- collect (mp:mailbox-read mbox))
- #'<)
- messages)
- (mp:mailbox-empty-p mbox)))
- t)
-
-;;; Date: 14/04/2012
-;;; 1 producer and N consumer, but they do not block, because the
-;;; queue is large enough and pre-filled with messages
-(def-mp-test mbox-1-to-n-non-blocking
- (loop with lock = (mp:make-lock :name "mbox-1-to-n-communication")
- for n from 1 to 10
- for m = (round 128 n)
- for length = (* n m)
- for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length)
- for flags = (make-array length :initial-element nil)
- for aux = (loop for i from 0 below length
- do (mp:mailbox-send mbox i))
- for producers = (loop for i from 0 below n
- do (mp:process-run-function
- "mbox-1-to-n-consumer"
- #'(lambda ()
- (loop for i from 0 below m
- for msg = (mp:mailbox-read mbox)
- do (setf (aref flags msg) t)))))
- do (sleep 0.1)
- always (and (every #'identity flags)
- (mp:mailbox-empty-p mbox)))
- t)
-
-;;; Date: 14/04/2012
-;;; 1 producer and N consumers, which block, because the producer
-;;; is started _after_ them and is slower.
-(def-mp-test mbox-1-to-n-blocking
- (loop for n from 1 to 10
- for m = (round 10000 n)
- for length = (* n m)
- for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length)
- for flags = (make-array length :initial-element nil)
- for producers = (loop for i from 0 below n
- do (mp:process-run-function
- "mbox-1-to-n-consumer"
- #'(lambda ()
- (loop for i from 0 below m
- for msg = (mp:mailbox-read mbox)
- do (setf (aref flags msg) t)))))
- do (loop for i from 0 below length
- do (mp:mailbox-send mbox i))
- do (sleep 0.1)
- always (and (every #'identity flags)
- (mp:mailbox-empty-p mbox)))
- t)
-
,expected-value)))
\f
-;; Tests
+;; Locks
;;; Date: 04/09/2009
;;; From: Matthew Mondor
t)
\f
+;; Semaphores
+
+;;; Date: 14/04/2012
+;;; Ensure that at creation name and counter are set
+(deftest sem-make-and-counter
+ (loop with name = "sem-make-and-counter"
+ for count from 0 to 10
+ for sem = (mp:make-semaphore :name name :count count)
+ always (and (eq (mp:semaphore-name sem) name)
+ (= (mp:semaphore-count sem) count)
+ (zerop (mp:semaphore-wait-count sem))))
+ t)
+
+;;; Date: 14/04/2012
+;;; Ensure that signal changes the counter by the specified amount
+(deftest sem-signal-semaphore-count
+ (loop with name = "sem-signal-semaphore-count"
+ for count from 0 to 10
+ always (loop for delta from 0 to 10
+ for sem = (mp:make-semaphore :name name :count count)
+ always (and (= (mp:semaphore-count sem) count)
+ (null (mp:signal-semaphore sem delta))
+ (= (mp:semaphore-count sem ) (+ count delta)))))
+ t)
+
+;;; Date: 14/04/2012
+;;; A semaphore with a count of zero blocks a process
+(def-mp-test sem-signal-one-process
+ (let* ((flag nil)
+ (sem (mp:make-semaphore :name "sem-signal-one"))
+ (a-process (mp:process-run-function
+ "sem-signal-one-process"
+ #'(lambda ()
+ (mp:wait-on-semaphore sem)
+ (setf flag t)))))
+ (and (null flag)
+ (mp:process-active-p a-process)
+ (progn (mp:signal-semaphore sem) (sleep 0.2) flag)
+ (= (mp:semaphore-count sem) 0)))
+ t)
+
+;;; Date: 14/04/2012
+;;; We can signal multiple processes
+(def-mp-test sem-signal-n-processes
+ (loop for count from 1 upto 10 always
+ (let* ((counter 0)
+ (lock (mp:make-lock :name "sem-signal-n-processes"))
+ (sem (mp:make-semaphore :name "sem-signal-n-processs"))
+ (all-process
+ (loop for i from 1 upto count
+ collect (mp:process-run-function
+ "sem-signal-n-processes"
+ #'(lambda ()
+ (mp:wait-on-semaphore sem)
+ (mp:with-lock (lock) (incf counter)))))))
+ (and (zerop counter)
+ (every #'mp:process-active-p all-process)
+ (= (mp:semaphore-wait-count sem) count)
+ (progn (mp:signal-semaphore sem count) (sleep 0.2)
+ (= counter count))
+ (= (mp:semaphore-count sem) 0))))
+ t)
+
+;;; Date: 14/04/2012
+;;; When we signal N processes and N+M are waiting, only N awake
+(def-mp-test sem-signal-only-n-processes
+ (loop for m from 1 upto 3 always
+ (loop for n from 1 upto 4 always
+ (let* ((counter 0)
+ (lock (mp:make-lock :name "sem-signal-n-processes"))
+ (sem (mp:make-semaphore :name "sem-signal-n-processs"))
+ (all-process
+ (loop for i from 1 upto (+ n m)
+ collect (mp:process-run-function
+ "sem-signal-n-processes"
+ #'(lambda ()
+ (mp:wait-on-semaphore sem)
+ (mp:with-lock (lock) (incf counter)))))))
+ (and (zerop counter)
+ (every #'mp:process-active-p all-process)
+ (= (mp:semaphore-wait-count sem) (+ m n))
+ (progn (mp:signal-semaphore sem n) (sleep 0.02)
+ (= counter n))
+ (= (mp:semaphore-wait-count sem) m)
+ (progn (mp:signal-semaphore sem m) (sleep 0.02)
+ (= counter (+ n m)))
+ ))))
+ t)
+
+;;; Date: 14/04/2012
+;;; It is possible to kill processes waiting for a semaphore.
+;;;
+(def-mp-test sem-interruptible
+ (loop with sem = (mp:make-semaphore :name "sem-interruptible")
+ with flag = nil
+ for count from 1 to 10
+ for all-processes = (loop for i from 1 upto count
+ collect (mp:process-run-function
+ "sem-interruptible"
+ #'(lambda ()
+ (mp:wait-on-semaphore sem)
+ (setf flag t))))
+ always (and (progn (sleep 0.2) (null flag))
+ (every #'mp:process-active-p all-processes)
+ (= (mp:semaphore-wait-count sem) count)
+ (mapc #'mp:process-kill all-processes)
+ (progn (sleep 0.2) (notany #'mp:process-active-p all-processes))
+ (null flag)
+ (zerop (mp:semaphore-wait-count sem))
+ t))
+ t)
+
+;;; Date: 14/04/2012
+;;; When we kill a process, it is removed from the wait queue.
+;;;
+(def-mp-test sem-interrupt-updates-queue
+ (let* ((sem (mp:make-semaphore :name "sem-interrupt-updates-queue"))
+ (process (mp:process-run-function
+ "sem-interrupt-updates-queue"
+ #'(lambda () (mp:wait-on-semaphore sem)))))
+ (sleep 0.2)
+ (and (= (mp:semaphore-wait-count sem) 1)
+ (mp:process-active-p process)
+ (progn (mp:process-kill process)
+ (sleep 0.2)
+ (not (mp:process-active-p process)))
+ (zerop (mp:semaphore-wait-count sem))
+ t))
+ t)
+
+;;; Date: 14/04/2012
+;;; When we kill a process, it signals another one. This is tricky,
+;;; because we need the awake signal to arrive _after_ the process is
+;;; killed, but the process must still be in the queue for the semaphore
+;;; to awake it. The way we solve this is by intercepting the kill signal.
+;;;
+(def-mp-test sem-interrupted-resignals
+ (let* ((sem (mp:make-semaphore :name "sem-interrupted-resignals"))
+ (flag1 nil)
+ (flag2 nil)
+ (process1 (mp:process-run-function
+ "sem-interrupted-resignals"
+ #'(lambda ()
+ (unwind-protect
+ (mp:wait-on-semaphore sem)
+ (sleep 4)
+ (setf flag1 t)
+ ))))
+ (process2 (mp:process-run-function
+ "sem-interrupted-resignals"
+ #'(lambda ()
+ (mp:wait-on-semaphore sem)
+ (setf flag2 t)))))
+ (sleep 0.2)
+ (and (= (mp:semaphore-wait-count sem) 2)
+ (mp:process-active-p process1)
+ (mp:process-active-p process2)
+ ;; We kill the process but ensure it is still running
+ (progn (mp:process-kill process1)
+ (mp:process-active-p process1))
+ (null flag1)
+ ;; ... and in the queue
+ (= (mp:semaphore-wait-count sem) 2)
+ ;; We awake it and it should awake the other one
+ (progn (format t "~%;;; Signaling semaphore")
+ (mp:signal-semaphore sem)
+ (sleep 1)
+ (zerop (mp:semaphore-wait-count sem)))
+ flag2
+ t))
+ t)
+
+;;; Date: 14/04/2012
+;;; 1 producer and N consumers, non-blocking, because the initial count
+;;; is larger than the consumed data.
+(def-mp-test sem-1-to-n-non-blocking
+ (loop with counter = 0
+ with lock = (mp:make-lock :name "sem-1-to-n-communication")
+ for n from 1 to 10
+ for m = (round 128 n)
+ for length = (* n m)
+ for sem = (mp:make-semaphore :name "sem-1-to-n-communication" :count length)
+ for producers = (progn
+ (setf counter 0)
+ (loop for i from 0 below n
+ collect (mp:process-run-function
+ "sem-1-to-n-consumer"
+ #'(lambda ()
+ (loop for i from 0 below m
+ do (mp:wait-on-semaphore sem)
+ do (mp:with-lock (lock) (incf counter)))))))
+ do (mapc #'mp:process-join producers)
+ always (and (= counter length)
+ (zerop (mp:semaphore-count sem))
+ (zerop (mp:semaphore-wait-count sem))))
+ t)
+
+;;; Date: 14/04/2012
+;;; 1 producer and N consumers, blocking due to a slow producer.
+(def-mp-test sem-1-to-n-blocking
+ (loop with lock = (mp:make-lock :name "sem-1-to-n-communication")
+ for n from 1 to 10
+ for m = (round 10000 n)
+ for length = (* n m)
+ for sem = (mp:make-semaphore :name "sem-1-to-n-communication" :count 0)
+ for counter = 0
+ for producers = (loop for i from 0 below n
+ collect (mp:process-run-function
+ "sem-1-to-n-consumer"
+ #'(lambda ()
+ (loop for i from 0 below m
+ do (mp:wait-on-semaphore sem))
+ (mp:with-lock (lock) (incf counter)))))
+ do (loop for i from 0 below length
+ do (mp:signal-semaphore sem))
+ do (mapc #'mp:process-join producers)
+ always (and (= counter n)
+ (zerop (mp:semaphore-count sem))
+ (zerop (mp:semaphore-wait-count sem))))
+ t)
+
+\f
+;; Mutexes
+;;; Date: 12/04/2012
+;;; Non-recursive mutexes should signal an error when they
+;;; cannot be relocked.
+(deftest mutex-001-recursive-error
+ (let* ((mutex (mp:make-lock :name 'mutex-001-recursive-error)))
+ (and
+ (mp:get-lock mutex)
+ (eq (mp:lock-owner mutex) mp:*current-process*)
+ (handler-case
+ (progn (mp:get-lock mutex) nil)
+ (error (c) t))
+ (mp:giveup-lock mutex)
+ (null (mp:lock-owner mutex))
+ (zerop (mp:lock-count mutex))
+ t))
+ t)
+
+;;; Date: 12/04/2012
+;;; Recursive locks increase the counter.
+(deftest mutex-002-recursive-count
+ (let* ((mutex (mp:make-lock :name 'mutex-002-recursive-count :recursive t)))
+ (and
+ (loop for i from 1 upto 10
+ always (and (mp:get-lock mutex)
+ (= (mp:lock-count mutex) i)
+ (eq (mp:lock-owner mutex) mp:*current-process*)))
+ (loop for i from 9 downto 0
+ always (and (eq (mp:lock-owner mutex) mp:*current-process*)
+ (mp:giveup-lock mutex)
+ (= (mp:lock-count mutex) i)))
+ (null (mp:lock-owner mutex))
+ (zerop (mp:lock-count mutex))
+ t))
+ t)
+
+
+;;; Date: 12/04/2012
+;;; When multiple threads compete for a mutex, they should
+;;; all get the same chance of accessing the resource
+;;;
+(def-mp-test mutex-003-fairness
+ (let* ((mutex (mp:make-lock :name 'mutex-001-fairness))
+ (nthreads 10)
+ (count 10)
+ (counter (* nthreads count))
+ (array (make-array count :element-type 'fixnum :initial-element 0)))
+ (flet ((slave (n)
+ (loop with continue = t
+ for i from 1 by 1
+ while continue do
+ (mp:get-lock mutex)
+ (cond ((plusp counter)
+ (decf counter)
+ (setf (aref array n) i))
+ (t
+ (setf continue nil)))
+ (mp:giveup-lock mutex))))
+ ;; Launch all agents. They will be locked
+ (let ((all-processes
+ (mp:with-lock (mutex)
+ (loop for n from 0 below nthreads
+ collect (mp:process-run-function n #'slave n)
+ ;; ... and give them some time to block on this mutex
+ finally (sleep 1)))))
+ ;; Now they are released and operate. They should all have
+ ;; the same share of counts.
+ (loop for p in all-processes
+ do (mp:process-join p))
+ (loop for i from 0 below nthreads
+ always (= (aref array i) count)))))
+ t)
+
+;;; Date: 12/04/2012
+;;; It is possible to kill processes waiting for a lock. We launch a lot of
+;;; processes, 50% of which are zombies: they acquire the lock and do not
+;;; do anything. These processes are then killed, resulting in the others
+;;; doing their job.
+;;;
+(def-mp-test mutex-004-interruptible
+ (let* ((mutex (mp:make-lock :name "mutex-003-fairness"))
+ (nprocesses 20)
+ (counter 0))
+ (flet ((normal-thread ()
+ (mp:with-lock (mutex)
+ (incf counter)))
+ (zombie-thread ()
+ (mp:with-lock (mutex)
+ (loop (sleep 10)))))
+ (let* ((all-processes (loop for i from 0 below nprocesses
+ for zombie = (zerop (mod i 2))
+ for fn = (if zombie #'zombie-thread #'normal-thread)
+ collect (cons zombie
+ (mp:process-run-function
+ "mutex-003-fairness"
+ fn))))
+ (zombies (mapcar #'cdr (remove-if-not #'car all-processes))))
+ (and (zerop counter) ; No proces works because the first one is a zombie
+ (kill-and-wait zombies)
+ (progn (sleep 0.2) (= counter (/ nprocesses 2)))
+ (not (mp:lock-owner mutex))
+ t))))
+ t)
+
+\f
+;; Mailbox
+
+;;; Date: 14/04/2012
+;;; Ensure that at creation name and counter are set, and mailbox is empty.
+(deftest mailbox-make-and-counter
+ (loop with name = "mbox-make-and-counter"
+ for count from 4 to 63
+ for mbox = (mp:make-mailbox :name name :count count)
+ always (and (eq (mp:mailbox-name mbox) name)
+ (>= (mp:mailbox-count mbox) count)
+ (mp:mailbox-empty-p mbox)
+ t))
+ t)
+
+;;; Date: 14/04/2012
+;;; Ensure that the mailbox works in a nonblocking fashion (when the
+;;; number of messages < mailbox size in a single producer and single
+;;; consumer setting. We do not need to create new threads for this.
+(deftest mbox-mailbox-nonblocking-io-1-to-1
+ (loop with count = 30
+ with name = "mbox-mailbox-nonblocking-io-1-to-1"
+ with mbox = (mp:make-mailbox :name name :count count)
+ for l from 1 to 10
+ for messages = (loop for i from 1 to l
+ do (mp:mailbox-send mbox i)
+ collect i)
+ always
+ (and (not (mp:mailbox-empty-p mbox))
+ (equalp (loop for i from 1 to l
+ collect (mp:mailbox-read mbox))
+ messages)
+ (mp:mailbox-empty-p mbox)
+ t))
+ t)
+
+;;; Date: 14/04/2012
+;;; The mailbox blocks a process when it saturates the write queue.
+(def-mp-test mbox-blocks-1-to-1
+ (let* ((flag nil)
+ (mbox (mp:make-mailbox :name "mbox-signal-one" :count 32))
+ (size (mp:mailbox-count mbox))
+ (a-process (mp:process-run-function
+ "mbox-signal-one-process"
+ #'(lambda ()
+ ;; This does not block
+ (loop for i from 1 to size
+ do (mp:mailbox-send mbox i))
+ ;; Here we block
+ (setf flag t)
+ (mp:mailbox-send mbox (1+ size))
+ ;; Now we unblock
+ (setf flag nil)))))
+ (sleep 0.2) ; give time for all messages to arrive
+ (and (not (mp:mailbox-empty-p mbox)) ; the queue has messages
+ (mp:process-active-p a-process) ; the process is active
+ flag ; and it is blocked
+ (loop for i from 1 to (1+ size) ; messages arrive in order
+ always (= i (mp:mailbox-read mbox)))
+ (null flag) ; and process unblocked
+ (mp:mailbox-empty-p mbox)
+ t))
+ t)
+
+;;; Date: 14/04/2012
+;;; N producers and 1 consumer
+(def-mp-test mbox-n-to-1-communication
+ (loop with length = 10000
+ with mbox = (mp:make-mailbox :name "mbox-n-to-1-communication" :count 128)
+ for n from 1 to 10
+ for m = (round length n)
+ for messages = (loop for i from 0 below (* n m) collect i)
+ for producers = (loop for i from 0 below n
+ do (mp:process-run-function
+ "mbox-n-to-1-producer"
+ (let ((proc-no i))
+ #'(lambda ()
+ (loop for i from 0 below m
+ for msg = (+ i (* proc-no m))
+ do (mp:mailbox-send mbox msg))))))
+ always (and (equalp
+ (sort (loop for i from 1 to (* n m)
+ collect (mp:mailbox-read mbox))
+ #'<)
+ messages)
+ (mp:mailbox-empty-p mbox)))
+ t)
+
+;;; Date: 14/04/2012
+;;; 1 producer and N consumer, but they do not block, because the
+;;; queue is large enough and pre-filled with messages
+(def-mp-test mbox-1-to-n-non-blocking
+ (loop with lock = (mp:make-lock :name "mbox-1-to-n-communication")
+ for n from 1 to 10
+ for m = (round 128 n)
+ for length = (* n m)
+ for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length)
+ for flags = (make-array length :initial-element nil)
+ for aux = (loop for i from 0 below length
+ do (mp:mailbox-send mbox i))
+ for producers = (loop for i from 0 below n
+ do (mp:process-run-function
+ "mbox-1-to-n-consumer"
+ #'(lambda ()
+ (loop for i from 0 below m
+ for msg = (mp:mailbox-read mbox)
+ do (setf (aref flags msg) t)))))
+ do (sleep 0.1)
+ always (and (every #'identity flags)
+ (mp:mailbox-empty-p mbox)))
+ t)
+
+;;; Date: 14/04/2012
+;;; 1 producer and N consumers, which block, because the producer
+;;; is started _after_ them and is slower.
+(def-mp-test mbox-1-to-n-blocking
+ (loop for n from 1 to 10
+ for m = (round 10000 n)
+ for length = (* n m)
+ for mbox = (mp:make-mailbox :name "mbox-1-to-n-communication" :count length)
+ for flags = (make-array length :initial-element nil)
+ for producers = (loop for i from 0 below n
+ do (mp:process-run-function
+ "mbox-1-to-n-consumer"
+ #'(lambda ()
+ (loop for i from 0 below m
+ for msg = (mp:mailbox-read mbox)
+ do (setf (aref flags msg) t)))))
+ do (loop for i from 0 below length
+ do (mp:mailbox-send mbox i))
+ do (sleep 0.1)
+ always (and (every #'identity flags)
+ (mp:mailbox-empty-p mbox)))
+ t)
+
+\f
+++ /dev/null
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Fri Apr 12 CEST 2012
-;;;; Contains: Mutex tests
-
-(in-package :cl-test)
-
-;;; Date: 12/04/2012
-;;; Non-recursive mutexes should signal an error when they
-;;; cannot be relocked.
-(deftest mutex-001-recursive-error
- (let* ((mutex (mp:make-lock :name 'mutex-001-recursive-error)))
- (and
- (mp:get-lock mutex)
- (eq (mp:lock-owner mutex) mp:*current-process*)
- (handler-case
- (progn (mp:get-lock mutex) nil)
- (error (c) t))
- (mp:giveup-lock mutex)
- (null (mp:lock-owner mutex))
- (zerop (mp:lock-count mutex))
- t))
- t)
-
-;;; Date: 12/04/2012
-;;; Recursive locks increase the counter.
-(deftest mutex-002-recursive-count
- (let* ((mutex (mp:make-lock :name 'mutex-002-recursive-count :recursive t)))
- (and
- (loop for i from 1 upto 10
- always (and (mp:get-lock mutex)
- (= (mp:lock-count mutex) i)
- (eq (mp:lock-owner mutex) mp:*current-process*)))
- (loop for i from 9 downto 0
- always (and (eq (mp:lock-owner mutex) mp:*current-process*)
- (mp:giveup-lock mutex)
- (= (mp:lock-count mutex) i)))
- (null (mp:lock-owner mutex))
- (zerop (mp:lock-count mutex))
- t))
- t)
-
-
-;;; Date: 12/04/2012
-;;; When multiple threads compete for a mutex, they should
-;;; all get the same chance of accessing the resource
-;;;
-(def-mp-test mutex-003-fairness
- (let* ((mutex (mp:make-lock :name 'mutex-001-fairness))
- (nthreads 10)
- (count 10)
- (counter (* nthreads count))
- (array (make-array count :element-type 'fixnum :initial-element 0)))
- (flet ((slave (n)
- (loop with continue = t
- for i from 1 by 1
- while continue do
- (mp:get-lock mutex)
- (cond ((plusp counter)
- (decf counter)
- (setf (aref array n) i))
- (t
- (setf continue nil)))
- (mp:giveup-lock mutex))))
- ;; Launch all agents. They will be locked
- (let ((all-processes
- (mp:with-lock (mutex)
- (loop for n from 0 below nthreads
- collect (mp:process-run-function n #'slave n)
- ;; ... and give them some time to block on this mutex
- finally (sleep 1)))))
- ;; Now they are released and operate. They should all have
- ;; the same share of counts.
- (loop for p in all-processes
- do (mp:process-join p))
- (loop for i from 0 below nthreads
- always (= (aref array i) count)))))
- t)
-
-;;; Date: 12/04/2012
-;;; It is possible to kill processes waiting for a lock. We launch a lot of
-;;; processes, 50% of which are zombies: they acquire the lock and do not
-;;; do anything. These processes are then killed, resulting in the others
-;;; doing their job.
-;;;
-(def-mp-test mutex-004-interruptible
- (let* ((mutex (mp:make-lock :name "mutex-003-fairness"))
- (nprocesses 20)
- (counter 0))
- (flet ((normal-thread ()
- (mp:with-lock (mutex)
- (incf counter)))
- (zombie-thread ()
- (mp:with-lock (mutex)
- (loop (sleep 10)))))
- (let* ((all-processes (loop for i from 0 below nprocesses
- for zombie = (zerop (mod i 2))
- for fn = (if zombie #'zombie-thread #'normal-thread)
- collect (cons zombie
- (mp:process-run-function
- "mutex-003-fairness"
- fn))))
- (zombies (mapcar #'cdr (remove-if-not #'car all-processes))))
- (and (zerop counter) ; No proces works because the first one is a zombie
- (kill-and-wait zombies)
- (progn (sleep 0.2) (= counter (/ nprocesses 2)))
- (not (mp:lock-owner mutex))
- t))))
- t)
+++ /dev/null
-;-*- Mode: Lisp -*-
-;;;; Author: Juan Jose Garcia-Ripoll
-;;;; Created: Fri Apr 14 11:13:17 CEST 2006
-;;;; Contains: Multithreading API regression tests
-
-(in-package :cl-test)
-
-;;; Date: 14/04/2012
-;;; Ensure that at creation name and counter are set
-(deftest sem-make-and-counter
- (loop with name = "sem-make-and-counter"
- for count from 0 to 10
- for sem = (mp:make-semaphore :name name :count count)
- always (and (eq (mp:semaphore-name sem) name)
- (= (mp:semaphore-count sem) count)
- (zerop (mp:semaphore-wait-count sem))))
- t)
-
-;;; Date: 14/04/2012
-;;; Ensure that signal changes the counter by the specified amount
-(deftest sem-signal-semaphore-count
- (loop with name = "sem-signal-semaphore-count"
- for count from 0 to 10
- always (loop for delta from 0 to 10
- for sem = (mp:make-semaphore :name name :count count)
- always (and (= (mp:semaphore-count sem) count)
- (null (mp:signal-semaphore sem delta))
- (= (mp:semaphore-count sem ) (+ count delta)))))
- t)
-
-;;; Date: 14/04/2012
-;;; A semaphore with a count of zero blocks a process
-(def-mp-test sem-signal-one-process
- (let* ((flag nil)
- (sem (mp:make-semaphore :name "sem-signal-one"))
- (a-process (mp:process-run-function
- "sem-signal-one-process"
- #'(lambda ()
- (mp:wait-on-semaphore sem)
- (setf flag t)))))
- (and (null flag)
- (mp:process-active-p a-process)
- (progn (mp:signal-semaphore sem) (sleep 0.2) flag)
- (= (mp:semaphore-count sem) 0)))
- t)
-
-;;; Date: 14/04/2012
-;;; We can signal multiple processes
-(def-mp-test sem-signal-n-processes
- (loop for count from 1 upto 10 always
- (let* ((counter 0)
- (lock (mp:make-lock :name "sem-signal-n-processes"))
- (sem (mp:make-semaphore :name "sem-signal-n-processs"))
- (all-process
- (loop for i from 1 upto count
- collect (mp:process-run-function
- "sem-signal-n-processes"
- #'(lambda ()
- (mp:wait-on-semaphore sem)
- (mp:with-lock (lock) (incf counter)))))))
- (and (zerop counter)
- (every #'mp:process-active-p all-process)
- (= (mp:semaphore-wait-count sem) count)
- (progn (mp:signal-semaphore sem count) (sleep 0.2)
- (= counter count))
- (= (mp:semaphore-count sem) 0))))
- t)
-
-;;; Date: 14/04/2012
-;;; When we signal N processes and N+M are waiting, only N awake
-(def-mp-test sem-signal-only-n-processes
- (loop for m from 1 upto 3 always
- (loop for n from 1 upto 4 always
- (let* ((counter 0)
- (lock (mp:make-lock :name "sem-signal-n-processes"))
- (sem (mp:make-semaphore :name "sem-signal-n-processs"))
- (all-process
- (loop for i from 1 upto (+ n m)
- collect (mp:process-run-function
- "sem-signal-n-processes"
- #'(lambda ()
- (mp:wait-on-semaphore sem)
- (mp:with-lock (lock) (incf counter)))))))
- (and (zerop counter)
- (every #'mp:process-active-p all-process)
- (= (mp:semaphore-wait-count sem) (+ m n))
- (progn (mp:signal-semaphore sem n) (sleep 0.02)
- (= counter n))
- (= (mp:semaphore-wait-count sem) m)
- (progn (mp:signal-semaphore sem m) (sleep 0.02)
- (= counter (+ n m)))
- ))))
- t)
-
-;;; Date: 14/04/2012
-;;; It is possible to kill processes waiting for a semaphore.
-;;;
-(def-mp-test sem-interruptible
- (loop with sem = (mp:make-semaphore :name "sem-interruptible")
- with flag = nil
- for count from 1 to 10
- for all-processes = (loop for i from 1 upto count
- collect (mp:process-run-function
- "sem-interruptible"
- #'(lambda ()
- (mp:wait-on-semaphore sem)
- (setf flag t))))
- always (and (progn (sleep 0.2) (null flag))
- (every #'mp:process-active-p all-processes)
- (= (mp:semaphore-wait-count sem) count)
- (mapc #'mp:process-kill all-processes)
- (progn (sleep 0.2) (notany #'mp:process-active-p all-processes))
- (null flag)
- (zerop (mp:semaphore-wait-count sem))
- t))
- t)
-
-;;; Date: 14/04/2012
-;;; When we kill a process, it is removed from the wait queue.
-;;;
-(def-mp-test sem-interrupt-updates-queue
- (let* ((sem (mp:make-semaphore :name "sem-interrupt-updates-queue"))
- (process (mp:process-run-function
- "sem-interrupt-updates-queue"
- #'(lambda () (mp:wait-on-semaphore sem)))))
- (sleep 0.2)
- (and (= (mp:semaphore-wait-count sem) 1)
- (mp:process-active-p process)
- (progn (mp:process-kill process)
- (sleep 0.2)
- (not (mp:process-active-p process)))
- (zerop (mp:semaphore-wait-count sem))
- t))
- t)
-
-;;; Date: 14/04/2012
-;;; When we kill a process, it signals another one. This is tricky,
-;;; because we need the awake signal to arrive _after_ the process is
-;;; killed, but the process must still be in the queue for the semaphore
-;;; to awake it. The way we solve this is by intercepting the kill signal.
-;;;
-(def-mp-test sem-interrupted-resignals
- (let* ((sem (mp:make-semaphore :name "sem-interrupted-resignals"))
- (flag1 nil)
- (flag2 nil)
- (process1 (mp:process-run-function
- "sem-interrupted-resignals"
- #'(lambda ()
- (unwind-protect
- (mp:wait-on-semaphore sem)
- (sleep 4)
- (setf flag1 t)
- ))))
- (process2 (mp:process-run-function
- "sem-interrupted-resignals"
- #'(lambda ()
- (mp:wait-on-semaphore sem)
- (setf flag2 t)))))
- (sleep 0.2)
- (and (= (mp:semaphore-wait-count sem) 2)
- (mp:process-active-p process1)
- (mp:process-active-p process2)
- ;; We kill the process but ensure it is still running
- (progn (mp:process-kill process1)
- (mp:process-active-p process1))
- (null flag1)
- ;; ... and in the queue
- (= (mp:semaphore-wait-count sem) 2)
- ;; We awake it and it should awake the other one
- (progn (format t "~%;;; Signaling semaphore")
- (mp:signal-semaphore sem)
- (sleep 1)
- (zerop (mp:semaphore-wait-count sem)))
- flag2
- t))
- t)
-
-;;; Date: 14/04/2012
-;;; 1 producer and N consumers, non-blocking, because the initial count
-;;; is larger than the consumed data.
-(def-mp-test sem-1-to-n-non-blocking
- (loop with counter = 0
- with lock = (mp:make-lock :name "sem-1-to-n-communication")
- for n from 1 to 10
- for m = (round 128 n)
- for length = (* n m)
- for sem = (mp:make-semaphore :name "sem-1-to-n-communication" :count length)
- for producers = (progn
- (setf counter 0)
- (loop for i from 0 below n
- collect (mp:process-run-function
- "sem-1-to-n-consumer"
- #'(lambda ()
- (loop for i from 0 below m
- do (mp:wait-on-semaphore sem)
- do (mp:with-lock (lock) (incf counter)))))))
- do (mapc #'mp:process-join producers)
- always (and (= counter length)
- (zerop (mp:semaphore-count sem))
- (zerop (mp:semaphore-wait-count sem))))
- t)
-
-;;; Date: 14/04/2012
-;;; 1 producer and N consumers, blocking due to a slow producer.
-(def-mp-test sem-1-to-n-blocking
- (loop with lock = (mp:make-lock :name "sem-1-to-n-communication")
- for n from 1 to 10
- for m = (round 10000 n)
- for length = (* n m)
- for sem = (mp:make-semaphore :name "sem-1-to-n-communication" :count 0)
- for counter = 0
- for producers = (loop for i from 0 below n
- collect (mp:process-run-function
- "sem-1-to-n-consumer"
- #'(lambda ()
- (loop for i from 0 below m
- do (mp:wait-on-semaphore sem))
- (mp:with-lock (lock) (incf counter)))))
- do (loop for i from 0 below length
- do (mp:signal-semaphore sem))
- do (mapc #'mp:process-join producers)
- always (and (= counter n)
- (zerop (mp:semaphore-count sem))
- (zerop (mp:semaphore-wait-count sem))))
- t)
-4
Repositories / ecl.git / commitdiff