Index: docs/api.html ================================================================== --- docs/api.html +++ docs/api.html @@ -1010,10 +1010,10 @@
Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -9,11 +9,11 @@ ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) - posix-extras directory-utils pathname-expand defstruct format) + posix-extras directory-utils pathname-expand typed-records format) (import (prefix sqlite3 sqlite3:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) @@ -31,16 +31,17 @@ (include "run_records.scm") (include "test_records.scm") ;; (include "debugger.scm") -(define (runs:test-get-full-path test) - (let* ((testname (db:test-get-testname test)) - (itempath (db:test-get-item-path test))) - (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) +;; use this struct to facilitate refactoring +;; +(defstruct runs:dat hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps) +;; set up needed environment variables given a run-id and optionally a target, itempath etc. +;; (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) (let* ((target (or intarget (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) @@ -114,10 +115,16 @@ (define (runs:can-keep-running? testname n) (< (hash-table-ref/default *seen-cant-run-tests* testname 0) n)) (define *runs:denoise* (make-hash-table)) ;; key => last-time-ran +;; mechanism to limit printing info to the screen that is repetitive. +;; +;; Example: +;; (if (runs:lownoise "waiting on tasks" 60) +;; (debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ...")) +;; (define (runs:lownoise key waitval) (let ((lasttime (hash-table-ref/default *runs:denoise* key 0)) (currtime (current-seconds))) (if (> (- currtime lasttime) waitval) (begin @@ -434,19 +441,10 @@ (car reg) (if (null? tal) ;; tal is used up, pop from reg (car reg) (car tal)))) -;; (cond -;; ((and regfull (null? reg)(not (null? tal))) (car tal)) -;; ((and regfull (not (null? reg))) (car reg)) -;; ((and (not regfull)(null? tal)(not (null? reg))) (car reg)) -;; ((and (not regfull)(not (null? tal))) (car tal)) -;; (else -;; (debug:print-error 0 *default-log-port* "runs:queue-next-hed, tal=" tal ", reg=" reg ", n=" n ", regfull=" regfull) -;; #f))) - (define (runs:queue-next-tal tal reg n regfull) (if regfull tal (if (null? tal) ;; must transfer from reg (cdr reg) @@ -652,12 +650,40 @@ t) (else (conc t)))) inlst))) -(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps) - (let* ((run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running + +;; hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps) +(define (runs:process-expanded-tests runsdat) + (let* ((hed (runs:dat-hed runsdat)) + (tal (runs:dat-tal runsdat)) + (reg (runs:dat-reg runsdat)) + (reruns (runs:dat-reruns runsdat)) + (reglen (runs:dat-reglen runsdat)) + (regfull (runs:dat-regfull runsdat)) + (test-record (runs:dat-test-record runsdat)) + (runname (runs:dat-runname runsdat)) + (test-name (runs:dat-test-name runsdat)) + (item-path (runs:dat-item-path runsdat)) + (jobgroup (runs:dat-jobgroup runsdat)) + (max-concurrent-jobs (runs:dat-max-concurrent-jobs runsdat)) + (run-id (runs:dat-run-id runsdat)) + (waitons (runs:dat-waitons runsdat)) + (item-path (runs:dat-item-path runsdat)) + (testmode (runs:dat-testmode runsdat)) + (test-patts (runs:dat-test-patts runsdat)) + (required-tests (runs:dat-required-tests runsdat)) + (test-registry (runs:dat-test-registry runsdat)) + (registry-mutex (runs:dat-registry-mutex runsdat)) + (flags (runs:dat-flags runsdat)) + (keyvals (runs:dat-keyvals runsdat)) + (run-info (runs:dat-run-info runsdat)) + (newtal (runs:dat-newtal runsdat)) + (all-tests-registry (runs:dat-all-tests-registry runsdat)) + (itemmaps (runs:dat-itemmaps runsdat)) + (run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) @@ -1147,12 +1173,39 @@ ((not items) (debug:print-info 4 *default-log-port* "OUTER COND: (not items)") (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) (not (null? tal))) (loop (car tal)(cdr tal) reg reruns)) - (let ((loop-list (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps))) - (if loop-list (apply loop loop-list)))) + (let ((runsdat (make-runs:dat + hed: hed + tal: tal + reg: reg + reruns: reruns + reglen: reglen + regfull: regfull + test-record: test-record + runname: runname + test-name: test-name + item-path: item-path + jobgroup: jobgroup + max-concurrent-jobs: max-concurrent-jobs + run-id: run-id + waitons: waitons + item-path: item-path + testmode: testmode + test-patts: test-patts + required-tests: required-tests + test-registry: test-registry + registry-mutex: registry-mutex + flags: flags + keyvals: keyvals + run-info: run-info + newtal: newtal + all-tests-registry: all-tests-registry + itemmaps: itemmaps))) + (let ((loop-list (runs:process-expanded-tests runsdat))) + (if loop-list (apply loop loop-list))))) ;; items processed into a list but not came in as a list been processed ;; ((and (list? items) ;; thus we know our items are already calculated (not itemdat)) ;; and not yet expanded into the list of things to be done @@ -1304,10 +1357,11 @@ (conc t) (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)) ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step +;; (define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) ;; All these vars might be referenced by the testconfig file reader (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (test-conf (tests:testqueue-get-testconfig test-record))