comp: split code in comp-run.el
* lisp/emacs-lisp/comp-run.el : New file. (comp-run) (native-comp-jit-compilation-deny-list) (native-comp-async-jobs-number) (native-comp-async-report-warnings-errors) (native-comp-always-compile) (native-comp-async-cu-done-functions) (native-comp-async-all-done-hook) (native-comp-async-env-modifier-form) (native-comp-async-query-on-exit, native-comp-verbose) (comp-log-buffer-name, comp-async-buffer-name, comp-no-spawn) (comp-async-compilations, native-comp-limple-mode) (comp-ensure-native-compiler, native-compile-async-skip-p) (comp-files-queue, comp-async-compilations, comp-async-runnings) (comp-num-cpus, comp-effective-async-max-jobs) (comp-last-scanned-async-output) (comp-accept-and-process-async-output, comp-valid-source-re) (comp-run-async-workers, native--compile-async) (native-compile-async): Move these definitions here. * lisp/Makefile.in (COMPILE_FIRST): Update. * src/Makefile.in (elnlisp): Likewise. * admin/MAINTAINERS: Likewise.
This commit is contained in:
Andrea Corallo
parent
5416896d60
commit
e6a955d242
5 changed files with 492 additions and 439 deletions
|
|
@ -133,6 +133,7 @@ Andrea Corallo
|
|||
Lisp native compiler
|
||||
src/comp.c
|
||||
lisp/emacs-lisp/comp.el
|
||||
lisp/emacs-lisp/comp-run.el
|
||||
lisp/emacs-lisp/comp-cstr.el
|
||||
test/src/comp-*.el
|
||||
|
||||
|
|
|
|||
|
|
@ -95,6 +95,7 @@ COMPILE_FIRST = \
|
|||
ifeq ($(HAVE_NATIVE_COMP),yes)
|
||||
COMPILE_FIRST += $(lisp)/emacs-lisp/comp.elc
|
||||
COMPILE_FIRST += $(lisp)/emacs-lisp/comp-cstr.elc
|
||||
COMPILE_FIRST += $(lisp)/emacs-lisp/comp-run.elc
|
||||
endif
|
||||
COMPILE_FIRST += $(lisp)/emacs-lisp/loaddefs-gen.elc
|
||||
COMPILE_FIRST += $(lisp)/emacs-lisp/radix-tree.elc
|
||||
|
|
|
|||
488
lisp/emacs-lisp/comp-run.el
Normal file
488
lisp/emacs-lisp/comp-run.el
Normal file
|
|
@ -0,0 +1,488 @@
|
|||
;;; comp-runtime.el --- runtime Lisp native compiler code -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2023 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 files contains all
|
||||
;; the code needed to drive async compilations and any Lisp code
|
||||
;; needed at runtime to run native code.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'warnings)
|
||||
|
||||
(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" nil)
|
||||
(const :tag "Report and display warnings" t)
|
||||
(const :tag "Report but do not display warnings" silent))
|
||||
:version "28.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-env-modifier-form nil
|
||||
"Form evaluated before compilation by each asynchronous compilation subprocess.
|
||||
Used to modify the compiler environment."
|
||||
:type 'sexp
|
||||
:risky t
|
||||
: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")
|
||||
|
||||
(defcustom native-comp-verbose 0
|
||||
"Compiler verbosity for native compilation, a number between 0 and 3.
|
||||
This is intended for debugging the compiler itself.
|
||||
0 no logging.
|
||||
1 final LIMPLE is logged.
|
||||
2 LAP, final LIMPLE, and some pass info are logged.
|
||||
3 max verbosity."
|
||||
:type 'natnum
|
||||
:risky t
|
||||
:version "28.1")
|
||||
|
||||
(defconst comp-log-buffer-name "*Native-compile-Log*"
|
||||
"Name of the native-compiler log buffer.")
|
||||
|
||||
(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.")
|
||||
|
||||
(cl-defun comp-log (data &optional (level 1) quoted)
|
||||
"Log DATA at LEVEL.
|
||||
LEVEL is a number from 1-3, and defaults to 1; if it is less
|
||||
than `native-comp-verbose', do nothing. If `noninteractive', log
|
||||
with `message'. Otherwise, log with `comp-log-to-buffer'."
|
||||
(when (>= native-comp-verbose level)
|
||||
(if noninteractive
|
||||
(cl-typecase data
|
||||
(atom (message "%s" data))
|
||||
(t (dolist (elem data)
|
||||
(message "%s" elem))))
|
||||
(comp-log-to-buffer data quoted))))
|
||||
|
||||
(define-derived-mode native-comp-limple-mode fundamental-mode "LIMPLE"
|
||||
"Syntax-highlight LIMPLE IR."
|
||||
(setf font-lock-defaults '(comp-limple-lock-keywords)))
|
||||
|
||||
(cl-defun comp-log-to-buffer (data &optional quoted)
|
||||
"Log DATA to `comp-log-buffer-name'."
|
||||
(let* ((print-f (if quoted #'prin1 #'princ))
|
||||
(log-buffer
|
||||
(or (get-buffer comp-log-buffer-name)
|
||||
(with-current-buffer (get-buffer-create comp-log-buffer-name)
|
||||
(unless (derived-mode-p 'compilation-mode)
|
||||
(emacs-lisp-compilation-mode))
|
||||
(current-buffer))))
|
||||
(log-window (get-buffer-window log-buffer))
|
||||
(inhibit-read-only t)
|
||||
at-end-p)
|
||||
(with-current-buffer log-buffer
|
||||
(unless (eq major-mode 'native-comp-limple-mode)
|
||||
(native-comp-limple-mode))
|
||||
(when (= (point) (point-max))
|
||||
(setf at-end-p t))
|
||||
(save-excursion
|
||||
(goto-char (point-max))
|
||||
(cl-typecase data
|
||||
(atom (funcall print-f data log-buffer))
|
||||
(t (dolist (elem data)
|
||||
(funcall print-f elem log-buffer)
|
||||
(insert "\n"))))
|
||||
(insert "\n"))
|
||||
(when (and at-end-p log-window)
|
||||
;; When log window's point is at the end, follow the tail.
|
||||
(with-selected-window log-window
|
||||
(goto-char (point-max)))))))
|
||||
|
||||
(defun comp-ensure-native-compiler ()
|
||||
"Make sure Emacs has native compiler support and libgccjit can be loaded.
|
||||
Signal an error otherwise.
|
||||
To be used by all entry points."
|
||||
(cond
|
||||
((null (featurep 'native-compile))
|
||||
(error "Emacs was not compiled with native compiler support (--with-native-compilation)"))
|
||||
((null (native-comp-available-p))
|
||||
(error "Cannot find libgccjit library"))))
|
||||
|
||||
(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)
|
||||
(cl-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 comp-last-scanned-async-output nil)
|
||||
(make-variable-buffer-local 'comp-last-scanned-async-output)
|
||||
(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 '(comp) warning-suppress-types)
|
||||
warning-suppress-types)))
|
||||
(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 "^.*?\\(?:Error\\|Warning\\): .*$"
|
||||
nil t)
|
||||
(display-warning 'comp (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
|
||||
;; 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)))
|
||||
|
||||
;;;###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 (cl-find file comp-files-queue :key #'car :test #'string=)))
|
||||
;; 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-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))
|
||||
(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 'comp
|
||||
(format "No write access for %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
|
||||
|
|
@ -34,6 +34,7 @@
|
|||
(require 'rx)
|
||||
(require 'subr-x)
|
||||
(require 'warnings)
|
||||
(require 'comp-run)
|
||||
(require 'comp-cstr)
|
||||
|
||||
;; These variables and functions are defined in comp.c
|
||||
|
|
@ -83,33 +84,6 @@ This is intended for debugging the compiler itself.
|
|||
:safe #'natnump
|
||||
:version "29.1")
|
||||
|
||||
(defcustom native-comp-verbose 0
|
||||
"Compiler verbosity for native compilation, a number between 0 and 3.
|
||||
This is intended for debugging the compiler itself.
|
||||
0 no logging.
|
||||
1 final LIMPLE is logged.
|
||||
2 LAP, final LIMPLE, and some pass info are logged.
|
||||
3 max verbosity."
|
||||
:type 'natnum
|
||||
:risky t
|
||||
:version "28.1")
|
||||
|
||||
(defcustom native-comp-always-compile nil
|
||||
"Non-nil means unconditionally (re-)compile all files."
|
||||
:type 'boolean
|
||||
:version "28.1")
|
||||
|
||||
(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")
|
||||
|
||||
(make-obsolete-variable 'native-comp-deferred-compilation-deny-list
|
||||
'native-comp-jit-compilation-deny-list
|
||||
"29.1")
|
||||
|
||||
(defcustom native-comp-bootstrap-deny-list
|
||||
'()
|
||||
"List of regexps to exclude files from native compilation during bootstrap.
|
||||
|
|
@ -131,65 +105,6 @@ those primitives unnecessary in case of function redefinition/advice."
|
|||
:type '(repeat symbol)
|
||||
: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-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-env-modifier-form nil
|
||||
"Form evaluated before compilation by each asynchronous compilation subprocess.
|
||||
Used to modify the compiler environment."
|
||||
:type 'sexp
|
||||
: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" nil)
|
||||
(const :tag "Report and display warnings" t)
|
||||
(const :tag "Report but do not display warnings" silent))
|
||||
: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")
|
||||
|
||||
(defcustom native-comp-compiler-options nil
|
||||
"Command line options passed verbatim to GCC compiler.
|
||||
Note that not all options are meaningful and some options might even
|
||||
|
|
@ -245,15 +160,6 @@ Emacs Lisp file:
|
|||
(defvar comp-dry-run nil
|
||||
"If non-nil, run everything but the C back-end.")
|
||||
|
||||
(defconst comp-valid-source-re (rx ".el" (? ".gz") eos)
|
||||
"Regexp to match filename of valid input source files.")
|
||||
|
||||
(defconst comp-log-buffer-name "*Native-compile-Log*"
|
||||
"Name of the native-compiler log buffer.")
|
||||
|
||||
(defconst comp-async-buffer-name "*Async-native-compile-log*"
|
||||
"Name of the async compilation buffer log.")
|
||||
|
||||
(defvar comp-native-compiling nil
|
||||
"This gets bound to t during native compilation.
|
||||
Intended to be used by code that needs to work differently when
|
||||
|
|
@ -1027,16 +933,6 @@ In use by the back-end."
|
|||
|
||||
|
||||
|
||||
(defun comp-ensure-native-compiler ()
|
||||
"Make sure Emacs has native compiler support and libgccjit can be loaded.
|
||||
Signal an error otherwise.
|
||||
To be used by all entry points."
|
||||
(cond
|
||||
((null (featurep 'native-compile))
|
||||
(error "Emacs was not compiled with native compiler support (--with-native-compilation)"))
|
||||
((null (native-comp-available-p))
|
||||
(error "Cannot find libgccjit library"))))
|
||||
|
||||
(defun comp-equality-fun-p (function)
|
||||
"Equality functions predicate for FUNCTION."
|
||||
(when (memq function '(eq eql equal)) t))
|
||||
|
|
@ -1124,53 +1020,6 @@ Assume allocation class `d-default' as default."
|
|||
(1 font-lock-keyword-face)))
|
||||
"Highlights used by `native-comp-limple-mode'.")
|
||||
|
||||
(define-derived-mode native-comp-limple-mode fundamental-mode "LIMPLE"
|
||||
"Syntax-highlight LIMPLE IR."
|
||||
(setf font-lock-defaults '(comp-limple-lock-keywords)))
|
||||
|
||||
(cl-defun comp-log (data &optional (level 1) quoted)
|
||||
"Log DATA at LEVEL.
|
||||
LEVEL is a number from 1-3, and defaults to 1; if it is less
|
||||
than `native-comp-verbose', do nothing. If `noninteractive', log
|
||||
with `message'. Otherwise, log with `comp-log-to-buffer'."
|
||||
(when (>= native-comp-verbose level)
|
||||
(if noninteractive
|
||||
(cl-typecase data
|
||||
(atom (message "%s" data))
|
||||
(t (dolist (elem data)
|
||||
(message "%s" elem))))
|
||||
(comp-log-to-buffer data quoted))))
|
||||
|
||||
(cl-defun comp-log-to-buffer (data &optional quoted)
|
||||
"Log DATA to `comp-log-buffer-name'."
|
||||
(let* ((print-f (if quoted #'prin1 #'princ))
|
||||
(log-buffer
|
||||
(or (get-buffer comp-log-buffer-name)
|
||||
(with-current-buffer (get-buffer-create comp-log-buffer-name)
|
||||
(unless (derived-mode-p 'compilation-mode)
|
||||
(emacs-lisp-compilation-mode))
|
||||
(current-buffer))))
|
||||
(log-window (get-buffer-window log-buffer))
|
||||
(inhibit-read-only t)
|
||||
at-end-p)
|
||||
(with-current-buffer log-buffer
|
||||
(unless (eq major-mode 'native-comp-limple-mode)
|
||||
(native-comp-limple-mode))
|
||||
(when (= (point) (point-max))
|
||||
(setf at-end-p t))
|
||||
(save-excursion
|
||||
(goto-char (point-max))
|
||||
(cl-typecase data
|
||||
(atom (funcall print-f data log-buffer))
|
||||
(t (dolist (elem data)
|
||||
(funcall print-f elem log-buffer)
|
||||
(insert "\n"))))
|
||||
(insert "\n"))
|
||||
(when (and at-end-p log-window)
|
||||
;; When log window's point is at the end, follow the tail.
|
||||
(with-selected-window log-window
|
||||
(goto-char (point-max)))))))
|
||||
|
||||
(defun comp-prettyformat-mvar (mvar)
|
||||
(format "#(mvar %s %s %S)"
|
||||
(comp-mvar-id mvar)
|
||||
|
|
@ -3927,174 +3776,6 @@ session."
|
|||
(when newfile
|
||||
(rename-file newfile oldfile)))))
|
||||
|
||||
(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 comp-last-scanned-async-output nil)
|
||||
(make-variable-buffer-local 'comp-last-scanned-async-output)
|
||||
(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 '(comp) warning-suppress-types)
|
||||
warning-suppress-types)))
|
||||
(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 "^.*?\\(?:Error\\|Warning\\): .*$"
|
||||
nil t)
|
||||
(display-warning 'comp (match-string 0)))
|
||||
(setq comp-last-scanned-async-output (point-max)))))
|
||||
(accept-process-output process)))
|
||||
|
||||
(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
|
||||
;; 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)))
|
||||
|
||||
(defun comp--native-compile (function-or-file &optional with-late-load output)
|
||||
"Compile FUNCTION-OR-FILE into native code.
|
||||
When WITH-LATE-LOAD is non-nil, mark the compilation unit for late
|
||||
|
|
@ -4177,102 +3858,6 @@ the deferred compilation mechanism."
|
|||
(ignore-errors (delete-file (comp-ctxt-output comp-ctxt))))
|
||||
(t (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.
|
||||
|
||||
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)
|
||||
(cl-some (lambda (re)
|
||||
(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.
|
||||
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 (cl-find file comp-files-queue :key #'car :test #'string=)))
|
||||
;; 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-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))
|
||||
(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 'comp
|
||||
(format "No write access for %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))))
|
||||
|
||||
|
||||
;;; Compiler entry points.
|
||||
|
||||
|
|
@ -4380,29 +3965,6 @@ variable \"NATIVE_DISABLED\" is set, only byte compile."
|
|||
(comp-write-bytecode-file eln-file)
|
||||
(setq command-line-args-left (cdr command-line-args-left)))))
|
||||
|
||||
;;;###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)))
|
||||
|
||||
(defun native-compile-prune-cache ()
|
||||
"Remove .eln files that aren't applicable to the current Emacs invocation."
|
||||
(interactive)
|
||||
|
|
|
|||
|
|
@ -943,6 +943,7 @@ elnlisp := \
|
|||
international/charscript.eln \
|
||||
emacs-lisp/comp.eln \
|
||||
emacs-lisp/comp-cstr.eln \
|
||||
emacs-lisp/comp-run.eln \
|
||||
international/emoji-zwj.eln
|
||||
elnlisp := $(addprefix ${lispsource}/,${elnlisp}) $(lisp:.elc=.eln)
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue