diff options
Diffstat (limited to 'lisp/emacs-lisp/comp.el')
| -rw-r--r-- | lisp/emacs-lisp/comp.el | 1232 |
1 files changed, 192 insertions, 1040 deletions
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 586a4df3890..f9eeef1b9e8 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -29,16 +29,27 @@ ;;; Code: (require 'bytecomp) -(require 'cl-extra) (require 'cl-lib) -(require 'cl-macs) -(require 'cl-seq) (require 'gv) (require 'rx) (require 'subr-x) (require 'warnings) +(require 'comp-common) (require 'comp-cstr) +;; These variables and functions are defined in comp.c +(defvar comp-native-version-dir) +(defvar comp-subr-arities-h) +(defvar native-comp-eln-load-path) +(defvar native-comp-enable-subr-trampolines) + +(declare-function comp--compile-ctxt-to-file "comp.c") +(declare-function comp--init-ctxt "comp.c") +(declare-function comp--release-ctxt "comp.c") +(declare-function comp-el-to-eln-filename "comp.c") +(declare-function comp-el-to-eln-rel-filename "comp.c") +(declare-function native-elisp-load "comp.c") + (defgroup comp nil "Emacs Lisp native compiler." :group 'lisp) @@ -69,33 +80,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. @@ -104,78 +88,6 @@ during bootstrap." :type '(repeat regexp) :version "28.1") -(defcustom native-comp-never-optimize-functions - '(;; The following two are mandatory for Emacs to be working - ;; correctly (see comment in `advice--add-function'). DO NOT - ;; REMOVE. - macroexpand rename-buffer) - "Primitive functions to exclude from trampoline optimization. - -Primitive functions included in this list will not be called -directly by the natively-compiled code, which makes trampolines for -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 @@ -186,8 +98,9 @@ and above." :type '(repeat string) :version "28.1") -(defcustom native-comp-driver-options (when (eq system-type 'darwin) - '("-Wl,-w")) +(defcustom native-comp-driver-options + (cond ((eq system-type 'darwin) '("-Wl,-w")) + ((eq system-type 'cygwin) '("-Wl,-dynamicbase"))) "Options passed verbatim to the native compiler's back-end driver. Note that not all options are meaningful; typically only the options affecting the assembler and linker are likely to be useful. @@ -230,15 +143,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 @@ -273,324 +177,6 @@ For internal use by the test suite only.") Each function in FUNCTIONS is run after PASS. Useful to hook into pass checkers.") -;; FIXME this probably should not be here but... good for now. -(defconst comp-known-type-specifiers - `( - ;; Functions we can trust not to be or if redefined should expose - ;; the same type. Vast majority of these is either pure or - ;; primitive, the original list is the union of pure + - ;; side-effect-free-fns + side-effect-and-error-free-fns: - (% (function ((or number marker) (or number marker)) number)) - (* (function (&rest (or number marker)) number)) - (+ (function (&rest (or number marker)) number)) - (- (function (&rest (or number marker)) number)) - (/ (function ((or number marker) &rest (or number marker)) number)) - (/= (function ((or number marker) (or number marker)) boolean)) - (1+ (function ((or number marker)) number)) - (1- (function ((or number marker)) number)) - (< (function ((or number marker) &rest (or number marker)) boolean)) - (<= (function ((or number marker) &rest (or number marker)) boolean)) - (= (function ((or number marker) &rest (or number marker)) boolean)) - (> (function ((or number marker) &rest (or number marker)) boolean)) - (>= (function ((or number marker) &rest (or number marker)) boolean)) - (abs (function (number) number)) - (acos (function (number) float)) - (append (function (&rest t) t)) - (aref (function (t fixnum) t)) - (arrayp (function (t) boolean)) - (ash (function (integer integer) integer)) - (asin (function (number) float)) - (assq (function (t list) list)) - (atan (function (number &optional number) float)) - (atom (function (t) boolean)) - (bignump (function (t) boolean)) - (bobp (function () boolean)) - (bolp (function () boolean)) - (bool-vector-count-consecutive (function (bool-vector boolean integer) fixnum)) - (bool-vector-count-population (function (bool-vector) fixnum)) - (bool-vector-not (function (bool-vector &optional bool-vector) bool-vector)) - (bool-vector-p (function (t) boolean)) - (bool-vector-subsetp (function (bool-vector bool-vector) boolean)) - (boundp (function (symbol) boolean)) - (buffer-end (function ((or number marker)) integer)) - (buffer-file-name (function (&optional buffer) (or string null))) - (buffer-list (function (&optional frame) list)) - (buffer-local-variables (function (&optional buffer) list)) - (buffer-modified-p (function (&optional buffer) boolean)) - (buffer-size (function (&optional buffer) integer)) - (buffer-string (function () string)) - (buffer-substring (function ((or integer marker) (or integer marker)) string)) - (bufferp (function (t) boolean)) - (byte-code-function-p (function (t) boolean)) - (capitalize (function (or integer string) (or integer string))) - (car (function (list) t)) - (car-less-than-car (function (list list) boolean)) - (car-safe (function (t) t)) - (case-table-p (function (t) boolean)) - (cdr (function (list) t)) - (cdr-safe (function (t) t)) - (ceiling (function (number &optional number) integer)) - (char-after (function (&optional (or marker integer)) (or fixnum null))) - (char-before (function (&optional (or marker integer)) (or fixnum null))) - (char-equal (function (integer integer) boolean)) - (char-or-string-p (function (t) boolean)) - (char-to-string (function (fixnum) string)) - (char-width (function (fixnum) fixnum)) - (characterp (function (t &optional t) boolean)) - (charsetp (function (t) boolean)) - (commandp (function (t &optional t) boolean)) - (compare-strings (function (string (or integer marker null) (or integer marker null) string (or integer marker null) (or integer marker null) &optional t) (or (member t) fixnum))) - (concat (function (&rest sequence) string)) - (cons (function (t t) cons)) - (consp (function (t) boolean)) - (coordinates-in-window-p (function (cons window) boolean)) - (copy-alist (function (list) list)) - (copy-marker (function (&optional (or integer marker) boolean) marker)) - (copy-sequence (function (sequence) sequence)) - (copysign (function (float float) float)) - (cos (function (number) float)) - (count-lines (function ((or integer marker) (or integer marker) &optional t) integer)) - (current-buffer (function () buffer)) - (current-global-map (function () cons)) - (current-indentation (function () integer)) - (current-local-map (function () (or cons null))) - (current-minor-mode-maps (function () (or cons null))) - (current-time (function () cons)) - (current-time-string (function (&optional (or number list) - (or symbol string cons integer)) - string)) - (current-time-zone (function (&optional (or number list) - (or symbol string cons integer)) - cons)) - (custom-variable-p (function (symbol) boolean)) - (decode-char (function (cons t) (or fixnum null))) - (decode-time (function (&optional (or number list) - (or symbol string cons integer) - symbol) - cons)) - (default-boundp (function (symbol) boolean)) - (default-value (function (symbol) t)) - (degrees-to-radians (function (number) float)) - (documentation (function ((or function symbol subr) &optional t) (or null string))) - (downcase (function ((or fixnum string)) (or fixnum string))) - (elt (function (sequence integer) t)) - (encode-char (function (fixnum symbol) (or fixnum null))) - (encode-time (function (cons &rest t) cons)) - (eobp (function () boolean)) - (eolp (function () boolean)) - (eq (function (t t) boolean)) - (eql (function (t t) boolean)) - (equal (function (t t) boolean)) - (error-message-string (function (list) string)) - (eventp (function (t) boolean)) - (exp (function (number) float)) - (expt (function (number number) float)) - (fboundp (function (symbol) boolean)) - (fceiling (function (float) float)) - (featurep (function (symbol &optional symbol) boolean)) - (ffloor (function (float) float)) - (file-directory-p (function (string) boolean)) - (file-exists-p (function (string) boolean)) - (file-locked-p (function (string) boolean)) - (file-name-absolute-p (function (string) boolean)) - (file-newer-than-file-p (function (string string) boolean)) - (file-readable-p (function (string) boolean)) - (file-symlink-p (function (string) boolean)) - (file-writable-p (function (string) boolean)) - (fixnump (function (t) boolean)) - (float (function (number) float)) - (float-time (function (&optional (or number list)) float)) - (floatp (function (t) boolean)) - (floor (function (number &optional number) integer)) - (following-char (function () fixnum)) - (format (function (string &rest t) string)) - (format-time-string (function (string &optional (or number list) - (or symbol string cons integer)) - string)) - (frame-first-window (function ((or frame window)) window)) - (frame-root-window (function (&optional (or frame window)) window)) - (frame-selected-window (function (&optional (or frame window)) window)) - (frame-visible-p (function (frame) boolean)) - (framep (function (t) boolean)) - (fround (function (float) float)) - (ftruncate (function (float) float)) - (get (function (symbol symbol) t)) - (get-buffer (function ((or buffer string)) (or buffer null))) - (get-buffer-window (function (&optional (or buffer string) (or symbol (integer 0 0))) (or null window))) - (get-file-buffer (function (string) (or null buffer))) - (get-largest-window (function (&optional t t t) (or window null))) - (get-lru-window (function (&optional t t t) (or window null))) - (getenv (function (string &optional frame) (or null string))) - (gethash (function (t hash-table &optional t) t)) - (hash-table-count (function (hash-table) integer)) - (hash-table-p (function (t) boolean)) - (identity (function (t) t)) - (ignore (function (&rest t) null)) - (int-to-string (function (number) string)) - (integer-or-marker-p (function (t) boolean)) - (integerp (function (t) boolean)) - (interactive-p (function () boolean)) - (intern-soft (function ((or string symbol) &optional vector) symbol)) - (invocation-directory (function () string)) - (invocation-name (function () string)) - (isnan (function (float) boolean)) - (keymap-parent (function (cons) (or cons null))) - (keymapp (function (t) boolean)) - (keywordp (function (t) boolean)) - (last (function (list &optional integer) list)) - (lax-plist-get (function (list t) t)) - (ldexp (function (number integer) float)) - (length (function (t) (integer 0 *))) - (length< (function (sequence fixnum) boolean)) - (length= (function (sequence fixnum) boolean)) - (length> (function (sequence fixnum) boolean)) - (line-beginning-position (function (&optional integer) integer)) - (line-end-position (function (&optional integer) integer)) - (list (function (&rest t) list)) - (listp (function (t) boolean)) - (local-variable-if-set-p (function (symbol &optional buffer) boolean)) - (local-variable-p (function (symbol &optional buffer) boolean)) - (locale-info (function ((member codeset days months paper)) (or null string))) - (log (function (number number) float)) - (log10 (function (number) float)) - (logand (function (&rest (or integer marker)) integer)) - (logb (function (number) integer)) - (logcount (function (integer) integer)) - (logior (function (&rest (or integer marker)) integer)) - (lognot (function (integer) integer)) - (logxor (function (&rest (or integer marker)) integer)) - ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ? - (lsh (function (integer integer) integer)) - (make-byte-code (function ((or fixnum list) string vector integer &optional string t &rest t) vector)) - (make-list (function (integer t) list)) - (make-marker (function () marker)) - (make-string (function (integer fixnum &optional t) string)) - (make-symbol (function (string) symbol)) - (mark (function (&optional t) (or integer null))) - (mark-marker (function () marker)) - (marker-buffer (function (marker) (or buffer null))) - (markerp (function (t) boolean)) - (max (function ((or number marker) &rest (or number marker)) number)) - (max-char (function (&optional t) fixnum)) - (member (function (t list) list)) - (memory-limit (function () integer)) - (memq (function (t list) list)) - (memql (function (t list) list)) - (min (function ((or number marker) &rest (or number marker)) number)) - (minibuffer-selected-window (function () (or window null))) - (minibuffer-window (function (&optional frame) window)) - (mod (function ((or number marker) (or number marker)) (or (integer 0 *) (float 0 *)))) - (mouse-movement-p (function (t) boolean)) - (multibyte-char-to-unibyte (function (fixnum) fixnum)) - (natnump (function (t) boolean)) - (next-window (function (&optional window t t) window)) - (nlistp (function (t) boolean)) - (not (function (t) boolean)) - (nth (function (integer list) t)) - (nthcdr (function (integer t) t)) - (null (function (t) boolean)) - (number-or-marker-p (function (t) boolean)) - (number-to-string (function (number) string)) - (numberp (function (t) boolean)) - (one-window-p (function (&optional t t) boolean)) - (overlayp (function (t) boolean)) - (parse-colon-path (function (string) cons)) - (plist-get (function (list t &optional t) t)) - (plist-member (function (list t &optional t) list)) - (point (function () integer)) - (point-marker (function () marker)) - (point-max (function () integer)) - (point-min (function () integer)) - (preceding-char (function () fixnum)) - (previous-window (function (&optional window t t) window)) - (prin1-to-string (function (t &optional t t) string)) - (processp (function (t) boolean)) - (proper-list-p (function (t) boolean)) - (propertize (function (string &rest t) string)) - (radians-to-degrees (function (number) float)) - (rassoc (function (t list) list)) - (rassq (function (t list) list)) - (read-from-string (function (string &optional integer integer) cons)) - (recent-keys (function (&optional (or cons null)) vector)) - (recursion-depth (function () integer)) - (regexp-opt (function (list) string)) - (regexp-quote (function (string) string)) - (region-beginning (function () integer)) - (region-end (function () integer)) - (reverse (function (sequence) sequence)) - (round (function (number &optional number) integer)) - (safe-length (function (t) integer)) - (selected-frame (function () frame)) - (selected-window (function () window)) - (sequencep (function (t) boolean)) - (sin (function (number) float)) - (sqrt (function (number) float)) - (standard-case-table (function () char-table)) - (standard-syntax-table (function () char-table)) - (string (function (&rest fixnum) string)) - (string-as-multibyte (function (string) string)) - (string-as-unibyte (function (string) string)) - (string-equal (function ((or string symbol) (or string symbol)) boolean)) - (string-lessp (function ((or string symbol) (or string symbol)) boolean)) - (string-make-multibyte (function (string) string)) - (string-make-unibyte (function (string) string)) - (string-search (function (string string &optional integer) (or integer null))) - (string-to-char (function (string) fixnum)) - (string-to-multibyte (function (string) string)) - (string-to-number (function (string &optional integer) number)) - (string-to-syntax (function (string) (or cons null))) - (string< (function ((or string symbol) (or string symbol)) boolean)) - (string= (function ((or string symbol) (or string symbol)) boolean)) - (stringp (function (t) boolean)) - (subrp (function (t) boolean)) - (substring (function ((or string vector) &optional integer integer) (or string vector))) - (sxhash (function (t) integer)) - (sxhash-eq (function (t) integer)) - (sxhash-eql (function (t) integer)) - (sxhash-equal (function (t) integer)) - (symbol-function (function (symbol) t)) - (symbol-name (function (symbol) string)) - (symbol-plist (function (symbol) list)) - (symbol-value (function (symbol) t)) - (symbolp (function (t) boolean)) - (syntax-table (function () char-table)) - (syntax-table-p (function (t) boolean)) - (tan (function (number) float)) - (this-command-keys (function () string)) - (this-command-keys-vector (function () vector)) - (this-single-command-keys (function () vector)) - (this-single-command-raw-keys (function () vector)) - (time-convert (function ((or number list) &optional (or symbol integer)) - (or cons number))) - (truncate (function (number &optional number) integer)) - (type-of (function (t) symbol)) - (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum - (upcase (function ((or fixnum string)) (or fixnum string))) - (user-full-name (function (&optional integer) (or string null))) - (user-login-name (function (&optional integer) (or string null))) - (user-original-login-name (function (&optional integer) (or string null))) - (user-real-login-name (function () string)) - (user-real-uid (function () integer)) - (user-uid (function () integer)) - (vconcat (function (&rest sequence) vector)) - (vector (function (&rest t) vector)) - (vectorp (function (t) boolean)) - (visible-frame-list (function () list)) - (wholenump (function (t) boolean)) - (window-configuration-p (function (t) boolean)) - (window-live-p (function (t) boolean)) - (window-valid-p (function (t) boolean)) - (windowp (function (t) boolean)) - (zerop (function (number) boolean)) - ;; Type hints - (comp-hint-fixnum (function (t) fixnum)) - (comp-hint-cons (function (t) cons)) - ;; Non returning functions - (throw (function (t t) nil)) - (error (function (string &rest t) nil)) - (signal (function (symbol t) nil))) - "Alist used for type propagation.") - (defconst comp-known-func-cstr-h (cl-loop with comp-ctxt = (make-comp-cstr-ctxt) @@ -638,13 +224,16 @@ Useful to hook into pass checkers.") finally return h) "Hash table function -> `comp-constraint'.") -(defun comp-known-predicate-p (predicate) +(defun comp--known-predicate-p (predicate) "Return t if PREDICATE is known." - (when (gethash predicate comp-known-predicates-h) t)) + (when (or (gethash predicate comp-known-predicates-h) + (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))) + t)) -(defun comp-pred-to-cstr (predicate) +(defun comp--pred-to-cstr (predicate) "Given PREDICATE, return the corresponding constraint." - (gethash predicate comp-known-predicates-h)) + (or (gethash predicate comp-known-predicates-h) + (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))) (defconst comp-symbol-values-optimizable '(most-positive-fixnum most-negative-fixnum) @@ -654,33 +243,6 @@ Useful to hook into pass checkers.") comp-hint-cons) "List of fake functions used to give compiler hints.") -(defconst comp-limple-sets '(set - setimm - set-par-to-local - set-args-to-local - set-rest-args-to-local) - "Limple set operators.") - -(defconst comp-limple-assignments `(assume - fetch-handler - ,@comp-limple-sets) - "Limple operators that clobber the first m-var argument.") - -(defconst comp-limple-calls '(call - callref - direct-call - direct-callref) - "Limple operators used to call subrs.") - -(defconst comp-limple-branches '(jump cond-jump) - "Limple operators used for conditional and unconditional branches.") - -(defconst comp-limple-ops `(,@comp-limple-calls - ,@comp-limple-assignments - ,@comp-limple-branches - return) - "All Limple operators.") - (defvar comp-func nil "Bound to the current function by most passes.") @@ -698,30 +260,6 @@ Useful to hook into pass checkers.") (defvar comp-no-spawn nil "Non-nil don't spawn native compilation processes.") -(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.") - -;; Moved early to avoid circularity when comp.el is loaded and -;; `macroexpand' needs to be advised (bug#47049). -;;;###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)) - (unless (or (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 (symbol-function subr-name))) - (when-let ((trampoline (or (comp-trampoline-search subr-name) - (comp-trampoline-compile subr-name)))) - (comp--install-trampoline subr-name trampoline)))) - (cl-defstruct (comp-vec (:copier nil)) "A re-sizable vector like object." @@ -892,7 +430,7 @@ non local exit (ends with an `unreachable' insn).")) (:include comp-block)) "A basic block holding only constraints.") -(cl-defstruct (comp-edge (:copier nil) (:constructor make--comp-edge)) +(cl-defstruct (comp-edge (:copier nil) (:constructor comp--edge-make0)) "An edge connecting two basic blocks." (src nil :type (or null comp-block)) (dst nil :type (or null comp-block)) @@ -900,19 +438,19 @@ non local exit (ends with an `unreachable' insn).")) :documentation "The index number corresponding to this edge in the edge hash.")) -(defun make-comp-edge (&rest args) +(defun comp--edge-make (&rest args) "Create a `comp-edge' with basic blocks SRC and DST." (let ((n (funcall (comp-func-edge-cnt-gen comp-func)))) (puthash n - (apply #'make--comp-edge :number n args) + (apply #'comp--edge-make0 :number n args) (comp-func-edges-h comp-func)))) -(defun comp-block-preds (basic-block) +(defun comp--block-preds (basic-block) "Return the list of predecessors of BASIC-BLOCK." (mapcar #'comp-edge-src (comp-block-in-edges basic-block))) -(defun comp-gen-counter () +(defun comp--gen-counter () "Return a sequential number generator." (let ((n -1)) (lambda () @@ -946,9 +484,9 @@ CFG is mutated by a pass.") :documentation "LAP label -> LIMPLE basic block name.") (edges-h (make-hash-table) :type hash-table :documentation "Hash edge-num -> edge connecting basic two blocks.") - (block-cnt-gen (funcall #'comp-gen-counter) :type function + (block-cnt-gen (funcall #'comp--gen-counter) :type function :documentation "Generates block numbers.") - (edge-cnt-gen (funcall #'comp-gen-counter) :type function + (edge-cnt-gen (funcall #'comp--gen-counter) :type function :documentation "Generates edges numbers.") (has-non-local nil :type boolean :documentation "t if non local jumps are present.") @@ -987,49 +525,39 @@ 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) +(defun comp--equality-fun-p (function) "Equality functions predicate for FUNCTION." (when (memq function '(eq eql equal)) t)) -(defun comp-arithm-cmp-fun-p (function) +(defun comp--arithm-cmp-fun-p (function) "Predicate for arithmetic comparison functions." (when (memq function '(= > < >= <=)) t)) -(defun comp-set-op-p (op) +(defun comp--set-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-sets) t)) -(defun comp-assign-op-p (op) +(defun comp--assign-op-p (op) "Assignment predicate for OP." (when (memq op comp-limple-assignments) t)) -(defun comp-call-op-p (op) +(defun comp--call-op-p (op) "Call predicate for OP." (when (memq op comp-limple-calls) t)) -(defun comp-branch-op-p (op) +(defun comp--branch-op-p (op) "Branch predicate for OP." (when (memq op comp-limple-branches) t)) -(defsubst comp-limple-insn-call-p (insn) +(defsubst comp--limple-insn-call-p (insn) "Limple INSN call predicate." - (comp-call-op-p (car-safe insn))) + (comp--call-op-p (car-safe insn))) -(defun comp-type-hint-p (func) +(defun comp--type-hint-p (func) "Type-hint predicate for function name FUNC." (when (memq func comp-type-hints) t)) -(defun comp-func-unique-in-cu-p (func) +(defun comp--func-unique-in-cu-p (func) "Return t if FUNC is known to be unique in the current compilation unit." (if (symbolp func) (cl-loop with h = (make-hash-table :test #'eq) @@ -1041,110 +569,46 @@ To be used by all entry points." finally return t) t)) -(defsubst comp-symbol-func-to-fun (symbol-funcion) +(defsubst comp--symbol-func-to-fun (symbol-funcion) "Given a function called SYMBOL-FUNCION return its `comp-func'." (gethash (gethash symbol-funcion (comp-ctxt-sym-to-c-name-h comp-ctxt)) (comp-ctxt-funcs-h comp-ctxt))) -(defun comp-function-pure-p (f) +(defun comp--function-pure-p (f) "Return t if F is pure." (or (get f 'pure) - (when-let ((func (comp-symbol-func-to-fun f))) + (when-let ((func (comp--symbol-func-to-fun f))) (comp-func-pure func)))) -(defun comp-alloc-class-to-container (alloc-class) +(defun comp--alloc-class-to-container (alloc-class) "Given ALLOC-CLASS, return the data container for the current context. Assume allocation class `d-default' as default." (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) -(defsubst comp-add-const-to-relocs (obj) +(defsubst comp--add-const-to-relocs (obj) "Keep track of OBJ into the ctxt relocations." - (puthash obj t (comp-data-container-idx (comp-alloc-class-to-container + (puthash obj t (comp-data-container-idx (comp--alloc-class-to-container comp-curr-allocation-class)))) ;;; Log routines. -(defconst comp-limple-lock-keywords - `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face) - (,(rx "#(" (group-n 1 "mvar")) - (1 font-lock-function-name-face)) - (,(rx bol "(" (group-n 1 "phi")) - (1 font-lock-variable-name-face)) - (,(rx bol "(" (group-n 1 (or "return" "unreachable"))) - (1 font-lock-warning-face)) - (,(rx (group-n 1 (or "entry" - (seq (or "entry_" "entry_fallback_" "bb_") - (1+ num) (? (or "_latch" - (seq "_cstrs_" (1+ num)))))))) - (1 font-lock-constant-face)) - (,(rx-to-string - `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops))))) - (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) - (setf buffer-read-only t) - (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) +(defun comp--prettyformat-mvar (mvar) (format "#(mvar %s %s %S)" (comp-mvar-id mvar) (comp-mvar-slot mvar) (comp-cstr-to-type-spec mvar))) -(defun comp-prettyformat-insn (insn) +(defun comp--prettyformat-insn (insn) (cond ((comp-mvar-p insn) - (comp-prettyformat-mvar insn)) + (comp--prettyformat-mvar insn)) ((proper-list-p insn) - (concat "(" (mapconcat #'comp-prettyformat-insn insn " ") ")")) + (concat "(" (mapconcat #'comp--prettyformat-insn insn " ") ")")) (t (prin1-to-string insn)))) -(defun comp-log-func (func verbosity) +(defun comp--log-func (func verbosity) "Log function FUNC at VERBOSITY. VERBOSITY is a number between 0 and 3." (when (>= native-comp-verbose verbosity) @@ -1155,9 +619,9 @@ VERBOSITY is a number between 0 and 3." do (comp-log (concat "<" (symbol-name block-name) ">") verbosity) (cl-loop for insn in (comp-block-insns bb) - do (comp-log (comp-prettyformat-insn insn) verbosity))))) + do (comp-log (comp--prettyformat-insn insn) verbosity))))) -(defun comp-log-edges (func) +(defun comp--log-edges (func) "Log edges in FUNC." (let ((edges (comp-func-edges-h func))) (comp-log (format "\nEdges in function: %s\n" @@ -1241,7 +705,7 @@ clashes." (defun comp-decrypt-arg-list (x function-name) "Decrypt argument list X for FUNCTION-NAME." (unless (fixnump x) - (signal 'native-compiler-error-dyn-func function-name)) + (signal 'native-compiler-error-dyn-func (list function-name))) (let ((rest (not (= (logand x 128) 0))) (mandatory (logand x 127)) (nonrest (ash x -8))) @@ -1274,75 +738,32 @@ clashes." (make-temp-file (comp-c-func-name function-name "freefn-") nil ".eln"))) (let* ((f (symbol-function function-name)) - (c-name (comp-c-func-name function-name "F")) - (func (make-comp-func-l :name function-name - :c-name c-name - :doc (documentation f t) - :int-spec (interactive-form f) - :command-modes (command-modes f) - :speed (comp-spill-speed function-name) - :pure (comp-spill-decl-spec function-name - 'pure)))) + (byte-code (byte-compile function-name)) + (c-name (comp-c-func-name function-name "F"))) (when (byte-code-function-p f) (signal 'native-compiler-error - "can't native compile an already byte-compiled function")) - (setf (comp-func-byte-func func) - (byte-compile (comp-func-name func))) - (let ((lap (byte-to-native-lambda-lap - (gethash (aref (comp-func-byte-func func) 1) - byte-to-native-lambdas-h)))) - (cl-assert lap) - (comp-log lap 2 t) - (let ((arg-list (aref (comp-func-byte-func func) 0))) - (setf (comp-func-l-args func) - (comp-decrypt-arg-list arg-list function-name) - (comp-func-lap func) - lap - (comp-func-frame-size func) - (comp-byte-frame-size (comp-func-byte-func func)))) + '("can't native compile an already byte-compiled function"))) (setf (comp-ctxt-top-level-forms comp-ctxt) (list (make-byte-to-native-func-def :name function-name - :c-name c-name))) - (comp-add-func-to-ctxt func)))) + :c-name c-name + :byte-func byte-code))) + (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))) (cl-defmethod comp-spill-lap-function ((form list)) "Byte-compile FORM, spilling data from the byte compiler." - (unless (eq (car-safe form) 'lambda) + (unless (memq (car-safe form) '(lambda closure)) (signal 'native-compiler-error - "Cannot native-compile, form is not a lambda")) + '("Cannot native-compile, form is not a lambda or closure"))) (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) (make-temp-file "comp-lambda-" nil ".eln"))) (let* ((byte-code (byte-compile form)) - (c-name (comp-c-func-name "anonymous-lambda" "F")) - (func (if (comp-lex-byte-func-p byte-code) - (make-comp-func-l :c-name c-name - :doc (documentation form t) - :int-spec (interactive-form form) - :command-modes (command-modes form) - :speed (comp-ctxt-speed comp-ctxt)) - (make-comp-func-d :c-name c-name - :doc (documentation form t) - :int-spec (interactive-form form) - :command-modes (command-modes form) - :speed (comp-ctxt-speed comp-ctxt))))) - (let ((lap (byte-to-native-lambda-lap - (gethash (aref byte-code 1) - byte-to-native-lambdas-h)))) - (cl-assert lap) - (comp-log lap 2 t) - (if (comp-func-l-p func) - (setf (comp-func-l-args func) - (comp-decrypt-arg-list (aref byte-code 0) byte-code)) - (setf (comp-func-d-lambda-list func) (cadr form))) - (setf (comp-func-lap func) lap - (comp-func-frame-size func) (comp-byte-frame-size - byte-code)) - (setf (comp-func-byte-func func) byte-code - (comp-ctxt-top-level-forms comp-ctxt) + (c-name (comp-c-func-name "anonymous-lambda" "F"))) + (setf (comp-ctxt-top-level-forms comp-ctxt) (list (make-byte-to-native-func-def :name '--anonymous-lambda - :c-name c-name))) - (comp-add-func-to-ctxt func)))) + :c-name c-name + :byte-func byte-code))) + (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))) (defun comp-intern-func-in-ctxt (_ obj) "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'." @@ -1390,7 +811,7 @@ clashes." (alist-get 'no-native-compile byte-native-qualities)) (throw 'no-native-compile nil)) (unless byte-to-native-top-level-forms - (signal 'native-compiler-error-empty-byte filename)) + (signal 'native-compiler-error-empty-byte (list filename))) (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) (comp-el-to-eln-filename filename native-compile-target-directory))) @@ -1424,11 +845,13 @@ clashes." "Byte-compile and spill the LAP representation for INPUT. If INPUT is a symbol, it is the function-name to be compiled. If INPUT is a string, it is the filename to be compiled." - (let ((byte-native-compiling t) - (byte-to-native-lambdas-h (make-hash-table :test #'eq)) - (byte-to-native-top-level-forms ()) - (byte-to-native-plist-environment ())) - (comp-spill-lap-function input))) + (let* ((byte-native-compiling t) + (byte-to-native-lambdas-h (make-hash-table :test #'eq)) + (byte-to-native-top-level-forms ()) + (byte-to-native-plist-environment ()) + (res (comp-spill-lap-function input))) + (comp-cstr-ctxt-update-type-slots comp-ctxt) + res)) ;;; Limplification pass specific code. @@ -1536,14 +959,16 @@ STACK-OFF is the index of the first slot frame involved." for sp from stack-off collect (comp-slot-n sp)))) -(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type) +(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type neg) "`comp-mvar' initializer." (let ((mvar (make--comp-mvar :slot slot))) (when const-vld - (comp-add-const-to-relocs constant) + (comp--add-const-to-relocs constant) (setf (comp-cstr-imm mvar) constant)) (when type (setf (comp-mvar-typeset mvar) (list type))) + (when neg + (setf (comp-mvar-neg mvar) t)) mvar)) (defun comp-new-frame (size vsize &optional ssa) @@ -1583,7 +1008,7 @@ If DST-N is specified, use it; otherwise assume it to be the current slot." (defsubst comp-emit-setimm (val) "Set constant VAL to current slot." - (comp-add-const-to-relocs val) + (comp--add-const-to-relocs val) ;; Leave relocation index nil on purpose, will be fixed-up in final ;; by `comp-finalize-relocs'. (comp-emit `(setimm ,(comp-slot) ,val))) @@ -1708,14 +1133,15 @@ Return value is the fall-through block name." (defun comp-jump-table-optimizable (jmp-table) "Return t if JMP-TABLE can be optimized out." - (cl-loop - with labels = (cl-loop for target-label being each hash-value of jmp-table - collect target-label) - with x = (car labels) - for l in (cdr-safe labels) - unless (= l x) - return nil - finally return t)) + ;; Identify LAP sequences like: + ;; (byte-constant #s(hash-table size 3 test eq rehash-size 1.5 rehash-threshold 0.8125 purecopy t data (created 126 deleted 126 changed 126)) . 24) + ;; (byte-switch) + ;; (TAG 126 . 10) + (let ((targets (hash-table-values jmp-table))) + (when (apply #'= targets) + (pcase (nth (1+ (comp-limplify-pc comp-pass)) (comp-func-lap comp-func)) + (`(TAG ,target . ,_label-sp) + (= target (car targets))))))) (defun comp-emit-switch (var last-insn) "Emit a Limple for a lap jump table given VAR and LAST-INSN." @@ -1758,7 +1184,7 @@ Return value is the fall-through block name." do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) (setf (comp-limplify-curr-block comp-pass) ff-bb)))) (_ (signal 'native-ice - "missing previous setimm while creating a switch")))) + '("missing previous setimm while creating a switch"))))) (defun comp--func-arity (subr-name) "Like `func-arity' but invariant against primitive redefinitions. @@ -1790,7 +1216,7 @@ SP-DELTA is the stack adjustment." (eval-when-compile (defun comp-op-to-fun (x) "Given the LAP op strip \"byte-\" to have the subr name." - (intern (replace-regexp-in-string "byte-" "" x))) + (intern (string-replace "byte-" "" x))) (defun comp-body-eff (body op-name sp-delta) "Given the original BODY, compute the effective one. @@ -2070,7 +1496,7 @@ and the annotation emission." (cl-loop for bb being the hash-value in (comp-func-blocks func) do (setf (comp-block-insns bb) (nreverse (comp-block-insns bb)))) - (comp-log-func func 2) + (comp--log-func func 2) func) (cl-defgeneric comp-prepare-args-for-top-level (function) @@ -2144,7 +1570,7 @@ and the annotation emission." These are stored in the reloc data array." (let ((args (comp-prepare-args-for-top-level func))) (let ((comp-curr-allocation-class 'd-impure)) - (comp-add-const-to-relocs (comp-func-byte-func func))) + (comp--add-const-to-relocs (comp-func-byte-func func))) (comp-emit (comp-call 'comp--register-lambda ;; mvar to be fixed-up when containers are @@ -2347,7 +1773,7 @@ into the C code forwarding the compilation unit." do (cl-loop for insn in (comp-block-insns b) for (op . args) = insn - if (comp-assign-op-p op) + if (comp--assign-op-p op) do (comp-collect-mvars (cdr args)) else do (comp-collect-mvars args)))) @@ -2396,7 +1822,7 @@ The assume is emitted at the beginning of the block BB." (comp-cstr-negation-make rhs) rhs))) (comp-block-insns bb)))) - ((pred comp-arithm-cmp-fun-p) + ((pred comp--arithm-cmp-fun-p) (when-let ((kind (if negated (comp-negate-arithm-cmp-fun kind) kind))) @@ -2429,7 +1855,7 @@ Return OP otherwise." (cl-loop with new-bb = (make-comp-block-cstr :name bb-symbol :insns `((jump ,(comp-block-name bb-b)))) - with new-edge = (make-comp-edge :src bb-a :dst new-bb) + with new-edge = (comp--edge-make :src bb-a :dst new-bb) for ed in (comp-block-in-edges bb-b) when (eq (comp-edge-src ed) bb-a) do @@ -2460,7 +1886,7 @@ Keep on searching till EXIT-INSN is encountered." when (eq insn exit-insn) do (cl-return (and (comp-mvar-p res) res)) do (pcase insn - (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs) + (`(,(pred comp--assign-op-p) ,(pred targetp) ,rhs) (setf res rhs))) finally (cl-assert nil)))) @@ -2532,10 +1958,27 @@ TARGET-BB-SYM is the symbol name of the target block." for insns-seq on (comp-block-insns b) do (pcase insns-seq + (`((set ,(and (pred comp-mvar-p) mvar-tested-copy) + ,(and (pred comp-mvar-p) mvar-tested)) + (set ,(and (pred comp-mvar-p) mvar-1) + (call type-of ,(and (pred comp-mvar-p) mvar-tested-copy))) + (set ,(and (pred comp-mvar-p) mvar-2) + (call symbol-value ,(and (pred comp-cstr-cl-tag-p) mvar-tag))) + (set ,(and (pred comp-mvar-p) mvar-3) + (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2))) + (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2)) + (comp-emit-assume 'and mvar-tested + (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)) + (comp-add-cond-cstrs-target-block b bb2) + nil) + (comp-emit-assume 'and mvar-tested + (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)) + (comp-add-cond-cstrs-target-block b bb1) + t)) (`((set ,(and (pred comp-mvar-p) cmp-res) - (,(pred comp-call-op-p) - ,(and (or (pred comp-equality-fun-p) - (pred comp-arithm-cmp-fun-p)) + (,(pred comp--call-op-p) + ,(and (or (pred comp--equality-fun-p) + (pred comp--arithm-cmp-fun-p)) fun) ,op1 ,op2)) ;; (comment ,_comment-str) @@ -2567,14 +2010,14 @@ TARGET-BB-SYM is the symbol name of the target block." block-target negated))) finally (cl-return-from in-the-basic-block))) (`((set ,(and (pred comp-mvar-p) cmp-res) - (,(pred comp-call-op-p) - ,(and (pred comp-known-predicate-p) fun) + (,(pred comp--call-op-p) + ,(and (pred comp--known-predicate-p) fun) ,op)) ;; (comment ,_comment-str) (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) (cl-loop with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) - with cstr = (comp-pred-to-cstr fun) + with cstr = (comp--pred-to-cstr fun) for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(t nil) @@ -2586,14 +2029,14 @@ TARGET-BB-SYM is the symbol name of the target block." finally (cl-return-from in-the-basic-block))) ;; Match predicate on the negated branch (unless). (`((set ,(and (pred comp-mvar-p) cmp-res) - (,(pred comp-call-op-p) - ,(and (pred comp-known-predicate-p) fun) + (,(pred comp--call-op-p) + ,(and (pred comp--known-predicate-p) fun) ,op)) (set ,neg-cmp-res (call eq ,cmp-res ,(pred comp-cstr-null-p))) (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks)) (cl-loop with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b) - with cstr = (comp-pred-to-cstr fun) + with cstr = (comp--pred-to-cstr fun) for branch-target-cell on blocks for branch-target = (car branch-target-cell) for negated in '(nil t) @@ -2645,10 +2088,10 @@ TARGET-BB-SYM is the symbol name of the target block." (comp-loop-insn-in-block bb (when-let ((match (pcase insn - (`(set ,lhs (,(pred comp-call-op-p) ,f . ,args)) + (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) (cl-values f cstr-f lhs args))) - (`(,(pred comp-call-op-p) ,f . ,args) + (`(,(pred comp--call-op-p) ,f . ,args) (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) (cl-values f cstr-f nil args)))))) (cl-multiple-value-bind (f cstr-f lhs args) match @@ -2687,7 +2130,7 @@ blocks." (comp-add-cond-cstrs-simple) (comp-add-cond-cstrs) (comp-add-call-cstr) - (comp-log-func comp-func 3)))) + (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -2706,9 +2149,9 @@ blocks." do (cl-loop for insn in (comp-block-insns b) do (pcase insn - (`(set ,_lval (,(pred comp-call-op-p) ,f . ,_rest)) + (`(set ,_lval (,(pred comp--call-op-p) ,f . ,_rest)) (puthash f t h)) - (`(,(pred comp-call-op-p) ,f . ,_rest) + (`(,(pred comp--call-op-p) ,f . ,_rest) (puthash f t h)))) finally return (cl-loop for f being each hash-key of h @@ -2721,7 +2164,7 @@ blocks." (defun comp-pure-infer-func (f) "If all functions called by F are pure then F is pure too." (when (and (cl-every (lambda (x) - (or (comp-function-pure-p x) + (or (comp--function-pure-p x) (eq x (comp-func-name f)))) (comp-collect-calls f)) (not (eq (comp-func-pure f) t))) @@ -2785,16 +2228,16 @@ blocks." for (op first second third forth) = last-insn do (cl-case op (jump - (make-comp-edge :src bb :dst (gethash first blocks))) + (comp--edge-make :src bb :dst (gethash first blocks))) (cond-jump - (make-comp-edge :src bb :dst (gethash third blocks)) - (make-comp-edge :src bb :dst (gethash forth blocks))) + (comp--edge-make :src bb :dst (gethash third blocks)) + (comp--edge-make :src bb :dst (gethash forth blocks))) (cond-jump-narg-leq - (make-comp-edge :src bb :dst (gethash second blocks)) - (make-comp-edge :src bb :dst (gethash third blocks))) + (comp--edge-make :src bb :dst (gethash second blocks)) + (comp--edge-make :src bb :dst (gethash third blocks))) (push-handler - (make-comp-edge :src bb :dst (gethash third blocks)) - (make-comp-edge :src bb :dst (gethash forth blocks))) + (comp--edge-make :src bb :dst (gethash third blocks)) + (comp--edge-make :src bb :dst (gethash forth blocks))) (return) (unreachable) (otherwise @@ -2811,7 +2254,7 @@ blocks." (comp-block-out-edges (comp-edge-src edge))) (push edge (comp-block-in-edges (comp-edge-dst edge)))) - (comp-log-edges comp-func))) + (comp--log-edges comp-func))) (defun comp-collect-rev-post-order (basic-block) "Walk BASIC-BLOCK children and return their name in reversed post-order." @@ -2844,9 +2287,9 @@ blocks." finger2 (comp-block-post-num b2)))) b1)) (first-processed (l) - (if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) l))) + (if-let ((p (cl-find-if #'comp-block-idom l))) p - (signal 'native-ice "can't find first preprocessed")))) + (signal 'native-ice '("can't find first preprocessed"))))) (when-let ((blocks (comp-func-blocks comp-func)) (entry (gethash 'entry blocks)) @@ -2867,7 +2310,7 @@ blocks." do (cl-loop for name in (cdr rev-bb-list) for b = (gethash name blocks) - for preds = (comp-block-preds b) + for preds = (comp--block-preds b) for new-idom = (first-processed preds) initially (setf changed nil) do (cl-loop for p in (delq new-idom preds) @@ -2887,7 +2330,7 @@ blocks." (cl-loop with blocks = (comp-func-blocks comp-func) for b-name being each hash-keys of blocks using (hash-value b) - for preds = (comp-block-preds b) + for preds = (comp--block-preds b) when (length> preds 1) ; All joins do (cl-loop for p in preds for runner = p @@ -2919,7 +2362,7 @@ blocks." ;; Return t if a SLOT-N was assigned within BB. (cl-loop for insn in (comp-block-insns bb) for op = (car insn) - when (or (and (comp-assign-op-p op) + when (or (and (comp--assign-op-p op) (eql slot-n (comp-mvar-slot (cadr insn)))) ;; fetch-handler is after a non local ;; therefore clobbers all frame!!! @@ -2985,7 +2428,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (setf (comp-vec-aref frame slot-n) mvar (cadr insn) mvar)))) (pcase insn - (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_) + (`(,(pred comp--assign-op-p) ,(pred targetp) . ,_) (let ((mvar (comp-vec-aref frame slot-n))) (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn)))) (new-lvalue)) @@ -3072,7 +2515,7 @@ Return t when one or more block was removed, nil otherwise." (comp-place-phis) (comp-ssa-rename) (comp-finalize-phis) - (comp-log-func comp-func 3) + (comp--log-func comp-func 3) (setf (comp-func-ssa-status f) t)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -3135,7 +2578,7 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or (defun comp-function-foldable-p (f args) "Given function F called with ARGS, return non-nil when optimizable." - (and (comp-function-pure-p f) + (and (comp--function-pure-p f) (cl-every #'comp-cstr-imm-vld-p args))) (defun comp-function-call-maybe-fold (insn f args) @@ -3143,7 +2586,7 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or Return non-nil if the function is folded successfully." (cl-flet ((rewrite-insn-as-setimm (insn value) ;; See `comp-emit-setimm'. - (comp-add-const-to-relocs value) + (comp--add-const-to-relocs value) (setf (car insn) 'setimm (cddr insn) `(,value)))) (cond @@ -3160,7 +2603,7 @@ Return non-nil if the function is folded successfully." ;; should do basic block pruning in order to be sure that this ;; is not dead-code. This is now left to gcc, to be ;; implemented only if we want a reliable diagnostic here. - (let* ((f (if-let (f-in-ctxt (comp-symbol-func-to-fun f)) + (let* ((f (if-let (f-in-ctxt (comp--symbol-func-to-fun f)) ;; If the function is IN the compilation ctxt ;; and know to be pure. (comp-func-byte-func f-in-ctxt) @@ -3187,7 +2630,11 @@ Fold the call in case." (+ (comp-cstr-add lval args)) (- (comp-cstr-sub lval args)) (1+ (comp-cstr-add lval `(,(car args) ,comp-cstr-one))) - (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one)))))) + (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one))) + (record (when (comp-cstr-imm-vld-p (car args)) + (comp-cstr-shallow-copy lval + (comp-type-spec-to-cstr + (comp-cstr-imm (car args))))))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." @@ -3202,6 +2649,8 @@ Fold the call in case." (_ (comp-cstr-shallow-copy lval rval)))) (`(assume ,lval ,(and (pred comp-mvar-p) rval)) + ;; NOTE we should probably assert this case in the future when + ;; will be possible. (comp-cstr-shallow-copy lval rval)) (`(assume ,lval (,kind . ,operands)) (cl-case kind @@ -3233,7 +2682,7 @@ Fold the call in case." (comp-func-blocks comp-func)))) (or (comp-latch-p bb) (when (comp-block-cstr-p bb) - (comp-latch-p (car (comp-block-preds bb))))))) + (comp-latch-p (car (comp--block-preds bb))))))) rest)) (prop-fn (if from-latch #'comp-cstr-union-no-range @@ -3300,7 +2749,7 @@ Return t if something was changed." (format "fwprop pass jammed into %s?" (comp-func-name f)))) (comp-log (format "Propagation run %d times\n" i) 2)) (comp-rewrite-non-locals) - (comp-log-func comp-func 3)))) + (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -3323,7 +2772,7 @@ Return t if something was changed." "Given FUNC return the `comp-fun' definition in the current context. FUNCTION can be a function-name or byte compiled function." (if (symbolp func) - (comp-symbol-func-to-fun func) + (comp--symbol-func-to-fun func) (cl-assert (byte-code-function-p func)) (gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt)))) @@ -3340,6 +2789,14 @@ FUNCTION can be a function-name or byte compiled function." (symbol-function callee) (cl-assert (byte-code-function-p callee)) callee)) + ;; Below call to `subrp' returns nil on an advised + ;; primitive F, so that we do not optimize calls to F + ;; with the funcall trampoline removal below. But if F + ;; is advised while we compile its call, it is very + ;; likely to be advised also when that call is executed. + ;; And in that case an "unoptimized" call to F is + ;; actually cheaper since it avoids the call to the + ;; intermediate native trampoline (bug#67005). (subrp (subrp f)) (comp-func-callee (comp-func-in-unit callee))) (cond @@ -3361,7 +2818,7 @@ FUNCTION can be a function-name or byte compiled function." ((and comp-func-callee (comp-func-c-name comp-func-callee) (or (and (>= (comp-func-speed comp-func) 3) - (comp-func-unique-in-cu-p callee)) + (comp--func-unique-in-cu-p callee)) (and (>= (comp-func-speed comp-func) 2) ;; Anonymous lambdas can't be redefined so are ;; always safe to optimize. @@ -3373,7 +2830,7 @@ FUNCTION can be a function-name or byte compiled function." args (fill-args args (comp-args-max func-args))))) `(,call-type ,(comp-func-c-name comp-func-callee) ,@args))) - ((comp-type-hint-p callee) + ((comp--type-hint-p callee) `(call ,callee ,@args))))))) (defun comp-call-optim-func () @@ -3430,7 +2887,7 @@ Return the list of m-var ids nuked." do (cl-loop for insn in (comp-block-insns b) for (op arg0 . rest) = insn - if (comp-assign-op-p op) + if (comp--assign-op-p op) do (push (comp-mvar-id arg0) l-vals) (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals)) else @@ -3448,10 +2905,10 @@ Return the list of m-var ids nuked." for b being each hash-value of (comp-func-blocks comp-func) do (comp-loop-insn-in-block b (cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn - (when (and (comp-assign-op-p op) + (when (and (comp--assign-op-p op) (memq (comp-mvar-id arg0) nuke-list)) (setf insn - (if (comp-limple-insn-call-p arg1) + (if (comp--limple-insn-call-p arg1) arg1 `(comment ,(format "optimized out: %s" insn)))))))) @@ -3468,7 +2925,7 @@ Return the list of m-var ids nuked." for i from 1 while (comp-dead-assignments-func) finally (comp-log (format "dead code rm run %d times\n" i) 2) - (comp-log-func comp-func 3)))) + (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -3508,7 +2965,7 @@ Return the list of m-var ids nuked." (not (comp-func-has-non-local f))) (let ((comp-func f)) (comp-tco-func) - (comp-log-func comp-func 3)))) + (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -3524,7 +2981,7 @@ These are substituted with a normal `set' op." for b being each hash-value of (comp-func-blocks comp-func) do (comp-loop-insn-in-block b (pcase insn - (`(set ,l-val (call ,(pred comp-type-hint-p) ,r-val)) + (`(set ,l-val (call ,(pred comp--type-hint-p) ,r-val)) (setf insn `(set ,l-val ,r-val))))))) (defun comp-remove-type-hints (_) @@ -3533,7 +2990,7 @@ These are substituted with a normal `set' op." (when (>= (comp-func-speed f) 2) (let ((comp-func f)) (comp-remove-type-hints-func) - (comp-log-func comp-func 3)))) + (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) @@ -3586,7 +3043,7 @@ Set it into the `type' slot." finally return res))) (type `(function ,(comp-args-to-lambda-list (comp-func-l-args func)) ,(comp-cstr-to-type-spec res-mvar)))) - (comp-add-const-to-relocs type) + (comp--add-const-to-relocs type) ;; Fix it up. (setf (comp-cstr-imm (comp-func-type func)) type)))) @@ -3615,7 +3072,7 @@ Update all insn accordingly." ;; Symbols imported by C inlined functions. We do this here because ;; is better to add all objs to the relocation containers before we ;; compacting them. - (mapc #'comp-add-const-to-relocs '(nil t consp listp symbol-with-pos-p)) + (mapc #'comp--add-const-to-relocs '(nil t consp listp symbol-with-pos-p)) (let* ((d-default (comp-ctxt-d-default comp-ctxt)) (d-default-idx (comp-data-container-idx d-default)) @@ -3670,7 +3127,7 @@ Prepare every function for final compilation and drive the C back-end." (let ((dir (file-name-directory name))) (comp-finalize-relocs) (maphash (lambda (_ f) - (comp-log-func f 1)) + (comp--log-func f 1)) (comp-ctxt-funcs-h comp-ctxt)) (unless (file-exists-p dir) ;; In case it's created in the meanwhile. @@ -3679,13 +3136,10 @@ Prepare every function for final compilation and drive the C back-end." (comp--compile-ctxt-to-file name))) (defun comp-final1 () - (let (compile-result) - (comp--init-ctxt) - (unwind-protect - (setf compile-result - (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt))) - (and (comp--release-ctxt) - compile-result)))) + (comp--init-ctxt) + (unwind-protect + (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt)) + (comp--release-ctxt))) (defvar comp-async-compilation nil "Non-nil while executing an asynchronous native compilation.") @@ -3746,7 +3200,7 @@ Prepare every function for final compilation and drive the C back-end." (progn (delete-file temp-file) output) - (signal 'native-compiler-error (buffer-string))) + (signal 'native-compiler-error (list (buffer-string)))) (comp-log-to-buffer (buffer-string)))))))) @@ -3769,19 +3223,6 @@ Prepare every function for final compilation and drive the C back-end." ;; Primitive function advice machinery -(defun comp-eln-load-path-eff () - "Return a list of effective eln load directories. -Account for `native-comp-eln-load-path' and `comp-native-version-dir'." - (mapcar (lambda (dir) - (expand-file-name comp-native-version-dir - (file-name-as-directory - (expand-file-name dir invocation-directory)))) - native-comp-eln-load-path)) - -(defun comp-trampoline-filename (subr-name) - "Given SUBR-NAME return the filename containing the trampoline." - (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln")) - (defun comp-make-lambda-list-from-subr (subr) "Given SUBR return the equivalent lambda-list." (pcase-let ((`(,min . ,max) (subr-arity subr)) @@ -3797,16 +3238,6 @@ Account for `native-comp-eln-load-path' and `comp-native-version-dir'." (push (gensym "arg") lambda-list)) (reverse lambda-list))) -(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)))) - (defun comp--trampoline-abs-filename (subr-name) "Return the absolute filename for a trampoline for SUBR-NAME." (cl-loop @@ -3832,6 +3263,8 @@ Return the trampoline if found or nil otherwise." (make-temp-file (file-name-sans-extension rel-filename) nil ".eln" nil)))) +;; Called from comp-run.el +;;;###autoload (defun comp-trampoline-compile (subr-name) "Synthesize compile and return a trampoline for SUBR-NAME." (let* ((lambda-list (comp-make-lambda-list-from-subr @@ -3906,174 +3339,9 @@ session." ;; Remove the old eln instead of copying the new one into it ;; to get a new inode and prevent crashes in case the old one ;; is currently loaded. - (t (delete-file oldfile) - (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) - (setf buffer-read-only t) - (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 - (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))) + (t (if newfile + (rename-file newfile oldfile t) + (delete-file oldfile))))) (defun comp--native-compile (function-or-file &optional with-late-load output) "Compile FUNCTION-OR-FILE into native code. @@ -4102,14 +3370,14 @@ the deferred compilation mechanism." (comp-log "\n \n" 1) (unwind-protect (progn - (condition-case err + (condition-case-unless-debug err (cl-loop with report = nil for t0 = (current-time) for pass in comp-passes unless (memq pass comp-disabled-passes) do - (comp-log (format "(%s) Running pass %s:\n" + (comp-log (format "\n(%s) Running pass %s:\n" function-or-file pass) 2) (setf data (funcall pass data)) @@ -4121,7 +3389,8 @@ the deferred compilation mechanism." (comp-log (format "Done compiling %s" data) 0) (cl-loop for (pass . time) in (reverse report) do (comp-log (format "Pass %s took: %fs." - pass time) 0)))) + pass time) + 0)))) (native-compiler-skip) (t (let ((err-val (cdr err))) @@ -4156,100 +3425,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)))) - -(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))) - (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. @@ -4357,29 +3532,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) |