Overview
Comment: | Added glob caching for apparently expensive regexp execution |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.65 |
Files: | files | file ages | folders |
SHA1: |
b4a13d110654edeecfdaff308132d723 |
User & Date: | matt on 2020-08-16 22:07:22 |
Other Links: | branch diff | manifest | tags |
Context
2020-08-17
| ||
06:20 | Short circuit calculation of number tests running. check-in: 6f1893ddd7 user: matt tags: v1.65 | |
2020-08-16
| ||
22:07 | Added glob caching for apparently expensive regexp execution check-in: b4a13d1106 user: matt tags: v1.65 | |
2020-08-15
| ||
23:19 | Converted anther call from imperative to functional and added more statement caching check-in: 9277e72e14 user: matt tags: v1.65 | |
Changes
Modified runs.scm from [c2ee7717e6] to [9bdec6c892].
︙ | ︙ | |||
59 60 61 62 63 64 65 | (defstruct runs:testdat hed tal reg reruns test-record test-name item-path jobgroup waitons testmode newtal itemmaps prereqs-not-met) ;; Fourth try, do accounting through time ;; | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (defstruct runs:testdat hed tal reg reruns test-record test-name item-path jobgroup waitons testmode newtal itemmaps prereqs-not-met) ;; Fourth try, do accounting through time ;; (define (runs:parallel-runners-mgmt-4 rdat) (let ((time-to-check 10) ;; 28 (time-to-wait 12) (now-time (current-seconds))) (if (> (- now-time (runs:dat-last-fuel-check rdat)) time-to-check) ;; time to check (let* ((fuel-used (or (rmt:get-var "runners-fuel") now-time))) ;; initialize and sanitize values if needed (if (> fuel-used (+ now-time 1)) ;; are we over-drawn? If so, kill time, do not add time to fuel used (begin ;; gonna rest (debug:print-info 0 *default-log-port* "Runner load high, taking a break.") (thread-sleep! time-to-wait) (runs:dat-last-fuel-check-set! rdat (current-seconds)) ;; work done from here (i.e. seconds of "fuel") will be added to fuel-used ) (begin ;; no fuel deficit, back to work (rmt:set-var "runners-fuel" (+ now-time time-to-check)) )))))) ;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files ;; - remove any that are over 3600 seconds old ;; - if there are any that are younger than 10 seconds ;; * sleep 10 seconds ;; * touch my key-host-pid.softlock file ;; * return ;; - if there are no files younger than 10 seconds ;; * touch my key-host-pid.softlock file ;; * return ;; (define (runs:wait-on-softlock rdat key) (if (not (and *toppath* (file-exists? *toppath*))) ;; don't seem to have toppath yet (debug:print-info 0 *default-log-port* "Can't create softlocks - don't see MTRAH yet.") (let* ((softlocks-dir (conc *toppath* "/.softlocks"))) (if (not (file-exists? softlocks-dir)) (create-directory softlocks-dir #t)) (let* ((my-lock-file (conc softlocks-dir "/" key "-" (get-host-name) "-" (current-process-id) ".softlock")) (lock-files (filter (lambda (x) (not (equal? x my-lock-file))) (glob (conc softlocks-dir "/" key "*.softlock")))) (fresh-locks (any (lambda (x) ;; do we have any locks younger than 10 seconds (let ((mod-time (file-modification-time x))) (cond ((> (- (current-seconds) mod-time) 3600) ;; too old to keep, remove it (delete-file* x) #f) ((< mod-time 10) #t) (else #f)))) lock-files))) (if fresh-locks (begin (if (runs:lownoise "runners-softlock-wait" 360) (debug:print-info 0 *default-log-port* "Other runners in flight, giving up some time...")) (thread-sleep! 10)) (begin (if (runs:lownoise "runners-softlock-nowait" 360) (debug:print-info 0 *default-log-port* "No runners in flight, updating softlock")) (with-output-to-file my-lock-file (lambda () (print (current-seconds)))))) (runs:dat-last-fuel-check-set! rdat (current-seconds)))))) ;; Fourth try, do accounting through time ;; (define (runs:parallel-runners-mgmt rdat) (let ((time-to-check 10) ;; 28 (time-to-wait 12) (now-time (current-seconds))) (if (> (- now-time (runs:dat-last-fuel-check rdat)) time-to-check) ;; time to check (runs:wait-on-softlock rdat "runners")))) ;; To test parallel-runners management start a repl: ;; megatest -repl ;; then run: ;; (runs:test-parallel-runners 60) ;; (define (runs:test-parallel-runners duration #!optional (proc #f)) |
︙ | ︙ |
Modified tests.scm from [52d412173f] to [5b233fb0bb].
︙ | ︙ | |||
269 270 271 272 273 274 275 | (else ;; not waiting on items, waiting on entire waiton test. (let* ((patts (string-split test-patt ",")) (new-patts (if (member waiton-test patts) patts (cons waiton-test patts)))) (string-intersperse (delete-duplicates new-patts) ","))))) | | > > > > > > | | | | | | | > | < < | | 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 295 296 297 298 299 300 301 | (else ;; not waiting on items, waiting on entire waiton test. (let* ((patts (string-split test-patt ",")) (new-patts (if (member waiton-test patts) patts (cons waiton-test patts)))) (string-intersperse (delete-duplicates new-patts) ","))))) (define *glob-like-match-cache* (make-hash-table)) (define (tests:cache-regexp str-in flag) (let* ((key (conc str-in flag))) (or (hash-table-ref/default *glob-like-match-cache* key #f) (let* ((newrx (regexp str-in flag))) (hash-table-set! *glob-like-match-cache* key newrx) newrx)))) ;; tests:glob-like-match (define (tests:glob-like-match patt str) (let* ((like (substring-index "%" patt)) (notpatt (equal? (substring-index "~" patt) 0)) (newpatt (if notpatt (substring patt 1) patt)) (finpatt (if like (string-substitute (regexp "%") ".*" newpatt #f) (string-substitute (regexp "\\*") ".*" newpatt #f))) (rx (tests:cache-regexp finpatt (if like #t #f))) (res (string-match rx str))) (if notpatt (not res) res))) ;; if itempath is #f then look only at the testname part ;; (define (tests:match patterns testname itempath #!key (required '())) (if (string? patterns) (let ((patts (append (string-split patterns ",") required))) (if (null? patts) ;;; no pattern(s) means no match |
︙ | ︙ |