Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -170,10 +170,11 @@ (header #f) ;; header for decoding the run records (keys #f) ;; keys for this run (i.e. target components) ((numruns (string->number (or (args:get-arg "-cols") "8"))) : number) ;; ((tot-runs 0) : number) ((last-data-update 0) : number) ;; last time the data in allruns was updated + ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files @@ -567,14 +568,15 @@ ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) - (let* ( - (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (let* ((keys (rmt:get-keys)) + (last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (rmt:get-runs "%" #f "0" '())) + (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update));;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -581,10 +583,11 @@ (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run header "id") run)) runs-tree) ;; (vector-ref runs-dat 1)) ht)) (tb (dboard:tabdat-runs-tree tabdat))) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (dboard:tabdat-header-set! tabdat header) ;; ;; trim runs to only those that are changing often here ;; (if (null? runs) @@ -1266,10 +1269,13 @@ (if (> (- now-time last-data-update) 5) (if (not (dboard:tabdat-running-layout tabdat)) (begin (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) (dboard:tabdat-last-data-update-set! tabdat now-time) + ;; this is threadified to return control to the gui for a redraw. + ;; it relies on the running-layout flag to prevent overlapping + ;; calls. (thread-start! (make-thread (lambda () (dboard:tabdat-running-layout-set! tabdat #t) (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) (dboard:tabdat-running-layout-set! tabdat #f)) @@ -1398,11 +1404,13 @@ (record-b (hash-table-ref runs-hash b)) (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b))))) (changed #f) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))) + (last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) (run-name (db:get-value-by-header run-record runs-header "runname")) @@ -1422,11 +1430,12 @@ ;; (set! colnum (+ colnum 1)) )))) run-ids))) (define (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix) - (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) + (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) @@ -1457,10 +1466,11 @@ (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window (numrows 1) (numcols 1) (changed #f) ) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) (dboard:tabdat-filters-changed-set! tabdat #f) (let loop ((pass-num 0) (changed #f)) @@ -2241,11 +2251,12 @@ (db:test-get-event_time (hash-table-ref testsdat (car b)))))))))) ;; run times tab data updater ;; (define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) - (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) + (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) (vector-ref runs-dat 1)) @@ -2259,10 +2270,11 @@ (< time-a time-b))))) (tb (dboard:tabdat-runs-tree tabdat)) (num-runs (length (hash-table-keys runs-hash))) (update-start-time (current-seconds)) (inc-mode #f)) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) ;; fill in the tree (if (and tb (not inc-mode)) (for-each (lambda (run-id) @@ -2847,12 +2859,11 @@ (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab ;; (dboard:commondat-please-update-set! commondat #t) ;; MRW: ww36.3 - why was please update set true here? Removing it for now. ;; (dashboard:run-update commondat) ) "update buttons once")) (th2 (make-thread iup:main-loop "Main loop"))) - - (thread-start! th1) + ;; (thread-start! th1) (thread-start! th2) (thread-join! th2)))) (main) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1962,11 +1962,11 @@ ;; register a test run with the db ;; ;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; -(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields) ;; test-name) +(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update) ;; test-name) (let* ((tmp (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time")))) (keystr (car tmp)) (header (cadr tmp)) (res '()) (key-patt "") @@ -1982,11 +1982,15 @@ (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) (begin (debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey) (exit 6))))) keyvals) - (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " + (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt + (if last-update + (conc " AND last_update >= " last-update " ") + " ") + " ORDER BY event_time " (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (db:with-db dbstruct #f #f ;; reads db, does not write to it. Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -940,11 +940,11 @@ (dashboard:update-run-command tabdat)))) "command-runname-selector lb action")))) (refresh-runs-list (lambda () (if (dashboard:database-changed? commondat tabdat) (let* ((target (dboard:tabdat-target-string tabdat)) - (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" target #f #f #f)) + (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" target #f #f #f 0)) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -41,11 +41,11 @@ ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; (define (mt:get-runs-by-patt keys runnamepatt targpatt) - (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f)) + (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f 0)) (res '()) (offset 0) (limit 500)) ;; (print "runsdat: " runsdat) (let* ((header (vector-ref runsdat 0)) @@ -53,11 +53,11 @@ (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) ;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) - (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f))) + (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f 0))) (debug:print-info 4 *default-log-port* "More than " limit " runs, have " (length full-list) " runs so far.") (debug:print-info 0 *default-log-port* "next-batch: " next-batch) (loop next-batch full-list new-offset Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -576,12 +576,12 @@ (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) (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) ;; fields of #f uses default - (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields))) +(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update) ;; fields of #f uses default + (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update))) (define (rmt:find-and-mark-incomplete run-id ovr-deadtime) (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))))