Re: jit-lock refontifies too much

[martin rudalics]

> My gut feeling is that this is way past the point of diminishing returns.
> Already his optimization is rarely noticeable, but breaks a couple
> (rare) special cases.
>

In the patch below I provide three variables recording the behavior of
contextual fontification

jit-lock-fail-change records the number of modifications the patch
couldn't handle because a buffer change did not occur within the bounds
of a previous change

jit-lock-fail-context records the number of buffer modifications where
syntactic context changed, including modifications of elisp doc-strings

jit-lock-succ-context records the number of buffer modifications where
contextual refontification was avoided

I believe that the patch would be useful if and only if (1) it does not
break existing code, (2) redisplay doesn't suffer noticeable delay due
to before-change-functions, (3) the value of jit-lock-succ-context
exceeds the sum of jit-lock-fail-change and jit-lock-fail-context
significantly, that is by a factor of two or three at least.


--- jit-lock.el 2005-08-18 09:58:40.000000000 +0200
+++ jit-lock.el 2005-09-28 14:17:28.000000000 +0200
@@ -164,6 +164,19 @@
 If nil, contextual fontification is disabled.")
 (make-variable-buffer-local 'jit-lock-context-unfontify-pos)

+(defvar jit-lock-context-start (make-marker)
+  "Position preceding text affected by latest sequence of buffer changes.
+A marker that stays behind when text is inserted there.")
+
+(defvar jit-lock-context-end (make-marker)
+  "Position following text affected by latest sequence of buffer changes.
+A marker that advances when text is inserted there.")
+(set-marker-insertion-type jit-lock-context-end t)
+
+(defvar jit-lock-context-ppss nil
+ "ppss recorded before the latest sequence of buffer changes.
+This state is recorded by `jit-lock-before-change' at position
+`jit-lock-context-end' before the first of these changes.")

 (defvar jit-lock-stealth-timer nil
   "Timer for stealth fontification in Just-in-time Lock mode.")
@@ -229,6 +242,7 @@

         ;; Initialize contextual fontification if requested.
         (when (eq jit-lock-contextually t)
+          (add-hook 'before-change-functions 'jit-lock-before-change nil t)
           (unless jit-lock-context-timer
             (setq jit-lock-context-timer
                   (run-with-idle-timer jit-lock-context-time t
@@ -258,9 +272,13 @@
             (setq jit-lock-context-timer nil))
           (when jit-lock-defer-timer
             (cancel-timer jit-lock-defer-timer)
-            (setq jit-lock-defer-timer nil)))
+            (setq jit-lock-defer-timer nil))
+          ;; Reset markers.
+          (set-marker jit-lock-context-start nil)
+          (set-marker jit-lock-context-end nil))

         ;; Remove hooks.
+        (remove-hook 'before-change-functions 'jit-lock-before-change t)
         (remove-hook 'after-change-functions 'jit-lock-after-change t)
         (remove-hook 'fontification-functions 'jit-lock-function))))

@@ -509,38 +527,97 @@
     (with-current-buffer buffer
       (when jit-lock-context-unfontify-pos
        ;; (message "Jit-Context %s" (buffer-name))
-       (save-restriction
-         (widen)
-         (when (and (>= jit-lock-context-unfontify-pos (point-min))
-                    (< jit-lock-context-unfontify-pos (point-max)))
-           ;; If we're in text that matches a complex multi-line
-           ;; font-lock pattern, make sure the whole text will be
-           ;; redisplayed eventually.
-           ;; Despite its name, we treat jit-lock-defer-multiline here
-           ;; rather than in jit-lock-defer since it has to do with multiple
-           ;; lines, i.e. with context.
-           (when (get-text-property jit-lock-context-unfontify-pos
-                                    'jit-lock-defer-multiline)
-             (setq jit-lock-context-unfontify-pos
-                   (or (previous-single-property-change
-                        jit-lock-context-unfontify-pos
-                        'jit-lock-defer-multiline)
-                       (point-min))))
-           (with-buffer-prepared-for-jit-lock
-            ;; Force contextual refontification.
-            (remove-text-properties
-             jit-lock-context-unfontify-pos (point-max)
-             '(fontified nil jit-lock-defer-multiline nil)))
-           (setq jit-lock-context-unfontify-pos (point-max))))))))
+       (save-excursion
+         (save-restriction
+           (widen)
+
+           ;; If `jit-lock-context-start' points into current buffer
+           ;; investigate latest sequence of buffer modifications.
+           (when (eq (marker-buffer jit-lock-context-start) (current-buffer))
+             ;; Record ppss for `jit-lock-context-end' - a position following
+             ;; the latest sequence of buffer changes - and compare it with the
+             ;; value before these changes recorded in `jit-lock-context-ppss'.
+             (let ((ppss (syntax-ppss jit-lock-context-end)))
+               ;; Refontify contextually if
+               ;; 1. paren depth equals 1 before or after change(s) in Lisp
+               ;;    modes - needed to handle doc-strings,
+               ;; 2. character that terminates containing string changed,
+               ;; 3. comment status changed,
+               ;; 4. comment type changed.
+               (if (or (and (memq major-mode '(emacs-lisp-mode lisp-mode))
+                            (or (= (nth 0 ppss) 1)
+                                (= (nth 0 jit-lock-context-ppss) 1)))
+                       (not (equal (nth 3 ppss) (nth 3 jit-lock-context-ppss)))
+                       (not (equal (nth 4 ppss) (nth 4 jit-lock-context-ppss)))
+                       (not (equal (nth 7 ppss) (nth 7 
jit-lock-context-ppss))))
+                   ;; Assign `jit-lock-context-unfontify-pos'.
+                   (progn
+                     (setq jit-lock-fail-context (1+ jit-lock-fail-context))
+                     (setq jit-lock-context-unfontify-pos
+                           (min jit-lock-context-unfontify-pos
+                                jit-lock-context-start)))
+                 (setq jit-lock-succ-context (1+ jit-lock-succ-context))))
+             ;; Reset markers.
+             (set-marker jit-lock-context-start nil)
+             (set-marker jit-lock-context-end nil))
+
+           (when (and (>= jit-lock-context-unfontify-pos (point-min))
+                      (< jit-lock-context-unfontify-pos (point-max)))
+             ;; If we're in text that matches a complex multi-line
+             ;; font-lock pattern, make sure the whole text will be
+             ;; redisplayed eventually.
+             ;; Despite its name, we treat jit-lock-defer-multiline here
+             ;; rather than in jit-lock-defer since it has to do with multiple
+             ;; lines, i.e. with context.
+             (when (get-text-property jit-lock-context-unfontify-pos
+                                      'jit-lock-defer-multiline)
+               (setq jit-lock-context-unfontify-pos
+                     (or (previous-single-property-change
+                          jit-lock-context-unfontify-pos
+                          'jit-lock-defer-multiline)
+                         (point-min))))
+             (with-buffer-prepared-for-jit-lock
+              ;; Force contextual refontification.
+              (remove-text-properties
+               jit-lock-context-unfontify-pos (point-max)
+               '(fontified nil jit-lock-defer-multiline nil)))
+             (setq jit-lock-context-unfontify-pos (point-max)))))))))
+
+(defun jit-lock-before-change (start end)
+  "Calculate ppss at beginning of first line following END.
+Installed on `before-change-functions' when contextual fontification is
+enabled.  START and END are start and end of the changed text."
+  (when (and jit-lock-mode jit-lock-context-unfontify-pos
+            ;; Quit unless `jit-lock-context-unfontify-pos' is below START.
+            (> jit-lock-context-unfontify-pos start)
+            ;; Do this once for a sequence of modifications only, that is, iff
+            ;; `jit-lock-context-start' does not point into current buffer.
+            (not (eq (marker-buffer jit-lock-context-start)
+                     (current-buffer))))
+    (when (marker-buffer jit-lock-context-start)
+      ;; `jit-lock-context-start' points into another buffer.  Set
+      ;; `jit-lock-context-unfontify-pos' in that buffer.
+      (with-current-buffer (marker-buffer jit-lock-context-start)
+       (setq jit-lock-context-unfontify-pos
+             (min jit-lock-context-unfontify-pos
+                  jit-lock-context-start))))
+    (save-excursion
+      ;; Install markers.
+      (set-marker jit-lock-context-start
+                 (progn (goto-char start) (line-beginning-position)))
+      (set-marker jit-lock-context-end
+                 (progn (goto-char end) (line-beginning-position 2)))
+      ;; Record ppss at `jit-lock-context-end'.
+      (setq jit-lock-context-ppss (syntax-ppss jit-lock-context-end)))))

 (defun jit-lock-after-change (start end old-len)
   "Mark the rest of the buffer as not fontified after a change.
-Installed on `after-change-functions'.
-START and END are the start and end of the changed text.  OLD-LEN
-is the pre-change length.
-This function ensures that lines following the change will be refontified
-in case the syntax of those lines has changed.  Refontification
-will take place when text is fontified stealthily."
+Installed on `after-change-functions'. START and END are the start and
+end of the changed text.  OLD-LEN is the pre-change length.  When
+contextual fontification is enabled, this function ensures that lines
+following the change will be refontified in case the syntax of those
+lines has changed.  Refontification will take place during redisplay or
+when text is fontified stealthily."
   (when jit-lock-mode
     (save-excursion
       (with-buffer-prepared-for-jit-lock
@@ -562,13 +639,50 @@
        ;; Make sure we change at least one char (in case of deletions).
        (setq end (min (max end (1+ start)) (point-max)))
        ;; Request refontification.
-       (put-text-property start end 'fontified nil))
-      ;; Mark the change for deferred contextual refontification.
-      (when jit-lock-context-unfontify-pos
-       (setq jit-lock-context-unfontify-pos
-             (min jit-lock-context-unfontify-pos start))))))
+       (put-text-property start end 'fontified nil)
+
+       ;; Contextual refontification.
+       (cond
+       ((not jit-lock-context-unfontify-pos))
+       ;; Handle case where `jit-lock-context-start' was not set properly for
+       ;; some reason, for example, because `before-change-functions' has been
+       ;; temporarily let-bound to nil.
+       ((not (eq (marker-buffer jit-lock-context-start) (current-buffer)))
+        ;; Adjust `jit-lock-context-unfontify-pos'.
+        (setq jit-lock-context-unfontify-pos
+              (min jit-lock-context-unfontify-pos start))
+        (when (marker-buffer jit-lock-context-start)
+          ;; `jit-lock-context-start' points into some other buffer.
+          ;; Set `jit-lock-context-unfontify-pos' in that buffer.
+          (with-current-buffer (marker-buffer jit-lock-context-start)
+            (setq jit-lock-context-unfontify-pos
+                  (min jit-lock-context-unfontify-pos
+                       jit-lock-context-start)))
+          ;; Reset markers.
+          (setq jit-lock-fail-change (1+ jit-lock-fail-change))
+          (set-marker jit-lock-context-start nil)
+          (set-marker jit-lock-context-end nil)))
+       ;; Quit if `jit-lock-context-unfontify-pos' is before START.  Also sort
+       ;; out buffer modifications that precede `jit-lock-context-start' or
+       ;; follow `jit-lock-context-end'.  We could handle backward-deletions of
+       ;; newlines here but in that case we would have to re-parse anyway.
+       ((or (<= jit-lock-context-unfontify-pos start)
+            (< start jit-lock-context-start)
+            (> end jit-lock-context-end))
+        ;; Adjust `jit-lock-context-unfontify-pos'.
+        (setq jit-lock-context-unfontify-pos
+              (min jit-lock-context-unfontify-pos
+                   jit-lock-context-start start))
+        ;; Reset markers.
+        (setq jit-lock-fail-change (1+ jit-lock-fail-change))
+        (set-marker jit-lock-context-start nil)
+        (set-marker jit-lock-context-end nil)))))))

 (provide 'jit-lock)

 ;;; arch-tag: 56b5de6e-f581-453b-bb97-49c39372ff9e
 ;;; jit-lock.el ends here
+
+(defvar jit-lock-fail-change 0)
+(defvar jit-lock-fail-context 0)
+(defvar jit-lock-succ-context 0)