1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-15 10:30:25 -08:00

Don't load comp when installing an existing trampoline

* lisp/emacs-lisp/nadvice.el (advice--add-function): Update.
	(comp-subr-trampoline-install): Update src file.
	* lisp/emacs-lisp/comp.el (comp-trampoline-compile): Autoload.
	* lisp/emacs-lisp/comp-run.el (comp-log-buffer-name)
	(native--compile-async, comp-warn-primitives)
	(comp-trampoline-filename, comp-eln-load-path-eff)
	(comp-trampoline-search, comp-trampoline-compile): Move here.
	* lisp/emacs-lisp/advice.el (comp-subr-trampoline-install): Update
	src file.
This commit is contained in:
Andrea Corallo 2023-11-07 11:28:32 +01:00
parent 93cc43a23c
commit b2416d2c02
4 changed files with 64 additions and 63 deletions

View file

@ -2042,7 +2042,7 @@ in that CLASS."
function class name))) function class name)))
(error "ad-remove-advice: `%s' is not advised" function))) (error "ad-remove-advice: `%s' is not advised" function)))
(declare-function comp-subr-trampoline-install "comp") (declare-function comp-subr-trampoline-install "comp-run")
;;;###autoload ;;;###autoload
(defun ad-add-advice (function advice class position) (defun ad-add-advice (function advice class position)

View file

@ -123,6 +123,19 @@ This is intended for debugging the compiler itself.
:risky t :risky t
:version "28.1") :version "28.1")
(defcustom native-comp-never-optimize-functions
'(;; The following two are mandatory for Emacs to be working
;; correctly (see comment in `advice--add-function'). DO NOT
;; REMOVE.
macroexpand rename-buffer)
"Primitive functions to exclude from trampoline optimization.
Primitive functions included in this list will not be called
directly by the natively-compiled code, which makes trampolines for
those primitives unnecessary in case of function redefinition/advice."
:type '(repeat symbol)
:version "28.1")
(defconst comp-log-buffer-name "*Native-compile-Log*" (defconst comp-log-buffer-name "*Native-compile-Log*"
"Name of the native-compiler log buffer.") "Name of the native-compiler log buffer.")
@ -385,6 +398,52 @@ display a message."
;; Reset it anyway. ;; Reset it anyway.
(clrhash comp-deferred-pending-h))) (clrhash comp-deferred-pending-h)))
(defconst comp-warn-primitives
'(null memq gethash and subrp not subr-native-elisp-p
comp--install-trampoline concat if symbolp symbol-name make-string
length aset aref length> mapcar expand-file-name
file-name-as-directory file-exists-p native-elisp-load)
"List of primitives we want to warn about in case of redefinition.
This are essential for the trampoline machinery to work properly.")
(defun comp-trampoline-filename (subr-name)
"Given SUBR-NAME return the filename containing the trampoline."
(concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln"))
(defun comp-eln-load-path-eff ()
"Return a list of effective eln load directories.
Account for `native-comp-eln-load-path' and `comp-native-version-dir'."
(mapcar (lambda (dir)
(expand-file-name comp-native-version-dir
(file-name-as-directory
(expand-file-name dir invocation-directory))))
native-comp-eln-load-path))
(defun comp-trampoline-search (subr-name)
"Search a trampoline file for SUBR-NAME.
Return the trampoline if found or nil otherwise."
(cl-loop
with rel-filename = (comp-trampoline-filename subr-name)
for dir in (comp-eln-load-path-eff)
for filename = (expand-file-name rel-filename dir)
when (file-exists-p filename)
do (cl-return (native-elisp-load filename))))
(declare-function comp-trampoline-compile "comp")
;;;###autoload
(defun comp-subr-trampoline-install (subr-name)
"Make SUBR-NAME effectively advice-able when called from native code."
(when (memq subr-name comp-warn-primitives)
(warn "Redefining `%s' might break native compilation of trampolines."
subr-name))
(unless (or (null native-comp-enable-subr-trampolines)
(memq subr-name native-comp-never-optimize-functions)
(gethash subr-name comp-installed-trampolines-h))
(cl-assert (subr-primitive-p (symbol-function subr-name)))
(when-let ((trampoline (or (comp-trampoline-search subr-name)
(comp-trampoline-compile subr-name))))
(comp--install-trampoline subr-name trampoline))))
;;;###autoload ;;;###autoload
(defun native--compile-async (files &optional recursively load selector) (defun native--compile-async (files &optional recursively load selector)
;; BEWARE, this function is also called directly from C. ;; BEWARE, this function is also called directly from C.

View file

@ -92,19 +92,6 @@ during bootstrap."
:type '(repeat regexp) :type '(repeat regexp)
:version "28.1") :version "28.1")
(defcustom native-comp-never-optimize-functions
'(;; The following two are mandatory for Emacs to be working
;; correctly (see comment in `advice--add-function'). DO NOT
;; REMOVE.
macroexpand rename-buffer)
"Primitive functions to exclude from trampoline optimization.
Primitive functions included in this list will not be called
directly by the natively-compiled code, which makes trampolines for
those primitives unnecessary in case of function redefinition/advice."
:type '(repeat symbol)
:version "28.1")
(defcustom native-comp-compiler-options nil (defcustom native-comp-compiler-options nil
"Command line options passed verbatim to GCC compiler. "Command line options passed verbatim to GCC compiler.
Note that not all options are meaningful and some options might even Note that not all options are meaningful and some options might even
@ -644,30 +631,6 @@ Useful to hook into pass checkers.")
(defvar comp-no-spawn nil (defvar comp-no-spawn nil
"Non-nil don't spawn native compilation processes.") "Non-nil don't spawn native compilation processes.")
(defconst comp-warn-primitives
'(null memq gethash and subrp not subr-native-elisp-p
comp--install-trampoline concat if symbolp symbol-name make-string
length aset aref length> mapcar expand-file-name
file-name-as-directory file-exists-p native-elisp-load)
"List of primitives we want to warn about in case of redefinition.
This are essential for the trampoline machinery to work properly.")
;; Moved early to avoid circularity when comp.el is loaded and
;; `macroexpand' needs to be advised (bug#47049).
;;;###autoload
(defun comp-subr-trampoline-install (subr-name)
"Make SUBR-NAME effectively advice-able when called from native code."
(when (memq subr-name comp-warn-primitives)
(warn "Redefining `%s' might break native compilation of trampolines."
subr-name))
(unless (or (null native-comp-enable-subr-trampolines)
(memq subr-name native-comp-never-optimize-functions)
(gethash subr-name comp-installed-trampolines-h))
(cl-assert (subr-primitive-p (symbol-function subr-name)))
(when-let ((trampoline (or (comp-trampoline-search subr-name)
(comp-trampoline-compile subr-name))))
(comp--install-trampoline subr-name trampoline))))
(cl-defstruct (comp-vec (:copier nil)) (cl-defstruct (comp-vec (:copier nil))
"A re-sizable vector like object." "A re-sizable vector like object."
@ -3635,19 +3598,6 @@ Prepare every function for final compilation and drive the C back-end."
;; Primitive function advice machinery ;; Primitive function advice machinery
(defun comp-eln-load-path-eff ()
"Return a list of effective eln load directories.
Account for `native-comp-eln-load-path' and `comp-native-version-dir'."
(mapcar (lambda (dir)
(expand-file-name comp-native-version-dir
(file-name-as-directory
(expand-file-name dir invocation-directory))))
native-comp-eln-load-path))
(defun comp-trampoline-filename (subr-name)
"Given SUBR-NAME return the filename containing the trampoline."
(concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln"))
(defun comp-make-lambda-list-from-subr (subr) (defun comp-make-lambda-list-from-subr (subr)
"Given SUBR return the equivalent lambda-list." "Given SUBR return the equivalent lambda-list."
(pcase-let ((`(,min . ,max) (subr-arity subr)) (pcase-let ((`(,min . ,max) (subr-arity subr))
@ -3663,16 +3613,6 @@ Account for `native-comp-eln-load-path' and `comp-native-version-dir'."
(push (gensym "arg") lambda-list)) (push (gensym "arg") lambda-list))
(reverse lambda-list))) (reverse lambda-list)))
(defun comp-trampoline-search (subr-name)
"Search a trampoline file for SUBR-NAME.
Return the trampoline if found or nil otherwise."
(cl-loop
with rel-filename = (comp-trampoline-filename subr-name)
for dir in (comp-eln-load-path-eff)
for filename = (expand-file-name rel-filename dir)
when (file-exists-p filename)
do (cl-return (native-elisp-load filename))))
(defun comp--trampoline-abs-filename (subr-name) (defun comp--trampoline-abs-filename (subr-name)
"Return the absolute filename for a trampoline for SUBR-NAME." "Return the absolute filename for a trampoline for SUBR-NAME."
(cl-loop (cl-loop
@ -3698,6 +3638,8 @@ Return the trampoline if found or nil otherwise."
(make-temp-file (file-name-sans-extension rel-filename) nil ".eln" (make-temp-file (file-name-sans-extension rel-filename) nil ".eln"
nil)))) nil))))
;; Called from comp-run.el
;;;###autoload
(defun comp-trampoline-compile (subr-name) (defun comp-trampoline-compile (subr-name)
"Synthesize compile and return a trampoline for SUBR-NAME." "Synthesize compile and return a trampoline for SUBR-NAME."
(let* ((lambda-list (comp-make-lambda-list-from-subr (let* ((lambda-list (comp-make-lambda-list-from-subr

View file

@ -389,7 +389,7 @@ is also interactive. There are 3 cases:
`(advice--add-function ,how (gv-ref ,(advice--normalize-place place)) `(advice--add-function ,how (gv-ref ,(advice--normalize-place place))
,function ,props)) ,function ,props))
(declare-function comp-subr-trampoline-install "comp") (declare-function comp-subr-trampoline-install "comp-run")
;;;###autoload ;;;###autoload
(defun advice--add-function (how ref function props) (defun advice--add-function (how ref function props)
@ -407,7 +407,7 @@ is also interactive. There are 3 cases:
(unless (memq subr-name '(macroexpand rename-buffer)) (unless (memq subr-name '(macroexpand rename-buffer))
;; Must require explicitly as during bootstrap we have no ;; Must require explicitly as during bootstrap we have no
;; autoloads. ;; autoloads.
(require 'comp) (require 'comp-run)
(comp-subr-trampoline-install subr-name)))) (comp-subr-trampoline-install subr-name))))
(let* ((name (cdr (assq 'name props))) (let* ((name (cdr (assq 'name props)))
(a (advice--member-p (or name function) (if name t) (gv-deref ref)))) (a (advice--member-p (or name function) (if name t) (gv-deref ref))))