Merge remote-tracking branch 'origin/master' into feature/package+vc

1 files changed, 148 insertions, 87 deletions

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 122638077ce..4354ea03a4e 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
 
@@ -45,7 +45,9 @@
 
 (defcustom native-comp-speed 2
   "Optimization level for native compilation, a number between -1 and 3.
- -1 functions are kept in bytecode form and no native compilation is performed.
+ -1 functions are kept in bytecode form and no native compilation is performed
+    (but *.eln files are still produced, and include the compiled code in
+    bytecode form).
   0 native compilation is performed with no optimizations.
   1 light optimizations.
   2 max optimization level fully adherent to the language semantic.
@@ -63,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")
 
@@ -74,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")
 
@@ -111,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")
 
@@ -238,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
@@ -475,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))
@@ -898,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
@@ -942,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.
@@ -1021,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)
@@ -1243,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))))
@@ -1282,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)
@@ -1327,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)
@@ -1907,10 +1915,7 @@ and the annotation emission."
       (byte-char-syntax auto)
       (byte-buffer-substring auto)
       (byte-delete-region auto)
-      (byte-narrow-to-region
-       (comp-emit-set-call (comp-call 'narrow-to-region
-                                      (comp-slot)
-                                      (comp-slot+1))))
+      (byte-narrow-to-region auto)
       (byte-widen
        (comp-emit-set-call (comp-call 'widen)))
       (byte-end-of-line auto)
@@ -2079,7 +2084,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))))))
@@ -2122,7 +2128,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)))))
@@ -2625,8 +2632,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)
@@ -3474,7 +3481,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
@@ -3685,7 +3692,7 @@ Prepare every function for final compilation and drive the C back-end."
 				 (file-name-base output) "-")
 			 nil ".el")))
 	(with-temp-file temp-file
-          (insert ";; -*-coding: nil; -*-\n")
+          (insert ";; -*-coding: utf-8-emacs-unix; -*-\n")
           (mapc (lambda (e)
                   (insert (prin1-to-string e)))
                 expr))
@@ -3918,22 +3925,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))))
@@ -3986,7 +4007,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.
@@ -4017,48 +4038,60 @@ the deferred compilation mechanism."
            (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.
@@ -4080,6 +4113,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.
 
@@ -4113,16 +4147,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
@@ -4209,7 +4244,7 @@ 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)
@@ -4252,6 +4287,32 @@ 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)
+  (unless (featurep 'native-compile)
+    (user-error "This Emacs isn't built with native-compile support"))
+  (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