New vc-async-checkin user option

* lisp/vc/vc.el (vc-async-checkin): New option.
(vc-checkin): Don't use with-vc-properties on or display
messages around asynchronous checkins.
* lisp/vc/vc-git.el (vc-git-checkin):
* lisp/vc/vc-hg.el (vc-hg-checkin, vc-hg-checkin-patch): Perform
an async checkin operation when vc-async-checkin is non-nil.
* doc/emacs/vc1-xtra.texi (General VC Options):
* etc/NEWS: Document the new option.

* lisp/vc/vc-dispatcher.el (vc-wait-for-process-before-save):
New function.
(vc-set-async-update): If the current buffer visits a file, call
vc-refresh-state.
* lisp/vc/vc-hg.el (vc-wait-for-process-before-save): Autoload.
(vc-hg--async-command, vc-hg--async-buffer, vc-hg--command-1):
New utilities, partially factored out of vc-hg-command.
(vc-hg-merge-branch): Use vc-hg--async-command, thereby newly
respecting vc-hg-global-switches.

6 files changed, 219 insertions, 84 deletions

diff --git a/doc/emacs/vc1-xtra.texi b/doc/emacs/vc1-xtra.texi
index 5c448e741f2..b4e1e82dcb9 100644
--- a/doc/emacs/vc1-xtra.texi
+++ b/doc/emacs/vc1-xtra.texi
@@ -380,6 +380,25 @@ appropriate version control system.  If @code{vc-command-messages} is
 non-@code{nil}, VC displays messages to indicate which shell commands
 it runs, and additional messages when the commands finish.
 
+@vindex vc-async-checkin
+  Normally checkin operations are done synchronously; that is, Emacs
+waits until the checkin has completed before doing anything else.  This
+can be inconvenient for repositories in which the checkin operation is
+slow, such as Git repositories where you check in changes to very large
+files, or Mercurial repositories with a very large number of files.
+
+  For those backends which support it, setting @code{vc-async-checkin}
+to non-nil switches to doing checkin operations asynchronously.  This is
+particularly useful as a directory local variable in repositories where
+checkin operations are slow
+(@pxref{Directory Local Variables,,,elisp,GNU Emacs Lisp Reference Manual}).
+
+  While an asynchronous checkin operation is in progress, if you use
+@kbd{C-x C-s} to save a buffer visiting any file within the current VC
+tree, then the operation reverts to a synchronous checkin and Emacs
+waits for it to complete before saving the buffer.  This is to avoid
+nondeterminism regarding exactly what changes get checked in.
+
 @node RCS and SCCS
 @subsubsection Options for RCS and SCCS
 
diff --git a/etc/NEWS b/etc/NEWS
index d1b0189da0c..5c2a004164c 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1752,6 +1752,10 @@ were added, removed or edited, Emacs would refuse to proceed.
 Now Emacs prompts to first register the unregistered files, so that all
 files in the fileset are in a compatible state for a checkin.
 
++++
+*** New user option 'vc-async-checkin' to enable async checkin operations.
+Currently only supported by the Git and Mercurial backends.
+
 ---
 *** New 'log-edit-hook' option to display diff of changes to commit.
 You can customize 'log-edit-hook' to include its new
diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el
index a454a0bfc78..27837ddace1 100644
--- a/lisp/vc/vc-dispatcher.el
+++ b/lisp/vc/vc-dispatcher.el
@@ -294,6 +294,41 @@ Only run CODE if the SUCCESS process has a zero exit code."
   (declare (indent 0) (debug (def-body)))
   `(vc-exec-after (lambda () ,@body)))
 
+(defun vc-wait-for-process-before-save (proc message)
+  "Make Emacs wait for PROC before saving buffers under current VC tree.
+If waiting for PROC takes more than a second, display MESSAGE.
+
+This is used to implement `vc-async-checkin'.  It effectively switches
+to a synchronous checkin in the case that the user asks to save a buffer
+under the tree in which the checkin operation is running.
+
+The hook installed by this function will make Emacs unconditionally wait
+for PROC if the root of the current VC tree couldn't be determined, and
+whenever writing out a buffer which doesn't have any `buffer-file-name'
+yet."
+  (letrec ((root (vc-root-dir))
+           (hook
+            (lambda ()
+              (cond ((not (process-live-p proc))
+                     (remove-hook 'before-save-hook hook))
+                    ((or (and buffer-file-name
+                              (or (not root)
+                                  (file-in-directory-p buffer-file-name
+                                                       root)))
+                         ;; No known buffer file name but we are saving:
+                         ;; perhaps writing out a `special-mode' buffer.
+                         ;; A `before-save-hook' cannot know whether or
+                         ;; not it'll be written out under ROOT.
+                         ;; Err on the side of switching to synchronous.
+                         (not buffer-file-name))
+                     (with-delayed-message (1 message)
+                       (while (process-live-p proc)
+                         (when (input-pending-p)
+                           (discard-input))
+                         (sit-for 0.05)))
+                     (remove-hook 'before-save-hook hook))))))
+    (add-hook 'before-save-hook hook)))
+
 (defvar vc-filter-command-function #'list
   "Function called to transform VC commands before execution.
 The function is called inside the buffer in which the command
@@ -525,23 +560,24 @@ asynchronous VC command has completed.  PROCESS-BUFFER is the
 buffer for the asynchronous VC process.
 
 If the current buffer is a VC Dir buffer, call `vc-dir-refresh'.
-If the current buffer is a Dired buffer, revert it."
+If the current buffer is a Dired buffer, revert it.
+If the current buffer visits a file, call `vc-refresh-state'."
   (let* ((buf (current-buffer))
          (tick (buffer-modified-tick buf)))
-    (cond
-     ((derived-mode-p 'vc-dir-mode)
-      (with-current-buffer process-buffer
-        (vc-run-delayed
-         (if (buffer-live-p buf)
-             (with-current-buffer buf
-               (vc-dir-refresh))))))
-     ((derived-mode-p 'dired-mode)
-      (with-current-buffer process-buffer
-        (vc-run-delayed
-         (and (buffer-live-p buf)
-              (= (buffer-modified-tick buf) tick)
-              (with-current-buffer buf
-                (revert-buffer)))))))))
+    (cl-macrolet ((run-delayed (&rest body)
+                    `(with-current-buffer process-buffer
+                       (vc-run-delayed
+                         (when (buffer-live-p buf)
+                           (with-current-buffer buf
+                             ,@body))))))
+      (cond ((derived-mode-p 'vc-dir-mode)
+             (run-delayed (vc-dir-refresh)))
+            ((derived-mode-p 'dired-mode)
+             (run-delayed
+              (when (= (buffer-modified-tick buf) tick)
+                (revert-buffer))))
+            (buffer-file-name
+             (run-delayed (vc-refresh-state)))))))
 
 ;; These functions are used to ensure that the view the user sees is up to date
 ;; even if the dispatcher client mode has messed with file contents (as in,
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 4acacaff203..53dedb05320 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -1209,32 +1209,49 @@ It is based on `log-edit-mode', and has Git-specific extensions."
               (vc-git-command nil 0 nil "apply" "--cached" patch-file)
             (delete-file patch-file))))
       (when to-stash (vc-git--stash-staged-changes to-stash)))
-    ;; When operating on the whole tree, better pass "-a" than ".",
-    ;; since "."  fails when we're committing a merge.
-    (apply #'vc-git-command nil 0
-           (if (and only (not vc-git-patch-string)) files)
-           (nconc (if msg-file (list "commit" "-F"
-                                     (file-local-name msg-file))
-                    (list "commit" "-m"))
-                  (let ((args
-                         (vc-git--log-edit-extract-headers comment)))
-                    (when msg-file
-                      (let ((coding-system-for-write
-                             (or pcsw vc-git-commits-coding-system)))
-                        (write-region (car args) nil msg-file))
-                      (setq args (cdr args)))
-                    args)
-                  (unless vc-git-patch-string
-                    (if only (list "--only" "--") '("-a")))))
-    (if (and msg-file (file-exists-p msg-file)) (delete-file msg-file))
-    (when to-stash
-      (let ((cached (make-nearby-temp-file "git-cached")))
-        (unwind-protect
-            (progn (with-temp-file cached
-                     (vc-git-command t 0 nil "stash" "show" "-p"))
-                   (vc-git-command nil 0 nil "apply" "--cached" cached))
-          (delete-file cached))
-        (vc-git-command nil 0 nil "stash" "drop")))))
+    (let ((files (and only (not vc-git-patch-string) files))
+          (args (vc-git--log-edit-extract-headers comment))
+          (buffer (format "*vc-git : %s*" (expand-file-name root)))
+          (post
+           (lambda ()
+             (when (and msg-file (file-exists-p msg-file))
+               (delete-file msg-file))
+             (when to-stash
+               (let ((cached (make-nearby-temp-file "git-cached")))
+                 (unwind-protect
+                     (progn
+                       (with-temp-file cached
+                         (vc-git-command t 0 nil "stash" "show" "-p"))
+                       (vc-git-command nil 0 "apply" "--cached" cached))
+                   (delete-file cached))
+                 (vc-git-command nil 0 nil "stash" "drop"))))))
+      (when msg-file
+        (let ((coding-system-for-write
+               (or pcsw vc-git-commits-coding-system)))
+          (write-region (car args) nil msg-file))
+        (setq args (cdr args)))
+      (setq args (nconc (if msg-file
+                            (list "commit" "-F"
+                                  (file-local-name msg-file))
+                          (list "commit" "-m"))
+                        args
+                        ;; When operating on the whole tree, better pass
+                        ;; "-a" than ".", since "."  fails when we're
+                        ;; committing a merge.
+                        (and (not vc-git-patch-string)
+                             (if only (list "--only" "--") '("-a")))))
+      (if vc-async-checkin
+          (progn (vc-wait-for-process-before-save
+                  (apply #'vc-do-async-command buffer root
+                         vc-git-program (nconc args files))
+                  "Finishing checking in files...")
+                 (with-current-buffer buffer
+                   (vc-run-delayed
+                     (vc-compilation-mode 'git)
+                     (funcall post)))
+                 (vc-set-async-update buffer))
+        (apply #'vc-git-command nil 0 files args)
+        (funcall post)))))
 
 (defun vc-git--stash-staged-changes (files)
   "Stash only the staged changes to FILES."
diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el
index a18c463c848..5c0758b93b2 100644
--- a/lisp/vc/vc-hg.el
+++ b/lisp/vc/vc-hg.el
@@ -1181,25 +1181,42 @@ If toggling on, also insert its message into the buffer."
   "Major mode for editing Hg log messages.
 It is based on `log-edit-mode', and has Hg-specific extensions.")
 
+(autoload 'vc-wait-for-process-before-save "vc-dispatcher")
+
 (defun vc-hg-checkin (files comment &optional _rev)
   "Hg-specific version of `vc-backend-checkin'.
 REV is ignored."
-  (apply #'vc-hg-command nil 0 files
-         (nconc (list "commit" "-m")
-                (vc-hg--extract-headers comment))))
+  (let ((args (nconc (list "commit" "-m")
+                     (vc-hg--extract-headers comment))))
+    (if vc-async-checkin
+        (let ((buffer (vc-hg--async-buffer)))
+          (vc-wait-for-process-before-save
+           (apply #'vc-hg--async-command buffer (nconc args files))
+           "Finishing checking in files...")
+          (with-current-buffer buffer
+            (vc-run-delayed
+              (vc-compilation-mode 'hg)))
+          (vc-set-async-update buffer))
+      (apply #'vc-hg-command nil 0 files args))))
 
 (defun vc-hg-checkin-patch (patch-string comment)
   (let ((patch-file (make-temp-file "hg-patch")))
     (write-region patch-string nil patch-file)
     (unwind-protect
-        (progn
+        (let ((args (list "update"
+                          "--merge" "--tool" "internal:local"
+                          "tip")))
           (apply #'vc-hg-command nil 0 nil
                  (nconc (list "import" "--bypass" patch-file "-m")
                         (vc-hg--extract-headers comment)))
-          (vc-hg-command nil 0 nil
-                         "update"
-                         "--merge" "--tool" "internal:local"
-                         "tip"))
+          (if vc-async-checkin
+              (let ((buffer (vc-hg--async-buffer)))
+                (apply #'vc-hg--async-command buffer args)
+                (with-current-buffer buffer
+                  (vc-run-delayed
+                    (vc-compilation-mode 'hg)))
+                (vc-set-async-update buffer))
+            (apply #'vc-hg-command nil 0 nil args)))
       (delete-file patch-file))))
 
 (defun vc-hg--extract-headers (comment)
@@ -1543,15 +1560,14 @@ call \"hg push -r REVS\" to push the specified revisions REVS."
 (defun vc-hg-merge-branch ()
   "Prompt for revision and merge it into working directory.
 This runs the command \"hg merge\"."
-  (let* ((root (vc-hg-root default-directory))
-         (buffer (format "*vc-hg : %s*" (expand-file-name root)))
-         ;; Disable pager.
-         (process-environment (cons "HGPLAIN=1" process-environment))
-         (branch (vc-read-revision "Revision to merge: ")))
-    (apply #'vc-do-async-command buffer root vc-hg-program
+  (let ((buffer (vc-hg--async-buffer))
+        (branch (vc-read-revision "Revision to merge: ")))
+    (apply #'vc-hg--async-command buffer
            (append '("--config" "ui.report_untrusted=0" "merge")
-                   (unless (string= branch "") (list branch))))
-    (with-current-buffer buffer (vc-run-delayed (vc-compilation-mode 'hg)))
+                   (and (not (string-empty-p branch)) (list branch))))
+    (with-current-buffer buffer
+      (vc-run-delayed
+        (vc-compilation-mode 'hg)))
     (vc-set-async-update buffer)))
 
 (defun vc-hg-prepare-patch (rev)
@@ -1571,15 +1587,33 @@ This runs the command \"hg merge\"."
   "A wrapper around `vc-do-command' for use in vc-hg.el.
 This function differs from `vc-do-command' in that it invokes
 `vc-hg-program', and passes `vc-hg-global-switches' to it before FLAGS."
+  (vc-hg--command-1 #'vc-do-command
+                    (list (or buffer "*vc*")
+                          okstatus vc-hg-program file-or-list)
+                    flags))
+
+(defun vc-hg--async-command (buffer &rest args)
+  "Wrapper around `vc-do-async-command' like `vc-hg-command'."
+  (vc-hg--command-1 #'vc-do-async-command
+                    (list buffer (vc-hg-root default-directory)
+                          vc-hg-program)
+                    args))
+
+(defun vc-hg--async-buffer ()
+  "Buffer passed to `vc-do-async-command' by vg-hg.el commands.
+Intended for use via the `vc-hg--async-command' wrapper."
+  (format "*vc-hg : %s*"
+          (expand-file-name (vc-hg-root default-directory))))
+
+(defun vc-hg--command-1 (fun args flags)
   ;; Disable pager.
-  (let ((process-environment (cons "HGPLAIN=1" process-environment))
-        (flags (append '("--config" "ui.report_untrusted=0") flags)))
-    (apply #'vc-do-command (or buffer "*vc*")
-           okstatus vc-hg-program file-or-list
-           (if (stringp vc-hg-global-switches)
-               (cons vc-hg-global-switches flags)
-             (append vc-hg-global-switches
-                     flags)))))
+  (let ((process-environment (cons "HGPLAIN=1" process-environment)))
+    (apply fun (append args
+                       '("--config" "ui.report_untrusted=0")
+                       (if (stringp vc-hg-global-switches)
+                           (cons vc-hg-global-switches flags)
+                         (append vc-hg-global-switches
+                                 flags))))))
 
 (defun vc-hg-root (file)
   (vc-find-root file ".hg"))
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index f58290ccd69..dcb32e9da67 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -1002,6 +1002,24 @@ the URL-REGEXP of the association."
                 :value-type ,vc-cloneable-backends-custom-type)
   :version "31.1")
 
+(defcustom vc-async-checkin nil
+  "If non-nil, checkin operations should be done asynchronously.
+
+This is useful to set as a directory local variable in repositories
+where the VCS in use performs checkin operations slowly.
+For example, Git is slow when committing changes to very large files,
+and Mercurial can be slow when there is a very large number of files.
+
+While an asynchronous checkin operation is in progress, Emacs installs a
+`before-save-hook' to switch back to a synchronous checkin if you ask to
+save buffers under the current VC tree.  This is to avoid nondeterminism
+regarding exactly what changes get checked in.
+
+Not supported by all backends."
+  :type 'boolean
+  :safe #'booleanp
+  :version "31.1")
+
 
 ;; File property caching
 
@@ -1857,26 +1875,33 @@ Runs the normal hooks `vc-before-checkin-hook' and `vc-checkin-hook'."
    (lambda ()
      (vc-call-backend backend 'log-edit-mode))
    (lambda (files comment)
-     (message "Checking in %s..." (vc-delistify files))
      ;; "This log message intentionally left almost blank".
-     ;; RCS 5.7 gripes about white-space-only comments too.
-     (or (and comment (string-match "[^\t\n ]" comment))
-         (setq comment "*** empty log message ***"))
-     (with-vc-properties
-         files
-       ;; We used to change buffers to get local value of
-       ;; vc-checkin-switches, but 'the' local buffer is
-       ;; not a well-defined concept for filesets.
-       (progn
-         (if patch-string
-             (vc-call-backend backend 'checkin-patch patch-string comment)
-           (vc-call-backend backend 'checkin files comment rev))
-         (mapc #'vc-delete-automatic-version-backups files))
-       `((vc-state . up-to-date)
-         (vc-checkout-time . ,(file-attribute-modification-time
-                               (file-attributes file)))
-         (vc-working-revision . nil)))
-     (message "Checking in %s...done" (vc-delistify files)))
+     ;; RCS 5.7 gripes about whitespace-only comments too.
+     (unless (and comment (string-match "[^\t\n ]" comment))
+       (setq comment "*** empty log message ***"))
+     (cl-labels ((do-it ()
+                   ;; We used to change buffers to get local value of
+                   ;; `vc-checkin-switches', but the (singular) local
+                   ;; buffer is not well defined for filesets.
+                   (if patch-string
+                       (vc-call-backend backend 'checkin-patch
+                                        patch-string comment)
+                     (vc-call-backend backend 'checkin
+                                      files comment rev))
+                   (mapc #'vc-delete-automatic-version-backups files)))
+       (if (and vc-async-checkin
+                ;; Backends which support `vc-async-checkin'.
+                (memq backend '(Git Hg)))
+           ;; Rely on `vc-set-async-update' to update properties.
+           (do-it)
+         (message "Checking in %s..." (vc-delistify files))
+         (with-vc-properties files (do-it)
+                             `((vc-state . up-to-date)
+                               (vc-checkout-time
+                                . ,(file-attribute-modification-time
+                                    (file-attributes file)))
+                               (vc-working-revision . nil)))
+         (message "Checking in %s...done" (vc-delistify files)))))
    'vc-checkin-hook
    backend
    patch-string))