| ︙ | | |
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
-
+
|
;;;;;; (vector target runname testpatt keys keyvals envdat mconfig runconfig (common:get-remote remote run-id) transport db toppath run-id)))
(define (runs:set-megatest-env-vars run-id area-dat #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
(let* ((configdat (megatest:area-configdat area-dat))
(toppath (megatest:area-path area-dat))
(target (or (common:args-get-target)
(get-environment-variable "MT_TARGET")))
(keys (if inkeys inkeys (rmt:get-keys)))
(keys (if inkeys inkeys (rmt:get-keys area-dat)))
(keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target)))
(vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))
(link-tree (configf:lookup configdat "setup" "linktree")))
;; get the info from the db and put it in the cache
(if link-tree
(setenv "MT_LINKTREE" link-tree)
(debug:print 0 "ERROR: linktree not set, should be set in megatest.config in [setup] section."))
|
| ︙ | | |
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
-
+
|
vals
(lambda (key val)
(debug:print 2 "setenv " key " " val)
(safe-setenv key val)))
(if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
(alist->env-vars (hash-table-ref/default configdat "env-override" '()))
;; Lets use this as an opportunity to put MT_RUNNAME in the environment
(let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
(let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id area-dat))))
(if runname
(setenv "MT_RUNNAME" runname)
(debug:print 0 "ERROR: no value for runname for id " run-id)))
(setenv "MT_RUN_AREA_HOME" toppath)))
(define (set-item-env-vars itemdat)
(for-each (lambda (item)
|
| ︙ | | |
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
-
-
+
+
|
(thread-sleep! (cond
((> *runs:can-run-more-tests-count* 20)
(if (runs:lownoise "waiting on tasks" 60)
(debug:print-info 2 "waiting for tasks to complete, sleeping briefly ..."))
2);; obviously haven't had any work to do for a while
(else 0)))
(let* ((configdat (megatest:area-configdat area-dat))
(num-running (rmt:get-count-tests-running run-id))
(num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
(num-running (rmt:get-count-tests-running run-id area-dat))
(num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup area-dat))
(job-group-limit (let ((jobg-count (config-lookup configdat "jobgroups" jobgroup)))
(if (string? jobg-count)
(string->number jobg-count)
jobg-count))))
(if (> (+ num-running num-running-in-jobgroup) 0)
(set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1)))
(if (not (eq? *last-num-running-tests* num-running))
|
| ︙ | | |
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
|
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
|
-
-
+
+
|
(print "Received signal " signum ", cleaning up before exit. Please wait...")
(let ((tdbdat (tasks:open-db area-dat)))
(rmt:tasks-set-state-given-param-key task-key "killed"))
(print "Killed by signal " signum ". Exiting")
(exit)))
;; register this run in monitor.db
(rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params)
(rmt:tasks-set-state-given-param-key task-key "running")
(rmt:tasks-add "run-tests" user target runname test-patts task-key area-dat) ;; params)
(rmt:tasks-set-state-given-param-key task-key "running" area-dat)
(runs:set-megatest-env-vars run-id area-dat inkeys: keys inrunname: runname) ;; these may be needed by the launching process
(if (file-exists? runconfigf)
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
;; Now generate all the tests lists
(set! all-tests-registry (tests:get-all area-dat))
|
| ︙ | | |
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
|
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
|
-
+
|
;; A failed for some reason then on re-run using -keepgoing the run can never complete.
;;
;; (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED")
;; Now convert FAIL and anything in allow-auto-rerun to NOT_STARTED
;;
(for-each (lambda (state)
(rmt:set-tests-state-status run-id test-names state #f "NOT_STARTED" state))
(rmt:set-tests-state-status run-id test-names state #f "NOT_STARTED" state area-dat))
(string-split (or (configf:lookup configdat "setup" "allow-auto-rerun") "")))))
;; Ensure all tests are registered in the test_meta table
(runs:update-all-test_meta #f)
;; now add non-directly referenced dependencies (i.e. waiton)
;;======================================================================
|
| ︙ | | |
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
|
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
|
-
+
-
+
-
+
|
(begin
(set! run-queue-retries (- run-queue-retries 1))
(runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry area-dat))))
(runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry area-dat)))
"runs:run-tests-queue"))
(th2 (make-thread (lambda ()
;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ...
(let ((run-ids (rmt:get-all-run-ids)))
(let ((run-ids (rmt:get-all-run-ids area-dat)))
(for-each (lambda (run-id)
(if keep-going
(handle-exceptions
exn
(debug:print 0 "error in calling find-and-mark-incomplete for run-id " run-id)
(rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime)))
(rmt:find-and-mark-incomplete run-id #f area-dat)))) ;; ovr-deadtime)))
run-ids)))
"runs: mark-incompletes")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(set! keep-going #f)
(thread-join! th2)
;; if run-count > 0 call, set -preclean and -rerun STUCK/DEAD
(if (> run-count 0)
(begin
(if (not (hash-table-ref/default flags "-preclean" #f))
(hash-table-set! flags "-preclean" #t))
(if (not (hash-table-ref/default flags "-rerun" #f))
(hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS"))
(runs:run-tests target runname test-patts user flags area-dat run-count: (- run-count 1)))))
(debug:print-info 0 "No tests to run")))
(debug:print-info 4 "All done by here")
(rmt:tasks-set-state-given-param-key task-key "done")
(rmt:tasks-set-state-given-param-key task-key "done" area-dat)
;; (sqlite3:finalize! tasks-db)
))
;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable.
;;
;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns
|
| ︙ | | |
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
|
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
|
-
+
|
'()
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 itemmap)
(let* ((loop-list (list hed tal reg reruns))
(prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap))
(prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode area-dat itemmap: itemmap))
;; (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))
(prereq-fails (runs:calc-prereq-fail prereqs-not-met))
(non-completed (runs:calc-not-completed prereqs-not-met))
(runnables (runs:calc-runnable prereqs-not-met)))
(debug:print-info 4 "START OF INNER COND #2 "
"\n can-run-more: " can-run-more
|
| ︙ | | |
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
|
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
|
-
+
|
(setenv "MT_TEST_NAME" test-name) ;;
(setenv "MT_RUNNAME" runname)
(runs:set-megatest-env-vars run-id area-dat inrunname: runname) ;; these may be needed by the launching process
(let ((items-list (items:get-items-from-config tconfig)))
(if (list? items-list)
(begin
(if (null? items-list)
(let ((test-id (rmt:get-test-id run-id test-name "")))
(let ((test-id (rmt:get-test-id run-id test-name "" area-dat)))
(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites"))))
(tests:testqueue-set-items! test-record items-list)
(list hed tal reg reruns))
(begin
(debug:print 0 "ERROR: The proc from reading the items table did not yield a list - please report this")
(exit 1))))))
|
| ︙ | | |
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
|
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
|
-
+
|
(if (and give-up
(not (and (null? tal)(null? reg))))
(let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records))
(trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records)))
(debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue")
(let ((test-id (rmt:get-test-id run-id hed "")))
(let ((test-id (rmt:get-test-id run-id hed "" area-dat)))
(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites")))
(if (and (null? trimmed-tal)
(null? trimmed-reg))
#f
(list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull)
(runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull)
|
| ︙ | | |
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
|
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
|
-
+
-
+
|
;; getting here likely means the system is way overloaded, kill a full minute before continuing
(thread-sleep! 60)
;; num-retries code was here
;; we use this opportunity to move contents of reg to tal
(list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met?
(begin
(debug:print-info 1 "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue")
(let ((test-id (rmt:get-test-id run-id hed "")))
(let ((test-id (rmt:get-test-id run-id hed "" area-dat)))
(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while.")))
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
reruns))))
((and
(or (not (null? fails))
(not (null? prereq-fails)))
(member 'normal testmode))
(debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); "
(string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
", removing it from to-do list")
(let ((test-id (rmt:get-test-id run-id hed "")))
(let ((test-id (rmt:get-test-id run-id hed "" area-dat)))
(if test-id
(if (not (null? prereq-fails))
(mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites")
(mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))))
(if (or (not (null? reg))(not (null? tal)))
(begin
(hash-table-set! test-registry hed 'CANNOTRUN)
|
| ︙ | | |
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
|
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
|
-
+
|
(toppath (megatest:area-path area-dat))
(run-limits-info (runs:can-run-more-tests run-id 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 (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap))
(prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode area-dat itemmap: itemmap))
;; (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))
;; configure the load runner
(numcpus (common:get-num-cpus))
(maxload (string->number (or (configf:lookup configdat "jobtools" "maxload") "3")))
|
| ︙ | | |
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
|
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
|
-
+
-
+
|
;; Register tests
;;
((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f))
(debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" )
;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs
(let register-loop ((numtries 15))
(rmt:general-call 'register-test run-id run-id test-name item-path)
(rmt:general-call 'register-test run-id area-dat run-id test-name item-path)
(if (rmt:get-test-id run-id test-name item-path)
(hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done)
(if (> numtries 0)
(begin
(thread-sleep! 0.5)
(register-loop (- numtries 1)))
(debug:print 0 "ERROR: failed to register test " (db:test-make-full-name test-name item-path)))))
(if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done))
(begin
(rmt:general-call 'register-test run-id run-id test-name "")
(rmt:general-call 'register-test run-id area-dat run-id test-name "")
(if (rmt:get-test-id run-id test-name "")
(hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))))
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
(if (and (null? tal)(null? reg))
(list hed tal (append reg (list hed)) reruns)
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
|
| ︙ | | |
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
|
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
|
-
+
|
(hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*))
;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard
;; and it is clear they *should* have run but did not.
(if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f))
(begin
(rmt:general-call 'register-test run-id run-id test-name "" area-dat)
(rmt:general-call 'register-test run-id area-dat run-id test-name "" area-dat)
(hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))
;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :(
;;
(if (member (hash-table-ref/default test-registry tfullname #f)
'(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE))
(begin
|
| ︙ | | |
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
|
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
|
-
+
|
;;
;; NB// for the above line. I want the test to be registered long before this routine gets called!
;;
(if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path area-dat)))
(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)
(rmt:general-call 'register-test run-id run-id test-name item-path area-dat)
(rmt:general-call 'register-test run-id area-dat run-id test-name item-path area-dat)
(set! test-id (rmt:get-test-id run-id test-name item-path area-dat))))
(debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
(set! testdat (rmt:get-test-info-by-id run-id test-id area-dat))
(if (not testdat)
(begin
(debug:print-info 0 "WARNING: server is overloaded, trying again in one second")
(thread-sleep! 1)
|
| ︙ | | |