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

[Alan Mackenzie <acm@muc.de>]

Hello, Eli and Stefan.

On Fri, Sep 03, 2021 at 16:52:55 +0000, Alan Mackenzie wrote:
> On Fri, Sep 03, 2021 at 09:10:24 +0300, Eli Zaretskii wrote:
> > > Date: Thu, 2 Sep 2021 19:24:51 +0000
> > > From: Alan Mackenzie <acm@muc.de>
> > > Cc: emacs-devel@gnu.org

> > > In words (;-), only the first function on jit-lock-functions should
> > > be able to expand the region which gets `fontified' text properties.
> > > This expanded region will then be supplied to the subsequent
> > > functions.

> > > Given how little used the `jit-lock-bounds' mechanism is (there is
> > > one function in Emacs, font-lock-default-fontify-region, which uses
> > > it, and a web search revealed only a single other instance, in
> > > lsp-mode on git-hub), this shouldn't cause problems.  In fact, I'm
> > > not sure the lsp-mode use of it is even correct.

> > Bother: this is not future-proof, and certainly isn't scalable.  If we
> > are changing the protocol, can we instead come up with a more scalable
> > change, so that functions won't "fight" in the future who gets to be
> > "the first"?

> OK, so the problem is how do we cope with two (or even several) "first"
> functions?

> How about something like this:
> o - We still have a first function, font-lock-fontify-region.
> o - We call the next function with the jit-lock-bounds returned by the
>   previous one.  Repeat this step with steadily expanding bounds for
>   each function in jit-lock-functions.
> o - if (< BEG-final BEG-1) we go through jit-lock-functions again on the
>   region (BEG-final BEG-1).  Do the same for END-final.  During this
>   stage, we ignore the returned jit-lock-bounds.
> o - We set the `fontified' text properties on the region (BEG-final
>   END-final).

> This needn't actually be too complicated.  The current
> jit-lock--run-functions already calculates BEG-final and END-final (it
> calls them loose-beg and loose-end).

> For this mechanism, it would still be best to have all the functions
> using jit-lock-bounds together at the start of jit-lock-functions,
> though this would be an optimsation rather than essential to the
> functionality.

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.



(defun jit-lock--run-functions (beg 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*
           ;; 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))))
         (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)))
    `(,(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 res-end)
      ;; 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.
Defaults to the whole buffer.  END can be out of bounds."
  (with-buffer-prepared-for-jit-lock
   (save-excursion
     (unless start (setq start (point-min)))
     (setq end (if end (min end (point-max)) (point-max)))
     (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)))))))))


-- 
Alan Mackenzie (Nuremberg, Germany).