Remove some early-bootstrap dependencies for advice

The dependencies between `advice`, cl-generic`, `bytecomp`, `cl-lib`,
`simple`, `help`, ... were becoming unmanageable.
Break the reliance on `advice` (which includes making sure the
compiler is not needed during the early bootstrap).

* lisp/simple.el (pre-redisplay-function): Set without using `add-function`.

* lisp/loadup.el (advice, simple): Move to after `cl-generic`.

* lisp/help.el (command-error-function): Set without using `add-function`.
(help-command-error-confusable-suggestions): Explicitly call
`command-error-default-function` instead.

* lisp/emacs-lisp/cl-macs.el (pcase--mutually-exclusive-p): Don't
optimize during early-bootstrap.

* lisp/emacs-lisp/cl-generic.el (cl--generic-lambda): Tiny simplification.
(cl-defmethod): Label the obsolescence warning as it should.
(cl--generic-compiler): New variable.
(cl--generic-get-dispatcher): Use it.
(cl--generic-prefill-dispatchers): Make freshly made dispatchers.
This commit is contained in:
Stefan Monnier 2022-03-17 19:07:59 -04:00
parent 751c8f88c4
commit 06ea82e4e3
5 changed files with 48 additions and 20 deletions

View file

@ -392,9 +392,9 @@ the specializer used will be the one returned by BODY."
. ,(lambda () spec-args))
macroexpand-all-environment)))
(require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'.
(when (assq 'interactive (cadr fun))
(when (assq 'interactive body)
(message "Interactive forms not supported in generic functions: %S"
(assq 'interactive (cadr fun))))
(assq 'interactive body)))
;; First macroexpand away the cl-function stuff (e.g. &key and
;; destructuring args, `declare' and whatnot).
(pcase (macroexpand fun macroenv)
@ -526,7 +526,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
(let* ((obsolete (get name 'byte-obsolete-info)))
(macroexp-warn-and-return
(macroexp--obsolete-warning name obsolete "generic function")
nil nil nil orig-name)))
nil (list 'obsolete name) nil orig-name)))
;; You could argue that `defmethod' modifies rather than defines the
;; function, so warnings like "not known to be defined" are fair game.
;; But in practice, it's common to use `cl-defmethod'
@ -614,6 +614,14 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
(defvar cl--generic-dispatchers (make-hash-table :test #'equal))
(defvar cl--generic-compiler
;; Don't byte-compile the dispatchers if cl-generic itself is not
;; compiled. Otherwise the byte-compiler and all the code on
;; which it depends needs to be usable before cl-generic is loaded,
;; which imposes a significant burden on the bootstrap.
(if (consp (lambda (x) (+ x 1)))
(lambda (exp) (eval exp t)) #'byte-compile))
(defun cl--generic-get-dispatcher (dispatch)
(with-memoization
;; We need `copy-sequence` here because this `dispatch' object might be
@ -658,7 +666,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
;; FIXME: For generic functions with a single method (or with 2 methods,
;; one of which always matches), using a tagcode + hash-table is
;; overkill: better just use a `cl-typep' test.
(byte-compile
(funcall
cl--generic-compiler
`(lambda (generic dispatches-left methods)
;; FIXME: We should find a way to expand `with-memoize' once
;; and forall so we don't need `subr-x' when we get here.
@ -886,11 +895,20 @@ those methods.")
(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
,@(apply #'append
(mapcar #'cl-generic-generalizers specializers))
,cl--generic-t-generalizer))))
(let ((fun
;; Let-bind cl--generic-dispatchers so we *re*compute the function
;; from scratch, since the one in the cache may be non-compiled!
(let ((cl--generic-dispatchers (make-hash-table))
;; When compiling `cl-generic' during bootstrap, make sure
;; we prefill with compiled dispatchers even though the loaded
;; `cl-generic' is still interpreted.
(cl--generic-compiler
(if (featurep 'bytecomp) #'byte-compile cl--generic-compiler)))
(cl--generic-get-dispatcher
`(,arg-or-context
,@(apply #'append
(mapcar #'cl-generic-generalizers specializers))
,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

View file

@ -3279,8 +3279,9 @@ the form NAME which is a shorthand for (NAME NAME)."
(funcall orig pred1
(cl--defstruct-predicate t2))))
(funcall orig pred1 pred2))))
(advice-add 'pcase--mutually-exclusive-p
:around #'cl--pcase-mutually-exclusive-p)
(when (fboundp 'advice-add) ;Not available during bootstrap.
(advice-add 'pcase--mutually-exclusive-p
:around #'cl--pcase-mutually-exclusive-p))
(defun cl-struct-sequence-type (struct-type)

View file

@ -621,7 +621,7 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer."
(enable-recursive-minibuffers t)
val)
(setq val (completing-read (format-prompt "Where is command" fn)
obarray 'commandp t nil nil
obarray #'commandp t nil nil
(and fn (symbol-name fn))))
(list (unless (equal val "") (intern val))
current-prefix-arg)))
@ -2147,7 +2147,10 @@ the suggested string to use instead. See
confusables ", ")
string))))
(defun help-command-error-confusable-suggestions (data _context _signal)
(defun help-command-error-confusable-suggestions (data context signal)
;; Delegate most of the work to the original default value of
;; `command-error-function' implemented in C.
(command-error-default-function data context signal)
(pcase data
(`(void-variable ,var)
(let ((suggestions (help-uni-confusable-suggestions
@ -2156,8 +2159,12 @@ the suggested string to use instead. See
(princ (concat "\n " suggestions) t))))
(_ nil)))
(add-function :after command-error-function
#'help-command-error-confusable-suggestions)
(when (eq command-error-function #'command-error-default-function)
;; Override the default set in the C code.
;; This is not done using `add-function' so as to loosen the bootstrap
;; dependencies.
(setq command-error-function
#'help-command-error-confusable-suggestions))
(define-obsolete-function-alias 'help-for-help-internal #'help-for-help "28.1")

View file

@ -196,11 +196,9 @@
(setq definition-prefixes new))
(load "button") ;After loaddefs, because of define-minor-mode!
(load "emacs-lisp/nadvice")
(load "emacs-lisp/cl-preloaded")
(load "obarray") ;abbrev.el is implemented in terms of obarrays.
(load "abbrev") ;lisp-mode.el and simple.el use define-abbrev-table.
(load "simple")
(load "help")
@ -251,6 +249,8 @@
(let ((max-specpdl-size (max max-specpdl-size 1800)))
;; A particularly demanding file to load; 1600 does not seem to be enough.
(load "emacs-lisp/cl-generic"))
(load "simple")
(load "emacs-lisp/nadvice")
(load "minibuffer") ;Needs cl-generic (and define-minor-mode).
(load "frame")
(load "startup")

View file

@ -6545,9 +6545,11 @@ is set to the buffer displayed in that window.")
(with-current-buffer (window-buffer win)
(run-hook-with-args 'pre-redisplay-functions win))))))
(add-function :before pre-redisplay-function
#'redisplay--pre-redisplay-functions)
(when (eq pre-redisplay-function #'ignore)
;; Override the default set in the C code.
;; This is not done using `add-function' so as to loosen the bootstrap
;; dependencies.
(setq pre-redisplay-function #'redisplay--pre-redisplay-functions))
(defvar-local mark-ring nil
"The list of former marks of the current buffer, most recent first.")