Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -2483,10 +2483,14 @@ ;; simple lock. improve and converge on this one. ;; (define (common:simple-lock keyname) (rmt:no-sync-get-lock keyname)) + +(define (common:simple-unlock keyname #!key (force #f)) + (rmt:no-sync-del! keyname)) + ;;====================================================================== ;; ;;====================================================================== Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -481,10 +481,26 @@ (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) (string-intersperse (map number->string (u8vector->list (if res res (hostname->ip hostname)))) "."))) + +(define server:sync-lock-token "SERVER_SYNC_LOCK") +(define (server:release-sync-lock) + (db:no-sync-del! *no-sync-db* server:sync-lock-token)) +(define (server:have-sync-lock?) + (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token)) + (have-lock? (car have-lock-pair)) + (lock-time (cdr have-lock-pair)) + (lock-age (- (current-seconds) lock-time))) + (cond + (have-lock? #t) + ((>lock-age + (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180))) + (server:release-sync-lock) + (server:have-sync-lock?)) + (else #f)))) ;; moving this here as it needs access to db and cannot be in common. ;; (define (server:writable-watchdog dbstruct) (thread-sleep! 0.05) ;; delay for startup @@ -510,11 +526,12 @@ (let loop () ;; sync for filesystem local db writes ;; (mutex-lock! *db-multi-sync-mutex*) (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write - (sync-in-progress *db-sync-in-progress*) + (sync-in-progress *db-sync-in-progress*) + (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5)) (should-sync (and (not *time-to-exit*) (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed (start-time (current-seconds)) (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f))) @@ -528,15 +545,23 @@ (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db! (< mt-mod-time last-sync-start))) (sync-done (<= last-sync-start last-sync-end)) (sync-stale (> start-time (+ last-sync-start sync-stale-seconds))) - (will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting + (will-sync-pre (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting + have-lock? (or need-sync should-sync) (or sync-done sync-stale) (not sync-in-progress) - (not recently-synced)))) + (not recently-synced))) + (will-sync (if will-sync-pre + ;; delay get lock until we decide to sync + (server:have-sync-lock?) + #f))) + ;; if another server is syncing, postpone sync + (if (and will-sync-pre (not will-sync)) + (set! *db-last-sync* start-time)) (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync " sync-done=" sync-done " sync-period=" sync-period) (if (and (> sync-period 5) (common:low-noise-print 30 "sync-period")) @@ -591,11 +616,11 @@ (set! *db-sync-in-progress* #f) (set! *db-last-sync* start-time) (with-output-to-file end-file (lambda ()(print (current-process-id)))) ;; release lock here - + (server:release-sync-lock) (mutex-unlock! *db-multi-sync-mutex*))) (if (and debug-mode (> (- start-time last-time) 60)) (begin (set! last-time start-time)