Megatest

Diff
Login

Differences From Artifact [ace8916649]:

To Artifact [bbb893475a]:


313
314
315
316
317
318
319
320



321
322
323
324
325
326
327
313
314
315
316
317
318
319

320
321
322
323
324
325
326
327
328
329







-
+
+
+







	   (args:get-arg "-one-pass"))
      (exit 0))

  (thread-sleep! (cond ;; BB: check with Matt.  Should this sleep move
		       ;; to cond clauses below where we determine we
		       ;; have too many jobs running rather than each
		       ;; time the and condition above is true (which
		       ;; seems like always)?
		  ;; seems like always)?
		  ((< (- (current-seconds)(runs:dat-beginning-of-time runsdat)) 30) ;; for the first 30 seconds do not throttle in any way
		   0)
        	  ((> (runs:dat-can-run-more-tests-count runsdat) 20) ;; original intent was - save cycles, wait a long time
		   (if (runs:lownoise "waiting on tasks" 60)(debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ..."))
		   10)  ;; obviously haven't had any work to do for a while
		  (else 0)))
;;		   ;; if have a number for inter-test-delay, use it, else don't delay much, maybe even zero?
;;		   (configf:lookup-number *configdat* "setup" "inter-test-delay" default: 0.01)
;;		   )))
1190
1191
1192
1193
1194
1195
1196
1197

1198
1199
1200
1201
1202
1203
1204
1192
1193
1194
1195
1196
1197
1198

1199
1200
1201
1202
1203
1204
1205
1206







-
+







     ;; If no resources are available just kill time and loop again
     ;;
     ((not have-resources) ;; simply try again after waiting a second
      (if (runs:lownoise "no resources" 60)
	  (debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ..."))
      ;; Have gone back and forth on this but db starvation is an issue.
      ;; wait one second before looking again to run jobs.
      (thread-sleep! 1)
      (thread-sleep! 0.25)
      ;; could have done hed tal here but doing car/cdr of newtal to rotate tests
      (list (car newtal)(cdr newtal) reg reruns))
     
     ;; This is the final stage, everything is in place so launch the test
     ;;
     ((and have-resources
	   (or (null? prereqs-not-met)
2041
2042
2043
2044
2045
2046
2047
2048

2049
2050
2051
2052
2053
2054
2055
2043
2044
2045
2046
2047
2048
2049

2050
2051
2052
2053
2054
2055
2056
2057







-
+







		     (begin
		       (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test)
		       (debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test))
		     ;;
		     ;; Here the test is handed off to launch.scm for launch-test to complete the launch process
		     ;;
		     (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags))
	 		 (begin
			 (begin
			   (print "ERROR: Failed to launch the test. Exiting as soon as possible")
			   (set! *globalexitstatus* 1) ;; 
			   (process-signal (current-process-id) signal/kill))))))))
	((KILLED) 
	 (debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
	 (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED))
	((LAUNCHED REMOTEHOSTSTART RUNNING)  
2117
2118
2119
2120
2121
2122
2123
2124

2125
2126
2127
2128
2129
2130
2131
2119
2120
2121
2122
2123
2124
2125

2126
2127
2128
2129
2130
2131
2132
2133







-
+







;;
(define (runs:get-hash-by-target target-patts runpatt)
  (let* ((targets (string-split target-patts ","))
	 (keys    (rmt:get-keys))
	 (res-ht  (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... )
    (for-each
     (lambda (target-patt)
       (let ((runs     (rmt:simple-get-runs runpatt #f #f target-patt)))
       (let ((runs     (rmt:simple-get-runs runpatt #f #f target-patt #f)))
	 (for-each
	  (lambda (run)
	    (let ((target (simple-run-target run)))
	      (hash-table-set! res-ht target (cons run (hash-table-ref/default res-ht target '())))))
	  runs)))
     targets)
    res-ht))