Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-06-14 12:31:25 +00:00
Code Issues Projects Releases Packages Wiki Activity

nativecomp: optimize local CU calls at speed 2

Browse source 
* etc/NEWS: Document speed-2 local call optimization.
* etc/TODO: Remove completed item.
* lisp/emacs-lisp/comp.el
(comp--cu-local-func-c-name-v): New function.
(comp--call-optim-form-call): Enable named local direct calls
at speed 2.
(comp--function-trampoline-form): New helper.
(comp-trampoline-compile, comp-local-function-trampoline-compile):
Share trampoline generation.
* lisp/emacs-lisp/comp-run.el
(comp-local-function-trampoline--install-now): New function.
(comp-local-function-trampoline-install): Install local trampolines.
Defer trampoline compilation until after load.
* src/comp.c (emit_call, emit_ctxt_code, compile_function)
(load_comp_unit, unload_comp_unit): Add local function relocation
support.
(native_comp_local_function_p): New function.
(comp--install-local-function-trampoline): New subr.
(syms_of_comp): Register it and update trampoline docs.
* src/comp.h (Lisp_Native_Comp_Unit): Add local relocation slot.
(native_comp_local_function_p): Declare.
* src/data.c (Ffset): Install local trampolines for redefined
named local native functions.  Keep skipping anonymous lambdas.
* src/pdumper.c: Clear local relocation state.
* test/src/comp-tests.el
(comp-tests--run-in-sub-emacs): New helper.
(comp-tests--direct-call-redefinition-form): New helper.
(comp-tests-direct-call-redefinition-speed-split): New test.
(comp-tests-anonymous-lambda-recompile): New test.
(comp-tests-direct-call-with-lambdas): Use an explicit output file.
This commit is contained in:
Andrea Corallo 2026-03-12 14:30:54 +01:00
parent fe121ef586
commit 6198bb89b4
9 changed files with 380 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
etc/NEWS
View file

@ -3885,6 +3885,12 @@ At native compilation speed 2 and above, declared function types are
used for type propagation, value prediction, and optimization within
function bodies.
** Native compilation speed 2 now optimizes local calls.
Named calls between native-compiled functions in the same compilation
unit can now be optimized at speed 2 while still honoring later
redefinition through a trampoline. At speed 3, these calls keep the
previous direct-call behavior.
** Nested backquotes are not supported any more in Pcase patterns.
---

9
etc/TODO
View file

@ -993,15 +993,6 @@ It would make it easy to add (and remove) mappings like
*** Performance
**** Intra compilation unit call optimization
We could have a mechanism similar to what we use for optimizing calls
to primitive functions. IE using a link table for each compilation
unit (CU) such that calls from functions in a CU targeting functions
in the same CU don't have to go through funcall. If one of these
functions is redefined, a trampoline is compiled and installed to
restore the redirection through funcall.
**** Better runtime function inlining
Several functions could be open-coded in generated code once exposed to

29
lisp/emacs-lisp/comp-run.el
View file

@ -152,6 +152,7 @@ if `confirm-kill-processes' is non-nil."
(defvar native-comp-enable-subr-trampolines)
(declare-function comp--install-trampoline "comp.c")
(declare-function comp--install-local-function-trampoline "comp.c")
(declare-function comp-el-to-eln-filename "comp.c")
(declare-function native-elisp-load "comp.c")
@ -407,6 +408,7 @@ Return the trampoline if found or nil otherwise."
do (cl-return (native-elisp-load filename))))
(declare-function comp-trampoline-compile "comp")
(declare-function comp-local-function-trampoline-compile "comp")
;;;###autoload
(defun comp-subr-trampoline-install (subr-name)
"Make SUBR-NAME effectively advice-able when called from native code."
@ -423,6 +425,33 @@ Return the trampoline if found or nil otherwise."
(comp-trampoline-compile subr-name))))
(comp--install-trampoline subr-name trampoline)))))
;;;###autoload
(defun comp-local-function-trampoline--install-now (function-name function)
"Install a trampoline immediately for local FUNCTION-NAME."
(when-let* ((trampoline (comp-local-function-trampoline-compile
function-name function)))
(comp--install-local-function-trampoline function trampoline)))
;;;###autoload
(defun comp-local-function-trampoline-install (function-name function)
"Make local FUNCTION-NAME effectively redefinable for speed-2 native callers."
(unless (null native-comp-enable-subr-trampolines)
(cl-assert (native-comp-function-p function))
(if (and load-in-progress (stringp load-file-name))
(let* ((loaded-file load-file-name)
(installer nil))
;; Avoid native-compiling the trampoline while the current file is
;; still being loaded, otherwise eager macro-expansion can recurse
;; back into that load.
(setq installer
(lambda (file)
(when (equal file loaded-file)
(remove-hook 'after-load-functions installer)
(comp-local-function-trampoline--install-now
function-name function))))
(add-hook 'after-load-functions installer 'append))
(comp-local-function-trampoline--install-now function-name function))))
;;;###autoload
(defun native--compile-async (files &optional recursively load selector)
;; BEWARE, this function is also called directly from C.

57
lisp/emacs-lisp/comp.el
View file

@ -612,6 +612,14 @@ In use by the back-end."
finally return t)
t))
(defun comp--cu-local-func-c-name-v (&optional ctxt)
"Return exported local function C names for CTXT in compilation order."
(vconcat
(cl-loop
for form in (comp-ctxt-top-level-forms (or ctxt comp-ctxt))
when (byte-to-native-func-def-p form)
collect (byte-to-native-func-def-c-name form))))
(defun comp--function-pure-p (f)
"Return t if F is pure."
(or (get f 'pure)
@ -2936,10 +2944,9 @@ Return t if something was changed."
;; - Recursive calls gets optimized into direct calls.
;; Triggered at native-comp-speed >= 2.
;; - Intra compilation unit procedure calls gets optimized into direct calls.
;; This can be a big win and even allow gcc to inline but does not make
;; function in the compilation unit re-definable safely without recompiling
;; the full compilation unit.
;; For this reason this is triggered only at native-comp-speed == 3.
;; At native-comp-speed == 2 named calls use a per-CU relocation table so
;; redefinition can still be honored via trampolines.
;; At native-comp-speed >= 3 keep the previous raw direct-call behavior.
(defun comp--func-in-unit (func)
"Given FUNC return the `comp-fun' definition in the current context.
@ -2987,15 +2994,15 @@ FUNCTION can be a function-name or byte compiled function."
(fill-args args maxarg))))
`(,call-type ,callee ,@args)))
;; Intra compilation unit procedure call optimization.
;; Attention speed 3 triggers this for non self calls too!!
((and comp-func-callee
(comp-func-c-name comp-func-callee)
(or (and (>= (comp-func-speed comp-func) 3)
(comp--func-unique-in-cu-p callee))
(and (>= (comp-func-speed comp-func) 2)
(or (comp--func-unique-in-cu-p callee)
;; Anonymous lambdas can't be redefined so are
;; always safe to optimize.
(byte-code-function-p callee))))
(byte-code-function-p callee)))))
(let* ((func-args (comp-func-l-args comp-func-callee))
(nargs (comp-nargs-p func-args))
(call-type (if nargs 'direct-callref 'direct-call))
@ -3468,6 +3475,18 @@ Prepare every function for final compilation and drive the C back-end."
(push (gensym "arg") lambda-list))
(reverse lambda-list)))
(defun comp--function-trampoline-form (function-name function)
"Return a trampoline form for FUNCTION-NAME with FUNCTION's ABI."
(let ((lambda-list (comp--make-lambda-list-from-subr function)))
`(lambda ,lambda-list
(let ((f #',function-name))
(,(if (memq '&rest lambda-list) #'apply 'funcall)
f
,@(cl-loop
for arg in lambda-list
unless (memq arg '(&optional &rest))
collect arg))))))
(defun comp--trampoline-abs-filename (subr-name)
"Return the absolute filename for a trampoline for SUBR-NAME."
(cl-loop
@ -3497,18 +3516,9 @@ Prepare every function for final compilation and drive the C back-end."
;;;###autoload
(defun comp-trampoline-compile (subr-name)
"Synthesize compile and return a trampoline for SUBR-NAME."
(let* ((lambda-list (comp--make-lambda-list-from-subr
(let* ((form (comp--function-trampoline-form
subr-name
(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 1 for compilation speed and not to optimize away
;; funcall calls!
(byte-optimize nil)
@ -3518,6 +3528,19 @@ Prepare every function for final compilation and drive the C back-end."
form nil
(comp--trampoline-abs-filename subr-name))))
;; Called from comp-run.el
;;;###autoload
(defun comp-local-function-trampoline-compile (function-name function)
"Synthesize compile and return a trampoline for local FUNCTION-NAME.
FUNCTION provides the ABI that the trampoline must expose."
(let* ((form (comp--function-trampoline-form function-name function))
;; Use speed 1 for compilation speed and not to optimize away
;; funcall calls.
(byte-optimize nil)
(native-comp-speed 1)
(lexical-binding t))
(comp--native-compile form)))
;; Some entry point support code.

205
src/comp.c
View file

@ -480,10 +480,12 @@ load_gccjit_if_necessary (bool mandatory)
#define DATA_RELOC_EPHEMERAL_SYM "d_reloc_eph"
#define FUNC_LINK_TABLE_SYM "freloc_link_table"
#define LOCAL_FUNC_LINK_TABLE_SYM "local_freloc_link_table"
#define LINK_TABLE_HASH_SYM "freloc_hash"
#define COMP_UNIT_SYM "comp_unit"
#define TEXT_DATA_RELOC_SYM "text_data_reloc"
#define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph"
#define TEXT_LOCAL_FUNC_C_NAMES_SYM "text_local_func_c_names"
#define TEXT_OPTIM_QLY_SYM "text_optim_qly"
#define TEXT_FDOC_SYM "text_data_fdoc"
@ -650,6 +652,10 @@ typedef struct {
gcc_jit_type *func_relocs_ptr_type;
/* Pointer to this structure local to each function. */
gcc_jit_lvalue *func_relocs_local;
/* Per compilation unit redirection table for local named functions. */
gcc_jit_lvalue *local_func_relocs;
gcc_jit_lvalue *local_func_relocs_local;
Lisp_Object local_func_reloc_idx_h; /* c-name -> relocation index. */
gcc_jit_function *memcpy;
Lisp_Object d_default_idx;
Lisp_Object d_ephemeral_idx;
@ -947,6 +953,9 @@ emit_comment (const char *str)
str);
}
static gcc_jit_rvalue *emit_coerce (gcc_jit_type *new_type,
gcc_jit_rvalue *obj);
/*
Declare an imported function.
When nargs is MANY (ptrdiff_t nargs, Lisp_Object *args) signature is assumed.
@ -1013,18 +1022,55 @@ static gcc_jit_rvalue *
emit_call (Lisp_Object func, gcc_jit_type *ret_type, ptrdiff_t nargs,
gcc_jit_rvalue **args, bool direct)
{
Lisp_Object gcc_func =
Fgethash (func,
direct ? comp.exported_funcs_h : comp.imported_funcs_h,
Qnil);
if (direct)
{
Lisp_Object local_idx = Qnil;
if (comp.func_speed == 2)
local_idx = Fgethash (func, comp.local_func_reloc_idx_h, Qnil);
if (!NILP (local_idx))
{
USE_SAFE_ALLOCA;
gcc_jit_type **types;
SAFE_NALLOCA (types, 1, nargs);
for (ptrdiff_t i = 0; i < nargs; ++i)
types[i] = gcc_jit_rvalue_get_type (args[i]);
gcc_jit_type *f_ptr_type =
gcc_jit_type_get_const (
gcc_jit_context_new_function_ptr_type (comp.ctxt,
NULL,
ret_type,
nargs,
types,
0));
gcc_jit_lvalue *f_ptr =
gcc_jit_context_new_array_access (
comp.ctxt,
NULL,
gcc_jit_lvalue_as_rvalue (comp.local_func_relocs_local
? comp.local_func_relocs_local
: comp.local_func_relocs),
gcc_jit_context_new_rvalue_from_int (comp.ctxt,
comp.ptrdiff_type,
XFIXNUM (local_idx)));
gcc_jit_rvalue *res =
gcc_jit_context_new_call_through_ptr (
comp.ctxt,
NULL,
emit_coerce (f_ptr_type, gcc_jit_lvalue_as_rvalue (f_ptr)),
nargs,
args);
SAFE_FREE ();
emit_comment (format_string ("direct call via local reloc to: %s",
SSDATA (func)));
return res;
}
Lisp_Object gcc_func = Fgethash (func, comp.exported_funcs_h, Qnil);
if (NILP (gcc_func))
xsignal2 (Qnative_ice,
build_string ("missing function declaration"),
func);
if (direct)
{
emit_comment (format_string ("direct call to: %s",
SSDATA (func)));
return gcc_jit_context_new_call (comp.ctxt,
@ -1035,6 +1081,11 @@ emit_call (Lisp_Object func, gcc_jit_type *ret_type, ptrdiff_t nargs,
}
else
{
Lisp_Object gcc_func = Fgethash (func, comp.imported_funcs_h, Qnil);
if (NILP (gcc_func))
xsignal2 (Qnative_ice,
build_string ("missing function declaration"),
func);
/* Inline functions so far don't have a local variable for
function reloc table so we fall back to the global one. Even
if this is not aesthetic calling into C from open-code is
@ -2981,6 +3032,14 @@ emit_ctxt_code (void)
emit_static_object (TEXT_FDOC_SYM,
CALLNI (comp-ctxt-function-docs, Vcomp_ctxt));
Lisp_Object local_func_c_names
= CALLNI (comp--cu-local-func-c-name-v, Vcomp_ctxt);
emit_static_object (TEXT_LOCAL_FUNC_C_NAMES_SYM, local_func_c_names);
CHECK_VECTOR (local_func_c_names);
for (EMACS_INT i = 0; i < ASIZE (local_func_c_names); ++i)
Fputhash (AREF (local_func_c_names, i), make_fixnum (i),
comp.local_func_reloc_idx_h);
comp.current_thread_ref =
gcc_jit_lvalue_as_rvalue (
gcc_jit_context_new_global (
@ -2999,6 +3058,13 @@ emit_ctxt_code (void)
comp.bool_ptr_type,
F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM));
comp.local_func_relocs =
gcc_jit_context_new_global (comp.ctxt,
NULL,
GCC_JIT_GLOBAL_EXPORTED,
gcc_jit_type_get_pointer (comp.void_ptr_type),
LOCAL_FUNC_LINK_TABLE_SYM);
gcc_jit_context_new_global (
comp.ctxt,
NULL,
@ -4186,6 +4252,11 @@ compile_function (Lisp_Object func)
NULL,
comp.func_relocs_ptr_type,
"freloc");
comp.local_func_relocs_local =
gcc_jit_function_new_local (comp.func,
NULL,
gcc_jit_type_get_pointer (comp.void_ptr_type),
"local_freloc");
SAFE_NALLOCA (comp.frame, 1, comp.frame_size);
if (comp.func_has_non_local || !comp.func_speed)
@ -4242,6 +4313,10 @@ compile_function (Lisp_Object func)
NULL,
comp.func_relocs_local,
gcc_jit_lvalue_as_rvalue (comp.func_relocs));
gcc_jit_block_add_assignment (retrieve_block (Qentry),
NULL,
comp.local_func_relocs_local,
gcc_jit_lvalue_as_rvalue (comp.local_func_relocs));
DOHASH (ht, block_name, block)
@ -4619,6 +4694,7 @@ Return t on success. */)
collected by libgccjit when the ctxt is released.
*/
comp.imported_funcs_h = Fmake_hash_table (0, NULL);
comp.local_func_reloc_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal);
define_memcpy ();
@ -4774,6 +4850,7 @@ DEFUN ("comp--compile-ctxt-to-file0", Fcomp__compile_ctxt_to_file0,
Lisp_Object ebase_name = ENCODE_FILE (base_name);
comp.func_relocs_local = NULL;
comp.local_func_relocs_local = NULL;
#ifdef WINDOWSNT
ebase_name = ansi_encode_filename (ebase_name);
@ -5266,22 +5343,47 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump,
dynlib_sym (handle, F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM);
Lisp_Object *data_relocs = comp_u->data_relocs;
void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM);
void ***local_freloc_link_table
= dynlib_sym (handle, LOCAL_FUNC_LINK_TABLE_SYM);
Lisp_Object local_func_c_names =
load_static_obj (comp_u, TEXT_LOCAL_FUNC_C_NAMES_SYM);
if (!(current_thread_reloc
&& f_symbols_with_pos_enabled_reloc
&& data_relocs
&& data_eph_relocs
&& freloc_link_table
&& local_freloc_link_table
&& top_level_run)
|| NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM),
Vcomp_abi_hash)))
xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
if (!VECTORP (local_func_c_names))
xsignal2 (Qnative_lisp_file_inconsistent, comp_u->file,
build_string ("missing local function relocation vector"));
*current_thread_reloc = &current_thread;
*f_symbols_with_pos_enabled_reloc = &symbols_with_pos_enabled;
/* Imported functions. */
*freloc_link_table = freloc.link_table;
ptrdiff_t n_local_frelocs = ASIZE (local_func_c_names);
comp_u->local_func_relocs =
n_local_frelocs
? xnmalloc (n_local_frelocs, sizeof (*comp_u->local_func_relocs))
: NULL;
*local_freloc_link_table = comp_u->local_func_relocs;
for (ptrdiff_t i = 0; i < n_local_frelocs; ++i)
{
Lisp_Object c_name = AREF (local_func_c_names, i);
if (!STRINGP (c_name))
xsignal2 (Qnative_lisp_file_inconsistent, comp_u->file,
build_string ("invalid local function relocation name"));
void *func = dynlib_sym (handle, SSDATA (c_name));
if (!func)
xsignal2 (Qnative_lisp_file_inconsistent, comp_u->file, c_name);
comp_u->local_func_relocs[i] = func;
}
/* Imported data. */
if (!loading_dump)
@ -5351,6 +5453,8 @@ unload_comp_unit (struct Lisp_Native_Comp_Unit *cu)
if (EQ (this_cu, *saved_cu))
*saved_cu = Qnil;
dynlib_close (cu->handle);
xfree (cu->local_func_relocs);
cu->local_func_relocs = NULL;
}
Lisp_Object
@ -5370,6 +5474,70 @@ native_function_doc (Lisp_Object function)
return make_fixnum (doc);
}
static ptrdiff_t
find_comp_unit_local_func_reloc_idx (struct Lisp_Native_Comp_Unit *cu,
const char *c_name)
{
Lisp_Object names = load_static_obj (cu, TEXT_LOCAL_FUNC_C_NAMES_SYM);
if (!VECTORP (names))
xsignal2 (Qnative_lisp_file_inconsistent, cu->file,
build_string ("missing local function relocation vector"));
Lisp_Object target = build_string (c_name);
ptrdiff_t len = ASIZE (names);
for (ptrdiff_t i = 0; i < len; ++i)
if (!NILP (Fstring_equal (AREF (names, i), target)))
return i;
return -1;
}
bool
native_comp_local_function_p (Lisp_Object function)
{
if (!NATIVE_COMP_FUNCTIONP (function))
return false;
struct Lisp_Native_Comp_Unit *cu =
XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (function));
return (cu->local_func_relocs
&& find_comp_unit_local_func_reloc_idx (
cu, XSUBR (function)->native_c_name) >= 0);
}
DEFUN ("comp--install-local-function-trampoline",
Fcomp__install_local_function_trampoline,
Scomp__install_local_function_trampoline, 2, 2, 0,
doc: /* Install TRAMPOLINE for speed-2 local native-compiled FUNCTION. */)
(Lisp_Object function, Lisp_Object trampoline)
{
CHECK_SUBR (function);
CHECK_SUBR (trampoline);
CHECK_TYPE (NATIVE_COMP_FUNCTIONP (function), Qnative_comp_function,
function);
if (will_dump_p ())
signal_error ("Trying to advice unexpected native function before dumping",
function);
struct Lisp_Native_Comp_Unit *cu =
XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (function));
if (!cu->local_func_relocs)
signal_error ("Trying to install trampoline for unloaded compilation unit",
function);
ptrdiff_t idx = find_comp_unit_local_func_reloc_idx (
cu, XSUBR (function)->native_c_name);
if (idx < 0)
signal_error ("Trying to install trampoline for non existent local native function",
function);
cu->local_func_relocs[idx] = XSUBR (trampoline)->function.a0;
Fputhash (trampoline, Qt, cu->lambda_gc_guard_h);
return Qt;
}
static Lisp_Object
make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg,
Lisp_Object c_name, Lisp_Object type, Lisp_Object doc_idx,
@ -5697,6 +5865,7 @@ natively compiled one. */);
defsubr (&Scomp_native_driver_options_effective_p);
defsubr (&Scomp_native_compiler_options_effective_p);
defsubr (&Scomp__install_trampoline);
defsubr (&Scomp__install_local_function_trampoline);
defsubr (&Scomp__init_ctxt);
defsubr (&Scomp__release_ctxt);
defsubr (&Scomp__compile_ctxt_to_file0);
@ -5710,6 +5879,8 @@ natively compiled one. */);
comp.exported_funcs_h = Qnil;
staticpro (&comp.imported_funcs_h);
comp.imported_funcs_h = Qnil;
staticpro (&comp.local_func_reloc_idx_h);
comp.local_func_reloc_idx_h = Qnil;
staticpro (&comp.func_blocks_h);
staticpro (&comp.emitter_dispatcher);
comp.emitter_dispatcher = Qnil;
@ -5759,14 +5930,15 @@ Emacs. */);
DEFVAR_LISP ("native-comp-enable-subr-trampolines",
Vnative_comp_enable_subr_trampolines,
doc: /* If non-nil, enable generation of trampolines for calling primitives.
doc: /* If non-nil, enable generation of trampolines for optimized calls.
Trampolines are needed so that Emacs respects redefinition or advice of
primitive functions when they are called from native-compiled Lisp code
at `native-comp-speed' of 2.
primitive functions, and redefinition of named native-compiled
functions inside the same compilation unit, when these calls are
optimized by native compilation at speed 2.
By default, the value is t, and when Emacs sees a redefined or advised
primitive called from native-compiled Lisp, it generates a trampoline
for it on-the-fly.
optimized function called from native-compiled Lisp, it generates a
trampoline for it on-the-fly.
If the value is a file name (a string), it specifies the directory in
which to deposit the generated trampolines, overriding the directories
@ -5775,12 +5947,9 @@ in `native-comp-eln-load-path'.
When this variable is nil, generation of trampolines is disabled.
Disabling the generation of trampolines, when a trampoline for a redefined
or advised primitive is not already available from previous compilations,
means that such redefinition or advice will not have effect when calling
primitives from native-compiled Lisp code. That is, calls to primitives
without existing trampolines from native-compiled Lisp will behave as if
the primitive was called directly from C, and will ignore its redefinition
and advice. */);
or advised optimized function is not already available, means that such
redefinition or advice will not have effect when calling that function
from native-compiled Lisp code. */);
DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h,
doc: /* Hash table subr-name -> installed trampoline.

10
src/comp.h
View file

@ -44,6 +44,7 @@ struct Lisp_Native_Comp_Unit
Lisp_Object data_vec;
/* STUFFS WE DO NOT DUMP!! */
Lisp_Object *data_relocs;
void **local_func_relocs;
bool loaded_once;
bool load_ongoing;
dynlib_handle_ptr handle;
@ -75,6 +76,8 @@ extern Lisp_Object load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u,
extern void unload_comp_unit (struct Lisp_Native_Comp_Unit *);
extern bool native_comp_local_function_p (Lisp_Object function);
extern Lisp_Object native_function_doc (Lisp_Object function);
extern void syms_of_comp (void);
@ -97,6 +100,13 @@ static inline
void unload_comp_unit (struct Lisp_Native_Comp_Unit *cu)
{}
static inline bool
native_comp_local_function_p (Lisp_Object function)
{
(void) function;
return false;
}
extern void syms_of_comp (void);
INLINE_HEADER_END

18
src/data.c
View file

@ -912,10 +912,24 @@ signal a `cyclic-function-indirection' error. */)
register Lisp_Object function = XSYMBOL (symbol)->u.s.function;
if (!NILP (Vnative_comp_enable_subr_trampolines)
&& SUBRP (function)
&& !NATIVE_COMP_FUNCTIONP (function)
&& !EQ (definition, Fsymbol_function (symbol)))
{
if (SUBRP (function) && !NATIVE_COMP_FUNCTIONP (function))
calln (Qcomp_subr_trampoline_install, symbol);
else if (NATIVE_COMP_FUNCTIONP (function))
{
if (!EQ (symbol, intern_c_string ("--anonymous-lambda"))
&& native_comp_local_function_p (function)
&& !(NATIVE_COMP_FUNCTIONP (definition)
&& EQ (Fsubr_native_comp_unit (function),
Fsubr_native_comp_unit (definition))))
{
calln (intern_c_string ("require"), intern_c_string ("comp-run"));
calln (intern_c_string ("comp-local-function-trampoline-install"),
symbol, function);
}
}
}
#endif
set_symbol_function (symbol, definition);

1
src/pdumper.c
View file

@ -2960,6 +2960,7 @@ dump_native_comp_unit (struct dump_context *ctx,
START_DUMP_PVEC (ctx, &comp_u->header, struct Lisp_Native_Comp_Unit, out);
dump_pseudovector_lisp_fields (ctx, &out->header, &comp_u->header);
out->handle = NULL;
out->local_func_relocs = NULL;
dump_off comp_u_off = finish_dump_pvec (ctx, &out->header);
if (ctx->flags.dump_object_contents)

85
test/src/comp-tests.el
View file

@ -1648,6 +1648,63 @@ folded."
(or (comp-tests-mentioned-p 'direct-call insn)
(comp-tests-mentioned-p 'direct-callref insn))))))
(defun comp-tests--unbind-direct-call-functions ()
"Clear shared definitions used by the direct-call fixture."
(dolist (sym '(comp-tests-direct-call-caller-f
comp-tests-direct-call-callee-f))
(when (fboundp sym)
(fmakunbound sym))))
(defun comp-tests--run-in-sub-emacs (form)
"Run FORM in a fresh batch Emacs and return (STATUS . OUTPUT)."
(let* ((default-directory (expand-file-name ".." invocation-directory))
(emacs (expand-file-name invocation-name invocation-directory))
(buf (generate-new-buffer " *comp-sub-emacs*")))
(unwind-protect
(cons
(call-process emacs nil buf nil
"--batch" "--no-init-file" "--no-site-file"
"--no-site-lisp"
"--eval" "(setq native-comp-eln-load-path (list temporary-file-directory))"
"-L" "test" "-l" "ert"
"-l" "test/src/comp-tests.el"
"--eval" (prin1-to-string form))
(with-current-buffer buf
(buffer-string)))
(kill-buffer buf))))
(defun comp-tests--direct-call-redefinition-form (speed expected-first expected-second)
"Return a form checking direct-call redefinition at SPEED.
The caller should produce EXPECTED-FIRST and EXPECTED-SECOND after
successive callee redefinitions."
`(let* ((native-comp-speed ,speed)
(native-comp-eln-load-path (list temporary-file-directory))
(source ,(ert-resource-file "comp-test-direct-call.el"))
(output (make-temp-file ,(format "comp-test-direct-call-speed%d-" speed)
nil ".eln")))
(comp-tests--unbind-direct-call-functions)
(delete-file output)
(let ((comp-post-pass-hooks
'((comp--final
(lambda (_)
(unless (comp-tests-has-direct-call-p
'comp-tests-direct-call-caller-f)
(error "missing direct call optimization")))))))
(native-compile source output))
(load output)
(let ((orig (symbol-function 'comp-tests-direct-call-callee-f)))
(unwind-protect
(progn
(fset 'comp-tests-direct-call-callee-f
(lambda (x) (+ x 100)))
(unless (= (comp-tests-direct-call-caller-f 3) ,expected-first)
(error "unexpected first result at speed %d" ,speed))
(fset 'comp-tests-direct-call-callee-f
(lambda (x) (+ x 200)))
(unless (= (comp-tests-direct-call-caller-f 3) ,expected-second)
(error "unexpected second result at speed %d" ,speed)))
(fset 'comp-tests-direct-call-callee-f orig)))))
(comp-deftest direct-call-with-lambdas ()
"Check that anonymous lambdas don't prevent direct calls at speed 3.
See `comp--func-unique-in-cu-p'."
@ -1657,13 +1714,37 @@ See `comp--func-unique-in-cu-p'."
(lambda (_)
(should (comp-tests-has-direct-call-p
'comp-tests-direct-call-caller-f)))))))
(load (native-compile
(ert-resource-file "comp-test-direct-call.el")))
(let* ((source (ert-resource-file "comp-test-direct-call.el"))
(output (make-temp-file "comp-test-direct-call-lambdas-" nil ".eln")))
(comp-tests--unbind-direct-call-functions)
(delete-file output)
(native-compile source output)
(load output))
(declare-function comp-tests-direct-call-caller-f nil)
(should (native-comp-function-p
(symbol-function 'comp-tests-direct-call-caller-f)))
(should (= (comp-tests-direct-call-caller-f 3) 4))))
(comp-deftest anonymous-lambda-recompile ()
"Check that recompiling standalone lambdas does not recurse via `fset'."
(let ((f1 (native-compile '(lambda () 1)))
(f2 (native-compile '(lambda () 2))))
(should (native-comp-function-p f1))
(should (native-comp-function-p f2))
(should (= (funcall f1) 1))
(should (= (funcall f2) 2))))
(comp-deftest direct-call-redefinition-speed-split ()
"Check speed-2 and speed-3 redefinition behavior for named direct calls."
(dolist (case '((2 103 203) (3 4 4)))
(pcase-let* ((`(,speed ,expected-first ,expected-second) case)
(`(,status . ,output)
(comp-tests--run-in-sub-emacs
(comp-tests--direct-call-redefinition-form
speed expected-first expected-second))))
(ert-info ((format "speed %d subprocess output:\n%s" speed output))
(should (zerop status))))))
(comp-deftest direct-call-with-duplicate-names ()
"Check that duplicate names only block their own direct calls.
See `comp--func-unique-in-cu-p'."