Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -134,10 +134,14 @@ tree vgmod ducttape-lib ) +;; globals to dashboard module +(define *updaters-running* #f) +(define *updaters-thread* #f) + (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2017 @@ -3662,19 +3666,19 @@ numruns testnamepatt keypatts))) (define (dashboard:runs-tab-updater commondat tab-num) - (debug:catch-and-dump - (lambda () + ;; (debug:catch-and-dump + ;; (lambda () (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)) (dbkeys (dboard:tabdat-dbkeys tabdat))) (dashboard:do-update-rundat tabdat) (let ((uidat (dboard:commondat-uidat commondat))) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) )) - "dashboard:runs-tab-updater")) + ;; "dashboard:runs-tab-updater")) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== @@ -3715,35 +3719,46 @@ (dboard:commondat-add-updater commondat (lambda () (dashboard:runs-tab-updater commondat 1)) tab-num: 2) + (iup:callback-set! *tim* "ACTION_CB" (lambda (time-obj) - (let ((update-is-running #f)) - (mutex-lock! (dboard:commondat-update-mutex commondat)) - (set! update-is-running (dboard:commondat-updating commondat)) - (if (not update-is-running) - (dboard:commondat-updating-set! commondat #t)) - (mutex-unlock! (dboard:commondat-update-mutex commondat)) - (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update - (begin - (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) - (mutex-lock! (dboard:commondat-update-mutex commondat)) - (dboard:commondat-updating-set! commondat #f) - (mutex-unlock! (dboard:commondat-update-mutex commondat))) + (if (not *updaters-thread*) + (begin + ;; (debug:print-info 0 *default-log-port* "Updater started...") + (set! *updaters-thread* + (make-thread + (lambda () + (dboard:common-run-curr-updaters commondat)))) + (thread-start! *updaters-thread*)) + (begin + (debug:print-info 0 *default-log-port* "Updater restarted...") + (thread-resume! *updaters-thread*))) + (thread-sleep! 0.25) + (if (eq? (thread-state *updaters-thread*) 'running) + (begin + (debug:print-info 0 *default-log-port* "Updater suspended...") + (thread-suspend! *updaters-thread*)) + (begin + (set! *updaters-thread* #f) + ;; (debug:print-info 0 *default-log-port* "Updater done...") )) 1)))) - (let ((th1 (make-thread (lambda () - (thread-sleep! 1) - (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab - ) "update buttons once")) - (th2 (make-thread iup:main-loop "Main loop"))) - (thread-start! th2) - (thread-join! th2))))) + ;; (let ((th1 (make-thread (lambda () + ;; (thread-sleep! 1) + ;; (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab + ;; ) "update buttons once")) + ;; (th2 (make-thread iup:main-loop "Main loop"))) + ;; (thread-start! th2) + ;; (thread-join! th2)) + + (iup:main-loop) + ))) (define (get-debugcontrolf) (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (common:file-exists? debugcontrolf) debugcontrolf Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -84,11 +84,10 @@ (define dashboard:update-summary-tab #f) (define dashboard:update-servers-table #f) (define *last-monitor-update-time* 0) (define *exit-started* #f) - ;;====================================================================== ;; C O M M O N D A T A S T R U C T U R E ;;====================================================================== ;; Index: runsmod.scm ================================================================== --- runsmod.scm +++ runsmod.scm @@ -269,11 +269,11 @@ (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat))) (let* ((num-running (rmt:get-count-tests-running run-id)) (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) - (job-group-limit (let ((jobg-count (configf:lookup *configdat* "jobgroups" jobgroup))) + (job-group-limit (let ((jobg-count (configf:lookup-number *configdat* "jobgroups" jobgroup))) (if (string? jobg-count) (string->number jobg-count) jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) (runs:inc-can-run-more-tests-count runsdat)) ;; (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) Index: ulex-full/dbmgr.scm ================================================================== --- ulex-full/dbmgr.scm +++ ulex-full/dbmgr.scm @@ -334,11 +334,11 @@ ;; (thread-start! th1) ;; (thread-join! th1) ;; gratuitious thread stuff is so that mailbox is not used in primordial thead ;; since we accessed the server we can bump the expires time up (conndat-expires-set! cdat (+ (current-seconds) (server:expiration-timeout) - -2)) ;; two second margin for network time misalignments etc. + -10)) ;; ten second margin for network time misalignments etc. res))) ;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed ;; sometime in the future. ;; Index: ulex-full/ulex.scm ================================================================== --- ulex-full/ulex.scm +++ ulex-full/ulex.scm @@ -271,11 +271,11 @@ (let* ((cmbox (get-cmbox uconn)) ;; would it be better to keep a stack of mboxes to reuse? (qrykey (car cmbox)) (mbox (cdr cmbox)) (mbox-time (current-milliseconds)) (sres (send uconn host-port qrykey cmd data))) ;; short res - (if (eq? sres 'ack) + (if (eq? sres 'ack) ;; BUG: change to be less than server:expiration-timeout? (let* ((mbox-timeout-secs 120 #;(if (eq? 'primordial (thread-name (current-thread))) #f 120)) ;; timeout) (mbox-timeout-result 'MBOX_TIMEOUT) (res (mailbox-receive! mbox mbox-timeout-secs mbox-timeout-result)) @@ -438,11 +438,11 @@ ((direct) result) (else (print "ULEX: work "cmd", "params" done in "run-time" ms") ;; send 'response as cmd and result as params (send uconn rem-host-port qrykey 'response result) ;; could check for ack - (print "ULEX: response sent back to "rem-host-port" in "(- (current-milliseconds) end-time)))))) + (print "ULEX: response sent back to "rem-host-port" for "qrykey" in "(- (current-milliseconds) end-time)"ms"))))) (MBOX_TIMEOUT 'do-work-timeout) (else (print "ERROR: rdat "rdat", did not match rem-host-port qrykey cmd params"))))) ;; NEW APPROACH: Index: ulex/ulex.scm ================================================================== --- ulex/ulex.scm +++ ulex/ulex.scm @@ -438,11 +438,11 @@ ((direct) result) (else (print "ULEX: work "cmd", "params" done in "run-time" ms") ;; send 'response as cmd and result as params (send uconn rem-host-port qrykey 'response result) ;; could check for ack - (print "ULEX: response sent back to "rem-host-port" in "(- (current-milliseconds) end-time)))))) + (print "ULEX: response sent back to "rem-host-port" for "qrykey" in "(- (current-milliseconds) end-time)"ms"))))) (MBOX_TIMEOUT 'do-work-timeout) (else (print "ERROR: rdat "rdat", did not match rem-host-port qrykey cmd params"))))) ;; NEW APPROACH: