Megatest

Changes On Branch 985f2017bfb837bb
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Hide Diff Patch Side-by-Side Diff

Changes In Branch debug_chained_waiton Through [985f2017bf] Excluding Merge-Ins

This is equivalent to a diff from f01b76ecf0 to 985f2017bf

2016-04-22
09:18
Some minor refactoring of items.scm, runs.scm and tests.scm: removed a placeholder for the one-record effort (defunct), added few helpful comments and moved some inline code to a function check-in: 4460ca12ae user: mrwellan tags: v1.60_defunct
2016-04-18
15:41
adding my changes to runs.scm -- note: not in a completely runnable state check-in: 9ff8cae0bf user: bjbarcla tags: debug_chained_waiton, v1.60_defunct
15:30
adding dfs poc for solving chained-waiton check-in: 985f2017bf user: bjbarcla tags: debug_chained_waiton, v1.60_defunct
2016-04-12
18:26
found locus of debug_chained_waiton issue check-in: cd59ba0d0b user: bjbarcla tags: debug_chained_waiton, v1.60_defunct
2016-04-06
15:50
Resurrected get and set vars from the meta table check-in: f01b76ecf0 user: mrwellan tags: v1.6031, v1.60_defunct
14:39
Added nodot support for tests view check-in: 30cb850fed user: mrwellan tags: v1.60_defunct

Added dfs.scm version [d2739ff496]. 



















































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
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
198
199
200
201
202
203
204
205
206
207
208
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

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


(use extras)
(use data-structures)
(use srfi-1)
(use regex)


(define (tests:get-test-property test-registry test property)
  (let loop ((rem-test-registry test-registry) (res #f))
    (if (null? rem-test-registry)
        res
        (let* ((this-test (car rem-test-registry))
              (this-testname (car this-test))
              (this-testrec (cdr this-test)))
          (if (eq? this-testname test)
              (alist-ref property this-testrec)
              (loop (cdr rem-test-registry) res))))))

(define (tests:get-test-waitons test-registry test)
  (tests:get-test-property test-registry test 'waitons))

(define (tests:get-test-list test-registry)
  (map car test-registry))


(define (alist-push alist key val)
  (let ((current (alist-ref key alist)))
    (if current
        (alist-update key (cons val current) alist)
        (cons (list key val) alist))))

  
(define (test:get-adj-list test-registry)
  (let loop ((rem-tests (tests:get-test-list test-registry)) (res '()))
    (if (null? rem-tests)
        res
        (let* ((test (car rem-tests))
               (rest-rem-tests (cdr rem-tests))
               (waitons
                (or
                 (tests:get-test-waitons test-registry test)
                 '())))
          (loop rest-rem-tests
                (let loop2 ((rem-waitons waitons) (res2 res))
                  (if (null? rem-waitons)
                      res2
                      (let* ((waiton (car rem-waitons))
                             (rest-waitons (cdr rem-waitons))
                             (next-res (alist-push res2 waiton test)))
                        (loop2 rest-waitons next-res)))))))))



(define (add-item-to-items-list item items)
  (cond
   ((eq? item '%) 
    (list '%))
   ((member '% items) (print "% in items")
    (list '%))
   ((member item items) 
    items)
   (else
    (cons item items))))

(define (append-items-lists l1 l2)
  (let loop ((rem-l1 l1) (res l2))
    (if (null? rem-l1)
        res
        (let* ((hed-rem-l1 (car rem-l1))
               (tal-rem-l1 (cdr rem-l1))
               (new-res (add-item-to-items-list hed-rem-l1 res)))
          (loop tal-rem-l1 new-res)))))


(define (testpatt->alist testpatt)
  (if (string? testpatt)
      (let ((patts (string-split testpatt ",")))
        (if (null? patts) ;;; no pattern(s) means no match
            #f
            (let loop ((rest-patts patts) (res  '()))
              ;; (print "loop: patt: " patt ", tal " tal)
              (if (null? rest-patts)
                  res
                  (let* ((hed-patt (car rest-patts))
                         (tal-rest-patts (cdr rest-patts))
                         (patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") hed-patt))
                         (test (string->symbol (cadr patt-parts)))
                         (item-patt-raw  (cadddr patt-parts))
                         (item-patt
                          (if item-patt-raw
                              (string->symbol item-patt-raw)
                              '%))
                         (existing-item-patts (or (alist-ref test res) '()))
                         (new-item-patts (add-item-to-items-list item-patt existing-item-patts))
                         (new-res (alist-update test new-item-patts res)))
                    (print "BB->: test="test" item-patt-raw="item-patt-raw" item-patt="item-patt" existing-item-patts="existing-item-patts" new-item-patts="new-item-patts)
                    (loop tal-rest-patts new-res))))))))

(define (traverse node adj-list path)
  ;(print "node="node" path="path)
  (let ((children (alist-ref node adj-list)))
    (cond
     ((not children)  (list (cons node path)))
     (else
      (apply append
             (map
              (lambda (child)
                (traverse child adj-list (cons node path)))
              children))))))

(define test-registry
  '(
    (aa . ( (items . ( 1 2 3 )) ))
    (a  . ( (items . ( 1 2 3 )) ))
    (b  . ( (items . ( 1 2 3 ))
           (waitons . (a)   ) ) )
    (c  . ( (items . ( 1 2 3 ))
           (waitons . (a)   ) ) )
    (f  . ( (items . ( 1 2 3 ))
           (waitons . (a)   ) ) )
    (d  . ( (items . ( 1 2 3 ))
           (waitons . (b c) ) ) )
    (g  . ( (items . ( 1 2 3 ))
           (waitons . (b)   ) ) )
    (e  . ( (items . ( 1 2 3 ))
           (waitons . (d)   ) ) )
    (h  . ( (items . ( 1 2 3 ))
           (waitons . (d)   ) ) )
       ))

(set! test-registry2
      (cons
       (cons 'ALL-TESTS (list (cons 'waitons (tests:get-test-list test-registry))))
       test-registry))



(pretty-print test-registry)
(define adj-list (test:get-adj-list test-registry))

(print "adjacency list=")(pretty-print adj-list)

(print "topological-sort=" (topological-sort adj-list eq?))

(define seed-testpatt "a/1,a/2,d,aa/%")
(define seed-testpatt-alist (testpatt->alist seed-testpatt))

;;(define seed-tests '(d aa))
(define seed-tests (map car seed-testpatt-alist))
(print "seed-testpatt="seed-testpatt"\n** seed-testpatt-alist="seed-testpatt-alist"\n seed-tests="seed-tests)

(define waiton-paths
  (map
   reverse
   (apply append
          (map
           (lambda (test)
             (traverse test adj-list '())) seed-tests))))
       

(print "waiton-paths=")
(pretty-print waiton-paths)  


(define (get-waiton-items parent-test parent-item-patterns waiton-test test-registry)
  (let* ((parent-item->waiton-item (lambda (x) x)) ;; super simplified vs. megatest, should use itemmap property
         (waiton-test-items (or (tests:get-test-property test-registry waiton-test 'items) '(%)))
         )
    (let loop ((rest-parent-item-patterns parent-item-patterns) (res '()))
      (if (null? rest-parent-item-patterns)
          res
          (let* ((hed-parent-item (car rest-parent-item-patterns))
                 (tal-parent-items (cdr rest-parent-item-patterns))
                 (newres (add-item-to-items-list (parent-item->waiton-item hed-parent-item) res)))
            (loop tal-parent-items newres))))))
   
(define (push-itempatt-down-path waiton-path seed-items test-registry )
  (let loop ((rest-path waiton-path) (waiton-items seed-items) (res '())  )
    (if (null? rest-path)
        res
        (let* ((hed-test (car rest-path))
               (tal-path (cdr rest-path))
               (waiton-test (car rest-path))
               (waiton-items (get-waiton-items hed-test waiton-items waiton-test test-registry))
               (new-res (cons (cons waiton-test waiton-items) res)))
                 
          (loop tal-path waiton-items new-res)))))
               
(print "testpatts from first path="(car waiton-paths))

(define (condense-alist alist)
  (let loop ((rest-alist alist) (res '()))
    (if (null? rest-alist)
        res
        (let* ((hed-alist (car rest-alist))
               (tal-alist (cdr rest-alist))
               (key (car hed-alist))
               (new-items (cdr hed-alist))
               (existing-list (alist-ref key res))
               (new-list
                (if existing-list
                    (append-items-lists new-items existing-list)
                    new-items
                    ))
               (new-res (alist-update key new-list res)))
          (loop tal-alist new-res)))))
               
                    

(define (get-elaborated-testpatt-alist waiton-paths seed-testpatt-alist test-registry)
  (let ((raw-res
         (let loop ((rest-waiton-paths waiton-paths) (res '()))
           (if (null? rest-waiton-paths)
               res
               (let* ((hed-path (car rest-waiton-paths))
                      (tal-paths (cdr rest-waiton-paths))
                      (test (car hed-path))
                      (items (alist-ref test seed-testpatt-alist))
                      (new-res (cons (push-itempatt-down-path hed-path items test-registry) res))
                      
                      
                      )
                 (loop tal-paths new-res))))))
    (condense-alist raw-res)))
        


(pretty-print
 (get-elaborated-testpatt-alist waiton-paths seed-testpatt-alist test-registry))










  









Modified runs.scm
from [62ed47157d]
to [8f7cfd9962].




︙


235
236
237
238
239
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

235
236
237
238
239
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








-
+











-
+







+



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


-
-
+
+
+








;;              of tests to run. The item portions are not respected.
;;              FIXME: error out if /patt specified
;;            
(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names
  (let* ((keys               (keys:config-get-fields *configdat*))
	 (keyvals            (keys:target->keyval keys target))
	 (run-id             (rmt:register-run keyvals runname "new" "n/a" user))  ;;  test-name)))
	 (deferred          '()) ;; delay running these since they have a waiton clause
	 (deferred          '()) ;; delay running these since they have a waiton clause (never used - BB)
	 (runconfigf         (conc  *toppath* "/runconfigs.config"))
	 (test-records       (make-hash-table))
	 ;; need to process runconfigs before generating these lists
	 (all-tests-registry #f)  ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
	 (all-test-names     #f)  ;; (hash-table-keys all-tests-registry))
	 (test-names         #f)  ;; (tests:filter-test-names all-test-names test-patts))
	 (required-tests     #f)  ;; Put fully qualified test/testpath names in this list to be done
	 (task-key           (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id)))
	 (tdbdat             (tasks:open-db))
	 (config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
			       (if x (string->number x) #f))))

    (debug:print-info 0 "BB------------------------------------------------\nBB: entered run:run-tests with target="target" runname="runname" test-patts="test-patts" user="user" flags="flags" run-count="run-count)
    ;; override the number of reruns from the configs
    (if (and config-reruns
	     (> run-count config-reruns))
	(set! run-count config-reruns))
    
    (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))

    ;; if signal received, clean up and exit
    (let ((sighand (lambda (signum)
		     ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
		     (if (eq? signum signal/stop)
			 (debug:print 0 "ERROR: attempt to STOP process. Exiting."))
		     (set! *time-to-exit* #t)
		     (print "Received signal " signum ", cleaning up before exit. Please wait...")
		     (let ((th1 (make-thread (lambda ()
					       (let ((tdbdat (tasks:open-db)))
						 (rmt:tasks-set-state-given-param-key task-key "killed"))
					       (print "Killed by signal " signum ". Exiting")
					       (thread-sleep! 3)
					       (exit))))
			   (th2 (make-thread (lambda ()
					       (thread-sleep! 5)
					       (debug:print 0 "Done")
					       (exit 4)))))
		       (thread-start! th2)
		       (thread-start! th1)
		       (thread-join! th2)))))
			 (debug:print 0 "ERROR: attempt to STOP process.")
                         (begin
                           (set! *time-to-exit* #t)
                           (print "Received signal " signum ", cleaning up before exit. Please wait...")
                           (let ((th1 (make-thread (lambda ()
                                                     (let ((tdbdat (tasks:open-db)))
                                                       (rmt:tasks-set-state-given-param-key task-key "killed"))
                                                     (print "Killed by signal " signum ". Exiting")
                                                     (thread-sleep! 3)
                                                     (exit))))
                                 (th2 (make-thread (lambda ()
                                                     (thread-sleep! 5)
                                                     (debug:print 0 "Done")
                                                     (exit 4)))))
                             (thread-start! th2)
                             (thread-start! th1)
                             (thread-join! th2)))))))
      (set-signal-handler! signal/int sighand)
      (set-signal-handler! signal/term sighand)
      (set-signal-handler! signal/stop sighand))

      ;;(set-signal-handler! signal/stop sighand)
      )
    
    (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process
    (set! runconf (if (file-exists? runconfigf)
		      (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
		      (begin
			(debug:print 0 "WARNING: You do not have a run config file: " runconfigf)
			#f)))





︙


318
319
320
321
322
323
324


325
326
327
328
329
330
331

321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336








+
+









    ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts)))
    (debug:print-info 0 "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " "))
    (debug:print-info 0 "all tests:         " (string-intersperse (sort all-test-names string<) " "))
    (debug:print-info 0 "test names:        " (string-intersperse (sort test-names string<) " "))
    (debug:print-info 0 "required tests:    " (string-intersperse (sort required-tests string<) " "))


    ;; allow-auto-rerun - undocumented, maybe unimplemented.
    ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
    ;; -keepgoing is specified
    (if (eq? *passnum* 0)
	(begin
	  ;; Is this still necessary? I think not. Unreachable tests are marked as such and 
	  ;; should not cause problems here.
	  ;;




︙


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

388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406


407
408

409
410
411
412
413
414
415
416

417
418
419
420
421
422
423
424
425
426
427
428
429

430

431
432
433
434
435

436



437
438
439

440



441
442
443
444















445
446
447
448
449
450



451

452

453
454
455
456
















457




458
459

460
461

462
463
464
465
466
467
468

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
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414

415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440

441
442
443
444
445
446
447
448
449

450
451
452
453
454
455
456

457
458
459
460



461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480

481
482
483
484
485

486
487



488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509

510
511

512
513
514
515
516
517
518
519








+
-
+

+















+
+
-
+












-
+


















-
+
+


+








+












-
+

+





+
-
+
+
+



+
-
+
+
+

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





-
+
+
+

+
-
+

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

+
+
+
+

-
+

-
+








    ;; refactoring this block into tests:get-full-data
    ;;
    ;; What happended, this code is now duplicated in tests!?
    ;;
    ;;======================================================================
    
    (if (not (null? test-names))
	(let loop ((processed '())
	(let loop ((hed (car test-names))
                   (hed (car test-names))
		   (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
          (debug:print-info 0 "BB: +++LOOP (iter="(counter 'rtloop)")  test-patts="test-patts" hed="hed" tal="tal)
	  (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
	  (setenv "MT_TEST_NAME" hed) ;; 
	  (let*-values (((waitons waitors config)(tests:get-waitons hed all-tests-registry)))
	    (debug:print-info 8 "waitons: " waitons)
	    ;; check for hed in waitons => this would be circular, remove it and issue an
	    ;; error
	    (if (or (member hed waitons)
		    (member hed waitors))
		(begin
		  (debug:print 0 "ERROR: test " hed " has listed itself as a waiton or waitor, please correct this!")
		  (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))
		  (set! waitors (filter (lambda (x)(not (equal? x hed))) waitors))))
	    
	    ;; (items   (items:get-items-from-config config)))
	    (if (not (hash-table-ref/default test-records hed #f))
		(begin
                  (debug:print-info 0 "BB: HASH ADD "hed" whose waitors are >"waitors"<")
		(hash-table-set! test-records
                  (hash-table-set! test-records  ;; BB: here we add record to hash table
				 hed (vector hed     ;; 0
					     config  ;; 1
					     waitons ;; 2
					     (config-lookup config "requirements" "priority")     ;; priority 3
					     (let ((items      (hash-table-ref/default config "items" #f)) ;; items 4
						   (itemstable (hash-table-ref/default config "itemstable" #f))) 
					       ;; if either items or items table is a proc return it so test running
					       ;; process can know to call items:get-items-from-config
					       ;; if either is a list and none is a proc go ahead and call get-items
					       ;; otherwise return #f - this is not an iterated test
					       (cond
						((procedure? items)      
						 (debug:print-info 4 "items is a procedure, will calc later")
						 (debug:print-info 4 "items is a procedure, will calc later") ;; BB? calc later? when?? why not now?
						 items)            ;; calc later
						((procedure? itemstable)
						 (debug:print-info 4 "itemstable is a procedure, will calc later")
						 itemstable)       ;; calc later
						((filter (lambda (x)
							   (let ((val (car x)))
							     (if (procedure? val) val #f)))
							 (append (if (list? items) items '())
								 (if (list? itemstable) itemstable '())))
						 'have-procedure)
						((or (list? items)(list? itemstable)) ;; calc now
						 (debug:print-info 4 "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 - used for item-path
					     waitors ;; 
					     )))
					     ))))
            (debug:print-info 0 "BB: iterating over waitons+waitors -> waitons="waitons" waitors="waitors)
	    (for-each 
	     (lambda (waiton)
               (debug:print-info 0 "BB:   - visiting "waiton)
	       (if (and waiton (not (member waiton test-names)))
		   (let* ((waiton-record   (hash-table-ref/default test-records waiton #f))
			  (waiton-tconfig  (if waiton-record (vector-ref waiton-record 1) #f))
			  (waiton-itemized (and waiton-tconfig
						(or (hash-table-ref/default waiton-tconfig "items" #f)
						    (hash-table-ref/default waiton-tconfig "itemstable" #f))))
			  (itemmaps        (tests:get-itemmaps config));; (configf:lookup config "requirements" "itemmap"))
			  (new-test-patts  (tests:extend-test-patts test-patts hed waiton itemmaps)))
                     (debug:print-info 0 "BB: HASH REF "waiton" (waiton)")
		     (debug:print-info 0 "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items")
		     ;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%"
		     ;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt
		     ;; is this satisfied by merely appending "/" to the waiton name added to the list?
		     ;;
		     ;; This approach causes all of the items in an upstream test to be run 

		     ;; if we have this waiton already processed once we can analzye it for extending
		     ;; tests to be run, since we can't properly process waitons unless they have been
		     ;; initially added we add them again to be processed on second round AND add the hed
		     ;; back in to also be processed on second round
		     ;;
		     (if waiton-tconfig
		     (if waiton-tconfig ;; will be false if waiton record has not been added to hash yet
			 (begin

			   (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read
			   (if waiton-itemized
			       (begin
				 (debug:print-info 0 "New test patts: " new-test-patts ", prev test patts: " test-patts)
				 (set! required-tests (cons (conc waiton "/") required-tests))
                                 (debug:print-info 0 "!!! BB !!! waiton *is* itemized accepted new-test-patts->test-patts: "new-test-patts)
				 (set! test-patts new-test-patts))
				 (set! test-patts new-test-patts)
                                 (set! processed (cons hed processed))
                                 )
			       (begin
				 (debug:print-info 0 "Adding non-itemized test " waiton " to required-tests")
				 (set! required-tests (cons waiton required-tests))
                                 (debug:print-info 0 "!!! BB !!! waiton NOT itemized accepted new-test-patts->test-patts: "new-test-patts)
				 (set! test-patts new-test-patts))))
				 (set! test-patts new-test-patts)
                                 (set! processed (cons hed processed))
                                 )))
			 (begin
			   (debug:print-info 0 "No testconfig info yet for " waiton ", setting up to re-process it")
			   (set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests))
			 
			   (debug:print-info 0 "No testconfig info yet for " waiton ", setting up to re-process it even though new-test-patt is >"new-test-patts"<")

                           ;; BB: by pushing upstream test with item
                           ;; filter to end, downstream tests' items
                           ;; are not filtered when encountered.  This
                           ;; causes chained-waiton/item_seq4 to FAIL.
                           ;; when test3/%, test2/%, test1/% all items
                           ;; are added to testpatt when instead
                           ;; test4/item.1 should imply test3/item.1,
                           ;; which shold imply test2/item.1 and so on
                           (debug:print-info 0 "BB: pushing "hed" to back of the line")
                           (debug:print-info 0 "BB: new tal = waiton,tal + hed = "waiton","tal" + "hed)
                           
                           (set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests)) ;; BB- EXAMINE
                     
		     ;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts
		     ;;  - doesn't work
		     ;; (set! test-patts (conc test-patts "," waiton "/"))
		     
		     ;; (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
		     )))
		     ))
               (debug:print-info 0 "BB:   - leaving "waiton)
               )
	     (delete-duplicates (append waitons waitors)))
            (debug:print-info 0 "BB: done iterating over waitons+waitors -> waitons="waitons" waitors="waitors)
	    (let ((remtests (delete-duplicates (append waitons tal))))
	    (let ((remtests (delete-duplicates (append waitons tal)))) ;; BB EXAMINE
	      (if (not (null? remtests))
		  (begin
		    ;; (debug:print-info 0 "Preprocessing continues for " (string-intersperse remtests ", "))
		    (loop (car remtests)(cdr remtests))))))))
		  (begin 
                    
		    (debug:print-info 0 "Preprocessing continues for " (string-intersperse remtests ", "))
                    ;; BB: remtest must be in topological order of waiton edges
                    (let* (
                           (filtered-remtests (filter (lambda (x) (not (member x processed))) remtests))
                           (new-hed (car filtered-remtests))
                           (method (string->symbol (or (get-environment-variable "DEPSORTMETHOD") "new"))) ;; setenv DEPSORTMETHOD old to go back
                           (new-tal
                            (if (eq? method 'old)
                                (cdr filtered-remtests)
                                (runs:toposort (cdr filtered-remtests) all-tests-registry))))
                      ;;(set! remtests (runs:toposort remtests all-tests-registry))
                      ;;(loop (car remtests)(cdr remtests))
                      (loop processed new-hed new-tal)
                    )))))))


    
    (counter-reset 'rtloop)
    (debug:print-info 0 "BB: Finished elaboration of waiton dependencies (maybe?)")
    (if (not (null? required-tests))
	(debug:print-info 1 "Adding \"" (string-intersperse required-tests " ") "\" to the run queue"))
	(debug:print-info 0 "BB Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) ; BB changed 1 to 0
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (debug:print-info 4 "test-records=" (hash-table->alist test-records))
    (debug:print-info 0 "BB test-records=" (hash-table->alist test-records)) ; BB: changed 4 to 0
    (let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
      (if (> (length (hash-table-keys test-records)) 0)
	  (let* ((keep-going        #t)
		 (run-queue-retries 5)
		 (th1        (make-thread (lambda ()
					    (handle-exceptions
					     exn




︙


501
502
503
504
505
506
507




































































































































508
509
510
511
512
513
514

552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697








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








		  ;; recursive call to self
		  (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))))
	  (debug:print-info 0 "No tests to run")))
    (debug:print-info 4 "All done by here")
    (rmt:tasks-set-state-given-param-key task-key "done")
    ;; (sqlite3:finalize! tasks-db)
    ))

;; define custom counters -- very handy to line up iteration of debug message calls within a single execution
(define *counter-alist* (make-parameter '()))
(define (counter key)
  (let* ((counter-param
         (or
          (alist-ref (->string key) (*counter-alist*) equal?)
          (let ((new-counter (make-parameter 0)))
            (*counter-alist* (cons (cons (->string key) new-counter) (*counter-alist*)))
            new-counter)))
         (current-count (counter-param))
         (new-count (add1 current-count)))
    (counter-param new-count)))

(define (counter-reset key)
  (let ((existing-counter (alist-ref (->string key) (*counter-alist*) equal?)))
    (if existing-counter
        (existing-counter 0)
        (counter key))))
        
          
;; BAD HACK follows.
;; on initial pass thru, adjacency-list is correct.  later, somehow waitons get corrupted (eg. EVERYTHING depends on test3.. whY?
;; the hack - cache initial adjacency-list  (hopefully alltests cannot change midstream or the static analysis is otherwise invalidated!!)
;; good god, *cached-adjacency-list* changes over time.  Should be constant! wtf?, disabling cache.


(define *cached-adjacency-list* (make-parameter #f))

;; (define (runs:get-itemmaps all-tests-registry)
;;   (let* ((full-adjacency-list
;;          (map
;;           (lambda (test)
;;             (let*-values (((waitons waitors config) (tests:get-waitons test all-tests-registry)))
;;               (debug:print-info 0 "    BB: test="test" waitons="waitons" waitors="waitors)
;;               (cons test (append waitons waitors))))))))

;; ;(hash-table-ref all-tests-registry test-name))
  
;;   )
  

(define (runs:get-test-adjacency-list all-tests-registry testlist-filter )
  ;; on first pass, initialize cache with adjacency-list for all tests 
  (when (or #t (not (*cached-adjacency-list*))) ;; or #t forces eval every time
      (let* ((alltestlist (hash-table-keys (tests:get-all)))
             (full-adjacency-list
                (map
                 (lambda (test)
                   (let*-values (((waitons waitors config) (tests:get-waitons test all-tests-registry)))
                     (debug:print-info 0 "    BB: test="test" waitons="waitons" waitors="waitors)
                     (cons test (append waitons waitors))))
                 ;;testlist-filter))
                 alltestlist))
             (sorted-alltestlist (sort alltestlist (lambda (a b) (string< (->string a) (->string b))))))
        (debug:print-info 0 "--=> BB: ALLTESTLIST iter="(counter 'alltestlist)"  val="sorted-alltestlist)

        (debug:print-info 0 "--=> BB: initialized *cached-adjacency-list* with "
                          full-adjacency-list)
        (*cached-adjacency-list* full-adjacency-list)))

  ;; return adjacency-list only containing tests in testlist-filter
  (let* ((full-adjacency-list (*cached-adjacency-list*))
         ;; trim list - 1) remove any toplevel list whose car is not a member of testlist-filter
         ;;             2) remove all items from cdr which is not a member of testlist-filter
         ;;             3) shouldn't happen, but remove any from cdr which matches car
         (trimmed-list-1 (filter
                          (lambda (row)
                            (member (car row) testlist-filter))
                          full-adjacency-list))
         (trimmed-list-2 (map
                          (lambda (row)
                            (filter
                             (lambda (field)
                               (member field testlist-filter))
                             row))
                          trimmed-list-1))
         (trimmed-list-3 (map
                          (lambda (row)
                            (let ((hed (car row)) (tal (cdr row)))
                              (cons hed
                                    (filter
                                     (lambda (field)
                                       (not (equal? field hed)))
                                     tal))))
                          trimmed-list-2))
         (adjacency-list trimmed-list-3))
    (debug:print-info 0 "      BB full-adjacency-list="full-adjacency-list)
    (debug:print-info 0 "      BB trimmed-list-1"trimmed-list-1)
    (debug:print-info 0 "      BB trimmed-list-2"trimmed-list-2)
    (debug:print-info 0 "      BB trimmed-list-3"trimmed-list-3)
    (debug:print-info 0 "     BB entered with testlist-filter="testlist-filter)
    adjacency-list))
        

(define (toposort-check testlist sortedlist)
  (let* ((normalize-list (lambda (the-list) (sort the-list (lambda (a b) (string< (->string a) (->string b))))))
         (normal-testlist (normalize-list testlist))
         (normal-sortedlist (normalize-list sortedlist))
         (OK  (cond
               ((not (= (length normal-testlist) (length normal-sortedlist)))
                (debug:print-info 0 "BB: TOPOSORT-CHECK FAILED.  length["testlist"] != length["sortedlist"]")
                #f)
               ((not (equal? normal-testlist normal-sortedlist))
                (debug:print-info 0 "BB: TOPOSORT-CHECK FAILED.  members["testlist"] != members["sortedlist"]")
                #f)
               (else
               (debug:print-info 0 "BB: TOPOSORT-CHECK :) PASS :)")))))

    
    OK))
    
          
(define (runs:toposort testlist all-tests-registry)
  ;(print "ALL-TESTS-REGISTRY")
  
  ;(pretty-print (hash-table->alist all-tests-registry))
  ;(exit 1)
    

  (let* ((adjacency-list (runs:get-test-adjacency-list all-tests-registry testlist)))
    (debug:print-info 0 "BB> adjacency-list("testlist") = "adjacency-list)
    (let ((sorted-list
           (topological-sort adjacency-list equal?)))
      (debug:print-info 0 "BB> sorted-list("testlist") = "sorted-list)
      (let* ((filtered-sorted-list
             (filter (lambda (item) (member item testlist)) sorted-list))
             (res filtered-sorted-list))
        (debug:print-info 0 "BB> TOPOSORT-*"(counter res)"*-       "testlist" ==**==> " filtered-sorted-list)
        (toposort-check testlist res)
        res
        ))))


;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable.
;;
;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns
;; If reg is full (i.e. length >= n
;;   loop with (car reg) tal (cdr reg) reruns




︙







Modified tests.scm
from [41a7ac7d26]
to [52b9831c5a].




︙


119
120
121
122
123
124
125
126

127
128
129
130
131

132
133
134
135


136
137
138
139
140
141
142
143
144
145


146
147
148
149
150
151
152
153
154
155
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
198
199

119
120
121
122
123
124
125

126
127
128
129
130

131
132
133
134

135
136
137
138
139
140
141
142
143
144
145

146
147
148
149
150
151
152
153
154
155
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
198
199
200
201
202
203
204
205
206
207
208
209
210
211








-
+




-
+



-
+
+









-
+
+














-
+
















+
+












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








		      (config-lookup config "requirements" "waiton")
		      (begin ;; No config means this is a non-existant test
			(debug:print 0 "ERROR: non-existent required test \"" test-name "\"")
			(exit 1))))
	   (instr2 (if config
		       (config-lookup config "requirements" "waitor")
		       "")))
       (debug:print-info 8 "waitons string is " instr ", waitors string is " instr2)
       (debug:print-info 0 "BB: RAW waiton("test-name") is >" instr "<, waitors string is >" instr2"<") ; BB 8 to 0
       (let ((newwaitons
	      (string-split (cond
			     ((procedure? instr)
			      (let ((res (instr)))
				(debug:print-info 8 "waiton procedure results in string " res " for test " test-name)
				(debug:print-info 0 "waiton procedure results in string " res " for test " test-name) ; BB changed from 8 to 0
				res))
			     ((string? instr)     instr)
			     (else 
			      ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " test-name)
			      ;; NOTE: This is actually the case of *no* waitons!
                              (debug:print 0 "BB: ERROR: something went wrong in processing waitons for test " test-name) ;; BB: uncommented.
			      ""))))
	     (newwaitors
	      (string-split (cond
			     ((procedure? instr2)
			      (let ((res (instr2)))
				(debug:print-info 8 "waitor procedure results in string " res " for test " test-name)
				res))
			     ((string? instr2)     instr2)
			     (else 
			      ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " test-name)
			      ;; NOTE: This is actually the case of *no* waitors! ;; BB: WRONG.  This seems to be the case of ALL waitors.
                              ;;(debug:print 0 "BB: ERROR: something went wrong in processing waitors for test " test-name) ; BB: uncommented/recommented
			      "")))))
	 (values
	  ;; the waitons
	  (filter (lambda (x)
		    (if (hash-table-ref/default all-tests-registry x #f)
			#t
			(begin
			  (debug:print 0 "ERROR: test " test-name " has unrecognised waiton testname " x)
			  #f)))
		  newwaitons)
	  (filter (lambda (x)
		    (if (hash-table-ref/default all-tests-registry x #f)
			#t
			(begin
			  (debug:print 0 "ERROR: test " test-name " has unrecognised waiton testname " x)
			  (debug:print 0 "ERROR: test " test-name " has unrecognised waitor testname " x)
			  #f)))
		  newwaitors)
	  config)))))
					     
;; given waiting-test that is waiting on waiton-test extend test-patt appropriately
;;
;;  genlib/testconfig               sim/testconfig
;;  genlib/sch                      sim/sch/cell1
;;
;;  [requirements]                  [requirements]
;;                                  mode itemwait
;;                                  # trim off the cell to determine what to run for genlib
;;                                  itemmap /.*
;;
;;                                  waiting-test is waiting on waiton-test so we need to create a pattern for waiton-test given waiting-test and itemmap
(define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps)

  (debug:print-info 0 "BB: iter="(counter test-patt)" test:extend-test-patts entered with test-patt="test-patt" waiting-test="waiting-test" waiton-test="waiton-test" itemmaps="itemmaps)
  (let* ((itemmap          (tests:lookup-itemmap itemmaps waiton-test))
	 (patts            (string-split test-patt ","))
	 (waiting-test-len (+ (string-length waiting-test) 1))
	 (patts-waiton     (map (lambda (x)  ;; for each incoming patt that matches the waiting test
				  (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x)) 
					 (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt)))))
				    ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt)))))
				    ;; (print "in map, x=" x ", newpatt=" newpatt)
				    newpatt))
				(filter (lambda (x)
					  (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test
					patts))))

    (let ((res
    (string-intersperse (delete-duplicates (append patts (if (null? patts-waiton)
							     (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
							     patts-waiton)))
			",")))
           (string-intersperse
            (delete-duplicates
             (append
              patts
              (if (null? patts-waiton)
                  (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this
                  patts-waiton)))
            ",")))
      (debug:print-info 0 "BB: test:extend-test-patts returns "res)
      res)))
  
;; tests:glob-like-match 
(define (tests:glob-like-match patt str) 
  (let ((like (substring-index "%" patt)))
    (let* ((notpatt  (equal? (substring-index "~" patt) 0))
	   (newpatt  (if notpatt (substring patt 1) patt))
	   (finpatt  (if like




︙










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