Attempt to speed up completion with lazy highlightingscratch/icomplete-lazy-highlight-attempt

After enabling fido-mode and replacing the while-no-input in
icomplete.el with benchmark-progn, evaluated this form:

    (completing-read "bla" obarray)

many times in my lightly loaded Emacs session which has:

   (length (all-completions "" obarray)) = 46762 symbols

On every evaluation, a measurement of the time it takes to generate
completions is taken and printed to *Messages*.

These are the results.  They are decent but not spectacular.  Can't
seem to reproduce the spectacular results of

   https://debbugs.gnu.org/cgi/bugreport.cgi?bug=48841#83

WITH completion-pcm-lazy-hilit = nil

Elapsed time: 0.830821s (0.652251s in 3 GCs)
Elapsed time: 0.828888s (0.652339s in 3 GCs)
Elapsed time: 0.840977s (0.665493s in 3 GCs)
Elapsed time: 0.838810s (0.660840s in 3 GCs)
Elapsed time: 0.844244s (0.666753s in 3 GCs)
Elapsed time: 0.837558s (0.649146s in 3 GCs)
Elapsed time: 0.860952s (0.680139s in 3 GCs)
Elapsed time: 0.835933s (0.657953s in 3 GCs)
Elapsed time: 0.833641s (0.660285s in 3 GCs)
Elapsed time: 0.612756s (0.441977s in 2 GCs)

Average: 0.816s

WITH completion-pcm-lazy-hilit = t

Elapsed time: 0.618526s (0.446630s in 9 GCs)
Elapsed time: 0.519817s (0.342596s in 5 GCs)
Elapsed time: 0.580578s (0.404180s in 5 GCs)
Elapsed time: 0.535658s (0.362378s in 4 GCs)
Elapsed time: 0.598076s (0.424361s in 3 GCs)
Elapsed time: 0.613332s (0.447435s in 3 GCs)
Elapsed time: 0.510226s (0.338068s in 2 GCs)
Elapsed time: 0.706932s (0.534357s in 3 GCs)
Elapsed time: 0.565533s (0.392478s in 2 GCs)
Elapsed time: 0.566993s (0.398196s in 2 GCs)

Average: 0.582s

* lisp/icomplete.el (icomplete-exhibit)
(icomplete--render-vertical)
(icomplete--render-vertical):
(icomplete-completions): Use completion-pcm-lazy-hilit.

* lisp/minibuffer.el (completion-pcm-lazy-hilit): New function and
flag.
(completion-pcm--hilit-commonality)  Use it.

2 files changed, 43 insertions, 13 deletions

diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index adea1505fd2..c6ce3efb6d9 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -683,6 +683,7 @@ See `icomplete-mode' and `minibuffer-setup-hook'."
                  ;; deterministic but `C-x C-f M-DEL M-DEL ...'
                  ;; seems to trigger it fairly often!
                  (while-no-input-ignore-events '(selection-request))
+                 (completion-pcm-lazy-hilit t)
                  (text (while-no-input
                          (icomplete-completions
                           field-string
@@ -797,7 +798,9 @@ Return a list of (COMP PREFIX SUFFIX)."
                (cl-return-from icomplete--render-vertical
                  (concat
                   " \n"
-                  (mapconcat #'identity torender icomplete-separator))))
+                  (mapconcat #'identity
+                             (mapcar #'completion-pcm-lazy-hilit torender)
+                             icomplete-separator))))
    for (comp prefix) in triplets
    maximizing (length prefix) into max-prefix-len
    maximizing (length comp) into max-comp-len
@@ -809,7 +812,7 @@ Return a list of (COMP PREFIX SUFFIX)."
     (cl-loop for (comp prefix suffix) in triplets
              concat prefix
              concat (make-string (- max-prefix-len (length prefix)) ? )
-             concat comp
+             concat (completion-pcm-lazy-hilit comp)
              concat (make-string (- max-comp-len (length comp)) ? )
              concat suffix
              concat icomplete-separator))))
@@ -959,7 +962,8 @@ matches exist."
                   (if (< prospects-len prospects-max)
                       (push comp prospects)
                     (setq limit t)))
-                (setq prospects (nreverse prospects))
+                (setq prospects
+                      (nreverse (mapcar #'completion-pcm-lazy-hilit prospects)))
                 ;; Decorate first of the prospects.
                 (when prospects
                   (let ((first (copy-sequence (pop prospects))))
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 1e8e9fc6246..21d194b7bdc 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -3512,6 +3512,24 @@ one large \"hole\" and a clumped-together \"oo\" match) higher
 than the latter (which has two \"holes\" and three
 one-letter-long matches).")
 
+(defvar completion-pcm-lazy-hilit nil
+  "If non-nil, defer highting of matching completions to frontend.
+The completion frontend may bind this variable around
+completion-generating calls and then be responsible for calling
+the function `completion-pcm-lazy-hilit' on each completion that
+it intends to actually display to the user.  This enables the
+`completion-pcm' backend to skip expensive string copies.")
+
+(defun completion-pcm-lazy-hilit (str)
+  "Hilit STR completion produced under `completion-pcm-lazy-hilit'.
+Return a copy of STR that can be display to the user.  If STR,
+was not produced under `completion-pcm-lazy-hilit', it is assumed
+to be hilighted and unchanged."
+  (let ((str (copy-sequence str)))
+    (dolist (v (get-text-property 0 'completion-pcm-lazy-hilit str))
+      (add-face-text-property (car v) (cadr v) (caddr v) nil str))
+    str))
+
 (defun completion-pcm--hilit-commonality (pattern completions)
   "Show where and how well PATTERN matches COMPLETIONS.
 PATTERN, a list of symbols and strings as seen
@@ -3527,8 +3545,10 @@ between 0 and 1, and with faces `completions-common-part',
            last-md)
       (mapcar
        (lambda (str)
-         ;; Don't modify the string itself.
-         (setq str (copy-sequence str))
+         (unless completion-pcm-lazy-hilit
+           ;; Don't modify the string itself.
+           (setq str (copy-sequence str))
+           (put-text-property 0 1 'completion-pcm-lazy-hilit nil str))
          (unless (string-match re str)
            (error "Internal error: %s does not match %s" re str))
          (let* ((pos (if point-idx (match-beginning point-idx) (match-end 0)))
@@ -3573,12 +3593,22 @@ between 0 and 1, and with faces `completions-common-part',
                 (score-numerator 0)
                 (score-denominator 0)
                 (last-b 0)
+                (hilit-maybe
+                 (lambda (from to face)
+                   (cond ((< (length str) to) nil)
+                         (completion-pcm-lazy-hilit
+                          (let ((lazies (get-text-property
+                                         0 'completion-pcm-lazy-hilit str)))
+                            (put-text-property 0 1 'completion-pcm-lazy-hilit
+                                               (cons (list from to face)
+                                                     lazies)
+                                               str)))
+                         (t
+                          (add-face-text-property from to face nil str)))))
                 (update-score-and-face
                  (lambda (a b)
                    "Update score and face given match range (A B)."
-                   (add-face-text-property a b
-                                           'completions-common-part
-                                           nil str)
+                   (funcall hilit-maybe a b 'completions-common-part)
                    (setq
                     score-numerator   (+ score-numerator (- b a)))
                    (unless (or (= a last-b)
@@ -3601,11 +3631,7 @@ between 0 and 1, and with faces `completions-common-part',
            ;; for that extra bit of match (bug#42149).
            (unless (= from match-end)
              (funcall update-score-and-face from match-end))
-           (if (> (length str) pos)
-               (add-face-text-property
-                pos (1+ pos)
-                'completions-first-difference
-                nil str))
+           (funcall hilit-maybe pos (1+ pos) 'completions-first-difference)
            (unless (zerop (length str))
              (put-text-property
               0 1 'completion-score