Megatest

Check-in [5501f178c7]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Add trimming of tests from launch list to cut down on irrelevant queries and speed up launching
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 5501f178c73f93b494e8b79cb3298374812954ab
User & Date: matt on 2012-03-26 00:23:02
Other Links: manifest | tags
Context
2012-03-26
00:39
Cleaned up output a little check-in: b3c755e579 user: matt tags: trunk
00:23
Add trimming of tests from launch list to cut down on irrelevant queries and speed up launching check-in: 5501f178c7 user: matt tags: trunk
2012-03-25
15:15
Added current dir to end of path so that on systems without . in the path the script will still be found check-in: ae5dd4f3a6 user: matt tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified runs.scm from [c9cc30bbd7] to [8cce014215].

︙
205
206
207
208
209
210
211
212

213
214
215
216
217
218
219

205
206
207
208
209
210
211

212
213
214
215
216
217
218
219








-
+








	  (db:delete-tests-in-state db run-id "NOT_STARTED")
	  (rdb:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))

    ;; now add non-directly referenced dependencies (i.e. waiton)
    (if (not (null? test-names))
	(let loop ((hed (car test-names))
		   (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
	  (let* ((config  (test:get-testconfig hed 'return-procs))
	  (let* ((config  (tests:get-testconfig hed 'return-procs))
		 (waitons (string-split (let ((w (config-lookup config "requirements" "waiton")))
					  (if w w "")))))
	    ;; (items   (items:get-items-from-config config)))
	    (if (not (hash-table-ref/default test-records hed #f))
		(hash-table-set! test-records
				 hed (vector hed     ;; 0
					     config  ;; 1
︙
240
241
242
243
244
245
246
247

248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266

267
268
269
270
271
272
273
274
275
276
277
278
279
280

281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300

301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316



317
318
319
320
321
322
323
324
325
326
327
328
329
330
331




332
333
334
335
336
337
338

240
241
242
243
244
245
246

247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280

281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300

301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332



333
334
335
336
337
338
339
340
341
342
343








-
+



















+













-
+



















-
+
















+
+
+












-
-
-
+
+
+
+








						 'have-procedure)
						((or (list? items)(list? itemstable)) ;; calc now
						 (debug:print 4 "INFO: items and itemstable are lists, calc now\n"
							      "    items: " items " itemstable: " itemstable)
						 (items:get-items-from-config config))
						(else #f)))                           ;; not iterated
					     #f      ;; itemsdat 5
					     ;; #f      ;; spare
					     #f      ;; spare - used for item-path
					     )))
	    (for-each 
	     (lambda (waiton)
	       (if (and waiton (not (member waiton test-names)))
		   (begin
		     (set! required-tests (cons waiton required-tests))
		     (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
	     waitons)
	    (let ((remtests (delete-duplicates (append waitons tal))))
	      (if (not (null? remtests))
		  (loop (car remtests)(cdr remtests)))))))

    (if (not (null? required-tests))
	(debug:print 1 "INFO: Adding " required-tests " to the run queue"))
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (runs:run-tests-queue db run-id runname test-records keyvallst flags)
    (if *rpc:listener* (server:keep-running db))
    (debug:print 4 "INFO: All done by here")))

;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue db run-id runname test-records keyvallst flags)
    ;; 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 ", keyvallst: " keyvallst)
  (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records))
	(item-patts        (hash-table-ref/default flags "-itempatt" #f)))
    (let loop (; (numtimes 0) ;; shouldn't need this
	       (hed         (car sorted-test-names))
	       (tal         (cdr sorted-test-names)))
      (let* ((test-record (hash-table-ref test-records hed))
	     (tconfig     (tests:testqueue-get-testconfig test-record))
	     (waitons     (tests:testqueue-get-waitons    test-record))
	     (priority    (tests:testqueue-get-priority   test-record))
	     (itemdat     (tests:testqueue-get-itemdat    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)))
	(debug:print 6
		     "itemdat:     " itemdat
		     "\n  items:     " items
		     "\n  item-path: " item-path)
	(cond
	 ((not items) ;; when false the test is ok to be handed off to launch (but not before)
	  (let ((have-resources  (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running
		(prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path)))
	    ;; Don't know at this time if the test have been launched at some time in the past
	    ;; i.e. is this a re-launch?
	    (if (and have-resources
		     (null? prereqs-not-met))
		;; no loop - drop though and use the loop at the bottom 
		(run:test db run-id runname keyvallst test-record flags #f)
		;; else the run is stuck, temporarily or permanently
		(let ((newtal (append tal (list hed))))
		  ;; couldn't run, take a breather
		  (thread-sleep! 4)
		  (thread-sleep! 0.5)
		  (loop (car newtal)(cdr newtal))))))
	 
	 ;; 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
	  (if (>= *verbosity* 1)(pp items))
	  ;; (if (>= *verbosity* 5)
	  ;;     (begin
	  ;;       (print "items: ")     (pp (item-assoc->item-list items))
	  ;;       (print "itemstable: ")(pp (item-table->item-list itemstable))))
	  (for-each
	   (lambda (my-itemdat)
	     (let* ((new-test-record (let ((newrec (make-tests:testqueue)))
				       (vector-copy! test-record newrec)
				       newrec))
		    (my-item-path (item-list->path my-itemdat))
		    
		    ;; 3/25/2012 - this match is *always* returning true I believe. Or is it the tests that are not being handled?
		    ;;
		    (item-matches (if item-patts       ;; here we are filtering for matches with -itempatt
				      (let ((res #f))	 ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is %
					(for-each 
					 (lambda (patt)
					   (if (string-search (glob->regexp
							       (string-translate patt "%" "*"))
							      item-path)
					       (set! res #t)))
					 (string-split item-patts ","))
					res)
				      #t)))
	       (if item-matches ;; yes, we want to process this item
		   (let ((newtestname (conc hed "/" my-item-path))) 
		     (tests:testqueue-set-items!   new-test-record #f)
		     (tests:testqueue-set-itemdat! new-test-record my-itemdat)
		   (let ((newtestname (conc hed "/" my-item-path)))    ;; test names are unique on testname/item-path
		     (tests:testqueue-set-items!     new-test-record #f)
		     (tests:testqueue-set-itemdat!   new-test-record my-itemdat)
		     (tests:testqueue-set-item_path! new-test-record my-item-path)
		     (hash-table-set! test-records newtestname new-test-record)
		     (set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath
	   items)
	  (loop (car tal)(cdr tal)))

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

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








-
+












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








-
+








			(tests:testqueue-set-items! test-record items-list)
			(loop hed tal))
		      (begin
			(debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this")
			(exit 1)))))
	      (let ((newtal (append tal (list hed))))
		;; if can't run more tests, lets take a breather
		(thread-sleep! 1)
		(thread-sleep! 0.5)
		(loop (car newtal)(cdr newtal)))))

	 ;; 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))))
	
      ;; we get here on "drop through" - loop for next test in queue
      (if (null? tal)
	  (begin
	    ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!!
	    (debug:print 1 "INFO: All tests launched")
	    (thread-sleep! 0.5)
	    ;; (exit 0)
	    ;; FIXME! This harsh exit should not be necessary....
	    )
	  (loop (car tal)(cdr tal))))))
	    (if (not *runremote*)(exit)) ;; 
	    #f) ;; return a #f as a hint that we are done
	  ;; Here we need to check that all the tests remaining to be run are eligible to run
	  ;; and are not blocked by failed
	  (let ((newlst (tests:filter-non-runnable db run-id tal test-records))) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED,
	    (thread-sleep! 0.5)
	    (if (not (null? newlst))
		(loop (car newlst)(cdr newlst))))))))

;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
(define (run:test db run-id runname keyvallst test-record flags parent-test)
  ;; All these vars might be referenced by the testconfig file reader
  (let* ((test-name    (tests:testqueue-get-testname   test-record))
	 (test-waitons (tests:testqueue-get-waitons    test-record))
	 (test-conf    (tests:testqueue-get-testconfig test-record))
	 (itemdat      (tests:testqueue-get-itemdat    test-record))
	 (test-path    (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
	 (test-path    (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
	 (force        (hash-table-ref/default flags "-force" #f))
	 (rerun        (hash-table-ref/default flags "-rerun" #f))
	 (keepgoing    (hash-table-ref/default flags "-keepgoing" #f))
	 (item-path     ""))
    (debug:print 5
		 "test-config: " (hash-table->alist test-conf)
		 "\n   itemdat: " itemdat
︙

Modified test_records.scm from [7236ce2839] to [9245906f33]. 

1
2

3
4
5
6
7
8
9

10
11
12
13
14
15
16



1

2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19


-
+







+







+
+

;; make-vector-record tests testqueue testname testconfig waitons priority items
(define (make-tests:testqueue)(make-vector 6 #f))
(define (make-tests:testqueue)(make-vector 7 #f))
(define-inline (tests:testqueue-get-testname     vec)    (vector-ref  vec 0))
(define-inline (tests:testqueue-get-testconfig   vec)    (vector-ref  vec 1))
(define-inline (tests:testqueue-get-waitons      vec)    (vector-ref  vec 2))
(define-inline (tests:testqueue-get-priority     vec)    (vector-ref  vec 3))
;; items: #f=no items, list=list of items remaining, proc=need to call to get items
(define-inline (tests:testqueue-get-items        vec)    (vector-ref  vec 4))
(define-inline (tests:testqueue-get-itemdat      vec)    (vector-ref  vec 5))
(define-inline (tests:testqueue-get-item_path    vec)    (vector-ref  vec 6))

(define-inline (tests:testqueue-set-testname!    vec val)(vector-set! vec 0 val))
(define-inline (tests:testqueue-set-testconfig!  vec val)(vector-set! vec 1 val))
(define-inline (tests:testqueue-set-waitons!     vec val)(vector-set! vec 2 val))
(define-inline (tests:testqueue-set-priority!    vec val)(vector-set! vec 3 val))
(define-inline (tests:testqueue-set-items!       vec val)(vector-set! vec 4 val))
(define-inline (tests:testqueue-set-itemdat!     vec val)(vector-set! vec 5 val))
(define-inline (tests:testqueue-set-item_path!   vec val)(vector-set! vec 6 val))

Modified tests.scm from [ae091a19dc] to [366fb2c610].

︙
283
284
285
286
287
288
289
290

291
292
293
294
295
296
297

283
284
285
286
287
288
289

290
291
292
293
294
295
296
297








-
+








    (debug:print 4 "INFO: Looking at tests " (string-intersperse tests ","))
    (for-each (lambda (testpath)
		(if (file-exists? (conc testpath "/testconfig"))
		    (set! res (cons (last (string-split testpath "/")) res))))
	      tests)
    res))

(define (test:get-testconfig test-name system-allowed)
(define (tests:get-testconfig test-name system-allowed)
  (let* ((test-path    (conc *toppath* "/tests/" test-name))
	 (test-configf (conc test-path "/testconfig"))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf))))
    (if testexists
	(read-config test-configf #f system-allowed environ-patt: (if system-allowed
								      "pre-launch-env-vars"
								      #f))
︙
335
336
337
338
339
340
341





































342
343
344
345
346
347
348

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








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








	     #f ;; cannot have a which is waiting on b happening before b
	     (if (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons))
		 #t ;; this is the correct order, b is waiting on a and b is before a
		 (if (> a-priority b-priority)
		     #t ;; if a is a higher priority than b then we are good to go
		     #f))))))))

;; for each test:
;;   
(define (tests:filter-non-runnable db run-id testkeynames testrecordshash)
  (let ((runnables '()))
    (for-each
     (lambda (testkeyname)
       (let* ((test-record (hash-table-ref testrecordshash testkeyname))
	      (test-name   (tests:testqueue-get-testname  test-record))
	      (itemdat     (tests:testqueue-get-itemdat   test-record))
	      (item-path   (tests:testqueue-get-item_path test-record))
	      (waitons     (tests:testqueue-get-waitons   test-record))
	      (keep-test   #t)
	      (tdat        (db:get-test-info db run-id test-name item-path)))
	 (if tdat
	     (begin
	       ;; Look at the test state and status
	       (if (or (member (db:test-get-status tdat) 
			       '("PASS" "WARN" "WAIVED" "CHECK"))
		       (member (db:test-get-state tdat)
			       '("INCOMPLETE" "KILLED")))
		   (set! keep-test #f))

	       ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
	       ;; from the runnable list
	       (if keep-test
		   (for-each (lambda (waiton)
			       ;; for now we are waiting only on the parent test
			       (let ((wtdat (db:get-test-info db run-id waiton ""))) 
				 (if (or (member (db:test-get-status wtdat)
						 '("FAIL" "KILLED"))
					 (member (db:test-get-state wtdat)
						 '("INCOMPETE")))
				     (set! keep-test #f)))) ;; no point in running this one again
			     waitons))))
	 (if keep-test (set! runnables (cons testkeyname runnables)))))
     testkeynames)
    runnables))

;;======================================================================
;; test steps
;;======================================================================

;; teststep-set-status! used to be here
︙

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