[Emacs-diffs] master 37ab224: * lisp/loadup.el ("emacs-lisp/cl-generic"): Preload

[Stefan Monnier]

branch: master
commit 37ab2245f27d83f0faa3c0d9277088433bc4efaf
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    * lisp/loadup.el ("emacs-lisp/cl-generic"): Preload
    
    * src/lisp.mk (lisp): Add emacs-lisp/cl-generic.elc.
    * lisp/emacs-lisp/cl-generic.el (cl-generic-define-method):
    Avoid defalias for closures which are not immutable.
    (cl--generic-prefill-dispatchers): New macro.  Use it to prefill the
    dispatchers table with various entries.
    
    * lisp/emacs-lisp/ert.el (emacs-lisp-mode-hook):
    * lisp/emacs-lisp/seq.el (emacs-lisp-mode-hook): Use add-hook.
---
 lisp/emacs-lisp/cl-generic.el |   50 +++++++++++++++++++++++++++++++---------
 lisp/emacs-lisp/ert.el        |    4 +-
 lisp/emacs-lisp/seq.el        |    2 +-
 lisp/loadup.el                |    1 +
 src/lisp.mk                   |    1 +
 5 files changed, 43 insertions(+), 15 deletions(-)

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index f6595d3..a2716ef 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -438,7 +438,16 @@ which case this method will be invoked when the argument 
is `eql' to VAL.
           ;; the generic function.
           current-load-list)
       ;; For aliases, cl--generic-name gives us the actual name.
-      (defalias (cl--generic-name generic) gfun))))
+      (funcall
+       (if purify-flag
+           ;; BEWARE!  Don't purify this function definition, since that leads
+           ;; to memory corruption if the hash-tables it holds are modified
+           ;; (the GC doesn't trace those pointers).
+           #'fset
+         ;; But do use `defalias' in the normal case, so that it interacts
+         ;; properly with nadvice, e.g. for tracing/debug-on-entry.
+         #'defalias)
+       (cl--generic-name generic) gfun))))
 
 (defmacro cl--generic-with-memoization (place &rest code)
   (declare (indent 1) (debug t))
@@ -696,6 +705,25 @@ methods.")
   (if (eq specializer t) (list cl--generic-t-generalizer)
     (error "Unknown specializer %S" specializer)))
 
+(defmacro cl--generic-prefill-dispatchers (arg-or-context specializer)
+  (unless (integerp arg-or-context)
+    (setq arg-or-context `(&context . ,arg-or-context)))
+  (unless (fboundp 'cl--generic-get-dispatcher)
+    (require 'cl-generic))
+  (let ((fun (cl--generic-get-dispatcher
+              `(,arg-or-context ,@(cl-generic-generalizers specializer)
+                                ,cl--generic-t-generalizer))))
+    ;; Recompute dispatch at run-time, since the generalizers may be slightly
+    ;; different (e.g. byte-compiled rather than interpreted).
+    ;; FIXME: There is a risk that the run-time generalizer is not equivalent
+    ;; to the compile-time one, in which case `fun' may not be correct
+    ;; any more!
+    `(let ((dispatch `(,',arg-or-context
+                       ,@(cl-generic-generalizers ',specializer)
+                       ,cl--generic-t-generalizer)))
+       ;; (message "Prefilling for %S with \n%S" dispatch ',fun)
+       (puthash dispatch ',fun cl--generic-dispatchers))))
+
 (cl-defmethod cl-generic-combine-methods (generic methods)
   "Standard support for :after, :before, :around, and `:extra NAME' 
qualifiers."
   (cl--generic-standard-method-combination generic methods))
@@ -869,17 +897,6 @@ Can only be used from within the lexical body of a primary 
or around method."
    80 (lambda (name) `(gethash (car-safe ,name) cl--generic-head-used))
    (lambda (tag) (if (eq (car-safe tag) 'head) (list tag)))))
 
-;; Pre-fill the cl--generic-dispatchers table.
-;; We have two copies of `(0 ...)' but we can't share them via `let' because
-;; they're not used at the same time (one is compile-time, one is run-time).
-(puthash `(0 ,cl--generic-head-generalizer ,cl--generic-t-generalizer)
-         (eval-when-compile
-           (unless (fboundp 'cl--generic-get-dispatcher)
-             (require 'cl-generic))
-           (cl--generic-get-dispatcher
-            `(0 ,cl--generic-head-generalizer ,cl--generic-t-generalizer)))
-         cl--generic-dispatchers)
-
 (cl-defmethod cl-generic-generalizers :extra "head" (specializer)
   "Support for the `(head VAL)' specializers."
   ;; We have to implement `head' here using the :extra qualifier,
@@ -890,6 +907,8 @@ Can only be used from within the lexical body of a primary 
or around method."
         (gethash (cadr specializer) cl--generic-head-used) specializer)
     (list cl--generic-head-generalizer)))
 
+(cl--generic-prefill-dispatchers 0 (head eql))
+
 ;;; Support for (eql <val>) specializers.
 
 (defvar cl--generic-eql-used (make-hash-table :test #'eql))
@@ -904,6 +923,9 @@ Can only be used from within the lexical body of a primary 
or around method."
   (puthash (cadr specializer) specializer cl--generic-eql-used)
   (list cl--generic-eql-generalizer))
 
+(cl--generic-prefill-dispatchers 0 (eql nil))
+(cl--generic-prefill-dispatchers window-system (eql nil))
+
 ;;; Support for cl-defstructs specializers.
 
 (defun cl--generic-struct-tag (name)
@@ -960,6 +982,8 @@ Can only be used from within the lexical body of a primary 
or around method."
             (list cl--generic-struct-generalizer))))
    (cl-call-next-method)))
 
+(cl--generic-prefill-dispatchers 0 cl--generic-generalizer)
+
 ;;; Dispatch on "system types".
 
 (defconst cl--generic-typeof-types
@@ -998,6 +1022,8 @@ Can only be used from within the lexical body of a primary 
or around method."
           (list cl--generic-typeof-generalizer)))
    (cl-call-next-method)))
 
+(cl--generic-prefill-dispatchers 0 integer)
+
 ;; Local variables:
 ;; generated-autoload-file: "cl-loaddefs.el"
 ;; End:
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 8dc8261..b678e12 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -2537,7 +2537,7 @@ To be used in the ERT results buffer."
 (add-to-list 'minor-mode-alist '(ert--current-run-stats
                                  (:eval
                                   (ert--tests-running-mode-line-indicator))))
-(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords)
+(add-hook 'emacs-lisp-mode-hook #'ert--activate-font-lock-keywords)
 
 (defun ert--unload-function ()
   "Unload function to undo the side-effects of loading ert.el."
@@ -2548,7 +2548,7 @@ To be used in the ERT results buffer."
   nil)
 
 (defvar ert-unload-hook '())
-(add-hook 'ert-unload-hook 'ert--unload-function)
+(add-hook 'ert-unload-hook #'ert--unload-function)
 
 
 (provide 'ert)
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el
index 5553de6..0aa0f09 100644
--- a/lisp/emacs-lisp/seq.el
+++ b/lisp/emacs-lisp/seq.el
@@ -442,7 +442,7 @@ If no element is found, return nil."
 (unless (fboundp 'elisp--font-lock-flush-elisp-buffers)
   ;; In Emacs≥25, (via elisp--font-lock-flush-elisp-buffers and a few others)
   ;; we automatically highlight macros.
-  (add-to-list 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords))
+  (add-hook 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords))
 
 (provide 'seq)
 ;;; seq.el ends here
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 0746f95..828b19e 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -193,6 +193,7 @@
 (load "language/cham")
 
 (load "indent")
+(load "emacs-lisp/cl-generic")
 (load "frame")
 (load "startup")
 (load "term/tty-colors")
diff --git a/src/lisp.mk b/src/lisp.mk
index ee2a07c..8eb86b7 100644
--- a/src/lisp.mk
+++ b/src/lisp.mk
@@ -113,6 +113,7 @@ lisp = \
        $(lispsource)/language/cham.elc \
        $(lispsource)/indent.elc \
        $(lispsource)/window.elc \
+       $(lispsource)/emacs-lisp/cl-generic.elc \
        $(lispsource)/frame.elc \
        $(lispsource)/term/tty-colors.elc \
        $(lispsource)/font-core.elc \