Support `comp-enable-subr-trampolines' as string value

* src/comp.c (syms_of_comp): Update `comp-enable-subr-trampolines'.

* lisp/emacs-lisp/comp.el (native-comp-never-optimize-functions)
(comp--trampoline-abs-filename): Support
`comp-enable-subr-trampolines' string value.

* src/data.c (Ffset): Use Vcomp_enable_subr_trampolines now.
This commit is contained in:
Andrea Corallo 2023-02-13 11:09:46 +01:00
parent b6e2799aa1
commit 1795839bab
3 changed files with 28 additions and 18 deletions

View file

@ -3782,6 +3782,28 @@ Return the trampoline if found or nil otherwise."
when (file-exists-p filename) when (file-exists-p filename)
do (cl-return (native-elisp-load filename)))) do (cl-return (native-elisp-load filename))))
(defun comp--trampoline-abs-filename (subr-name)
"Return the absolute filename for a trampoline for SUBR-NAME."
(cl-loop
with dirs = (if (stringp comp-enable-subr-trampolines)
(list comp-enable-subr-trampolines)
(if native-compile-target-directory
(list (expand-file-name comp-native-version-dir
native-compile-target-directory))
(comp-eln-load-path-eff)))
for dir in dirs
for f = (expand-file-name
(comp-trampoline-filename subr-name)
dir)
unless (file-exists-p dir)
do (ignore-errors
(make-directory dir t)
(cl-return f))
when (file-writable-p f)
do (cl-return f)
finally (error "Cannot find suitable directory for output in \
`native-comp-eln-load-path'")))
(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
@ -3803,22 +3825,7 @@ Return the trampoline if found or nil otherwise."
(lexical-binding t)) (lexical-binding t))
(comp--native-compile (comp--native-compile
form nil form nil
(cl-loop (comp--trampoline-abs-filename subr-name))))
for dir in (if native-compile-target-directory
(list (expand-file-name comp-native-version-dir
native-compile-target-directory))
(comp-eln-load-path-eff))
for f = (expand-file-name
(comp-trampoline-filename subr-name)
dir)
unless (file-exists-p dir)
do (ignore-errors
(make-directory dir t)
(cl-return f))
when (file-writable-p f)
do (cl-return f)
finally (error "Cannot find suitable directory for output in \
`native-comp-eln-load-path'")))))
;; Some entry point support code. ;; Some entry point support code.

View file

@ -5858,12 +5858,15 @@ The last directory of this list is assumed to be the system one. */);
dump reload. */ dump reload. */
Vnative_comp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); Vnative_comp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil);
DEFVAR_BOOL ("comp-enable-subr-trampolines", comp_enable_subr_trampolines, DEFVAR_LISP ("comp-enable-subr-trampolines", Vcomp_enable_subr_trampolines,
doc: /* If non-nil, enable primitive trampoline synthesis. doc: /* If non-nil, enable primitive trampoline synthesis.
This makes Emacs respect redefinition or advises of primitive functions This makes Emacs respect redefinition or advises of primitive functions
when they are called from Lisp code natively-compiled at `native-comp-speed' when they are called from Lisp code natively-compiled at `native-comp-speed'
of 2. of 2.
If `comp-enable-subr-trampolines' is a string it specifies a directory
in which to deposit the trampoline.
By default, this is enabled, and when Emacs sees a redefined or advised By default, this is enabled, and when Emacs sees a redefined or advised
primitive called from natively-compiled Lisp, it generates a trampoline primitive called from natively-compiled Lisp, it generates a trampoline
for it on-the-fly. for it on-the-fly.

View file

@ -855,7 +855,7 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
#ifdef HAVE_NATIVE_COMP #ifdef HAVE_NATIVE_COMP
register Lisp_Object function = XSYMBOL (symbol)->u.s.function; register Lisp_Object function = XSYMBOL (symbol)->u.s.function;
if (comp_enable_subr_trampolines if (!NILP (Vcomp_enable_subr_trampolines)
&& SUBRP (function) && SUBRP (function)
&& !SUBR_NATIVE_COMPILEDP (function)) && !SUBR_NATIVE_COMPILEDP (function))
CALLN (Ffuncall, Qcomp_subr_trampoline_install, symbol); CALLN (Ffuncall, Qcomp_subr_trampoline_install, symbol);