[Pkg-gnupg-commit] [gnupg2] 62/185: gpgscm: Limit the number of parallel jobs.
Daniel Kahn Gillmor
dkg at fifthhorseman.net
Mon Aug 7 11:55:20 UTC 2017
This is an automated email from the git hooks/post-receive script.
dkg pushed a commit to branch experimental
in repository gnupg2.
commit 61ef43546ba9f0209692a1569d2f033436566a02
Author: Justus Winter <justus at g10code.com>
Date: Mon Jun 19 16:31:25 2017 +0200
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 <justus at g10code.com>
---
tests/gpgscm/ffi.c | 2 +
tests/gpgscm/tests.scm | 106 ++++++++++++++++++++++++++++++++++++++++++-------
2 files changed, 93 insertions(+), 15 deletions(-)
diff --git a/tests/gpgscm/ffi.c b/tests/gpgscm/ffi.c
index 3af3328..4c03ba6 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 b66240d..a6772d1 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)
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-gnupg/gnupg2.git
More information about the Pkg-gnupg-commit
mailing list