︙ | | |
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
|
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
|
-
+
+
+
|
(args:get-arg "-one-pass"))
(exit 0))
(thread-sleep! (cond ;; BB: check with Matt. Should this sleep move
;; to cond clauses below where we determine we
;; have too many jobs running rather than each
;; time the and condition above is true (which
;; seems like always)?
;; seems like always)?
((< (- (current-seconds)(runs:dat-beginning-of-time runsdat)) 30) ;; for the first 30 seconds do not throttle in any way
0)
((> (runs:dat-can-run-more-tests-count runsdat) 20) ;; original intent was - save cycles, wait a long time
(if (runs:lownoise "waiting on tasks" 60)(debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ..."))
10) ;; obviously haven't had any work to do for a while
(else 0)))
;; ;; if have a number for inter-test-delay, use it, else don't delay much, maybe even zero?
;; (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.01)
;; )))
|
︙ | | |
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
|
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
|
-
+
|
;; If no resources are available just kill time and loop again
;;
((not have-resources) ;; simply try again after waiting a second
(if (runs:lownoise "no resources" 60)
(debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ..."))
;; Have gone back and forth on this but db starvation is an issue.
;; wait one second before looking again to run jobs.
(thread-sleep! 1)
(thread-sleep! 0.25)
;; could have done hed tal here but doing car/cdr of newtal to rotate tests
(list (car newtal)(cdr newtal) reg reruns))
;; This is the final stage, everything is in place so launch the test
;;
((and have-resources
(or (null? prereqs-not-met)
|
︙ | | |
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
|
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
|
-
+
|
(begin
(mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test)
(debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test))
;;
;; Here the test is handed off to launch.scm for launch-test to complete the launch process
;;
(if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags))
(begin
(begin
(print "ERROR: Failed to launch the test. Exiting as soon as possible")
(set! *globalexitstatus* 1) ;;
(process-signal (current-process-id) signal/kill))))))))
((KILLED)
(debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED))
((LAUNCHED REMOTEHOSTSTART RUNNING)
|
︙ | | |
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
|
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
|
-
+
|
;;
(define (runs:get-hash-by-target target-patts runpatt)
(let* ((targets (string-split target-patts ","))
(keys (rmt:get-keys))
(res-ht (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... )
(for-each
(lambda (target-patt)
(let ((runs (rmt:simple-get-runs runpatt #f #f target-patt)))
(let ((runs (rmt:simple-get-runs runpatt #f #f target-patt #f)))
(for-each
(lambda (run)
(let ((target (simple-run-target run)))
(hash-table-set! res-ht target (cons run (hash-table-ref/default res-ht target '())))))
runs)))
targets)
res-ht))
|
︙ | | |