Megatest

Check-in [eccc3dc4d0]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:More streamlining
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | test-specific-db
Files: files | file ages | folders
SHA1: eccc3dc4d0f01f79633392353446b8b4fcd033aa
User & Date: matt on 2012-09-22 15:14:00
Other Links: branch diff | manifest | tags
Context
2012-09-22
17:03
Added addaptive delay for database collision mitigation check-in: 25def8d8a4 user: matt tags: test-specific-db
15:14
More streamlining check-in: eccc3dc4d0 user: matt tags: test-specific-db
2012-09-21
17:20
Streamlined a few queries, did more conversions to open-run-close check-in: ea8a0d8ef0 user: mrwellan tags: test-specific-db
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified dashboard.scm from [53663af7c6] to [9bc1b8f5fe].

︙
443
444
445
446
447
448
449
450

451
452
453
454
455
456
457

443
444
445
446
447
448
449

450
451
452
453
454
455
456
457








-
+








	      (iup:button "HideEmpty" #:action (lambda (obj)
						 (set! *hide-empty-runs* (not *hide-empty-runs*))
						 (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+Hide" "-Hide"))
						 (mark-for-update)))
	      (iup:button "Refresh"   #:action (lambda (obj)
						 (mark-for-update))))
	     (iup:hbox
	      (iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(exit)))
	      (iup:button "Quit" #:action (lambda (obj)(if *db* (sqlite3:finalize! *db*))(exit)))
	      (iup:button "Monitor" #:action (lambda (obj)(system (conc (car (argv))" -guimonitor &")))))
	     ))
	   ;; (iup:button "<-  Left" #:action (lambda (obj)(set! *start-run-offset*  (+ *start-run-offset* 1))))
	   ;; (iup:button "Up     ^" #:action (lambda (obj)(set! *start-test-offset* (if (> *start-test-offset* 0)(- *start-test-offset* 1) 0))))
	   ;; (iup:button "Down   v" #:action (lambda (obj)(set! *start-test-offset* (if (>= *start-test-offset* (length *alltestnamelst*))(length *alltestnamelst*)(+ *start-test-offset* 1)))))
	   ;; (iup:button "Right ->" #:action (lambda (obj)(set! *start-run-offset*  (if (> *start-run-offset* 0)(- *start-run-offset* 1) 0))))
	   (iup:frame
︙

Modified db.scm from [6bc38e85a0] to [5d54b40bcf].

︙
50
51
52
53
54
55
56
57

58
59
60
61










62
63
64
65
66
67
68

50
51
52
53
54
55
56

57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78








-
+




+
+
+
+
+
+
+
+
+
+








    (if (config-lookup *configdat* "setup"     "synchronous")
        (begin
          (debug:print 5 "INFO: Turning off pragma synchronous")
          (sqlite3:execute db "PRAGMA synchronous = 0;"))
        (debug:print 5 "INFO: NOT turning off pragma synchronous"))
    db))

(define (open-run-close proc idb . params)
(define (open-run-close  proc idb . params)
  (let* ((db  (if idb idb (open-db)))
	 (res (apply proc db params)))
    (if (not idb)(sqlite3:finalize! db))
    res))

(define *global-delta* 0)
(define (open-run-close-measure  proc idb . params)
  (let* ((start-ms (current-milliseconds))
	 (db       (if idb idb (open-db)))
	 (res      (apply proc db params)))
    (if (not idb)(sqlite3:finalize! db))
    (set! *global-delta* (- (current-milliseconds) start-ms))
    (print "INFO: delta=" *global-delta*)
    res))

(define (db:initialize db)
  (let* ((configdat (car *configinfo*))  ;; tut tut, global warning...
	 (keys     (config-get-fields configdat))
	 (havekeys (> (length keys) 0))
	 (keystr   (keys->keystr keys))
	 (fieldstr (keys->key/field keys)))
︙

Modified runs.scm from [22f36fb01a] to [cf939585e7].

︙
61
62
63
64
65
66
67
68

69
70
71
72
73
74
75

61
62
63
64
65
66
67

68
69
70
71
72
73
74
75








-
+









(define (runs:test-get-full-path test)
  (let* ((testname (db:test-get-testname   test))
	 (itempath (db:test-get-item-path test)))
    (conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))

(define (set-megatest-env-vars db run-id)
  (let ((keys (rdb:get-keys db)))
  (let ((keys (db:get-keys db)))
    (for-each (lambda (key)
		(sqlite3:for-each-row
		 (lambda (val)
		   (debug:print 2 "setenv " (key:get-fieldname key) " " val)
		   (setenv (key:get-fieldname key) val))
		 db 
		 (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;")
︙
282
283
284
285
286
287
288
289

290
291
292
293
294
295
296

282
283
284
285
286
287
288

289
290
291
292
293
294
295
296








-
+








    ;; NB// Should expand items here and then insert into the run queue.
  (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags))
  (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records))
	(item-patts        (hash-table-ref/default flags "-itempatt" #f)))
    (if (not (null? sorted-test-names))
	(let loop ((hed         (car sorted-test-names))
		   (tal         (cdr sorted-test-names)))
	  (thread-sleep! 0.1) ;; give other applications some time with the db
	  (thread-sleep! (/ *global-delta* 10)) ;; give other applications some time with the db
	  (let* ((test-record (hash-table-ref test-records hed))
		 (tconfig     (tests:testqueue-get-testconfig test-record))
		 (testmode    (let ((m (config-lookup tconfig "requirements" "mode")))
				(if m (string->symbol m) 'normal)))
		 (waitons     (tests:testqueue-get-waitons    test-record))
		 (priority    (tests:testqueue-get-priority   test-record))
		 (itemdat     (tests:testqueue-get-itemdat    test-record)) ;; itemdat can be a string, list or #f
︙
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

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








-
-
+
+
+
-
















-
+











-
+








	      (let* ((have-resources  (open-run-close runs:can-run-more-tests #f test-record)) ;; look at the test jobgroup and tot jobs running
		     (prereqs-not-met (open-run-close db:get-prereqs-not-met #f run-id waitons item-path mode: testmode))
		     (fails           (calc-fails prereqs-not-met))
		     (non-completed   (calc-not-completed prereqs-not-met)))
		(debug:print 8 "INFO: have-resources: " have-resources " prereqs-not-met: " 
			     (string-intersperse 
			      (map (lambda (t)
				     (if (not (vector? t))
					 (conc " WARNING: t is not a vector=" t )
				     (if (vector? t)
					 (conc (db:test-get-state t) "/" (db:test-get-status t))
					 (conc " WARNING: t is not a vector=" t )))
					 (conc (db:test-get-state t) "/" (db:test-get-status t))))
				   prereqs-not-met) ", ") " fails: " fails)
		;; 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?
		(cond
		 ((and have-resources
		       (or (null? prereqs-not-met)
			   (and (eq? testmode 'toplevel)
				(null? non-completed))))
		  ;; no loop here, just drop though and use the loop at the bottom 
		  (if (patt-list-match item-path item-patts)
		      (run:test run-id runname keyvallst test-record flags #f)
		      (debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts))
		  ;; else the run is stuck, temporarily or permanently
		  ;; but should check if it is due to lack of resources vs. prerequisites
		  )
		 ((not have-resources) ;; simply try again after waiting a second
		  (thread-sleep! 1.0)
		  (thread-sleep! (* *global-delta* *global-delta*))
		  (debug:print 1 "INFO: no resources to run new tests, waiting ...")
		  ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
		  (loop (car newtal)(cdr newtal)))
		 (else ;; must be we have unmet prerequisites
		    (debug:print 4 "FAILS: " fails)
		    ;; If one or more of the prereqs-not-met are FAIL then we can issue
		    ;; a message and drop hed from the items to be processed.
		    (if (null? fails)
			(begin
			  ;; couldn't run, take a breather
			  (debug:print 4 "INFO: Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...")
			  (thread-sleep! 0.1) ;; long sleep here - no resources, may as well be patient
			  (thread-sleep! (* *global-delta* *global-delta*)) ;; long sleep here - no resources, may as well be patient
			  ;; we made new tal by sticking hed at the back of the list
			  (loop (car newtal)(cdr newtal)))
			;; the waiton is FAIL so no point in trying to run hed ever again
			(if (not (null? tal))
			    (begin
			      (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed)
					   " from the launch list as it has prerequistes that are FAIL")
︙
427
428
429
430
431
432
433
434

435
436
437
438
439
440
441

427
428
429
430
431
432
433

434
435
436
437
438
439
440
441








-
+








		       ((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)))
			(let ((test-name (tests:testqueue-get-testname test-record)))
			  (setenv "MT_TEST_NAME" test-name) ;; 
			  (setenv "MT_RUNNAME"   runname)
			  (open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process
			  (open-run-close-measure set-megatest-env-vars #f run-id) ;; 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)
				  (loop hed tal))
				(begin
				  (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this")
︙
472
473
474
475
476
477
478
479

480
481
482
483
484
485
486

472
473
474
475
476
477
478

479
480
481
482
483
484
485
486








-
+








		(thread-sleep! 0.5)
		;; FIXME! This harsh exit should not be necessary....
		(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 (open-run-close tests:filter-non-runnable #f run-id tal test-records))) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED,
		(thread-sleep! 0.1)
		(thread-sleep! (/ *global-delta* 10))
		(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 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))
︙
499
500
501
502
503
504
505
506

507
508
509
510
511
512
513

499
500
501
502
503
504
505

506
507
508
509
510
511
512
513








-
+








		 )
    ;; setting itemdat to a list if it is #f
    (if (not itemdat)(set! itemdat '()))
    (set! item-path (item-list->path itemdat))
    (debug:print 2 "Attempting to launch test " test-name "/" item-path)
    (setenv "MT_TEST_NAME" test-name) ;; 
    (setenv "MT_RUNNAME"   runname)
    (open-run-close set-megatest-env-vars db run-id) ;; these may be needed by the launching process
    (open-run-close-measure set-megatest-env-vars db run-id) ;; these may be needed by the launching process
    (change-directory *toppath*)

    ;; Here is where the test_meta table is best updated
    ;; Yes, another use of a global for caching. Need a better way?
    (if (not (hash-table-ref/default *test-meta-updated* test-name #f))
        (begin
	   (hash-table-set! *test-meta-updated* test-name #t)
︙

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