nativecomp: optimize local CU calls at speed 2

* 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.

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.
 
 ---

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

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.

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
+;;   At native-comp-speed == 2 named calls use a per-CU relocation table so
-;;   function in the compilation unit re-definable safely without recompiling
+;;   redefinition can still be honored via trampolines.
-;;   the full compilation unit.
+;;   At native-comp-speed >= 3 keep the previous raw direct-call behavior.
-;;   For this reason this is triggered only at native-comp-speed == 3.
 
 (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
+                        (or (comp--func-unique-in-cu-p callee)
-                        ;; always safe to optimize.
+                            ;; Anonymous lambdas can't be redefined so are
-                        (byte-code-function-p callee))))
+                            ;; 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
+  (let* ((form (comp--function-trampoline-form
-                       (symbol-function subr-name)))
+                subr-name
-         ;; The synthesized trampoline must expose the exact same ABI of
+                (symbol-function subr-name)))
-         ;; 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.
 

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 = &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
+primitive functions, and redefinition of named native-compiled
-at `native-comp-speed' of 2.
+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
+optimized function called from native-compiled Lisp, it generates a
-for it on-the-fly.
+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,
+or advised optimized function is not already available, means that such
-means that such redefinition or advice will not have effect when calling
+redefinition or advice will not have effect when calling that function
-primitives from native-compiled Lisp code.  That is, calls to primitives
+from native-compiled Lisp code.  */);
-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.  */);
 
   DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h,
     doc: /* Hash table subr-name -> installed trampoline.

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

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);

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)

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
+    (let* ((source (ert-resource-file "comp-test-direct-call.el"))
-           (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'."