;;; comp-runtime.el --- runtime Lisp native compiler code -*- lexical-binding: t -*- ;; Copyright (C) 2023-2024 Free Software Foundation, Inc. ;; Author: Andrea Corallo ;; 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 . ;;; 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 comp-last-scanned-async-output nil) (make-variable-buffer-local 'comp-last-scanned-async-output) ;; 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 '(comp) 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 '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 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) (let (global-font-lock-mode-buffers) (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) (let (global-font-lock-mode-buffers) (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 subr-native-elisp-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 '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