feature/native-comp 2f78ac3 04/11: * Add `comp--install-trampoline' machinery

[Andrea Corallo]

branch: feature/native-comp
commit 2f78ac32bbef78155e2f52e73d60f7b46fc8afea
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>

    * 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 63a58be..db6aee9 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);