diff options
Diffstat (limited to 'lisp/emacs-lisp/bytecomp.el')
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 617 |
1 files changed, 384 insertions, 233 deletions
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 9429d6a0d5d..7bd642d2b23 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -192,10 +192,9 @@ otherwise adds \".elc\"." (autoload 'byte-compile-inline-expand "byte-opt") ;; This is the entry point to the lapcode optimizer pass1. -(autoload 'byte-optimize-form "byte-opt") +(autoload 'byte-optimize-one-form "byte-opt") ;; This is the entry point to the lapcode optimizer pass2. (autoload 'byte-optimize-lapcode "byte-opt") -(autoload 'byte-compile-unfold-lambda "byte-opt") ;; This is the entry point to the decompiler, which is used by the ;; disassembler. The disassembler just requires 'byte-compile, but @@ -549,6 +548,10 @@ has the form (autoload . FILENAME).") (defvar byte-compile-unresolved-functions nil "Alist of undefined functions to which calls have been compiled. +Each element in the list has the form (FUNCTION POSITION . CALLS) +where CALLS is a list whose elements are integers (indicating the +number of arguments passed in the function call) or the constant `t' +if the function is called indirectly. This variable is only significant whilst compiling an entire buffer. Used for warnings when a function is not known to be defined or is later defined with incorrect args.") @@ -574,6 +577,46 @@ Each element is (INDEX . VALUE)") (defvar byte-compile-depth 0 "Current depth of execution stack.") (defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") +;; The following is used by comp.el to spill data out of here. +;; +;; Spilling is done in 3 places: +;; +;; - `byte-compile-lapcode' to obtain the map bytecode -> LAP for any +;; code assembled. +;; +;; - `byte-compile-lambda' to obtain arglist doc and interactive spec +;; af any lambda compiled (including anonymous). +;; +;; - `byte-compile-file-form-defmumble' to obtain the list of +;; top-level forms as they would be outputted in the .elc file. +;; + +(cl-defstruct byte-to-native-lambda + byte-func lap) + +;; Top level forms: +(cl-defstruct byte-to-native-func-def + "Named function defined at top-level." + name c-name byte-func) +(cl-defstruct byte-to-native-top-level + "All other top-level forms." + form lexical) + +(defvar byte-native-compiling nil + "Non-nil while native compiling.") +(defvar byte-native-qualities nil + "To spill default qualities from the compiled file.") +(defvar byte+native-compile nil + "Non-nil while producing at the same time byte and native code.") +(defvar byte-to-native-lambdas-h nil + "Hash byte-code -> byte-to-native-lambda.") +(defvar byte-to-native-top-level-forms nil + "List of top level forms.") +(defvar byte-to-native-output-file nil + "Temporary file containing the byte-compilation output.") +(defvar byte-to-native-plist-environment nil + "To spill `overriding-plist-environment'.") + ;;; The byte codes; this information is duplicated in bytecomp.c @@ -970,7 +1013,12 @@ CONST2 may be evaluated multiple times." ;; it within 2 bytes in the byte string). (puthash value pc hash-table)) hash-table)) - (apply 'unibyte-string (nreverse bytes)))) + (let ((bytecode (apply 'unibyte-string (nreverse bytes)))) + (when byte-native-compiling + ;; Spill LAP for the native compiler here. + (puthash bytecode (make-byte-to-native-lambda :lap lap) + byte-to-native-lambdas-h)) + bytecode))) ;;; compile-time evaluation @@ -1424,11 +1472,35 @@ when printing the error message." ;; Remember number of args in call. (let ((cons (assq f byte-compile-unresolved-functions))) (if cons - (or (memq nargs (cdr cons)) - (push nargs (cdr cons))) - (push (list f nargs) + (or (memq nargs (cddr cons)) + (push nargs (cddr cons))) + (push (list f byte-compile-last-position nargs) byte-compile-unresolved-functions))))) +(defun byte-compile-emit-callargs-warn (name actual-args min-args max-args) + (byte-compile-set-symbol-position name) + (byte-compile-warn + "%s called with %d argument%s, but %s %s" + name actual-args + (if (= 1 actual-args) "" "s") + (if (< actual-args min-args) + "requires" + "accepts only") + (byte-compile-arglist-signature-string (cons min-args max-args)))) + +(defun byte-compile--check-arity-bytecode (form bytecode) + "Check that the call in FORM matches that allowed by BYTECODE." + (when (and (byte-code-function-p bytecode) + (byte-compile-warning-enabled-p 'callargs)) + (let* ((actual-args (length (cdr form))) + (arity (func-arity bytecode)) + (min-args (car arity)) + (max-args (and (numberp (cdr arity)) (cdr arity)))) + (when (or (< actual-args min-args) + (and max-args (> actual-args max-args))) + (byte-compile-emit-callargs-warn + (car form) actual-args min-args max-args))))) + ;; Warn if the form is calling a function with the wrong number of arguments. (defun byte-compile-callargs-warn (form) (let* ((def (or (byte-compile-fdefinition (car form) nil) @@ -1443,16 +1515,9 @@ when printing the error message." (setcdr sig nil)) (if sig (when (or (< ncall (car sig)) - (and (cdr sig) (> ncall (cdr sig)))) - (byte-compile-set-symbol-position (car form)) - (byte-compile-warn - "%s called with %d argument%s, but %s %s" - (car form) ncall - (if (= 1 ncall) "" "s") - (if (< ncall (car sig)) - "requires" - "accepts only") - (byte-compile-arglist-signature-string sig)))) + (and (cdr sig) (> ncall (cdr sig)))) + (byte-compile-emit-callargs-warn + (car form) ncall (car sig) (cdr sig)))) (byte-compile-format-warn form) (byte-compile-function-warn (car form) (length (cdr form)) def))) @@ -1526,14 +1591,14 @@ extra args." (setq byte-compile-unresolved-functions (delq calls byte-compile-unresolved-functions)) (setq calls (delq t calls)) ;Ignore higher-order uses of the function. - (when (cdr calls) + (when (cddr calls) (when (and (symbolp name) (eq (function-get name 'byte-optimizer) 'byte-compile-inline-expand)) (byte-compile-warn "defsubst `%s' was used before it was defined" name)) (setq sig (byte-compile-arglist-signature arglist) - nums (sort (copy-sequence (cdr calls)) (function <)) + nums (sort (copy-sequence (cddr calls)) (function <)) min (car nums) max (car (nreverse nums))) (when (or (< min (car sig)) @@ -1579,7 +1644,7 @@ the `\\\\=[command]' ones that are assumed to be of length `byte-compile--wide-docstring-substitution-len'. Also ignore URLs." (string-match - (format "^.\\{%s,\\}$" (int-to-string (1+ col))) + (format "^.\\{%d,\\}$" (min (1+ col) #xffff)) ; Heed RE_DUP_MAX. (replace-regexp-in-string (rx (or ;; Ignore some URLs. @@ -1587,7 +1652,10 @@ URLs." ;; Ignore these `substitute-command-keys' substitutions. (seq "\\" (or "=" (seq "<" (* (not ">")) ">") - (seq "{" (* (not "}")) "}"))))) + (seq "{" (* (not "}")) "}"))) + ;; Ignore the function signature that's stashed at the end of + ;; the doc string (in some circumstances). + (seq bol "(fn (" (* nonl)))) "" ;; Heuristic: assume these substitutions are of some length N. (replace-regexp-in-string @@ -1641,56 +1709,21 @@ It is too wide if it has any lines longer than the largest of kind name col)))) form) -(defun byte-compile-print-syms (str1 strn syms) - (when syms - (byte-compile-set-symbol-position (car syms) t)) - (cond ((and (cdr syms) (not noninteractive)) - (let* ((str strn) - (L (length str)) - s) - (while syms - (setq s (symbol-name (pop syms)) - L (+ L (length s) 2)) - (if (< L (1- (buffer-local-value 'fill-column - (or (get-buffer - byte-compile-log-buffer) - (current-buffer))))) - (setq str (concat str " " s (and syms ","))) - (setq str (concat str "\n " s (and syms ",")) - L (+ (length s) 4)))) - (byte-compile-warn "%s" str))) - ((cdr syms) - (byte-compile-warn "%s %s" - strn - (mapconcat #'symbol-name syms ", "))) - - (syms - (byte-compile-warn str1 (car syms))))) - ;; If we have compiled any calls to functions which are not known to be ;; defined, issue a warning enumerating them. ;; `unresolved' in the list `byte-compile-warnings' disables this. (defun byte-compile-warn-about-unresolved-functions () (when (byte-compile-warning-enabled-p 'unresolved) - (let ((byte-compile-current-form :end) - (noruntime nil) - (unresolved nil)) + (let ((byte-compile-current-form :end)) ;; Separate the functions that will not be available at runtime ;; from the truly unresolved ones. - (dolist (f byte-compile-unresolved-functions) - (setq f (car f)) - (when (not (memq f byte-compile-new-defuns)) - (if (fboundp f) (push f noruntime) (push f unresolved)))) - ;; Complain about the no-run-time functions - (byte-compile-print-syms - "the function `%s' might not be defined at runtime." - "the following functions might not be defined at runtime:" - noruntime) - ;; Complain about the unresolved functions - (byte-compile-print-syms - "the function `%s' is not known to be defined." - "the following functions are not known to be defined:" - unresolved))) + (dolist (urf byte-compile-unresolved-functions) + (let ((f (car urf))) + (when (not (memq f byte-compile-new-defuns)) + (let ((byte-compile-last-position (cadr urf))) + (byte-compile-warn + (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.") + (car urf)))))))) nil) @@ -1728,11 +1761,20 @@ It is too wide if it has any lines longer than the largest of ;; (byte-compile-generate-emacs19-bytecodes ;; byte-compile-generate-emacs19-bytecodes) (byte-compile-warnings byte-compile-warnings) + ;; Indicate that we're not currently loading some file. + ;; This is used in `macroexp-file-name' to make sure that + ;; loading file A which does (byte-compile-file B) won't + ;; cause macro calls in B to think they come from A. + (current-load-list (list nil)) ) - ,@body)) + (prog1 + (progn ,@body) + (when byte-native-compiling + (setq byte-to-native-plist-environment + overriding-plist-environment))))) (defmacro displaying-byte-compile-warnings (&rest body) - (declare (debug t)) + (declare (debug (def-body))) `(let* ((--displaying-byte-compile-warnings-fn (lambda () ,@body)) (warning-series-started (and (markerp warning-series) @@ -1815,8 +1857,8 @@ also be compiled." (while directories (setq directory (car directories)) (message "Checking %s..." directory) - (dolist (file (directory-files directory)) - (let ((source (expand-file-name file directory))) + (dolist (source (directory-files directory t)) + (let ((file (file-name-nondirectory source))) (if (file-directory-p source) (and (not (member file '("RCS" "CVS"))) (not (eq ?\. (aref file 0))) @@ -1832,8 +1874,7 @@ also be compiled." (file-readable-p source) (not (string-match "\\`\\.#" file)) (not (auto-save-file-name-p source)) - (not (string-equal dir-locals-file - (file-name-nondirectory source)))) + (not (member source (dir-locals--all-files directory)))) (progn (cl-incf (pcase (byte-recompile-file source force arg) ('no-byte-compile skip-count) @@ -2041,64 +2082,73 @@ See also `emacs-lisp-byte-compile-and-load'." (message "Compiling %s...done" filename)) (kill-buffer input-buffer) (with-current-buffer output-buffer - (goto-char (point-max)) - (insert "\n") ; aaah, unix. - (cond - ((null target-file) nil) ;We only wanted the warnings! - ((and (file-writable-p target-file) - ;; We attempt to create a temporary file in the - ;; target directory, so the target directory must be - ;; writable. - (file-writable-p - (file-name-directory - ;; Need to expand in case TARGET-FILE doesn't - ;; include a directory (Bug#45287). - (expand-file-name target-file)))) - ;; We must disable any code conversion here. - (let* ((coding-system-for-write 'no-conversion) - ;; Write to a tempfile so that if another Emacs - ;; process is trying to load target-file (eg in a - ;; parallel bootstrap), it does not risk getting a - ;; half-finished file. (Bug#4196) - (tempfile - (make-temp-file (expand-file-name target-file))) - (default-modes (default-file-modes)) - (temp-modes (logand default-modes #o600)) - (desired-modes (logand default-modes #o666)) - (kill-emacs-hook - (cons (lambda () (ignore-errors - (delete-file tempfile))) - kill-emacs-hook))) - (unless (= temp-modes desired-modes) - (set-file-modes tempfile desired-modes 'nofollow)) - (write-region (point-min) (point-max) tempfile nil 1) - ;; This has the intentional side effect that any - ;; hard-links to target-file continue to - ;; point to the old file (this makes it possible - ;; for installed files to share disk space with - ;; the build tree, without causing problems when - ;; emacs-lisp files in the build tree are - ;; recompiled). Previously this was accomplished by - ;; deleting target-file before writing it. - (rename-file tempfile target-file t)) - (or noninteractive (message "Wrote %s" target-file))) - ((file-writable-p target-file) - ;; In case the target directory isn't writable (see e.g. Bug#44631), - ;; try writing to the output file directly. We must disable any - ;; code conversion here. - (let ((coding-system-for-write 'no-conversion)) - (with-file-modes (logand (default-file-modes) #o666) - (write-region (point-min) (point-max) target-file nil 1))) - (or noninteractive (message "Wrote %s" target-file))) - (t - ;; This is just to give a better error message than write-region - (let ((exists (file-exists-p target-file))) - (signal (if exists 'file-error 'file-missing) - (list "Opening output file" - (if exists - "Cannot overwrite file" - "Directory not writable or nonexistent") - target-file))))) + (when (and target-file + (or (not byte-native-compiling) + (and byte-native-compiling byte+native-compile))) + (goto-char (point-max)) + (insert "\n") ; aaah, unix. + (cond + ((and (file-writable-p target-file) + ;; We attempt to create a temporary file in the + ;; target directory, so the target directory must be + ;; writable. + (file-writable-p + (file-name-directory + ;; Need to expand in case TARGET-FILE doesn't + ;; include a directory (Bug#45287). + (expand-file-name target-file)))) + ;; We must disable any code conversion here. + (let* ((coding-system-for-write 'no-conversion) + ;; Write to a tempfile so that if another Emacs + ;; process is trying to load target-file (eg in a + ;; parallel bootstrap), it does not risk getting a + ;; half-finished file. (Bug#4196) + (tempfile + (make-temp-file (when (file-writable-p target-file) + (expand-file-name target-file)))) + (default-modes (default-file-modes)) + (temp-modes (logand default-modes #o600)) + (desired-modes (logand default-modes #o666)) + (kill-emacs-hook + (cons (lambda () (ignore-errors + (delete-file tempfile))) + kill-emacs-hook))) + (unless (= temp-modes desired-modes) + (set-file-modes tempfile desired-modes 'nofollow)) + (write-region (point-min) (point-max) tempfile nil 1) + ;; This has the intentional side effect that any + ;; hard-links to target-file continue to + ;; point to the old file (this makes it possible + ;; for installed files to share disk space with + ;; the build tree, without causing problems when + ;; emacs-lisp files in the build tree are + ;; recompiled). Previously this was accomplished by + ;; deleting target-file before writing it. + (if byte-native-compiling + ;; Defer elc final renaming. + (setf byte-to-native-output-file + (cons tempfile target-file)) + (rename-file tempfile target-file t))) + (or noninteractive + byte-native-compiling + (message "Wrote %s" target-file))) + ((file-writable-p target-file) + ;; In case the target directory isn't writable (see e.g. Bug#44631), + ;; try writing to the output file directly. We must disable any + ;; code conversion here. + (let ((coding-system-for-write 'no-conversion)) + (with-file-modes (logand (default-file-modes) #o666) + (write-region (point-min) (point-max) target-file nil 1))) + (or noninteractive (message "Wrote %s" target-file))) + (t + ;; This is just to give a better error message than write-region + (let ((exists (file-exists-p target-file))) + (signal (if exists 'file-error 'file-missing) + (list "Opening output file" + (if exists + "Cannot overwrite file" + "Directory not writable or nonexistent") + target-file)))))) (kill-buffer (current-buffer))) (if (and byte-compile-generate-call-tree (or (eq t byte-compile-generate-call-tree) @@ -2201,6 +2251,17 @@ With argument ARG, insert value in current buffer after the form." (setq byte-compile-unresolved-functions nil) (setq byte-compile-noruntime-functions nil) (setq byte-compile-new-defuns nil) + (when byte-native-compiling + (defvar native-comp-speed) + (push `(native-comp-speed . ,native-comp-speed) byte-native-qualities) + (defvar native-comp-debug) + (push `(native-comp-debug . ,native-comp-debug) byte-native-qualities) + (defvar native-comp-driver-options) + (push `(native-comp-driver-options . ,native-comp-driver-options) + byte-native-qualities) + (defvar no-native-compile) + (push `(no-native-compile . ,no-native-compile) + byte-native-qualities)) ;; Compile the forms from the input buffer. (while (progn @@ -2273,6 +2334,10 @@ Call from the source buffer." ;; defalias calls are output directly by byte-compile-file-form-defmumble; ;; it does not pay to first build the defalias in defmumble and then parse ;; it here. + (when byte-native-compiling + ;; Spill output for the native compiler here + (push (make-byte-to-native-top-level :form form :lexical lexical-binding) + byte-to-native-top-level-forms)) (let ((print-escape-newlines t) (print-length nil) (print-level nil) @@ -2390,7 +2455,7 @@ list that represents a doc string reference. (defun byte-compile-keep-pending (form &optional handler) (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form t))) + (setq form (byte-optimize-one-form form t))) (if handler (let ((byte-compile--for-effect t)) ;; To avoid consing up monstrously large forms at load time, we split @@ -2418,8 +2483,6 @@ list that represents a doc string reference. byte-compile-output nil byte-compile-jump-tables nil)))) -(defvar byte-compile-force-lexical-warnings nil) - (defun byte-compile-preprocess (form &optional _for-effect) (setq form (macroexpand-all form byte-compile-macro-environment)) ;; FIXME: We should run byte-optimize-form here, but it currently does not @@ -2430,7 +2493,6 @@ list that represents a doc string reference. ;; (setq form (byte-optimize-form form for-effect))) (cond (lexical-binding (cconv-closure-convert form)) - (byte-compile-force-lexical-warnings (cconv-warnings-only form)) (t form))) ;; byte-hunk-handlers cannot call this! @@ -2496,12 +2558,14 @@ list that represents a doc string reference. (put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) (put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) -(defun byte-compile--declare-var (sym) +(defun byte-compile--check-prefixed-var (sym) (when (and (symbolp sym) (not (string-match "[-*/:$]" (symbol-name sym))) (byte-compile-warning-enabled-p 'lexical sym)) - (byte-compile-warn "global/dynamic var `%s' lacks a prefix" - sym)) + (byte-compile-warn "global/dynamic var `%s' lacks a prefix" sym))) + +(defun byte-compile--declare-var (sym) + (byte-compile--check-prefixed-var sym) (when (memq sym byte-compile-lexical-variables) (setq byte-compile-lexical-variables (delq sym byte-compile-lexical-variables)) @@ -2717,6 +2781,15 @@ not to take responsibility for the actual compilation of the code." ;; If there's no doc string, provide -1 as the "doc string ;; index" so that no element will be treated as a doc string. (if (not (stringp (documentation code t))) -1 4))) + (when byte-native-compiling + ;; Spill output for the native compiler here. + (push (if macro + (make-byte-to-native-top-level + :form `(defalias ',name '(macro . ,code) nil) + :lexical lexical-binding) + (make-byte-to-native-func-def :name name + :byte-func code)) + byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. (byte-compile-output-docform @@ -2784,16 +2857,12 @@ FUN should be either a `lambda' value or a `closure' value." (dolist (binding env) (cond ((consp binding) - ;; We check shadowing by the args, so that the `let' can be moved - ;; within the lambda, which can then be unfolded. FIXME: Some of those - ;; bindings might be unused in `body'. - (unless (memq (car binding) args) ;Shadowed. - (push `(,(car binding) ',(cdr binding)) renv))) + (push `(,(car binding) ',(cdr binding)) renv)) ((eq binding t)) (t (push `(defvar ,binding) body)))) (if (null renv) `(lambda ,args ,@preamble ,@body) - `(lambda ,args ,@preamble (let ,(nreverse renv) ,@body))))) + `(let ,renv (lambda ,args ,@preamble ,@body))))) ;;;###autoload (defun byte-compile (form) @@ -2818,23 +2887,27 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (symbolp form) form "provided")) fun) (t - (when (or (symbolp form) (eq (car-safe fun) 'closure)) - ;; `fun' is a function *value*, so try to recover its corresponding - ;; source code. - (setq lexical-binding (eq (car fun) 'closure)) - (setq fun (byte-compile--reify-function fun))) - ;; Expand macros. - (setq fun (byte-compile-preprocess fun)) - (setq fun (byte-compile-top-level fun nil 'eval)) - (if (symbolp form) - ;; byte-compile-top-level returns an *expression* equivalent to the - ;; `fun' expression, so we need to evaluate it, tho normally - ;; this is not needed because the expression is just a constant - ;; byte-code object, which is self-evaluating. - (setq fun (eval fun t))) - (if macro (push 'macro fun)) - (if (symbolp form) (fset form fun)) - fun)))))) + (let (final-eval) + (when (or (symbolp form) (eq (car-safe fun) 'closure)) + ;; `fun' is a function *value*, so try to recover its corresponding + ;; source code. + (setq lexical-binding (eq (car fun) 'closure)) + (setq fun (byte-compile--reify-function fun)) + (setq final-eval t)) + ;; Expand macros. + (setq fun (byte-compile-preprocess fun)) + (setq fun (byte-compile-top-level fun nil 'eval)) + (if (symbolp form) + ;; byte-compile-top-level returns an *expression* equivalent to the + ;; `fun' expression, so we need to evaluate it, tho normally + ;; this is not needed because the expression is just a constant + ;; byte-code object, which is self-evaluating. + (setq fun (eval fun t))) + (if final-eval + (setq fun (eval fun t))) + (if macro (push 'macro fun)) + (if (symbolp form) (fset form fun)) + fun))))))) (defun byte-compile-sexp (sexp) "Compile and return SEXP." @@ -2860,7 +2933,9 @@ If FORM is a lambda or a macro, byte-compile it as a function." ((eq arg '&optional) (when (memq '&optional (cdr list)) (error "Duplicate &optional"))) - ((memq arg vars) + ((and (memq arg vars) + ;; Allow repetitions for unused args. + (not (string-match "\\`_" (symbol-name arg)))) (byte-compile-warn "repeated variable %s in lambda-list" arg)) (t (push arg vars)))) @@ -2940,7 +3015,8 @@ for symbols generated by the byte compiler itself." ;; unless it is the last element of the body. (if (cdr body) (setq body (cdr body)))))) - (int (assq 'interactive body))) + (int (assq 'interactive body)) + command-modes) (when lexical-binding (dolist (var arglistvars) (when (assq var byte-compile--known-dynamic-vars) @@ -2951,10 +3027,13 @@ for symbols generated by the byte compiler itself." ;; Skip (interactive) if it is in front (the most usual location). (if (eq int (car body)) (setq body (cdr body))) - (cond ((consp (cdr int)) - (if (cdr (cdr int)) - (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string int))) + (cond ((consp (cdr int)) ; There is an `interactive' spec. + ;; Check that the bit after the `interactive' spec is + ;; just a list of symbols (i.e., modes). + (unless (seq-every-p #'symbolp (cdr (cdr int))) + (byte-compile-warn "malformed interactive specc: %s" + (prin1-to-string int))) + (setq command-modes (cdr (cdr int))) ;; If the interactive spec is a call to `list', don't ;; compile it, because `call-interactively' looks at the ;; args of `list'. Actually, compile it to get warnings, @@ -2965,15 +3044,14 @@ for symbols generated by the byte compiler itself." (while (consp (cdr form)) (setq form (cdr form))) (setq form (car form))) - (if (and (eq (car-safe form) 'list) - ;; For code using lexical-binding, form is not - ;; valid lisp, but rather an intermediate form - ;; which may include "calls" to - ;; internal-make-closure (Bug#29988). - (not lexical-binding)) - nil - (setq int `(interactive ,newform))))) - ((cdr int) + (when (or (not (eq (car-safe form) 'list)) + ;; For code using lexical-binding, form is not + ;; valid lisp, but rather an intermediate form + ;; which may include "calls" to + ;; internal-make-closure (Bug#29988). + lexical-binding) + (setq int `(interactive ,newform))))) + ((cdr int) ; Invalid (interactive . something). (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string int))))) ;; Process the body. @@ -2989,23 +3067,37 @@ for symbols generated by the byte compiler itself." reserved-csts))) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) - (apply #'make-byte-code - (if lexical-binding - (byte-compile-make-args-desc arglist) - arglist) - (append - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (cond ((and lexical-binding arglist) - ;; byte-compile-make-args-desc lost the args's names, - ;; so preserve them in the docstring. - (list (help-add-fundoc-usage doc arglist))) - ((or doc int) - (list doc))) - ;; optionally, the interactive spec. - (if int - (list (nth 1 int)))))))) + (let ((out + (apply #'make-byte-code + (if lexical-binding + (byte-compile-make-args-desc arglist) + arglist) + (append + ;; byte-string, constants-vector, stack depth + (cdr compiled) + ;; optionally, the doc string. + (cond ((and lexical-binding arglist) + ;; byte-compile-make-args-desc lost the args's names, + ;; so preserve them in the docstring. + (list (help-add-fundoc-usage doc arglist))) + ((or doc int) + (list doc))) + ;; optionally, the interactive spec (and the modes the + ;; command applies to). + (cond + ;; We have some command modes, so use the vector form. + (command-modes + (list (vector (nth 1 int) command-modes))) + ;; No command modes, use the simple form with just the + ;; interactive spec. + (int + (list (nth 1 int)))))))) + (when byte-native-compiling + (setf (byte-to-native-lambda-byte-func + (gethash (cadr compiled) + byte-to-native-lambdas-h)) + out)) + out)))) (defvar byte-compile-reserved-constants 0) @@ -3063,7 +3155,7 @@ for symbols generated by the byte compiler itself." (byte-compile-output nil) (byte-compile-jump-tables nil)) (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form byte-compile--for-effect))) + (setq form (byte-optimize-one-form form byte-compile--for-effect))) (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) (setq form (nth 1 form))) ;; Set up things for a lexically-bound function. @@ -3277,7 +3369,7 @@ for symbols generated by the byte compiler itself." ((and (eq (car-safe (car form)) 'lambda) ;; if the form comes out the same way it went in, that's ;; because it was malformed, and we couldn't unfold it. - (not (eq form (setq form (byte-compile-unfold-lambda form))))) + (not (eq form (setq form (macroexp--unfold-lambda form))))) (byte-compile-form form byte-compile--for-effect) (setq byte-compile--for-effect nil)) ((byte-compile-normal-call form))) @@ -3806,15 +3898,38 @@ discarding." (cl-assert (or (> (length env) 0) docstring-exp)) ;Otherwise, we don't need a closure. (cl-assert (byte-code-function-p fun)) - (byte-compile-form `(make-byte-code - ',(aref fun 0) ',(aref fun 1) - (vconcat (vector . ,env) ',(aref fun 2)) - ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun)))) - (if docstring-exp - `(,(car rest) - ,docstring-exp - ,@(cddr rest)) - rest))))))) + (byte-compile-form + (if (or (not docstring-exp) (stringp docstring-exp)) + ;; Use symbols V0, V1 ... as placeholders for closure variables: + ;; they should be short (to save space in the .elc file), yet + ;; distinct when disassembled. + (let* ((dummy-vars (mapcar (lambda (i) (intern (format "V%d" i))) + (number-sequence 0 (1- (length env))))) + (opt-args (mapcar (lambda (i) (aref fun i)) + (number-sequence 4 (1- (length fun))))) + (proto-fun + (apply #'make-byte-code + (aref fun 0) (aref fun 1) + ;; Prepend dummy cells to the constant vector, + ;; to get the indices right when disassembling. + (vconcat dummy-vars (aref fun 2)) + (aref fun 3) + (if docstring-exp + (cons docstring-exp (cdr opt-args)) + opt-args)))) + `(make-closure ,proto-fun ,@env)) + ;; Nontrivial doc string expression: create a bytecode object + ;; from small pieces at run time. + `(make-byte-code + ',(aref fun 0) ',(aref fun 1) + (vconcat (vector . ,env) ',(aref fun 2)) + ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun)))) + (if docstring-exp + `(,(car rest) + ,docstring-exp + ,@(cddr rest)) + rest)))) + )))) (defun byte-compile-get-closed-var (form) "Byte-compile the special `internal-get-closed-var' form." @@ -4148,9 +4263,15 @@ that suppresses all warnings during execution of BODY." byte-compile-unresolved-functions)) (bound-list (byte-compile-find-bound-condition ,condition '(boundp default-boundp local-variable-p))) + (new-bound-list + ;; (seq-difference byte-compile-bound-variables)) + (delq nil (mapcar (lambda (s) + (if (memq s byte-compile-bound-variables) nil s)) + bound-list))) ;; Maybe add to the bound list. (byte-compile-bound-variables - (append bound-list byte-compile-bound-variables))) + (append new-bound-list byte-compile-bound-variables))) + (mapc #'byte-compile--check-prefixed-var new-bound-list) (unwind-protect ;; If things not being bound at all is ok, so must them being ;; obsolete. Note that we add to the existing lists since Tramp @@ -4236,6 +4357,17 @@ Return (TAIL VAR TEST CASES), where: (push value keys) (push (cons (list value) (or body '(t))) cases)) t)))) + ;; Treat (not X) as (eq X nil). + (`((,(or 'not 'null) ,(and var (pred symbolp))) . ,body) + (and (or (eq var switch-var) (not switch-var)) + (progn + (setq switch-var var) + (setq switch-test + (byte-compile--common-test switch-test 'eq)) + (unless (memq nil keys) + (push nil keys) + (push (cons (list nil) (or body '(t))) cases)) + t))) (`((,(and fn (or 'memq 'memql 'member)) ,var ,expr) . ,body) (and (symbolp var) (or (eq var switch-var) (not switch-var)) @@ -4608,10 +4740,15 @@ binding slots have been popped." (defun byte-compile-condition-case (form) (let* ((var (nth 1 form)) (body (nth 2 form)) + (handlers (nthcdr 3 form)) (depth byte-compile-depth) + (success-handler (assq :success handlers)) + (failure-handlers (if success-handler + (remq success-handler handlers) + handlers)) (clauses (mapcar (lambda (clause) (cons (byte-compile-make-tag) clause)) - (nthcdr 3 form))) + failure-handlers)) (endtag (byte-compile-make-tag))) (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) @@ -4637,30 +4774,40 @@ binding slots have been popped." (byte-compile-form body) ;; byte-compile--for-effect (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) - (byte-compile-goto 'byte-goto endtag) - (while clauses - (let ((clause (pop clauses)) - (byte-compile-bound-variables byte-compile-bound-variables) - (byte-compile--lexical-environment - byte-compile--lexical-environment)) - (setq byte-compile-depth (1+ depth)) - (byte-compile-out-tag (pop clause)) - (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) - (cond - ((null var) (byte-compile-discard)) - (lexical-binding - (push (cons var (1- byte-compile-depth)) - byte-compile--lexical-environment)) - (t (byte-compile-dynamic-variable-bind var))) - (byte-compile-body (cdr clause)) ;; byte-compile--for-effect - (cond - ((null var) nil) - (lexical-binding (byte-compile-discard 1 'preserve-tos)) - (t (byte-compile-out 'byte-unbind 1))) - (byte-compile-goto 'byte-goto endtag))) + (let ((compile-handler-body + (lambda (body) + (let ((byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile--lexical-environment + byte-compile--lexical-environment)) + (cond + ((null var) (byte-compile-discard)) + (lexical-binding + (push (cons var (1- byte-compile-depth)) + byte-compile--lexical-environment)) + (t (byte-compile-dynamic-variable-bind var))) - (byte-compile-out-tag endtag))) + (byte-compile-body body) ;; byte-compile--for-effect + + (cond + ((null var)) + (lexical-binding (byte-compile-discard 1 'preserve-tos)) + (t (byte-compile-out 'byte-unbind 1))))))) + + (when success-handler + (funcall compile-handler-body (cdr success-handler))) + + (byte-compile-goto 'byte-goto endtag) + + (while clauses + (let ((clause (pop clauses))) + (setq byte-compile-depth (1+ depth)) + (byte-compile-out-tag (pop clause)) + (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) + (funcall compile-handler-body (cdr clause)) + (byte-compile-goto 'byte-goto endtag))) + + (byte-compile-out-tag endtag)))) (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) @@ -4868,10 +5015,10 @@ binding slots have been popped." (byte-compile-push-constant op) (byte-compile-form fun) (byte-compile-form prop) - (let* ((fun (eval fun)) - (prop (eval prop)) + (let* ((fun (eval fun t)) + (prop (eval prop t)) (val (if (macroexp-const-p val) - (eval val) + (eval val t) (byte-compile-lambda (cadr val))))) (push `(,fun . (,prop ,val ,@(alist-get fun overriding-plist-environment))) @@ -5189,8 +5336,10 @@ already up-to-date." "Reload any Lisp file that was changed since Emacs was dumped. Use with caution." (let* ((argv0 (car command-line-args)) - (emacs-file (executable-find argv0))) - (if (not (and emacs-file (file-executable-p emacs-file))) + (emacs-file (or (and (fboundp 'pdumper-stats) + (cdr (nth 2 (pdumper-stats)))) + (executable-find argv0)))) + (if (not (and emacs-file (file-exists-p emacs-file))) (message "Can't find %s to refresh preloaded Lisp files" argv0) (dolist (f (reverse load-history)) (setq f (car f)) @@ -5203,7 +5352,7 @@ Use with caution." ;; so it can cause recompilation to fail. (not (member (file-name-nondirectory f) '("pcase.el" "bytecomp.el" "macroexp.el" - "cconv.el" "byte-opt.el")))) + "cconv.el" "byte-opt.el" "comp.el")))) (message "Reloading stale %s" (file-name-nondirectory f)) (condition-case nil (load f 'noerror nil 'nosuffix) @@ -5284,13 +5433,15 @@ and corresponding effects." ;; (eval-when-compile (or (byte-code-function-p (symbol-function 'byte-compile-form)) + (subr-native-elisp-p (symbol-function 'byte-compile-form)) (assq 'byte-code (symbol-function 'byte-compile-form)) (let ((byte-optimize nil) ; do it fast (byte-compile-warnings nil)) (mapc (lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) + (unless (subr-native-elisp-p x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x)))) '(byte-compile-normal-call byte-compile-form byte-compile-body |