Speed up counsel-yank-pop on large kill-ring

counsel.el

@@ -4463,19 +4463,29 @@ Additional actions:\\<ivy-minibuffer-map>
    cand-pairs
    (propertize counsel-yank-pop-separator 'face 'ivy-separator)))
 
+;; Macro to leverage `compiler-macro' of `cl-member' in Emacs >= 24.
+(defmacro counsel--idx-of (elt list test)
+  "Return index of ELT in LIST, comparing with TEST.
+Typically faster than `cl-position' using `equal' on large LIST."
+  ;; No `macroexp-let2*' before Emacs 25.
+  (macroexp-let2 nil elt elt
+    (macroexp-let2 nil list list
+      (macroexp-let2 nil tail `(cl-member ,elt ,list :test ,test)
+        `(and ,tail (- (length ,list) (length ,tail)))))))
+
 (defun counsel--yank-pop-position (s)
   "Return position of S in `kill-ring' relative to last yank."
-  (or (cl-position s kill-ring-yank-pointer :test #'equal-including-properties)
-      (cl-position s kill-ring-yank-pointer :test #'equal)
-      (+ (or (cl-position s kill-ring :test #'equal-including-properties)
-             (cl-position s kill-ring :test #'equal))
+  (or (counsel--idx-of s kill-ring-yank-pointer #'equal-including-properties)
+      (counsel--idx-of s kill-ring-yank-pointer #'equal)
+      (+ (or (counsel--idx-of s kill-ring #'equal-including-properties)
+             (counsel--idx-of s kill-ring #'equal))
          (- (length kill-ring-yank-pointer)
             (length kill-ring)))))
 
 (defun counsel-string-non-blank-p (s)
   "Return non-nil if S includes non-blank characters.
 Newlines and carriage returns are considered blank."
-  (not (string-match-p "\\`[\n\r[:blank:]]*\\'" s)))
+  (string-match-p "[^\n\r[:blank:]]" s))
 
 (defcustom counsel-yank-pop-filter #'counsel-string-non-blank-p
   "Unary filter function applied to `counsel-yank-pop' candidates.
@@ -4484,9 +4494,53 @@ will be destructively removed from `kill-ring' before completion.
 All blank strings are deleted from `kill-ring' by default."
   :type '(radio
           (function-item counsel-string-non-blank-p)
-          (function-item identity)
+          (function-item identity) ;; Faster than the newer `always'.
           (function :tag "Other")))
 
+(defun counsel--equal-w-props ()
+  "Return a `hash-table-test' using `equal-including-properties'.
+If not available, return nil."
+  ;; Added in Emacs 28.
+  (when (fboundp 'sxhash-equal-including-properties)
+    (let ((name 'counsel--equal-w-props))
+      ;; Define the test only once.
+      (unless (get name 'hash-table-test)
+        (define-hash-table-test name #'equal-including-properties
+                                #'sxhash-equal-including-properties))
+      name)))
+
+(defun counsel--yank-pop-filter (kills)
+  "Apply `counsel-yank-pop-filter' to and deduplicate KILLS.
+Equality is defined by `equal-including-properties' for some consistency
+with `kill-do-not-save-duplicates' (which is otherwise ignored).  This
+function tries to be faster than `cl-delete-duplicates' when possible."
+  (let* ((pred counsel-yank-pop-filter)
+         (len (length kills))
+         ;; Same threshold as `delete-dups'.
+         (test (and (> len 100) (counsel--equal-w-props))))
+    (if (not test) ;; Slow fallback.
+        (cl-delete-duplicates (cl-delete-if-not pred kills)
+                              :test #'equal-including-properties
+                              :from-end t)
+      ;; The rest is `delete-dups' combined with `delete' in a single pass.
+      ;; Find first (or no) element that passes through filter.
+      (while (unless (funcall pred (car kills))
+               (cl-decf len)
+               (setq kills (cdr kills))))
+      (let ((ht (make-hash-table :test test :size len))
+            (tail kills)
+            retail)
+        ;; Mark it and continue with the rest.
+        (puthash (car tail) t ht)
+        (while (setq retail (cdr tail))
+          (let ((elt (car retail)))
+            (if (or (gethash elt ht)
+                    (not (funcall pred elt)))
+                (setcdr tail (cdr retail))
+              (puthash elt t ht)
+              (setq tail retail)))))
+      kills)))
+
 (defun counsel--yank-pop-kills ()
   "Return filtered `kill-ring' for `counsel-yank-pop' completion.
 Both `kill-ring' and `kill-ring-yank-pointer' may be
@@ -4497,11 +4551,9 @@ and incorporate `interprogram-paste-function'."
   ;; `interprogram-paste-function' both being nil
   (ignore-errors (current-kill 0))
   ;; Keep things consistent with the rest of Emacs
-  (dolist (sym '(kill-ring kill-ring-yank-pointer))
-    (set sym (cl-delete-duplicates
-              (cl-delete-if-not counsel-yank-pop-filter (symbol-value sym))
-              :test #'equal-including-properties :from-end t)))
-  kill-ring)
+  (prog1 (setq kill-ring (counsel--yank-pop-filter kill-ring))
+    (setq kill-ring-yank-pointer
+          (counsel--yank-pop-filter kill-ring-yank-pointer))))
 
 (defcustom counsel-yank-pop-after-point nil
   "Whether `counsel-yank-pop' yanks after point.
@@ -4539,9 +4591,10 @@ buffer position."
 
 (defun counsel-yank-pop-action-remove (s)
   "Remove all occurrences of S from the kill ring."
-  (dolist (sym '(kill-ring kill-ring-yank-pointer))
-    (set sym (cl-delete s (symbol-value sym)
-                        :test #'equal-including-properties)))
+  (setq kill-ring
+        (cl-delete s kill-ring :test #'equal-including-properties))
+  (setq kill-ring-yank-pointer
+        (cl-delete s kill-ring-yank-pointer :test #'equal-including-properties))
   ;; Update collection and preselect for next `ivy-call'
   (setf (ivy-state-collection ivy-last) kill-ring)
   (setf (ivy-state-preselect ivy-last)

ivy-test.el

@@ -1163,6 +1163,40 @@ Since `execute-kbd-macro' doesn't pick up a let-bound `default-directory'.")
              (ivy-with-temp-buffer '(counsel-yank-pop) "C-m"))
            '(1 "foo"))))
 
+(ert-deftest counsel-string-non-blank-p ()
+  "Test `counsel-string-non-blank-p'."
+  (should-not (counsel-string-non-blank-p ""))
+  (should-not (counsel-string-non-blank-p " "))
+  (should-not (counsel-string-non-blank-p "  "))
+  (should (counsel-string-non-blank-p "a"))
+  (should (counsel-string-non-blank-p " a"))
+  (should (counsel-string-non-blank-p "a "))
+  (should (counsel-string-non-blank-p "aa")))
+
+(ert-deftest counsel--equal-w-props ()
+  "Sanity check for `sxhash-equal-including-properties'."
+  (let ((name 'counsel--equal-w-props)
+        (test (counsel--equal-w-props)))
+    (should (eq test (and (>= emacs-major-version 28) name)))
+    (if test
+        (should (make-hash-table :test test :size 0))
+      (should-not (get name 'hash-table-test)))))
+
+(ert-deftest counsel--yank-pop-filter ()
+  "Test `counsel--yank-pop-filter'."
+  (should-not (counsel--yank-pop-filter ()))
+  (dolist (len '(1 2 3 120))
+    (let (kills)
+      (dotimes (_ len)
+        (push (propertize "a" t nil) kills))
+      (should (equal (counsel--yank-pop-filter kills) '("a")))))
+  (dolist (len '(1 2 3 60))
+    (let (kills)
+      (dotimes (_ len)
+        (push (propertize "a" t nil) kills)
+        (push (propertize "a" t t) kills))
+      (should (equal (counsel--yank-pop-filter kills) '("a" "a"))))))
+
 (ert-deftest ivy-read-file-name-in-buffer-visiting-file ()
   "Test `ivy-immediate-done' command in `read-file-name' without any editing in
 a buffer visiting a file."