unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
blob 5cc615790306ceda9c59b7d74b2cde4855235748 21937 bytes (raw)
name: lisp/emacs-lisp/comp-run.el 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
 
;;; 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 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)
                                         (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 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

debug log:

solving 5cc61579030 ...
found 5cc61579030 in https://git.savannah.gnu.org/cgit/emacs.git

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).