[bug#66138] [PATCH 1/4] etc/committer: Do not recompute changes when there are no definitions.

[bug#66138] [PATCH 1/4] etc/committer: Do not recompute changes when there are no definitions.

[Ricardo Wurmus]

* etc/committer.scm.in (main): Reuse previously computed changes if there are
no changes to the number of definitions.
---
 etc/committer.scm.in | 75 +++++++++++++++++++++++---------------------
 1 file changed, 40 insertions(+), 35 deletions(-)

diff --git a/etc/committer.scm.in b/etc/committer.scm.in
index e7f1ca8c45..cc3b572710 100755
--- a/etc/committer.scm.in
+++ b/etc/committer.scm.in
@@ -388,41 +388,46 @@ (define (main . args)
               (unless (eqv? 0 (status:exit-val (close-pipe port)))
                 (error "Cannot commit"))))
           (usleep %delay))
-        definitions))
+        definitions)
 
-     ;; Changes.
-     (for-each
-      (match-lambda
-        ((new old . hunks)
-         (for-each (lambda (hunk)
-                     (let ((port (open-pipe* OPEN_WRITE
-                                             "git" "apply"
-                                             "--cached"
-                                             "--unidiff-zero")))
-                       (hunk->patch hunk port)
-                       (unless (eqv? 0 (status:exit-val (close-pipe port)))
-                         (error "Cannot apply")))
-                     (usleep %delay))
-                   hunks)
-         (define copyright-line
-           (any (lambda (line) (and=> (string-prefix? "+;;; Copyright ©" line)
-                                      (const line)))
-                (hunk-diff-lines (first hunks))))
-         (cond
-          (copyright-line
-           (add-copyright-line copyright-line))
-          (else
-           (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
-             (change-commit-message* (hunk-file-name (first hunks))
-                                     old new)
-             (change-commit-message* (hunk-file-name (first hunks))
-                                     old new
-                                     port)
-             (usleep %delay)
-             (unless (eqv? 0 (status:exit-val (close-pipe port)))
-               (error "Cannot commit")))))))
-      ;; XXX: we recompute the hunks here because previous
-      ;; insertions lead to offsets.
-      (new+old+hunks (diff-info))))))
+       ;; Changes.
+       (for-each
+        (match-lambda
+          ((new old . hunks)
+           (for-each (lambda (hunk)
+                       (let ((port (open-pipe* OPEN_WRITE
+                                               "git" "apply"
+                                               "--cached"
+                                               "--unidiff-zero")))
+                         (hunk->patch hunk port)
+                         (unless (eqv? 0 (status:exit-val (close-pipe port)))
+                           (error "Cannot apply")))
+                       (usleep %delay))
+                     hunks)
+           (define copyright-line
+             (any (lambda (line) (and=> (string-prefix? "+;;; Copyright ©" line)
+                                   (const line)))
+                  (hunk-diff-lines (first hunks))))
+           (cond
+            (copyright-line
+             (add-copyright-line copyright-line))
+            (else
+             (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-")))
+               (change-commit-message* (hunk-file-name (first hunks))
+                                       old new)
+               (change-commit-message* (hunk-file-name (first hunks))
+                                       old new
+                                       port)
+               (usleep %delay)
+               (unless (eqv? 0 (status:exit-val (close-pipe port)))
+                 (error "Cannot commit")))))))
+        (new+old+hunks (match definitions
+                         ('() changes) ;reuse
+                         (_
+                          ;; XXX: we recompute the hunks here because previous
+                          ;; insertions lead to offsets.
+                          (let-values (((definitions changes)
+                                        (partition hunk-type (diff-info))))
+                            changes)))))))))
 
 (apply main (cdr (command-line)))

base-commit: 4bdb8bd2674c2b630626be43a5cd3c2b65401b52
-- 
2.41.0

[bug#66138] [PATCH 2/4] etc/committer: Do not record positions when reading from git files.

[Ricardo Wurmus]

This gives us a slight performance boost.

* etc/committer.scm.in (main): Disable recording of positions.
---
 etc/committer.scm.in | 1 +
 1 file changed, 1 insertion(+)

diff --git a/etc/committer.scm.in b/etc/committer.scm.in
index cc3b572710..45efb68be2 100755
--- a/etc/committer.scm.in
+++ b/etc/committer.scm.in
@@ -358,6 +358,7 @@ (define (main . args)
         (_
          (apply change-commit-message file-name old new rest)))))
 
+  (read-disable 'positions)
   (match (diff-info)
     (()
      (display "Nothing to be done.\n" (current-error-port)))
-- 
2.41.0

[bug#66138] [PATCH 3/4] etc/committer: Avoid reading original files more than once.

[Ricardo Wurmus]

* etc/committer.scm.in (%original-file-cache): New variable.
(read-original-file): New procedure.
(read-original-file*): New procedure.
(old-sexp): Use it.
---
 etc/committer.scm.in | 35 ++++++++++++++++++++++++-----------
 1 file changed, 24 insertions(+), 11 deletions(-)

diff --git a/etc/committer.scm.in b/etc/committer.scm.in
index 45efb68be2..eb8865513e 100755
--- a/etc/committer.scm.in
+++ b/etc/committer.scm.in
@@ -196,21 +196,34 @@ (define (lines-to-first-change hunk)
                 (string-ref line 0)))
              (hunk-diff-lines hunk))))
 
-(define (old-sexp hunk)
-  "Using the diff information in HUNK return the unmodified S-expression
-corresponding to the top-level definition containing the staged changes."
-  ;; TODO: We can't seek with a pipe port...
+(define %original-file-cache
+  (make-hash-table))
+
+(define (read-original-file file-name)
+  "Return the contents of FILE-NAME prior to any changes."
   (let* ((port (open-pipe* OPEN_READ
                            "git" "cat-file" "-p" (string-append
-                                                  "HEAD:"
-                                                  (hunk-file-name hunk))))
+                                                  "HEAD:" file-name)))
          (contents (get-string-all port)))
     (close-pipe port)
-    (call-with-input-string contents
-      (lambda (port)
-        (surrounding-sexp port
-                          (+ (lines-to-first-change hunk)
-                             (hunk-old-line-number hunk)))))))
+    contents))
+
+(define (read-original-file* file-name)
+  "Caching variant of READ-ORIGINAL-FILE."
+  (or (hashv-ref %original-file-cache file-name)
+      (let ((value (read-original-file file-name)))
+        (hashv-set! %original-file-cache file-name value)
+        value)))
+
+(define (old-sexp hunk)
+  "Using the diff information in HUNK return the unmodified S-expression
+corresponding to the top-level definition containing the staged changes."
+  ;; TODO: We can't seek with a pipe port...
+  (call-with-input-string (read-original-file* (hunk-file-name hunk))
+    (lambda (port)
+      (surrounding-sexp port
+                        (+ (lines-to-first-change hunk)
+                           (hunk-old-line-number hunk))))))
 
 (define (new-sexp hunk)
   "Using the diff information in HUNK return the modified S-expression
-- 
2.41.0

[bug#66138] [PATCH 4/4] etc/committer: Speed up surrounding-sexp.

[Ricardo Wurmus]

The old surrounding-sexp procedure would read all S-expressions from the
beginning of the file up to the given line number and then return the last
encountered S-expression.  This is quite wasteful.  Instead we can record all
lines that begin with an S-expression and jump straight to the offset closest
to the desired line number to read the S-expression there.

* etc/committer.scm.in (lines+offsets-with-opening-parens): New procedure.
(surrounding-sexp): Use it.
---
 etc/committer.scm.in | 46 ++++++++++++++++++++++++++++++--------------
 1 file changed, 32 insertions(+), 14 deletions(-)

diff --git a/etc/committer.scm.in b/etc/committer.scm.in
index eb8865513e..0705b29fd9 100755
--- a/etc/committer.scm.in
+++ b/etc/committer.scm.in
@@ -85,21 +85,39 @@ (define (read-excursion port)
     (seek port start SEEK_SET)
     result))
 
-(define (surrounding-sexp port line-no)
+(define (lines+offsets-with-opening-parens port)
+  "Record all line numbers (and their offsets) where an opening parenthesis is
+found in column 0.  The resulting list is in reverse order."
+  (let loop ((acc '())
+             (number 0))
+    (let ((line (read-line port)))
+      (cond
+       ((eof-object? line) acc)
+       ((string-prefix? "(" line)
+        (loop (cons (cons number                      ;line number
+                          (- (ftell port)
+                             (string-length line) 1)) ;offset
+                    acc)
+              (1+ number)))
+       (else (loop acc (1+ number)))))))
+
+(define (surrounding-sexp port target-line-no)
   "Return the top-level S-expression surrounding the change at line number
-LINE-NO in PORT."
-  (let loop ((i (1- line-no))
-             (last-top-level-sexp #f))
-    (if (zero? i)
-        last-top-level-sexp
-        (match (peek-char port)
-          (#\(
-           (let ((sexp (read-excursion port)))
-             (read-line port)
-             (loop (1- i) sexp)))
-          (_
-           (read-line port)
-           (loop (1- i) last-top-level-sexp))))))
+TARGET-LINE-NO in PORT."
+  (let* ((line-numbers+offsets
+          (lines+offsets-with-opening-parens port))
+         (closest-offset
+          (or (and=> (list-index (match-lambda
+                                   ((line-number . offset)
+                                    (< line-number target-line-no)))
+                                 line-numbers+offsets)
+                     (lambda (index)
+                       (match (list-ref line-numbers+offsets index)
+                         ((line-number . offset) offset))))
+              (error "Could not find surrounding S-expression for line"
+                     target-line-no))))
+    (seek port closest-offset SEEK_SET)
+    (read port)))
 
 ;;; Whether the hunk contains a newly added package (definition), a removed
 ;;; package (removal) or something else (#false).
-- 
2.41.0

bug#66138: [PATCH 1/4] etc/committer: Do not recompute changes when there are no definitions.

[Ricardo Wurmus]

I just pushed this series.

-- 
Ricardo