gpgscm: Limit the number of parallel jobs.
authorJustus Winter <justus@g10code.com>
Mon, 19 Jun 2017 14:31:25 +0000 (16:31 +0200)
committerJustus Winter <justus@g10code.com>
Mon, 19 Jun 2017 14:51:32 +0000 (16:51 +0200)
* 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@g10code.com>
tests/gpgscm/ffi.c
tests/gpgscm/tests.scm

index 3af3328..4c03ba6 100644 (file)
@@ -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 =
index b66240d..a6772d1 100644 (file)
 ;; 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))
       (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")))
 
 ;; 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"))
 ;; 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)