From 2f78ac32bbef78155e2f52e73d60f7b46fc8afea Mon Sep 17 00:00:00 2001
From: Andrea Corallo <akrl@sdf.org>
Date: Sat, 19 Sep 2020 16:44:53 +0200
Subject: [PATCH] * Add `comp--install-trampoline' machinery

	* src/comp.c (Fcomp__install_trampoline): New function to
	install a subr trampoline into the function relocation table.
	Once this is done any call from native compiled Lisp to the
	related primitive will go through the `funcall' trampoline
	making advicing effective.
---
 src/comp.c | 34 ++++++++++++++++++++++++++++++++++
 1 file changed, 34 insertions(+)

diff --git a/src/comp.c b/src/comp.c
index 63a58be264c..db6aee9d7b1 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -4102,6 +4102,39 @@ If BASE-DIR is nil use the first entry in `comp-eln-load-path'.  */)
 			    concat2 (base_dir, Vcomp_native_version_dir));
 }
 
+DEFUN ("comp--install-trampoline", Fcomp__install_trampoline,
+       Scomp__install_trampoline, 2, 2, 0,
+       doc: /* Install a TRAMPOLINE for primitive SUBR-NAME.  */)
+  (Lisp_Object subr_name, Lisp_Object trampoline)
+{
+  CHECK_SYMBOL (subr_name);
+  CHECK_SUBR (trampoline);
+  Lisp_Object orig_subr = Fsymbol_function (subr_name);
+  CHECK_SUBR (orig_subr);
+
+  /* FIXME: add a post dump load trampoline machinery to remove this
+     check.  */
+  if (will_dump_p ())
+    signal_error ("Trying to advice unexpected primitive before dumping",
+		  subr_name);
+
+  Lisp_Object subr_l = Vcomp_subr_list;
+  ptrdiff_t i = ARRAYELTS (helper_link_table);
+  FOR_EACH_TAIL (subr_l)
+    {
+      Lisp_Object subr = XCAR (subr_l);
+      if (EQ (subr, orig_subr))
+	{
+	  freloc.link_table[i] = XSUBR (trampoline)->function.a0;
+	  return Qt;
+	}
+      i++;
+    }
+    signal_error ("Trying to install trampoline for non existent subr",
+		  subr_name);
+    return Qnil;
+}
+
 DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt,
        0, 0, 0,
        doc: /* Initialize the native compiler context. Return t on success.  */)
@@ -5162,6 +5195,7 @@ native compiled one.  */);
 
   defsubr (&Scomp_el_to_eln_filename);
   defsubr (&Scomp_native_driver_options_effective_p);
+  defsubr (&Scomp__install_trampoline);
   defsubr (&Scomp__init_ctxt);
   defsubr (&Scomp__release_ctxt);
   defsubr (&Scomp__compile_ctxt_to_file);
-- 
2.39.5