332
333
334
335
336
337
338
339
340
341
342
343
344
345
|
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
|
+
|
;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue run-id runname test-records keyvallst flags test-patts)
;; At this point the list of parent tests is expanded
;; NB// Should expand items here and then insert into the run queue.
(debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags))
(let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records))
(test-registery (make-hash-table))
(registery-mutex (make-mutex))
(num-retries 0)
(max-retries (config-lookup *configdat* "setup" "maxretries")))
(set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100))
(if (not (null? sorted-test-names))
(let loop ((hed (car sorted-test-names))
(tal (cdr sorted-test-names))
(reruns '()))
|
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
|
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
|
+
+
-
-
+
+
+
+
+
-
+
+
+
+
+
-
-
-
+
+
+
+
+
+
+
|
((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path)) ;; This test/itempath is not to be run
;; else the run is stuck, temporarily or permanently
;; but should check if it is due to lack of resources vs. prerequisites
(debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts)
;; (thread-sleep! *global-delta*)
(if (not (null? tal))
(loop (car tal)(cdr tal) reruns)))
;; Registery has been started for this test but has not yet completed
;; this should be rare, the case where there are only a couple of tests and the db is slow
( ;; (and
(not (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f))
;; delay a short while and continue
((eq? (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f) 'start)
(thread-sleep! 0.01)
(loop (car newtal)(cdr newtal) reruns))
((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*)
(cdb:tests-register-test *runremote* run-id test-name item-path)
(mutex-lock! registery-mutex)
(hash-table-set! test-registery (runs:make-full-test-name test-name item-path) 'done)
(mutex-unlock! registery-mutex))
(conc test-name "/" item-path))))
(thread-start! th))
(thread-sleep! *global-delta*)
(runs:shrink-can-run-more-tests-delay)
(loop (car newtal)(cdr newtal) reruns))
((not have-resources) ;; simply try again after waiting a second
(debug:print-info 1 "no resources to run new tests, waiting ...")
;; (thread-sleep! (+ 2 *global-delta*))
;; could have done hed tal here but doing car/cdr of newtal to rotate tests
(loop (car newtal)(cdr newtal) reruns))
|
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
|
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
|
-
+
|
;;
;; NB// for the above line. I want the test to be registered long before this routine gets called!
;;
(set! test-id (open-run-close db:get-test-id db run-id test-name item-path))
(if (not test-id)
(begin
(debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
(open-run-close db:tests-register-test #f run-id test-name item-path)
(cdb:tests-register-test *runremote* run-id test-name item-path)
(set! test-id (open-run-close db:get-test-id db run-id test-name item-path))))
(debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
(set! testdat (cdb:get-test-info-by-id *runremote* test-id))))
(set! test-id (db:test-get-id testdat))
(change-directory test-path)
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
|