bug#50806: 27.2; [PATCH] Optimize ansi-color.el

[miha--- via "Bug reports for GNU Emacs, the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>]

[-- Attachment #1.1: Type: text/plain, Size: 696 bytes --]

Attached patch speeds up ansi-color.  It tries to eliminate as many
allocations (cons and list) as possible.

Benchmarks, recorded in emacs -q, are in the second attachments.  With
the patch applied, there is a 26% speedup in elapsed time, mostly
because the garbage collector has to take care of less allocations.

Two less important side notes:

1) This patch additionally makes it very straight forward to add support
   for ANSI color codes 38 and 48 allowing 256-colors and 24bit
   full-color.  I plan to submit such a patch later (for both ansi-color
   and term-mode).

2) Two vector variables, that were recently added by Jim, were merged
   into one.  Adding him as CC.

Best regards.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0001-Optimize-ansi-color.el.patch --]
[-- Type: text/x-patch, Size: 19801 bytes --]

From 9b40c13dd83a1c9336ba2eadf90041c07acb82a1 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Miha=20Rihtar=C5=A1i=C4=8D?= <miha@kamnitnik.top>
Date: Sat, 25 Sep 2021 23:05:11 +0200
Subject: [PATCH 1/3] Optimize ansi-color.el

* lisp/ansi-color.el (ansi-color-normal-colors-vector):
(ansi-color-bright-colors-vector): Merge these two vectors into one.

(ansi-color-context-region):
(ansi-color-context): Adjust doc string to the new format of
ansi-color context.

(ansi-color--find-face): Rename to ansi-color--face-vec-face
(ansi-color--face-vec-face): Adjust to the new format ansi-color
context.

(ansi-color-apply):
(ansi-color-apply-on-region): Adjust to the new format of ansi-color
context in order to speed these two functions up

(ansi-color-apply-sequence): Make it obsolete
(ansi-color--update-face-vec): New function to handle the new format
of ansi-color context.

(ansi-color-get-face-1): Make obsolete as this function isn't used any
more.
---
 lisp/ansi-color.el | 308 ++++++++++++++++++++++++++++++---------------
 1 file changed, 206 insertions(+), 102 deletions(-)

diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el
index b1c9cdaeca..d9d6f1c78d 100644
--- a/lisp/ansi-color.el
+++ b/lisp/ansi-color.el
@@ -288,7 +288,7 @@ ansi-color-basic-faces-vector
   6        rapidly blinking
   7        negative image")
 
-(defvar ansi-color-normal-colors-vector
+(defvar ansi-color-colors-vector
   [ansi-color-black
    ansi-color-red
    ansi-color-green
@@ -296,12 +296,26 @@ ansi-color-normal-colors-vector
    ansi-color-blue
    ansi-color-magenta
    ansi-color-cyan
-   ansi-color-white]
+   ansi-color-white
+
+   ansi-color-bright-black
+   ansi-color-bright-red
+   ansi-color-bright-green
+   ansi-color-bright-yellow
+   ansi-color-bright-blue
+   ansi-color-bright-magenta
+   ansi-color-bright-cyan
+   ansi-color-bright-white]
+
   "Faces used for SGR control sequences determining a color.
-This vector holds the faces used for SGR control sequence parameters
-30 to 37 (foreground colors) and 40 to 47 (background colors).
+The first eight elements are faces used for SGR control sequence
+parameters 30 to 37 (foreground colors) and 40 to 47 (background
+colors).  The second eight elements are the faces used for SGR
+control sequence parameters 90 to 97 (bright foreground colors)
+and 100 to 107 (bright background colors).
 
 Parameter  Color
+
   30  40   black
   31  41   red
   32  42   green
@@ -309,23 +323,8 @@ ansi-color-normal-colors-vector
   34  44   blue
   35  45   magenta
   36  46   cyan
-  37  47   white")
-
-(defvar ansi-color-bright-colors-vector
-  [ansi-color-bright-black
-   ansi-color-bright-red
-   ansi-color-bright-green
-   ansi-color-bright-yellow
-   ansi-color-bright-blue
-   ansi-color-bright-magenta
-   ansi-color-bright-cyan
-   ansi-color-bright-white]
-  "Faces used for SGR control sequences determining a \"bright\" color.
-This vector holds the faces used for SGR control sequence parameters
-90 to 97 (bright foreground colors) and 100 to 107 (bright background
-colors).
+  37  47   white
 
-Parameter   Color
   90  100   bright black
   91  101   bright red
   92  102   bright green
@@ -458,11 +457,18 @@ 'ansi-color-unfontify-region
 ;; Working with strings
 (defvar-local ansi-color-context nil
   "Context saved between two calls to `ansi-color-apply'.
-This is a list of the form (CODES FRAGMENT) or nil.  CODES
+This is a list of the form (FACE-VEC FRAGMENT) or nil.  FACE-VEC
 represents the state the last call to `ansi-color-apply' ended
-with, currently a list of ansi codes, and FRAGMENT is a string
-starting with an escape sequence, possibly the start of a new
-escape sequence.")
+with, currently a list of the form
+
+(BASIC-FACES FG BG).
+
+BASIC-FACES is a bool-vector that specifies which basic faces
+from `ansi-color-basic-faces-vector' to apply.  FG and BG are
+ANSI color codes for the foreground and background color.
+
+FRAGMENT is a string starting with an escape sequence, possibly
+the start of a new escape sequence.")
 
 (defun ansi-color-filter-apply (string)
   "Filter out all ANSI control sequences from STRING.
@@ -494,20 +500,39 @@ ansi-color-filter-apply
       (setq ansi-color-context (if fragment (list nil fragment))))
     (apply #'concat (nreverse result))))
 
-(defun ansi-color--find-face (codes)
-  "Return the face corresponding to CODES."
-  ;; Sort the codes in ascending order to guarantee that "bold" comes before
-  ;; any of the colors.  This ensures that `ansi-color-bold-is-bright' is
-  ;; applied correctly.
-  (let (faces bright (codes (sort (copy-sequence codes) #'<)))
-    (while codes
-      (when-let ((face (ansi-color-get-face-1 (pop codes) bright)))
-        (when (and ansi-color-bold-is-bright (eq face 'ansi-color-bold))
-          (setq bright t))
-        (push face faces)))
+(defun ansi-color--face-vec-face (face-vec)
+  "Return the face corresponding to FACE-VEC.
+FACE-VEC is a list containing information about the ANSI sequence
+code.  It is usually stored as the car of the variable
+`ansi-color-context-region'."
+  (let* ((basic-faces (car face-vec))
+         (colors (cdr face-vec))
+         (bright (and ansi-color-bold-is-bright (aref basic-faces 1)))
+         (faces nil))
+
+    (when-let ((fg (car colors)))
+      (push
+       `(:foreground
+         ,(face-foreground
+           (aref ansi-color-colors-vector (logior (if bright 8 0) fg))
+           nil 'default))
+       faces))
+    (when-let ((bg (cadr colors)))
+      (push
+       `(:background
+         ,(face-background
+           (aref ansi-color-colors-vector (logior (if bright 8 0) bg))
+           nil 'default))
+       faces))
+
+    (let ((i 8))
+      (while (> i 0)
+        (setq i (1- i))
+        (when (aref basic-faces i)
+          (push (aref ansi-color-basic-faces-vector i) faces))))
     ;; Avoid some long-lived conses in the common case.
     (if (cdr faces)
-	(nreverse faces)
+        faces
       (car faces))))
 
 (defun ansi-color-apply (string)
@@ -524,49 +549,71 @@ ansi-color-apply
 Set `ansi-color-context' to nil if you don't want this.
 
 This function can be added to `comint-preoutput-filter-functions'."
-  (let ((codes (car ansi-color-context))
-	(start 0) end result)
+  (let* ((context
+          (or ansi-color-context
+              (setq ansi-color-context
+                    (list
+                     (list
+                      ;; 8 slots for the basic faces
+                      (make-bool-vector 8 nil)
+                      ;; 2 slots for fg and bg number
+                      nil nil)
+                     ""))))
+         (face-vec (car context))
+         (start 0)
+         end result)
     ;; If context was saved and is a string, prepend it.
-    (if (cadr ansi-color-context)
-        (setq string (concat (cadr ansi-color-context) string)
-              ansi-color-context nil))
+    (setq string (concat (cadr context) string))
+    (setcar (cdr context) "")
     ;; Find the next escape sequence.
     (while (setq end (string-match ansi-color-control-seq-regexp string start))
       (let ((esc-end (match-end 0)))
         ;; Colorize the old block from start to end using old face.
-        (when codes
+        (when-let ((face (ansi-color--face-vec-face face-vec)))
           (put-text-property start end 'font-lock-face
-                             (ansi-color--find-face codes) string))
+                             face string))
         (push (substring string start end) result)
         (setq start (match-end 0))
         ;; If this is a color escape sequence,
         (when (eq (aref string (1- esc-end)) ?m)
           ;; create a new face from it.
-          (setq codes (ansi-color-apply-sequence
-                       (substring string end esc-end) codes)))))
+          (let ((cur-pos end))
+            (ansi-color--update-face-vec
+             face-vec
+             (lambda ()
+               (when (string-match ansi-color-parameter-regexp
+                                   string cur-pos)
+                 (setq cur-pos (match-end 0))
+                 (when (<= cur-pos esc-end)
+                   (string-to-number (match-string 1 string))))))))))
     ;; if the rest of the string should have a face, put it there
-    (when codes
+    (when-let ((face (ansi-color--face-vec-face face-vec)))
       (put-text-property start (length string)
-                         'font-lock-face (ansi-color--find-face codes) string))
+                         'font-lock-face face string))
     ;; save context, add the remainder of the string to the result
-    (let (fragment)
-      (if (string-match "\033" string start)
-	  (let ((pos (match-beginning 0)))
-	    (setq fragment (substring string pos))
-	    (push (substring string start pos) result))
-	(push (substring string start) result))
-      (setq ansi-color-context (if (or codes fragment) (list codes fragment))))
+    (if (string-match "\033" string start)
+        (let ((pos (match-beginning 0)))
+          (setcar (cdr context) (substring string pos))
+          (push (substring string start pos) result))
+      (push (substring string start) result))
     (apply 'concat (nreverse result))))
 
 ;; Working with regions
 
 (defvar-local ansi-color-context-region nil
   "Context saved between two calls to `ansi-color-apply-on-region'.
-This is a list of the form (CODES MARKER) or nil.  CODES
+This is a list of the form (FACE-VEC MARKER) or nil.  FACE-VEC
 represents the state the last call to `ansi-color-apply-on-region'
-ended with, currently a list of ansi codes, and MARKER is a
-buffer position within an escape sequence or the last position
-processed.")
+ended with, currently a list of the form
+
+(BASIC-FACES FG BG).
+
+BASIC-FACES is a bool-vector that specifies which basic faces
+from `ansi-color-basic-faces-vector' to apply.  FG and BG are
+ANSI color codes for the foreground and background color.
+
+MARKER is a buffer position within an escape sequence or the last
+position processed.")
 
 (defun ansi-color-filter-region (begin end)
   "Filter out all ANSI control sequences from region BEGIN to END.
@@ -608,58 +655,63 @@ ansi-color-apply-on-region
 
 If PRESERVE-SEQUENCES is t, the sequences are hidden instead of
 being deleted."
-  (let ((codes (car ansi-color-context-region))
-        (start-marker (or (cadr ansi-color-context-region)
-                          (copy-marker begin)))
-        (end-marker (copy-marker end)))
+  (let* ((context
+          (or ansi-color-context-region
+              (setq ansi-color-context-region
+                    (list
+                     (list
+                      ;; 8 slots for the basic faces
+                      (make-bool-vector 8 nil)
+                      ;; 2 slots for fg and bg numbers
+                      nil nil)
+                     (copy-marker begin)))))
+         (face-vec (car context))
+         (start-marker (cadr context))
+         (end-marker (copy-marker end)))
     (save-excursion
       (goto-char start-marker)
       ;; Find the next escape sequence.
       (while (re-search-forward ansi-color-control-seq-regexp end-marker t)
         ;; Extract escape sequence.
-        (let ((esc-seq (buffer-substring
-                        (match-beginning 0) (point))))
-          (if preserve-sequences
-              ;; Make the escape sequence transparent.
-              (overlay-put (make-overlay (match-beginning 0) (point))
-                           'invisible t)
-            ;; Otherwise, strip.
-            (delete-region (match-beginning 0) (point)))
-
+        (let ((esc-beg (match-beginning 0))
+              (esc-end (point)))
           ;; Colorize the old block from start to end using old face.
           (funcall ansi-color-apply-face-function
                    (prog1 (marker-position start-marker)
                      ;; Store new start position.
-                     (set-marker start-marker (point)))
-                   (match-beginning 0) (ansi-color--find-face codes))
+                     (set-marker start-marker esc-end))
+                   esc-beg (ansi-color--face-vec-face face-vec))
           ;; If this is a color sequence,
-          (when (eq (aref esc-seq (1- (length esc-seq))) ?m)
-            ;; update the list of ansi codes.
-            (setq codes (ansi-color-apply-sequence esc-seq codes)))))
+          (when (eq (char-before esc-end) ?m)
+            (goto-char esc-beg)
+            (ansi-color--update-face-vec
+             face-vec (lambda ()
+                        (when (re-search-forward ansi-color-parameter-regexp
+                                                 esc-end t)
+                          (string-to-number (match-string 1))))))
+
+          (if preserve-sequences
+              ;; Make the escape sequence transparent.
+              (overlay-put (make-overlay esc-beg esc-end) 'invisible t)
+            ;; Otherwise, strip.
+            (delete-region esc-beg esc-end))))
       ;; search for the possible start of a new escape sequence
       (if (re-search-forward "\033" end-marker t)
-	  (progn
-	    ;; if the rest of the region should have a face, put it there
-	    (funcall ansi-color-apply-face-function
-		     start-marker (point) (ansi-color--find-face codes))
-	    ;; save codes and point
-	    (setq ansi-color-context-region
-		  (list codes (copy-marker (match-beginning 0)))))
-	;; if the rest of the region should have a face, put it there
-	(funcall ansi-color-apply-face-function
-		 start-marker end-marker (ansi-color--find-face codes))
-        ;; Save a restart position when there are codes active. It's
-        ;; convenient for man.el's process filter to pass `begin'
-        ;; positions that overlap regions previously colored; these
-        ;; `codes' should not be applied to that overlap, so we need
-        ;; to know where they should really start.
-	(setq ansi-color-context-region
-              (if codes (list codes (copy-marker (point)))))))
-    ;; Clean up our temporary markers.
-    (unless (eq start-marker (cadr ansi-color-context-region))
-      (set-marker start-marker nil))
-    (unless (eq end-marker (cadr ansi-color-context-region))
-      (set-marker end-marker nil))))
+          (progn
+            (while (re-search-forward "\033" end-marker t))
+            (backward-char))
+        (goto-char end-marker))
+      (funcall ansi-color-apply-face-function
+               start-marker (point)
+               (ansi-color--face-vec-face face-vec))
+      ;; Save a restart position when there are codes active. It's
+      ;; convenient for man.el's process filter to pass `begin'
+      ;; positions that overlap regions previously colored; these
+      ;; `codes' should not be applied to that overlap, so we need
+      ;; to know where they should really start.
+      (set-marker start-marker (point)))
+    ;; Clean up our temporary marker.
+    (set-marker end-marker nil)))
 
 (defun ansi-color-apply-overlay-face (beg end face)
   "Make an overlay from BEG to END, and apply face FACE.
@@ -767,6 +819,7 @@ ansi-color-apply-sequence
 is 40-47 (or 100-107) resp. 49, the background color code is replaced
 or added resp. deleted; any other code is discarded together with the
 old codes.  Finally, the so changed list of codes is returned."
+  (declare (obsolete "it isn't used any more." "28.1"))
   (let ((new-codes (ansi-color-parse-sequence escape-sequence)))
     (while new-codes
       (let* ((new (pop new-codes))
@@ -795,6 +848,56 @@ ansi-color-apply-sequence
 		(_ nil)))))
     codes))
 
+(defun ansi-color--update-face-vec (face-vec iterator)
+  "Apply escape sequences to FACE-VEC.
+
+Destructively modify FACE-VEC, which should be a list containing
+face information.  It is described in
+`ansi-color-context-region'.  ITERATOR is a function which is
+called repeatedly with zero arguments and should return either
+the next ANSI code in the current sequence as a number or nil if
+there are no more ANSI codes left
+
+For each new code, the following happens: if it is 1-7, set the
+corresponding properties; if it is 21-25 or 27, unset appropriate
+properties; if it is 30-37 (or 90-97) or resp. 39, set the
+foreground color or resp. unset it; if it is 40-47 (or 100-107)
+resp. 49, set the background color or resp. unset it; if it is 38
+or 48, the following codes are used to set the foreground or
+background color and the correct color mode; any other code will
+unset all properties and colors."
+  (let ((basic-faces (car face-vec))
+        (colors (cdr face-vec))
+        new q do-clear)
+    (while (setq new (funcall iterator))
+      (setq q (/ new 10))
+      (pcase q
+        (0 (if (memq new '(0 8 9))
+               (setq do-clear t)
+             (aset basic-faces new t)))
+        (2 (if (memq new '(20 26 28 29))
+               (setq do-clear t)
+             ;; The standard says `21 doubly underlined' while
+             ;; https://en.wikipedia.org/wiki/ANSI_escape_code claims
+             ;; `21 Bright/Bold: off or Underline: Double'.
+             (aset basic-faces (- new 20) nil)
+             (aset basic-faces (pcase new (22 1) (25 6) (_ 0)) nil)))
+        ((or 3 4 9 10)
+         (let ((r (mod new 10))
+               (cell (if (memq q '(3 9)) colors (cdr colors))))
+           (pcase r
+             (8 (setq do-clear t))
+             (9 (setcar cell nil))
+             (_ (setcar cell (+ (if (memq q '(3 4)) 0 8) r))))))
+        (_ (setq do-clear t)))
+
+      (when do-clear
+        (setq do-clear nil)
+        ;; Zero out our bool vector without any allocation
+        (bool-vector-intersection basic-faces #&8"\0" basic-faces)
+        (setcar colors nil)
+        (setcar (cdr colors) nil)))))
+
 (defun ansi-color-make-color-map ()
   "Create a vector of face definitions and return it.
 
@@ -859,6 +962,7 @@ ansi-color-get-face-1
   "Get face definition for ANSI-CODE.
 BRIGHT, if non-nil, requests \"bright\" ANSI colors, even if ANSI-CODE
 is a normal-intensity color."
+  (declare (obsolete "it isn't used any more." "28.1"))
   (when (and bright (<= 30 ansi-code 49))
     (setq ansi-code (+ ansi-code 60)))
   (cond ((<= 0 ansi-code 7)
@@ -866,22 +970,22 @@ ansi-color-get-face-1
         ((<= 30 ansi-code 38)
          (list :foreground
                (face-foreground
-                (aref ansi-color-normal-colors-vector (- ansi-code 30))
+                (aref ansi-color-colors-vector (- ansi-code 30))
                 nil 'default)))
         ((<= 40 ansi-code 48)
          (list :background
                (face-background
-                (aref ansi-color-normal-colors-vector (- ansi-code 40))
+                (aref ansi-color-colors-vector (- ansi-code 40))
                 nil 'default)))
         ((<= 90 ansi-code 98)
          (list :foreground
                (face-foreground
-                (aref ansi-color-bright-colors-vector (- ansi-code 90))
+                (aref ansi-color-colors-vector (+ 8 (- ansi-code 90)))
                 nil 'default)))
         ((<= 100 ansi-code 108)
          (list :background
                (face-background
-                (aref ansi-color-bright-colors-vector (- ansi-code 100))
+                (aref ansi-color-colors-vector (+ 8 (- ansi-code 100)))
                 nil 'default)))))
 
 (provide 'ansi-color)
-- 
2.33.0


[-- Attachment #1.3: ansi-color-benchmark.org --]
[-- Type: application/vnd.lotus-organizer, Size: 1995 bytes --]

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 861 bytes --]