Re: Compiling Elisp to a native code with a GCC plugin

[Tom Tromey]

Wojciech> Yes please, I would like to take a look, thanks.

I attached the scripts.  They have a few comments, but probably not
enough, given that they are pretty much one-off hacks.  (Though,
funnily, today I'm going to repurpose one to rewrite gdb...)

The appended patch is needed to get GCC to emit error locations on the
`->' token when the token appears in the arguments to a macro.

Wojciech> I am just not sure how efficiently and reliably branches work
Wojciech> in bzr (I've managed to screw up some of my work once with
Wojciech> bzr), and I am not sure how reliable are git mirrors. I quite
Wojciech> like git, however there is a cost of troubles with integration
Wojciech> with bzr. On other hand I find forking <-> merging
Wojciech> unacceptable. I will try to mock something up, in the
Wojciech> meantime.

Yeah, bzr is a pain compared to git.  But, we're stuck with it.

Wojciech> BTW: If somebody would like to enlighten me on how reliably
Wojciech> mirrored git works with the Emacs source tree, I would be
Wojciech> grateful. Thanks.

I think the mirror is updated regularly.  I'm not using it myself, but I
gather it works ok.

Tom

Index: macro.c
===================================================================
--- macro.c     (revision 164202)
+++ macro.c     (working copy)
@@ -1350,7 +1350,7 @@
 
   pfile->set_invocation_location = true;
   result = cpp_get_token (pfile);
-  if (pfile->context->macro)
+  if (pfile->context->macro && pfile->invocation_location > result->src_loc)
     *loc = pfile->invocation_location;
   else
     *loc = result->src_loc;

;; Rewrite all references to buffer-objfwd fields in struct buffer
;; to use accessor macros.
;; This works in a tricky way: it renames all such fields, then
;; recompiles Emacs.  Then it visits each error location and
;; rewrites the expressions.
;; This has a few requirements in order to work.
;; First, Emacs must compile before the script is run.
;; It does not handle errors arising for other reasons.
;; Second, you need a GCC which has been hacked to emit proper
;; column location even when the -> expression in question has
;; been wrapped in a macro call.  (This is a one-liner in libcpp.)
;; After running this script, a few changes need to be made by hand.
;; These occur mostly in macros in headers, but also in
;; reset_buffer and reset_buffer_local_variables.  Finally,
;; DEFVAR_PER_BUFFER and the GC should not use these accessors.

(defvar gcc-prefix "/home/tromey/gnu/Trunk/install/")

(defvar emacs-src "/home/tromey/gnu/Emacs/Gitorious/emacs-mt/src/")
(defvar emacs-build "/home/tromey/gnu/Emacs/Gitorious/build/src/")

(defun file-error (text)
  (error "%s:%d:%d: error: expected %s"
         buffer-file-name (line-number-at-pos (point))
         (current-column)
         text))

(defun assert-looking-at (exp)
  (unless (looking-at exp)
    (file-error exp)))

(defvar field-names nil)

(defvar field-regexp nil)

(defun modify-buffer.h ()
  (message "Modifying fields in struct buffer")
  (find-file (expand-file-name "buffer.h" emacs-src))
  (goto-char (point-min))
  (re-search-forward "^struct buffer$")
  (forward-line)
  (assert-looking-at "^{")
  (let ((starting-point (point))
        (closing-brace (save-excursion
                         (forward-sexp)
                         (point))))
    ;; Find each field.
    (while (re-search-forward "^\\s *Lisp_Object\\s +"
                              closing-brace 'move)
      (goto-char (match-end 0))
      (while (not (looking-at ";"))
        (assert-looking-at "\\([A-Za-z0-9_]+\\)\\(;\\|,\\s *\\)")
        ;; Remember the name so we can generate accessors.
        (push (match-string 1) field-names)
        ;; Rename it.
        (goto-char (match-beginning 2))
        (insert "_")
        ;; On to the next one, if any.
        (if (looking-at ",\\s *")
            (goto-char (match-end 0)))))
    ;; Generate accessors.
    (goto-char starting-point)
    (forward-sexp)
    (forward-line)
    (insert "\n")
    (dolist (name field-names)
      (insert "#define BUF_" (upcase name) "(BUF) "
              "*find_variable_location (&((BUF)->"
              name "_))\n"))
    (insert "\n"))
  (setq field-regexp (concat "\\(->\\|\\.\\)"
                             (regexp-opt field-names t)
                             "\\_>"))
  (save-buffer))

(defun get-field-name ()
  (save-excursion
    (assert-looking-at "\\(\\.\\|->\\)\\([A-Za-z0-9_]+\\)\\_>")
    (prog1
        (match-string 2)
      (delete-region (match-beginning 0) (match-end 0)))))

(defun skip-backward-lhs ()
  (skip-chars-backward " \t\n")
  (cond
   ((eq (char-before) ?\])
    (file-error "array ref!")
    ;; fixme
    )
   ((eq (char-before) ?\))
    ;; A paren expression is preceding.
    ;; See if this is just a paren expression or whether it is a
    ;; function call.
    ;; For now assume that there are no function-calls-via-expr.
    (backward-sexp)
    (skip-chars-backward " \t\n")
    (if (save-excursion
          (backward-char)
          (looking-at "[A-Za-z0-9_]"))
        (backward-sexp)))
   ((save-excursion
      (backward-char)
      (looking-at "[A-Za-z0-9_]"))
    (backward-sexp))
   (t
    (file-error "unhandled case!"))))

(defun do-fix-instance ()
  (cond
   ((looking-at "->")
    (let ((field-name (get-field-name)))
      (insert ")")
      (backward-char)
      (skip-backward-lhs)
      (insert "BUF_" (upcase field-name) " (")))
   ((eq (char-after) ?.)
    (let ((field-name (get-field-name)))
      (insert ")")
      (backward-char)
      (backward-sexp)
      (assert-looking-at "\\(buffer_defaults\\|buffer_local_flags\\)")
      (insert "BUF_" (upcase field-name) " (&")))
   (t
    (message "%s:%d:%d: warning: did not see -> or ., probably macro"
             buffer-file-name (line-number-at-pos (point))
             (current-column)))))

(defun update-header-files ()
  (dolist (file (directory-files emacs-src t "h$"))
    (message "Applying header changes to %s" file)
    (find-file file)
    (while (re-search-forward
            "\\(current_buffer->\\|buffer_defaults\\.\\)"
            nil 'move)
      (goto-char (match-end 0))
      (skip-chars-backward "->.")
      (when (looking-at field-regexp)
        (do-fix-instance)))
    (goto-char (point-min))
    (while (search-forward "XBUFFER (" nil 'move)
      (goto-char (- (match-end 0) 1))
      (forward-sexp)
      ;; This works even for the new #define BUF_ macros
      ;; because the field-regexp ends with \_>.
      (when (looking-at field-regexp)
        (do-fix-instance)))
    (save-buffer)))

(defun fix-one-instance (filename line column)
  (message "%s:%d:%d: info: fixing instance" filename line column)
  (find-file filename)
  (goto-char (point-min))
  (forward-line (- line 1))
  ;; (move-to-column (- column 1))
  (forward-char (- column 1))
  (do-fix-instance))

(defvar make-accumulation "")

(defvar last-error-line nil)
(defvar error-list nil)

(defun make-filter (process string)
  (setq make-accumulation (concat make-accumulation string))
  (while (string-match "^[^\n]*\n" make-accumulation)
    (let ((line (substring (match-string 0 make-accumulation) 0 -1)))
      (setq make-accumulation (substring make-accumulation
                                         (match-end 0)))
      (message "%s" line)
      (if (string-match "^\\([^:]+\\):\\([0-9]+\\):\\([0-9]+\\)+: error:"
                        line)
          (save-excursion
            (let ((file-name (match-string 1 line))
                  (line-no (string-to-number (match-string 2 line)))
                  (col-no (string-to-number (match-string 3 line))))
              ;; Process all errors on a given line in reverse order.
              (unless (eq line-no last-error-line)
                (dolist (one-item error-list)
                  (apply #'fix-one-instance one-item))
                (setq error-list nil)
                (setq last-error-line line-no))
              (push (list file-name line-no col-no) error-list)))))))

(defvar make-done nil)

(defun make-sentinel (process string)
  (dolist (one-item error-list)
    (apply #'fix-one-instance one-item))
  (setq make-done t))

(defun recompile-emacs ()
  (let* ((default-directory emacs-build)
         (output-buffer (get-buffer-create "*recompile*"))
         (make (start-process "make" output-buffer "make" "-k")))
    (set-process-filter make #'make-filter)
    (set-process-sentinel make #'make-sentinel)
    (while (not make-done)
      (accept-process-output))))

(modify-buffer.h)
(update-header-files)
(recompile-emacs)
(dolist (buf (buffer-list))
  (with-current-buffer buf
    (when buffer-file-name
      (message "Saving %s" buffer-file-name)
      (save-buffer))))

;; Rewrite DEFVAR_LISP variables.
;; Each variable is renamed to start with impl_.
;; Compatibility defines are added to globals.h.
;; Invoke as:  emacs --script rewrite-globals.el

(defvar defvar-list '())

(defun extract-defvars ()
  (let ((case-fold-search nil))
    (while (re-search-forward "^[^#*]*\\(DEFVAR_[A-Z_]*\\)" nil 'move)
      (let ((kind (match-string 1)))
        (unless (member kind '("DEFVAR_KBOARD" "DEFVAR_PER_BUFFER"))
          ;; Skip the paren and the first argument.
          (skip-chars-forward " (")
          (forward-sexp)
          (skip-chars-forward ", \t\n&")
          (if (looking-at "\\_<\\(\\sw\\|\\s_\\)+\\_>")
              (let ((var-name (match-string 0)))
                  (if (equal kind "DEFVAR_LISP")
                      (push var-name defvar-list)))))))))

(defun munge-V ()
  (interactive)
  (while (re-search-forward "^\\(extern \\|static \\)?Lisp_Object " nil 'move)
    ;; skip function decls.
    (if (not (looking-at ".*("))
        (while (looking-at "[a-z0-9A-Z_]+")
          (if (member (match-string 0) defvar-list)
              (progn
                ;; Rename them all to impl_
                (goto-char (match-beginning 0))
                (insert "impl_")))
          (forward-sexp)
          (skip-chars-forward ", \t\n")))))

(defconst V-dir ".")

(defun munge-V-directory ()
  ;; First extract all defvars.
  (dolist (file (directory-files V-dir t "[ch]$"))
    (save-excursion
      (message "Scanning %s" file)
      (find-file file)
      (extract-defvars)))

  (setq defvar-list (delete-dups (sort defvar-list #'string<)))

  (dolist (file (directory-files V-dir t "[ch]$"))
    (save-excursion
      (message "Processing %s" file)
      (find-file file)
      (goto-char (point-min))
      (munge-V)
      (save-buffer)))

  (find-file "globals.h")
  (erase-buffer)
  (dolist (v defvar-list)
    (insert "#define " v " *find_variable_location (&impl_" v ")\n"))

  ;; A few special cases for globals.h.
  (insert "\n")
  (dolist (v '("do_mouse_tracking" "Vmark_even_if_inactive" "Vprint_level"))
    (insert "extern Lisp_Object impl_" v ";\n"))
  (save-buffer))

(munge-V-directory)