Re: bug-reference-prog-mode slows down CC Mode's scrolling by ~7%

[Alan Mackenzie <acm@muc.de>]

Hello, Eli.

On Sat, Sep 04, 2021 at 09:09:10 +0300, Eli Zaretskii wrote:
> > Date: Fri, 3 Sep 2021 20:51:22 +0000
> > Cc: monnier@iro.umontreal.ca, emacs-devel@gnu.org
> > From: Alan Mackenzie <acm@muc.de>

> > OK, I've hacked up a trial implementation, though I haven't started
> > testing it yet.  The key is to extract jit-lock--fontify-now-1 from
> > jit-lock-fontify-now, and have it call itself recursively to handle the
> > expansion of the region caused by a jit-lock-bounds returned by the
> > second or later function.

> > This should be easy to test and verify as correct, yet the recursion
> > should be invoked rarely enough that it won't lead to inefficiencies.

> > This implementation should resolve Eli's concerns about handling two
> > or more "first" functions in jit-lock-functions.

> Thanks.

OK, here's a working patch.  When I run my favourite benchmark,
time-scroll on xdisp.c, ....

(defmacro time-it (&rest forms)
  "Time the running of a sequence of forms using `float-time'.
Call like this: \"M-: (time-it (foo ...) (bar ...) ...)\"."
  `(let ((start (float-time)))
    ,@forms
    (- (float-time) start)))

(defun time-scroll (&optional arg)
  (interactive "P")
  (message "%s"
           (time-it
            (condition-case nil
                (while t
                  (if arg (scroll-down) (scroll-up))
                  (sit-for 0))
              (error nil)))))

..... it takes 21.2s.

This is with jit-lock-functions set to 

    (font-lock-fontify-region bug-reference-fontify t)

..  However, with the order of these functions reversed:

    (bug-reference-fontify font-lock-fontify-region t)

, it takes 27.9s.  So it would seem the cost of having a jit-lock
function returning a jit-lock-bounds structure when it's not the first
function is high.  That's using the strategy of a full refontification of
the "extra" regions of the buffer returned in that structure.  Maybe that
strategy is not optimal.

Here's the current version of the patch:



diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el
index a1287926eb..0c71201e6b 100644
--- a/lisp/jit-lock.el
+++ b/lisp/jit-lock.el
@@ -378,28 +378,90 @@ jit-lock-function
 			  'fontified 'defer)))))
 
 (defun jit-lock--run-functions (beg end)
-  (let ((tight-beg nil) (tight-end nil)
-        (loose-beg beg) (loose-end end))
+  (let ((tight-beg nil) (tight-end nil) ; The region we have fully fontified.
+        (loose-beg beg) (loose-end end)) ; The maximum region we have fontified
+                                         ; with at least some of
+                                         ; `jit-lock-functions'.
     (run-hook-wrapped
      'jit-lock-functions
      (lambda (fun)
        (pcase-let*
-           ((res (funcall fun beg end))
+           ;; The first function in `jit-lock-functions' can expand
+           ;; the region into `tight-beg' and `tight-end'.  These
+           ;; arguments are passed to the next function (if any).
+           ;; Subsequently, the expanded region from any function is
+           ;; stored in `loose-beg' and `loose-end', and is likewise
+           ;; passed to the next function.
+           ((res (funcall fun loose-beg loose-end))
             (`(,this-beg . ,this-end)
              (if (eq (car-safe res) 'jit-lock-bounds)
                  (cdr res) (cons beg end))))
-         ;; If all functions don't fontify the same region, we currently
-         ;; just try to "still be correct".  But we could go further and for
-         ;; the chunks of text that was fontified by some functions but not
-         ;; all, we could add text-properties indicating which functions were
-         ;; already run to avoid running them redundantly when we get to
-         ;; those chunks.
-         (setq tight-beg (max (or tight-beg (point-min)) this-beg))
-         (setq tight-end (min (or tight-end (point-max)) this-end))
+         (or tight-beg (setq tight-beg (min this-beg beg)))
+         (or tight-end (setq tight-end (max this-end end)))
          (setq loose-beg (min loose-beg this-beg))
          (setq loose-end (max loose-end this-end))
          nil)))
-    `(,(min tight-beg beg) ,(max tight-end end) ,loose-beg ,loose-end)))
+    `(,(or tight-beg beg) ,(or tight-end end) ,loose-beg ,loose-end)))
+
+(defun jit-lock--fontify-now-1 (start end)
+  "Fontify current buffer from START to END, possibly more.
+Return the list (RES-START RES-END), the entire region which was fontified."
+  (let ((res-start start) (res-end end) next)
+    ;; Fontify chunks beginning at START.  The end of a chunk is
+    ;; either `end', or the start of a region before `end' that has
+    ;; already been fontified.
+    (while (and start (< start end))
+      ;; Determine the end of this chunk.
+      (setq next (or (text-property-any start end 'fontified t)
+                     end))
+
+      ;; Avoid unnecessary work if the chunk is empty (bug#23278).
+      (when (> next start)
+        ;; Fontify the chunk, and mark it as fontified.  We mark it
+        ;; first, to make sure that we don't indefinitely re-execute
+        ;; this fontification if an error occurs.
+        (put-text-property start next 'fontified t)
+        (pcase-let
+            ;; `tight' is the part we've fully refontified, and
+            ;; `loose' is the part we've partly refontified (some of
+            ;; the functions have refontified it but maybe not all).
+            ((`(,tight-beg ,tight-end ,loose-beg ,loose-end)
+              (condition-case err
+                  (jit-lock--run-functions start next)
+                ;; If the user quits (which shouldn't happen in normal
+                ;; on-the-fly jit-locking), make sure the fontification
+                ;; will be performed before displaying the block again.
+                (quit (put-text-property start next 'fontified nil)
+                      (signal (car err) (cdr err))))))
+
+          ;; In case we fontified more than requested, take advantage
+          ;; of the good news.
+          (when (or (< tight-beg start) (> tight-end next))
+            (put-text-property tight-beg tight-end 'fontified t))
+
+          ;; If we've partially fontified (i.e. only run some
+          ;; `jit-lock-functions' on parts of the buffer beyond (START
+          ;; END), refontify those parts entirely.
+          (when (< loose-beg tight-beg)
+            (pcase-let
+                ((`(,sub-beg ,_)
+                  (jit-lock--fontify-now-1 loose-beg tight-beg)))
+              (setq tight-beg sub-beg)))
+          (when (> loose-end tight-end)
+            (pcase-let
+                ((`(,_ ,sub-end)
+                  (jit-lock--fontify-now-1 tight-end loose-end)))
+              (setq tight-end sub-end)))
+
+          (setq res-start (min res-start tight-beg)
+                res-end (max res-end tight-end))))
+
+      ;; Skip to the end of the fully refontified part.
+      (setq start next)
+      ;; Find the start of the next chunk, if any.
+      (setq start (text-property-any start end 'fontified nil)))
+
+    (list res-start res-end)))
 
 (defun jit-lock-fontify-now (&optional start end)
   "Fontify current buffer from START to END.
@@ -408,72 +470,39 @@ jit-lock-fontify-now
    (save-excursion
      (unless start (setq start (point-min)))
      (setq end (if end (min end (point-max)) (point-max)))
-     (let ((orig-start start) next)
-       (save-match-data
-	 ;; Fontify chunks beginning at START.  The end of a
-	 ;; chunk is either `end', or the start of a region
-	 ;; before `end' that has already been fontified.
-	 (while (and start (< start end))
-	   ;; Determine the end of this chunk.
-	   (setq next (or (text-property-any start end 'fontified t)
-			  end))
-
-           ;; Avoid unnecessary work if the chunk is empty (bug#23278).
-           (when (> next start)
-             ;; Fontify the chunk, and mark it as fontified.
-             ;; We mark it first, to make sure that we don't indefinitely
-             ;; re-execute this fontification if an error occurs.
-             (put-text-property start next 'fontified t)
-             (pcase-let
-                 ;; `tight' is the part we've fully refontified, and `loose'
-                 ;; is the part we've partly refontified (some of the
-                 ;; functions have refontified it but maybe not all).
-                 ((`(,tight-beg ,tight-end ,loose-beg ,_loose-end)
-                   (condition-case err
-                       (jit-lock--run-functions start next)
-                     ;; If the user quits (which shouldn't happen in normal
-                     ;; on-the-fly jit-locking), make sure the fontification
-                     ;; will be performed before displaying the block again.
-                     (quit (put-text-property start next 'fontified nil)
-                           (signal (car err) (cdr err))))))
-
-               ;; In case we fontified more than requested, take
-               ;; advantage of the good news.
-               (when (or (< tight-beg start) (> tight-end next))
-                 (put-text-property tight-beg tight-end 'fontified t))
-
-               ;; Make sure the contextual refontification doesn't re-refontify
-               ;; what's already been refontified.
-               (when (and jit-lock-context-unfontify-pos
-                          (< jit-lock-context-unfontify-pos tight-end)
-                          (>= jit-lock-context-unfontify-pos tight-beg)
-                          ;; Don't move boundary forward if we have to
-                          ;; refontify previous text.  Otherwise, we risk moving
-                          ;; it past the end of the multiline property and thus
-                          ;; forget about this multiline region altogether.
-                          (not (get-text-property tight-beg
-                                                  'jit-lock-defer-multiline)))
-                 (setq jit-lock-context-unfontify-pos tight-end))
-
-               ;; The redisplay engine has already rendered the buffer up-to
-               ;; `orig-start' and won't notice if the above jit-lock-functions
-               ;; changed the appearance of any part of the buffer prior
-               ;; to that.  So if `loose-beg' is before `orig-start', we need to
-               ;; cause a new redisplay cycle after this one so that the changes
-               ;; are properly reflected on screen.
-               ;; To make such repeated redisplay happen less often, we can
-               ;; eagerly extend the refontified region with
-               ;; jit-lock-after-change-extend-region-functions.
-               (when (< loose-beg orig-start)
-                 (run-with-timer 0 nil #'jit-lock-force-redisplay
-                                 (copy-marker loose-beg)
-                                 (copy-marker orig-start)))
-
-               ;; Skip to the end of the fully refontified part.
-               (setq start tight-end)))
-           ;; Find the start of the next chunk, if any.
-           (setq start
-                 (text-property-any start end 'fontified nil))))))))
+     (save-match-data
+       (let ((orig-start start))
+         (pcase-let
+             ;; `tight' is the part we've fully refontified.
+             ((`(,tight-beg ,tight-end)
+               (jit-lock--fontify-now-1 start end)))
+
+           ;; Make sure the contextual refontification doesn't re-refontify
+           ;; what's already been refontified.
+           (when (and jit-lock-context-unfontify-pos
+                      (< jit-lock-context-unfontify-pos tight-end)
+                      (>= jit-lock-context-unfontify-pos tight-beg)
+                      ;; Don't move boundary forward if we have to
+                      ;; refontify previous text.  Otherwise, we risk moving
+                      ;; it past the end of the multiline property and thus
+                      ;; forget about this multiline region altogether.
+                      (not (get-text-property tight-beg
+                                              'jit-lock-defer-multiline)))
+             (setq jit-lock-context-unfontify-pos tight-end))
+
+           ;; The redisplay engine has already rendered the buffer up-to
+           ;; `orig-start' and won't notice if the above jit-lock-functions
+           ;; changed the appearance of any part of the buffer prior
+           ;; to that.  So if `tight-beg' is before `orig-start', we need to
+           ;; cause a new redisplay cycle after this one so that the changes
+           ;; are properly reflected on screen.
+           ;; To make such repeated redisplay happen less often, we can
+           ;; eagerly extend the refontified region with
+           ;; jit-lock-after-change-extend-region-functions.
+           (when (< tight-beg orig-start)
+             (run-with-timer 0 nil #'jit-lock-force-redisplay
+                             (copy-marker tight-beg)
+                             (copy-marker orig-start)))))))))
 
 (defun jit-lock-force-redisplay (start end)
   "Force the display engine to re-render START's buffer from START to END.


-- 
Alan Mackenzie (Nuremberg, Germany).