Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -115,24 +115,25 @@ (define (runs:can-run-more-tests db test-record) (let* ((tconfig (tests:testqueue-get-testconfig test-record)) (jobgroup (config-lookup tconfig "requirements" "jobgroup")) (num-running (db:get-count-tests-running db)) (num-running-in-jobgroup (db:get-count-tests-running-in-jobgroup db jobgroup)) - (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")) + (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) + (if (and mcj (string->number mcj)) + (string->number mcj) + #f))) (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) (if (not (eq? *last-num-running-tests* num-running)) (begin (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) (set! *last-num-running-tests* num-running))) (if (not (eq? 0 *globalexitstatus*)) - #f + (list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit) (let ((can-not-run-more (cond ;; if max-concurrent-jobs is set and the number running is greater ;; than it than cannot run more jobs - ((and max-concurrent-jobs - (string->number max-concurrent-jobs) - (>= num-running (string->number max-concurrent-jobs))) + ((and max-concurrent-jobs (>= num-running max-concurrent-jobs)) (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running ", max_concurrent_jobs: " max-concurrent-jobs) #t) ;; if job-group-limit is set and number of jobs in the group is greater ;; than the limit then cannot run more jobs of this kind @@ -140,11 +141,11 @@ (>= num-running-in-jobgroup job-group-limit)) (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup " in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record)) #t) (else #f)))) - (not can-not-run-more))))) + (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) ;;====================================================================== ;; New methodology. These routines will replace the above in time. For ;; now the code is duplicated. This stuff is initially used in the monitor ;; based code. @@ -375,14 +376,19 @@ (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) (cond ;; OUTER COND ((not items) ;; when false the test is ok to be handed off to launch (but not before) - (let* ((have-resources (open-run-close runs:can-run-more-tests #f test-record)) ;; look at the test jobgroup and tot jobs running - (prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode)) - (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met))) + (let* ((run-limits-info (open-run-close runs:can-run-more-tests #f test-record)) ;; look at the test jobgroup and tot jobs running + (have-resources (car run-limits-info)) + (num-running (list-ref run-limits-info 1)) + (num-running-in-jobgroup (list-ref run-limits-info 2)) + (max-concurrent-jobs (list-ref run-limits-info 3)) + (job-group-limit (list-ref run-limits-info 4)) + (prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode)) + (fails (runs:calc-fails prereqs-not-met)) + (non-completed (runs:calc-not-completed prereqs-not-met))) (debug:print 8 "INFO: have-resources: " have-resources " prereqs-not-met: " (string-intersperse (map (lambda (t) (if (vector? t) (conc (db:test-get-state t) "/" (db:test-get-status t)) @@ -390,11 +396,11 @@ prereqs-not-met) ", ") " fails: " fails) (debug:print 4 "INFO: hed=" hed) ;; Don't know at this time if the test have been launched at some time in the past ;; i.e. is this a re-launch? - + (debug:print 4 "INFO: run-limits-info = " run-limits-info) (cond ;; INNER COND #1 for a launchable test ;; Check item path against item-patts ((and (not (patt-list-match item-path item-patts)) (not (equal? item-path ""))) ;; else the run is stuck, temporarily or permanently @@ -401,11 +407,12 @@ ;; but should check if it is due to lack of resources vs. prerequisites (debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts) (thread-sleep! *global-delta*) (if (not (null? tal)) (loop (car tal)(cdr tal) reruns))) - ((not (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f)) + ((and (not (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f)) + (and max-concurrent-jobs (> (- max-concurrent-jobs num-running) 5))) (open-run-close db:tests-register-test #f run-id test-name item-path) (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) #t) (thread-sleep! *global-delta*) (loop (car newtal)(cdr newtal) reruns)) ((not have-resources) ;; simply try again after waiting a second Index: tests/fullrun/config/mt_include_1.config ================================================================== --- tests/fullrun/config/mt_include_1.config +++ tests/fullrun/config/mt_include_1.config @@ -1,8 +1,8 @@ [setup] # exectutable /path/to/megatest -max_concurrent_jobs 200 +max_concurrent_jobs 30 linktree /tmp/mt_links [jobtools] useshell yes # ## launcher launches jobs, the job is managed on the target host