[feature/native-comp][PATCH] Minor improvements

[Adam Porter <adam@alphapapa.net>]

[-- Attachment #1: Type: text/plain, Size: 389 bytes --]

Hi,

This patch makes some minor improvements to the feature/native-comp
branch, including renaming a few symbols, improving the usability of
some commands, improving some docstrings, and a few minor refactorings.
None of the compilation code is touched, only the UI and logging.
Andrea has approved this patch, and it's presented here for further
discussion before merging.

Thanks,
Adam

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Minor improvements to feature/native-comp branch --]
[-- Type: text/x-diff, Size: 13652 bytes --]

diff --git a/configure.ac b/configure.ac
index 0b2f5b6..393a53d 100644
--- a/configure.ac
+++ b/configure.ac
@@ -463,7 +463,7 @@ AC_DEFUN
 OPTION_DEFAULT_ON([zlib],[don't compile with zlib decompression support])
 OPTION_DEFAULT_ON([modules],[don't compile with dynamic modules support])
 OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support])
-OPTION_DEFAULT_OFF([nativecomp],[don't compile with emacs lisp native compiler support])
+OPTION_DEFAULT_OFF([nativecomp],[compile with Emacs Lisp native compiler support])
 
 AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB],
  [use a file notification library (LIB one of: yes, inotify, kqueue, gfile, w32, no)])],
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 0779373..2ce530e 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -356,34 +356,44 @@ comp-add-const-to-relocs
   (puthash obj t (comp-data-container-idx (comp-alloc-class-to-container
                                            comp-curr-allocation-class))))
 
-(defmacro comp-within-log-buff (&rest body)
-  "Execute BODY while at the end the log-buffer.
-BODY is evaluate only if `comp-verbose' is > 0."
-  (declare (debug (form body))
-           (indent defun))
-  `(when (> comp-verbose 0)
-     (with-current-buffer (get-buffer-create comp-log-buffer-name)
-       (setf buffer-read-only t)
-       (let ((inhibit-read-only t))
-         (goto-char (point-max))
-         ,@body))))
-
-(defun comp-log (data verbosity)
-  "Log DATA given VERBOSITY."
-  (when (>= comp-verbose verbosity)
+(cl-defun comp-log (data &optional (level 1))
+  "Log DATA at LEVEL.
+LEVEL is a number from 1-3; if it is less than `comp-verbose', do
+nothing.  If `noninteractive', log with `message'.  Otherwise,
+log with `comp-log-to-buffer'."
+  (when (>= comp-verbose level)
     (if noninteractive
-        (if (atom data)
-            (message "%s" data)
-	  (mapc (lambda (x)
-                  (message "%s"(prin1-to-string x)))
-                data))
-      (comp-within-log-buff
-        (if (and data (atom data))
-            (insert data)
-          (mapc (lambda (x)
-                  (insert (prin1-to-string x) "\n"))
-                data)
-          (insert "\n"))))))
+        (cl-typecase data
+          (atom (message "%s" data))
+          (t (dolist (elem data)
+               (message "%s" elem))))
+      (comp-log-to-buffer data))))
+
+(cl-defun comp-log-to-buffer (data)
+  "Log DATA to `comp-log-buffer-name'."
+  (let* ((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
+      (when (= (point) (point-max))
+        (setf at-end-p t))
+      (save-excursion
+        (goto-char (point-max))
+        (cl-typecase data
+          (atom (princ data log-buffer))
+          (t (dolist (elem data)
+               (princ 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-log-func (func verbosity)
   "Log function FUNC.
@@ -2052,105 +2062,108 @@ comp-hint-cons
 \f
 ;; Some entry point support code.
 
-(defvar comp-src-pool ()
-  "List containing the files to be compiled.")
-
-(defvar comp-prc-pool ()
-  "List containing all async compilation processes.")
-
-(defun comp-to-file-p (file)
-  "Return t if FILE has to be compiled."
-  (let ((compiled-f (concat file "n")))
-    (or comp-always-compile
-        (not (and (file-exists-p compiled-f)
-                  (file-newer-than-file-p compiled-f file))))))
-
-(cl-defun comp-start-async-worker ()
-  "Run an async compile worker."
-  (let (f)
-    (while (setf f (pop comp-src-pool))
-      (when (comp-to-file-p f)
-        (let* ((code `(progn
-                        (require 'comp)
-                        (setf comp-speed ,comp-speed
-                              comp-debug ,comp-debug
-                              comp-verbose ,comp-verbose
-                              load-path ',load-path)
-                        (message "Compiling %s started." ,f)
-                        (native-compile ,f))))
-          (push (make-process :name (concat "Compiling: " f)
-                              :buffer (get-buffer-create comp-async-buffer-name)
-                              :command (list (concat invocation-directory
-                                                     invocation-name)
-                                             "--batch"
-                                             "--eval"
-                                             (prin1-to-string code))
-                              :sentinel (lambda (prc _event)
-                                          (run-hook-with-args
-                                           'comp-async-cu-done-hook
-                                           f)
-                                          (accept-process-output prc)
-                                          (comp-start-async-worker)))
-                comp-prc-pool)
-          (cl-return-from comp-start-async-worker))))
-    (when (cl-notany #'process-live-p comp-prc-pool)
+(defvar comp-files-queue ()
+  "List of Elisp files to be compiled.")
+
+(defvar comp-async-processes ()
+  "List of running async compilation processes.")
+
+(defun comp-start-async-worker ()
+  "Start compiling files from `comp-files-queue' asynchronously.
+When compilation is finished, run `comp-async-all-done-hook' and
+display a message."
+  (if comp-files-queue
+      (cl-loop
+       for source-file = (pop comp-files-queue)
+       while source-file
+       do (cl-assert (string-match-p (rx ".el" eos) source-file) nil
+                     "`comp-files-queue' should be \".el\" files: %s"
+                     source-file)
+       when (or comp-always-compile
+                (file-newer-than-file-p source-file (concat source-file "n")))
+       do (let* ((expr `(progn
+                          (require 'comp)
+                          (setf comp-speed ,comp-speed
+                                comp-debug ,comp-debug
+                                comp-verbose ,comp-verbose
+                                load-path ',load-path)
+                          (message "Compiling %s..." ,source-file)
+                          (native-compile ,source-file)))
+                 (process (make-process
+                           :name (concat "Compiling: " source-file)
+                           :buffer (get-buffer-create comp-async-buffer-name)
+                           :command (list
+                                     (expand-file-name invocation-name
+                                                       invocation-directory)
+                                     "--batch" "--eval" (prin1-to-string expr))
+                           :sentinel (lambda (process _event)
+                                       (run-hook-with-args
+                                        'comp-async-cu-done-hook
+                                        source-file)
+                                       (accept-process-output process)
+                                       (comp-start-async-worker)))))
+            (push process comp-async-processes)))
+    ;; No files left to compile.
+    (when (cl-notany #'process-live-p comp-async-processes)
       (let ((msg "Compilation finished."))
-        (setf comp-prc-pool ())
+        (setf comp-async-processes ())
         (run-hooks 'comp-async-all-done-hook)
         (with-current-buffer (get-buffer-create comp-async-buffer-name)
           (save-excursion
             (goto-char (point-max))
             (insert msg "\n")))
         (message msg)))))
+
 \f
 ;;; Compiler entry points.
 
 ;;;###autoload
-(defun native-compile (input)
-  "Compile INPUT into native code.
+(defun native-compile (function-or-file)
+  "Compile FUNCTION-OR-FILE into native code.
 This is the entry-point for the Emacs Lisp native compiler.
-If INPUT is a symbol, native compile its function definition.
-If INPUT is a string, use it as the file path to be native compiled.
+FUNCTION-OR-FILE is a function symbol or a path to an Elisp file.
 Return the compilation unit file name."
-  (unless (or (symbolp input)
-              (stringp input))
+  (unless (or (functionp function-or-file)
+              (stringp function-or-file))
     (signal 'native-compiler-error
-          (list "not a symbol function or file" input)))
-  (let ((data input)
-        (comp-native-compiling t)
-        ;; Have the byte compiler signal an error when compilation
-        ;; fails.
-        (byte-compile-debug t)
-        (comp-ctxt (make-comp-ctxt
-                    :output
-                    (if (symbolp input)
-                        (make-temp-file (concat (symbol-name input) "-"))
-                      (let ((exp-file (expand-file-name input)))
-                        (cl-assert comp-native-path-postfix)
-                        (concat
-                         (file-name-as-directory
-                          (concat
-                           (file-name-directory exp-file)
-                           comp-native-path-postfix))
-                         (file-name-sans-extension
-                          (file-name-nondirectory exp-file))))))))
+            (list "Not a function symbol or file" function-or-file)))
+  (let* ((data function-or-file)
+         (comp-native-compiling t)
+         ;; Have byte compiler signal an error when compilation fails.
+         (byte-compile-debug t)
+         (comp-ctxt
+          (make-comp-ctxt
+           :output
+           (if (symbolp function-or-file)
+               (make-temp-file (concat (symbol-name function-or-file) "-"))
+             (let* ((expanded-filename (expand-file-name function-or-file))
+                    (output-dir (file-name-as-directory
+                                 (concat (file-name-directory expanded-filename)
+                                         comp-native-path-postfix)))
+                    (output-filename
+                     (file-name-sans-extension
+                      (file-name-nondirectory expanded-filename))))
+               (expand-file-name output-filename output-dir))))))
     (comp-log "\n\f\n" 1)
     (condition-case err
         (mapc (lambda (pass)
-                (comp-log (format "Running pass %s:\n" pass) 2)
+                (comp-log (format "(%s) Running pass %s:\n"
+                                  function-or-file pass)
+                          2)
                 (setf data (funcall pass data)))
               comp-passes)
       (native-compiler-error
        ;; Add source input.
        (let ((err-val (cdr err)))
-         (signal (car err) (if (consp err-val)
-                               (cons input err-val)
-                             (list input err-val))))))
+	 (signal (car err) (if (consp err-val)
+			       (cons function-or-file err-val)
+			     (list function-or-file err-val))))))
     data))
 
 ;;;###autoload
 (defun batch-native-compile ()
-  "Ultra cheap impersonation of `batch-byte-compile'."
+  "Run `native-compile' on remaining command-line arguments.
+Ultra cheap impersonation of `batch-byte-compile'."
   (mapc #'native-compile command-line-args-left))
 
 ;;;###autoload
@@ -2169,23 +2182,25 @@ batch-byte-native-compile-for-bootstrap
          (rename-file tempfile target-file t))))))
 
 ;;;###autoload
-(defun native-compile-async (input &optional jobs recursively)
-  "Compile INPUT asynchronously.
-INPUT can be either a list of files a folder or a file.
-JOBS specifies the number of jobs (commands) to run simultaneously (1 default).
-Follow folders RECURSIVELY if non nil."
-  (let ((jobs (or jobs 1))
-        (files (if (listp input)
-                   input
-                 (if (file-directory-p input)
-                     (if recursively
-                         (directory-files-recursively input "\\.el$")
-                       (directory-files input t "\\.el$"))
-                   (if (file-exists-p input)
-                       (list input)
-                     (signal 'native-compiler-error
-                             "input not a file nor directory"))))))
-    (setf comp-src-pool (nconc files comp-src-pool))
+(cl-defun native-compile-async (paths &optional (jobs 1) recursively)
+  "Compile PATHS asynchronously.
+PATHS is one path or a list of paths to files or directories.
+JOBS specifies the number of jobs (commands) to run
+simultaneously (1 default).  If RECURSIVELY, recurse into
+subdirectories of given directories."
+  (unless (listp paths)
+    (setf paths (list paths)))
+  (let (files)
+    (dolist (path paths)
+      (cond ((file-directory-p path)
+             (dolist (file (if recursively
+                               (directory-files-recursively path (rx ".el" eos))
+                             (directory-files path t (rx ".el" eos))))
+               (push file files)))
+            ((file-exists-p path) (push path files))
+            (t (signal 'native-compiler-error
+                       (list "Path not a file nor directory" path)))))
+    (setf comp-files-queue (nconc files comp-files-queue))
     (cl-loop repeat jobs
              do (comp-start-async-worker))
     (message "Compilation started.")))