mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-14 09:39:42 +00:00
Code Issues Releases Activity

Use form native compilation in `comp-trampoline-compile'

Browse Source 
* lisp/emacs-lisp/comp.el (comp-trampoline-sym): Remove function.
	(comp-trampoline-filename): As we are introducing an ABI change in
	the eln trampoline format change the trampoline filename to
	disambiguate.
	(comp-trampoline-search): Rename from `comp-search-trampoline'
	and return directly the trampoline.
	(comp-trampoline-compile): Rework to use native form compilation
	in place of un-evaluating a function and return directly the
	trampoline.
	(comp-subr-trampoline-install): Update for
	`comp-trampoline-search' and `comp-trampoline-compile' new
	interfaces.
	* src/comp.c (Fcomp__install_trampoline): Store the trampoline
	itself as value in `comp-installed-trampolines-h'.
	(syms_of_comp): Doc update `comp-installed-trampolines-h'.
This commit is contained in:
Andrea Corallo 2020-10-13 22:48:22 +02:00
parent e9c150b5c2
commit 03e98f93f7
2 changed files with 34 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
lisp/emacs-lisp/comp.el
View File

@ -2598,13 +2598,9 @@ Prepare every function for final compilation and drive the C back-end."
;; Primitive funciton advice machinery
(defsubst comp-trampoline-sym (subr-name)
"Given SUBR-NAME return the trampoline function name."
(intern (concat "--subr-trampoline-" (symbol-name subr-name))))
(defsubst 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"))
(concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln"))
(defun comp-make-lambda-list-from-subr (subr)
"Given SUBR return the equivalent lambda-list."
@ -2621,39 +2617,38 @@ Prepare every function for final compilation and drive the C back-end."
(push (gensym "arg") lambda-list))
(reverse lambda-list)))
(defun comp-search-trampoline (subr-name)
(defun comp-trampoline-search (subr-name)
"Search a trampoline file for SUBR-NAME.
Return the its filename if found or nil otherwise."
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
for filename = (expand-file-name rel-filename
(concat dir comp-native-version-dir))
when (file-exists-p filename)
do (cl-return filename)))
do (cl-return (native-elisp-load filename))))
(defun comp-trampoline-compile (subr-name)
"Synthesize and compile a trampoline for SUBR-NAME and return its filename."
(let ((trampoline-sym (comp-trampoline-sym subr-name))
(lambda-list (comp-make-lambda-list-from-subr
(symbol-function subr-name)))
;; Use speed 0 to maximize compilation speed and not to
;; optimize away funcall calls!
(byte-optimize nil)
(comp-speed 0))
;; The synthesized trampoline must expose the exact same ABI of
;; the primitive we are replacing in the function reloc table.
(defalias trampoline-sym
`(closure nil ,lambda-list
(let ((f #',subr-name))
(,(if (memq '&rest lambda-list) #'apply 'funcall)
f
,@(cl-loop
for arg in lambda-list
unless (memq arg '(&optional &rest))
collect arg)))))
"Synthesize compile and return a trampoline for SUBR-NAME."
(let* ((lambda-list (comp-make-lambda-list-from-subr
(symbol-function subr-name)))
;; The synthesized trampoline must expose the exact same ABI of
;; the primitive we are replacing in the function reloc table.
(form `(lambda ,lambda-list
(let ((f #',subr-name))
(,(if (memq '&rest lambda-list) #'apply 'funcall)
f
,@(cl-loop
for arg in lambda-list
unless (memq arg '(&optional &rest))
collect arg)))))
;; Use speed 0 to maximize compilation speed and not to
;; optimize away funcall calls!
(byte-optimize nil)
(comp-speed 0)
(lexical-binding t))
(native-compile
trampoline-sym nil
form nil
(cl-loop
for load-dir in comp-eln-load-path
for dir = (concat load-dir comp-native-version-dir)
@ -2674,14 +2669,13 @@ Return the its filename if found or nil otherwise."
"Make SUBR-NAME effectively advice-able when called from native code."
(unless (or (memq subr-name comp-never-optimize-functions)
(gethash subr-name comp-installed-trampolines-h))
(let ((trampoline-sym (comp-trampoline-sym subr-name)))
(cl-assert (subr-primitive-p (symbol-function subr-name)))
(load (or (comp-search-trampoline subr-name)
(comp-trampoline-compile subr-name))
nil t)
(cl-assert
(subr-native-elisp-p (symbol-function trampoline-sym)))
(comp--install-trampoline subr-name (symbol-function trampoline-sym)))))
(cl-assert (subr-primitive-p (symbol-function subr-name)))
(comp--install-trampoline
subr-name
(or (comp-trampoline-search subr-name)
(comp-trampoline-compile subr-name)
;; Should never happen.
(cl-assert nil)))))
;; Some entry point support code.

6
src/comp.c
View File

@ -4158,7 +4158,7 @@ DEFUN ("comp--install-trampoline", Fcomp__install_trampoline,
if (EQ (subr, orig_subr))
{
freloc.link_table[i] = XSUBR (trampoline)->function.a0;
Fputhash (subr_name, Qt, Vcomp_installed_trampolines_h);
Fputhash (subr_name, trampoline, Vcomp_installed_trampolines_h);
return Qt;
}
i++;
@ -5296,7 +5296,9 @@ The last directory of this list is assumed to be the system one. */);
redefinable effectivelly. */);
DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h,
doc: /* Hash table subr-name -> bool. */);
doc: /* Hash table subr-name -> installed trampoline.
This is used to prevent double trampoline instantiation but also to
protect the trampolines against GC. */);
Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table);
Fprovide (intern_c_string ("nativecomp"), Qnil);