Megatest

Diff
Login

Differences From Artifact [3077567ff2]:

To Artifact [7959d5d055]:


328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375

376
377
378
379
380
381
382
383
384
385
386
387
388
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
(define (runs:queue-next-reg tal reg n regful)
  (if regful
      (cdr reg)
      (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal
	  '()
	  reg)))

(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
	 )

  (debug:print-info 4 "INNER COND: (or (procedure? items)(eq? items 'have-procedure))")
  (let* ((loop-list       (list hed tal reg reruns))
	 (prereqs-not-met (mt:get-prereqs-not-met 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-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) 
		      "\n fails:           " (runs:pretty-string fails)
		      "\n testmode:        " testmode
		      "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel)
		      "\n (null? non-completed):    " (null? non-completed)
		      "\n reruns:          " reruns
		      "\n items:           " items
		      "\n can-run-more:    " can-run-more)
    ;; (thread-sleep! (+ 0.01 *global-delta*))
    (cond ;; INNER COND #2
     ((or (null? prereqs-not-met) ;; all prereqs met, fire off the test
	  ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch

	  (and (eq? testmode 'toplevel)
	       (null? non-completed)))
      (debug:print-info 4 "INNER COND #2: (or (null? prereqs-not-met) (and (eq? testmode 'toplevel)(null? non-completed)))")
      (let ((test-name (tests:testqueue-get-testname test-record)))
	(setenv "MT_TEST_NAME" test-name) ;; 
	(setenv "MT_RUNNAME"   runname)
	(set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
	(let ((items-list (items:get-items-from-config tconfig)))
	  (if (list? items-list)
	      (begin
		(tests:testqueue-set-items! test-record items-list)
		;; (thread-sleep! *global-delta*)
		(set! loop-list (list hed tal reg reruns)))
	      (begin
		(debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this")
		(exit 1))))))

     ((null? fails)
      (debug:print-info 4 "fails is null, moving on in the queue but keeping " hed " for now")
      ;; num-retries code was here
      (set! loop-list (list (car newtal)(cdr newtal) reg reruns))) ;; an issue with prereqs not yet met?
     ((and (not (null? fails))(eq? testmode 'normal))
      (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")
      (if (or (not (null? reg))(not (null? tal)))
	  (begin
	    ;; (thread-sleep! *global-delta*)
	    (set! loop-list (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)
				  (cons hed reruns))))))

     (else
      (debug:print 4 "ERROR: No handler for this condition.")
      ;; TRY (thread-sleep! (+ 1 *global-delta*))
      (set! loop-list (list (car newtal)(cdr newtal) reg reruns)))) ;; END OF IF CAN RUN MORE
    loop-list))

(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)
  (let* ((run-limits-info         (runs:can-run-more-tests jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
	 ;; (open-run-close runs:can-run-more-tests #f 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))







|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















<
|
|
|
>











<
|



>



|





<
<
|
|
|
|
>


<
|
<







328
329
330
331
332
333
334
335




















336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351

352
353
354
355
356
357
358
359
360
361
362
363
364
365
366

367
368
369
370
371
372
373
374
375
376
377
378
379
380


381
382
383
384
385
386
387

388

389
390
391
392
393
394
395
(define (runs:queue-next-reg tal reg n regful)
  (if regful
      (cdr reg)
      (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal
	  '()
	  reg)))

(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)




















  (let* ((loop-list       (list hed tal reg reruns))
	 (prereqs-not-met (mt:get-prereqs-not-met 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-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) 
		      "\n fails:           " (runs:pretty-string fails)
		      "\n testmode:        " testmode
		      "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel)
		      "\n (null? non-completed):    " (null? non-completed)
		      "\n reruns:          " reruns
		      "\n items:           " items
		      "\n can-run-more:    " can-run-more)

    (cond
     ;; all prereqs met, fire off the test
     ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch
     ((or (null? prereqs-not-met)
	  (and (eq? testmode 'toplevel)
	       (null? non-completed)))
      (debug:print-info 4 "INNER COND #2: (or (null? prereqs-not-met) (and (eq? testmode 'toplevel)(null? non-completed)))")
      (let ((test-name (tests:testqueue-get-testname test-record)))
	(setenv "MT_TEST_NAME" test-name) ;; 
	(setenv "MT_RUNNAME"   runname)
	(set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
	(let ((items-list (items:get-items-from-config tconfig)))
	  (if (list? items-list)
	      (begin
		(tests:testqueue-set-items! test-record items-list)

		(list hed tal reg reruns))
	      (begin
		(debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this")
		(exit 1))))))

     ((null? fails)
      (debug:print-info 4 "fails is null, moving on in the queue but keeping " hed " for now")
      ;; num-retries code was here
      (list (car newtal)(cdr newtal) reg reruns)) ;; an issue with prereqs not yet met?
     ((and (not (null? fails))(eq? testmode 'normal))
      (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")
      (if (or (not (null? reg))(not (null? tal)))


	  (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)
		(cons hed reruns))
	  #f)) ;; #f flags do not loop
     (else
      (debug:print 4 "ERROR: No handler for this condition.")

      (list (car newtal)(cdr newtal) reg reruns)))))


(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)
  (let* ((run-limits-info         (runs:can-run-more-tests jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
	 ;; (open-run-close runs:can-run-more-tests #f 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))
546
547
548
549
550
551
552

553
554
555
556
557
558
559
				     (runs:queue-next-tal tal reg reglen regfull)
				     (runs:queue-next-reg tal reg reglen regfull)
				     (cons hed reruns))))
		  (begin
		    (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;;  " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
		    (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
		    (set! loop-list (list hed tal reg reruns))))))))

    loop-list)) ;; END OF INNER COND

;; End of INNER COND for launchable test.


;; 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 keyvals flags test-patts required-tests reglen-in)







>







523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
				     (runs:queue-next-tal tal reg reglen regfull)
				     (runs:queue-next-reg tal reg reglen regfull)
				     (cons hed reruns))))
		  (begin
		    (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;;  " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
		    (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
		    (set! loop-list (list hed tal reg reruns))))))))
    (debug:print-info 4 "runs:process-expanded-tests, loop-list=" loop-list)
    loop-list)) ;; END OF INNER COND

;; End of INNER COND for launchable test.


;; 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 keyvals flags test-patts required-tests reglen-in)
685
686
687
688
689
690
691

692
693
694
695
696
697
698
699
	 ;;    - 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)))

		  (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)
	  (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this")
	  (exit 1))







>
|







663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
	 ;;    - 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)))
		  (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)
	  (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this")
	  (exit 1))