Merge remote-tracking branch 'origin/master' into feature/android

4 files changed, 88 insertions, 32 deletions

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 562f21aa751..f64674d5a6c 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -447,16 +447,10 @@ for speeding up processing.")
           . ,(byte-optimize-body exps for-effect)))
 
       ;; Needed as long as we run byte-optimize-form after cconv.
-      (`(internal-make-closure . ,_)
-       (and (not for-effect)
-            (progn
-       ;; Look up free vars and mark them to be kept, so that they
-       ;; won't be optimized away.
-       (dolist (var (caddr form))
-         (let ((lexvar (assq var byte-optimize--lexvars)))
-           (when lexvar
-             (setcar (cdr lexvar) t))))
-              form)))
+      (`(internal-make-closure ,vars ,env . ,rest)
+       (if for-effect
+           `(progn ,@(byte-optimize-body env t))
+         `(,fn ,vars ,(mapcar #'byte-optimize-form env) . ,rest)))
 
       (`((lambda . ,_) . ,_)
        (let ((newform (macroexp--unfold-lambda form)))
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 416ca7f11b0..e0db82604f2 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -36,6 +36,7 @@
 ;;; Code:
 
 (require 'cl-lib)
+(require 'cl-macs)
 
 (defconst comp--typeof-builtin-types (mapcar (lambda (x)
                                                (append x '(t)))
@@ -1181,8 +1182,8 @@ FN non-nil indicates we are parsing a function lambda list."
       :ret (comp-type-spec-to-cstr ret)))
     (_ (error "Invalid type specifier"))))
 
-(defun comp-cstr-to-type-spec (cstr)
-  "Given CSTR return its type specifier."
+(defun comp--simple-cstr-to-type-spec (cstr)
+  "Given a non comp-cstr-f CSTR return its type specifier."
   (let ((valset (comp-cstr-valset cstr))
         (typeset (comp-cstr-typeset cstr))
         (range (comp-cstr-range cstr))
@@ -1236,6 +1237,20 @@ FN non-nil indicates we are parsing a function lambda list."
           `(not ,final)
         final))))
 
+(defun comp-cstr-to-type-spec (cstr)
+  "Given CSTR return its type specifier."
+  (cl-etypecase cstr
+    (comp-cstr-f
+     `(function
+       ,(mapcar (lambda (x)
+                  (cl-etypecase x
+                    (comp-cstr (comp-cstr-to-type-spec x))
+                    (symbol x)))
+                (comp-cstr-f-args cstr))
+       ,(comp--simple-cstr-to-type-spec (comp-cstr-f-ret cstr))))
+    (comp-cstr
+     (comp--simple-cstr-to-type-spec cstr))))
+
 (provide 'comp-cstr)
 
 ;;; comp-cstr.el ends here
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 2ea405728a3..b65da148787 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -277,10 +277,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))
@@ -307,7 +307,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))
@@ -317,10 +318,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) (or boolean (member autosaved))))
+    (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)))
@@ -340,17 +343,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) (or cons null (member bottom-divider right-divider mode-line header-line tab-line left-fringe right-fringe vertical-line left-margin right-margin))))
+    (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))
@@ -372,7 +385,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)))
@@ -412,12 +426,14 @@ Useful to hook into pass checkers.")
     (frame-root-window (function (&optional (or frame window)) window))
     (frame-selected-window (function (&optional (or frame window)) window))
     (frame-visible-p (function (frame) (or boolean (member icon))))
-    (framep (function (t) (or boolean (member x w32 ns pc pgtk haiku))))
+    (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)))
@@ -462,7 +478,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))
@@ -480,7 +499,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))
@@ -544,7 +565,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))
@@ -4425,6 +4447,27 @@ 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 (symbol-function function)))
+      (when (and (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
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index c4e09e48bea..b9388b45397 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -711,10 +711,14 @@ the C sources, too."
           (unless (and (symbolp function)
                        (get function 'reader-construct))
             (insert high-usage "\n")
-            (when (and (featurep 'native-compile)
-                       (subr-native-elisp-p (symbol-function function))
-                       (subr-type (symbol-function function)))
-              (insert (format "\nInferred type: %s\n" (subr-type (symbol-function function))))))
+            (when-let* ((res (comp-function-type-spec function))
+                        (type-spec (car res))
+                        (kind (cdr res)))
+              (insert (format
+                       (if (eq kind 'inferred)
+                           "\nInferred type: %s\n"
+                         "\nType: %s\n")
+                       type-spec))))
           (fill-region fill-begin (point))
           high-doc)))))