From: Andrea Corallo <andrea_corallo@yahoo.it>
Date: Mon, 8 Jul 2019 10:11:34 +0000 (+0200)
Subject: add comp-c-func-name
X-Git-Tag: emacs-28.0.90~2727^2~1383
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=34e0be815db9c9ad8f8b98b52824aa3cf15a3ccc;p=emacs.git

add comp-c-func-name
---

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index b6e3e010323..90713ec77b6 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -54,11 +54,13 @@
 (cl-defstruct (comp-func (:copier nil))
   "Internal rapresentation for a function."
   (symbol-name nil
-   :documentation "Function symbol's name")
+               :documentation "Function symbol's name")
+  (c-func-name nil :type 'string
+               :documentation "The function name in the native world")
   (func nil
-   :documentation "Original form")
+        :documentation "Original form")
   (byte-func nil
-   :documentation "Byte compiled version")
+             :documentation "Byte compiled version")
   (ir nil
       :documentation "Current intermediate rappresentation")
   (args nil :type 'comp-args)
@@ -86,6 +88,21 @@
   (frame nil :type 'vector
          :documentation "Meta-stack used to flat LAP"))
 
+(defun comp-c-func-name (symbol-function)
+  "Given SYMBOL-FUNCTION return a name suitable for the native code."
+  ;; Unfortunatelly not all symbol names are valid as C function names...
+  (let* ((orig-name (symbol-name symbol-function))
+         (crypted (cl-loop with str = (make-string (* 2 (length orig-name)) 0)
+	                   for j from 0 by 2
+	                   for i across orig-name
+	                   for byte = (format "%x" i)
+	                   do (aset str j (aref byte 0))
+	                   do (aset str (1+ j) (aref byte 1))
+	                   finally return str))
+         (human-readable (replace-regexp-in-string
+                          (rx (not (any "a-z"))) "" orig-name)))
+    (concat "F" crypted "_" human-readable)))
+
 (defun comp-decrypt-lambda-list (x)
   "Decript lambda list X."
   (make-comp-args :rest (not (= (logand x 128) 0))
@@ -255,23 +272,24 @@ VAL is known at compile time."
 (defun native-compile (fun)
   "FUN is the function definition to be compiled into native code."
   (unless lexical-binding
-    (error "Can't compile a non lexical binded function"))
+    (error "Can't native compile a non lexical scoped function"))
   (if-let ((f (symbol-function fun)))
       (progn
         (when (byte-code-function-p f)
           (error "Can't native compile an already bytecompiled function"))
         (let ((func (make-comp-func :symbol-name fun
-                                    :func f)))
+                                    :func f
+                                    :c-func-name (comp-c-func-name fun))))
           (mapc (lambda (pass)
                   (funcall pass func))
                 comp-passes)
           ;; Once we have the final LIMPLE we jump into C.
-          (when (boundp #'comp-init-ctxt)
-                (comp-init-ctxt)
-                (comp-add-func-to-ctxt func)
-                (comp-compile-and-load-ctxt)
-                (comp-release-ctxt))))
-    (error "Trying to native compile not a function")))
+          (when t ;(boundp #'comp-init-ctxt)
+            (comp-init-ctxt)
+            (comp-add-func-to-ctxt func)
+            (comp-compile-and-load-ctxt)
+            (comp-release-ctxt))))
+    (error "Trying to native compile something not a function")))
 
 (provide 'comp)
 
diff --git a/src/comp.c b/src/comp.c
index 89d057217dc..ed7aef0aa9b 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -35,8 +35,6 @@ along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
 
 #define COMP_DEBUG 1
 
-#define DISASS_FILE_NAME "emacs-asm.s"
-
 #define SAFE_ALLOCA_BLOCK(ptr, func, name)			\
 do {								\
   (ptr) = SAFE_ALLOCA (sizeof (basic_block_t));			\
@@ -1832,6 +1830,9 @@ DEFUN ("comp-add-func-to-ctxt", Fcomp_add_func_to_ctxt, Scomp_add_func_to_ctxt,
        doc: /* Add limple FUNC to the current compilation context.  */)
      (Lisp_Object func)
 {
+  char *c_name =
+    (char *) SDATA (CALLN (Ffuncall, intern ("comp-func-c-func-name"), func));
+
   return Qt;
 }