Changes In Branch debug_chained_waiton Through [9ff8cae0bf] Excluding Merge-Ins
This is equivalent to a diff from f01b76ecf0 to 9ff8cae0bf
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
| ||
18:47 | ceaned up dfs.scm a bit Closed-Leaf check-in: a482e0ffbd user: bjbarcla tags: debug_chained_waiton, v1.60_defunct | |
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 [5411b91e62].
︙ | ︙ | |||
235 236 237 238 239 240 241 | ;; 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))) | | | > | > | | | | | | | | | | | | | | | | | > | 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 (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.") (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) ) (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 | ;; (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<) " ")) ;; 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. ;; | > > | 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 | ;; refactoring this block into tests:get-full-data ;; ;; What happended, this code is now duplicated in tests!? ;; ;;====================================================================== (if (not (null? test-names)) | > | > > > | | | > > > | > > | > > > | > > | > > > > > > > > > > > > | | | > > > | | > | > > > > > > > > > > | > > > > > > | | | 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 '()) (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 ;; 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") ;; 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 ;; 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! 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! processed (cons hed processed)) ))) (begin (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)))) ;; BB EXAMINE (if (not (null? 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) ))))))) ;; above: populate test-records hash ;; below - manage call to run-tests-queue (counter-reset 'rtloop) (debug:print-info 0 "BB: Finished elaboration of waiton dependencies (maybe?)") (if (not (null? required-tests)) (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 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 | ;; 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) )) ;; 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 | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (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") ""))) | | | | > | > | > > > > | > > > > | | | > > | 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 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 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 "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* 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 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))) ","))) (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 |
︙ | ︙ |