@@ -99,30 +99,19 @@ (exit 1))) ;; data common to all tabs goes here ;; (defstruct dboard:commondat - curr-tab-num - please-update - tabdats - update-mutex - updaters - updating + ((curr-tab-num 0) : number) + ((tabdats (make-hash-table)) : hash-table) + ;; ((update-mutex (make-mutex)) : mutex) + (update-mutex (make-mutex)) + ((updaters (make-hash-table)) : hash-table) + ((updating #f) : boolean) uidat ;; needs to move to tabdat at some time - hide-not-hide-tabs - ) - -(define (dboard:commondat-make) - (make-dboard:commondat - curr-tab-num: 0 - tabdats: (make-hash-table) - please-update: #t - update-mutex: (make-mutex) - updaters: (make-hash-table) - updating: #f - hide-not-hide-tabs: #f - )) + ((hide-not-hide-tabs #f) : boolean) + ) (define (dboard:common-get-tabdat commondat #!key (tab-num #f)) (hash-table-ref/default (dboard:commondat-tabdats commondat) (or tab-num (dboard:commondat-curr-tab-num commondat)) @@ -171,10 +160,11 @@ ((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 (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 + ((please-update #t) : boolean) ;; was in commondat. (last-test-dat #f) ;; cache last tests dat ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files ;; Runs view ((buttondat (make-hash-table)) : hash-table) ;; @@ -470,11 +460,11 @@ ;; gets all the tests for run-id that match testnamepatt and key-vals, merges them ;; ;; NOTE: Yes, this is used ;; (define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals) - (let* ((num-to-get 20) + (let* ((num-to-get 100) (states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) (statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat))) (sort-info (get-curr-sort)) (sort-by (vector-ref sort-info 1)) (sort-order (vector-ref sort-info 2)) @@ -917,13 +907,16 @@ (define (update-search commondat tabdat x val) (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val) (dboard:tabdat-filters-changed-set! tabdat #t) (set-bg-on-filter commondat tabdat)) -(define (mark-for-update tabdat) +(define (mark-for-update update-mutex tabdat) + (mutex-lock! update-mutex) (dboard:tabdat-filters-changed-set! tabdat #t) - (dboard:tabdat-last-db-update-set! tabdat 0)) + (dboard:tabdat-last-db-update-set! tabdat 0) + (dboard:tabdat-please-update-set! tabdat #t) + (mutex-unlock! update-mutex)) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== @@ -1215,11 +1208,12 @@ ;; #:multiline "YES"))) ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) (define (dboard:runs-tree-browser commondat tabdat) - (let* ((tb (iup:treebox + (let* ((update-mutex (dboard:commondat-update-mutex commondat)) + (tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" #:selection-cb @@ -1226,14 +1220,15 @@ (lambda (obj id state) (debug:catch-and-dump (lambda () (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id tabdat (cdr run-path)))) - (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path) + (dboard:tabdat-target-set! tabdat (cdr run-path)) (dboard:tabdat-layout-update-ok-set! tabdat #f) (if (number? run-id) (begin + (mark-for-update update-mutex tabdat) (dboard:tabdat-curr-run-id-set! tabdat run-id) (dboard:tabdat-view-changed-set! tabdat #t)) (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id)))) "treebox")) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) @@ -1383,10 +1378,12 @@ (let ((res (assoc name lst))) (if (and res (> (length res) 1)) (cadr res) #f))) +;; generic update of tree with targets, runs +;; (define (dboard:update-tree tabdat runs-hash runs-header tb) (let* ((run-ids (sort (filter number? (hash-table-keys runs-hash)) (lambda (a b) (let* ((record-a (hash-table-ref runs-hash a)) (record-b (hash-table-ref runs-hash b)) @@ -1414,11 +1411,13 @@ userdata: (conc "run-id: " run-id)) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids))) - + +;; Updater for the run summary view +;; (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)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:tabdat-curr-run-id tabdat)) (last-update (hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0)) @@ -1427,10 +1426,11 @@ (db-pth (conc db-dir "/" run-id ".db"))) (hash-table-set! (dboard:tabdat-run-db-paths tabdat) run-id db-pth) db-pth))) (tests-dat (if (or (not run-id) (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps") + (dboard:tabdat-please-update tabdat) (>= (file-modification-time db-path) last-update)) (dboard:get-tests-dat tabdat run-id last-update) (dboard:tabdat-last-test-dat tabdat))) (tests-mindat (dcommon:minimize-test-data tests-dat)) (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) @@ -1565,11 +1565,12 @@ ;; display and manage a single run at a time ;; This is the Run Summary tab ;; (define (dashboard:one-run commondat tabdat #!key (tab-num #f)) - (let* ((tb (iup:treebox + (let* ((update-mutex (dboard:commondat-update-mutex commondat)) + (tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" #:selection-cb @@ -1579,10 +1580,11 @@ ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id tabdat (cdr run-path)))) (if (number? run-id) (begin + (mark-for-update update-mutex tabdat) (dboard:tabdat-curr-run-id-set! tabdat run-id) (dboard:tabdat-layout-update-ok-set! tabdat #f) ;; (dashboard:update-run-summary-tab) ) ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) @@ -1599,12 +1601,12 @@ (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id "&"))) (system cmd))))) (one-run-updater (lambda () - (if (dashboard:database-changed? commondat tabdat) - (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix))))) + ;; (if (dashboard:database-changed? commondat tabdat) + (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix))));; ) (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:vbox (iup:split tb @@ -1614,11 +1616,12 @@ ;;====================================================================== ;; R U N S ;;====================================================================== (define (dboard:make-controls commondat tabdat) - (let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat))) + (let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat)) + (update-mutex (dboard:commondat-update-mutex commondat))) (iup:hbox (iup:vbox (iup:frame #:title "filter test and items" (iup:hbox @@ -1626,20 +1629,20 @@ (iup:textbox #:size "120x15" #:fontsize "10" #:value "%" #:expand "NO" #:action (lambda (obj unk val) (debug:catch-and-dump (lambda () - (mark-for-update tabdat) + (mark-for-update update-mutex tabdat) (update-search commondat tabdat "test-name" val)) "make-controls"))) (iup:hbox (iup:button "Quit" #:action (lambda (obj) ;; (if (dboard:tabdat-dblocal tabdat) (db:close-all (dboard:tabdat-dblocal tabdat))) (exit)) #:expand "NO" #:size "40x15") (iup:button "Refresh" #:action (lambda (obj) - (mark-for-update tabdat)) + (mark-for-update update-mutex tabdat)) #:expand "NO" #:size "40x15") (iup:button "Collapse" #:action (lambda (obj) (debug:catch-and-dump (lambda () (let ((myname (iup:attribute obj "TITLE"))) @@ -1652,11 +1655,11 @@ (begin (for-each (lambda (tname) (hash-table-delete! *collapsed* tname)) (hash-table-keys *collapsed*)) (iup:attribute-set! obj "TITLE" "Collapse")))) - (mark-for-update tabdat)) + (mark-for-update update-mutex tabdat)) "make-controls collapse button")) #:expand "NO" #:size "40x15"))) (iup:vbox ;; (iup:button "Sort -t" #:action (lambda (obj) ;; (next-sort-option) @@ -1672,36 +1675,36 @@ (sort-lb (iup:listbox #:expand "NO" ;; "HORIZONTAL" #:size "80x15" #:dropdown "YES" #:action (lambda (obj val index lbstate) (set! *tests-sort-reverse* index) - (mark-for-update tabdat)))) + (mark-for-update update-mutex tabdat)))) (default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*)))) (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd) (set! hide-empty (iup:button "HideEmpty" ;; #:expand HORIZONTAL" #:expand "NO" #:size "80x15" #:action (lambda (obj) (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat))) (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE")) - (mark-for-update tabdat)))) + (mark-for-update update-mutex tabdat)))) (set! hide (iup:button "Hide" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat))) ;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide")) (iup:attribute-set! hide "BGCOLOR" sel-color) (iup:attribute-set! show "BGCOLOR" nonsel-color) - (mark-for-update tabdat)))) + (mark-for-update update-mutex tabdat)))) (set! show (iup:button "Show" #:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL" #:action (lambda (obj) (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat))) (iup:attribute-set! show "BGCOLOR" sel-color) (iup:attribute-set! hide "BGCOLOR" nonsel-color) - (mark-for-update tabdat)))) + (mark-for-update update-mutex tabdat)))) (iup:attribute-set! hide "BGCOLOR" sel-color) (iup:attribute-set! show "BGCOLOR" nonsel-color) ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ... (iup:vbox (iup:hbox hide show) @@ -1715,11 +1718,11 @@ (map (lambda (status) (iup:toggle (conc status " ") #:fontsize btn-fontsz ;; "10" #:expand "HORIZONTAL" #:action (lambda (obj val) - (mark-for-update tabdat) + (mark-for-update update-mutex tabdat) (if (eq? val 1) (hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t) (hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status)) (set-bg-on-filter commondat tabdat)))) (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) @@ -1728,11 +1731,11 @@ (map (lambda (state) (iup:toggle (conc state " ") #:fontsize btn-fontsz #:expand "HORIZONTAL" #:action (lambda (obj val) - (mark-for-update tabdat) + (mark-for-update update-mutex tabdat) (if (eq? val 1) (hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t) (hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state)) (set-bg-on-filter commondat tabdat)))) (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) @@ -1739,11 +1742,11 @@ (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) (oldmax (string->number (iup:attribute obj "MAX"))) (maxruns (dboard:tabdat-tot-runs tabdat))) (dboard:tabdat-start-run-offset-set! tabdat val) - (mark-for-update tabdat) + (mark-for-update update-mutex tabdat) (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) (iup:attribute-set! obj "MAX" (* maxruns 10)))) #:expand "HORIZONTAL" #:max (* 10 (length (dboard:tabdat-allruns tabdat))) #:min 0 @@ -1860,11 +1863,12 @@ (bdylst '()) (result '()) (i 0) (btn-height (dboard:tabdat-runs-btn-height runs-dat)) (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) - (cell-width (dboard:tabdat-runs-cell-width runs-dat))) + (cell-width (dboard:tabdat-runs-cell-width runs-dat)) + (update-mutex (dboard:commondat-update-mutex commondat))) ;; controls (along bottom) ;; (set! controls (dboard:make-controls commondat runs-dat)) ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox @@ -1873,11 +1877,11 @@ (map (lambda (x) (let ((res (iup:hbox #:expand "HORIZONTAL" (iup:label x #:size (conc 40 btn-height) #:fontsize btn-fontsz #:expand "NO") ;; "HORIZONTAL") (iup:textbox #:size (conc 35 btn-height) #:fontsize btn-fontsz #:value "%" #:expand "NO" ;; "HORIZONTAL" #:action (lambda (obj unk val) - (mark-for-update runs-dat) + (mark-for-update update-mutex runs-dat) (update-search commondat runs-dat x val)))))) (set! i (+ i 1)) res)) keynames))))) (let loop ((testnum 0) @@ -1888,11 +1892,11 @@ (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (string->number (iup:attribute obj "VALUE"))) (oldmax (string->number (iup:attribute obj "MAX"))) (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat))))) - (dboard:commondat-please-update-set! commondat #t) + (mark-for-update update-mutex tabdat) (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10)))) (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax) (if (< val 10) (iup:attribute-set! obj "MAX" newmax)) )) @@ -1909,11 +1913,11 @@ ; #:impress img2 #:size (conc cell-width btn-height) #:expand "HORIZONTAL" #:fontsize btn-fontsz #:action (lambda (obj) - (mark-for-update runs-dat) + (mark-for-update update-mutex runs-dat) (toggle-hide testnum (dboard:commondat-uidat commondat)))))) ;; (iup:attribute obj "TITLE")))) (vector-set! lftcol testnum labl) (loop (+ testnum 1)(cons labl res)))))) ;; These are the headers for each row (let loop ((runnum 0) @@ -2015,11 +2019,11 @@ (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) (dboard:tabdat-layout-update-ok-set! tabdat #f)) (dboard:commondat-curr-tab-num-set! commondat curr) (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) - (dboard:commondat-please-update-set! commondat #t) + (mark-for-update update-mutex tabdat) (dboard:tabdat-layout-update-ok-set! tabdat #t))) "tabchangepos")) (dashboard:summary commondat stats-dat tab-num: 0) runs-view (dashboard:one-run commondat onerun-dat tab-num: 2) @@ -2106,12 +2110,12 @@ #f))) (define (dashboard:database-changed? commondat tabdat) (let* ((run-update-time (current-seconds)) (modtime (dashboard:get-youngest-run-db-mod-time tabdat)) ;; NOTE: ensure this is tabdat!! - (recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:tabdat-last-db-update tabdat)))) - (dboard:commondat-please-update-set! commondat #f) + (recalc (dashboard:recalc modtime (dboard:tabdat-please-update tabdat) (dboard:tabdat-last-db-update tabdat)))) + (dboard:tabdat-please-update-set! tabdat #f) recalc)) ;; point inside line ;; (define-inline (dashboard:px-between px lx1 lx2) @@ -2756,11 +2760,11 @@ (if (file-exists? debugcontrolf) (load debugcontrolf))) (define (main) (if (not (args:get-arg "-skip-version-check"))(common:exit-on-version-changed)) - (let* ((commondat (dboard:commondat-make))) + (let* ((commondat (make-dboard:commondat))) ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... (cond ((args:get-arg "-test") ;; run-id,test-id (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) (if (> (length d) 1)