Speed up tall rectangular selections (bug#72830)

Instead of setting the highlight overlay on every line in the selection,
only do so on the window-height worth of lines closest to point because
the rest aren't likely to be visible.

This makes a massive difference for tall rectangular selections which
previously were so slow as to be unusable.

(Tall selections are still slow if `select-active-regions` is non-nil,
but that is something that users can actually do something about.)

* lisp/rect.el (rectangle--highlight-for-redisplay)
(rectangle--unhighlight-for-redisplay):
Replace call to `apply-on-rectangle`, which operates on every line,
with a loop over an approximate screenful.
Extend the `rectangle` overlay list structure with a value for point,
because `exchange-point-and-mark` must trigger a recomputation of
highlight overlays despite the selection not actually changing.

(cherry picked from commit 38c7516827902cdfb70bf68b2da4296a8d9349c0)

diff --git a/lisp/rect.el b/lisp/rect.el
index 00def3b527e38d40b1735de8d6ba6218e4d7620b..30397e4ef957e751518cb90054854d521a32805e 100644 (file)
--- a/lisp/rect.el
+++ b/lisp/rect.el
@@ -843,102 +843,130 @@ Ignores `line-move-visual'."
          (eq (nth 1 rol) (buffer-chars-modified-tick))
          (eq start (nth 2 rol))
          (eq end (nth 3 rol))
-         (equal (rectangle--crutches) (nth 4 rol)))
+         (equal (rectangle--crutches) (nth 4 rol))
+         ;; Check point explicitly so that `exchange-point-and-mark'
+         ;; triggers overlay recomputation.
+         (eq (nth 5 rol) (point)))
     rol)
    (t
     (save-excursion
-      (let* ((nrol nil)
+      (let* ((pt (point))
+             (nrol nil)
              (old (if (eq 'rectangle (car-safe rol))
-                      (nthcdr 5 rol)
+                      (nthcdr 6 rol)
                     (funcall redisplay-unhighlight-region-function rol)
                     nil)))
         (cl-assert (eq (window-buffer window) (current-buffer)))
         ;; `rectangle--pos-cols' looks up the `selected-window's parameter!
         (with-selected-window window
-          (apply-on-rectangle
-           (lambda (leftcol rightcol)
-             (let* ((mleft (move-to-column leftcol))
-                    (left (point))
-                    ;; BEWARE: In the presence of other overlays with
-                    ;; before/after/display-strings, this happens to move to
-                    ;; the column "as if the overlays were not applied", which
-                    ;; is sometimes what we want, tho it can be
-                    ;; considered a bug in move-to-column (it should arguably
-                    ;; pay attention to the before/after-string/display
-                    ;; properties when computing the column).
-                    (mright (move-to-column rightcol))
-                    (right (point))
-                    (ol
-                     (if (not old)
-                         (let ((ol (make-overlay left right)))
-                           (overlay-put ol 'window window)
-                           (overlay-put ol 'face 'region)
-                           ol)
-                       (let ((ol (pop old)))
-                         (move-overlay ol left right (current-buffer))
-                         ol))))
-               ;; `move-to-column' may stop before the column (if bumping into
-               ;; EOL) or overshoot it a little, when column is in the middle
-               ;; of a char.
-               (cond
-                ((< mleft leftcol)      ;`leftcol' is past EOL.
-                 (overlay-put ol 'before-string (rectangle--space-to leftcol))
-                 (setq mright (max mright leftcol)))
-                ((and (> mleft leftcol) ;`leftcol' is in the middle of a char.
-                      (eq (char-before left) ?\t))
-                 (setq left (1- left))
-                 (move-overlay ol left right)
-                 (goto-char left)
-                 (overlay-put ol 'before-string (rectangle--space-to leftcol)))
-                ((overlay-get ol 'before-string)
-                 (overlay-put ol 'before-string nil)))
-               (cond
-                ;; While doing rectangle--string-preview, the two sets of
-                ;; overlays steps on the other's toes.  I fixed some of the
-                ;; problems, but others remain.  The main one is the two
-                ;; (rectangle--space-to rightcol) below which try to virtually
-                ;; insert missing text, but during "preview", the text is not
-                ;; missing (it's provided by preview's own overlay).
-                (rectangle--string-preview-state
-                 (if (overlay-get ol 'after-string)
-                     (overlay-put ol 'after-string nil)))
-                ((< mright rightcol)    ;`rightcol' is past EOL.
-                 (let ((str (rectangle--space-to rightcol)))
-                   (put-text-property 0 (length str) 'face 'region str)
-                   ;; If cursor happens to be here, draw it at the right place.
-                   (rectangle--place-cursor leftcol left str)
-                   (overlay-put ol 'after-string str)))
-                ((and (> mright rightcol) ;`rightcol's in the middle of a char.
-                      (eq (char-before right) ?\t))
-                 (setq right (1- right))
-                 (move-overlay ol left right)
-                 (if (= rightcol leftcol)
-                     (overlay-put ol 'after-string nil)
-                   (goto-char right)
-                   (let ((str (rectangle--space-to rightcol)))
-                     (put-text-property 0 (length str) 'face 'region str)
-                     (when (= left right)
-                       (rectangle--place-cursor leftcol left str))
-                     (overlay-put ol 'after-string str))))
-                ((overlay-get ol 'after-string)
-                 (overlay-put ol 'after-string nil)))
-               (when (and (= leftcol rightcol) (display-graphic-p))
-                 ;; Make zero-width rectangles visible!
-                 (overlay-put ol 'after-string
-                              (concat (propertize " "
-                                                  'face '(region (:height 0.2)))
-                                      (overlay-get ol 'after-string))))
-               (push ol nrol)))
-           start end))
+          (let* ((cols (rectangle--pos-cols start end))
+                 (startcol (car cols))
+                 (endcol (cdr cols))
+                 (leftcol (min startcol endcol))
+                 (rightcol (max startcol endcol))
+                 ;; We don't know what lines will actually be displayed,
+                 ;; so add highlight overlays on lines within the window
+                 ;; height from point.
+                 (height (window-height))
+                 (start-pt (max start (progn (forward-line (- height))
+                                             (point))))
+                 (end-pt (min end (progn (goto-char pt)
+                                         (forward-line height)
+                                         (point)))))
+            (goto-char start-pt)
+            (beginning-of-line)
+            (while
+                (let* ((mleft (move-to-column leftcol))
+                       (left (point))
+                       ;; BEWARE: In the presence of other overlays with
+                       ;; before/after/display-strings, this happens to move to
+                       ;; the column "as if the overlays were not applied",
+                       ;; which is sometimes what we want, tho it can be
+                       ;; considered a bug in move-to-column (it should
+                       ;; arguably pay attention to the
+                       ;; before/after-string/display properties when computing
+                       ;; the column).
+                       (mright (move-to-column rightcol))
+                       (right (point))
+                       (ol
+                        (if (not old)
+                            (let ((ol (make-overlay left right)))
+                              (overlay-put ol 'window window)
+                              (overlay-put ol 'face 'region)
+                              ol)
+                          (let ((ol (pop old)))
+                            (move-overlay ol left right (current-buffer))
+                            ol))))
+                  ;; `move-to-column' may stop before the column (if bumping
+                  ;; into EOL) or overshoot it a little, when column is in the
+                  ;; middle of a char.
+                  (cond
+                   ((< mleft leftcol)      ;`leftcol' is past EOL.
+                    (overlay-put ol 'before-string
+                                 (rectangle--space-to leftcol))
+                    (setq mright (max mright leftcol)))
+                   ((and (> mleft leftcol) ;`leftcol' is in the middle of a char
+                         (eq (char-before left) ?\t))
+                    (setq left (1- left))
+                    (move-overlay ol left right)
+                    (goto-char left)
+                    (overlay-put ol 'before-string
+                                 (rectangle--space-to leftcol)))
+                   ((overlay-get ol 'before-string)
+                    (overlay-put ol 'before-string nil)))
+                  (cond
+                   ;; While doing rectangle--string-preview, the two sets of
+                   ;; overlays steps on the other's toes.  I fixed some of the
+                   ;; problems, but others remain.  The main one is the two
+                   ;; (rectangle--space-to rightcol) below which try to
+                   ;; virtually insert missing text, but during "preview", the
+                   ;; text is not missing (it's provided by preview's own
+                   ;; overlay).
+                   (rectangle--string-preview-state
+                    (if (overlay-get ol 'after-string)
+                        (overlay-put ol 'after-string nil)))
+                   ((< mright rightcol)    ;`rightcol' is past EOL.
+                    (let ((str (rectangle--space-to rightcol)))
+                      (put-text-property 0 (length str) 'face 'region str)
+                      ;; If cursor happens to be here, draw it at the right
+                      ;; place.
+                      (rectangle--place-cursor leftcol left str)
+                      (overlay-put ol 'after-string str)))
+                   ((and (> mright rightcol) ;`rightcol' in the middle of a char
+                         (eq (char-before right) ?\t))
+                    (setq right (1- right))
+                    (move-overlay ol left right)
+                    (if (= rightcol leftcol)
+                        (overlay-put ol 'after-string nil)
+                      (goto-char right)
+                      (let ((str (rectangle--space-to rightcol)))
+                        (put-text-property 0 (length str) 'face 'region str)
+                        (when (= left right)
+                          (rectangle--place-cursor leftcol left str))
+                        (overlay-put ol 'after-string str))))
+                   ((overlay-get ol 'after-string)
+                    (overlay-put ol 'after-string nil)))
+                  (when (and (= leftcol rightcol) (display-graphic-p))
+                    ;; Make zero-width rectangles visible!
+                    (overlay-put ol 'after-string
+                                 (concat (propertize
+                                          " " 'face '(region (:height 0.2)))
+                                         (overlay-get ol 'after-string))))
+                  (push ol nrol)
+                  (and (zerop (forward-line 1))
+                       (bolp)
+                       (<= (point) end-pt))))
+            )
+          )
         (mapc #'delete-overlay old)
         `(rectangle ,(buffer-chars-modified-tick)
-                    ,start ,end ,(rectangle--crutches)
+                    ,start ,end ,(rectangle--crutches) ,pt
                     ,@nrol))))))
 
 (defun rectangle--unhighlight-for-redisplay (orig rol)
   (if (not (eq 'rectangle (car-safe rol)))
       (funcall orig rol)
-    (mapc #'delete-overlay (nthcdr 5 rol))
+    (mapc #'delete-overlay (nthcdr 6 rol))
     (setcar (cdr rol) nil)))
 
 (defun rectangle--duplicate-right (n displacement)