Megatest

Check-in [a3eca73bd8]
Login
Overview
Comment:Refactored nested cond in run:tests to a proc runs:expand-items
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | dev
Files: files | file ages | folders
SHA1: a3eca73bd8c688e516af37602ac96b3e78935ace
User & Date: matt on 2013-06-26 00:53:43
Other Links: branch diff | manifest | tags
Context
2013-06-26
01:03
Refactored nested cond in run:tests to a proc runs:expand-items check-in: 6f312dd5f5 user: matt tags: dev
00:53
Refactored nested cond in run:tests to a proc runs:expand-items check-in: a3eca73bd8 user: matt tags: dev
2013-06-25
21:15
Corrected order of adding items when doing expand check-in: c0ed667b5b user: mrwellan tags: dev
Changes

Modified runs.scm from [8b6a7fd7f9] to [db6150ddbe].

327
328
329
330
331
332
333















































































334
335
336
337
338
339
340

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
















































































;; 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)
  ;; 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 ", flags: " (hash-table->alist flags))
  (let ((run-info              (cdb:remote-run db:get-run-info #f run-id))







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







327
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
419

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


;; 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)
  ;; 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 ", flags: " (hash-table->alist flags))
  (let ((run-info              (cdb:remote-run db:get-run-info #f run-id))
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
			    (loop (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)))
			  (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?)
			    ;; (thread-sleep! (+ 0.01 *global-delta*))
			    (loop hed tal reg reruns))))))))) ;; END OF INNER COND

	 ;; End of INNER COND for launchable test.

	 ;; case where an items 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







<







637
638
639
640
641
642
643

644
645
646
647
648
649
650
			    (loop (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)))
			  (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?)

			    (loop hed tal reg reruns))))))))) ;; END OF INNER COND

	 ;; End of INNER COND for launchable test.

	 ;; case where an items 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
594
595
596
597
598
599
600

601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
	  ;; (loop hed tal reg reruns))
	  ;; (let ((newtal (append tal (list hed))))  ;; We should discard hed as it has been expanded into it's items?
	  ;;   (loop (car newtal)(cdr newtal) reg reruns)) ;; )
	  (loop (car tal)(cdr tal) reg reruns))
	    
	 ;; 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

	 ((or (procedure? items)(eq? items 'have-procedure))
	  (debug:print-info 4 "INNER COND: (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* ((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 num-retries:     " num-retries
				    "\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*)
			      (loop 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")
		    ;; only increment num-retries when there are no tests runing
		    (if (eq? 0 (list-ref can-run-more 1))
			(begin
			  ;; TRY (if (> num-retries 100) ;; first 100 retries are low time cost
			  ;; TRY     (thread-sleep! (+ 2 *global-delta*))
			  ;; TRY     (thread-sleep! (+ 0.01 *global-delta*)))
			  (set! num-retries (+ num-retries 1))))
		    (if (> num-retries  max-retries)
			(begin
			  (debug:print 0 "WARNING: retries exceed " max-retries ", this may not be handled correctly. Please consider reporting this scenario.")
			  (if (not (null? tal))
			      (loop (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)))
			(loop (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*)
			  (loop (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*))
		    (loop (car newtal)(cdr newtal) reg reruns)))) ;; END OF IF CAN RUN MORE

		;; if can't run more just loop with next possible test
		(begin
		  (debug:print-info 4 "processing the case with a lambda for items or 'have-procedure. Moving through the queue without dropping " hed)
		  ;; (thread-sleep! (+ 2 *global-delta*))
		  (loop (car newtal)(cdr newtal) reg reruns))))) ;; END OF (or (procedure? items)(eq? items 'have-procedure))
	 
	 ;; 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))
	 ((not (null? reruns))
	  (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED,
		 (junked (lset-difference equal? tal newlst)))







>

<



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

<
<
<
|
|







672
673
674
675
676
677
678
679
680

681
682
683
































684




































685
686



687
688
689
690
691
692
693
694
695
	  ;; (loop hed tal reg reruns))
	  ;; (let ((newtal (append tal (list hed))))  ;; We should discard hed as it has been expanded into it's items?
	  ;;   (loop (car newtal)(cdr newtal) reg reruns)) ;; )
	  (loop (car tal)(cdr tal) reg reruns))
	    
	 ;; 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)))




































		  (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))
	 ((not (null? reruns))
	  (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED,
		 (junked (lset-difference equal? tal newlst)))