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

[Adam Porter <adam@alphapapa.net>]

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

Adam Porter <adam@alphapapa.net> writes:

> 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.

Seems that I used the wrong command to produce that patch, as it is
missing the normal git headers.  Please see the attached patch instead.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: comp.el: Minor improvements --]
[-- Type: text/x-diff, Size: 15271 bytes --]

From 4c1b5049c64a9abde028577800a4de2692ac3056 Mon Sep 17 00:00:00 2001
From: Adam Porter <adam@alphapapa.net>
Date: Fri, 13 Mar 2020 00:42:49 +0000
Subject: [PATCH] comp.el: Minor improvements

Change: (comp-start-async-worker) Refactor slightly

Change: (comp-start-async-worker) Inline (comp-to-file-p)

Change: (comp-source-files) Rename from comp-src-pool

Add: (comp-start-async-worker) Assertion

Change: (comp-async-processes) Rename from comp-prc-pool

Tidy: (native-compile)

Rename variables, improve docstring, adjust log message, simplify
filename code.

Tidy: (batch-native-compile) Docstring

Tidy: whitespace-cleanup

Tidy: (comp-start-async-worker) Use () instead of nil

Tidy: (comp-files-queue) Rename from comp-source-files

Change: (native-compile-async) Improve paths support

Tidy: Comment

Save a line for one word.  :)

Change: (comp-log) Rewrite without macro, follow tail

Change: (native-compile-async) Use end-of-string in filename regexps

Change: (native-compile-async) Use cl-loop instead of dotimes

Add/Change: (comp-log-to-buffer) And use in comp-log

Comment: Tidy comment

Fix: (configure.ac) Option description

Fix: (comp-log) Argument

Fix: (comp-start-async-worker) Variable name

Change: Undo whitespace changes

Some of them included incorrect indentation because the
macros' (declare (indent)) forms were not loaded.  The
whitespace-cleanup should be run from Emacs 27+ with the file loaded.
---
 configure.ac            |   2 +-
 lisp/emacs-lisp/comp.el | 249 +++++++++++++++++++++++++-----------------------
 2 files changed, 133 insertions(+), 118 deletions(-)

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.")))
-- 
2.7.4