elisp-mode.el: Optimize Xref integration

diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el
index d857c5105426594a3023cbde0178b9a463373df2..34c9261b6b406f5e835d736906478029746ac851 100644 (file)
--- a/lisp/emacs-lisp/scope.el
+++ b/lisp/emacs-lisp/scope.el
@@ -113,6 +113,7 @@
 
 (scope-define-symbol-type symbol-type-definition (symbol-type)
   :doc "Symbol type name definitions."
+  :definition t
   :face 'elisp-symbol-type-definition
   :help (constantly "Symbol type definition")
   :imenu "Symbol Type"
@@ -294,6 +295,7 @@
 
 (scope-define-symbol-type defun ()
   :doc "Function definitions."
+  :definition t
   :face 'font-lock-function-name-face
   :help (constantly "Function definition")
   :imenu "Function"
@@ -301,6 +303,7 @@
 
 (scope-define-symbol-type defvar ()
   :doc "Variable definitions."
+  :definition t
   :face 'font-lock-variable-name-face
   :help (constantly "Special variable definition")
   :imenu "Variable"
@@ -308,6 +311,7 @@
 
 (scope-define-symbol-type defface ()
   :doc "Face definitions."
+  :definition t
   :face 'font-lock-variable-name-face
   :help (constantly "Face definition")
   :imenu "Face"
@@ -340,13 +344,14 @@
 
 (scope-define-symbol-type deficon ()
   :doc "Icon definitions."
+  :definition t
   :face 'font-lock-type-face
   :help (constantly "Icon definition")
   :imenu "Icon"
   :namespace 'icon)
 
 (scope-define-symbol-type oclosure ()
-  :doc "oclosure type names."
+  :doc "OClosure type names."
   :face 'font-lock-type-face
   :help (lambda (beg end _def)
           (if-let ((sym (intern (buffer-substring-no-properties beg end))))
@@ -360,7 +365,8 @@
   :namespace 'oclosure)
 
 (scope-define-symbol-type defoclosure ()
-  :doc "oclosure type definitions."
+  :doc "OClosure type definitions."
+  :definition t
   :face 'font-lock-type-face
   :help (constantly "OClosure type definition")
   :imenu "OClosure type"
@@ -381,6 +387,7 @@
 
 (scope-define-symbol-type defcoding ()
   :doc "Coding system definitions."
+  :definition t
   :face 'font-lock-type-face
   :help (constantly "Coding system definition")
   :imenu "Coding system"
@@ -401,6 +408,7 @@
 
 (scope-define-symbol-type defcharset ()
   :doc "Charset definitions."
+  :definition t
   :face 'font-lock-type-face
   :help (constantly "Charset definition")
   :imenu "Charset"

diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index 3ce93afcfb551f9fd6c963526ebe277398126369..50cb318cd0aabd064a0d610d4517a7eabea9a05d 100644 (file)
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -1139,33 +1139,79 @@ confidence."
            ;; Use a property to transport the location of the identifier.
            (propertize ident 'pos (car bounds))))))
 
+(declare-function project-files "project" (project &optional dirs))
+
 (cl-defmethod xref-backend-definitions ((_backend (eql 'elisp)) identifier)
   (let* ((pos (get-text-property 0 'pos identifier))
-         (dec (when pos
-                (save-excursion
-                  (goto-char pos)
-                  (beginning-of-defun)
-                  (catch 'var-def
-                    (scope (lambda (_type beg len _id &optional def)
-                             (when (<= beg pos (+ beg len))
-                               (throw 'var-def def))))
-                    nil)))))
-    (if (numberp dec)
+         (enable-local-variables nil)
+         (gc-cons-threshold (* 1024 1024 1024))
+         (type-def (when pos
+                     (save-excursion
+                       (goto-char pos)
+                       (beginning-of-defun)
+                       (catch 'var-def
+                         (scope (lambda (type beg len _id &optional def)
+                                  (when (<= beg pos (+ beg len))
+                                    (throw 'var-def (cons type def)))))
+                         nil))))
+         (type (car type-def))
+         (def (cdr type-def)))
+    (if (numberp def)
         (list (xref-make "lexical binding"
-                         (xref-make-buffer-location (current-buffer) dec)))
-      (require 'find-func)
-      (let ((sym (intern-soft identifier)))
-        (when sym
-          (let* ((namespace (if (and pos
-                                     ;; Reusing it in Help Mode.
-                                     (derived-mode-p 'emacs-lisp-mode))
-                                (elisp--xref-infer-namespace pos)
-                              'any))
-                 (defs (elisp--xref-find-definitions sym)))
-            (if (eq namespace 'maybe-variable)
-                (or (elisp--xref-filter-definitions defs 'variable sym)
-                    (elisp--xref-filter-definitions defs 'any sym))
-              (elisp--xref-filter-definitions defs namespace sym))))))))
+                         (xref-make-buffer-location (current-buffer) def)))
+      (let (res
+            (tar
+             (case type
+               ((symbol-type symbol-type-definition) 'symbol-type-definition)
+               ((variable defvar) 'defval)
+               ((face defface) 'defface)
+               ((defun function macro) 'defun)
+               ((icon deficon) 'deficon)
+               ((coding defcoding) 'defcoding)
+               ((charset defcharset) 'defcharset)
+               ((oclosure defoclosure) 'defoclosure))))
+        (when tar
+          (require 'project)
+          (dolist-with-progress-reporter
+              (file
+               (seq-filter
+                (lambda (file) (string= (file-name-extension file) "el"))
+                (project-files (project-current))))
+              "Scanning for definitions"
+            (let (all lla)
+              (pcase-dolist (`(,type ,beg ,len . ,_) (gethash identifier (elisp-sym-name-index file)))
+                (when (eq type tar)
+                  (unless (eq beg (caar lla))
+                    (push (cons beg len) lla))))
+              (when lla
+                (with-work-buffer
+                  (insert-file-contents file)
+                  (pcase-dolist (`(,beg . ,len) lla)
+                    (goto-char beg)
+                    (push
+                     (let* ((begg (pos-bol))
+                            (endd (pos-eol))
+                            (line (buffer-substring begg endd))
+                            (cur (- beg begg)))
+                       (add-face-text-property
+                        cur (+ len cur) 'xref-match t line)
+                       (xref-make-match
+                        line
+                        (xref-make-file-pos-location
+                         file beg (line-number-at-pos beg))
+                        len))
+                     all))))
+              (when all (setq res (nconc res (nreverse all)))))))
+        (if res res
+          (require 'find-func)
+          (let ((sym (intern-soft identifier)))
+            (when sym
+              (let* ((namespace (if pos (elisp--xref-infer-namespace pos) 'any))
+                     (defs (elisp--xref-find-definitions sym)))
+                (if (eq namespace 'maybe-variable)
+                    (or (elisp--xref-filter-definitions defs 'variable sym)
+                        (elisp--xref-filter-definitions defs 'any sym))
+                  (elisp--xref-filter-definitions defs namespace sym))))))))))
 
 (defun elisp-local-references (pos)
   "Return references to local variable at POS as (BEG . LEN) cons cells."
@@ -1181,9 +1227,7 @@ confidence."
      (pcase-lambda (`(,beg ,len ,id)) (when (equal id cur) (cons beg len)))
      all)))
 
-(declare-function project-files "project" (project &optional dirs))
-
-(cl-defmethod xref-backend-references :around ((_backend (eql 'elisp)) identifier)
+(cl-defmethod xref-backend-references ((_backend (eql 'elisp)) identifier)
   (let* ((pos (get-text-property 0 'pos identifier))
          (enable-local-variables nil)
          (gc-cons-threshold (* 1024 1024 1024)))
@@ -1208,28 +1252,31 @@ confidence."
                 (lambda (file) (string= (file-name-extension file) "el"))
                 (project-files (project-current))))
               "Scanning for references"
-            (pcase-dolist (`(,type ,beg ,len ,sym . ,_) (elisp-symbols-index file))
-              (and (or (null types) (memq type types))
-                   (string= identifier sym)
-                   (with-work-buffer
-                     (insert-file-contents file)
-                     (goto-char beg)
-                     (push
-                      (let* ((begg (pos-bol))
-                             (endd (pos-eol))
-                             (line (buffer-substring begg endd))
-                             (cur (- beg begg)))
-                        (add-face-text-property
-                         cur (+ len cur) 'xref-match t line)
-                        (xref-make-match
-                         line
-                         (xref-make-file-pos-location
-                          file beg (line-number-at-pos beg))
-                         len))
-                      res)))))
-          (nreverse res))
-        ;; (cl-call-next-method backend identifier)
-        )))
+            (let (all lla)
+              (pcase-dolist (`(,type ,beg ,len . ,_) (gethash identifier (elisp-sym-name-index file)))
+                (when (or (null types) (memq type types))
+                  (unless (eq beg (caar lla))
+                    (push (cons beg len) lla))))
+              (when lla
+                (with-work-buffer
+                  (insert-file-contents file)
+                  (pcase-dolist (`(,beg . ,len) lla)
+                    (goto-char beg)
+                    (push
+                     (let* ((begg (pos-bol))
+                            (endd (pos-eol))
+                            (line (buffer-substring begg endd))
+                            (cur (- beg begg)))
+                       (add-face-text-property
+                        cur (+ len cur) 'xref-match t line)
+                       (xref-make-match
+                        line
+                        (xref-make-file-pos-location
+                         file beg (line-number-at-pos beg))
+                        len))
+                     all))))
+              (when all (setq res (nconc res (nreverse all))))))
+          res))))
 
 (defun elisp-make-xref (beg len)
   (let* ((beg-end (save-excursion
@@ -2775,10 +2822,10 @@ of TARGET."
 \f
 (put 'read-symbol-shorthands 'safe-local-variable #'consp)
 
-(defvar elisp-symbols-index-cache (make-hash-table :test #'equal))
+(defvar elisp-sym-type-index-cache (make-hash-table :test #'equal))
 
-(defun elisp-symbols-index (file)
-  (let ((cached (gethash file elisp-symbols-index-cache))
+(defun elisp-sym-type-index (file)
+  (let ((cached (gethash file elisp-sym-type-index-cache))
         (modtime (file-attribute-modification-time (file-attributes file))))
     (cdr
      (if (time-less-p (or (car cached) 0) modtime)
@@ -2786,11 +2833,11 @@ of TARGET."
                              (with-work-buffer
                                (setq lexical-binding t)
                                (insert-file-contents file)
-                               (elisp-symbols-index-1 file)))
-                  elisp-symbols-index-cache)
+                               (elisp-sym-type-index-1 file)))
+                  elisp-sym-type-index-cache)
        cached))))
 
-(defun elisp-symbols-index-1 (file)
+(defun elisp-sym-type-index-1 (file)
   (let (all)
     (save-excursion
       (goto-char (point-min))
@@ -2799,90 +2846,39 @@ of TARGET."
             (scope
              (lambda (type beg len &rest _)
                (push
-                (list type beg len (buffer-substring beg (+ beg len)))
-                all))))
+                (list beg len (buffer-substring beg (+ beg len)))
+                (alist-get type all)))))
         (end-of-file (nreverse all))
         (error (message "Encountered error while scanning %s: %S" file e) nil)))))
 
-(defun elisp-eval-1 (vars form)
-  (cond
-   ((consp form)
-    (let ((fun (car form)) (args (cdr form)) (evaluator nil))
-      (cond
-       ((not (listp args)) '(error . wrong-type-argument))
-       ((not (symbolp fun)) '(error . invalid-function))
-       ((setq evaluator (elisp-get-evaluator fun)) (apply evaluator vars args))
-       (t '(error . void-function)))))
-   ((and (symbolp form) (not (or (keywordp form) (booleanp form))))
-    (if-let ((val (alist-get form vars))) `(ok . ,val) '(error . void-variable)))
-   (t `(ok . ,form))))
-
-(defun elisp-eval-n (vars forms)
-  (catch 'ball
-    (while (cdr forms)
-      (let ((val (elisp-eval-1 vars (car forms))))
-        (if (eq (car val) 'ok) (setq forms (cdr forms))
-          (throw 'ball val))))
-    (elisp-eval-1 vars (car forms))))
-
-(defvar elisp-symbol-functions-alist nil)
-
-(defun elisp-get-evaluator (sym)
-  (or (get sym 'elisp-evaluator) (alist-get sym elisp-symbol-functions-alist)))
-
-(defmacro elisp-define-evaluator (fsym args &rest body)
-  (declare (indent defun))
-  (let ((analyzer (intern (concat "elisp--evaluate-" (symbol-name fsym)))))
-    `(progn
-       (defun ,analyzer ,args ,@body)
-       (put ',fsym 'elisp-evaluator #',analyzer))))
-
-(defmacro elisp-mark-function-as-safe (fsym)
-  (let ((analyzer (intern (concat "elisp--evaluate-" (symbol-name fsym)))))
-    `(progn
-       (defun ,analyzer (vars &rest args)
-         (elisp-eval-apply vars #',fsym args))
-       (put ',fsym 'elisp-evaluator #',analyzer))))
-
-(elisp-mark-function-as-safe cons)
-(elisp-mark-function-as-safe car)
-(elisp-mark-function-as-safe list)
-
-;; TODO: Look into unsafep.el.
-;; TODO: Trust `side-effect-free' property.
-
-(defmacro elisp-mark-macro-as-safe (msym)
-  (let ((analyzer (intern (concat "elisp--evaluate-" (symbol-name msym)))))
-    `(progn
-       (defun ,analyzer (vars &rest args)
-         (elisp-eval-expand vars ',msym args))
-       (put ',msym 'elisp-evaluator #',analyzer))))
-
-(elisp-mark-macro-as-safe ignore-errors)
-
-(defun elisp-eval-apply (vars fun args)
-  (catch 'ball
-    (let (vals)
-      (dolist (arg args)
-        (let ((val (elisp-eval-1 vars arg)))
-          (if (eq (car val) 'ok) (push (cdr val) vals)
-            (throw 'ball val))))
-      (condition-case e
-          `(ok . ,(apply fun vals))
-        (error `(error . ,(car-safe e)))))))
-
-(defun elisp-eval-expand (vars mac args)
-  (elisp-eval-1 vars (macroexpand-1 (cons mac args))))
+(defvar elisp-sym-name-index-cache (make-hash-table :test #'equal))
 
-(elisp-define-evaluator progn (vars &rest body)
-  (elisp-eval-n vars body))
+(defun elisp-sym-name-index (file)
+  (let ((cached (gethash file elisp-sym-name-index-cache))
+        (modtime (file-attribute-modification-time (file-attributes file))))
+    (cdr
+     (if (time-less-p (or (car cached) 0) modtime)
+         (puthash file (cons modtime
+                             (with-work-buffer
+                               (setq lexical-binding t)
+                               (insert-file-contents file)
+                               (elisp-sym-name-index-1 file)))
+                  elisp-sym-name-index-cache)
+       cached))))
 
-(elisp-define-evaluator if (vars cond then &rest else)
-  (let ((cond-val (elisp-eval-1 vars cond)))
-    (if (not (eq (car cond-val) 'ok)) cond-val
-      (if (cdr cond-val)
-          (elisp-eval-1 vars then)
-        (elisp-eval-n vars else)))))
+(defun elisp-sym-name-index-1 (file)
+  (let ((all (make-hash-table :test #'equal)))
+    (save-excursion
+      (goto-char (point-min))
+      (condition-case e
+          (while t
+            (scope
+             (lambda (type beg len &rest _)
+               (push
+                (list type beg len)
+                (gethash (buffer-substring beg (+ beg len)) all)))))
+        (end-of-file all)
+        (error (message "Encountered error while scanning %s: %S" file e) all)))))
 
 (provide 'elisp-mode)
 ;;; elisp-mode.el ends here