From: Mattias Engdegård Date: Thu, 29 Aug 2024 12:14:22 +0000 (+0200) Subject: Speed up tall rectangular selections (bug#72830) X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=874f4c09338ca2220eba2d2d1dd858b15a7a223a;p=emacs.git 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 00def3b527e..30397e4ef95 100644 --- 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)