feature/native-comp 03e98f9 6/7: Use form native compilation in `comp-trampoline-compile'

[Andrea Corallo]

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

    Use form native compilation in `comp-trampoline-compile'
    
        * lisp/emacs-lisp/comp.el (comp-trampoline-sym): Remove function.
        (comp-trampoline-filename): As we are introducing an ABI change in
        the eln trampoline format change the trampoline filename to
        disambiguate.
        (comp-trampoline-search): Rename from `comp-search-trampoline'
        and return directly the trampoline.
        (comp-trampoline-compile): Rework to use native form compilation
        in place of un-evaluating a function and return directly the
        trampoline.
        (comp-subr-trampoline-install): Update for
        `comp-trampoline-search' and `comp-trampoline-compile' new
        interfaces.
        * src/comp.c (Fcomp__install_trampoline): Store the trampoline
        itself as value in `comp-installed-trampolines-h'.
        (syms_of_comp): Doc update `comp-installed-trampolines-h'.
---
 lisp/emacs-lisp/comp.el | 66 ++++++++++++++++++++++---------------------------
 src/comp.c              |  6 +++--
 2 files changed, 34 insertions(+), 38 deletions(-)

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index cd13c44..a460340 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -2598,13 +2598,9 @@ Prepare every function for final compilation and drive 
the C back-end."
 
 ;; Primitive funciton advice machinery
 
-(defsubst comp-trampoline-sym (subr-name)
-  "Given SUBR-NAME return the trampoline function name."
-  (intern (concat "--subr-trampoline-" (symbol-name subr-name))))
-
 (defsubst comp-trampoline-filename (subr-name)
   "Given SUBR-NAME return the filename containing the trampoline."
-  (concat (comp-c-func-name subr-name "subr-trampoline-" t) ".eln"))
+  (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln"))
 
 (defun comp-make-lambda-list-from-subr (subr)
   "Given SUBR return the equivalent lambda-list."
@@ -2621,39 +2617,38 @@ Prepare every function for final compilation and drive 
the C back-end."
       (push (gensym "arg") lambda-list))
     (reverse lambda-list)))
 
-(defun comp-search-trampoline (subr-name)
+(defun comp-trampoline-search (subr-name)
   "Search a trampoline file for SUBR-NAME.
-Return the its filename if found or nil otherwise."
+Return the trampoline if found or nil otherwise."
   (cl-loop
    with rel-filename = (comp-trampoline-filename subr-name)
    for dir in comp-eln-load-path
    for filename = (expand-file-name rel-filename
                                     (concat dir comp-native-version-dir))
    when (file-exists-p filename)
-     do (cl-return filename)))
+     do (cl-return (native-elisp-load filename))))
 
 (defun comp-trampoline-compile (subr-name)
-  "Synthesize and compile a trampoline for SUBR-NAME and return its filename."
-  (let ((trampoline-sym (comp-trampoline-sym subr-name))
-        (lambda-list (comp-make-lambda-list-from-subr
-                      (symbol-function subr-name)))
-        ;; Use speed 0 to maximize compilation speed and not to
-        ;; optimize away funcall calls!
-        (byte-optimize nil)
-        (comp-speed 0))
-    ;; The synthesized trampoline must expose the exact same ABI of
-    ;; the primitive we are replacing in the function reloc table.
-    (defalias trampoline-sym
-      `(closure nil ,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)))))
+  "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)))))
+         ;; Use speed 0 to maximize compilation speed and not to
+         ;; optimize away funcall calls!
+         (byte-optimize nil)
+         (comp-speed 0)
+         (lexical-binding t))
     (native-compile
-     trampoline-sym nil
+     form nil
      (cl-loop
       for load-dir in comp-eln-load-path
       for dir = (concat load-dir comp-native-version-dir)
@@ -2674,14 +2669,13 @@ Return the its filename if found or nil otherwise."
   "Make SUBR-NAME effectively advice-able when called from native code."
   (unless (or (memq subr-name comp-never-optimize-functions)
               (gethash subr-name comp-installed-trampolines-h))
-    (let ((trampoline-sym (comp-trampoline-sym subr-name)))
-      (cl-assert (subr-primitive-p (symbol-function subr-name)))
-      (load (or (comp-search-trampoline subr-name)
-                (comp-trampoline-compile subr-name))
-            nil t)
-      (cl-assert
-       (subr-native-elisp-p (symbol-function trampoline-sym)))
-      (comp--install-trampoline subr-name (symbol-function trampoline-sym)))))
+    (cl-assert (subr-primitive-p (symbol-function subr-name)))
+    (comp--install-trampoline
+     subr-name
+     (or (comp-trampoline-search subr-name)
+         (comp-trampoline-compile subr-name)
+         ;; Should never happen.
+         (cl-assert nil)))))
 
 
 ;; Some entry point support code.
diff --git a/src/comp.c b/src/comp.c
index f80172e..0c55557 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -4158,7 +4158,7 @@ DEFUN ("comp--install-trampoline", 
Fcomp__install_trampoline,
       if (EQ (subr, orig_subr))
        {
          freloc.link_table[i] = XSUBR (trampoline)->function.a0;
-         Fputhash (subr_name, Qt, Vcomp_installed_trampolines_h);
+         Fputhash (subr_name, trampoline, Vcomp_installed_trampolines_h);
          return Qt;
        }
       i++;
@@ -5296,7 +5296,9 @@ The last directory of this list is assumed to be the 
system one.  */);
                       redefinable effectivelly.  */);
 
   DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h,
-              doc: /* Hash table subr-name -> bool.  */);
+              doc: /* Hash table subr-name -> installed trampoline.
+This is used to prevent double trampoline instantiation but also to
+protect the trampolines against GC.  */);
   Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table);
 
   Fprovide (intern_c_string ("nativecomp"), Qnil);