[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/lisp-func-type-decls c628abbad2d 2/3: Make use of Lisp function
From: |
Andrea Corallo |
Subject: |
scratch/lisp-func-type-decls c628abbad2d 2/3: Make use of Lisp function declarations in the native compiler |
Date: |
Sun, 28 Apr 2024 04:14:08 -0400 (EDT) |
branch: scratch/lisp-func-type-decls
commit c628abbad2dd0917284400ae644b4e911ee3290d
Author: Andrea Corallo <acorallo@gnu.org>
Commit: Andrea Corallo <acorallo@gnu.org>
Make use of Lisp function declarations in the native compiler
---
lisp/emacs-lisp/comp-common.el | 29 +++++++++++++++++------------
lisp/emacs-lisp/comp.el | 16 ++++++++++++----
2 files changed, 29 insertions(+), 16 deletions(-)
diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el
index 4edfe811586..193b50cb419 100644
--- a/lisp/emacs-lisp/comp-common.el
+++ b/lisp/emacs-lisp/comp-common.el
@@ -530,22 +530,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 (cons 'function 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..5fc218cc79b 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -179,7 +179,7 @@ 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)
@@ -189,6 +189,14 @@ Useful to hook into pass checkers.")
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-known-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.