summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp/comp.el
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp/comp.el')
-rw-r--r--lisp/emacs-lisp/comp.el269
1 files changed, 185 insertions, 84 deletions
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index b5355acf7cc..7fd9543d2ba 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -29,16 +29,30 @@
;;; Code:
(require 'bytecomp)
-(require 'cl-extra)
(require 'cl-lib)
-(require 'cl-macs)
-(require 'cl-seq)
(require 'gv)
(require 'rx)
(require 'subr-x)
(require 'warnings)
(require 'comp-cstr)
+;; These variables and functions are defined in comp.c
+(defvar native-comp-enable-subr-trampolines)
+(defvar comp-installed-trampolines-h)
+(defvar comp-subr-arities-h)
+(defvar native-comp-eln-load-path)
+(defvar comp-native-version-dir)
+(defvar comp-deferred-pending-h)
+(defvar comp--no-native-compile)
+
+(declare-function comp-el-to-eln-rel-filename "comp.c")
+(declare-function native-elisp-load "comp.c")
+(declare-function comp--release-ctxt "comp.c")
+(declare-function comp--init-ctxt "comp.c")
+(declare-function comp--compile-ctxt-to-file "comp.c")
+(declare-function comp-el-to-eln-filename "comp.c")
+(declare-function comp--install-trampoline "comp.c")
+
(defgroup comp nil
"Emacs Lisp native compiler."
:group 'lisp)
@@ -186,8 +200,9 @@ and above."
:type '(repeat string)
:version "28.1")
-(defcustom native-comp-driver-options (when (eq system-type 'darwin)
- '("-Wl,-w"))
+(defcustom native-comp-driver-options
+ (cond ((eq system-type 'darwin) '("-Wl,-w"))
+ ((eq system-type 'cygwin) '("-Wl,-dynamicbase")))
"Options passed verbatim to the native compiler's back-end driver.
Note that not all options are meaningful; typically only the options
affecting the assembler and linker are likely to be useful.
@@ -276,10 +291,10 @@ Useful to hook into pass checkers.")
;; FIXME this probably should not be here but... good for now.
(defconst comp-known-type-specifiers
`(
- ;; Functions we can trust not to be or if redefined should expose
- ;; the same type. Vast majority of these is either pure or
- ;; primitive, the original list is the union of pure +
- ;; side-effect-free-fns + side-effect-and-error-free-fns:
+ ;; Functions we can trust not to be redefined, or, if redefined,
+ ;; to expose the same type. The vast majority of these are
+ ;; either pure or primitive; the original list is the union of
+ ;; pure + side-effect-free-fns + side-effect-and-error-free-fns:
(% (function ((or number marker) (or number marker)) number))
(* (function (&rest (or number marker)) number))
(+ (function (&rest (or number marker)) number))
@@ -306,7 +321,8 @@ Useful to hook into pass checkers.")
(bignump (function (t) boolean))
(bobp (function () boolean))
(bolp (function () boolean))
- (bool-vector-count-consecutive (function (bool-vector boolean integer) fixnum))
+ (bool-vector-count-consecutive
+ (function (bool-vector boolean integer) fixnum))
(bool-vector-count-population (function (bool-vector) fixnum))
(bool-vector-not (function (bool-vector &optional bool-vector) bool-vector))
(bool-vector-p (function (t) boolean))
@@ -316,10 +332,12 @@ Useful to hook into pass checkers.")
(buffer-file-name (function (&optional buffer) (or string null)))
(buffer-list (function (&optional frame) list))
(buffer-local-variables (function (&optional buffer) list))
- (buffer-modified-p (function (&optional buffer) boolean))
+ (buffer-modified-p
+ (function (&optional buffer) (or boolean (member autosaved))))
(buffer-size (function (&optional buffer) integer))
(buffer-string (function () string))
- (buffer-substring (function ((or integer marker) (or integer marker)) string))
+ (buffer-substring
+ (function ((or integer marker) (or integer marker)) string))
(bufferp (function (t) boolean))
(byte-code-function-p (function (t) boolean))
(capitalize (function (or integer string) (or integer string)))
@@ -339,17 +357,27 @@ Useful to hook into pass checkers.")
(characterp (function (t &optional t) boolean))
(charsetp (function (t) boolean))
(commandp (function (t &optional t) boolean))
- (compare-strings (function (string (or integer marker null) (or integer marker null) string (or integer marker null) (or integer marker null) &optional t) (or (member t) fixnum)))
+ (compare-strings
+ (function (string (or integer marker null) (or integer marker null) string
+ (or integer marker null) (or integer marker null)
+ &optional t)
+ (or (member t) fixnum)))
(concat (function (&rest sequence) string))
(cons (function (t t) cons))
(consp (function (t) boolean))
- (coordinates-in-window-p (function (cons window) boolean))
+ (coordinates-in-window-p
+ (function (cons window)
+ (or cons null
+ (member bottom-divider right-divider mode-line header-line
+ tab-line left-fringe right-fringe vertical-line
+ left-margin right-margin))))
(copy-alist (function (list) list))
(copy-marker (function (&optional (or integer marker) boolean) marker))
(copy-sequence (function (sequence) sequence))
(copysign (function (float float) float))
(cos (function (number) float))
- (count-lines (function ((or integer marker) (or integer marker) &optional t) integer))
+ (count-lines
+ (function ((or integer marker) (or integer marker) &optional t) integer))
(current-buffer (function () buffer))
(current-global-map (function () cons))
(current-indentation (function () integer))
@@ -362,7 +390,7 @@ Useful to hook into pass checkers.")
(current-time-zone (function (&optional (or number list)
(or symbol string cons integer))
cons))
- (custom-variable-p (function (symbol) boolean))
+ (custom-variable-p (function (symbol) t))
(decode-char (function (cons t) (or fixnum null)))
(decode-time (function (&optional (or number list)
(or symbol string cons integer)
@@ -371,7 +399,8 @@ Useful to hook into pass checkers.")
(default-boundp (function (symbol) boolean))
(default-value (function (symbol) t))
(degrees-to-radians (function (number) float))
- (documentation (function ((or function symbol subr) &optional t) (or null string)))
+ (documentation
+ (function ((or function symbol subr) &optional t) (or null string)))
(downcase (function ((or fixnum string)) (or fixnum string)))
(elt (function (sequence integer) t))
(encode-char (function (fixnum symbol) (or fixnum null)))
@@ -384,18 +413,18 @@ Useful to hook into pass checkers.")
(error-message-string (function (list) string))
(eventp (function (t) boolean))
(exp (function (number) float))
- (expt (function (number number) float))
+ (expt (function (number number) number))
(fboundp (function (symbol) boolean))
(fceiling (function (float) float))
(featurep (function (symbol &optional symbol) boolean))
(ffloor (function (float) float))
(file-directory-p (function (string) boolean))
(file-exists-p (function (string) boolean))
- (file-locked-p (function (string) boolean))
+ (file-locked-p (function (string) (or boolean string)))
(file-name-absolute-p (function (string) boolean))
(file-newer-than-file-p (function (string string) boolean))
(file-readable-p (function (string) boolean))
- (file-symlink-p (function (string) boolean))
+ (file-symlink-p (function (string) (or boolean string)))
(file-writable-p (function (string) boolean))
(fixnump (function (t) boolean))
(float (function (number) float))
@@ -410,13 +439,15 @@ Useful to hook into pass checkers.")
(frame-first-window (function ((or frame window)) window))
(frame-root-window (function (&optional (or frame window)) window))
(frame-selected-window (function (&optional (or frame window)) window))
- (frame-visible-p (function (frame) boolean))
- (framep (function (t) boolean))
+ (frame-visible-p (function (frame) (or boolean (member icon))))
+ (framep (function (t) symbol))
(fround (function (float) float))
(ftruncate (function (float) float))
(get (function (symbol symbol) t))
(get-buffer (function ((or buffer string)) (or buffer null)))
- (get-buffer-window (function (&optional (or buffer string) (or symbol (integer 0 0))) (or null window)))
+ (get-buffer-window
+ (function (&optional (or buffer string) (or symbol (integer 0 0)))
+ (or null window)))
(get-file-buffer (function (string) (or null buffer)))
(get-largest-window (function (&optional t t t) (or window null)))
(get-lru-window (function (&optional t t t) (or window null)))
@@ -461,7 +492,10 @@ Useful to hook into pass checkers.")
(logxor (function (&rest (or integer marker)) integer))
;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ?
(lsh (function (integer integer) integer))
- (make-byte-code (function ((or fixnum list) string vector integer &optional string t &rest t) vector))
+ (make-byte-code
+ (function ((or fixnum list) string vector integer &optional string t
+ &rest t)
+ vector))
(make-list (function (integer t) list))
(make-marker (function () marker))
(make-string (function (integer fixnum &optional t) string))
@@ -479,7 +513,9 @@ Useful to hook into pass checkers.")
(min (function ((or number marker) &rest (or number marker)) number))
(minibuffer-selected-window (function () (or window null)))
(minibuffer-window (function (&optional frame) window))
- (mod (function ((or number marker) (or number marker)) (or (integer 0 *) (float 0 *))))
+ (mod
+ (function ((or number marker) (or number marker))
+ (or (integer 0 *) (float 0 *))))
(mouse-movement-p (function (t) boolean))
(multibyte-char-to-unibyte (function (fixnum) fixnum))
(natnump (function (t) boolean))
@@ -505,7 +541,7 @@ Useful to hook into pass checkers.")
(previous-window (function (&optional window t t) window))
(prin1-to-string (function (t &optional t t) string))
(processp (function (t) boolean))
- (proper-list-p (function (t) boolean))
+ (proper-list-p (function (t) (or fixnum null)))
(propertize (function (string &rest t) string))
(radians-to-degrees (function (number) float))
(rassoc (function (t list) list))
@@ -543,7 +579,8 @@ Useful to hook into pass checkers.")
(string= (function ((or string symbol) (or string symbol)) boolean))
(stringp (function (t) boolean))
(subrp (function (t) boolean))
- (substring (function ((or string vector) &optional integer integer) (or string vector)))
+ (substring
+ (function ((or string vector) &optional integer integer) (or string vector)))
(sxhash (function (t) integer))
(sxhash-eq (function (t) integer))
(sxhash-eql (function (t) integer))
@@ -640,11 +677,14 @@ Useful to hook into pass checkers.")
(defun comp-known-predicate-p (predicate)
"Return t if PREDICATE is known."
- (when (gethash predicate comp-known-predicates-h) t))
+ (when (or (gethash predicate comp-known-predicates-h)
+ (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))
+ t))
(defun comp-pred-to-cstr (predicate)
"Given PREDICATE, return the corresponding constraint."
- (gethash predicate comp-known-predicates-h))
+ (or (gethash predicate comp-known-predicates-h)
+ (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))))
(defconst comp-symbol-values-optimizable '(most-positive-fixnum
most-negative-fixnum)
@@ -1107,7 +1147,8 @@ with `message'. Otherwise, log with `comp-log-to-buffer'."
(log-buffer
(or (get-buffer comp-log-buffer-name)
(with-current-buffer (get-buffer-create comp-log-buffer-name)
- (setf buffer-read-only t)
+ (unless (derived-mode-p 'compilation-mode)
+ (emacs-lisp-compilation-mode))
(current-buffer))))
(log-window (get-buffer-window log-buffer))
(inhibit-read-only t)
@@ -1241,7 +1282,7 @@ clashes."
(defun comp-decrypt-arg-list (x function-name)
"Decrypt argument list X for FUNCTION-NAME."
(unless (fixnump x)
- (signal 'native-compiler-error-dyn-func function-name))
+ (signal 'native-compiler-error-dyn-func (list function-name)))
(let ((rest (not (= (logand x 128) 0)))
(mandatory (logand x 127))
(nonrest (ash x -8)))
@@ -1274,33 +1315,45 @@ clashes."
(make-temp-file (comp-c-func-name function-name "freefn-")
nil ".eln")))
(let* ((f (symbol-function function-name))
+ (byte-code (byte-compile function-name))
(c-name (comp-c-func-name function-name "F"))
- (func (make-comp-func-l :name function-name
- :c-name c-name
- :doc (documentation f t)
- :int-spec (interactive-form f)
- :command-modes (command-modes f)
- :speed (comp-spill-speed function-name)
- :pure (comp-spill-decl-spec function-name
- 'pure))))
+ (func
+ (if (comp-lex-byte-func-p byte-code)
+ (make-comp-func-l :name function-name
+ :c-name c-name
+ :doc (documentation f t)
+ :int-spec (interactive-form f)
+ :command-modes (command-modes f)
+ :speed (comp-spill-speed function-name)
+ :pure (comp-spill-decl-spec function-name
+ 'pure))
+ (make-comp-func-d :name function-name
+ :c-name c-name
+ :doc (documentation f t)
+ :int-spec (interactive-form f)
+ :command-modes (command-modes f)
+ :speed (comp-spill-speed function-name)
+ :pure (comp-spill-decl-spec function-name
+ 'pure)))))
(when (byte-code-function-p f)
(signal 'native-compiler-error
- "can't native compile an already byte-compiled function"))
- (setf (comp-func-byte-func func)
- (byte-compile (comp-func-name func)))
+ '("can't native compile an already byte-compiled function")))
+ (setf (comp-func-byte-func func) byte-code)
(let ((lap (byte-to-native-lambda-lap
(gethash (aref (comp-func-byte-func func) 1)
byte-to-native-lambdas-h))))
(cl-assert lap)
(comp-log lap 2 t)
- (let ((arg-list (aref (comp-func-byte-func func) 0)))
- (setf (comp-func-l-args func)
- (comp-decrypt-arg-list arg-list function-name)
- (comp-func-lap func)
- lap
- (comp-func-frame-size func)
- (comp-byte-frame-size (comp-func-byte-func func))))
- (setf (comp-ctxt-top-level-forms comp-ctxt)
+ (if (comp-func-l-p func)
+ (let ((arg-list (aref (comp-func-byte-func func) 0)))
+ (setf (comp-func-l-args func)
+ (comp-decrypt-arg-list arg-list function-name)))
+ (setf (comp-func-d-lambda-list func) (cadr f)))
+ (setf (comp-func-lap func)
+ lap
+ (comp-func-frame-size func)
+ (comp-byte-frame-size (comp-func-byte-func func))
+ (comp-ctxt-top-level-forms comp-ctxt)
(list (make-byte-to-native-func-def :name function-name
:c-name c-name)))
(comp-add-func-to-ctxt func))))
@@ -1309,7 +1362,7 @@ clashes."
"Byte-compile FORM, spilling data from the byte compiler."
(unless (eq (car-safe form) 'lambda)
(signal 'native-compiler-error
- "Cannot native-compile, form is not a lambda"))
+ '("Cannot native-compile, form is not a lambda")))
(unless (comp-ctxt-output comp-ctxt)
(setf (comp-ctxt-output comp-ctxt)
(make-temp-file "comp-lambda-" nil ".eln")))
@@ -1390,7 +1443,7 @@ clashes."
(alist-get 'no-native-compile byte-native-qualities))
(throw 'no-native-compile nil))
(unless byte-to-native-top-level-forms
- (signal 'native-compiler-error-empty-byte filename))
+ (signal 'native-compiler-error-empty-byte (list filename)))
(unless (comp-ctxt-output comp-ctxt)
(setf (comp-ctxt-output comp-ctxt)
(comp-el-to-eln-filename filename native-compile-target-directory)))
@@ -1424,11 +1477,13 @@ clashes."
"Byte-compile and spill the LAP representation for INPUT.
If INPUT is a symbol, it is the function-name to be compiled.
If INPUT is a string, it is the filename to be compiled."
- (let ((byte-native-compiling t)
- (byte-to-native-lambdas-h (make-hash-table :test #'eq))
- (byte-to-native-top-level-forms ())
- (byte-to-native-plist-environment ()))
- (comp-spill-lap-function input)))
+ (let* ((byte-native-compiling t)
+ (byte-to-native-lambdas-h (make-hash-table :test #'eq))
+ (byte-to-native-top-level-forms ())
+ (byte-to-native-plist-environment ())
+ (res (comp-spill-lap-function input)))
+ (comp-cstr-ctxt-update-type-slots comp-ctxt)
+ res))
;;; Limplification pass specific code.
@@ -1536,7 +1591,7 @@ STACK-OFF is the index of the first slot frame involved."
for sp from stack-off
collect (comp-slot-n sp))))
-(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type)
+(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type neg)
"`comp-mvar' initializer."
(let ((mvar (make--comp-mvar :slot slot)))
(when const-vld
@@ -1544,6 +1599,8 @@ STACK-OFF is the index of the first slot frame involved."
(setf (comp-cstr-imm mvar) constant))
(when type
(setf (comp-mvar-typeset mvar) (list type)))
+ (when neg
+ (setf (comp-mvar-neg mvar) t))
mvar))
(defun comp-new-frame (size vsize &optional ssa)
@@ -1708,14 +1765,15 @@ Return value is the fall-through block name."
(defun comp-jump-table-optimizable (jmp-table)
"Return t if JMP-TABLE can be optimized out."
- (cl-loop
- with labels = (cl-loop for target-label being each hash-value of jmp-table
- collect target-label)
- with x = (car labels)
- for l in (cdr-safe labels)
- unless (= l x)
- return nil
- finally return t))
+ ;; Identify LAP sequences like:
+ ;; (byte-constant #s(hash-table size 3 test eq rehash-size 1.5 rehash-threshold 0.8125 purecopy t data (created 126 deleted 126 changed 126)) . 24)
+ ;; (byte-switch)
+ ;; (TAG 126 . 10)
+ (let ((targets (hash-table-values jmp-table)))
+ (when (apply #'= targets)
+ (pcase (nth (1+ (comp-limplify-pc comp-pass)) (comp-func-lap comp-func))
+ (`(TAG ,target . ,_label-sp)
+ (= target (car targets)))))))
(defun comp-emit-switch (var last-insn)
"Emit a Limple for a lap jump table given VAR and LAST-INSN."
@@ -1758,7 +1816,7 @@ Return value is the fall-through block name."
do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func))
(setf (comp-limplify-curr-block comp-pass) ff-bb))))
(_ (signal 'native-ice
- "missing previous setimm while creating a switch"))))
+ '("missing previous setimm while creating a switch")))))
(defun comp--func-arity (subr-name)
"Like `func-arity' but invariant against primitive redefinitions.
@@ -1790,7 +1848,7 @@ SP-DELTA is the stack adjustment."
(eval-when-compile
(defun comp-op-to-fun (x)
"Given the LAP op strip \"byte-\" to have the subr name."
- (intern (replace-regexp-in-string "byte-" "" x)))
+ (intern (string-replace "byte-" "" x)))
(defun comp-body-eff (body op-name sp-delta)
"Given the original BODY, compute the effective one.
@@ -2532,6 +2590,19 @@ TARGET-BB-SYM is the symbol name of the target block."
for insns-seq on (comp-block-insns b)
do
(pcase insns-seq
+ (`((set ,(and (pred comp-mvar-p) mvar-tested-copy)
+ ,(and (pred comp-mvar-p) mvar-tested))
+ (set ,(and (pred comp-mvar-p) mvar-1)
+ (call type-of ,(and (pred comp-mvar-p) mvar-tested-copy)))
+ (set ,(and (pred comp-mvar-p) mvar-2)
+ (call symbol-value ,(and (pred comp-cstr-cl-tag-p) mvar-tag)))
+ (set ,(and (pred comp-mvar-p) mvar-3)
+ (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2)))
+ (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2))
+ (push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)))
+ (comp-block-insns (comp-add-cond-cstrs-target-block b bb2)))
+ (push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag) :neg t))
+ (comp-block-insns (comp-add-cond-cstrs-target-block b bb1))))
(`((set ,(and (pred comp-mvar-p) cmp-res)
(,(pred comp-call-op-p)
,(and (or (pred comp-equality-fun-p)
@@ -2844,9 +2915,9 @@ blocks."
finger2 (comp-block-post-num b2))))
b1))
(first-processed (l)
- (if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) l)))
+ (if-let ((p (cl-find-if #'comp-block-idom l)))
p
- (signal 'native-ice "can't find first preprocessed"))))
+ (signal 'native-ice '("can't find first preprocessed")))))
(when-let ((blocks (comp-func-blocks comp-func))
(entry (gethash 'entry blocks))
@@ -3187,7 +3258,11 @@ Fold the call in case."
(+ (comp-cstr-add lval args))
(- (comp-cstr-sub lval args))
(1+ (comp-cstr-add lval `(,(car args) ,comp-cstr-one)))
- (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one))))))
+ (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one)))
+ (record (when (comp-cstr-imm-vld-p (car args))
+ (comp-cstr-shallow-copy lval
+ (comp-type-spec-to-cstr
+ (comp-cstr-imm (car args)))))))))
(defun comp-fwprop-insn (insn)
"Propagate within INSN."
@@ -3679,13 +3754,10 @@ Prepare every function for final compilation and drive the C back-end."
(comp--compile-ctxt-to-file name)))
(defun comp-final1 ()
- (let (compile-result)
- (comp--init-ctxt)
- (unwind-protect
- (setf compile-result
- (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)))
- (and (comp--release-ctxt)
- compile-result))))
+ (comp--init-ctxt)
+ (unwind-protect
+ (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt))
+ (comp--release-ctxt)))
(defvar comp-async-compilation nil
"Non-nil while executing an asynchronous native compilation.")
@@ -3746,7 +3818,7 @@ Prepare every function for final compilation and drive the C back-end."
(progn
(delete-file temp-file)
output)
- (signal 'native-compiler-error (buffer-string)))
+ (signal 'native-compiler-error (list (buffer-string))))
(comp-log-to-buffer (buffer-string))))))))
@@ -4034,7 +4106,8 @@ display a message."
:buffer (with-current-buffer
(get-buffer-create
comp-async-buffer-name)
- (setf buffer-read-only t)
+ (unless (derived-mode-p 'compilation-mode)
+ (emacs-lisp-compilation-mode))
(current-buffer))
:command (list
(expand-file-name invocation-name
@@ -4068,6 +4141,8 @@ display a message."
(run-hooks 'native-comp-async-all-done-hook)
(with-current-buffer (get-buffer-create comp-async-buffer-name)
(save-excursion
+ (unless (derived-mode-p 'compilation-mode)
+ (emacs-lisp-compilation-mode))
(let ((inhibit-read-only t))
(goto-char (point-max))
(insert "Compilation finished.\n"))))
@@ -4102,7 +4177,7 @@ the deferred compilation mechanism."
(comp-log "\n \n" 1)
(unwind-protect
(progn
- (condition-case err
+ (condition-case-unless-debug err
(cl-loop
with report = nil
for t0 = (current-time)
@@ -4121,7 +4196,8 @@ the deferred compilation mechanism."
(comp-log (format "Done compiling %s" data) 0)
(cl-loop for (pass . time) in (reverse report)
do (comp-log (format "Pass %s took: %fs."
- pass time) 0))))
+ pass time)
+ 0))))
(native-compiler-skip)
(t
(let ((err-val (cdr err)))
@@ -4176,6 +4252,7 @@ LOAD and SELECTOR work as described in `native--compile-async'."
(string-match-p re file))
native-comp-jit-compilation-deny-list))))
+;;;###autoload
(defun native--compile-async (files &optional recursively load selector)
;; BEWARE, this function is also called directly from C.
"Compile FILES asynchronously.
@@ -4229,8 +4306,9 @@ bytecode definition was not changed in the meantime)."
;; compilation, so update `comp-files-queue' to reflect that.
(unless (or (null load)
(eq load (cdr entry)))
- (cl-substitute (cons file load) (car entry) comp-files-queue
- :key #'car :test #'string=))
+ (setf comp-files-queue
+ (cl-substitute (cons file load) (car entry) comp-files-queue
+ :key #'car :test #'string=)))
(unless (native-compile-async-skip-p file load selector)
(let* ((out-filename (comp-el-to-eln-filename file))
@@ -4410,6 +4488,29 @@ of (commands) to run simultaneously."
(delete-directory subdir))))))
(message "Cache cleared"))
+;;;###autoload
+(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 )
+ (when-let ((res (gethash function comp-known-func-cstr-h)))
+ (setf type-spec (comp-cstr-to-type-spec 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 type-spec
+ (cons type-spec kind))))
+
(provide 'comp)
;; LocalWords: limplified limplification limplify Limple LIMPLE libgccjit elc eln