scratch/lisp-func-type-decls d8c941df7d8 2/4: Make use of Lisp function declarations

[Andrea Corallo]

branch: scratch/lisp-func-type-decls
commit d8c941df7d8167fdec8cad562c095e27203f7818
Author: Andrea Corallo <acorallo@gnu.org>
Commit: Andrea Corallo <acorallo@gnu.org>

    Make use of Lisp function declarations
    
    * lisp/emacs-lisp/comp.el (comp-primitive-func-cstr-h): Rename.
    (comp--get-function-cstr): Define new function.
    (comp--add-call-cstr, comp--fwprop-call): Update.
    * lisp/emacs-lisp/comp-common.el (comp-function-type-spec): Update.
    * lisp/help-fns.el (help-fns--signature): Mention when a type is
    declared.
    * lisp/emacs-lisp/comp.el (comp-primitive-func-cstr-h): Rename.
---
 lisp/emacs-lisp/comp-common.el | 29 +++++++++++++++++------------
 lisp/emacs-lisp/comp.el        | 18 +++++++++++++-----
 lisp/help-fns.el               |  2 +-
 3 files changed, 31 insertions(+), 18 deletions(-)

diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el
index 62fd28f772e..cfaf843a3fd 100644
--- a/lisp/emacs-lisp/comp-common.el
+++ b/lisp/emacs-lisp/comp-common.el
@@ -532,22 +532,27 @@ Account for `native-comp-eln-load-path' and 
`comp-native-version-dir'."
 (defun comp-function-type-spec (function)
   "Return the type specifier of FUNCTION.
 
-This function returns a cons cell whose car is the function
-specifier, and cdr is a symbol, either `inferred' or `know'.
-If the symbol is `inferred', the type specifier is automatically
-inferred from the code itself by the native compiler; if it is
-`know', the type specifier comes from `comp-known-type-specifiers'."
-  (let ((kind 'know)
-        type-spec )
+This function returns a cons cell whose car is the function specifier,
+and cdr is a symbol, either `inferred' or `declared'.  If the symbol is
+`inferred', the type specifier is automatically inferred from the code
+itself by the native compiler; if it is `declared', the type specifier
+comes from `comp-known-type-specifiers' or the function type declaration
+itself."
+  (let ((kind 'declared)
+        type-spec)
     (when-let ((res (assoc function comp-known-type-specifiers)))
+      ;; Declared primitive
       (setf type-spec (cadr res)))
     (let ((f (and (symbolp function)
                   (symbol-function function))))
-      (when (and f
-                 (null type-spec)
-                 (subr-native-elisp-p f))
-        (setf kind 'inferred
-              type-spec (subr-type f))))
+      (when (and f (null type-spec))
+        (if-let ((delc-type (function-get function 'declared-type)))
+            ;; Declared Lisp function
+            (setf type-spec (car delc-type))
+          (when (subr-native-elisp-p f)
+            ;; Native compiled inferred
+            (setf kind 'inferred
+                  type-spec (subr-type f))))))
     (when type-spec
         (cons type-spec kind))))
 
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 2ec55ed98ee..a7d4c71dc26 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -179,16 +179,24 @@ For internal use by the test suite only.")
 Each function in FUNCTIONS is run after PASS.
 Useful to hook into pass checkers.")
 
-(defconst comp-known-func-cstr-h
+(defconst comp-primitive-func-cstr-h
   (cl-loop
    with comp-ctxt = (make-comp-cstr-ctxt)
    with h = (make-hash-table :test #'eq)
-   for (f type-spec) in comp-known-type-specifiers
+   for (f type-spec) in comp-primitive-type-specifiers
    for cstr = (comp-type-spec-to-cstr type-spec)
    do (puthash f cstr h)
    finally return h)
   "Hash table function -> `comp-constraint'.")
 
+(defun comp--get-function-cstr (function)
+  "Given FUNCTION return the corresponding `comp-constraint'."
+  (when (symbolp function)
+    (let ((f (symbol-function function)))
+      (or (gethash f comp-primitive-func-cstr-h)
+          (when-let ((res (function-get function 'declared-type)))
+            (comp-type-spec-to-cstr (car res)))))))
+
 ;; Keep it in sync with the `cl-deftype-satisfies' property set in
 ;; cl-macs.el. We can't use `cl-deftype-satisfies' directly as the
 ;; relation type <-> predicate is not bijective (bug#45576).
@@ -2102,10 +2110,10 @@ TARGET-BB-SYM is the symbol name of the target block."
      (when-let ((match
                  (pcase insn
                    (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args))
-                    (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
+                    (when-let ((cstr-f (comp--get-function-cstr f)))
                       (cl-values f cstr-f lhs args)))
                    (`(,(pred comp--call-op-p) ,f . ,args)
-                    (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
+                    (when-let ((cstr-f (comp--get-function-cstr f)))
                       (cl-values f cstr-f nil args))))))
        (cl-multiple-value-bind (f cstr-f lhs args) match
          (cl-loop
@@ -2642,7 +2650,7 @@ Fold the call in case."
                (comp-cstr-imm-vld-p (car args)))
       (setf f (comp-cstr-imm (car args))
             args (cdr args)))
-    (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
+    (when-let ((cstr-f (comp--get-function-cstr f)))
       (let ((cstr (comp-cstr-f-ret cstr-f)))
         (when (comp-cstr-empty-p cstr)
           ;; Store it to be rewritten as non local exit.
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index cfe27077055..26fe614ffb5 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -734,7 +734,7 @@ the C sources, too."
               (insert (format
                        (if (eq kind 'inferred)
                            "\nInferred type: %s\n"
-                         "\nType: %s\n")
+                         "\nDeclared type: %s\n")
                        type-spec))))
           (fill-region fill-begin (point))
           high-doc)))))