master 15b2138719: (syntax-wholeline-max): New var

[Stefan Monnier]

branch: master
commit 15b2138719b34083967001c3903e7560d5e0947c
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    (syntax-wholeline-max): New var
    
    Try and reduce the pain caused by font-lock and syntax-propertize's
    wholeline-based operation in buffers made up of a few very long lines
    (bug#45898).
    
    * lisp/emacs-lisp/syntax.el (syntax-wholeline-max): New var.
    (syntax--lbp): New function.
    (syntax-propertize-wholelines): Use it.
    
    * lisp/jit-lock.el (jit-lock--antiblink-post-command): Use `syntax--lbp`.
    
    * lisp/font-lock.el (font-lock-extend-region-wholelines): Rewrite,
    using `syntax-propertize-wholelines`.
---
 etc/NEWS                  | 11 +++++++++++
 lisp/emacs-lisp/syntax.el | 46 ++++++++++++++++++++++++++++++++++++++++------
 lisp/font-lock.el         | 33 +++++++++++++--------------------
 lisp/jit-lock.el          | 21 +++++++++++----------
 4 files changed, 75 insertions(+), 36 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index e757435ff9..d3dd896526 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -317,6 +317,17 @@ startup.  Previously, these functions ignored
 
 * Changes in Emacs 29.1
 
+** New config variable 'syntax-wholeline-max' to reduce the cost of long lines.
+This variable is used by some operations (mostly syntax-propertization
+and font-locking) to treat lines longer than this variable as if they
+were made up of various smaller lines.  This can help reduce the
+pathological slowdowns seen in buffers made of a single long line, but
+can also cause misbehavior in the presence of such long lines (tho
+most of that misbehavior should usually be limited to mis-highlighting).
+You can recover the previous behavior with:
+
+    (setq syntax-wholeline-max most-positive-fixnum)
+
 ---
 ** New bindings in 'find-function-setup-keys' for 'find-library'.
 When 'find-function-setup-keys' is enabled, 'C-x L' is now bound to
diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el
index 36b0c56e95..e1be301583 100644
--- a/lisp/emacs-lisp/syntax.el
+++ b/lisp/emacs-lisp/syntax.el
@@ -124,15 +124,49 @@ When the last position scanned holds the first character 
of a
 otherwise nil.  That construct can be a two character comment
 delimiter or an Escaped or Char-quoted character."))
 
-(defun syntax-propertize-wholelines (start end)
-  "Extend the region delimited by START and END to whole lines.
+(defvar syntax-wholeline-max 10000
+  "Maximum line length for syntax operations.
+If lines are longer than that, syntax operations will treat them as chunks
+of this size.  Misfontification may then occur.
+This is a tradeoff between correctly applying the syntax rules,
+and avoiding major slowdown on pathologically long lines.")
+
+(defun syntax--lbp (&optional arg)
+  "Like `line-beginning-position' but obeying `syntax-wholeline-max'."
+  (let ((pos (point))
+        (res (line-beginning-position arg)))
+    (cond
+     ((< (abs (- pos res)) syntax-wholeline-max) res)
+     ;; For lines that are too long, round to the nearest multiple of
+     ;; `syntax-wholeline-max'.  We use rounding rather than just
+     ;; (min res (+ pos syntax-wholeline-max)) so that repeated calls
+     ;; to `syntax-propertize-wholelines' don't keep growing the bounds,
+     ;; i.e. it really behaves like additional line-breaks.
+     ((< res pos)
+      (let ((max syntax-wholeline-max))
+        (max (point-min) (* max (truncate pos max)))))
+     (t
+      (let ((max syntax-wholeline-max))
+        (min (point-max) (* max (ceiling pos max))))))))
+
+(defun syntax-propertize-wholelines (beg end)
+  "Extend the region delimited by BEG and END to whole lines.
 This function is useful for
 `syntax-propertize-extend-region-functions';
 see Info node `(elisp) Syntax Properties'."
-  (goto-char start)
-  (cons (line-beginning-position)
-        (progn (goto-char end)
-               (if (bolp) (point) (line-beginning-position 2)))))
+  ;; This let-binding was taken from
+  ;; `font-lock-extend-region-wholelines' where it was used to avoid
+  ;; inf-looping (Bug#21615) but for some reason it was not applied
+  ;; here in syntax.el and was used only for the "beg" side.
+  (let ((inhibit-field-text-motion t))
+    (let ((new-beg (progn (goto-char beg)
+                          (if (bolp) beg
+                            (syntax--lbp))))
+          (new-end (progn (goto-char end)
+                          (if (bolp) end
+                            (syntax--lbp 2)))))
+      (unless (and (eql beg new-beg) (eql end new-end))
+        (cons new-beg new-end)))))
 
 (defun syntax-propertize-multiline (beg end)
   "Let `syntax-propertize' pay attention to the syntax-multiline property."
diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index df0a26f4d0..7eeaf2f547 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -1260,18 +1260,11 @@ Put first the functions more likely to cause a change 
and cheaper to compute.")
 
 (defun font-lock-extend-region-wholelines ()
   "Move fontification boundaries to beginning of lines."
-  (let ((changed nil))
-    (goto-char font-lock-beg)
-    (unless (bolp)
-      (setq changed t font-lock-beg
-            (let ((inhibit-field-text-motion t))
-              (line-beginning-position))))
-    (goto-char font-lock-end)
-    (unless (bolp)
-      (unless (eq font-lock-end
-                  (setq font-lock-end (line-beginning-position 2)))
-        (setq changed t)))
-    changed))
+  (let ((new (syntax-propertize-wholelines font-lock-beg font-lock-end)))
+    (when new
+      (setq font-lock-beg (car new))
+      (setq font-lock-end (cdr new))
+      t)))
 
 (defun font-lock-default-fontify-region (beg end loudly)
   "Fontify the text between BEG and END.
@@ -1565,7 +1558,7 @@ see `font-lock-syntactic-keywords'."
        (or (nth 3 highlight)
            (error "No match %d in highlight %S" match highlight))
       (when (and (consp value) (not (numberp (car value))))
-       (setq value (eval value)))
+       (setq value (eval value t)))
       (when (stringp value) (setq value (string-to-syntax value)))
       ;; Flush the syntax-cache.  I believe this is not necessary for
       ;; font-lock's use of syntax-ppss, but I'm not 100% sure and it can
@@ -1589,7 +1582,7 @@ KEYWORDS should be of the form MATCH-ANCHORED, see 
`font-lock-keywords',
 LIMIT can be modified by the value of its PRE-MATCH-FORM."
   (let ((matcher (nth 0 keywords)) (lowdarks (nthcdr 3 keywords)) highlights
        ;; Evaluate PRE-MATCH-FORM.
-       (pre-match-value (eval (nth 1 keywords))))
+       (pre-match-value (eval (nth 1 keywords) t)))
     ;; Set LIMIT to value of PRE-MATCH-FORM or the end of line.
     (if (and (numberp pre-match-value) (> pre-match-value (point)))
        (setq limit pre-match-value)
@@ -1605,7 +1598,7 @@ LIMIT can be modified by the value of its PRE-MATCH-FORM."
          (font-lock-apply-syntactic-highlight (car highlights))
          (setq highlights (cdr highlights)))))
     ;; Evaluate POST-MATCH-FORM.
-    (eval (nth 2 keywords))))
+    (eval (nth 2 keywords) t)))
 
 (defun font-lock-fontify-syntactic-keywords-region (start end)
   "Fontify according to `font-lock-syntactic-keywords' between START and END.
@@ -1718,7 +1711,7 @@ HIGHLIGHT should be of the form MATCH-HIGHLIGHT, see 
`font-lock-keywords'."
        ;; No match but we might not signal an error.
        (or (nth 3 highlight)
            (error "No match %d in highlight %S" match highlight))
-      (let ((val (eval (nth 1 highlight))))
+      (let ((val (eval (nth 1 highlight) t)))
        (when (eq (car-safe val) 'face)
          (add-text-properties start end (cddr val))
          (setq val (cadr val)))
@@ -1753,7 +1746,7 @@ LIMIT can be modified by the value of its PRE-MATCH-FORM."
   (let ((matcher (nth 0 keywords)) (lowdarks (nthcdr 3 keywords)) highlights
        (lead-start (match-beginning 0))
        ;; Evaluate PRE-MATCH-FORM.
-       (pre-match-value (eval (nth 1 keywords))))
+       (pre-match-value (eval (nth 1 keywords) t)))
     ;; Set LIMIT to value of PRE-MATCH-FORM or the end of line.
     (if (not (and (numberp pre-match-value) (> pre-match-value (point))))
        (setq limit (line-end-position))
@@ -1778,7 +1771,7 @@ LIMIT can be modified by the value of its PRE-MATCH-FORM."
          (font-lock-apply-highlight (car highlights))
          (setq highlights (cdr highlights)))))
     ;; Evaluate POST-MATCH-FORM.
-    (eval (nth 2 keywords))))
+    (eval (nth 2 keywords) t)))
 
 (defun font-lock-fontify-keywords-region (start end &optional loudly)
   "Fontify according to `font-lock-keywords' between START and END.
@@ -1884,7 +1877,7 @@ If SYNTACTIC-KEYWORDS is non-nil, it means these keywords 
are used for
   (cond ((or (functionp keyword) (nlistp keyword)) ; MATCHER
         (list keyword '(0 font-lock-keyword-face)))
        ((eq (car keyword) 'eval)               ; (eval . FORM)
-        (font-lock-compile-keyword (eval (cdr keyword))))
+        (font-lock-compile-keyword (eval (cdr keyword) t)))
        ((eq (car-safe (cdr keyword)) 'quote)   ; (MATCHER . 'FORM)
         ;; If FORM is a FACENAME then quote it.  Otherwise ignore the quote.
         (if (symbolp (nth 2 keyword))
@@ -1905,7 +1898,7 @@ If SYNTACTIC-KEYWORDS is non-nil, it means these keywords 
are used for
       keywords
     (font-lock-eval-keywords (if (fboundp keywords)
                                 (funcall keywords)
-                              (eval keywords)))))
+                              (eval keywords t)))))
 
 (defun font-lock-value-in-major-mode (values)
   "If VALUES is a list, use `major-mode' as a key and return the `assq' value.
diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el
index 17969d5762..a3ada44370 100644
--- a/lisp/jit-lock.el
+++ b/lisp/jit-lock.el
@@ -242,20 +242,20 @@ If you need to debug code run from jit-lock, see 
`jit-lock-debug-mode'."
     (when (and jit-lock-stealth-time (null jit-lock-stealth-timer))
       (setq jit-lock-stealth-timer
             (run-with-idle-timer jit-lock-stealth-time t
-                                 'jit-lock-stealth-fontify)))
+                                 #'jit-lock-stealth-fontify)))
 
     ;; Create, but do not activate, the idle timer for repeated
     ;; stealth fontification.
     (when (and jit-lock-stealth-time (null jit-lock-stealth-repeat-timer))
       (setq jit-lock-stealth-repeat-timer (timer-create))
       (timer-set-function jit-lock-stealth-repeat-timer
-                          'jit-lock-stealth-fontify '(t)))
+                          #'jit-lock-stealth-fontify '(t)))
 
     ;; Init deferred fontification timer.
     (when (and jit-lock-defer-time (null jit-lock-defer-timer))
       (setq jit-lock-defer-timer
             (run-with-idle-timer jit-lock-defer-time t
-                                 'jit-lock-deferred-fontify)))
+                                 #'jit-lock-deferred-fontify)))
 
     ;; Initialize contextual fontification if requested.
     (when (eq jit-lock-contextually t)
@@ -265,13 +265,13 @@ If you need to debug code run from jit-lock, see 
`jit-lock-debug-mode'."
                                    (lambda ()
                                      (unless jit-lock--antiblink-grace-timer
                                        (jit-lock-context-fontify))))))
-      (add-hook 'post-command-hook 'jit-lock--antiblink-post-command nil t)
+      (add-hook 'post-command-hook #'jit-lock--antiblink-post-command nil t)
       (setq jit-lock-context-unfontify-pos
             (or jit-lock-context-unfontify-pos (point-max))))
 
     ;; Setup our hooks.
-    (add-hook 'after-change-functions 'jit-lock-after-change nil t)
-    (add-hook 'fontification-functions 'jit-lock-function nil t))
+    (add-hook 'after-change-functions #'jit-lock-after-change nil t)
+    (add-hook 'fontification-functions #'jit-lock-function nil t))
 
    ;; Turn Just-in-time Lock mode off.
    (t
@@ -294,8 +294,9 @@ If you need to debug code run from jit-lock, see 
`jit-lock-debug-mode'."
         (setq jit-lock-defer-timer nil)))
 
     ;; Remove hooks.
-    (remove-hook 'after-change-functions 'jit-lock-after-change t)
-    (remove-hook 'fontification-functions 'jit-lock-function))))
+    (remove-hook 'post-command-hook #'jit-lock--antiblink-post-command t)
+    (remove-hook 'after-change-functions #'jit-lock-after-change t)
+    (remove-hook 'fontification-functions #'jit-lock-function))))
 
 (define-minor-mode jit-lock-debug-mode
   "Minor mode to help debug code run from jit-lock.
@@ -707,8 +708,8 @@ will take place when text is fontified stealthily."
               (min jit-lock-context-unfontify-pos jit-lock-start))))))
 
 (defun jit-lock--antiblink-post-command ()
-  (let* ((new-l-b-p (copy-marker (line-beginning-position)))
-         (l-b-p-2 (line-beginning-position 2))
+  (let* ((new-l-b-p (copy-marker (syntax--lbp)))
+         (l-b-p-2 (syntax--lbp 2))
          (same-line
           (and jit-lock-antiblink-grace
                (not (= new-l-b-p l-b-p-2))