Overview
| Comment: | Initial attempt at runner throttle. NOT WORKING QUITE RIGHT |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.65 |
| Files: | files | file ages | folders |
| SHA1: |
5c5398b2f239681d68f86cf57594972e |
| User & Date: | mrwellan on 2020-08-11 00:37:46 |
| Other Links: | branch diff | manifest | tags |
Context
|
2020-08-11
| ||
| 23:26 | several tries later ... check-in: 7308f2111f user: mrwellan tags: v1.65 | |
| 00:37 | Initial attempt at runner throttle. NOT WORKING QUITE RIGHT check-in: 5c5398b2f2 user: mrwellan tags: v1.65 | |
|
2020-08-10
| ||
| 10:52 | Added MT_STEP_NAME check-in: 0e49a44c95 user: mrwellan tags: v1.65 | |
Changes
Modified api.scm from [a15c0cd809] to [70cdbd0f27].
| ︙ | ︙ | |||
210 211 212 213 214 215 216 217 218 219 220 221 222 223 |
((register-run) (apply db:register-run dbstruct params))
((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
((delete-run) (apply db:delete-run dbstruct params))
((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
((update-run-event_time) (apply db:update-run-event_time dbstruct params))
((update-run-stats) (apply db:update-run-stats dbstruct params))
((set-var) (apply db:set-var dbstruct params))
((del-var) (apply db:del-var dbstruct params))
;; STEPS
((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params))
;; TEST DATA
| > > | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 |
((register-run) (apply db:register-run dbstruct params))
((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
((delete-run) (apply db:delete-run dbstruct params))
((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
((update-run-event_time) (apply db:update-run-event_time dbstruct params))
((update-run-stats) (apply db:update-run-stats dbstruct params))
((set-var) (apply db:set-var dbstruct params))
((inc-var) (apply db:inc-var dbstruct params))
((dec-var) (apply db:dec-var dbstruct params))
((del-var) (apply db:del-var dbstruct params))
;; STEPS
((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
((delete-steps-for-test!) (apply db:delete-steps-for-test! dbstruct params))
;; TEST DATA
|
| ︙ | ︙ |
Modified db.scm from [b66b42236f] to [b0064c2033].
| ︙ | ︙ | |||
1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 |
"SELECT val FROM metadat WHERE var=?;" var)
;; convert to number if can
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
res))))
;; This was part of db:get-var. It was used to estimate the load on
;; the database files.
;;
;; scale by 10, average with current value.
;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
;; (if throttle throttle 0.01)))
;; 2))
| > > > > > > > > > > | 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 |
"SELECT val FROM metadat WHERE var=?;" var)
;; convert to number if can
(if (string? res)
(let ((valnum (string->number res)))
(if valnum (set! res valnum))))
res))))
(define (db:inc-var dbstruct var)
(db:with-db dbstruct #f #t
(lambda (db)
(sqlite3:execute db "UPDATE metadat SET val=val+1 WHERE var=?;" var))))
(define (db:dec-var dbstruct var)
(db:with-db dbstruct #f #t
(lambda (db)
(sqlite3:execute db "UPDATE metadat SET val=val-1 WHERE var=?;" var))))
;; This was part of db:get-var. It was used to estimate the load on
;; the database files.
;;
;; scale by 10, average with current value.
;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms)
;; (if throttle throttle 0.01)))
;; 2))
|
| ︙ | ︙ |
Modified ezsteps.scm from [9d1b48037c] to [59d2b04420].
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") ;;(rmt:get-test-info-by-id run-id test-id) -> testdat | < < | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
;;(rmt:get-test-info-by-id run-id test-id) -> testdat
(define (ezsteps:run-from testdat start-step-name run-one)
;;# TODO - recapture item variables, debug repeated step eval; regen logpro from test
(let* ((do-update-test-state-status #f)
(test-run-dir ;; (filedb:get-path *fdb*
(db:test-get-rundir testdat)) ;; )
(testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
(ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
|
| ︙ | ︙ | |||
92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
(proceed-with-this-step
(or (not start-step-name)
(equal? stepname start-step-name)
(and saw-start-step-name (not run-one))
saw-start-step-name-next
(and start-step-name (equal? stepname start-step-name))))
)
(set! do-update-test-state-status (and proceed-with-this-step (null? tal)))
;;(BB> "stepname="stepname" proceed-with-this-step="proceed-with-this-step " do-update-test-state-status="do-update-test-state-status " orig-test-state="orig-test-state" orig-test-status="orig-test-status)
(cond
((and (not proceed-with-this-step) (null? tal))
'done)
((not proceed-with-this-step)
(loop (car tal)
| > | 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 |
(proceed-with-this-step
(or (not start-step-name)
(equal? stepname start-step-name)
(and saw-start-step-name (not run-one))
saw-start-step-name-next
(and start-step-name (equal? stepname start-step-name))))
)
(setenv "MT_STEP_NAME" stepname)
(set! do-update-test-state-status (and proceed-with-this-step (null? tal)))
;;(BB> "stepname="stepname" proceed-with-this-step="proceed-with-this-step " do-update-test-state-status="do-update-test-state-status " orig-test-state="orig-test-state" orig-test-status="orig-test-status)
(cond
((and (not proceed-with-this-step) (null? tal))
'done)
((not proceed-with-this-step)
(loop (car tal)
|
| ︙ | ︙ |
Modified rmt.scm from [e52432dc0d] to [c90382995e].
| ︙ | ︙ | |||
786 787 788 789 790 791 792 | (define (rmt:set-run-status run-id run-status #!key (msg #f)) (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) (define (rmt:set-run-state-status run-id state status ) (rmt:send-receive 'set-run-state-status #f (list run-id state status))) | < | 786 787 788 789 790 791 792 793 794 795 796 797 798 799 | (define (rmt:set-run-status run-id run-status #!key (msg #f)) (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) (define (rmt:set-run-state-status run-id state status ) (rmt:send-receive 'set-run-state-status #f (list run-id state status))) (define (rmt:update-run-event_time run-id) (rmt:send-receive 'update-run-event_time #f (list run-id))) (define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order))) (define (rmt:find-and-mark-incomplete run-id ovr-deadtime) |
| ︙ | ︙ | |||
809 810 811 812 813 814 815 816 817 818 819 820 821 822 | (define (rmt:del-var varname) (rmt:send-receive 'del-var #f (list varname))) (define (rmt:set-var varname value) (rmt:send-receive 'set-var #f (list varname value))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== ;; Need to move this to multi-run section and make associated changes (define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) (let ((run-ids (rmt:get-all-run-ids))) | > > > > > > | 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 | (define (rmt:del-var varname) (rmt:send-receive 'del-var #f (list varname))) (define (rmt:set-var varname value) (rmt:send-receive 'set-var #f (list varname value))) (define (rmt:inc-var varname) (rmt:send-receive 'inc-var #f (list varname))) (define (rmt:dec-var varname) (rmt:send-receive 'dec-var #f (list varname))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== ;; Need to move this to multi-run section and make associated changes (define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) (let ((run-ids (rmt:get-all-run-ids))) |
| ︙ | ︙ |
Modified runs.scm from [8eb0eeffbc] to [d0362390bc].
| ︙ | ︙ | |||
44 45 46 47 48 49 50 | (defstruct runs:dat reglen regfull runname max-concurrent-jobs run-id test-patts required-tests test-registry registry-mutex flags keyvals run-info all-tests-registry can-run-more-tests | | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
(defstruct runs:dat
reglen regfull
runname max-concurrent-jobs run-id
test-patts required-tests test-registry
registry-mutex flags keyvals run-info all-tests-registry
can-run-more-tests
((can-run-more-tests-count 0) : fixnum)
(last-runners-check 0) ;; time when we last checked number of runners
(last-runners-count #f) ;;
(runner-registered #f) ;; have I registered myself?
(run-skip-count 0) ;; how many times have I skipped running sequentially
)
(defstruct runs:testdat
hed tal reg reruns test-record
test-name item-path jobgroup
waitons testmode newtal itemmaps prereqs-not-met)
(define (runs:print-parallel-runners-state state num-registered last-registered skip-count)
(debug:print-info 0 *default-log-port* "runs:parallel-runners-mgmt, state=" state
", num-registered=" num-registered ", last-registered=" last-registered
", skip-count=" skip-count))
(define (runs:print-parallel-runners-state2 state num-registered last-runners-count skip-count)
(debug:print-info 0 *default-log-port* "runs:parallel-runners-mgmt, state=" state
", num-registered=" num-registered ", last-runners-count=" last-runners-count
", skip-count=" skip-count))
(define (runs:parallel-runners-mgmt rdat)
(let ((time-to-check 2.8) ;; 28
(time-to-wait 3.0))
(if (> (- (current-seconds) (runs:dat-last-runners-check rdat)) time-to-check) ;; time to check
(let* ((num-registered (or (rmt:get-var "num-runners") 0))
(last-runners-count (runs:dat-last-runners-count rdat))
(skip-count (runs:dat-run-skip-count rdat)))
(cond
;; first time in
((not last-runners-count)
(runs:print-parallel-runners-state2 "A" num-registered last-runners-count skip-count)
(rmt:set-var "num-runners" 1)
(runs:dat-last-runners-count-set! rdat num-registered)
(runs:dat-run-skip-count-set! rdat 0))
;; too many waits, decrement num-runners and continue on
((> (runs:dat-run-skip-count rdat) 3)
(runs:print-parallel-runners-state2 "B" num-registered last-runners-count skip-count)
(rmt:dec-var "num-runners")
(runs:dat-run-skip-count-set! rdat 0))
;; too many running, take a break
((> num-registered last-runners-count)
(runs:print-parallel-runners-state2 "C" num-registered last-runners-count skip-count)
(rmt:dec-var "num-runners")
(debug:print-info 0 *default-log-port*
"Too many running (" num-registered
"), last-count=" last-runners-count " waiting... ")
(thread-sleep! time-to-wait)
(runs:dat-run-skip-count-set! rdat (+ (runs:dat-run-skip-count rdat) 1)))
;; we have been in waiting mode, do not increment again as we already did that
((> skip-count 0)
(runs:print-parallel-runners-state2 "D" num-registered last-runners-count skip-count)
(runs:dat-run-skip-count-set! rdat 0)
;; (runs:dat-last-runners-count-set! rdat num-registered)
)
;; skip count is zero, not too many running, this is transition into running
(else
(runs:print-parallel-runners-state2 "E" num-registered last-runners-count skip-count)
(rmt:inc-var "num-runners")
#;(runs:dat-run-skip-count-set! rdat 0)))))))
;; (define (runs:parallel-runners-mgmt rdat)
;; (let ((time-to-check 2.8) ;; 28
;; (time-to-wait 3.0))
;; (if (> (- (current-seconds) (runs:dat-last-runners-check rdat)) time-to-check) ;; time to check
;; (let* ((num-registered (or (rmt:get-var "num-runners") 0))
;; (last-registered (or (rmt:get-var "runner-change-time") 0))
;; (skip-count (runs:dat-run-skip-count rdat)))
;; (cond
;; ;; consider this the beginning of time
;; ((eq? num-registered 0)
;; (runs:print-parallel-runners-state "A" num-registered last-registered skip-count)
;; (rmt:set-var "num-runners" 1) ;; potential bug - not ACID
;; (rmt:set-var "runner-change-time" (current-seconds))
;; (runs:dat-last-runners-check-set! rdat (current-seconds))
;; (runs:dat-runner-registered-set! rdat #t)
;; (runs:dat-run-skip-count-set! rdat 0))
;; ;; have headroom to run another
;; ((< num-registered 3)
;; (runs:print-parallel-runners-state "B" num-registered last-registered skip-count)
;; (rmt:inc-var "num-runners")
;; (rmt:set-var "runner-change-time" (current-seconds))
;; (runs:dat-last-runners-check-set! rdat (current-seconds))
;; (runs:dat-run-skip-count-set! rdat 0))
;; ;; we've waited too many rounds, gonna force a round
;; ((> (runs:dat-run-skip-count rdat) 3)
;; (runs:print-parallel-runners-state "C" num-registered last-registered skip-count)
;; (rmt:set-var "num-runners" 1)
;; ;; (rmt:set-var "runner-change-time" (current-seconds))
;; (runs:dat-last-runners-check-set! rdat (current-seconds))
;; (runs:dat-run-skip-count-set! rdat 0))
;; ;; have too many runners working, but this is the first time to wait since doing some work
;; ((eq? (runs:dat-run-skip-count rdat) 0) ;; and num-registered is >= 3
;; (runs:print-parallel-runners-state "D" num-registered last-registered skip-count)
;; (if (not (eq? (runs:dat-last-runners-check rdat) 0)) ;; do not decrement if we've never incremented
;; (begin
;; (rmt:dec-var "num-runners")
;; #;(rmt:set-var "runner-change-time" (current-seconds))))
;; (runs:dat-last-runners-check-set! rdat (current-seconds))
;; (runs:dat-run-skip-count-set! rdat (+ (runs:dat-run-skip-count rdat) 1))
;; (debug:print-info 0 *default-log-port* "Too many runners working (" num-registered
;; "). Resting for 30 seconds.")
;; (thread-sleep! time-to-wait)
;; (runs:parallel-runners-mgmt rdat))
;; ;; ok, keep waiting
;; (else
;; (runs:print-parallel-runners-state "E" num-registered last-registered skip-count)
;; (thread-sleep! time-to-wait)
;; (runs:dat-run-skip-count-set! rdat (+ (runs:dat-run-skip-count rdat) 1))
;; (runs:parallel-runners-mgmt rdat)))))))
(define (runs:get-mt-env-alist run-id runname target testname itempath)
;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
`(("MT_TEST_NAME" . ,testname)
("MT_ITEMPATH" . ,itempath)
|
| ︙ | ︙ | |||
1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 |
"\n waitons: " waitons
"\n num-retries: " num-retries
"\n reruns: " reruns
"\n regfull: " regfull
"\n reglen: " reglen
"\n length reg: " (length reg)
)
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (member test-name waitons)
(begin
(debug:print-error 0 *default-log-port* "test " test-name " has listed itself as a waiton, please correct this!")
(set! waiton (filter (lambda (x)(not (equal? x hed))) waitons))))
| > > | 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 |
"\n waitons: " waitons
"\n num-retries: " num-retries
"\n reruns: " reruns
"\n regfull: " regfull
"\n reglen: " reglen
"\n length reg: " (length reg)
)
(runs:parallel-runners-mgmt runsdat)
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
(if (member test-name waitons)
(begin
(debug:print-error 0 *default-log-port* "test " test-name " has listed itself as a waiton, please correct this!")
(set! waiton (filter (lambda (x)(not (equal? x hed))) waitons))))
|
| ︙ | ︙ |