Megatest

Check-in [333191162a]
Login
Overview
Comment:fixed logic in test registration. More agressive starting of a server when sync takes a long time
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: 333191162a91c70dc3731cb977e732429e1e5dac
User & Date: matt on 2014-11-16 21:50:06
Other Links: branch diff | manifest | tags
Context
2014-11-16
21:58
Tweaks for testing check-in: afb9cc1df1 user: mrwellan tags: v1.60
21:50
fixed logic in test registration. More agressive starting of a server when sync takes a long time check-in: 333191162a user: matt tags: v1.60
20:51
missed a variable change in a almost never used routine - only to trigger the use of said routine. check-in: 4cfc6e3ba2 user: matt tags: v1.60
Changes

Modified megatest.scm from [3ecca6725e] to [521d8a79fe].

300
301
302
303
304
305
306
307

308
309
310
311

312
313
314
315
316
317
318
319
300
301
302
303
304
305
306

307

308
309

310

311
312
313
314
315
316
317







-
+
-


-
+
-







	    (if (hash-table-ref/default *db-local-sync* run-id #f)
		;; (if (> (- start-time last-write) 5) ;; every five seconds
		(let ((sync-time (- (current-seconds) start-time)))
		  (db:multi-db-sync (list run-id) 'new2old)
		  (if (common:low-noise-print 30 "sync new to old")
		      (begin
			(debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")
			(if (and (> sync-time 10) ;; took more than ten seconds, start a server for this run
			(if (> sync-time 10) ;; took more than ten seconds, start a server for this run
				 (hash-table-ref/default servers-started run-id #f))
			    (begin
			      (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id)
			      (server:kind-run run-id)
			      (server:kind-run run-id)))))
			      (hash-table-set! servers-started run-id #t)))))
		  (hash-table-delete! *db-local-sync* run-id)))
	    (mutex-unlock! *db-multi-sync-mutex*))
	  (hash-table-keys *db-local-sync*)))

       ;; keep going unless time to exit
       ;;
       (if (not *time-to-exit*)

Modified runs.scm from [94d1fbb17e] to [e885f5dfc6].

670
671
672
673
674
675
676

677

678
679


680
681
682
683
684
685
686
670
671
672
673
674
675
676
677
678
679


680
681
682
683
684
685
686
687
688







+

+
-
-
+
+







     
     ;; Register tests 
     ;;
     ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f))
      (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" )
      ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs
      (rmt:general-call 'register-test run-id run-id test-name item-path)
      (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done)
      (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done))
	  (begin
	  (rmt:general-call 'register-test run-id run-id test-name ""))
      (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done)
	    (rmt:general-call 'register-test run-id run-id test-name "")
	    (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done)))
      (runs:shrink-can-run-more-tests-count)   ;; DELAY TWEAKER (still needed?)
      (if (and (null? tal)(null? reg))
	  (list hed tal (append reg (list hed)) reruns)
	  (list (runs:queue-next-hed tal reg reglen regfull)
		(runs:queue-next-tal tal reg reglen regfull)
		;; NB// Here we are building reg as we register tests
		;; if regfull we must pop the front item off reg

Modified server.scm from [13f9300039] to [f2b9d5f3d9].

112
113
114
115
116
117
118
119

120
121
122
123
124
125
126
112
113
114
115
116
117
118

119
120
121
122
123
124
125
126







-
+







    (pop-directory)))

;; kind start up of servers, wait 40 seconds before allowing another server for a given
;; run-id to be launched
(define (server:kind-run run-id)
  (let ((last-run-time (hash-table-ref/default *server-kind-run* run-id #f)))
    (if (or (not last-run-time)
	    (> (- (current-seconds) last-run-time) 40))
	    (> (- (current-seconds) last-run-time) 30))
	(begin
	  (server:run run-id)
	  (hash-table-set! *server-kind-run* run-id (current-seconds))))))

;; The generic run a server command. Dispatches the call to server 0 if run-id != 0
;; 
(define (server:try-running run-id)