diff options
Diffstat (limited to 'lisp/emacs-lisp/comp.el')
| -rw-r--r-- | lisp/emacs-lisp/comp.el | 271 |
1 files changed, 166 insertions, 105 deletions
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 374b39e9990..9a635a47763 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2019-2022 Free Software Foundation, Inc. -;; Author: Andrea Corallo <akrl@sdf.com> +;; Author: Andrea Corallo <akrl@sdf.org> ;; Keywords: lisp ;; Package: emacs @@ -65,7 +65,7 @@ This is intended for debugging the compiler itself. 2 emit debug symbols and dump pseudo C code. 3 emit debug symbols and dump: pseudo C code, GCC intermediate passes and libgccjit log file." - :type 'integer + :type 'natnum :safe #'natnump :version "28.1") @@ -76,7 +76,7 @@ This is intended for debugging the compiler itself. 1 final LIMPLE is logged. 2 LAP, final LIMPLE, and some pass info are logged. 3 max verbosity." - :type 'integer + :type 'natnum :risky t :version "28.1") @@ -113,7 +113,7 @@ during bootstrap." "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 'integer + :type 'natnum :risky t :version "28.1") @@ -240,7 +240,7 @@ native compilation runs.") (defvar comp-curr-allocation-class 'd-default "Current allocation class. -Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") +Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") (defconst comp-passes '(comp-spill-lap comp-limplify @@ -477,15 +477,15 @@ Useful to hook into pass checkers.") (one-window-p (function (&optional t t) boolean)) (overlayp (function (t) boolean)) (parse-colon-path (function (string) cons)) - (plist-get (function (list t) t)) - (plist-member (function (list t) list)) + (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) string)) + (prin1-to-string (function (t &optional t t) string)) (processp (function (t) boolean)) (proper-list-p (function (t) integer)) (propertize (function (string &rest t) string)) @@ -900,6 +900,8 @@ non local exit (ends with an `unreachable' insn).")) :documentation "Doc string.") (int-spec nil :type list :documentation "Interactive form.") + (command-modes nil :type list + :documentation "Command modes.") (lap () :type list :documentation "LAP assembly representation.") (ssa-status nil :type symbol @@ -944,7 +946,7 @@ CFG is mutated by a pass.") :documentation "Unique id when in SSA form.") (slot nil :type (or fixnum symbol) :documentation "Slot number in the array if a number or - 'scratch' for scratch slot.")) + `scratch' for scratch slot.")) (defun comp-mvar-type-hint-match-p (mvar type-hint) "Match MVAR against TYPE-HINT. @@ -1023,7 +1025,7 @@ To be used by all entry points." (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." +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) @@ -1245,6 +1247,7 @@ clashes." :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)))) @@ -1284,10 +1287,12 @@ clashes." (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) @@ -1329,6 +1334,7 @@ clashes." (comp-func-byte-func func) byte-func (comp-func-doc func) (documentation byte-func t) (comp-func-int-spec func) (interactive-form byte-func) + (comp-func-command-modes func) (command-modes byte-func) (comp-func-c-name func) c-name (comp-func-lap func) lap (comp-func-frame-size func) (comp-byte-frame-size byte-func) @@ -1769,6 +1775,7 @@ This is responsible for generating the proper stack adjustment, when known, and the annotation emission." (declare (debug (body)) (indent defun)) + (declare-function comp-body-eff nil (body op-name sp-delta)) `(pcase op ,@(cl-loop for (op . body) in cases for sp-delta = (gethash op comp-op-stack-info) @@ -1947,7 +1954,6 @@ and the annotation emission." (byte-condition-case) ;; Obsolete (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) - (byte-unbind-all) ;; Obsolete (byte-set-marker auto) (byte-match-beginning auto) (byte-match-end auto) @@ -2081,7 +2087,8 @@ and the annotation emission." (i (hash-table-count h))) (puthash i (comp-func-doc f) h) i) - (comp-func-int-spec f))) + (comp-func-int-spec f) + (comp-func-command-modes f))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0)))))) @@ -2124,7 +2131,8 @@ These are stored in the reloc data array." (i (hash-table-count h))) (puthash i (comp-func-doc func) h) i) - (comp-func-int-spec func))) + (comp-func-int-spec func) + (comp-func-command-modes func))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0))))) @@ -2627,8 +2635,8 @@ TARGET-BB-SYM is the symbol name of the target block." do (comp-emit-call-cstr target insn-cell cstr))))))) (defun comp-add-cstrs (_) - "Rewrite conditional branches adding appropriate 'assume' insns. -This is introducing and placing 'assume' insns in use by fwprop + "Rewrite conditional branches adding appropriate `assume' insns. +This is introducing and placing `assume' insns in use by fwprop to propagate conditional branch test information on target basic blocks." (maphash (lambda (_ f) @@ -3090,13 +3098,6 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or (`(setimm ,lval ,v) (setf (comp-cstr-imm lval) v)))))) -(defun comp-mvar-propagate (lval rval) - "Propagate into LVAL properties of RVAL." - (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval) - (comp-mvar-valset lval) (comp-mvar-valset rval) - (comp-mvar-range lval) (comp-mvar-range rval) - (comp-mvar-neg lval) (comp-mvar-neg rval))) - (defun comp-function-foldable-p (f args) "Given function F called with ARGS, return non-nil when optimizable." (and (comp-function-pure-p f) @@ -3146,10 +3147,7 @@ Fold the call in case." (when (comp-cstr-empty-p cstr) ;; Store it to be rewritten as non local exit. (setf (comp-block-lap-non-ret-insn comp-block) insn)) - (setf (comp-mvar-range lval) (comp-cstr-range cstr) - (comp-mvar-valset lval) (comp-cstr-valset cstr) - (comp-mvar-typeset lval) (comp-cstr-typeset cstr) - (comp-mvar-neg lval) (comp-cstr-neg cstr)))) + (comp-cstr-shallow-copy lval cstr))) (cl-case f (+ (comp-cstr-add lval args)) (- (comp-cstr-sub lval args)) @@ -3167,9 +3165,9 @@ Fold the call in case." (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) (comp-fwprop-call insn lval f args))) (_ - (comp-mvar-propagate lval rval)))) + (comp-cstr-shallow-copy lval rval)))) (`(assume ,lval ,(and (pred comp-mvar-p) rval)) - (comp-mvar-propagate lval rval)) + (comp-cstr-shallow-copy lval rval)) (`(assume ,lval (,kind . ,operands)) (cl-case kind (and @@ -3486,7 +3484,7 @@ Return the list of m-var ids nuked." (defun comp-remove-type-hints-func () "Remove type hints from the current function. -These are substituted with a normal 'set' op." +These are substituted with a normal `set' op." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (comp-loop-insn-in-block b @@ -3582,7 +3580,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)) + (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)) @@ -3930,22 +3928,36 @@ display a message." (file-newer-than-file-p source-file (comp-el-to-eln-filename source-file))) do (let* ((expr `((require 'comp) - ,(when (boundp 'backtrace-line-length) - `(setf backtrace-line-length ,backtrace-line-length)) - (setf comp-file-preloaded-p ,comp-file-preloaded-p - native-compile-target-directory ,native-compile-target-directory - native-comp-speed ,native-comp-speed - native-comp-debug ,native-comp-debug - native-comp-verbose ,native-comp-verbose - comp-libgccjit-reproducer ,comp-libgccjit-reproducer - comp-async-compilation t - native-comp-eln-load-path ',native-comp-eln-load-path - native-comp-compiler-options - ',native-comp-compiler-options - native-comp-driver-options - ',native-comp-driver-options - load-path ',load-path - warning-fill-column most-positive-fixnum) + (setq comp-async-compilation t) + (setq 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 + ;; 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)))) @@ -3998,7 +4010,7 @@ display a message." (run-hooks 'native-comp-async-all-done-hook) (with-current-buffer (get-buffer-create comp-async-buffer-name) (save-excursion - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (goto-char (point-max)) (insert "Compilation finished.\n")))) ;; `comp-deferred-pending-h' should be empty at this stage. @@ -4018,56 +4030,71 @@ the deferred compilation mechanism." (signal 'native-compiler-error (list "Not a function symbol or file" function-or-file))) (catch 'no-native-compile - (let* ((data function-or-file) + (let* ((print-symbols-bare t) + (max-specpdl-size (max max-specpdl-size 5000)) + (data function-or-file) (comp-native-compiling t) (byte-native-qualities nil) + (symbols-with-pos-enabled t) ;; Have byte compiler signal an error when compilation fails. (byte-compile-debug t) (comp-ctxt (make-comp-ctxt :output output :with-late-load with-late-load))) (comp-log "\n \n" 1) - (condition-case 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" - function-or-file pass) - 2) - (setf data (funcall pass data)) - (push (cons pass (float-time (time-since t0))) report) - (cl-loop for f in (alist-get pass comp-post-pass-hooks) - do (funcall f data)) - finally - (when comp-log-time-report - (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)))) - (native-compiler-skip) - (t - (let ((err-val (cdr err))) - ;; If we are doing an async native compilation print the - ;; error in the correct format so is parsable and abort. - (if (and comp-async-compilation - (not (eq (car err) 'native-compiler-error))) - (progn - (message (if err-val - "%s: Error: %s %s" - "%s: Error %s") - function-or-file - (get (car err) 'error-message) - (car-safe err-val)) - (kill-emacs -1)) - ;; Otherwise re-signal it adding the compilation input. - (signal (car err) (if (consp err-val) - (cons function-or-file err-val) - (list function-or-file err-val))))))) - (if (stringp function-or-file) - data - ;; So we return the compiled function. - (native-elisp-load data))))) + (unwind-protect + (progn + (condition-case 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" + function-or-file pass) + 2) + (setf data (funcall pass data)) + (push (cons pass (float-time (time-since t0))) report) + (cl-loop for f in (alist-get pass comp-post-pass-hooks) + do (funcall f data)) + finally + (when comp-log-time-report + (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)))) + (native-compiler-skip) + (t + (let ((err-val (cdr err))) + ;; If we are doing an async native compilation print the + ;; error in the correct format so is parsable and abort. + (if (and comp-async-compilation + (not (eq (car err) 'native-compiler-error))) + (progn + (message (if err-val + "%s: Error: %s %s" + "%s: Error %s") + function-or-file + (get (car err) 'error-message) + (car-safe err-val)) + (kill-emacs -1)) + ;; Otherwise re-signal it adding the compilation input. + (signal (car err) (if (consp err-val) + (cons function-or-file err-val) + (list function-or-file err-val))))))) + (if (stringp function-or-file) + data + ;; So we return the compiled function. + (native-elisp-load data))) + ;; We may have created a temporary file when we're being + ;; called with something other than a file as the argument. + ;; Delete it. + (when (and (not (stringp function-or-file)) + (not output) + comp-ctxt + (comp-ctxt-output comp-ctxt) + (file-exists-p (comp-ctxt-output comp-ctxt))) + (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. @@ -4089,6 +4116,7 @@ LOAD and SELECTOR work as described in `native--compile-async'." native-comp-deferred-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. @@ -4122,16 +4150,17 @@ bytecode definition was not changed in the meantime)." (unless (listp files) (setf files (list files))) (let (file-list) - (dolist (path files) - (cond ((file-directory-p path) + (dolist (file-or-dir files) + (cond ((file-directory-p file-or-dir) (dolist (file (if recursively (directory-files-recursively - path comp-valid-source-re) - (directory-files path t comp-valid-source-re))) + file-or-dir comp-valid-source-re) + (directory-files file-or-dir + t comp-valid-source-re))) (push file file-list))) - ((file-exists-p path) (push path file-list)) + ((file-exists-p file-or-dir) (push file-or-dir file-list)) (t (signal 'native-compiler-error - (list "Path not a file nor directory" path))))) + (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 @@ -4207,9 +4236,9 @@ last directory in `native-comp-eln-load-path')." if (or (null byte+native-compile) (cl-notany (lambda (re) (string-match re file)) native-comp-bootstrap-deny-list)) - do (comp--native-compile file) + collect (comp--native-compile file) else - do (byte-compile-file file)))) + collect (byte-compile-file file)))) ;;;###autoload (defun batch-byte+native-compile () @@ -4218,17 +4247,25 @@ Generate .elc files in addition to the .eln files. Force the produced .eln to be outputted in the eln system directory (the last entry in `native-comp-eln-load-path') unless `native-compile-target-directory' is non-nil. If the environment -variable 'NATIVE_DISABLED' is set, only byte compile." +variable \"NATIVE_DISABLED\" is set, only byte compile." (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) (cl-assert (length= command-line-args-left 1)) - (let ((byte+native-compile t) - (byte-to-native-output-file nil)) - (batch-native-compile) - (pcase byte-to-native-output-file - (`(,tempfile . ,target-file) - (rename-file tempfile target-file t)))))) + (let* ((byte+native-compile t) + (byte-to-native-output-buffer-file nil) + (eln-file (car (batch-native-compile)))) + (pcase byte-to-native-output-buffer-file + (`(,temp-buffer . ,target-file) + (unwind-protect + (progn + (byte-write-target-file temp-buffer target-file) + ;; Touch the .eln in order to have it older than the + ;; corresponding .elc. + (when (stringp eln-file) + (set-file-times eln-file))) + (kill-buffer temp-buffer)))) + (setq command-line-args-left (cdr command-line-args-left))))) ;;;###autoload (defun native-compile-async (files &optional recursively load selector) @@ -4253,6 +4290,30 @@ of (commands) to run simultaneously." (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) + (dolist (dir native-comp-eln-load-path) + ;; If a directory is non absolute it is assumed to be relative to + ;; `invocation-directory'. + (setq dir (expand-file-name dir invocation-directory)) + (when (file-exists-p dir) + (dolist (subdir (directory-files dir t)) + (when (and (file-directory-p subdir) + (file-writable-p subdir) + (not (equal (file-name-nondirectory + (directory-file-name subdir)) + comp-native-version-dir))) + (message "Deleting %s..." subdir) + ;; We're being overly cautious here -- there shouldn't be + ;; anything but .eln files in these directories. + (dolist (eln (directory-files subdir t "\\.eln\\(\\.tmp\\)?\\'")) + (when (file-writable-p eln) + (delete-file eln))) + (when (directory-empty-p subdir) + (delete-directory subdir)))))) + (message "Cache cleared")) + (provide 'comp) ;; LocalWords: limplified limplified limplification limplify Limple LIMPLE libgccjit elc eln |