[no subject]

[Ludovic Courtès]

branch: master
commit 2737a489b0bea0f07db8f825590da1584d7f83f1
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Jan 9 14:32:35 2024 +0100

    utils: Add ‘with-timing-check’ and use it.
    
    * src/cuirass/utils.scm (call-with-timing-check): New procedure.
    (with-timing-check): New macro.
    * src/cuirass/scripts/remote-server.scm (run-fetch): Use it.
---
 .dir-locals.el                        |  2 ++
 src/cuirass/scripts/remote-server.scm | 13 +++----------
 src/cuirass/utils.scm                 | 17 ++++++++++++++++-
 3 files changed, 21 insertions(+), 11 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 8c44a82..5623e58 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -12,6 +12,8 @@
   (eval put 'with-store/non-blocking 'scheme-indent-function 1)
   (eval put 'call-with-time 'scheme-indent-function 1)
   (eval put 'test-error 'scheme-indent-function 1)
+  (eval put 'with-time-logging 'scheme-indent-function 1)
+  (eval put 'with-timing-check 'scheme-indent-function 1)
   (eval put 'make-parameter 'scheme-indent-function 1)
   (eval put 'with-database 'scheme-indent-function 0)
   (eval put 'with-transaction 'scheme-indent-function 0)
diff --git a/src/cuirass/scripts/remote-server.scm 
b/src/cuirass/scripts/remote-server.scm
index 2a503b4..51c8ef2 100644
--- a/src/cuirass/scripts/remote-server.scm
+++ b/src/cuirass/scripts/remote-server.scm
@@ -1,6 +1,6 @@
 ;;; remote-server.scm -- Remote build server.
 ;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
-;;; Copyright © 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2023, 2024 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -314,15 +314,8 @@ directory."
      (let ((outputs (build-outputs drv)))
        (log-info "fetching ~a outputs of '~a' from ~a"
                  (length outputs) drv url)
-       (call-with-time
-        (lambda ()
-          (add-to-store drv outputs url))
-        (lambda (time result)
-          (let ((duration (+ (time-second time)
-                             (/ (time-nanosecond time) 1e9))))
-            (when (> duration 60)
-              (log-warning "fetching '~a' took ~a seconds."
-                           drv duration)))))
+       (with-timing-check (format #f "fetching '~a'" drv)
+         (add-to-store drv outputs url))
        (log-info "build succeeded: '~a'" drv)
        (set-build-successful! drv)))
     (('build-failed ('drv drv) ('url url) _ ...)
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index 1ef5eae..291111a 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -1,5 +1,5 @@
 ;;; utils.scm -- helper procedures
-;;; Copyright © 2012-2013, 2016, 2018-2019, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2013, 2016, 2018-2019, 2023-2024 Ludovic Courtès 
<ludo@gnu.org>
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
@@ -47,6 +47,7 @@
             date->rfc822-str
             random-string
             call-with-time
+            with-timing-check
             gather-user-privileges))
 
 (define-syntax-rule (define-enumeration name (symbol value) ...)
@@ -221,6 +222,20 @@ values."
          (end    (current-time time-monotonic)))
     (apply kont (time-difference end start) result)))
 
+(define* (call-with-timing-check label thunk #:key (threshold 60))
+  (call-with-time thunk
+    (lambda (time . results)
+      (let ((duration (+ (time-second time)
+                         (/ (time-nanosecond time) 1e9))))
+        (when (> duration 60)
+          (log-warning "~a took ~a seconds" label duration)))
+      (apply values results))))
+
+(define-syntax-rule (with-timing-check label exp args ...)
+  "Evaluate EXP, printing a warning if its execution time exceeds #:threshold
+seconds (60 seconds by default)."
+  (call-with-timing-check label (lambda () exp) args ...))
+
 (define (gather-user-privileges user)
   "switch to the identity of user, a user name."
   (catch 'misc-error