From 61ef43546ba9f0209692a1569d2f033436566a02 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Mon, 19 Jun 2017 16:31:25 +0200 Subject: gpgscm: Limit the number of parallel jobs. * ffi.c (do_wait_processes): Suppress the timeout error. * tests.scm (semaphore): New definition. (test-pool): Only run a bounded number of tests in parallel. (test::started?): New function. (run-tests-parallel): Do not report results, do not start the tests. (run-tests-sequential): Adapt. (run-tests): Parse the number of parallel jobs. -- This change limits the number of tests that are run in parallel. This way we do not overwhelm the operating systems' scheduler. As a side-effect, we also get more accurate runtime information, and it will be easy to implement timeouts on top of this. Use TESTFLAGS to limit the number of jobs: $ make check-all TESTFLAGS=--parallel=16 Signed-off-by: Justus Winter --- tests/gpgscm/ffi.c | 2 + tests/gpgscm/tests.scm | 106 ++++++++++++++++++++++++++++++++++++++++++------- 2 files changed, 93 insertions(+), 15 deletions(-) (limited to 'tests') diff --git a/tests/gpgscm/ffi.c b/tests/gpgscm/ffi.c index 3af3328d3..4c03ba674 100644 --- a/tests/gpgscm/ffi.c +++ b/tests/gpgscm/ffi.c @@ -915,6 +915,8 @@ do_wait_processes (scheme *sc, pointer args) retcodes); if (err == GPG_ERR_GENERAL) err = 0; /* Let the return codes speak. */ + if (err == GPG_ERR_TIMEOUT) + err = 0; /* We may have got some results. */ for (i = 0; i < count; i++) retcodes_list = diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm index b66240d2c..a6772d1ab 100644 --- a/tests/gpgscm/tests.scm +++ b/tests/gpgscm/tests.scm @@ -498,29 +498,98 @@ ;; The main test framework. ;; +(define semaphore + (package + (define (new n) + (package + (define (acquire!?) + (if (> n 0) + (begin + (set! n (- n 1)) + #t) + #f)) + (define (release!) + (set! n (+ n 1))))))) + ;; A pool of tests. (define test-pool (package - (define (new procs) + (define (new n) (package + ;; A semaphore to restrict the number of spawned processes. + (define sem (semaphore::new n)) + + ;; A list of enqueued, but not yet run tests. + (define enqueued '()) + + ;; A list of running or finished processes. + (define procs '()) + (define (add test) - (set! procs (cons test procs)) + (if (test::started?) + (set! procs (cons test procs)) + (if (sem::acquire!?) + (add (test::run-async)) + (set! enqueued (cons test enqueued)))) (current-environment)) + + ;; Pop the last of the enqueued tests off the fifo queue. + (define (pop-test!) + (let ((i (length enqueued))) + (assert (> i 0)) + (cond + ((= i 1) + (let ((test (car enqueued))) + (set! enqueued '()) + test)) + (else + (let* ((tail (list-tail enqueued (- i 2))) + (test (cadr tail))) + (set-cdr! tail '()) + (assert (= (length enqueued) (- i 1))) + test))))) + (define (pid->test pid) (let ((t (filter (lambda (x) (= pid x::pid)) procs))) (if (null? t) #f (car t)))) (define (wait) + (if (null? enqueued) + ;; If no tests are enqueued, we can just block until all + ;; of them finished. + (wait' #t) + ;; Otherwise, we must not block, but give some tests the + ;; chance to finish so that we can start new ones. + (begin + (wait' #f) + (usleep (/ 1000000 10)) + (wait)))) + (define (wait' hang) (let ((unfinished (filter (lambda (t) (not t::retcode)) procs))) (if (null? unfinished) (current-environment) (let ((names (map (lambda (t) t::name) unfinished)) - (pids (map (lambda (t) t::pid) unfinished))) + (pids (map (lambda (t) t::pid) unfinished)) + (any #f)) (for-each (lambda (test retcode) - (test::set-end-time!) - (test:::set! 'retcode retcode)) + (unless (< retcode 0) + (test::set-end-time!) + (test:::set! 'retcode retcode) + (test::report) + (sem::release!) + (set! any #t))) (map pid->test pids) - (wait-processes (map stringify names) pids #t))))) + (wait-processes (map stringify names) pids hang)) + + ;; If some processes finished, try to start new ones. + (let loop () + (cond + ((not any) #f) + ((pair? enqueued) + (if (sem::acquire!?) + (let ((test (pop-test!))) + (add (test::run-async)) + (loop))))))))) (current-environment)) (define (filter-tests status) (filter (lambda (p) (eq? status (p::status))) procs)) @@ -629,6 +698,10 @@ (define (set-end-time!) (set! end-time (get-time))) + ;; Has the test been started yet? + (define (started?) + (number? pid)) + (define (open-log-file) (unless log-file-name (set! log-file-name (string-append (basename name) ".log"))) @@ -713,23 +786,22 @@ ;; Run the setup target to create an environment, then run all given ;; tests in parallel. -(define (run-tests-parallel tests) - (let loop ((pool (test-pool::new '())) (tests' tests)) +(define (run-tests-parallel tests n) + (let loop ((pool (test-pool::new n)) (tests' tests)) (if (null? tests') (let ((results (pool::wait))) - (for-each (lambda (t) (t::report)) (reverse results::procs)) ((results::xml) (open-output-file "report.xml")) (exit (results::report))) (let ((wd (mkdtemp-autoremove)) (test (car tests'))) (test:::set! 'directory wd) - (loop (pool::add (test::run-async)) + (loop (pool::add test) (cdr tests')))))) ;; Run the setup target to create an environment, then run all given ;; tests in sequence. (define (run-tests-sequential tests) - (let loop ((pool (test-pool::new '())) (tests' tests)) + (let loop ((pool (test-pool::new 1)) (tests' tests)) (if (null? tests') (let ((results (pool::wait))) ((results::xml) (open-output-file "report.xml")) @@ -743,10 +815,14 @@ ;; Run tests either in sequence or in parallel, depending on the ;; number of tests and the command line flags. (define (run-tests tests) - (if (and (flag "--parallel" *args*) - (> (length tests) 1)) - (run-tests-parallel tests) - (run-tests-sequential tests))) + (let ((parallel (flag "--parallel" *args*)) + (default-parallel-jobs 32)) + (if (and parallel (> (length tests) 1)) + (run-tests-parallel tests (if (and (pair? parallel) + (string->number (car parallel))) + (string->number (car parallel)) + default-parallel-jobs)) + (run-tests-sequential tests)))) ;; Load all tests from the given path. (define (load-tests . path) -- cgit v1.2.3