[shepherd] 03/03: timer: Detect resumption from sleep state.

[Ludovic Courtès]

civodul pushed a commit to branch devel
in repository shepherd.

commit f1b57344f62ceec5dadac937c50d984c504a0cf1
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Apr 20 15:41:44 2024 +0200

    timer: Detect resumption from sleep state.
    
    Previously, timers could fire when resuming from sleep state when their
    deadline had long passed, because said deadline occurred while the
    machine was in sleep state.
    
    This commit avoids a “timer storm” when resuming by checking whether we
    “overslept”.
    
    * modules/shepherd/service.scm (sleep-operation/check): New procedure.
    (get-message*): Add ‘overslept’ parameter and honor it.  Use
    ‘sleep-operation/check’ instead of ‘sleep-operation’.
    * modules/shepherd/service/timer.scm (make-timer-constructor): Pass
    second argument to ‘get-message*’.  Add case for 'overslept.
---
 modules/shepherd/service.scm       | 35 +++++++++++++++++++++++------------
 modules/shepherd/service/timer.scm | 13 +++++++++++--
 2 files changed, 34 insertions(+), 14 deletions(-)

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index a03b16e..d5f99ac 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -2809,19 +2809,30 @@ while waiting for @var{program} to terminate."
   ;; Default process termination "grace period" before we send SIGKILL.
   (make-parameter 5))
 
-(define* (get-message* channel timeout #:optional default)
+(define (sleep-operation/check seconds timeout overslept)
+  "Make an operation that returns @var{timeout} when @var{seconds} have
+elapsed and @var{overslept} when many more seconds have elapsed--this can
+happen if the machine is suspended or put into hibernation mode."
+  (let ((expiry (+ (get-internal-real-time)
+                   (inexact->exact
+                    (round (* seconds internal-time-units-per-second))))))
+    (wrap-operation (timer-operation expiry)
+                    (lambda ()
+                      (let* ((now (get-internal-real-time))
+                             (delta (- now expiry)))
+                        (if (> delta (* 2 internal-time-units-per-second))
+                            overslept
+                            timeout))))))
+
+(define* (get-message* channel timeout
+                       #:optional default (overslept default))
   "Receive a message from @var{channel} and return it, or, if the message 
hasn't
-arrived before @var{timeout} seconds, return @var{default}."
-  (call-with-values
-      (lambda ()
-        (perform-operation
-         (choice-operation (get-operation channel)
-                           (sleep-operation timeout))))
-    (match-lambda*
-      (()                               ;'sleep' operation returns zero values
-       default)
-      ((message)                            ;'get' operation returns one value
-       message))))
+arrived before @var{timeout} seconds, return @var{default}; return
+@var{overslept} if more than @var{timeout} seconds expired, for instance
+because the machine hibernated."
+  (perform-operation
+   (choice-operation (get-operation channel)
+                     (sleep-operation/check timeout default overslept))))
 
 (define* (terminate-process pid signal
                             #:key (grace-period
diff --git a/modules/shepherd/service/timer.scm 
b/modules/shepherd/service/timer.scm
index 6d1d66f..5fe6d3e 100644
--- a/modules/shepherd/service/timer.scm
+++ b/modules/shepherd/service/timer.scm
@@ -533,7 +533,7 @@ instances running concurrently."
                           (and (pair? processes) wait-for-termination?))
                       (get-message channel)
                       (get-message* channel (seconds-to-wait event)
-                                    'timeout))
+                                    'timeout 'overslept))
              (('terminate reply)
               ;; Terminate this timer and its processes.  Send #t on REPLY
               ;; when we're done.
@@ -592,7 +592,16 @@ instances running concurrently."
                          (l10n "Exception caught while calling action of \
 timer '~a': ~s")
                          name (cons key args))))
-                    (loop processes termination))))))))
+                    (loop processes termination))))
+             ('overslept
+              ;; Reached when resuming from sleep state: we slept
+              ;; significantly more than the requested number of seconds.  To
+              ;; avoid triggering every timer when resuming from sleep state,
+              ;; sleep again to remain in sync.
+              (local-output (l10n "Waiting anew for timer '~a' (resuming \
+from sleep state?).")
+                            name)
+              (loop processes termination))))))
 
       (timer channel event action))))