Overview
Comment: | mid-hacking |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | reorg-runs-code |
Files: | files | file ages | folders |
SHA1: |
0894da02e1fe30e44631327b4163ed70 |
User & Date: | matt on 2011-11-17 07:11:52 |
Other Links: | branch diff | manifest | tags |
Context
2011-11-19
| ||
16:49 | Updated diagrams check-in: 78b5afb1e6 user: matt tags: reorg-runs-code | |
2011-11-17
| ||
07:11 | mid-hacking check-in: 0894da02e1 user: matt tags: reorg-runs-code | |
2011-11-16
| ||
21:30 | Re-added the delayed update, issue with dashboard displaying was window manager check-in: b13e42d1a5 user: matt tags: reorg-runs-code | |
Changes
Modified Makefile from [ed1fd098c5] to [b20ff2bde7].
︙ | ︙ | |||
22 23 24 25 26 27 28 | csc $(OFILES) $(GOFILES) -o dboard # Special dependencies for the includes db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o monitor.o dashboard.o megatest.o : db_records.scm runs.o dashboard.o dashboard-tests.o : run_records.scm keys.o db.o runs.o launch.o megatest.o : key_records.scm tasks.o dashboard-tasks.o : task_records.scm | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | csc $(OFILES) $(GOFILES) -o dboard # Special dependencies for the includes db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o monitor.o dashboard.o megatest.o : db_records.scm runs.o dashboard.o dashboard-tests.o : run_records.scm keys.o db.o runs.o launch.o megatest.o : key_records.scm tasks.o dashboard-tasks.o : task_records.scm runs.o : old-runs.scm test_records.scm $(OFILES) $(GOFILES) : common_records.scm %.o : %.scm csc -c $< $(PREFIX)/bin/megatest : megatest |
︙ | ︙ |
Modified items.scm from [24c2262144] to [b49fc1c23e].
︙ | ︙ | |||
123 124 125 126 127 128 129 130 131 132 133 134 | (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class))) (if s (string-split s) #f)))) (if valid-values (if (member item valid-values) item #f) item))) ;; (pp (item-assoc->item-list itemdat)) | > > > > > > > > > | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 | (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class))) (if s (string-split s) #f)))) (if valid-values (if (member item valid-values) item #f) item))) (define (items:get-items-from-config tconfig) (let* (;; db is always at *toppath*/db/megatest.db (items (hash-table-ref/default test-conf "items" '())) (itemstable (hash-table-ref/default test-conf "itemstable" '())) (allitems (if (or (not (null? items))(not (null? itemstable))) (append (item-assoc->item-list items) (item-table->item-list itemstable)) '(())))) allitems)) ;; (pp (item-assoc->item-list itemdat)) |
Modified runs.scm from [5d46e1bbed] to [253a55cec5].
︙ | ︙ | |||
20 21 22 23 24 25 26 27 28 29 30 31 32 33 | (declare (uses runconfig)) (declare (uses tests)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") ;; stuff to be deprecated then removed (include "old-runs.scm") ;; runs:get-runs-by-patt ;; get runs by list of criteria | > | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | (declare (uses runconfig)) (declare (uses tests)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; stuff to be deprecated then removed (include "old-runs.scm") ;; runs:get-runs-by-patt ;; get runs by list of criteria |
︙ | ︙ | |||
155 156 157 158 159 160 161 | (let* ((keys (db-get-keys db)) (keyvallst (keys:target->keyval keys target)) (run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (test-names '()) (runconfigf (conc *toppath* "/runconfigs.config")) | | > | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | (let* ((keys (db-get-keys db)) (keyvallst (keys:target->keyval keys target)) (run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (test-names '()) (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '()) (test-records (make-hash-table))) (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) |
︙ | ︙ | |||
179 180 181 182 183 184 185 186 187 | tests))))) (string-split test-patts ",")) ;; now remove duplicates (set! test-names (delete-duplicates test-names)) (debug:print 0 "INFO: test names " test-names) ;; now add non-directly referenced dependencies (i.e. waiton) | > > > > > > > > > > > > > > < < > > | | < < < < < < < < < < | > > > > > > > > > | | | 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 242 243 244 245 246 247 248 249 250 | tests))))) (string-split test-patts ",")) ;; now remove duplicates (set! test-names (delete-duplicates test-names)) (debug:print 0 "INFO: test names " test-names) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (and (eq? *passnum* 0) keepgoing) (begin ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. (db:delete-tests-in-state db run-id "NOT_STARTED") (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) (set! *passnum* (+ *passnum* 1)) ;; now add non-directly referenced dependencies (i.e. waiton) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) (let* ((config (test:get-testconfig hed #f)) (waitons (string-split (let ((w (config-lookup config "requirements" "waiton"))) (if w w ""))))) (if (not (hash-table-ref/default test-records hed #f)) (hash-table-set! test-records hed (vector hed config waitons (config-lookup "requirements" "priority") #f))) (for-each (lambda (waiton) (if (and waiton (not (member waiton test-names))) (begin (set! required-tests (cons waiton required-tests)) (set! test-names (append test-names (list waiton)))))) waitons) (let ((remtests (delete-duplicates (append waitons tal)))) (if (not (null? remtests)) (loop (car remtests)(cdr remtests))))))) (if (not (null? required-tests)) (debug:print 1 "INFO: Adding " required-tests " to the run queue")) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (let loop ((numtimes 0)) (for-each (lambda (test-record) ;; need to inspect the items field tests:testqueue-get-items ;; ;; if #f then no items for this test, check prereqs and launch ;; ;; else if list, then have items ;; ;; if proc then eval it. ;; (let ((items (items:get-items-from-config tconfig))) (if (runs:can-run-more-tests db test-record) ;; now needs to look at the test group (run:test db run-id runname test-name keyvallst item-patts flags) )) (tests:sort-by-priority-and-waiton test-records)) ;; (run-waiting-tests db) (if keepgoing (let ((estrem (db:estimated-tests-remaining db run-id))) (if (and (> estrem 0) (eq? *globalexitstatus* 0)) (begin (debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...") |
︙ | ︙ |
Added test_records.scm version [1c9875ade7].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | ;; make-vector-record tests testqueue testname testconfig waitons priority items (define (make-tests:testqueue)(make-vector 5)) (define-inline (tests:testqueue-get-testname vec) (vector-ref vec 0)) (define-inline (tests:testqueue-get-testconfig vec) (vector-ref vec 1)) (define-inline (tests:testqueue-get-waitons vec) (vector-ref vec 2)) (define-inline (tests:testqueue-get-priority vec) (vector-ref vec 3)) (define-inline (tests:testqueue-get-items vec) (vector-ref vec 4)) (define-inline (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val)) (define-inline (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val)) (define-inline (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val)) (define-inline (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val)) (define-inline (tests:testqueue-set-items! vec val)(vector-set! vec 4 val)) |
Modified tests.scm from [f3725b9582] to [b7feda25e5].
︙ | ︙ | |||
319 320 321 322 323 324 325 | (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" #f)) #f))) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days | | < | < < < < | | | | | > > | | | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 | (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" #f)) #f))) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) (let ((mungepriority (lambda (priority) (if priority (let ((tmp (any->number priority))) (if tmp tmp (begin (debug:print 0 "ERROR: bad priority value " priority ", using 0") 0))) 0)))) (sort (hash-table-keys test-records) ;; avoid dealing with deleted tests, look at the hash table (lambda (a b) (let* ((a-record (hash-table-ref test-records a)) (b-record (hash-table-ref test-records b)) (a-waitons (tests:testqueue-get-waitons a-record)) (b-waitons (tests:testqueue-get-waitons a-record)) (a-priority (mungepriority (config-lookup tconf-a "requirements" "priority"))) (b-priority (mungepriority (config-lookup tconf-b "requirements" "priority")))) (tests:testqueue-set-priority! a-record a-priority) (tests:testqueue-set-priority! b-record b-priority) (if (and a-waiton (member? (tests:testqueue-get-testname b) a-waitons)) #f ;; cannot have a which is waiting on b happening before b (if (and b-waiton (member? (tests:testqueue-get-testname a) b-waitons)) #t ;; this is the correct order, b is waiting on a and b is before a (if (> a-priority b-priority) #t ;; if a is a higher priority than b then we are good to go #f)))))))) ;;====================================================================== |
︙ | ︙ |