diff --git a/etc/NEWS b/etc/NEWS index 6107ee153f5..8f67b3f870f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -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. --- diff --git a/etc/TODO b/etc/TODO index b93236d3759..e577fec0e6e 100644 --- a/etc/TODO +++ b/etc/TODO @@ -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 diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index f329d627392..b63479b8ac4 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -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. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index ec95dfdb8b2..ba9a25c39e1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -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) - ;; Anonymous lambdas can't be redefined so are - ;; always safe to optimize. - (byte-code-function-p callee)))) + (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))))) (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 - (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))))) + (let* ((form (comp--function-trampoline-form + subr-name + (symbol-function subr-name))) ;; 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. diff --git a/src/comp.c b/src/comp.c index ac45eb72cfc..4227a502693 100644 --- a/src/comp.c +++ b/src/comp.c @@ -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 (NILP (gcc_func)) - xsignal2 (Qnative_ice, - build_string ("missing function declaration"), - func); - 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); 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) @@ -4617,8 +4692,9 @@ Return t on success. */) /* Always reinitialize this cause old function definitions are garbage 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 = ¤t_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. diff --git a/src/comp.h b/src/comp.h index 16f2aab7b9a..5b4fec9d132 100644 --- a/src/comp.h +++ b/src/comp.h @@ -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 diff --git a/src/data.c b/src/data.c index 4973d577c1c..2360033bb6b 100644 --- a/src/data.c +++ b/src/data.c @@ -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))) - calln (Qcomp_subr_trampoline_install, 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); diff --git a/src/pdumper.c b/src/pdumper.c index c21af24d9f1..7108aa64788 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -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) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index e322bdb057e..32d5859562f 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -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'."