GNU bug report logs - #78432
[PATCH 1/2] channels: Speed up ‘channel-news-for-commit’.

Previous Next

To reply to this bug, email your comments to 78432 AT debbugs.gnu.org.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: guix-patches <at> gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>,
 Ian Eure <ian <at> retrospec.tv>
Subject: [PATCH 1/2] channels: Speed up ‘channel-news-for-commit’.
Date: Wed, 14 May 2025 22:23:45 +0200

Partly fixes <https://issues.guix.gnu.org/78194>.

This makes the wall-clock time of:

  guix pull --list-generations > /dev/null

shrink from 33s to 4s on a profile with 8 generations.

* guix/channels.scm (channel-news-for-commit): Rewrite in terms of
‘commit-descendant?’.

Reported-by: Ian Eure <ian <at> retrospec.tv>
Change-Id: I387e3dc37437e2d98bfd7ab710417f68d16146ad
---
 guix/channels.scm | 24 ++++++++++++------------
 1 file changed, 12 insertions(+), 12 deletions(-)

diff --git a/guix/channels.scm b/guix/channels.scm
index 7a02d24a84..f6b3f40cc3 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018-2024 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2018-2025 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado <at> elephly.net>
 ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke <at> gnu.org>
 ;;; Copyright © 2021 Brice Waegeneire <brice <at> waegenei.re>
@@ -31,7 +31,7 @@ (define-module (guix channels)
   #:autoload   (git structs) (git-error-code)
   #:autoload   (guix git) (update-cached-checkout
                            url+commit->name
-                           commit-difference
+                           commit-descendant?
                            repository-info
                            commit-short-id
                            tag->commit
@@ -48,7 +48,6 @@ (define-module (guix channels)
   #:use-module (guix progress)
   #:use-module (guix derivations)
   #:use-module (guix diagnostics)
-  #:use-module (guix sets)
   #:use-module (guix store)
   #:use-module (guix i18n)
   #:use-module (srfi srfi-1)
@@ -1237,15 +1236,16 @@ (define* (channel-news-for-commit channel new #:optional old)
                                                                      entry))
                                    (channel-news-entries news))))
                 (if old
-                    (let* ((new     (commit-lookup repository (string->oid new)))
-                           (old     (commit-lookup repository (string->oid old)))
-                           (commits (list->set
-                                     (map (compose oid->string commit-id)
-                                          (commit-difference new old)))))
-                      (filter (lambda (entry)
-                                (set-contains? commits
-                                               (channel-news-entry-commit entry)))
-                              entries))
+                    (let ((new (commit-lookup repository (string->oid new)))
+                          (old (commit-lookup repository (string->oid old))))
+                      (take-while (lambda (entry)
+                                    (let ((entry (commit-lookup
+                                                  repository
+                                                  (string->oid
+                                                   (channel-news-entry-commit entry)))))
+                                      (and (commit-descendant? new (list entry))
+                                           (not (commit-descendant? old (list entry))))))
+                                  entries))
                     entries)))
             '())))
     (lambda (key error . rest)

base-commit: c5265b90b055ee15908298c5d463301f1aae2eb1
-- 
2.49.0

Message #8 received at 78432 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 78432 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 2/2] git: Remove code for Guile-Git < 0.10.0.
Date: Wed, 14 May 2025 22:26:28 +0200

* guix/git.scm (commit-relation, commit-descendant?): Remove code for
Guile-Git < 0.10.0.
(set-git-timeouts): Remove code for Guile-Git < 0.9.0.
(report-git-error): Remove code for ancient Guile-Git.

Change-Id: Ie597151ce4c1e5ea006e2783fcc510caed3f566c
---
 guix/git.scm | 90 ++++++++++++++--------------------------------------
 1 file changed, 24 insertions(+), 66 deletions(-)

diff --git a/guix/git.scm b/guix/git.scm
index 9975c9b92e..c1353c5c04 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -211,15 +211,9 @@ (define (set-git-timeouts connection-timeout read-timeout)
 when talking to remote Git servers.
 
 If one of them is #f, the corresponding default setting is kept unchanged."
-  ;; 'set-server-timeout!' & co. were added in Guile-Git 0.9.0.
-  (define (defined? variable)
-    (module-defined? (resolve-interface '(git)) variable))
-
-  (when (and (defined? 'set-server-connection-timeout!)
-             connection-timeout)
+  (when connection-timeout
     (set-server-connection-timeout! connection-timeout))
-  (when (and (defined? 'set-server-timeout!)
-             read-timeout)
+  (when read-timeout
     (set-server-timeout! read-timeout)))
 
 (define* (clone* url directory #:key (verify-certificate? #t))
@@ -374,13 +368,7 @@ (define-syntax-rule (with-repository directory repository exp ...)
 
 (define (report-git-error error)
   "Report the given Guile-Git error."
-  ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
-  ;; errors would be represented by integers.
-  (match error
-    ((? integer? error)                           ;old Guile-Git
-     (leave (G_ "Git error ~a~%") error))
-    ((? git-error? error)                         ;new Guile-Git
-     (leave (G_ "Git error: ~a~%") (git-error-message error)))))
+  (leave (G_ "Git error: ~a~%") (git-error-message error)))
 
 (define-syntax-rule (with-git-error-handling body ...)
   (catch 'git-error
@@ -769,60 +757,30 @@ (define* (commit-difference new old #:optional (excluded '()))
                  (cons head result)
                  (set-insert head visited)))))))
 
-(define commit-relation
-  (if (resolve-module '(git graph) #:ensure #f)   ;Guile-Git >= 0.10.0
-      (lambda (old new)
-        "Return a symbol denoting the relation between OLD and NEW, two commit
+(define (commit-relation old new)
+  "Return a symbol denoting the relation between OLD and NEW, two commit
 objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or
 'unrelated, or 'self (OLD and NEW are the same commit)."
-        (let ((repository (commit-owner old))
-              (old (commit-id old))
-              (new (commit-id new)))
-          (cond ((graph-descendant? repository new old)
-                 'ancestor)
-                ((oid=? old new)
-                 'self)
-                ((graph-descendant? repository old new)
-                 'descendant)
-                (else 'unrelated))))
-      (lambda (old new)            ;remove when Guile-Git 0.10.0 is widespread
-        (if (eq? old new)
-            'self
-            (let ((newest (commit-closure new)))
-              (if (set-contains? newest old)
-                  'ancestor
-                  (let* ((seen   (list->setq (commit-parents new)))
-                         (oldest (commit-closure old seen)))
-                    (if (set-contains? oldest new)
-                        'descendant
-                        'unrelated))))))))
+  (let ((repository (commit-owner old))
+        (old (commit-id old))
+        (new (commit-id new)))
+    (cond ((graph-descendant? repository new old)
+           'ancestor)
+          ((oid=? old new)
+           'self)
+          ((graph-descendant? repository old new)
+           'descendant)
+          (else 'unrelated))))
 
-(define commit-descendant?
-  (if (resolve-module '(git graph) #:ensure #f)   ;Guile-Git >= 0.10.0
-      (lambda (new old)
-        "Return true if NEW is the descendant of one of OLD, a list of
-commits."
-        (let ((repository (commit-owner new))
-              (new (commit-id new)))
-          (any (lambda (old)
-                 (let ((old (commit-id old)))
-                   (or (graph-descendant? repository new old)
-                       (oid=? old new))))
-               old)))
-      (lambda (new old)            ;remove when Guile-Git 0.10.0 is widespread
-        (let ((old (list->setq old)))
-          (let loop ((commits (list new))
-                     (visited (setq)))
-            (match commits
-              (()
-               #f)
-              (_
-               ;; Perform a breadth-first search as this is likely going to
-               ;; terminate more quickly than a depth-first search.
-               (let ((commits (remove (cut set-contains? visited <>) commits)))
-                 (or (any (cut set-contains? old <>) commits)
-                     (loop (append-map commit-parents commits)
-                           (fold set-insert visited commits)))))))))))
+(define (commit-descendant? new old)
+  "Return true if NEW is the descendant of one of OLD, a list of commits."
+  (let ((repository (commit-owner new))
+        (new (commit-id new)))
+    (any (lambda (old)
+           (let ((old (commit-id old)))
+             (or (graph-descendant? repository new old)
+                 (oid=? old new))))
+         old)))
 
 
 ;;
-- 
2.49.0

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.