| ︙ | | |
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
|
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
|
-
+
-
+
|
(cdr reg)
(if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal
'()
reg)))
(define runs:nothing-left-in-queue-count 0)
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records)
(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap)
(let* ((loop-list (list hed tal reg reruns))
(prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode))
(prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
(fails (runs:calc-fails prereqs-not-met))
(non-completed (runs:calc-not-completed prereqs-not-met)))
(debug:print-info 4 "START OF INNER COND #2 "
"\n can-run-more: " can-run-more
"\n testname: " hed
"\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
"\n non-completed: " (runs:pretty-string non-completed)
|
| ︙ | | |
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
|
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
|
-
+
-
+
|
(conc (db:test-get-state t) "/" (db:test-get-status t)))
((string? t)
t)
(else
(conc t))))
inlst)))
(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry)
(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap)
(let* ((run-limits-info (runs:can-run-more-tests jobgroup max-concurrent-jobs)) ;; 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 (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode))
(prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
(fails (runs:calc-fails prereqs-not-met))
(non-completed (runs:calc-not-completed prereqs-not-met))
(loop-list (list hed tal reg reruns)))
(debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: ("
(string-intersperse
(map (lambda (t)
(if (vector? t)
|
| ︙ | | |
824
825
826
827
828
829
830
831
832
833
834
835
836
837
|
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
|
+
|
;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns)
(let* ((test-record (hash-table-ref test-records hed))
(test-name (tests:testqueue-get-testname test-record))
(tconfig (tests:testqueue-get-testconfig test-record))
(jobgroup (config-lookup tconfig "test_meta" "jobgroup"))
(testmode (let ((m (config-lookup tconfig "requirements" "mode")))
(if m (map string->symbol (string-split m)) '(normal))))
(itemmap (configf:lookup tconfig "requirements" "itemmap"))
(waitons (tests:testqueue-get-waitons test-record))
(priority (tests:testqueue-get-priority test-record))
(itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f
(items (tests:testqueue-get-items test-record))
(item-path (item-list->path itemdat))
(tfullname (runs:make-full-test-name test-name item-path))
(newtal (append tal (list hed)))
|
| ︙ | | |
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
|
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
|
-
+
|
;; items is #f then the test is ok to be handed off to launch (but not before)
;;
((not items)
(debug:print-info 4 "OUTER COND: (not items)")
(if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
(not (null? tal)))
(loop (car tal)(cdr tal) reg reruns))
(let ((loop-list (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry)))
(let ((loop-list (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap)))
(if loop-list (apply loop loop-list))))
;; items processed into a list but not came in as a list been processed
;;
((and (list? items) ;; thus we know our items are already calculated
(not itemdat)) ;; and not yet expanded into the list of things to be done
(debug:print-info 4 "OUTER COND: (and (list? items)(not itemdat))")
|
| ︙ | | |
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
|
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
|
-
+
|
;; if items is a proc then need to run items:get-items-from-config, get the list and loop
;; - but only do that if resources exist to kick off the job
;; EXPAND ITEMS
((or (procedure? items)(eq? items 'have-procedure))
(let ((can-run-more (runs:can-run-more-tests jobgroup max-concurrent-jobs)))
(if (and (list? can-run-more)
(car can-run-more))
(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records)))
(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap)))
(if loop-list
(apply loop loop-list)))
;; if can't run more just loop with next possible test
(loop (car newtal)(cdr newtal) reg reruns))))
;; this case should not happen, added to help catch any bugs
((and (list? items) itemdat)
|
| ︙ | | |