483 lines
21 KiB
EmacsLisp
483 lines
21 KiB
EmacsLisp
;;; comp-runtime.el --- runtime Lisp native compiler code -*- lexical-binding: t -*-
|
||
|
||
;; Copyright (C) 2023-2024 Free Software Foundation, Inc.
|
||
|
||
;; Author: Andrea Corallo <acorallo@gnu.org>
|
||
;; Keywords: lisp
|
||
;; Package: emacs
|
||
|
||
;; This file is part of GNU Emacs.
|
||
|
||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation, either version 3 of the License, or
|
||
;; (at your option) any later version.
|
||
|
||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
|
||
;; While the main native compiler is implemented in comp.el, when
|
||
;; commonly used as a jit compiler it is only loaded by Emacs sub
|
||
;; processes performing async compilation. This file contains all
|
||
;; the code needed to drive async compilations and any Lisp code
|
||
;; needed at runtime to run native code.
|
||
|
||
;;; Code:
|
||
|
||
(eval-when-compile (require 'cl-lib))
|
||
(require 'comp-common)
|
||
(require 'bytecomp) ;; For `emacs-lisp-compilation-mode'.
|
||
|
||
(defgroup comp-run nil
|
||
"Emacs Lisp native compiler runtime."
|
||
:group 'lisp)
|
||
|
||
(defcustom native-comp-jit-compilation-deny-list
|
||
'()
|
||
"List of regexps to exclude matching files from deferred native compilation.
|
||
Files whose names match any regexp are excluded from native compilation."
|
||
:type '(repeat regexp)
|
||
:version "28.1")
|
||
|
||
(defcustom native-comp-async-jobs-number 0
|
||
"Default number of subprocesses used for async native compilation.
|
||
Value of zero means to use half the number of the CPU's execution units,
|
||
or one if there's just one execution unit."
|
||
:type 'natnum
|
||
:risky t
|
||
:version "28.1")
|
||
|
||
(defcustom native-comp-async-report-warnings-errors t
|
||
"Whether to report warnings and errors from asynchronous native compilation.
|
||
|
||
When native compilation happens asynchronously, it can produce
|
||
warnings and errors, some of which might not be emitted by a
|
||
byte-compilation. The typical case for that is native-compiling
|
||
a file that is missing some `require' of a necessary feature,
|
||
while having it already loaded into the environment when
|
||
byte-compiling.
|
||
|
||
As asynchronous native compilation always starts from a pristine
|
||
environment, it is more sensitive to such omissions, and might be
|
||
unable to compile such Lisp source files correctly.
|
||
|
||
Set this variable to nil to suppress warnings altogether, or to
|
||
the symbol `silent' to log warnings but not pop up the *Warnings*
|
||
buffer."
|
||
:type '(choice
|
||
(const :tag "Do not report warnings/errors" nil)
|
||
(const :tag "Report and display warnings/errors" t)
|
||
(const :tag "Report but do not display warnings/errors" silent))
|
||
:version "28.1")
|
||
|
||
(defcustom native-comp-async-warnings-errors-kind 'important
|
||
"Which kind of warnings and errors to report from async native compilation.
|
||
|
||
Setting this variable to `important' (the default) will report
|
||
only important warnings and all errors.
|
||
Setting this variable to `all' will report all warnings and
|
||
errors."
|
||
:type '(choice
|
||
(const :tag "Report all warnings/errors" all)
|
||
(const :tag "Report important warnings and all errors" important))
|
||
:version "30.1")
|
||
|
||
(defcustom native-comp-always-compile nil
|
||
"Non-nil means unconditionally (re-)compile all files."
|
||
:type 'boolean
|
||
:version "28.1")
|
||
|
||
(make-obsolete-variable 'native-comp-deferred-compilation-deny-list
|
||
'native-comp-jit-compilation-deny-list
|
||
"29.1")
|
||
|
||
(defcustom native-comp-async-cu-done-functions nil
|
||
"List of functions to call when asynchronous compilation of a file is done.
|
||
Each function is called with one argument FILE, the filename whose
|
||
compilation has completed."
|
||
:type 'hook
|
||
:version "28.1")
|
||
|
||
(defcustom native-comp-async-all-done-hook nil
|
||
"Hook run after completing asynchronous compilation of all input files."
|
||
:type 'hook
|
||
:version "28.1")
|
||
|
||
(defcustom native-comp-async-query-on-exit nil
|
||
"Whether to query the user about killing async compilations when exiting.
|
||
If this is non-nil, Emacs will ask for confirmation to exit and kill the
|
||
asynchronous native compilations if any are running. If nil, when you
|
||
exit Emacs, it will silently kill those asynchronous compilations even
|
||
if `confirm-kill-processes' is non-nil."
|
||
:type 'boolean
|
||
:version "28.1")
|
||
|
||
(defconst comp-async-buffer-name "*Async-native-compile-log*"
|
||
"Name of the async compilation buffer log.")
|
||
|
||
(defvar comp-no-spawn nil
|
||
"Non-nil don't spawn native compilation processes.")
|
||
|
||
(defvar comp-async-compilations (make-hash-table :test #'equal)
|
||
"Hash table file-name -> async compilation process.")
|
||
|
||
;; These variables and functions are defined in comp.c
|
||
(defvar comp--no-native-compile)
|
||
(defvar comp-deferred-pending-h)
|
||
(defvar comp-installed-trampolines-h)
|
||
(defvar native-comp-enable-subr-trampolines)
|
||
|
||
(declare-function comp--install-trampoline "comp.c")
|
||
(declare-function comp-el-to-eln-filename "comp.c")
|
||
(declare-function native-elisp-load "comp.c")
|
||
|
||
(defun native--compile-async-skip-p (file load selector)
|
||
"Return non-nil if FILE's compilation should be skipped.
|
||
|
||
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)))
|
||
((stringp selector) (not (string-match-p selector file)))
|
||
(t (error "SELECTOR must be a function a regexp or nil")))
|
||
;; Also exclude files from deferred compilation if
|
||
;; any of the regexps in
|
||
;; `native-comp-jit-compilation-deny-list' matches.
|
||
(and (eq load 'late)
|
||
(seq-some (lambda (re)
|
||
(string-match-p re file))
|
||
native-comp-jit-compilation-deny-list))))
|
||
|
||
(defvar comp-files-queue ()
|
||
"List of Emacs Lisp files to be compiled.")
|
||
|
||
(defvar comp-async-compilations (make-hash-table :test #'equal)
|
||
"Hash table file-name -> async compilation process.")
|
||
|
||
(defun comp--async-runnings ()
|
||
"Return the number of async compilations currently running.
|
||
This function has the side effect of cleaning-up finished
|
||
processes from `comp-async-compilations'"
|
||
(cl-loop
|
||
for file-name in (cl-loop
|
||
for file-name being each hash-key of comp-async-compilations
|
||
for prc = (gethash file-name comp-async-compilations)
|
||
unless (process-live-p prc)
|
||
collect file-name)
|
||
do (remhash file-name comp-async-compilations))
|
||
(hash-table-count comp-async-compilations))
|
||
|
||
(defvar comp-num-cpus nil)
|
||
(defun comp--effective-async-max-jobs ()
|
||
"Compute the effective number of async jobs."
|
||
(if (zerop native-comp-async-jobs-number)
|
||
(or comp-num-cpus
|
||
(setf comp-num-cpus
|
||
(max 1 (/ (num-processors) 2))))
|
||
native-comp-async-jobs-number))
|
||
|
||
(defvar-local comp-last-scanned-async-output nil)
|
||
;; From warnings.el
|
||
(defvar warning-suppress-types)
|
||
(defun comp--accept-and-process-async-output (process)
|
||
"Accept PROCESS output and check for diagnostic messages."
|
||
(if native-comp-async-report-warnings-errors
|
||
(let ((warning-suppress-types
|
||
(if (eq native-comp-async-report-warnings-errors 'silent)
|
||
(cons '(native-compiler) warning-suppress-types)
|
||
warning-suppress-types))
|
||
(regexp (if (eq native-comp-async-warnings-errors-kind 'all)
|
||
"^.*?\\(?:Error\\|Warning\\): .*$"
|
||
(rx bol
|
||
(*? nonl)
|
||
(or
|
||
(seq "Error: " (*? nonl))
|
||
(seq "Warning: the function ‘" (1+ (not "’"))
|
||
"’ is not known to be defined."))
|
||
eol))))
|
||
(with-current-buffer (process-buffer process)
|
||
(save-excursion
|
||
(accept-process-output process)
|
||
(goto-char (or comp-last-scanned-async-output (point-min)))
|
||
(while (re-search-forward regexp nil t)
|
||
(display-warning 'native-compiler (match-string 0)))
|
||
(setq comp-last-scanned-async-output (point-max)))))
|
||
(accept-process-output process)))
|
||
|
||
(defconst comp-valid-source-re (rx ".el" (? ".gz") eos)
|
||
"Regexp to match filename of valid input source files.")
|
||
|
||
(defun comp--run-async-workers ()
|
||
"Start compiling files from `comp-files-queue' asynchronously.
|
||
When compilation is finished, run `native-comp-async-all-done-hook' and
|
||
display a message."
|
||
(cl-assert (null comp-no-spawn))
|
||
(if (or comp-files-queue
|
||
(> (comp--async-runnings) 0))
|
||
(unless (>= (comp--async-runnings) (comp--effective-async-max-jobs))
|
||
(cl-loop
|
||
for (source-file . load) = (pop comp-files-queue)
|
||
while source-file
|
||
do (cl-assert (string-match-p comp-valid-source-re source-file) nil
|
||
"`comp-files-queue' should be \".el\" files: %s"
|
||
source-file)
|
||
when (or native-comp-always-compile
|
||
load ; Always compile when the compilation is
|
||
; commanded for late load.
|
||
;; Skip compilation if `comp-el-to-eln-filename' fails
|
||
;; to find a writable directory.
|
||
(with-demoted-errors "Async compilation :%S"
|
||
(file-newer-than-file-p
|
||
source-file (comp-el-to-eln-filename source-file))))
|
||
do (let* ((expr `((require 'comp)
|
||
(setq comp-async-compilation t
|
||
warning-fill-column most-positive-fixnum)
|
||
,(let ((set (list 'setq)))
|
||
(dolist (var '(comp-file-preloaded-p
|
||
native-compile-target-directory
|
||
native-comp-speed
|
||
native-comp-debug
|
||
native-comp-verbose
|
||
comp-libgccjit-reproducer
|
||
native-comp-eln-load-path
|
||
native-comp-compiler-options
|
||
native-comp-driver-options
|
||
load-path
|
||
backtrace-line-length
|
||
byte-compile-warnings
|
||
comp-sanitizer-emit
|
||
;; package-load-list
|
||
;; package-user-dir
|
||
;; package-directory-list
|
||
))
|
||
(when (boundp var)
|
||
(push var set)
|
||
(push `',(symbol-value var) set)))
|
||
(nreverse set))
|
||
;; FIXME: Activating all packages would align the
|
||
;; functionality offered with what is usually done
|
||
;; for ELPA packages (and thus fix some compilation
|
||
;; issues with some ELPA packages), but it's too
|
||
;; blunt an instrument (e.g. we don't even know if
|
||
;; we're compiling such an ELPA package at
|
||
;; this point).
|
||
;;(package-activate-all)
|
||
,native-comp-async-env-modifier-form
|
||
(message "Compiling %s..." ,source-file)
|
||
(comp--native-compile ,source-file ,(and load t))))
|
||
(source-file1 source-file) ;; Make the closure works :/
|
||
(temp-file (make-temp-file
|
||
(concat "emacs-async-comp-"
|
||
(file-name-base source-file) "-")
|
||
nil ".el"))
|
||
(expr-strings (let ((print-length nil)
|
||
(print-level nil))
|
||
(mapcar #'prin1-to-string expr)))
|
||
(_ (progn
|
||
(with-temp-file temp-file
|
||
(mapc #'insert expr-strings))
|
||
(comp-log "\n")
|
||
(mapc #'comp-log expr-strings)))
|
||
(load1 load)
|
||
(default-directory invocation-directory)
|
||
(process (make-process
|
||
:name (concat "Compiling: " source-file)
|
||
:buffer (with-current-buffer
|
||
(get-buffer-create
|
||
comp-async-buffer-name)
|
||
(unless (derived-mode-p 'compilation-mode)
|
||
(emacs-lisp-compilation-mode))
|
||
(current-buffer))
|
||
:command (list
|
||
(expand-file-name invocation-name
|
||
invocation-directory)
|
||
"-no-comp-spawn" "-Q" "--batch"
|
||
"--eval"
|
||
;; Suppress Abort dialogs on MS-Windows
|
||
"(setq w32-disable-abort-dialog t)"
|
||
"-l" temp-file)
|
||
:sentinel
|
||
(lambda (process _event)
|
||
(run-hook-with-args
|
||
'native-comp-async-cu-done-functions
|
||
source-file)
|
||
(comp--accept-and-process-async-output process)
|
||
(ignore-errors (delete-file temp-file))
|
||
(let ((eln-file (comp-el-to-eln-filename
|
||
source-file1)))
|
||
(when (and load1
|
||
(zerop (process-exit-status
|
||
process))
|
||
(file-exists-p eln-file))
|
||
(native-elisp-load eln-file
|
||
(eq load1 'late))))
|
||
(comp--run-async-workers))
|
||
:noquery (not native-comp-async-query-on-exit))))
|
||
(puthash source-file process comp-async-compilations))
|
||
when (>= (comp--async-runnings) (comp--effective-async-max-jobs))
|
||
do (cl-return)))
|
||
;; No files left to compile and all processes finished.
|
||
(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"))))
|
||
;; `comp-deferred-pending-h' should be empty at this stage.
|
||
;; Reset it anyway.
|
||
(clrhash comp-deferred-pending-h)))
|
||
|
||
(defconst comp-warn-primitives
|
||
'(null memq gethash and subrp not native-comp-function-p
|
||
comp--install-trampoline concat if symbolp symbol-name make-string
|
||
length aset aref length> mapcar expand-file-name
|
||
file-name-as-directory file-exists-p native-elisp-load)
|
||
"List of primitives we want to warn about in case of redefinition.
|
||
This are essential for the trampoline machinery to work properly.")
|
||
|
||
(defun comp--trampoline-search (subr-name)
|
||
"Search a trampoline file for SUBR-NAME.
|
||
Return the trampoline if found or nil otherwise."
|
||
(cl-loop
|
||
with rel-filename = (comp-trampoline-filename subr-name)
|
||
for dir in (comp-eln-load-path-eff)
|
||
for filename = (expand-file-name rel-filename dir)
|
||
when (file-exists-p filename)
|
||
do (cl-return (native-elisp-load filename))))
|
||
|
||
(declare-function comp-trampoline-compile "comp")
|
||
;;;###autoload
|
||
(defun comp-subr-trampoline-install (subr-name)
|
||
"Make SUBR-NAME effectively advice-able when called from native code."
|
||
(when (memq subr-name comp-warn-primitives)
|
||
(warn "Redefining `%s' might break native compilation of trampolines."
|
||
subr-name))
|
||
(let ((subr (symbol-function subr-name)))
|
||
(unless (or (not (string= subr-name (subr-name subr))) ;; (bug#69573)
|
||
(null native-comp-enable-subr-trampolines)
|
||
(memq subr-name native-comp-never-optimize-functions)
|
||
(gethash subr-name comp-installed-trampolines-h))
|
||
(cl-assert (subr-primitive-p subr))
|
||
(when-let* ((trampoline (or (comp--trampoline-search subr-name)
|
||
(comp-trampoline-compile subr-name))))
|
||
(comp--install-trampoline subr-name trampoline)))))
|
||
|
||
;;;###autoload
|
||
(defun native--compile-async (files &optional recursively load selector)
|
||
;; BEWARE, this function is also called directly from C.
|
||
"Compile FILES asynchronously.
|
||
FILES is one filename or a list of filenames or directories.
|
||
|
||
If optional argument RECURSIVELY is non-nil, recurse into
|
||
subdirectories of given directories.
|
||
|
||
If optional argument LOAD is non-nil, request to load the file
|
||
after compiling.
|
||
|
||
The optional argument SELECTOR has the following valid values:
|
||
|
||
nil -- Select all files.
|
||
a string -- A regular expression selecting files with matching names.
|
||
a function -- A function selecting files with matching names.
|
||
|
||
The variable `native-comp-async-jobs-number' specifies the number
|
||
of (commands) to run simultaneously.
|
||
|
||
LOAD can also be the symbol `late'. This is used internally if
|
||
the byte code has already been loaded when this function is
|
||
called. It means that we request the special kind of load
|
||
necessary in that situation, called \"late\" loading.
|
||
|
||
During a \"late\" load, instead of executing all top-level forms
|
||
of the original files, only function definitions are
|
||
loaded (paying attention to have these effective only if the
|
||
bytecode definition was not changed in the meantime)."
|
||
(comp-ensure-native-compiler)
|
||
(unless (member load '(nil t late))
|
||
(error "LOAD must be nil, t or 'late"))
|
||
(unless (listp files)
|
||
(setf files (list files)))
|
||
(let ((added-something nil)
|
||
file-list)
|
||
(dolist (file-or-dir files)
|
||
(cond ((file-directory-p file-or-dir)
|
||
(dolist (file (if recursively
|
||
(directory-files-recursively
|
||
file-or-dir comp-valid-source-re)
|
||
(directory-files file-or-dir
|
||
t comp-valid-source-re)))
|
||
(push file file-list)))
|
||
((file-exists-p file-or-dir) (push file-or-dir file-list))
|
||
(t (signal 'native-compiler-error
|
||
(list "Not a file nor directory" file-or-dir)))))
|
||
(dolist (file file-list)
|
||
(if-let* ((entry (seq-find (lambda (x) (string= file (car x))) comp-files-queue)))
|
||
;; Most likely the byte-compiler has requested a deferred
|
||
;; compilation, so update `comp-files-queue' to reflect that.
|
||
(unless (or (null load)
|
||
(eq load (cdr entry)))
|
||
(setf comp-files-queue
|
||
(cl-loop for i in comp-files-queue
|
||
with old = (car entry)
|
||
if (string= (car i) old)
|
||
collect (cons file load)
|
||
else
|
||
collect i)))
|
||
|
||
(unless (native--compile-async-skip-p file load selector)
|
||
(let* ((out-filename (comp-el-to-eln-filename file))
|
||
(out-dir (file-name-directory out-filename)))
|
||
(unless (file-exists-p out-dir)
|
||
(make-directory out-dir t))
|
||
(if (file-writable-p out-filename)
|
||
(setf comp-files-queue
|
||
(append comp-files-queue `((,file . ,load)))
|
||
added-something t)
|
||
(display-warning 'native-compiler
|
||
(format "Cannot write %s; skipping."
|
||
out-filename)))))))
|
||
;; 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))))
|
||
|
||
;;;###autoload
|
||
(defun native-compile-async (files &optional recursively load selector)
|
||
"Compile FILES asynchronously.
|
||
FILES is one file or a list of filenames or directories.
|
||
|
||
If optional argument RECURSIVELY is non-nil, recurse into
|
||
subdirectories of given directories.
|
||
|
||
If optional argument LOAD is non-nil, request to load the file
|
||
after compiling.
|
||
|
||
The optional argument SELECTOR has the following valid values:
|
||
|
||
nil -- Select all files.
|
||
a string -- A regular expression selecting files with matching names.
|
||
a function -- A function selecting files with matching names.
|
||
|
||
The variable `native-comp-async-jobs-number' specifies the number
|
||
of (commands) to run simultaneously."
|
||
;; Normalize: we only want to pass t or nil, never e.g. `late'.
|
||
(let ((load (not (not load))))
|
||
(native--compile-async files recursively load selector)))
|
||
|
||
(provide 'comp-run)
|
||
|
||
;;; comp-run.el ends here
|