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
|
;; delay a short while and continue
((eq? (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f) 'start)
(thread-sleep! 0.01)
(loop (car newtal)(cdr newtal) reruns))
((not (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f))
(debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" )
;; NEED TO THREADIFY THIS
;; (let ((th (make-thread (lambda ()
;; (print "Got here! AA")
;; (mutex-lock! registery-mutex)
;; (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) 'start)
;; (mutex-unlock! registery-mutex)
(cdb:tests-register-test #f run-id test-name item-path)
;; (print "Got here! AB")
;; (mutex-lock! registery-mutex)
(hash-table-set! test-registery (runs:make-full-test-name test-name item-path) 'done)
;; (mutex-unlock! registery-mutex))
;; (conc test-name "/" item-path))))
;; (thread-start! th))
;; (thread-sleep! *global-delta*)
(runs:shrink-can-run-more-tests-delay)
(loop (car newtal)(cdr newtal) reruns))
((not have-resources) ;; simply try again after waiting a second
(debug:print-info 1 "no resources to run new tests, waiting ...")
;; (thread-sleep! (+ 2 *global-delta*))
;; could have done hed tal here but doing car/cdr of newtal to rotate tests
(loop (car newtal)(cdr newtal) reruns))
|
|
<
|
|
|
|
<
|
|
|
|
|
|
|
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
|
;; delay a short while and continue
((eq? (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f) 'start)
(thread-sleep! 0.01)
(loop (car newtal)(cdr newtal) reruns))
((not (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f))
(debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" )
;; NEED TO THREADIFY THIS
(let ((th (make-thread (lambda ()
(mutex-lock! registery-mutex)
(hash-table-set! test-registery (runs:make-full-test-name test-name item-path) 'start)
(mutex-unlock! registery-mutex)
(cdb:tests-register-test *runremote* run-id test-name item-path)
(mutex-lock! registery-mutex)
(hash-table-set! test-registery (runs:make-full-test-name test-name item-path) 'done)
(mutex-unlock! registery-mutex))
(conc test-name "/" item-path))))
(thread-start! th))
(thread-sleep! *global-delta*)
(runs:shrink-can-run-more-tests-delay)
(loop (car newtal)(cdr newtal) reruns))
((not have-resources) ;; simply try again after waiting a second
(debug:print-info 1 "no resources to run new tests, waiting ...")
;; (thread-sleep! (+ 2 *global-delta*))
;; could have done hed tal here but doing car/cdr of newtal to rotate tests
(loop (car newtal)(cdr newtal) reruns))
|
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
|
;;
;; NB// for the above line. I want the test to be registered long before this routine gets called!
;;
(set! test-id (open-run-close db:get-test-id db run-id test-name item-path))
(if (not test-id)
(begin
(debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
(cdb:tests-register-test #f run-id test-name item-path)
(set! test-id (open-run-close db:get-test-id db run-id test-name item-path))))
(debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
(set! testdat (cdb:get-test-info-by-id *runremote* test-id))))
(set! test-id (db:test-get-id testdat))
(change-directory test-path)
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
|
|
|
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
|
;;
;; NB// for the above line. I want the test to be registered long before this routine gets called!
;;
(set! test-id (open-run-close db:get-test-id db run-id test-name item-path))
(if (not test-id)
(begin
(debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
(cdb:tests-register-test *runremote* run-id test-name item-path)
(set! test-id (open-run-close db:get-test-id db run-id test-name item-path))))
(debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
(set! testdat (cdb:get-test-info-by-id *runremote* test-id))))
(set! test-id (db:test-get-id testdat))
(change-directory test-path)
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
|