diff options
Diffstat (limited to 'lisp/emacs-lisp/comp.el')
| -rw-r--r-- | lisp/emacs-lisp/comp.el | 227 |
1 files changed, 157 insertions, 70 deletions
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 322df0e86a1..b35e1b97e9d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -186,8 +186,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. @@ -276,10 +277,10 @@ 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: + ;; Functions we can trust not to be redefined, or, if redefined, + ;; to expose the same type. The vast majority of these are + ;; 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)) @@ -306,7 +307,8 @@ Useful to hook into pass checkers.") (bignump (function (t) boolean)) (bobp (function () boolean)) (bolp (function () boolean)) - (bool-vector-count-consecutive (function (bool-vector boolean integer) fixnum)) + (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)) @@ -316,10 +318,12 @@ Useful to hook into pass checkers.") (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-modified-p + (function (&optional buffer) (or boolean (member autosaved)))) (buffer-size (function (&optional buffer) integer)) (buffer-string (function () string)) - (buffer-substring (function ((or integer marker) (or integer marker)) 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))) @@ -339,17 +343,27 @@ Useful to hook into pass checkers.") (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))) + (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)) + (coordinates-in-window-p + (function (cons window) + (or cons null + (member bottom-divider right-divider mode-line header-line + tab-line left-fringe right-fringe vertical-line + left-margin right-margin)))) (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)) + (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)) @@ -362,7 +376,7 @@ Useful to hook into pass checkers.") (current-time-zone (function (&optional (or number list) (or symbol string cons integer)) cons)) - (custom-variable-p (function (symbol) boolean)) + (custom-variable-p (function (symbol) t)) (decode-char (function (cons t) (or fixnum null))) (decode-time (function (&optional (or number list) (or symbol string cons integer) @@ -371,7 +385,8 @@ Useful to hook into pass checkers.") (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))) + (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))) @@ -384,18 +399,18 @@ Useful to hook into pass checkers.") (error-message-string (function (list) string)) (eventp (function (t) boolean)) (exp (function (number) float)) - (expt (function (number number) float)) + (expt (function (number number) number)) (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-locked-p (function (string) (or boolean string))) (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-symlink-p (function (string) (or boolean string))) (file-writable-p (function (string) boolean)) (fixnump (function (t) boolean)) (float (function (number) float)) @@ -410,13 +425,15 @@ Useful to hook into pass checkers.") (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)) + (frame-visible-p (function (frame) (or boolean (member icon)))) + (framep (function (t) symbol)) (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-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))) @@ -461,7 +478,10 @@ Useful to hook into pass checkers.") (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-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)) @@ -479,7 +499,9 @@ Useful to hook into pass checkers.") (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 *)))) + (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)) @@ -505,7 +527,7 @@ Useful to hook into pass checkers.") (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)) + (proper-list-p (function (t) (or fixnum null))) (propertize (function (string &rest t) string)) (radians-to-degrees (function (number) float)) (rassoc (function (t list) list)) @@ -543,7 +565,8 @@ Useful to hook into pass checkers.") (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))) + (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)) @@ -640,11 +663,14 @@ Useful to hook into pass checkers.") (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) "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) @@ -1107,7 +1133,8 @@ with `message'. Otherwise, log with `comp-log-to-buffer'." (log-buffer (or (get-buffer comp-log-buffer-name) (with-current-buffer (get-buffer-create comp-log-buffer-name) - (setf buffer-read-only t) + (unless (derived-mode-p 'compilation-mode) + (emacs-lisp-compilation-mode)) (current-buffer)))) (log-window (get-buffer-window log-buffer)) (inhibit-read-only t) @@ -1241,7 +1268,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,33 +1301,45 @@ clashes." (make-temp-file (comp-c-func-name function-name "freefn-") nil ".eln"))) (let* ((f (symbol-function function-name)) + (byte-code (byte-compile 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)))) + (func + (if (comp-lex-byte-func-p byte-code) + (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)) + (make-comp-func-d :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))))) (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))) + '("can't native compile an already byte-compiled function"))) + (setf (comp-func-byte-func func) byte-code) (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)))) - (setf (comp-ctxt-top-level-forms comp-ctxt) + (if (comp-func-l-p func) + (let ((arg-list (aref (comp-func-byte-func func) 0))) + (setf (comp-func-l-args func) + (comp-decrypt-arg-list arg-list function-name))) + (setf (comp-func-d-lambda-list func) (cadr f))) + (setf (comp-func-lap func) + lap + (comp-func-frame-size func) + (comp-byte-frame-size (comp-func-byte-func func)) + (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)))) @@ -1309,7 +1348,7 @@ clashes." "Byte-compile FORM, spilling data from the byte compiler." (unless (eq (car-safe form) 'lambda) (signal 'native-compiler-error - "Cannot native-compile, form is not a lambda")) + '("Cannot native-compile, form is not a lambda"))) (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) (make-temp-file "comp-lambda-" nil ".eln"))) @@ -1390,7 +1429,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 @@ -1427,11 +1466,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. @@ -1539,7 +1580,7 @@ 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 @@ -1547,6 +1588,8 @@ STACK-OFF is the index of the first slot frame involved." (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) @@ -1711,14 +1754,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." @@ -1761,7 +1805,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. @@ -2535,6 +2579,19 @@ 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)) + (push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag))) + (comp-block-insns (comp-add-cond-cstrs-target-block b bb2))) + (push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag) :neg t)) + (comp-block-insns (comp-add-cond-cstrs-target-block b bb1)))) (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp-call-op-p) ,(and (or (pred comp-equality-fun-p) @@ -2849,7 +2906,7 @@ blocks." (first-processed (l) (if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) 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)) @@ -3190,7 +3247,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." @@ -3749,7 +3810,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)))))))) @@ -4037,7 +4098,8 @@ display a message." :buffer (with-current-buffer (get-buffer-create comp-async-buffer-name) - (setf buffer-read-only t) + (unless (derived-mode-p 'compilation-mode) + (emacs-lisp-compilation-mode)) (current-buffer)) :command (list (expand-file-name invocation-name @@ -4071,6 +4133,8 @@ display a message." (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")))) @@ -4178,6 +4242,7 @@ LOAD and SELECTOR work as described in `native--compile-async'." (string-match-p re file)) native-comp-jit-compilation-deny-list)))) +;;;###autoload (defun native--compile-async (files &optional recursively load selector) ;; BEWARE, this function is also called directly from C. "Compile FILES asynchronously. @@ -4231,8 +4296,9 @@ bytecode definition was not changed in the meantime)." ;; 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=)) + (setf comp-files-queue + (cl-substitute (cons file load) (car entry) comp-files-queue + :key #'car :test #'string=))) (unless (native-compile-async-skip-p file load selector) (let* ((out-filename (comp-el-to-eln-filename file)) @@ -4409,6 +4475,27 @@ of (commands) to run simultaneously." (delete-directory subdir)))))) (message "Cache cleared")) +;;;###autoload +(defun comp-function-type-spec (function) + "Return the type specifier of FUNCTION. + +This function returns a cons cell whose car is the function +specifier, and cdr is a symbol, either `inferred' or `know'. +If the symbol is `inferred', the type specifier is automatically +inferred from the code itself by the native compiler; if it is +`know', the type specifier comes from `comp-known-type-specifiers'." + (let ((kind 'know) + type-spec ) + (when-let ((res (gethash function comp-known-func-cstr-h))) + (setf type-spec (comp-cstr-to-type-spec res))) + (let ((f (symbol-function function))) + (when (and (null type-spec) + (subr-native-elisp-p f)) + (setf kind 'inferred + type-spec (subr-type f)))) + (when type-spec + (cons type-spec kind)))) + (provide 'comp) ;; LocalWords: limplified limplification limplify Limple LIMPLE libgccjit elc eln |