sfos/ecl
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

tests: improvements to stress tests

Browse source 
Use the cl-test package (same as for ordinary tests), declare suite
inside the file and remove infinite loops from tests.
This commit is contained in:
Marius Gerbershagen 2020-04-13 15:03:54 +02:00
parent 42fdbba968
commit 6825e1afe0
2 changed files with 68 additions and 60 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
src/tests/ecl-tests.lisp
View file

@ -27,9 +27,6 @@
(suite 'ecl-tests
'(make-check eformat))
(suite 'stress)
(test stress.all (finishes (1am-ecl:run)))
(defmacro is-true (form)
(ext:once-only (form)

125
src/tests/stress-tests/multiprocessing.lsp
View file

@ -4,39 +4,47 @@
;; Author: Daniel Kochmański
;; Contains: Multiprocessing stress tests
(defparameter *runs* 1000)
(in-package :cl-test)
(suite 'stress)
(defparameter *runs* 5)
;; Semaphores
;; Submitted by James M. Lawrence
;;
;; Notes: couldn't reproduce on 64-bit machine, but author uses 32-bit
;; This test uses infinite loop, this should be fixed.
(1am-ecl:test semaphore.wait/signal
(let ((message-count 10000)
(worker-count 64)
(to-workers (mp:make-semaphore))
(from-workers (mp:make-semaphore)))
(loop repeat worker-count
do (mp:process-run-function
"test"
(lambda ()
(loop
(mp:wait-on-semaphore to-workers)
(mp:signal-semaphore from-workers)))))
(test semaphore.wait/signal
(let* ((message-count 10000)
(worker-count 64)
(to-workers (mp:make-semaphore))
(from-workers (mp:make-semaphore))
(threads
(loop repeat worker-count
collect (mp:process-run-function
"test"
(lambda ()
(loop
(mp:wait-on-semaphore to-workers)
(mp:signal-semaphore from-workers)))))))
(dotimes (i *runs*)
(loop repeat message-count
do (mp:signal-semaphore to-workers))
(loop repeat message-count
do (mp:wait-on-semaphore from-workers))
(1am-ecl:is (zerop (mp:semaphore-count to-workers)))
(1am-ecl:is (zerop (mp:semaphore-count from-workers)))
(finish-output))))
(is (zerop (mp:semaphore-count to-workers)))
(is (zerop (mp:semaphore-count from-workers)))
(finish-output))
(mapcar #'mp:process-kill threads)))
;; Implementation of a semaphore using locks and condition variables
;; Submitted by James M. Lawrence
;;
;; Notes: couldn't reproduce on 64-bit machine, but author uses 32-bit
;; This test uses infinite loop, this should be fixed.
(defstruct sema
(count 0)
(lock (mp:make-lock :recursive nil))
@ -56,32 +64,35 @@
(mp:condition-variable-wait
(sema-cvar sema) (sema-lock sema)))))))
(1am-ecl:test semaphore/condition-wait
(let ((message-count 10000)
(worker-count 64)
(to-workers (make-sema))
(from-workers (make-sema)))
(loop repeat worker-count
do (mp:process-run-function
"test"
(lambda ()
(loop
(dec-sema to-workers)
(inc-sema from-workers)))))
(test semaphore/condition-wait
(let* ((message-count 10000)
(worker-count 64)
(to-workers (make-sema))
(from-workers (make-sema))
(threads
(loop repeat worker-count
collect (mp:process-run-function
"test"
(lambda ()
(loop
(dec-sema to-workers)
(inc-sema from-workers)))))))
(dotimes (i *runs*)
(loop repeat message-count
do (inc-sema to-workers))
(loop repeat message-count
do (dec-sema from-workers))
(1am-ecl:is (zerop (sema-count to-workers)))
(1am-ecl:is (zerop (sema-count from-workers)))
(finish-output))))
(is (zerop (sema-count to-workers)))
(is (zerop (sema-count from-workers)))
(finish-output))
(mapcar #'mp:process-kill threads)))
;; Implementation of a queue using locks and condition variables
;; Submitted by James M. Lawrence
;;
;; Notes: couldn't reproduce on 64-bit machine, but author uses 32-bit
;; This test uses infinite loop, this should be fixed.
(defstruct (raw-queue (:conc-name nil))
(head nil)
(tail nil))
@ -103,8 +114,6 @@
(cdr node) nil))
(values nil nil))))
;;;; queue
(defstruct queue
(impl (make-raw-queue))
(lock (mp:make-lock))
@ -125,28 +134,30 @@
(queue-cvar queue)
(queue-lock queue)))))))
;;;; qtest
(defun qtest (message-count worker-count)
(loop (let ((to-workers (make-queue))
(from-workers (make-queue)))
(loop repeat worker-count
do (mp:process-run-function
"test"
(lambda ()
(dotimes (i *runs*)
(let ((message (pop-queue to-workers)))
(push-queue message from-workers)
(unless message (return)))))))
(loop repeat message-count do (push-queue t to-workers))
(loop repeat message-count do (pop-queue from-workers))
(loop repeat worker-count do (push-queue nil to-workers))
(loop repeat worker-count do (pop-queue from-workers))
(format t ".")
(finish-output))))
(dotimes (i *runs*)
(let ((to-workers (make-queue))
(from-workers (make-queue)))
(loop repeat worker-count
do (mp:process-run-function
"test"
(lambda ()
(loop
(let ((message (pop-queue to-workers)))
(push-queue message from-workers)
(unless message (return)))))))
(loop repeat message-count do (push-queue t to-workers))
(loop repeat message-count do (pop-queue from-workers))
(loop repeat worker-count do (push-queue nil to-workers))
(loop repeat worker-count do (pop-queue from-workers))
(format t ".")
(finish-output))))
(test qtest.1 (finishes (let ((*runs* (* *runs* 10)))
(qtest 0 64)))) ; => segfault
(test qtest.2 (finishes (let ((*runs* (* *runs* 10)))
(qtest 1 64)))) ; => hang
(test qtest.3 (finishes (qtest 10000 64))) ; => error "Attempted to recursively lock..."
(1am-ecl:test qtest.1 (qtest 0 64)) ; => segfault
(1am-ecl:test qtest.2 (qtest 1 64)) ; => hang
(1am-ecl:test qtest.3 (qtest 10000 64)) ; => error "Attempted to recursively lock..."