Megatest

Check-in [f5d77988cc]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Somewhat speculative fix for failure to discard non-runnable tests
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.55
Files: files | file ages | folders
SHA1: f5d77988cc62450384e4cceaec51b1130b760146
User & Date: matt on 2013-10-15 01:16:24
Other Links: branch diff | manifest | tags
Context
2013-10-17
08:36
Added protection to the opening of borked testdat.db files check-in: 45737fefdf user: mrwellan tags: v1.55
2013-10-15
01:16
Somewhat speculative fix for failure to discard non-runnable tests check-in: f5d77988cc user: matt tags: v1.55
2013-10-14
23:25
Added blocked chain testcase check-in: f3bf15140a user: matt tags: v1.55
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified megatest-version.scm from [6a6644ddd1] to [549dda85a8]. 

1
2
3
4
5
6

7

1
2
3
4
5

6
7






-
+


;; Always use two digit decimal
;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.5512)
(define megatest-version 1.5513)

Modified mt.scm from [c1cc555b4f] to [4beb856e75].

︙
83
84
85
86
87
88
89




















90
91
92
93
94
95
96

83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








	  full-list))))

(define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))
  (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode))

(define (mt:get-run-stats)
  (cdb:remote-run db:get-run-stats #f))

(define (mt:discard-blocked-tests run-id failed-test tests test-records)
  (if (null? tests)
      tests
      (begin
	(debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test)
	(let loop ((testn (car tests))
		   (remt  (cdr tests))
		   (res   '()))
	  (let ((waitons (vector-ref (hash-table-ref/default test-records testn (vector #f #f '())) 2)))
	    ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons)
	    (if (null? remt)
		(let ((new-res (reverse res)))
		  ;; (print "       new-res: " new-res)
		  new-res)
		(loop (car remt)
		      (cdr remt)
		      (if (member failed-test waitons)
			  res
			  (cons testn res)))))))))

;;======================================================================
;;  T R I G G E R S
;;======================================================================

(define (mt:process-triggers test-id newstate newstatus)
  (let* ((test-dat      (mt:lazy-get-test-info-by-id test-id))
︙

Modified runs.scm from [631ee0cd7b] to [3ff33aede5].

︙
365
366
367
368
369
370
371
372

373
374
375
376
377
378
379

365
366
367
368
369
370
371

372
373
374
375
376
377
378
379








-
+








      (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)
(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)
  (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
︙
448
449
450
451
452
453
454
455
456
457
458
459
460
461











462
463
464
465
466
467
468
469

448
449
450
451
452
453
454







455
456
457
458
459
460
461
462
463
464
465

466
467
468
469
470
471
472








-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-








	;; We need to use this to dequeue this item as CANNOTRUN
	(for-each (lambda (prereq)
		    (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN)
			(set! give-up #t)))
		  prereqstrs)
	(if (and give-up
		 (not (and (null? tal)(null? reg))))
	    (begin
	      (debug:print 1 "WARNING: test " hed " has no discarded prerequisites, removing it from the queue")
	      (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))
	    (list (car newtal)(append (cdr newtal) reg) '() reruns))))
	    (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")
	      (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)
			(runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull)
			reruns)))
	      (list (car newtal)(append (cdr newtal) reg) '() reruns))))


     ;; (debug:print-info 1 "allinqueue: " allinqueue)
     ;; (debug:print-info 1 "prereqstrs: " prereqstrs)
     ;; (debug:print-info 1 "notinqueue: " notinqueue)
     ;; (debug:print-info 1 "tal:        " tal)
     ;; (debug:print-info 1 "newtal:     " newtal)
     ;; (debug:print-info 1 "reg:        " reg)
︙
872
873
874
875
876
877
878
879

880
881
882
883
884
885
886

875
876
877
878
879
880
881

882
883
884
885
886
887
888
889








-
+








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

This page was generated in about 0.119s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00