1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
|
1
2
3
4
5
6
7
8
9
10
11
12
|
-
-
-
-
-
-
-
-
+
+
|
;; (use trace)
;; (trace
;; runs:queue-next-hed
;; runs:queue-next-tal
;; runs:queue-next-reg
;; )
;; At this point the list of parent tests is expanded
;; NB// Should expand items here and then insert into the run queue.
|
| ︙ | | |
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
|
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
|
(if (member test-name waitons)
(begin
(debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!")
(set! waiton (filter (lambda (x)(not (equal? x hed))) waitons))))
(cond ;; OUTER COND
((not items) ;; when false the test is ok to be handed off to launch (but not before)
(if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path))
(not (null? tal)))
(loop (car tal)(cdr tal) reg reruns))
(let* ((run-limits-info (runs:can-run-more-tests test-record max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
(have-resources (car run-limits-info))
(num-running (list-ref run-limits-info 1))
(num-running-in-jobgroup (list-ref run-limits-info 2))
(max-concurrent-jobs (list-ref run-limits-info 3))
(job-group-limit (list-ref run-limits-info 4))
(prereqs-not-met (db: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 8 "have-resources: " have-resources " prereqs-not-met: "
(string-intersperse
(map (lambda (t)
(if (vector? t)
(conc (db:test-get-state t) "/" (db:test-get-status t))
(conc " WARNING: t is not a vector=" t )))
prereqs-not-met) ", ") " fails: " fails)
(string-intersperse
(map (lambda (t)
(if (vector? t)
(conc (db:test-get-state t) "/" (db:test-get-status t))
(conc " WARNING: t is not a vector=" t )))
prereqs-not-met) ", ") " fails: " fails)
(debug:print-info 4 "hed=" hed "\n test-record=" test-record "\n test-name: " test-name "\n item-path: " item-path "\n test-patts: " test-patts)
;; 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?
(debug:print-info 4 "run-limits-info = " run-limits-info)
(cond ;; INNER COND #1 for a launchable test
;; Check item path against item-patts
|
| ︙ | | |
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
-
-
-
+
+
+
-
+
-
-
+
+
|
;; ((eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f) 'start)
;; (thread-sleep! 0.01)
;; (loop (car newtal)(cdr newtal) reruns))
;; count number of 'done, if more than 100 then skip on through.
((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) ;; ) ;; too many changes required. Implement later.
(debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" )
(let ((th (make-thread (lambda ()
(mutex-lock! registry-mutex)
(hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start)
(mutex-unlock! registry-mutex)
(mutex-lock! registry-mutex)
(hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start)
(mutex-unlock! registry-mutex)
;; If haven't done it before register a top level test if this is an itemized test
(if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done))
(cdb:tests-register-test *runremote* run-id test-name ""))
(cdb:tests-register-test *runremote* run-id test-name item-path)
(mutex-lock! registry-mutex)
(mutex-lock! registry-mutex)
(hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done)
(mutex-unlock! registry-mutex))
(conc test-name "/" item-path))))
(mutex-unlock! registry-mutex))
(conc test-name "/" item-path))))
(thread-start! th))
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
(if (and (null? tal)(null? reg))
(loop hed tal reg reruns)
(loop (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(let ((newl (append reg (list hed))))
|
| ︙ | | |
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; (thread-sleep! *global-delta*)
(if (not (null? tal))
(loop (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)))
(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-info 4 "Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...")
;; (thread-sleep! (+ 0.01 *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) reg reruns))
;; the waiton is FAIL so no point in trying to run hed ever again
(if (not (null? tal))
(if (vector? hed)
(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")
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
(hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed)
(loop (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
(cons hed reruns)))
(begin
(debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! (+ 0.01 *global-delta*))
(loop hed tal reg reruns))))))))) ;; END OF INNER COND
(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-info 4 "Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...")
;; (thread-sleep! (+ 0.01 *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) reg reruns))
;; the waiton is FAIL so no point in trying to run hed ever again
(if (not (null? tal))
(if (vector? hed)
(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")
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
(hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed)
(loop (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
(cons hed reruns)))
(begin
(debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! (+ 0.01 *global-delta*))
(loop hed tal reg reruns))))))))) ;; END OF INNER COND
;; 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 (and (debug:debug-mode 1) ;; (>= *verbosity* 1)
(> (length items) 0)
(> (length (car items)) 0))
|
| ︙ | | |
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
|
-
+
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
|
(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)
(if (not (null? tal))
(begin
(debug:print-info 4 "End of items list, looping with next after short delay")
;; (thread-sleep! (+ 0.01 *global-delta*))
"\n testname: " hed
"\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
"\n non-completed: " (runs:pretty-string non-completed)
"\n fails: " (runs:pretty-string fails)
"\n testmode: " testmode
"\n num-retries: " num-retries
"\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel)
"\n (null? non-completed): " (null? non-completed)
"\n reruns: " reruns
"\n items: " items
"\n can-run-more: " can-run-more)
"\n testname: " hed
"\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
"\n non-completed: " (runs:pretty-string non-completed)
"\n fails: " (runs:pretty-string fails)
"\n testmode: " testmode
"\n num-retries: " num-retries
"\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel)
"\n (null? non-completed): " (null? non-completed)
"\n reruns: " reruns
"\n items: " items
"\n can-run-more: " can-run-more)
;; (thread-sleep! (+ 0.01 *global-delta*))
(cond ;; INNER COND #2
((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)))
|
| ︙ | | |
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
|
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
|
-
-
+
+
-
+
|
(loop (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))
(loop (car newtal)(cdr newtal) reg reruns))) ;; an issue with prereqs not yet met?
((and (not (null? fails))(eq? testmode 'normal))
(debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); "
(string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
", removing it from to-do list")
(string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
", removing it from to-do list")
(if (not (null? tal))
(begin
;; (thread-sleep! *global-delta*)
|
| ︙ | | |
328
329
330
331
332
333
334
335
336
337
|
325
326
327
328
329
330
331
332
333
334
|
-
-
-
+
+
+
|
;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!!
(debug:print-info 1 "All tests launched")
(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
|