bug#47711: bug#48841: bug#47711: bug#48841: bug#47711: [PATCH VERSION 2] Add new `completion-filter-completions` API and deferred highlighting

[Dmitry Gutov <dmitry@gutov.dev>]

[-- Attachment #1: Type: text/plain, Size: 4181 bytes --]

Hi all!

Time flies, doesn't it?

On 14/08/2021 10:16, Eli Zaretskii wrote:
>>> If one removes these lines, the process becomes much faster, but there is a
>>> problem with highlighting.  My idea is indeed to defer highlighting by not
>>> setting the 'face property directly on that shared string, but some
>>> other property
>>> that is read later from the shared string by compliant frontents.
>>
>> I haven't done any direct benchmarking, but I'm pretty sure that this
>> approach cannot, by definition, be as fast as the non-mutating one.
> 
> Daniel seems to think otherwise, AFAIU.
> 
>> Because you go through the whole list and mutate all of its elements,
>> you have to perform a certain bit of work W x N times, where N is the
>> size of the whole list.
>>
>> Whereas the deferred-mutation approach will only have to do its bit
>> (which is likely more work, like, WWW) only 20 times, or 100 times, or
>> however many completions are displayed. And this is usually negligible.
>>
>> However big the difference is going to be, I can't say in advance, of
>> course, or whether it's going to be shadowed by some other performance
>> costs. But the non-mutating approach should have the best optimization
>> potential when the list is long.
> 
> So I guess the suggestion to have a benchmark is still useful, because
> the estimations of which approach has better performance vary between
> you three.  So maybe producing such benchmarks would be a good step?

To cross this out from my TODO, I spent most of the day rebasing both of 
the proposed patches (one of them longer than the other) -- one from an 
attachment here and another from a commit inside the 
scratch/icomplete-lazy-highlight-attempt-2 branch, porting icomplete to 
Daniel's new completion-filter-completions API (*), and benchmarking.

(*) Included in the attached patch: it needed changing just two lines 
inside icomplete, but also new variable completion-all-sorted-highlight 
and updates to completion--cache-all-sorted-completions and 
completion-all-sorted-completions.

Both rebased patches are attached to this email for your convenience.

AFAICT, the results confirmed my expectations quoted above.

Using Joao's benchmark, with setup:

   (defmacro lotsoffunctions ()
     `(progn
        ,@(cl-loop repeat 150000
                   collect `(defun ,(intern (symbol-name (gensym 
"heyhey"))) () 42))))

   (lotsoffunctions)

I ran the comparisons for empty and non-empty inputs.

With no characters typed:

   (benchmark-run 1
     (let ((completion-styles '(flex))
           (completion-lazy-hilit (cl-gensym)) ; might not be defined
           )
       ;; Uncomment one of the lines below, depending on the patch used.
       ;; (completion-all-completions "" obarray 'fboundp 0 nil)
       ;; (completion-filter-completions "" obarray 'fboundp 0 nil)
       ))

master => 0.066
lazy-hilit => 0.045
filter-and-defer => 0.041 (but more often ~0.110 including GC, somehow)

With one character typed:

   (benchmark-run 1
     (let ((completion-styles '(flex))
           (completion-lazy-hilit (cl-gensym)) ; might not be defined
           )
       ;; Uncomment one of the lines below, depending on the patch used.
       ;; (completion-all-completions "h" obarray 'fboundp 1 nil)
       ;; (completion-filter-completions "h" obarray 'fboundp 1 nil)
       ))

master => 0.824
lazy-hilit => 0.395
filter-and-defer => 0.125 (!)

This more or less translates into the improvement in speed of 
fido-vertical-mode, according to my benchmark-progn call inside 
icomplete-exhibit (included in both attached patches for convenience). 
For non-empty inputs (h or hh or hhe, to match the generated functions), 
filter-and-defer is about 1.5x faster than lazy-hilit, like 0.450ms vs 
0.640ms.

lazy-hilit is slightly faster than filter-and-defer with the empty input 
(like 380ms vs 420ms), and I'm not yet sure why, but it's the scenario 
with 0 highlighting (and so no flex scoring/sorting). Perhaps some 
short-circuiting can be added somewhere to reach parity, or it's the 
cost of extra branching somewhere for backward compatibility (which 
could be removed in the future). Worth additional study.

[-- Attachment #2: 0001-Add-new-completion-filter-completions-API-and-deferr-v3.diff --]
[-- Type: text/x-patch, Size: 54102 bytes --]

diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index e6fdd1f1836..234113e607c 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -754,12 +754,13 @@ icomplete-exhibit
                            (overlay-end rfn-eshadow-overlay)))
           (let* ((field-string (icomplete--field-string))
                  (text (while-no-input
+                         (benchmark-progn
                          (icomplete-completions
                           field-string
                           (icomplete--completion-table)
                           (icomplete--completion-predicate)
                           (if (window-minibuffer-p)
-                              (eq minibuffer--require-match t)))))
+                              (eq minibuffer--require-match t))))))
                  (buffer-undo-list t)
                  deactivate-mark)
             ;; Do nothing if while-no-input was aborted.
@@ -878,7 +879,7 @@ icomplete--render-vertical
   ;; Halfway there...
   (let* ((selected (propertize (car comps) 'icomplete-selected t))
          (chosen (append scroll-above (list selected) scroll-below))
-         (tuples (icomplete--augment md chosen))
+         (tuples (icomplete--augment md (funcall completion-all-sorted-highlight chosen)))
          max-prefix-len max-comp-len lines nsections)
     (add-face-text-property 0 (length selected)
                             'icomplete-selected-match 'append selected)
@@ -1067,7 +1068,8 @@ icomplete-completions
                   (if (< prospects-len prospects-max)
                       (push comp prospects)
                     (setq limit t)))
-                (setq prospects (nreverse prospects))
+                (setq prospects (nreverse
+                                 (funcall completion-all-sorted-highlight 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 2120e31775e..e8b2849f45a 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -677,6 +677,10 @@ completion--twq-all
                                              'completions-common-part)
                                qprefix))))
                         (qcompletion (concat qprefix qnew)))
+                   ;; Attach unquoted completion string, which is needed
+                   ;; to score the completion in `completion--flex-score'.
+                   (put-text-property 0 1 'completion--unquoted
+                                      completion qcompletion)
 		   ;; FIXME: Similarly here, Cygwin's mapping trips this
 		   ;; assertion.
                    ;;(cl-assert
@@ -1171,6 +1175,17 @@ completion--styles
         (delete-dups (append (cdr over) (copy-sequence completion-styles)))
        completion-styles)))
 
+(defvar completion--return-alist-flag nil
+  "Non-nil means to return completions in alist format.
+If this variable is non-nil the `all-completions' function of a
+completion style should return the results in the alist format of
+`completion-filter-completions'.  This variable is purely needed to
+for backward compatibility of the existing builtin completion style
+functions as of Emacs 28.  Newer completion style functions should
+always return their results in the alist format, since
+`completion-all-completions' transparently converts back to a list of
+completions with base size in the last cdr.")
+
 (defun completion--nth-completion (n string table pred point metadata)
   "Call the Nth method of completion styles."
   ;; We provide special support for quoting/unquoting here because it cannot
@@ -1197,6 +1212,15 @@ completion--nth-completion
                  ;; the original table, in that case!
                  (functionp table))
             (let ((new (funcall table string point 'completion--unquote)))
+              ;; FIXME For now do not attempt deferred highlighting if
+              ;; quoting is used.  Not doing deferred highlighting is
+              ;; not too severe in this case, since
+              ;; `completion--twq-all' is already an expensive
+              ;; function, which allocates all completion strings.  In
+              ;; contrast to plain completion tables, the savings of
+              ;; deferred highlighting would be minimal in the case of
+              ;; quoted completion tables.
+              (setq completion--return-alist-flag nil)
               (setq string (pop new))
               (setq table (pop new))
               (setq point (pop new))
@@ -1205,18 +1229,36 @@ completion--nth-completion
          (result-and-style
           (seq-some
            (lambda (style)
-             (let ((probe (funcall
-                           (or (nth n (assq style completion-styles-alist))
-                               (error "Invalid completion style %s" style))
-                           string table pred point)))
+             (let* ((fun (or (nth n (assq style completion-styles-alist))
+                               (error "Invalid completion style %s" style)))
+                    ;; Transparently upgrade the return value for
+                    ;; existing built-in styles as of Emacs 28.  No
+                    ;; new styles should be added here. New completion
+                    ;; styles should directly return the new
+                    ;; completion format.el
+                    (completion--return-alist-flag
+                     (and completion--return-alist-flag
+                          (memq style '(emacs21 emacs22 basic substring
+                                        partial-completion initials flex))))
+                    (probe (funcall fun string table pred point)))
                (and probe (cons probe style))))
            (completion--styles md)))
-         (adjust-fn (get (cdr result-and-style) 'completion--adjust-metadata)))
-    (when (and adjust-fn metadata)
-      (setcdr metadata (cdr (funcall adjust-fn metadata))))
+         (style-md (get (cdr result-and-style) 'completion--style-metadata))
+         (result (car result-and-style)))
+    (when (and style-md metadata)
+      (setcdr metadata (cdr (funcall style-md
+                                     string table pred point metadata))))
+    (when (and (not completion--return-alist-flag) (= n 2) (consp (car result)))
+      ;; Give the completion styles some freedom!  If they are
+      ;; targeting Emacs 28 upwards only, they may return a result
+      ;; with deferred highlighting.  We convert back to the old
+      ;; format here by applying the highlighting eagerly.
+      (setq result (nconc (funcall (cdr (assq 'highlight result))
+                                   (cdr (assq 'completions result)))
+                          (cdr (assq 'base result)))))
     (if requote
-        (funcall requote (car result-and-style) n)
-      (car result-and-style))))
+        (funcall requote result n)
+      result)))
 
 (defun completion-try-completion (string table pred point &optional metadata)
   "Try to complete STRING using completion table TABLE.
@@ -1225,7 +1267,8 @@ completion-try-completion
 The return value can be either nil to indicate that there is no completion,
 t to indicate that STRING is the only possible completion,
 or a pair (NEWSTRING . NEWPOINT) of the completed result string together with
-a new position for point."
+a new position for point.
+The METADATA may be modified by the completion style."
   (completion--nth-completion 1 string table pred point metadata))
 
 (defun completion-all-completions (string table pred point &optional metadata)
@@ -1233,10 +1276,47 @@ completion-all-completions
 Only the elements of table that satisfy predicate PRED are considered.
 POINT is the position of point within STRING.
 The return value is a list of completions and may contain the base-size
-in the last `cdr'."
-  ;; FIXME: We need to additionally return the info needed for the
-  ;; second part of completion-base-position.
-  (completion--nth-completion 2 string table pred point metadata))
+in the last `cdr'.
+The METADATA may be modified by the completion style.
+
+This function has been superseded by `completion-filter-completions',
+which returns richer information and supports deferred candidate
+highlighting."
+  (let ((completion--return-alist-flag nil))
+    (completion--nth-completion 2 string table pred point metadata)))
+
+(defun completion-filter-completions (string table pred point metadata)
+  "Filter the possible completions of STRING in completion table TABLE.
+Only the elements of table that satisfy predicate PRED are considered.
+POINT is the position of point within STRING.
+The METADATA may be modified by the completion style.
+The return value is a alist with the keys:
+
+- base: Base position of the completion (from the start of STRING)
+- end: End position of the completion (from the start of STRING)
+- highlight: Highlighting function taking a list of completions and
+  returning a new list of new strings with applied highlighting.
+- completions: The list of completions.
+
+This function supersedes the function `completion-all-completions',
+which does not provide the `end' position of the completion and does
+not support deferred highlighting."
+  (let* ((completion--return-alist-flag t)
+         (result (completion--nth-completion 2 string table
+                                             pred point metadata)))
+    (if (and result (not (consp (car result))))
+        ;; Deferred highlighting has been requested, but the
+        ;; completion style returned a non-deferred result.  Convert
+        ;; the result to the alist format of
+        ;; `completion-filter-completions'.
+        (let* ((last (last result))
+               (base (or (cdr last) 0)))
+          (setcdr last nil)
+          `((base . ,base)
+            (end . ,(length string))
+            (highlight . identity)
+            (completions . ,result)))
+      result)))
 
 (defun minibuffer--bitset (modified completions exact)
   (logior (if modified    4 0)
@@ -1253,7 +1333,8 @@ completion--replace
   (if minibuffer-allow-text-properties
       ;; If we're preserving properties, then just remove the faces
       ;; and other properties added by the completion machinery.
-      (remove-text-properties 0 (length newtext) '(face completion-score)
+      (remove-text-properties 0 (length newtext)
+                              '(face nil completion-score nil)
                               newtext)
     ;; Remove all text properties.
     (set-text-properties 0 (length newtext) nil newtext))
@@ -1356,6 +1437,7 @@ completion--cycle-threshold
 
 (defvar-local completion-all-sorted-completions nil)
 (defvar-local completion--all-sorted-completions-location nil)
+(defvar-local completion-all-sorted-highlight nil)
 (defvar completion-cycling nil)      ;Function that takes down the cycling map.
 (defvar completion-tab-width nil)
 
@@ -1562,12 +1644,15 @@ completion--in-region-1
           ;; When the completion list window was displayed, select it.
           (switch-to-completions))))))
 
-(defun completion--cache-all-sorted-completions (beg end comps)
+(defun completion--cache-all-sorted-completions (beg end comps &optional highlight)
   (add-hook 'after-change-functions
             #'completion--flush-all-sorted-completions nil t)
   (setq completion--all-sorted-completions-location
         (cons (copy-marker beg) (copy-marker end)))
-  (setq completion-all-sorted-completions comps))
+  (setq completion-all-sorted-completions comps)
+  (when highlight
+    (setq completion-all-sorted-highlight highlight))
+  comps)
 
 (defun completion--flush-all-sorted-completions (&optional start end _len)
   (unless (and start end
@@ -1578,7 +1663,8 @@ completion--flush-all-sorted-completions
     ;; Remove the transient map if applicable.
     (when completion-cycling
       (funcall (prog1 completion-cycling (setq completion-cycling nil))))
-    (setq completion-all-sorted-completions nil)))
+    (setq completion-all-sorted-completions nil
+          completion-all-sorted-highlight nil)))
 
 (defun completion--metadata (string base md-at-point table pred)
   ;; Like completion-metadata, but for the specific case of getting the
@@ -1656,14 +1742,15 @@ completion-all-sorted-completions
              (end (or end (point-max)))
              (string (buffer-substring start end))
              (md (completion--field-metadata start))
-             (all (completion-all-completions
-                   string
-                   minibuffer-completion-table
-                   minibuffer-completion-predicate
-                   (- (point) start)
-                   md))
-             (last (last all))
-             (base-size (or (cdr last) 0))
+             (alist (completion-filter-completions
+                     string
+                     minibuffer-completion-table
+                     minibuffer-completion-predicate
+                     (- (point) start)
+                     md))
+             (all (assoc-default 'completions alist))
+             (base-size (assoc-default 'base alist))
+             (highlight (assoc-default 'highlight alist))
              (all-md (completion--metadata (buffer-substring-no-properties
                                             start (point))
                                            base-size md
@@ -1671,14 +1758,11 @@ completion-all-sorted-completions
                                            minibuffer-completion-predicate))
              (sort-fun (completion-metadata-get all-md 'cycle-sort-function))
              (group-fun (completion-metadata-get all-md 'group-function)))
-        (when last
-          (setcdr last nil)
-
+        (when all
           ;; Delete duplicates: do it after setting last's cdr to nil (so
           ;; it's a proper list), and be careful to reset `last' since it
           ;; may be a different cons-cell.
           (setq all (delete-dups all))
-          (setq last (last all))
 
           (cond
            (sort-fun (setq all (funcall sort-fun all)))
@@ -1704,7 +1788,7 @@ completion-all-sorted-completions
           ;; repeated calls to minibuffer-force-complete can cycle through
           ;; all possibilities.
           (completion--cache-all-sorted-completions
-           start end (nconc all base-size))))))
+           start end (nconc all base-size) highlight)))))
 
 (defun minibuffer-force-complete-and-exit ()
   "Complete the minibuffer with first of the matches and exit."
@@ -2238,34 +2322,49 @@ completion-hilit-commonality
 It returns a list with font-lock properties applied to each element,
 and with BASE-SIZE appended as the last element."
   (when completions
-    (let ((com-str-len (- prefix-len (or base-size 0))))
-      (nconc
-       (mapcar
-        (lambda (elem)
-          (let ((str
-                 ;; Don't modify the string itself, but a copy, since the
-                 ;; string may be read-only or used for other purposes.
-                 ;; Furthermore, since `completions' may come from
-                 ;; display-completion-list, `elem' may be a list.
-                 (if (consp elem)
-                     (car (setq elem (cons (copy-sequence (car elem))
-                                           (cdr elem))))
-                   (setq elem (copy-sequence elem)))))
-            (font-lock-prepend-text-property
-             0
-             ;; If completion-boundaries returns incorrect
-             ;; values, all-completions may return strings
-             ;; that don't contain the prefix.
-             (min com-str-len (length str))
-             'face 'completions-common-part str)
-            (if (> (length str) com-str-len)
-                (font-lock-prepend-text-property com-str-len (1+ com-str-len)
-                                                 'face
-                                                 'completions-first-difference
-                                                 str)))
-          elem)
-        completions)
-       base-size))))
+    (nconc
+     (completion--hilit-commonality (- prefix-len (or base-size 0)) completions)
+     base-size)))
+
+(defun completion--hilit-commonality (com-size completions)
+  (mapcar
+   (lambda (elem)
+     (let ((str
+            ;; Don't modify the string itself, but a copy, since the
+            ;; string may be read-only or used for other purposes.
+            ;; Furthermore, since `completions' may come from
+            ;; display-completion-list, `elem' may be a list.
+            (if (consp elem)
+                (car (setq elem (cons (copy-sequence (car elem))
+                                      (cdr elem))))
+              (setq elem (copy-sequence elem)))))
+       (font-lock-prepend-text-property
+        0
+        ;; If completion-boundaries returns incorrect
+        ;; values, all-completions may return strings
+        ;; that don't contain the prefix.
+        (min com-size (length str))
+        'face 'completions-common-part str)
+       (if (> (length str) com-size)
+           (font-lock-prepend-text-property com-size (1+ com-size)
+                                            'face
+                                            'completions-first-difference
+                                            str)))
+     elem)
+   completions))
+
+(defun completion--deferred-hilit (completions prefix-len base end)
+  "Return completions as a list or as an alist.
+If `completion--return-alist-flag' is non-nil use the alist format of
+`completion-filter-completions'."
+  (if completion--return-alist-flag
+      (when completions
+        `((base . ,base)
+          (end . ,end)
+          (highlight . ,(apply-partially #'completion--hilit-commonality
+                                         (- prefix-len base)))
+          (completions . ,completions)))
+    (completion-hilit-commonality completions prefix-len base)))
 
 (defun display-completion-list (completions &optional common-substring group-fun)
   "Display the list of completions, COMPLETIONS, using `standard-output'.
@@ -2373,15 +2472,16 @@ minibuffer-completion-help
          (end (or end (point-max)))
          (string (buffer-substring start end))
          (md (completion--field-metadata start))
-         (completions (completion-all-completions
-                       string
-                       minibuffer-completion-table
-                       minibuffer-completion-predicate
-                       (- (point) start)
-                       md)))
+         (filtered-completions (completion-filter-completions
+                                string
+                                minibuffer-completion-table
+                                minibuffer-completion-predicate
+                                (- (point) start)
+                                md))
+         (completions (alist-get 'completions filtered-completions)))
     (message nil)
     (if (or (null completions)
-            (and (not (consp (cdr completions)))
+            (and (not (cdr completions))
                  (equal (car completions) string)))
         (progn
           ;; If there are no completions, or if the current input is already
@@ -2393,8 +2493,7 @@ minibuffer-completion-help
 	      (ding)
 	      (completion--message "No match"))))
 
-      (let* ((last (last completions))
-             (base-size (or (cdr last) 0))
+      (let* ((base-size (alist-get 'base filtered-completions))
              (prefix (unless (zerop base-size) (substring string 0 base-size)))
              (base-prefix (buffer-substring (minibuffer--completion-prompt-end)
                                             (+ start base-size)))
@@ -2442,9 +2541,12 @@ minibuffer-completion-help
             (body-function
              . ,#'(lambda (_window)
                     (with-current-buffer mainbuf
-                      ;; Remove the base-size tail because `sort' requires a properly
-                      ;; nil-terminated list.
-                      (when last (setcdr last nil))
+                      ;; Apply highlighting using the deferred
+                      ;; highlighting function provided by
+                      ;; `completion-format-completions'.
+                      (setq completions
+                            (funcall (alist-get 'highlight filtered-completions)
+                                     completions))
 
                       ;; Sort first using the `display-sort-function'.
                       ;; FIXME: This function is for the output of
@@ -2486,13 +2588,10 @@ minibuffer-completion-help
                                       completions))))
 
                       (with-current-buffer standard-output
-                        (setq-local completion-base-position
-                             (list (+ start base-size)
-                                   ;; FIXME: We should pay attention to completion
-                                   ;; boundaries here, but currently
-                                   ;; completion-all-completions does not give us the
-                                   ;; necessary information.
-                                   end))
+                        (setq-local
+                         completion-base-position
+                         (list (+ start base-size)
+                               (+ start (alist-get 'end filtered-completions))))
                         (setq-local completion-base-affixes
                                     (list base-prefix base-suffix))
                         (setq-local completion-list-insert-choice-function
@@ -3468,10 +3567,11 @@ completion-emacs21-try-completion
       completion)))
 
 (defun completion-emacs21-all-completions (string table pred _point)
-  (completion-hilit-commonality
+  (completion--deferred-hilit
    (all-completions string table pred)
    (length string)
-   (car (completion-boundaries string table pred ""))))
+   (car (completion-boundaries string table pred ""))
+   (length string)))
 
 (defun completion-emacs22-try-completion (string table pred point)
   (let ((suffix (substring string point))
@@ -3494,11 +3594,12 @@ completion-emacs22-try-completion
       (cons (concat completion suffix) (length completion)))))
 
 (defun completion-emacs22-all-completions (string table pred point)
-  (let ((beforepoint (substring string 0 point)))
-    (completion-hilit-commonality
+  (let* ((beforepoint (substring string 0 point))
+         (afterpoint (substring string point))
+         (bounds (completion-boundaries beforepoint table pred afterpoint)))
+    (completion--deferred-hilit
      (all-completions beforepoint table pred)
-     point
-     (car (completion-boundaries beforepoint table pred "")))))
+     point (car bounds) (+ point (cdr bounds)))))
 
 ;;; Basic completion.
 
@@ -3557,7 +3658,7 @@ completion-basic-all-completions
                             'point
                             (substring afterpoint 0 (cdr bounds)))))
          (all (completion-pcm--all-completions prefix pattern table pred)))
-    (completion-hilit-commonality all point (car bounds))))
+    (completion--deferred-hilit all point (car bounds) (+ point (cdr bounds)))))
 
 ;;; Partial-completion-mode style completion.
 
@@ -3749,14 +3850,27 @@ flex-score-match-tightness
 than the latter (which has two \"holes\" and three
 one-letter-long matches).")
 
-(defun completion-pcm--hilit-commonality (pattern completions)
+(defun completion-pcm--deferred-hilit (pattern completions base end)
+  "Return completions as a list or as an alist.
+If `completion--return-alist-flag' is non-nil use the alist format of
+`completion-filter-completions'."
+  (when completions
+    (if completion--return-alist-flag
+        `((base . ,base)
+          (end . ,end)
+          (highlight . ,(apply-partially
+                         #'completion-pcm--hilit-commonality
+                         pattern))
+          (completions . ,completions))
+      (nconc (completion-pcm--hilit-commonality pattern completions 'score) base))))
+
+(defun completion-pcm--hilit-commonality (pattern completions &optional score)
   "Show where and how well PATTERN matches COMPLETIONS.
 PATTERN, a list of symbols and strings as seen
 `completion-pcm--merge-completions', is assumed to match every
 string in COMPLETIONS.  Return a deep copy of COMPLETIONS where
-each string is propertized with `completion-score', a number
-between 0 and 1, and with faces `completions-common-part',
+each string is propertized with faces `completions-common-part',
 `completions-first-difference' in the relevant segments."
   (cond
    ((and completions (cl-loop for e in pattern thereis (stringp e)))
     (let* ((re (completion-pcm--pattern->regex pattern 'group))
@@ -3773,86 +3888,145 @@ completion-pcm--hilit-commonality
                 (match-end (match-end 0))
                 (md (cddr (setq last-md (match-data t last-md))))
                 (from 0)
-                (end (length str))
-                ;; To understand how this works, consider these simple
-                ;; ascii diagrams showing how the pattern "foo"
-                ;; flex-matches "fabrobazo", "fbarbazoo" and
-                ;; "barfoobaz":
-
-                ;;      f abr o baz o
-                ;;      + --- + --- +
-
-                ;;      f barbaz oo
-                ;;      + ------ ++
-
-                ;;      bar foo baz
-                ;;          +++
-
-                ;; "+" indicates parts where the pattern matched.  A
-                ;; "hole" in the middle of the string is indicated by
-                ;; "-".  Note that there are no "holes" near the edges
-                ;; of the string.  The completion score is a number
-                ;; bound by (0..1] (i.e., larger than (but not equal
-                ;; to) zero, and smaller or equal to one): the higher
-                ;; the better and only a perfect match (pattern equals
-                ;; string) will have score 1.  The formula takes the
-                ;; form of a quotient.  For the numerator, we use the
-                ;; number of +, i.e. the length of the pattern.  For
-                ;; the denominator, it first computes
-                ;;
-                ;;     hole_i_contrib = 1 + (Li-1)^(1/tightness)
-                ;;
-                ;; , for each hole "i" of length "Li", where tightness
-                ;; is given by `flex-score-match-tightness'.  The
-                ;; final value for the denominator is then given by:
-                ;;
-                ;;    (SUM_across_i(hole_i_contrib) + 1) * len
-                ;;
-                ;; , where "len" is the string's length.
-                (score-numerator 0)
-                (score-denominator 0)
-                (last-b 0)
-                (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)
-                   (setq
-                    score-numerator   (+ score-numerator (- b a)))
-                   (unless (or (= a last-b)
-                               (zerop last-b)
-                               (= a (length str)))
-                     (setq
-                      score-denominator (+ score-denominator
-                                           1
-                                           (expt (- a last-b 1)
-                                                 (/ 1.0
-                                                    flex-score-match-tightness)))))
-                   (setq
-                    last-b              b))))
+                (len (length str)))
+           (when (and score (/= 0 len))
+             (put-text-property
+              0 1 'completion-score (- (completion--flex-score-1 md match-end len)) str))
            (while md
-             (funcall update-score-and-face from (pop md))
+             (add-face-text-property from (pop md)
+                                     'completions-common-part
+                                     nil str)
              (setq from (pop md)))
            ;; If `pattern' doesn't have an explicit trailing any, the
            ;; regex `re' won't produce match data representing the
            ;; region after the match.  We need to account to account
            ;; 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 from match-end
+                                     'completions-common-part
+                                     nil str))
+           (if (> len pos)
                (add-face-text-property
                 pos (1+ pos)
                 'completions-first-difference
-                nil str))
-           (unless (zerop (length str))
-             (put-text-property
-              0 1 'completion-score
-              (/ score-numerator (* end (1+ score-denominator)) 1.0) str)))
+                nil str)))
          str)
        completions)))
    (t completions)))
 
+(defun completion--flex-score-1 (md match-end len)
+  "Compute matching score of completion.
+The score lies in the range between-1 and 0, where -1 corresponds to
+the full match.
+MD is the match data.
+MATCH-END is the end of the match.
+LEN is the length of the completion string."
+  (let* ((from 0)
+         ;; To understand how this works, consider these simple
+         ;; ascii diagrams showing how the pattern "foo"
+         ;; flex-matches "fabrobazo", "fbarbazoo" and
+         ;; "barfoobaz":
+
+         ;;      f abr o baz o
+         ;;      + --- + --- +
+
+         ;;      f barbaz oo
+         ;;      + ------ ++
+
+         ;;      bar foo baz
+         ;;          +++
+
+         ;; "+" indicates parts where the pattern matched.  A
+         ;; "hole" in the middle of the string is indicated by
+         ;; "-".  Note that there are no "holes" near the edges
+         ;; of the string.  The completion score is a number
+         ;; bound by (0..1] (i.e., larger than (but not equal
+         ;; to) zero, and smaller or equal to one): the higher
+         ;; the better and only a perfect match (pattern equals
+         ;; string) will have score 1.  The formula takes the
+         ;; form of a quotient.  For the numerator, we use the
+         ;; number of +, i.e. the length of the pattern.  For
+         ;; the denominator, it first computes
+         ;;
+         ;;     hole_i_contrib = 1 + (Li-1)^(1/tightness)
+         ;;
+         ;; , for each hole "i" of length "Li", where tightness
+         ;; is given by `flex-score-match-tightness'.  The
+         ;; final value for the denominator is then given by:
+         ;;
+         ;;    (SUM_across_i(hole_i_contrib) + 1) * len
+         ;;
+         ;; , where "len" is the string's length.
+         (score-numerator 0)
+         (score-denominator 0)
+         (last-b 0))
+    (while md
+      (let ((a from)
+            (b (pop md)))
+        (setq
+         score-numerator   (+ score-numerator (- b a)))
+        (unless (or (= a last-b)
+                    (zerop last-b)
+                    (= a len))
+          (setq
+           score-denominator (+ score-denominator
+                                1
+                                (expt (- a last-b 1)
+                                      (/ 1.0
+                                         flex-score-match-tightness)))))
+        (setq
+         last-b              b))
+      (setq from (pop md)))
+    ;; If `pattern' doesn't have an explicit trailing any, the
+    ;; regex `re' won't produce match data representing the
+    ;; region after the match.  We need to account to account
+    ;; for that extra bit of match (bug#42149).
+    (unless (= from match-end)
+      (let ((a from)
+            (b match-end))
+        (setq
+         score-numerator   (+ score-numerator (- b a)))
+        (unless (or (= a last-b)
+                    (zerop last-b)
+                    (= a len))
+          (setq
+           score-denominator (+ score-denominator
+                                1
+                                (expt (- a last-b 1)
+                                      (/ 1.0
+                                         flex-score-match-tightness)))))
+        (setq
+         last-b              b)))
+    (- (/ score-numerator (* len (1+ score-denominator)) 1.0))))
+
+(defun completion--flex-score (pattern completions)
+  "Compute how well PATTERN matches COMPLETIONS.
+PATTERN, a pcm pattern is assumed to match every string in the
+COMPLETIONS list.  Return a copy of COMPLETIONS where each element is
+a pair of a score and the string.  The score lies in the range between
+-1 and 0, where -1 corresponds to the full match."
+  (when completions
+    (let* ((re (completion-pcm--pattern->regex pattern 'group))
+           (case-fold-search completion-ignore-case)
+           last-md)
+      (mapcar
+       (lambda (str)
+         ;; The flex completion style requires the completion to match
+         ;; the pattern to compute the scoring.  For quoted completion
+         ;; tables the completions are matched against the *unquoted
+         ;; input string*.  However `completion-all-completions' and
+         ;; `completion-filter-completions' return a list of *quoted
+         ;; completions*, which is subsequently sorted.  Therefore we
+         ;; obtain the unquoted completion string which is stored in
+         ;; the text property `completion--unquoted'.
+         (let ((unquoted (or (get-text-property 0 'completion--unquoted str) str)))
+           (unless (string-match re unquoted)
+             (error "Internal error: %s does not match %s" re unquoted))
+           (cons (completion--flex-score-1 (cddr (setq last-md (match-data t last-md)))
+                                           (match-end 0) (length unquoted))
+                 str)))
+       completions))))
+
 (defun completion-pcm--find-all-completions (string table pred point
                                                     &optional filter)
   "Find all completions for STRING at POINT in TABLE, satisfying PRED.
@@ -3948,11 +4122,11 @@ completion-pcm--find-all-completions
         (list pattern all prefix suffix)))))
 
 (defun completion-pcm-all-completions (string table pred point)
-  (pcase-let ((`(,pattern ,all ,prefix ,_suffix)
+  (pcase-let ((`(,pattern ,all ,prefix ,suffix)
                (completion-pcm--find-all-completions string table pred point)))
-    (when all
-      (nconc (completion-pcm--hilit-commonality pattern all)
-             (length prefix)))))
+    (completion-pcm--deferred-hilit pattern all
+                                    (length prefix)
+                                    (- (length string) (length suffix)))))
 
 (defun completion--common-suffix (strs)
   "Return the common suffix of the strings STRS."
@@ -4136,8 +4310,8 @@ completion-pcm-try-completion
 ;;; Substring completion
 ;; Mostly derived from the code of `basic' completion.
 
-(defun completion-substring--all-completions
-    (string table pred point &optional transform-pattern-fn)
+(defun completion--pattern-compiler
+    (string table pred point transform-pattern-fn)
   "Match the presumed substring STRING to the entries in TABLE.
 Respect PRED and POINT.  The pattern used is a PCM-style
 substring pattern, but it be massaged by TRANSFORM-PATTERN-FN, if
@@ -4155,12 +4329,23 @@ completion-substring--all-completions
          (pattern (completion-pcm--optimize-pattern
                    (if transform-pattern-fn
                        (funcall transform-pattern-fn pattern)
-                     pattern)))
-         (all (completion-pcm--all-completions prefix pattern table pred)))
-    (list all pattern prefix suffix (car bounds))))
+                     pattern))))
+    (list pattern prefix suffix)))
+
+(defun completion-substring--all-completions
+    (string table pred point &optional transform-pattern-fn)
+  "Match the presumed substring STRING to the entries in TABLE.
+Respect PRED and POINT.  The pattern used is a PCM-style
+substring pattern, but it be massaged by TRANSFORM-PATTERN-FN, if
+that is non-nil."
+  (pcase-let (((and result `(,pattern ,prefix ,_suffix))
+               (completion--pattern-compiler string table pred point
+                                             transform-pattern-fn)))
+    (cons (completion-pcm--all-completions prefix pattern table pred)
+          result)))
 
 (defun completion-substring-try-completion (string table pred point)
-  (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds)
+  (pcase-let ((`(,all ,pattern ,prefix ,suffix)
                (completion-substring--all-completions
                 string table pred point)))
     (if minibuffer-completing-file-name
@@ -4168,12 +4353,12 @@ completion-substring-try-completion
     (completion-pcm--merge-try pattern all prefix suffix)))
 
 (defun completion-substring-all-completions (string table pred point)
-  (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds)
+  (pcase-let ((`(,all ,pattern ,prefix ,suffix)
                (completion-substring--all-completions
                 string table pred point)))
-    (when all
-      (nconc (completion-pcm--hilit-commonality pattern all)
-             (length prefix)))))
+    (completion-pcm--deferred-hilit pattern all
+                                    (length prefix)
+                                    (- (length string) (length suffix)))))
 
 ;;; "flex" completion, also known as flx/fuzzy/scatter completion
 ;; Completes "foo" to "frodo" and "farfromsober"
@@ -4183,19 +4368,11 @@ completion-flex-nospace
   :version "27.1"
   :type 'boolean)
 
-(put 'flex 'completion--adjust-metadata 'completion--flex-adjust-metadata)
+(put 'flex 'completion--style-metadata 'completion--flex-style-metadata)
 
-(defun completion--flex-adjust-metadata (metadata)
+(defun completion--flex-style-metadata (string table pred point metadata)
   "If `flex' is actually doing filtering, adjust sorting."
-  (let ((flex-is-filtering-p
-         ;; JT@2019-12-23: FIXME: this is kinda wrong.  What we need
-         ;; to test here is "some input that actually leads/led to
-         ;; flex filtering", not "something after the minibuffer
-         ;; prompt".  E.g. The latter is always true for file
-         ;; searches, meaning we'll be doing extra work when we
-         ;; needn't.
-         (or (not (window-minibuffer-p))
-             (> (point-max) (minibuffer-prompt-end))))
+  (let ((flex-is-filtering-p (not (equal string "")))
         (existing-dsf
          (completion-metadata-get metadata 'display-sort-function))
         (existing-csf
@@ -4204,12 +4381,32 @@ completion--flex-adjust-metadata
         ((compose-flex-sort-fn
           (existing-sort-fn) ; wish `cl-flet' had proper indentation...
           (lambda (completions)
-            (sort
-             (funcall existing-sort-fn completions)
-             (lambda (c1 c2)
-               (let ((s1 (get-text-property 0 'completion-score c1))
-                     (s2 (get-text-property 0 'completion-score c2)))
-                 (> (or s1 0) (or s2 0))))))))
+            (let ((pre-sorted (funcall existing-sort-fn completions))
+                  (pattern (car (completion--pattern-compiler
+                                 string table pred point
+                                 #'completion-flex--make-flex-pattern))))
+              ;; If `completion-scores' are already present use
+              ;; those instead of recomputing the scores with
+              ;; `completion--flex-score'.  The scores are already
+              ;; present, when the candidates have been computed by
+              ;; `completion-all-completions'.  In contrast, the
+              ;; score is not yet present, when the candidates have
+              ;; been computed by `completion-filter-completions'.
+              (if (and (car pre-sorted)
+                       (get-text-property 0 'completion-score (car pre-sorted)))
+                  (sort
+                   pre-sorted
+                   (lambda (c1 c2)
+                     (> (or (get-text-property 0 'completion-score c1) 0)
+                        (or (get-text-property 0 'completion-score c2) 0))))
+                (let* ((sorted (sort (completion--flex-score pattern pre-sorted)
+                                     #'car-less-than-car))
+                       (cell sorted))
+                  ;; Remove score decorations, reuse the list to avoid allocations.
+                  (while cell
+                    (setcar cell (cdar cell))
+                    (pop cell))
+                  sorted))))))
       `(metadata
         ,@(and flex-is-filtering-p
                `((display-sort-function
@@ -4239,7 +4436,7 @@ completion-flex--make-flex-pattern
 (defun completion-flex-try-completion (string table pred point)
   "Try to flex-complete STRING in TABLE given PRED and POINT."
   (unless (and completion-flex-nospace (string-search " " string))
-    (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds)
+    (pcase-let ((`(,all ,pattern ,prefix ,suffix)
                  (completion-substring--all-completions
                   string table pred point
                   #'completion-flex--make-flex-pattern)))
@@ -4256,13 +4453,13 @@ completion-flex-try-completion
 (defun completion-flex-all-completions (string table pred point)
   "Get flex-completions of STRING in TABLE, given PRED and POINT."
   (unless (and completion-flex-nospace (string-search " " string))
-    (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds)
+    (pcase-let ((`(,all ,pattern ,prefix ,suffix)
                  (completion-substring--all-completions
                   string table pred point
                   #'completion-flex--make-flex-pattern)))
-      (when all
-        (nconc (completion-pcm--hilit-commonality pattern all)
-               (length prefix))))))
+      (completion-pcm--deferred-hilit pattern all
+                                    (length prefix)
+                                    (- (length string) (length suffix))))))
 
 ;; Initials completion
 ;; Complete /ums to /usr/monnier/src or lch to list-command-history.
@@ -4299,7 +4496,11 @@ completion-initials-expand
 (defun completion-initials-all-completions (string table pred _point)
   (let ((newstr (completion-initials-expand string table pred)))
     (when newstr
-      (completion-pcm-all-completions newstr table pred (length newstr)))))
+      (pcase-let ((`(,pattern ,all ,prefix ,_suffix)
+                   (completion-pcm--find-all-completions newstr table
+                                                         pred (length newstr))))
+        (completion-pcm--deferred-hilit pattern all
+                                        (length prefix) (length string))))))
 
 (defun completion-initials-try-completion (string table pred _point)
   (let ((newstr (completion-initials-expand string table pred)))
diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el
index 4f92d7f841c..1ab80cd1364 100644
--- a/test/lisp/minibuffer-tests.el
+++ b/test/lisp/minibuffer-tests.el
@@ -28,8 +28,7 @@
 
 (require 'ert)
 (require 'ert-x)
-
-(eval-when-compile (require 'cl-lib))
+(require 'cl-lib)
 
 (ert-deftest completion-test1 ()
   (with-temp-buffer
@@ -344,6 +343,221 @@ completion-flex-test-3
                   "custgroup" '("customize-group-other-window") nil 9)))
            15)))
 
+(ert-deftest completion-flex-score-test-1 ()
+  ;; Full match!
+  (should (equal
+           (completion--flex-score '(prefix "R") '("R"))
+           (list (cons -1.0 "R")))))
+
+(ert-deftest completion-flex-score-test-2 ()
+  ;; One third and half of a match!
+  (should (equal
+           (completion--flex-score '(prefix "foo")
+                                   '("barfoobar" "fooboo"))
+           (list (cons (/ -1.0 3.0) "barfoobar")
+                 (cons (/ -1.0 2.0) "fooboo")))))
+
+(ert-deftest completion-flex-score-test-3 ()
+  ;; One fourth of a match
+  (should (eql
+           (caar (completion--flex-score '(prefix "R" point "O")
+                                         '("RaOb")))
+           (/ -1.0 4.0))))
+
+(ert-deftest completion-flex-score-test-4 ()
+  ;; For quoted completion tables, score the unquoted completion string.
+  (should (equal
+           (completion--flex-score
+            '(prefix "R")
+            (list (propertize "X" 'completion--unquoted "R")))
+           (list (cons -1.0 "X")))))
+
+(defun completion--test-style (style string point table filtered)
+  (let* ((completion-styles (list style))
+         (pred (lambda (x) (not (string-search "!" x))))
+         (result (completion-filter-completions
+                  string table pred point nil)))
+    (should (equal (alist-get 'base result) 0))
+    (should (equal (alist-get 'end result) (length string)))
+    (should (equal (alist-get 'completions result) filtered))
+    ;; The highlighting function should be present.
+    (should (not (memq (alist-get 'highlight result) '(nil identity))))
+    ;; Equal results as `completion-all-completions'.
+    (should (equal (completion-all-completions string table pred point)
+                   (append filtered 0)))
+    ;; The returned strings should be identical to the original strings.
+    ;; The `completion-filter-completions' function avoids allocations!
+    (should (cl-intersection (alist-get 'completions result)
+                             table :test #'eq))))
+
+(ert-deftest completion-basic-style-test-1 ()
+  ;; point at the beginning |foo
+  (completion--test-style 'basic "foo" 0
+                          '("foobar" "foo!" "barfoo" "xfooy" "boobar")
+                          '("foobar" "barfoo" "xfooy")))
+
+(ert-deftest completion-basic-style-test-2 ()
+  ;; point foo
+  (completion--test-style 'basic "foo" 2
+                          '("foobar" "foo!" "fobar" "barfoo" "xfooy" "boobar")
+                          '("foobar")))
+
+(ert-deftest completion-substring-style-test ()
+  (completion--test-style 'substring "foo" 1
+                          '("foobar" "foo!" "barfoo" "xfooy" "boobar")
+                          '("foobar" "barfoo" "xfooy")))
+
+(ert-deftest completion-emacs21-style-test ()
+  (completion--test-style 'emacs21 "foo" 1
+                          '("foobar" "foo!" "fobar" "barfoo" "xfooy" "boobar")
+                          '("foobar")))
+
+(ert-deftest completion-emacs22-style-test ()
+  (completion--test-style 'emacs22 "fo0" 1
+                          '("foobar" "foo!" "fobar" "barfoo" "xfooy" "boobar")
+                          '("foobar" "fobar"))) ;; suffix ignored completely
+
+(ert-deftest completion-flex-style-test ()
+  (completion--test-style 'flex "abc" 1
+                          '("abc" "abc!" "xaybzc" "xaybz")
+                          '("abc" "xaybzc")))
+
+(ert-deftest completion-initials-style-test ()
+  (completion--test-style 'initials "abc" 1
+                          '("a-b-c" "a-b-c!" "ax-by-cz" "xax-by-cz")
+                          '("a-b-c" "ax-by-cz")))
+
+(ert-deftest completion-pcm-style-test ()
+  (completion--test-style 'partial-completion "ax-b-c" 1
+                          '("ax-b-c" "ax-b-c!" "ax-by-cz" "xax-by-cz")
+                          '("ax-b-c" "ax-by-cz")))
+
+(ert-deftest completion-filter-completions-highlight-test ()
+  ;; point at the beginning |foo
+  (let* ((completion-styles '(basic))
+         (result (completion-filter-completions
+                  "foo" '("foobar" "fbarfoo" "fxfooy" "bar")
+                  nil 1 nil)))
+    (should (equal
+             (format "%S" (alist-get 'completions result))
+             (format "%S" '("foobar" "fbarfoo" "fxfooy"))))
+    (should (equal
+             (format "%S" (funcall (alist-get 'highlight result)
+                                   (alist-get 'completions result)))
+             (format "%S"
+                     '(#("foobar" 0 1 (face (completions-common-part))
+                         1 2 (face (completions-first-difference)))
+                       #("fbarfoo" 0 1 (face (completions-common-part))
+                         1 2 (face (completions-first-difference)))
+                       #("fxfooy" 0 1 (face (completions-common-part))
+                         1 2 (face (completions-first-difference)))))))))
+
+(defun completion--test-boundaries (style string table result)
+  (let ((table
+         (lambda (str pred action)
+           (pcase action
+             (`(boundaries . ,suffix) `(boundaries
+                                        ,(1+ (string-match-p "<\\|/" str))
+                                        . ,(or (string-search ">" suffix) (length suffix))))
+             (_ (complete-with-action action table
+                                      (replace-regexp-in-string ".*[</]" "" str)
+                                      pred)))))
+        (point (string-search "|" string))
+        (string (string-replace "|" "" string))
+        (completion-styles (list style)))
+    (should (equal
+             (assq-delete-all
+              (if (assq 'highlight result) '-does-not-exist 'highlight)
+              (completion-filter-completions
+               string table nil point nil))
+             result))
+    (should (equal
+             (completion-all-completions
+              string table nil point)
+             (append (alist-get 'completions result)
+                     (alist-get 'base result))))))
+
+(ert-deftest completion-emacs21-boundaries-test ()
+  (completion--test-boundaries 'emacs21 "before<in|put>after"
+                               '("other") nil)
+  (completion--test-boundaries 'emacs21 "before<in|put>after"
+                               '("ainput>after" "input>after" "inpux>after"
+                                 "inxputy>after" "input>after2")
+                               '((base . 7)
+                                 (end . 18)
+                                 (completions "input>after" "input>after2"))))
+
+(ert-deftest completion-emacs22-boundaries-test ()
+  (completion--test-boundaries 'emacs22 "before<in|put>after"
+                               '("other") nil)
+  (completion--test-boundaries 'emacs22 "before<in|put>after"
+                               '("ainxxx" "inyy" "inzzz")
+                               '((base . 7)
+                                 (end . 12)
+                                 (completions "inyy" "inzzz"))))
+
+(ert-deftest completion-basic-boundaries-test ()
+  (completion--test-boundaries 'basic "before<in|put>after"
+                               '("other") nil)
+  (completion--test-boundaries 'basic "before<in|put>after"
+                               '("ainput" "input" "inpux" "inxputy")
+                               '((base . 7)
+                                 (end . 12)
+                                 (completions "input" "inxputy"))))
+
+(ert-deftest completion-substring-boundaries-test ()
+  (completion--test-boundaries 'substring "before<in|puts>after"
+                               '("other") nil)
+  (completion--test-boundaries 'substring "before<in|puts>after"
+                               '("ainputs" "inputs" "inpux" "inxputsy")
+                               '((base . 7)
+                                 (end . 13)
+                                 (completions "ainputs" "inputs" "inxputsy"))))
+
+(ert-deftest completion-pcm-boundaries-test ()
+  (completion--test-boundaries 'partial-completion "before<in-p|t>after"
+                               '("other") nil)
+  (completion--test-boundaries 'partial-completion "before<in-p|t>after"
+                               '("ain-pu-ts" "in-pts" "in-pu-ts" "in-px" "inx-ptsy")
+                               '((base . 7)
+                                 (end . 12)
+                                 (completions "in-pts" "in-pu-ts" "inx-ptsy"))))
+
+(ert-deftest completion-initials-boundaries-test ()
+  (completion--test-boundaries 'initials "/ip|t"
+                               '("other") nil)
+  (completion--test-boundaries 'initials "/ip|t"
+                               '("ain/pu/ts" "in/pts" "in/pu/ts" "a/in/pu/ts"
+                                 "in/pu/ts/foo" "in/px" "inx/ptsy")
+                               '((base . 1)
+                                 (end . 4)
+                                 (completions "in/pu/ts" "in/pu/ts/foo"))))
+
+(defun completion-emacs22orig-all-completions (string table pred point)
+  (let ((beforepoint (substring string 0 point)))
+    (completion-hilit-commonality
+      (all-completions beforepoint table pred)
+     point
+     (car (completion-boundaries beforepoint table pred "")))))
+
+(ert-deftest completion-upgrade-return-type-test ()
+  ;; Test transparent upgrade of list completion style return value
+  ;; to the alist return value format of `completion-format-completions'.
+  (let ((completion-styles-alist
+         '((emacs22orig completion-emacs22-try-completion
+                        completion-emacs22orig-all-completions nil))))
+  (completion--test-boundaries 'emacs22orig "before<in|put>after"
+                               '("ainxxx" "inyy" "inzzz")
+                               '((base . 7)
+                                 ;; 18 is incorrect, should be 12!
+                                 ;; But the information is not available
+                                 ;; due to the completion-style upgrade.
+                                 (end . 18)
+                                 ;; Identity highlighting function.
+                                 (highlight . identity)
+                                 (completions "inyy" "inzzz")))))
+
+
 \f
 (defmacro completing-read-with-minibuffer-setup (collection &rest body)
   (declare (indent 1) (debug (collection body)))

[-- Attachment #3: completion-lazy-hilit.patch --]
[-- Type: text/x-patch, Size: 6740 bytes --]

diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index e6fdd1f1836..a9ac0b3f040 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -545,6 +545,7 @@ icomplete-minibuffer-setup
     (setq-local icomplete--initial-input (icomplete--field-string))
     (setq-local completion-show-inline-help nil)
     (setq icomplete--scrolled-completions nil)
+    (setq completion-lazy-hilit (cl-gensym))
     (use-local-map (make-composed-keymap icomplete-minibuffer-map
     					 (current-local-map)))
     (add-hook 'post-command-hook #'icomplete-post-command-hook nil t)
@@ -754,12 +755,13 @@ icomplete-exhibit
                            (overlay-end rfn-eshadow-overlay)))
           (let* ((field-string (icomplete--field-string))
                  (text (while-no-input
+                         (benchmark-progn
                          (icomplete-completions
                           field-string
                           (icomplete--completion-table)
                           (icomplete--completion-predicate)
                           (if (window-minibuffer-p)
-                              (eq minibuffer--require-match t)))))
+                              (eq minibuffer--require-match t))))))
                  (buffer-undo-list t)
                  deactivate-mark)
             ;; Do nothing if while-no-input was aborted.
@@ -901,7 +903,7 @@ icomplete--render-vertical
                                 'icomplete-selected-match 'append comp)
      collect (concat prefix
                      (make-string (- max-prefix-len (length prefix)) ? )
-                     comp
+                     (completion-lazy-hilit comp)
                      (make-string (- max-comp-len (length comp)) ? )
                      suffix)
      into lines-aux
@@ -1067,7 +1069,8 @@ icomplete-completions
                   (if (< prospects-len prospects-max)
                       (push comp prospects)
                     (setq limit t)))
-                (setq prospects (nreverse prospects))
+                (setq prospects
+                      (nreverse (mapcar #'completion-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 2120e31775e..c56ef64494a 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -3749,6 +3749,54 @@ flex-score-match-tightness
 than the latter (which has two \"holes\" and three
 one-letter-long matches).")
 
+(defvar-local completion-lazy-hilit nil
+  "If non-nil, request completion lazy hilighting.
+
+Completion-presenting frontends may opt to bind this variable to
+a unique non-nil value in the context of completion-producing
+calls (such as `completion-all-sorted-completions').  This hints
+the intervening completion styles that they do not need to
+propertize completion strings with the `face' property.
+
+When doing so, it is the frontend -- not the style -- who becomes
+responsible for `face'-propertizing only the completion strings
+that are meant to be displayed to the user.  This can be done by
+calling the function `completion-lazy-hilit' which returns a
+`face'-propertized string.
+
+The value stored in this variable by the completion frontend
+should be unique to each completion attempt or session that
+utilizes the same completion style in `completion-styles-alist'.
+For frontends using the minibuffer as the locus of completion
+calls and display, setting it to a buffer-local value given by
+`gensym' is appropriate.  For frontends operating entirely in a
+single command, let-binding it to `gensym' is appropriate.
+
+Note that the optimization enabled by variable is only actually
+performed some completions styles.  To others, it is a harmless
+and useless hint.  To author a completion style that takes
+advantage of this, look in the source of
+`completion-pcm--hilit-commonality'.")
+
+(defun completion-lazy-hilit (str)
+  "Return a copy of completion STR that is `face'-propertized.
+See documentation for variable `completion-lazy-hilit' for more
+details."
+  (let* ((str (copy-sequence str))
+         (data (get-text-property 0 'completion-lazy-hilit-data str))
+         (re (and
+              completion-lazy-hilit
+              (eq completion-lazy-hilit (car data)) (cdr data)))
+         (md (and re (string-match re str) (cddr (match-data t))))
+         (me (and md (match-end 0)))
+         (from 0))
+    (while md
+      (add-face-text-property from (pop md) 'completions-common-part nil str)
+      (setq from (pop md)))
+    (unless (or (not me) (= from me))
+      (add-face-text-property from me 'completions-common-part 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
@@ -3765,8 +3813,9 @@ completion-pcm--hilit-commonality
            last-md)
       (mapcar
        (lambda (str)
-	 ;; Don't modify the string itself.
-         (setq str (copy-sequence str))
+         (unless completion-lazy-hilit
+           ;; Don't modify the string itself.
+           (setq str (copy-sequence 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)))
@@ -3815,9 +3864,10 @@ completion-pcm--hilit-commonality
                 (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)
+                   (unless completion-lazy-hilit
+                     (add-face-text-property a b
+                                             'completions-common-part
+                                             nil str))
                    (setq
                     score-numerator   (+ score-numerator (- b a)))
                    (unless (or (= a last-b)
@@ -3840,7 +3890,10 @@ completion-pcm--hilit-commonality
            ;; for that extra bit of match (bug#42149).
            (unless (= from match-end)
              (funcall update-score-and-face from match-end))
-           (if (> (length str) pos)
+           (put-text-property 0 1 'completion-lazy-hilit-data
+                              (cons completion-lazy-hilit re) str)
+           (if (and (> (length str) pos)
+                    (not completion-lazy-hilit))
                (add-face-text-property
                 pos (1+ pos)
                 'completions-first-difference