From: Daniel Kochmański Date: Tue, 1 Sep 2015 15:08:14 +0000 (+0200) Subject: tests: merge multiprocessing tests (a few left) X-Git-Url: http://git.pulsar-zone.net/?a=commitdiff_plain;h=2609765524ac9f8a83dd5a1e25eae724d3028ecd;p=ecl.git tests: merge multiprocessing tests (a few left) Signed-off-by: Daniel Kochmański --- diff --git a/src/tests/bugs/mailbox-001.lsp b/src/tests/bugs/mailbox-001.lsp deleted file mode 100644 index 41837b4..0000000 --- a/src/tests/bugs/mailbox-001.lsp +++ /dev/null @@ -1,139 +0,0 @@ -;-*- 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) - diff --git a/src/tests/bugs/multiprocessing.lsp b/src/tests/bugs/multiprocessing.lsp index 77051d4..312fadd 100644 --- a/src/tests/bugs/multiprocessing.lsp +++ b/src/tests/bugs/multiprocessing.lsp @@ -42,7 +42,7 @@ creating stray processes." ,expected-value))) -;; Tests +;; Locks ;;; Date: 04/09/2009 ;;; From: Matthew Mondor @@ -82,3 +82,465 @@ creating stray processes." t) +;; 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) + + +;; 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) + + +;; 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) + + diff --git a/src/tests/bugs/mutex-001.lsp b/src/tests/bugs/mutex-001.lsp deleted file mode 100644 index 6270321..0000000 --- a/src/tests/bugs/mutex-001.lsp +++ /dev/null @@ -1,109 +0,0 @@ -;-*- 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) diff --git a/src/tests/bugs/sem-001.lsp b/src/tests/bugs/sem-001.lsp deleted file mode 100644 index e0adfe1..0000000 --- a/src/tests/bugs/sem-001.lsp +++ /dev/null @@ -1,226 +0,0 @@ -;-*- 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