diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/byte-run.el | 5 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 60 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 6 | ||||
| -rw-r--r-- | lisp/emacs-lisp/comp.el | 186 | ||||
| -rw-r--r-- | lisp/emacs-lisp/loaddefs-gen.el | 4 |
5 files changed, 141 insertions, 120 deletions
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 9db84c31b88..a33808ab92d 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -481,6 +481,11 @@ convention was modified." (puthash (indirect-function function) signature advertised-signature-table)) +(defun get-advertised-calling-convention (function) + "Get the advertised SIGNATURE of FUNCTION. +Return t if there isn't any." + (gethash function advertised-signature-table t)) + (defun make-obsolete (obsolete-name current-name when) "Make the byte-compiler warn that function OBSOLETE-NAME is obsolete. OBSOLETE-NAME should be a function name or macro name (a symbol). diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index ec45f488971..45ff1f4a8ec 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -129,6 +129,7 @@ ;; us from emitting warnings when compiling files which use cl-lib without ;; requiring it! (bug#30635) (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) ;; The feature of compiling in a specific target Emacs version ;; has been turned off because compile time options are a bad idea. @@ -1185,27 +1186,22 @@ message buffer `default-directory'." (defun byte-compile--first-symbol-with-pos (form) "Return the first symbol with position in form, or nil if none. Order is by depth-first search." - (cond - ((symbol-with-pos-p form) form) - ((consp form) - (or (byte-compile--first-symbol-with-pos (car form)) - (let ((sym nil)) - (setq form (cdr form)) - (while (and (consp form) - (not (setq sym (byte-compile--first-symbol-with-pos - (car form))))) - (setq form (cdr form))) - (or sym - (and form (byte-compile--first-symbol-with-pos form)))))) - ((or (vectorp form) (recordp form)) - (let ((len (length form)) - (i 0) - (sym nil)) - (while (and (< i len) - (not (setq sym (byte-compile--first-symbol-with-pos - (aref form i))))) - (setq i (1+ i))) - sym)))) + (named-let loop ((form form) + (depth 10)) ;Arbitrary limit. + (cond + ((<= depth 0) nil) ;Avoid cycles (bug#58601). + ((symbol-with-pos-p form) form) + ((consp form) + (or (loop (car form) (1- depth)) + (loop (cdr form) (1- depth)))) + ((or (vectorp form) (recordp form)) + (let ((len (length form)) + (i 0) + (sym nil)) + (while (and (< i len) + (not (setq sym (loop (aref form i) (1- depth))))) + (setq i (1+ i))) + sym))))) (defun byte-compile--warning-source-offset () "Return a source offset from `byte-compile-form-stack' or nil if none." @@ -1405,11 +1401,11 @@ when printing the error message." (and (not macro-p) (compiled-function-p (symbol-function fn))))) (setq fn (symbol-function fn))) - (let ((advertised (gethash (if (and (symbolp fn) (fboundp fn)) - ;; Could be a subr. - (symbol-function fn) - fn) - advertised-signature-table t))) + (let ((advertised (get-advertised-calling-convention + (if (and (symbolp fn) (fboundp fn)) + ;; Could be a subr. + (symbol-function fn) + fn)))) (cond ((listp advertised) (if macro-p @@ -2335,9 +2331,15 @@ With argument ARG, insert value in current buffer after the form." (setq case-fold-search nil)) (displaying-byte-compile-warnings (with-current-buffer inbuffer - (and byte-compile-current-file - (byte-compile-insert-header byte-compile-current-file - byte-compile--outbuffer)) + (when byte-compile-current-file + (byte-compile-insert-header byte-compile-current-file + byte-compile--outbuffer) + ;; Instruct native-comp to ignore this file. + (when (bound-and-true-p no-native-compile) + (with-current-buffer byte-compile--outbuffer + (insert + "(when (boundp 'comp--no-native-compile) + (puthash load-file-name t comp--no-native-compile))\n\n")))) (goto-char (point-min)) ;; Should we always do this? When calling multiple files, it ;; would be useful to delay this warning until all have been diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index b3ade3b8943..7b6d43e572b 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -650,13 +650,17 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (cl--generic-name generic) qualifiers specializers)) current-load-list :test #'equal) - (let (;; Prevent `defalias' from recording this as the definition site of + (let ((old-adv-cc (get-advertised-calling-convention + (symbol-function sym))) + ;; Prevent `defalias' from recording this as the definition site of ;; the generic function. current-load-list ;; BEWARE! Don't purify this function definition, since that leads ;; to memory corruption if the hash-tables it holds are modified ;; (the GC doesn't trace those pointers). (purify-flag nil)) + (when (listp old-adv-cc) + (set-advertised-calling-convention gfun old-adv-cc nil)) ;; But do use `defalias', so that it interacts properly with nadvice, ;; e.g. for tracing/debug-on-entry. (defalias sym gfun))))) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 889bffa3f5c..2c9b79334ba 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -687,6 +687,9 @@ Useful to hook into pass checkers.") 'native-compiler-error) +(defvar comp-no-spawn nil + "Non-nil don't spawn native compilation processes.") + ;; Moved early to avoid circularity when comp.el is loaded and ;; `macroexpand' needs to be advised (bug#47049). ;;;###autoload @@ -696,12 +699,9 @@ Useful to hook into pass checkers.") (memq subr-name native-comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) (cl-assert (subr-primitive-p (symbol-function subr-name))) - (comp--install-trampoline - subr-name - (or (comp-trampoline-search subr-name) - (comp-trampoline-compile subr-name) - ;; Should never happen. - (cl-assert nil))))) + (when-let ((trampoline (or (comp-trampoline-search subr-name) + (comp-trampoline-compile subr-name)))) + (comp--install-trampoline subr-name trampoline)))) (cl-defstruct (comp-vec (:copier nil)) @@ -3689,7 +3689,8 @@ Prepare every function for final compilation and drive the C back-end." (print-circle t) (print-escape-multibyte t) (expr `((require 'comp) - (setf native-comp-verbose ,native-comp-verbose + (setf comp-no-spawn t + native-comp-verbose ,native-comp-verbose comp-libgccjit-reproducer ,comp-libgccjit-reproducer comp-ctxt ,comp-ctxt native-comp-eln-load-path ',native-comp-eln-load-path @@ -3945,8 +3946,9 @@ display a message." (file-newer-than-file-p source-file (comp-el-to-eln-filename source-file)))) do (let* ((expr `((require 'comp) - (setq comp-async-compilation t) - (setq warning-fill-column most-positive-fixnum) + (setq comp-async-compilation t + comp-no-spawn t + warning-fill-column most-positive-fixnum) ,(let ((set (list 'setq))) (dolist (var '(comp-file-preloaded-p native-compile-target-directory @@ -4046,72 +4048,73 @@ the deferred compilation mechanism." (stringp function-or-file)) (signal 'native-compiler-error (list "Not a function symbol or file" function-or-file))) - (catch 'no-native-compile - (let* ((print-symbols-bare t) - (data function-or-file) - (comp-native-compiling t) - (byte-native-qualities nil) - (symbols-with-pos-enabled t) - ;; Have byte compiler signal an error when compilation fails. - (byte-compile-debug t) - (comp-ctxt (make-comp-ctxt :output output - :with-late-load with-late-load))) - (comp-log "\n \n" 1) - (unwind-protect - (progn - (condition-case err - (cl-loop - with report = nil - for t0 = (current-time) - for pass in comp-passes - unless (memq pass comp-disabled-passes) - do - (comp-log (format "(%s) Running pass %s:\n" - function-or-file pass) - 2) - (setf data (funcall pass data)) - (push (cons pass (float-time (time-since t0))) report) - (cl-loop for f in (alist-get pass comp-post-pass-hooks) - do (funcall f data)) - finally - (when comp-log-time-report - (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)))) - (native-compiler-skip) - (t - (let ((err-val (cdr err))) - ;; If we are doing an async native compilation print the - ;; error in the correct format so is parsable and abort. - (if (and comp-async-compilation - (not (eq (car err) 'native-compiler-error))) - (progn - (message (if err-val - "%s: Error: %s %s" - "%s: Error %s") - function-or-file - (get (car err) 'error-message) - (car-safe err-val)) - (kill-emacs -1)) - ;; Otherwise re-signal it adding the compilation input. - (signal (car err) (if (consp err-val) - (cons function-or-file err-val) - (list function-or-file err-val))))))) - (if (stringp function-or-file) - data - ;; So we return the compiled function. - (native-elisp-load data))) - ;; We may have created a temporary file when we're being - ;; called with something other than a file as the argument. - ;; Delete it. - (when (and (not (stringp function-or-file)) - (not output) - comp-ctxt - (comp-ctxt-output comp-ctxt) - (file-exists-p (comp-ctxt-output comp-ctxt))) - (message "Deleting %s" (comp-ctxt-output comp-ctxt)) - (delete-file (comp-ctxt-output comp-ctxt))))))) + (unless comp-no-spawn + (catch 'no-native-compile + (let* ((print-symbols-bare t) + (data function-or-file) + (comp-native-compiling t) + (byte-native-qualities nil) + (symbols-with-pos-enabled t) + ;; Have byte compiler signal an error when compilation fails. + (byte-compile-debug t) + (comp-ctxt (make-comp-ctxt :output output + :with-late-load with-late-load))) + (comp-log "\n \n" 1) + (unwind-protect + (progn + (condition-case err + (cl-loop + with report = nil + for t0 = (current-time) + for pass in comp-passes + unless (memq pass comp-disabled-passes) + do + (comp-log (format "(%s) Running pass %s:\n" + function-or-file pass) + 2) + (setf data (funcall pass data)) + (push (cons pass (float-time (time-since t0))) report) + (cl-loop for f in (alist-get pass comp-post-pass-hooks) + do (funcall f data)) + finally + (when comp-log-time-report + (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)))) + (native-compiler-skip) + (t + (let ((err-val (cdr err))) + ;; If we are doing an async native compilation print the + ;; error in the correct format so is parsable and abort. + (if (and comp-async-compilation + (not (eq (car err) 'native-compiler-error))) + (progn + (message (if err-val + "%s: Error: %s %s" + "%s: Error %s") + function-or-file + (get (car err) 'error-message) + (car-safe err-val)) + (kill-emacs -1)) + ;; Otherwise re-signal it adding the compilation input. + (signal (car err) (if (consp err-val) + (cons function-or-file err-val) + (list function-or-file err-val))))))) + (if (stringp function-or-file) + data + ;; So we return the compiled function. + (native-elisp-load data))) + ;; We may have created a temporary file when we're being + ;; called with something other than a file as the argument. + ;; Delete it. + (when (and (not (stringp function-or-file)) + (not output) + comp-ctxt + (comp-ctxt-output comp-ctxt) + (file-exists-p (comp-ctxt-output comp-ctxt))) + (message "Deleting %s" (comp-ctxt-output comp-ctxt)) + (delete-file (comp-ctxt-output comp-ctxt)))))))) (defun native-compile-async-skip-p (file load selector) "Return non-nil if FILE's compilation should be skipped. @@ -4119,6 +4122,7 @@ the deferred compilation mechanism." LOAD and SELECTOR work as described in `native--compile-async'." ;; Make sure we are not already compiling `file' (bug#40838). (or (gethash file comp-async-compilations) + (gethash (file-name-with-extension file "elc") comp--no-native-compile) (cond ((null selector) nil) ((functionp selector) (not (funcall selector file))) @@ -4166,7 +4170,8 @@ bytecode definition was not changed in the meantime)." (error "LOAD must be nil, t or 'late")) (unless (listp files) (setf files (list files))) - (let (file-list) + (let ((added-something nil) + file-list) (dolist (file-or-dir files) (cond ((file-directory-p file-or-dir) (dolist (file (if recursively @@ -4194,11 +4199,15 @@ bytecode definition was not changed in the meantime)." (make-directory out-dir t)) (if (file-writable-p out-filename) (setf comp-files-queue - (append comp-files-queue `((,file . ,load)))) + (append comp-files-queue `((,file . ,load))) + added-something t) (display-warning 'comp (format "No write access for %s skipping." out-filename))))))) - (when (zerop (comp-async-runnings)) + ;; Perhaps nothing passed `native-compile-async-skip-p'? + (when (and added-something + ;; Don't start if there's one already running. + (zerop (comp-async-runnings))) (comp-run-async-workers)))) @@ -4234,14 +4243,13 @@ Search happens in `native-comp-eln-load-path'." (defun native-compile (function-or-file &optional output) "Compile FUNCTION-OR-FILE into native code. This is the synchronous entry-point for the Emacs Lisp native -compiler. -FUNCTION-OR-FILE is a function symbol, a form, or the filename of -an Emacs Lisp source file. -If OUTPUT is non-nil, use it as the filename for the compiled -object. -If FUNCTION-OR-FILE is a filename, return the filename of the -compiled object. If FUNCTION-OR-FILE is a function symbol or a -form, return the compiled function." +compiler. FUNCTION-OR-FILE is a function symbol, a form, or the +filename of an Emacs Lisp source file. If OUTPUT is non-nil, use +it as the filename for the compiled object. If FUNCTION-OR-FILE +is a filename, if the compilation was successful return the +filename of the compiled object. If FUNCTION-OR-FILE is a +function symbol or a form, if the compilation was successful +return the compiled function." (comp--native-compile function-or-file nil output)) ;;;###autoload @@ -4328,13 +4336,15 @@ of (commands) to run simultaneously." ;; `invocation-directory'. (setq dir (expand-file-name dir invocation-directory)) (when (file-exists-p dir) - (dolist (subdir (directory-files dir t)) + (dolist (subdir (seq-filter + (lambda (f) (not (string-match (rx "/." (? ".") eos) f))) + (directory-files dir t))) (when (and (file-directory-p subdir) (file-writable-p subdir) (not (equal (file-name-nondirectory (directory-file-name subdir)) comp-native-version-dir))) - (message "Deleting %s..." subdir) + (message "Deleting `%s'..." subdir) ;; We're being overly cautious here -- there shouldn't be ;; anything but .eln files in these directories. (dolist (eln (directory-files subdir t "\\.eln\\(\\.tmp\\)?\\'")) diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index a1c4f91579e..ecc5f7e47bd 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -738,12 +738,12 @@ rules for built-in packages and excluded files." (expand-file-name "emacs-lisp/loaddefs-gen.el" lisp-directory) output-file))) (let ((lisp-mode-autoload-regexp - "^;;;###\\(\\(noexist\\)-\\)?\\(theme-autoload\\)")) + "^;;;###\\(\\(noexist\\)-\\)?\\(theme-autoload\\)")) (loaddefs-generate (expand-file-name "../etc/themes/" lisp-directory) (expand-file-name "theme-loaddefs.el" lisp-directory)))) -;;;###autoload (load "theme-loaddefs.el") +;;;###autoload (load "theme-loaddefs.el" t) (provide 'loaddefs-gen) |